begin gm

docs/src/commentary/gm.rst

@@ -58,5 +58,152 @@ sequence of instructions* which instantiate the expression at execution.
 Implementation
 **************
 
+WIP. state transition rules
 
+1. Lookup a global by name and push its value onto the stack
+
+.. math::
+   \gmrule
+   { \mathtt{PushGlobal} \; f : i
+   & s
+   & h
+   & m
+   \begin{bmatrix}
+        f : a
+   \end{bmatrix}
+   }
+   { i
+   & a : s
+   & h
+   & m
+   }
+
+2. Allocate an int node on the heap, and push the address of the newly created
+   node onto the stack
+
+.. math::
+   \gmrule
+   { \mathtt{PushInt} \; n : i
+   & s
+   & h
+   & m
+   }
+   { i
+   & a : s
+   & h
+   \begin{bmatrix}
+        a : \mathtt{NNum} \; n
+   \end{bmatrix}
+   & m
+   }
+
+3. Allocate an application node on the heap, applying the top of the stack to
+   the address directly below it. The address of the application node is pushed
+   onto the stack.
+
+.. math::
+   \gmrule
+   { \mathtt{MkAp} : i
+   & f : x : s
+   & h
+   & m
+   }
+   { i
+   & a : s
+   & h
+   \begin{bmatrix}
+        a : \mathtt{NAp} \; f \; x
+   \end{bmatrix}
+   & m
+   }
+
+4. Push a function's argument onto the stack
+
+.. math::
+   \gmrule
+   { \mathtt{Push} \; n : i
+   & a_0 : \ldots : a_{n+1} : s
+   & h
+   \begin{bmatrix}
+        a_{n+1} : \mathtt{NAp} \; a_n \; a'_n
+   \end{bmatrix}
+   & m
+   }
+   { i
+   & a'_n : a_0 : \ldots : a_{n+1} : s
+   & h
+   & m
+   }
+
+5. Tidy up the stack after instantiating a supercombinator
+
+.. math::
+   \gmrule
+   { \mathtt{Slide} \; n : i
+   & a_0 : \ldots : a_n : s
+   & h
+   & m
+   }
+   { i
+   & a_0 : s
+   & h
+   & m
+   }
+
+6. If a number is on top of the stack, :code:`Unwind` leaves the machine in a
+   halt state
+
+.. math::
+   \gmrule
+   { \mathtt{Unwind} : \nillist
+   & a : s
+   & h
+   \begin{bmatrix}
+        a : \mathtt{NNum} \; n
+   \end{bmatrix}
+   & m
+   }
+   { \nillist
+   & a : s
+   & h
+   & m
+   }
+
+7. If an application is on top of the stack, :code:`Unwind` continues unwinding
+
+.. math::
+   \gmrule
+   { \mathtt{Unwind} : \nillist
+   & a : s
+   & h
+   \begin{bmatrix}
+        a : \mathtt{NAp} \; f \; x
+   \end{bmatrix}
+   & m
+   }
+   { \mathtt{Unwind} : \nillist
+   & f : a : s
+   & h
+   & m
+   }
+
+8. When a global node is on top of the stack (and the correct number of
+   arguments have been provided), :code:`Unwind` jumps to the supercombinator's
+   code (:math:`\beta`-reduction)
+
+.. math::
+   \gmrule
+   { \mathtt{Unwind} : \nillist
+   & a_0 : \ldots : a_n : s
+   & h
+   \begin{bmatrix}
+        a_0 : \mathtt{NGlobal} \; n \; c
+   \end{bmatrix}
+   & m
+   }
+   { c
+   & a_0 : \ldots : a_n : s
+   & h
+   & m
+   }
 

docs/src/conf.py

@@ -41,6 +41,14 @@ imgmath_latex_preamble = r'''
          \hline
     \end{tblr} }
 
+\newcommand{\gmrule}[2]
+    {\begin{tblr}{|rrrll|}
+         \hline
+         & #1 \\
+         \implies & #2 \\
+         \hline
+    \end{tblr} }
+
 \newcommand{\nillist}{[\,]}
 '''
 

rlp.cabal

@@ -20,6 +20,7 @@ library
     import:           warnings
     exposed-modules:  Core
                     , TIM
+                    , GM
                     , Compiler.RLPC
 
     other-modules:    Data.Heap

src/GM.hs

