msyds/rlp
1
0
Fork 0
Code Issues 4 Pull Requests Actions Packages Projects Releases 2 Wiki Activity

Gm m3 #3

Merged
msydneyslaga merged 4 commits from gm-m3 into main 2023-12-01 14:45:08 -07:00
Conversation 0 Commits 4 Files Changed 2 +105 -30
2 changed files with 105 additions and 30 deletions
Download Patch File Download Diff File Expand all files Collapse all files

46
docs/src/commentary/gm.rst
View File

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

89
src/GM.hs
View File

@@ -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 -> "<uninitialised>"
Nothing -> "<invalid address>"
where h = st ^. gmHeap