Merge pull request #3 from msydneyslaga/gm-m3

Gm m3

docs/src/commentary/gm.rst

@@ -5,7 +5,7 @@ The *G-Machine*
 Motivation
 **********
 
-Our initial model, the *Template Instantiation Machine* (TIM) was a very
+Our initial model, the *Template Instantiator* (TI) was a very
 straightforward solution to compilation, but its core design has a major
 Achilles' heel, being that Compilation is interleaved with evaluation -- The
 heap nodes for supercombinators hold uninstantiated expressions, i.e. raw ASTs
@@ -43,11 +43,11 @@ The process of instantiating a supercombinator goes something like this
 
 4. Push the address to the newly instantiated body onto the stack.
 
-.. literalinclude:: /../../src/TIM.hs
+.. literalinclude:: /../../src/TI.hs
    :dedent:
    :start-after: -- >> [ref/scStep]
    :end-before: -- << [ref/scStep]
-   :caption: src/TIM.hs
+   :caption: src/TI.hs
 
 Instantiating the supercombinator's body in this way is the root of our
 Achilles' heel. Traversing a tree structure is a very non-linear task unfit for
@@ -125,15 +125,12 @@ Core Transition Rules
 .. math::
    \gmrule
    { \mathtt{Push} \; n : i
-   & a_0 : \ldots : a_{n+1} : s
+   & a_0 : \ldots : a_n : 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
+   & a_n : a_0 : \ldots : a_n : s
    & h
    & m
    }
@@ -190,9 +187,9 @@ Core Transition Rules
    & m
    }
 
-8. When a global node is on top of the stack (and the correct number of
+8. When a supercombinator is on top of the stack (and the correct number of
-   arguments have been provided), :code:`Unwind` jumps to the supercombinator's
+   arguments have been provided), :code:`Unwind` sets up the stack and jumps to
-   code (:math:`\beta`-reduction)
+   the supercombinator's code (:math:`\beta`-reduction)
 
 .. math::
    \gmrule
@@ -200,12 +197,15 @@ Core Transition Rules
    & a_0 : \ldots : a_n : s
    & h
    \begin{bmatrix}
-        a_0 : \mathtt{NGlobal} \; n \; c
+        a_0 : \mathtt{NGlobal} \; n \; c \\
+        a_1 : \mathtt{NAp} \; a_0 \; e_1 \\
+        \vdots \\
+        a_n : \mathtt{NAp} \; a_{n-1} \; e_n \\
    \end{bmatrix}
    & m
    }
    { c
-   & a_0 : \ldots : a_n : s
+   & e_1 : \ldots : e_n : a_n : s
    & h
    & m
    }
@@ -266,6 +266,26 @@ Core Transition Rules
    & m
    }
 
+12. Allocate uninitialised heap space
+
+.. math::
+   \gmrule
+   { \mathtt{Alloc} \; n : i
+   & s
+   & h
+   & m
+   }
+   { i
+   & a_1 : \ldots : a_n : s
+   & h
+   \begin{bmatrix}
+        a_1 : \mathtt{NUninitialised} \\
+        \vdots \\
+        a_n : \mathtt{NUninitialised} \\
+   \end{bmatrix}
+   & m
+   }
+
 Extension Rules
 ---------------
 

src/GM.hs

@@ -20,8 +20,9 @@ import Text.Printf
 import Text.PrettyPrint             hiding ((<>))
 import Text.PrettyPrint.HughesPJ    (maybeParens)
 import Data.Foldable                (traverse_)
+import Debug.Trace
 import System.IO                    (Handle, hPutStrLn)
-import Data.Heap
+import Data.Heap                    as Heap
 import Core
 ----------------------------------------------------------------------------------
 
@@ -47,6 +48,7 @@ data Instr = Unwind
            | Slide Int
            | Update Int
            | Pop Int
+           | Alloc Int
            deriving (Show, Eq)
 
 data Node = NNum Int
@@ -56,6 +58,7 @@ data Node = NNum Int
           -- the pre-compiled code :3
           | NGlobal Int Code
           | NInd Addr
+          | NUninitialised
           deriving (Show, Eq)
 
 data Stats = Stats
@@ -123,6 +126,7 @@ step st = case head (st ^. gmCode) of
     Slide      n -> slide      n st
     Pop        n -> pop        n st
     Update     n -> update     n st
+    Alloc      n -> alloc      n st
     where
 
         pushGlobal :: Name -> GmState -> GmState
@@ -154,7 +158,7 @@ step st = case head (st ^. gmCode) of
                      & gmStats . stsAllocations %~ succ --
                 where
                     s' = a : s
