g-machine mark 1 hooray

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
+debugFlagReader = maybeReader $ \case
-    "dump-eval"  -> DDumpEval
+    "dump-eval"  -> Just DDumpEval
-    "dump-opts"  -> DDumpOpts
+    "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
+                    Just f  -> liftIO $ withFile f WriteMode $ dumpEval a
-                    Nothing -> void . liftIO $ hdbgProg a stderr
+                    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 ()
+

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 = []
         }
 

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

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
+                s' = arg : s
-                an = s !! (n+1)
+                argAp = s !! (n+1)
-                an' = getArg an
+                arg = case hLookupUnsafe argAp h of
-
+                    NAp _ a -> a
-                getArg (hViewUnsafe h -> NAp _ a) = a
 
         slide :: Int -> GmState -> GmState
         slide n st = st
                    & gmCode  %~ drop 1
                    & gmStack .~ s'
             where
-                s = st ^. gmStack
+                (a:s) = st ^. gmStack
-                a0 = head s
+                s' = a : drop n s
-                s' = a0 : 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 "<unknown>" $ 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              -> "<invalid address>"
     where h = st ^. gmHeap