@@ -0,0 +1,216 @@
+{-|
+Module      : GM
+Description : The G-Machine
+-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE ViewPatterns #-}
+module GM
+    (
+    )
+    where
+----------------------------------------------------------------------------------
+import Data.Default.Class
+import Data.List                    (mapAccumL)
+import Data.Maybe                   (fromMaybe)
+import Lens.Micro
+import Lens.Micro.TH
+import Data.Heap
+import Core
+----------------------------------------------------------------------------------
+
+data GmState = GmState
+    { _gmCode   :: Code
+    , _gmStack  :: Stack
+    , _gmHeap   :: GmHeap
+    , _gmEnv    :: Env
+    , _gmStats  :: Stats
+    }
+    deriving Show
+
+type Code = [Instr]
+type Stack = [Addr]
+type Env = [(Name, Addr)]
+type GmHeap = Heap Node
+
+data Instr = Unwind
+           | PushGlobal Name
+           | PushInt Int
+           | Push Int
+           | MkAp
+           | Slide Int
+           deriving (Show, Eq)
+
+data Node = NNum Int
+          | NAp Addr Addr
+          -- NGlobal is the GM equivalent of NSupercomb. rather than storing a
+          -- template to be instantiated, NGlobal holds the global's arity and
+          -- the pre-compiled code :3
+          | NGlobal Int Code
+          deriving Show
+
+data Stats = Stats
+    { _stsReductions   :: Int
+    , _stsAllocations  :: Int
+    , _stsDereferences :: Int
+    , _stsGCCycles     :: Int
+    }
+    deriving Show
+
+instance Default Stats where
+    def = Stats 0 0 0 0
+
+-- TODO: _gmGlobals should not have a setter
+makeLenses ''GmState
+makeLenses ''Stats
+pure []
+
+----------------------------------------------------------------------------------
+
+eval :: GmState -> [GmState]
+eval st = st : rest
+    where
+        rest | isFinal st   = []
+             | otherwise    = eval next
+        next = doAdmin (step st)
+
+doAdmin :: GmState -> GmState
+doAdmin st = st & gmStats . stsReductions %~ succ
+
+isFinal :: GmState -> Bool
+isFinal st = null $ st ^. gmCode
+
+step :: GmState -> GmState
+step st = case head (st ^. gmCode) of
+    Unwind       -> unwind       st
+    PushGlobal n -> pushGlobal n st
+    PushInt    n -> pushInt    n st
+    Push       n -> push       n st
+    MkAp         -> mkAp         st
+    Slide      n -> slide      n st
+    where
+
+        pushGlobal :: Name -> GmState -> GmState
+        pushGlobal k st = st
+                        & gmCode  %~ drop 1
+                        & gmStack .~ s'
+            where
+                s = st ^. gmStack
+                m = st ^. gmEnv
+
+                s' = a : s
+                a = fromMaybe (error $ "undefined var: " <> show k)
+                        $ lookup k m
+
+        pushInt :: Int -> GmState -> GmState
+        pushInt n st = st
+                     & gmCode  %~ drop 1
+                     & gmStack .~ s'
+                     & gmHeap  .~ h'
+            where
+                s = st ^. gmStack
+                h = st ^. gmHeap
+
+                s' = a : s
+                (h',a) = alloc h (NNum n)
+
+        mkAp :: GmState -> GmState
+        mkAp st = st
+                & gmCode  %~ drop 1
+                & gmStack .~ s'
+                & gmHeap  .~ h'
+            where
+                (f:x:ss) = st ^. gmStack
+                h = st ^. gmHeap
+                
+                s' = a : ss
+                (h',a) = alloc h (NAp f x)
+
+        push :: Int -> GmState -> GmState
+        push n st = st
+                  & gmCode  %~ drop 1
+                  & gmStack .~ s'
+            where
+                s = st ^. gmStack
+                h = st ^. gmHeap
+
+                s' = an : s
+                an = s !! (n+1)
+                an' = getArg an
+
+                getArg (hViewUnsafe h -> 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
+
+        unwind :: GmState -> GmState
+        unwind st = case hLookupUnsafe a h of
+            NNum n      -> st
+                         -- halt; discard all further instructions
+                         & gmCode .~ []
+            NAp f x     -> st
+                         -- leave the Unwind instr; continue unwinding
+                         & gmStack %~ (f:)
+            NGlobal d c -> st
+                         -- 'jump' to global's code by replacing our current
+                         -- code with `c`
+                         & gmCode .~ c
+            where
+                s = st ^. gmStack
+                a = head s
+                h = st ^. gmHeap
+
+----------------------------------------------------------------------------------
+
+compile :: Program -> GmState
+compile p = GmState c [] h g sts
+    where
+        -- find the entry point and start unwinding
+        c = [PushGlobal "main", Unwind]
+        (h,g) = buildInitialHeap p
+        sts = def
+
+type CompiledSC = (Name, Int, Code)
+
+buildInitialHeap :: Program -> (GmHeap, Env)
+buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiled
+    where
+        compiled = fmap compileSc ss
+
+        allocateSc :: GmHeap -> CompiledSC -> (GmHeap, (Name, Addr))
+        allocateSc h (n,d,c) = (h', (n, a))
+            where (h',a) = alloc h $ NGlobal d c
+
+        compileSc :: ScDef -> CompiledSC
+        compileSc (ScDef n as b) = (n, d, compileR env b)
+            where
+                env = as `zip` [0..]
+                d = length as
+
+        compileR :: Env -> Expr -> Code
+        compileR g e = compileC g e <> [Slide (d+1), Unwind]
+            where
+                d = length g
+
+        compileC :: Env -> Expr -> Code
+        compileC g (Var k)
+            | k `elem` domain  = [Push n]
+            | otherwise        = [PushGlobal k]
+            where
+                n = fromMaybe (error "unknown var") $ lookup k g
+                domain = fmap fst g
+
+        compileC g (IntE n)  = [PushInt n]
+        compileC g (App f x) = compileC g x
+                            <> compileC (argOffset 1 g) f
+                            <> [MkAp]
+
+        -- | offset each address in the environment by n
+        argOffset :: Int -> Env -> Env
+        argOffset n = each . _2 %~ (+n)
+

src/TIM.hs

@@ -242,17 +242,19 @@ step st =
                 _ ->
                     TiState (f:ap:s) d h g sts
 
+        -- >> [ref/scStep]
         scStep :: Name -> [Name] -> Expr -> TiState -> TiState
         scStep n as e (TiState s d h g sts) =
             TiState s' d h' g sts
             where
-                s' = rootAddr : drop (length as + 1) s
+                s' = rootAddr : drop (length as + 1) s  -- 3., 4.
-                rootAddr = (s !! length as)
+                h' = instantiateU e rootAddr h env      -- 2.
-                h' = instantiateU e rootAddr h env
+                rootAddr = s !! length as
 
-                env = argBinds ++ g
+                env = argBinds ++ g                     -- 1.
                 argBinds = as `zip` argAddrs
                 argAddrs = getArgs h s
+        -- << [ref/scStep]
 
         -- dereference indirections
         indStep :: Addr -> TiState -> TiState