-                    (h',a) = alloc h (NNum n)
+                    (h',a) = Heap.alloc h (NNum n)
                     m' = (n',a) : m
             where
                 m = st ^. gmEnv
@@ -173,8 +177,8 @@ step st = case head (st ^. gmCode) of
         --         s = st ^. gmStack
         --         h = st ^. gmHeap
 
-                s' = a : s
+        --         s' = a : s
-                (h',a) = alloc h (NNum n)
+        --         (h',a) = alloc h (NNum n)
 
         mkAp :: GmState -> GmState
         mkAp st = st
@@ -188,23 +192,18 @@ step st = case head (st ^. gmCode) of
                 h = st ^. gmHeap
                 
                 s' = a : ss
-                (h',a) = alloc h (NAp f x)
+                (h',a) = Heap.alloc h (NAp f x)
 
         -- a `Push n` instruction pushes the address of (n+1)-th argument onto
-        -- the stack. this means that the nth node on the stack is assumed to be
+        -- the stack.
-        -- an application. the (n+1)-th argument is the rhs of that application.
         push :: Int -> GmState -> GmState
         push n st = st
                   & gmCode  %~ drop 1
-                  & gmStack .~ s'
+                  & gmStack %~ (a:)
             where
-                s = st ^. gmStack
                 h = st ^. gmHeap
-
+                s = st ^. gmStack
-                s' = arg : s
+                a = s !! n
-                argAp = s !! (n+1)
-                arg = case hLookupUnsafe argAp h of
-                    NAp _ a -> a
 
         -- 'slide' the top of the stack `n` entries downwards, popping any
         -- entries along the way.
@@ -231,13 +230,29 @@ step st = case head (st ^. gmCode) of
                 (e:s) = st ^. gmStack
                 an = s !! n
                 h' = st ^. gmHeap
-                    & Data.Heap.update an (NInd e)
+                    & Heap.update an (NInd e)
 
         pop :: Int -> GmState -> GmState
         pop n st = st
                  & gmCode  %~ drop 1
                  & gmStack %~ drop n
 
+        alloc :: Int -> GmState -> GmState
+        alloc n st = st
+                   & gmCode  %~ drop 1
+                   & gmStack .~ s'
+                   & gmHeap  .~ h'
+            where
+                s = st ^. gmStack
+                h = st ^. gmHeap
+                s' = ns ++ s
+                (h',ns) = allocNode n h
+
+                allocNode :: Int -> GmHeap -> (GmHeap, [Addr])
+                allocNode 0 g = (g,[])
+                allocNode k g = allocNode (k-1) g' & _2 %~ (a:)
+                    where (g',a) = Heap.alloc g NUninitialised
+
         -- the complex heart of the G-machine
         unwind :: GmState -> GmState
         unwind st = case hLookupUnsafe a h of
@@ -248,10 +263,20 @@ step st = case head (st ^. gmCode) of
                          -- leave the Unwind instr; continue unwinding
                          & gmStack %~ (f:)
             -- assumes length s < d (i.e. enough args have been supplied)
-            NGlobal d c -> st
+            NGlobal n c -> st
                          -- 'jump' to global's code by replacing our current
                          -- code with `c`
-                         & gmCode .~ c
+                         & gmCode  .~ c
+                         & gmStack .~ s'
+                where
+                    s' = args ++ drop n s
+                    args = getArgs $ take (n+1) s
+
+                    getArgs :: Stack -> [Addr]
+                    getArgs (_:ss) = fmap arg ss
+                        where
+                            arg (hViewUnsafe h -> NAp _ x) = x
+
             -- follow indirection
             NInd a      -> st
                          -- leave the Unwind instr; continue unwinding.
@@ -316,6 +341,35 @@ buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiled
                             <> [MkAp]
         -- << [ref/compileC]
 
+        compileC g (Let NonRec bs e) =
+                mconcat binders <> compileC g' e <> [Slide d]
+            where
+                d = length bs
+                (g',binders) = mapAccumL compileBinder (argOffset d g) addressed
+                -- kinda gross. revisit this
+                addressed = bs `zip` reverse [0 .. d-1]
+
+                compileBinder :: Env -> (Binding, Int) -> (Env, Code)
+                compileBinder m (k := v, a) = (m',c)
+                    where
+                        m' = (k,a) : m
+                        -- make note that we use m rather than m'!
+                        c = compileC m v
+
+        compileC g (Let Rec bs e) = Alloc d : initialisers <> body <> [Slide d]
+            where
+                d = length bs
+                g' = fmap toEnv addressed ++ argOffset d g
+                toEnv (k := _, a) = (k,a)
+                -- kinda gross. revisit this
+                addressed = bs `zip` reverse [0 .. d-1]
+
+                initialisers = mconcat $ compileBinder <$> addressed
+                body = compileC g' e
+
+                compileBinder :: (Binding, Int) -> Code
+                compileBinder (k := v, a) = compileC g' v <> [Update a]
+
         -- | offset each address in the environment by n
         argOffset :: Int -> Env -> Env
         argOffset n = each . _2 %~ (+n)
@@ -410,6 +464,7 @@ showNodeAtP p st a = case hLookup a h of
         where pprec = maybeParens (p > 0)
     Just (NInd a)        -> pprec $ "NInd -> " <> showNodeAtP (p+1) st a
         where pprec = maybeParens (p > 0)
+    Just NUninitialised  -> "<uninitialised>"
     Nothing              -> "<invalid address>"
     where h = st ^. gmHeap