g-machine mark 1 hooray

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
-                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 "<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