diff --git a/src/Compiler/RLPC.hs b/src/Compiler/RLPC.hs index f7ed654..54719a9 100644 --- a/src/Compiler/RLPC.hs +++ b/src/Compiler/RLPC.hs @@ -187,9 +187,9 @@ prettyRlpcMsg m = render $ docRlpcErr m prettyRlpcDebugMsg :: MsgEnvelope RlpcError -> String prettyRlpcDebugMsg msg = - T.unpack . foldMap mkLine $ ts + T.unpack . foldMap mkLine $ [ t' | t <- ts, t' <- T.lines t ] where - mkLine s = tag <> ": " <> s <> "\n" + mkLine s = "-d" <> tag <> ": " <> s <> "\n" Text ts = msg ^. msgDiagnostic SevDebug tag = msg ^. msgSeverity diff --git a/src/GM.hs b/src/GM.hs index 065cb08..216672d 100644 --- a/src/GM.hs +++ b/src/GM.hs @@ -8,6 +8,7 @@ Description : The G-Machine module GM ( hdbgProg , evalProg + , evalProgR , Node(..) , gmEvalProg , finalStateOf @@ -34,6 +35,7 @@ import System.IO (Handle, hPutStrLn) import Data.String (IsString) import Data.Heap import Debug.Trace +import Compiler.RLPC import Core2Core import Core ---------------------------------------------------------------------------------- @@ -156,6 +158,21 @@ hdbgProg p hio = do [resAddr] = final ^. gmStack res = hLookupUnsafe resAddr h +evalProgR :: (Monad m) => Program' -> RLPCT m (Node, Stats) +evalProgR p = do + (renderOut . showState) `traverse_` states + renderOut . showStats $ sts + pure (res, sts) + where + renderOut r = addDebugMsg "dump-eval" $ render r ++ "\n" + states = eval . compile $ p + final = last states + + sts = final ^. gmStats + -- the address of the result should be the one and only stack entry + [resAddr] = final ^. gmStack + res = hLookupUnsafe resAddr (final ^. gmHeap) + eval :: GmState -> [GmState] eval st = st : rest where