diff --git a/docs/src/commentary/gm.rst b/docs/src/commentary/gm.rst index e7c38e8..fe867b9 100644 --- a/docs/src/commentary/gm.rst +++ b/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 - arguments have been provided), :code:`Unwind` jumps to the supercombinator's - code (:math:`\beta`-reduction) +8. When a supercombinator is on top of the stack (and the correct number of + arguments have been provided), :code:`Unwind` sets up the stack and jumps to + 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 --------------- diff --git a/src/GM.hs b/src/GM.hs index b757375..a45c252 100644 --- a/src/GM.hs +++ b/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 - (h',a) = alloc h (NNum n) + -- s' = a : s + -- (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 - -- an application. the (n+1)-th argument is the rhs of that application. + -- the stack. push :: Int -> GmState -> GmState push n st = st & gmCode %~ drop 1 - & gmStack .~ s' + & gmStack %~ (a:) where - s = st ^. gmStack h = st ^. gmHeap - - s' = arg : s - argAp = s !! (n+1) - arg = case hLookupUnsafe argAp h of - NAp _ a -> a + s = st ^. gmStack + a = s !! n -- '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 -> "" Nothing -> "" where h = st ^. gmHeap