diff --git a/app/Main.hs b/app/Main.hs index 342c461..1bb77c1 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -10,6 +10,7 @@ import System.IO import System.Exit (exitSuccess) import Core import TIM +import GM import Lens.Micro import Lens.Micro.Mtl ---------------------------------------------------------------------------------- @@ -23,30 +24,46 @@ optParser = info (helper <*> options) options :: Parser RLPCOptions options = RLPCOptions + {- --log, -l -} <$> optional # strOption ( long "log" <> short 'l' <> metavar "FILE" <> help "output dumps to FILE. stderr is used by default" ) - -- temp. i want gcc/ghc style options + {- -d -} <*> fmap S.fromList # many # option debugFlagReader ( short 'd' <> help "dump evaluation logs" <> metavar "DEBUG FLAG" ) + {- --evaluator, -e -} + <*> option evaluatorReader + ( long "evaluator" + <> short 'e' + <> metavar "gm|tim" + <> value EvaluatorGM + <> help "the intermediate layer used to model evaluation" + ) <*> some (argument str (metavar "FILES...")) where infixr 9 # f # x = f x +evaluatorReader :: ReadM Evaluator +evaluatorReader = maybeReader $ \case + "gm" -> Just EvaluatorGM + "tim" -> Just EvaluatorTIM + _ -> Nothing + mmany :: (Alternative f, Monoid m) => f m -> f m mmany v = liftA2 (<>) v (mmany v) debugFlagReader :: ReadM DebugFlag -debugFlagReader = maybeReader $ Just . \case - "dump-eval" -> DDumpEval - "dump-opts" -> DDumpOpts +debugFlagReader = maybeReader $ \case + "dump-eval" -> Just DDumpEval + "dump-opts" -> Just DDumpOpts + _ -> Nothing ---------------------------------------------------------------------------------- @@ -83,12 +100,21 @@ ddumpEval = whenFlag flagDDumpEval do Left e -> addFatal . CompilerError $ show e Right (a,_) -> do log <- view rlpcLogFile + dumpEval <- chooseEval case log of - Just f -> void . liftIO $ withFile f WriteMode $ hdbgProg a - Nothing -> void . liftIO $ hdbgProg a stderr + Just f -> liftIO $ withFile f WriteMode $ dumpEval a + Nothing -> liftIO $ dumpEval a stderr parseProg :: RLPCOptions -> String -> Either SrcError (Program, [SrcError]) parseProg o = evalRLPC o . (lexCore >=> parseCoreProg) + -- choose the appropriate model based on the compiler opts + chooseEval = do + ev <- view rlpcEvaluator + pure $ case ev of + EvaluatorGM -> v GM.hdbgProg + EvaluatorTIM -> v TIM.hdbgProg + where v f p h = f p h *> pure () + diff --git a/src/Compiler/RLPC.hs b/src/Compiler/RLPC.hs index 8cc7373..7a266b8 100644 --- a/src/Compiler/RLPC.hs +++ b/src/Compiler/RLPC.hs @@ -17,11 +17,13 @@ module Compiler.RLPC , addWound , MonadErrorful , Severity(..) + , Evaluator(..) , evalRLPCT , evalRLPCIO , evalRLPC , rlpcLogFile , rlpcDebugOpts + , rlpcEvaluator , rlpcInputFiles , DebugFlag(..) , whenFlag @@ -80,10 +82,14 @@ evalRLPCIO o m = do data RLPCOptions = RLPCOptions { _rlpcLogFile :: Maybe FilePath , _rlpcDebugOpts :: DebugOpts + , _rlpcEvaluator :: Evaluator , _rlpcInputFiles :: [FilePath] } deriving Show +data Evaluator = EvaluatorGM | EvaluatorTIM + deriving Show + data Severity = Error | Warning | Debug @@ -105,6 +111,7 @@ instance Default RLPCOptions where def = RLPCOptions { _rlpcLogFile = Nothing , _rlpcDebugOpts = mempty + , _rlpcEvaluator = EvaluatorGM , _rlpcInputFiles = [] } diff --git a/src/Core/Examples.hs b/src/Core/Examples.hs index f783369..656e609 100644 --- a/src/Core/Examples.hs +++ b/src/Core/Examples.hs @@ -110,6 +110,13 @@ listExample3 = [coreProg| main = foldr (+#) 0 list; |] +simple1 = [coreProg| + k a b = a; + s f g x = f x (g x); + + main = s k k 3; +|] + corePrelude :: Module corePrelude = Module (Just ("Prelude", [])) $ -- non-primitive defs diff --git a/src/GM.hs b/src/GM.hs index b535405..422aea8 100644 --- a/src/GM.hs +++ b/src/GM.hs @@ -6,7 +6,7 @@ Description : The G-Machine {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE OverloadedStrings #-} module GM - ( + ( hdbgProg ) where ---------------------------------------------------------------------------------- @@ -19,6 +19,8 @@ import Lens.Micro.TH import Text.Printf import Text.PrettyPrint hiding ((<>)) import Text.PrettyPrint.HughesPJ (maybeParens) +import Data.Foldable (traverse_) +import System.IO (Handle, hPutStrLn) import Data.Heap import Core ---------------------------------------------------------------------------------- @@ -72,6 +74,21 @@ pure [] ---------------------------------------------------------------------------------- +hdbgProg :: Program -> Handle -> IO (Node, Stats) +hdbgProg p hio = do + (renderOut . showState) `traverse_` p' + renderOut . showStats $ sts + pure (res, sts) + where + renderOut r = hPutStrLn hio $ render r ++ "\n" + + p' = eval $ compile p + final = last p' + sts = final ^. gmStats + [resAddr] = final ^. gmStack + res = hLookupUnsafe resAddr h + h = final ^. gmHeap + eval :: GmState -> [GmState] eval st = st : rest where @@ -139,20 +156,18 @@ step st = case head (st ^. gmCode) of s = st ^. gmStack h = st ^. gmHeap - s' = an : s - an = s !! (n+1) - an' = getArg an - - getArg (hViewUnsafe h -> NAp _ a) = a + s' = arg : s + argAp = s !! (n+1) + arg = case hLookupUnsafe argAp h of + NAp _ a -> a slide :: Int -> GmState -> GmState slide n st = st & gmCode %~ drop 1 & gmStack .~ s' where - s = st ^. gmStack - a0 = head s - s' = a0 : drop n s + (a:s) = st ^. gmStack + s' = a : drop n s unwind :: GmState -> GmState unwind st = case hLookupUnsafe a h of @@ -162,6 +177,7 @@ step st = case head (st ^. gmCode) of NAp f x -> st -- leave the Unwind instr; continue unwinding & gmStack %~ (f:) + -- assumes length s < d (i.e. enough args have been supplied) NGlobal d c -> st -- 'jump' to global's code by replacing our current -- code with `c` @@ -235,9 +251,6 @@ pprTabstop = 4 qquotes :: Doc -> Doc qquotes d = "`" <> d <> "'" -showResults :: [GmState] -> String -showResults st = undefined - showStats :: Stats -> Doc showStats sts = "==== Stats ============" $$ stats where @@ -316,7 +329,8 @@ showNodeAtP p st a = case hLookup a h of where g = st ^. gmEnv name = fromMaybe "" $ lookup a (swap <$> g) - Just (NAp f x) -> showNodeAtP (p+1) st f <+> showNodeAtP (p+1) st x + Just (NAp f x) -> pprec $ showNodeAtP (p+1) st f <+> showNodeAtP (p+1) st x + where pprec = maybeParens (p > 0) Nothing -> "" where h = st ^. gmHeap