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

prim arith hooray

Browse Source
This commit is contained in:
crumbtoo
2023-12-04 11:21:00 -07:00
parent 44030fab0a
commit 7ef3bf1082
2 changed files with 518 additions and 361 deletions
Download Patch File Download Diff File Expand all files Collapse all files

155
docs/src/references/gm-state-transitions.rst
View File

@@ -6,9 +6,9 @@ G-Machine State Transition Rules
Core Transition Rules Core Transition Rules
********************* *********************
1. Lookup a global by name and push its value onto the stack #. Lookup a global by name and push its value onto the stack
.. math:: .. math::
\gmrule \gmrule
{ \mathtt{PushGlobal} \; f : i { \mathtt{PushGlobal} \; f : i
& s & s
@@ -26,10 +26,10 @@ Core Transition Rules
& m & m
} }
2. Allocate an int node on the heap, and push the address of the newly created #. Allocate an int node on the heap, and push the address of the newly created
node onto the stack node onto the stack
.. math:: .. math::
\gmrule \gmrule
{ \mathtt{PushInt} \; n : i { \mathtt{PushInt} \; n : i
& s & s
@@ -47,11 +47,11 @@ Core Transition Rules
& m & m
} }
3. Allocate an application node on the heap, applying the top of the stack to #. 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 the address directly below it. The address of the application node is pushed
onto the stack. onto the stack.
.. math:: .. math::
\gmrule \gmrule
{ \mathtt{MkAp} : i { \mathtt{MkAp} : i
& f : x : s & f : x : s
@@ -69,9 +69,9 @@ Core Transition Rules
& m & m
} }
4. Push a function's argument onto the stack #. Push a function's argument onto the stack
.. math:: .. math::
\gmrule \gmrule
{ \mathtt{Push} \; n : i { \mathtt{Push} \; n : i
& a_0 : \ldots : a_n : s & a_0 : \ldots : a_n : s
@@ -86,9 +86,9 @@ Core Transition Rules
& m & m
} }
5. Tidy up the stack after instantiating a supercombinator #. Tidy up the stack after instantiating a supercombinator
.. math:: .. math::
\gmrule \gmrule
{ \mathtt{Slide} \; n : i { \mathtt{Slide} \; n : i
& a_0 : \ldots : a_n : s & a_0 : \ldots : a_n : s
@@ -103,15 +103,38 @@ Core Transition Rules
& m & m
} }
6. If a number is on top of the stack, :code:`Unwind` leaves the machine in a #. If the top of the stack is in WHNF (currently this just means a number) is on
halt state top of the stack, :code:`Unwind` considers evaluation complete. In the case
where the dump is **not** empty, the instruction queue and stack is restored
from the top.
.. math:: .. math::
\gmrule \gmrule
{ \mathtt{Unwind} : \nillist { \mathtt{Unwind} : \nillist
& a : s & a : s
& \langle i', s' \rangle : d
& h
\begin{bmatrix}
a : \mathtt{NNum} \; n
\end{bmatrix}
& m
}
{ i'
& a : s'
& d & d
& h & h
& m
}
#. Bulding on the previous rule, in the case where the dump **is** empty, leave
the machine in a halt state (i.e. with an empty instruction queue).
.. math::
\gmrule
{ \mathtt{Unwind} : \nillist
& a : s
& \nillist
& h
\begin{bmatrix} \begin{bmatrix}
a : \mathtt{NNum} \; n a : \mathtt{NNum} \; n
\end{bmatrix} \end{bmatrix}
@@ -119,14 +142,14 @@ Core Transition Rules
} }
{ \nillist { \nillist
& a : s & a : s
& d & \nillist
& h & h
& m & m
} }
7. If an application is on top of the stack, :code:`Unwind` continues unwinding #. If an application is on top of the stack, :code:`Unwind` continues unwinding
.. math:: .. math::
\gmrule \gmrule
{ \mathtt{Unwind} : \nillist { \mathtt{Unwind} : \nillist
& a : s & a : s
@@ -144,11 +167,11 @@ Core Transition Rules
& m & m
} }
8. When a supercombinator is on top of the stack (and the correct number of #. 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 arguments have been provided), :code:`Unwind` sets up the stack and jumps to
the supercombinator's code (:math:`\beta`-reduction) the supercombinator's code (:math:`\beta`-reduction)
.. math:: .. math::
\gmrule \gmrule
{ \mathtt{Unwind} : \nillist { \mathtt{Unwind} : \nillist
& a_0 : \ldots : a_n : s & a_0 : \ldots : a_n : s
@@ -169,9 +192,9 @@ Core Transition Rules
& m & m
} }
9. Pop the stack, and update the nth node to point to the popped address #. Pop the stack, and update the nth node to point to the popped address
.. math:: .. math::
\gmrule \gmrule
{ \mathtt{Update} \; n : i { \mathtt{Update} \; n : i
& e : f : a_1 : \ldots : a_n : s & e : f : a_1 : \ldots : a_n : s
@@ -194,9 +217,9 @@ Core Transition Rules
& m & m
} }
10. Pop the stack. #. Pop the stack.
.. math:: .. math::
\gmrule \gmrule
{ \mathtt{Pop} \; n : i { \mathtt{Pop} \; n : i
& a_1 : \ldots : a_n : s & a_1 : \ldots : a_n : s
@@ -211,9 +234,9 @@ Core Transition Rules
& m & m
} }
11. Follow indirections while unwinding #. Follow indirections while unwinding
.. math:: .. math::
\gmrule \gmrule
{ \mathtt{Unwind} : \nillist { \mathtt{Unwind} : \nillist
& a : s & a : s
@@ -231,9 +254,9 @@ Core Transition Rules
& m & m
} }
12. Allocate uninitialised heap space #. Allocate uninitialised heap space
.. math:: .. math::
\gmrule \gmrule
{ \mathtt{Alloc} \; n : i { \mathtt{Alloc} \; n : i
& s & s
@@ -253,30 +276,9 @@ Core Transition Rules
& m & m
} }
13. When unwinding, if the top of the stack is in WHNF (currently this just #. Evaluate the top of the stack to WHNF
means a number), pop the dump
.. math:: .. math::
\gmrule
{ \mathtt{Unwind} : \nillist
& a : s
& \langle i', s' \rangle : d
& h
\begin{bmatrix}
a : \mathtt{NNum} \; n
\end{bmatrix}
& m
}
{ i'
& a : s'
& d
& h
& m
}
14. Evaluate the top of the stack to WHNF
.. math::
\gmrule \gmrule
{ \mathtt{Eval} : i { \mathtt{Eval} : i
& a : s & a : s
@@ -291,11 +293,58 @@ Core Transition Rules
& m & m
} }
#. Reduce a primitive binary operator :math:`*`.
.. math::
\gmrule
{ * : i
& a_1 : a_2 : s
& d
& h
\begin{bmatrix}
a_1 : x \\
a_2 : y
\end{bmatrix}
& m
}
{ i
& a' : s
& d
& h
\begin{bmatrix}
a' : (x * y)
\end{bmatrix}
& m
}
#. Reduce a primitive unary operator :math:`\neg`.
.. math::
\gmrule
{ \neg : i
& a : s
& d
& h
\begin{bmatrix}
a : x
\end{bmatrix}
& m
}
{ i
& a' : s
& d
& h
\begin{bmatrix}
a' : (\neg x)
\end{bmatrix}
& m
}
*************** ***************
Extension Rules Extension Rules
*************** ***************
1. A sneaky trick to enable sharing of :code:`NNum` nodes. We note that the #. A sneaky trick to enable sharing of :code:`NNum` nodes. We note that the
global environment is a mapping of plain old strings to heap addresses. global environment is a mapping of plain old strings to heap addresses.
Strings of digits are not considered valid identifiers, so putting them on Strings of digits are not considered valid identifiers, so putting them on
the global environment will never conflict with a supercombinator! We abuse the global environment will never conflict with a supercombinator! We abuse
@@ -303,7 +352,7 @@ Extension Rules
node's address. Consider how this rule might impact garbage collection node's address. Consider how this rule might impact garbage collection
(remember that the environment is intended for *globals*). (remember that the environment is intended for *globals*).
.. math:: .. math::
\gmrule \gmrule
{ \mathtt{PushInt} \; n : i { \mathtt{PushInt} \; n : i
& s & s
@@ -327,10 +376,10 @@ Extension Rules
\text{where $n'$ is the base-10 string rep. of $n$} \text{where $n'$ is the base-10 string rep. of $n$}
} }
2. In order for Extension Rule 1. to be effective, we are also required to take #. In order for the previous rule to be effective, we are also required to take
action when a number already exists in the environment: action when a number already exists in the environment:
.. math:: .. math::
\gmrule \gmrule
{ \mathtt{PushInt} \; n : i { \mathtt{PushInt} \; n : i
& s & s

188
src/GM.hs
View File

@@ -20,9 +20,9 @@ import Text.Printf
import Text.PrettyPrint hiding ((<>)) import Text.PrettyPrint hiding ((<>))
import Text.PrettyPrint.HughesPJ (maybeParens) import Text.PrettyPrint.HughesPJ (maybeParens)
import Data.Foldable (traverse_) import Data.Foldable (traverse_)
import Debug.Trace import Control.Arrow ((>>>))
import System.IO (Handle, hPutStrLn) import System.IO (Handle, hPutStrLn)
import Data.Heap as Heap import Data.Heap
import Core import Core
---------------------------------------------------------------------------------- ----------------------------------------------------------------------------------
@@ -52,8 +52,12 @@ data Instr = Unwind
| Pop Int | Pop Int
| Alloc Int | Alloc Int
| Eval | Eval
-- primitive ops
| Neg
| Add | Add
| Sub
| Mul | Mul
| Div
deriving (Show, Eq) deriving (Show, Eq)
data Node = NNum Int data Node = NNum Int
@@ -123,19 +127,25 @@ isFinal st = null $ st ^. gmCode
step :: GmState -> GmState step :: GmState -> GmState
step st = case head (st ^. gmCode) of step st = case head (st ^. gmCode) of
Unwind -> unwind st Unwind -> unwindI st
PushGlobal n -> pushGlobal n st PushGlobal n -> pushGlobalI n st
PushInt n -> pushInt n st PushInt n -> pushIntI n st
Push n -> push n st Push n -> pushI n st
MkAp -> mkAp st MkAp -> mkApI st
Slide n -> slide n st Slide n -> slideI n st
Pop n -> pop n st Pop n -> popI n st
Update n -> update n st Update n -> updateI n st
Alloc n -> alloc n st Alloc n -> allocI n st
Eval -> evalI st
Neg -> negI st
Add -> addI st
Sub -> subI st
Mul -> mulI st
Div -> divI st
where where
pushGlobal :: Name -> GmState -> GmState pushGlobalI :: Name -> GmState -> GmState
pushGlobal k st = st pushGlobalI k st = st
& gmCode %~ drop 1 & gmCode %~ drop 1
& gmStack .~ s' & gmStack .~ s'
where where
@@ -147,8 +157,8 @@ step st = case head (st ^. gmCode) of
$ lookup k m $ lookup k m
-- Extension Rules 1,2 (sharing) -- Extension Rules 1,2 (sharing)
pushInt :: Int -> GmState -> GmState pushIntI :: Int -> GmState -> GmState
pushInt n st = case lookup n' m of pushIntI n st = case lookup n' m of
Just a -> st Just a -> st
& gmCode %~ drop 1 & gmCode %~ drop 1
& gmStack .~ s' & gmStack .~ s'
@@ -163,7 +173,7 @@ step st = case head (st ^. gmCode) of
& gmStats . stsAllocations %~ succ -- & gmStats . stsAllocations %~ succ --
where where
s' = a : s s' = a : s
(h',a) = Heap.alloc h (NNum n) (h',a) = alloc h (NNum n)
m' = (n',a) : m m' = (n',a) : m
where where
m = st ^. gmEnv m = st ^. gmEnv
@@ -172,8 +182,8 @@ step st = case head (st ^. gmCode) of
n' = show n n' = show n
-- Core Rule 2. (no sharing) -- Core Rule 2. (no sharing)
-- pushInt :: Int -> GmState -> GmState -- pushIntI :: Int -> GmState -> GmState
-- pushInt n st = st -- pushIntI n st = st
-- & gmCode %~ drop 1 -- & gmCode %~ drop 1
-- & gmStack .~ s' -- & gmStack .~ s'
-- & gmHeap .~ h' -- & gmHeap .~ h'
@@ -185,8 +195,8 @@ step st = case head (st ^. gmCode) of
-- s' = a : s -- s' = a : s
-- (h',a) = alloc h (NNum n) -- (h',a) = alloc h (NNum n)
mkAp :: GmState -> GmState mkApI :: GmState -> GmState
mkAp st = st mkApI st = st
& gmCode %~ drop 1 & gmCode %~ drop 1
& gmStack .~ s' & gmStack .~ s'
& gmHeap .~ h' & gmHeap .~ h'
@@ -197,12 +207,12 @@ step st = case head (st ^. gmCode) of
h = st ^. gmHeap h = st ^. gmHeap
s' = a : ss s' = a : ss
(h',a) = Heap.alloc h (NAp f x) (h',a) = alloc h (NAp f x)
-- a `Push n` instruction pushes the address of (n+1)-th argument onto -- a `Push n` instruction pushes the address of (n+1)-th argument onto
-- the stack. -- the stack.
push :: Int -> GmState -> GmState pushI :: Int -> GmState -> GmState
push n st = st pushI n st = st
& gmCode %~ drop 1 & gmCode %~ drop 1
& gmStack %~ (a:) & gmStack %~ (a:)
where where
@@ -218,16 +228,16 @@ step st = case head (st ^. gmCode) of
-- 1: f 1: f x y -- 1: f 1: f x y
-- 2: f x -- 2: f x
-- 3: f x y -- 3: f x y
slide :: Int -> GmState -> GmState slideI :: Int -> GmState -> GmState
slide n st = st slideI n st = st
& gmCode %~ drop 1 & gmCode %~ drop 1
& gmStack .~ s' & gmStack .~ s'
where where
(a:s) = st ^. gmStack (a:s) = st ^. gmStack
s' = a : drop n s s' = a : drop n s
update :: Int -> GmState -> GmState updateI :: Int -> GmState -> GmState
update n st = st updateI n st = st
& gmCode %~ drop 1 & gmCode %~ drop 1
& gmStack .~ s & gmStack .~ s
& gmHeap .~ h' & gmHeap .~ h'
@@ -235,15 +245,15 @@ step st = case head (st ^. gmCode) of
(e:s) = st ^. gmStack (e:s) = st ^. gmStack
an = s !! n an = s !! n
h' = st ^. gmHeap h' = st ^. gmHeap
& Heap.update an (NInd e) & update an (NInd e)
pop :: Int -> GmState -> GmState popI :: Int -> GmState -> GmState
pop n st = st popI n st = st
& gmCode %~ drop 1 & gmCode %~ drop 1
& gmStack %~ drop n & gmStack %~ drop n
alloc :: Int -> GmState -> GmState allocI :: Int -> GmState -> GmState
alloc n st = st allocI n st = st
& gmCode %~ drop 1 & gmCode %~ drop 1
& gmStack .~ s' & gmStack .~ s'
& gmHeap .~ h' & gmHeap .~ h'
@@ -256,14 +266,47 @@ step st = case head (st ^. gmCode) of
allocNode :: Int -> GmHeap -> (GmHeap, [Addr]) allocNode :: Int -> GmHeap -> (GmHeap, [Addr])
allocNode 0 g = (g,[]) allocNode 0 g = (g,[])
allocNode k g = allocNode (k-1) g' & _2 %~ (a:) allocNode k g = allocNode (k-1) g' & _2 %~ (a:)
where (g',a) = Heap.alloc g NUninitialised where (g',a) = alloc g NUninitialised
evalI :: GmState -> GmState
evalI st = st
-- Unwind performs the actual evaluation; we just set the stage
-- so Unwind knows what to do
& gmCode .~ [Unwind]
-- leave lone scrutinee on stk to be eval'd by Unwind
& gmStack .~ [a]
-- push remaining code & stk to dump
& gmDump %~ ((i,s):)
where
(_:i) = st ^. gmCode
(a:s) = st ^. gmStack
negI :: GmState -> GmState
negI = primitive1 boxInt unboxInt negate
addI, subI, mulI, divI :: GmState -> GmState
addI = primitive2 boxInt unboxInt (+)
subI = primitive2 boxInt unboxInt (-)
mulI = primitive2 boxInt unboxInt (*)
divI = primitive2 boxInt unboxInt div
-- the complex heart of the G-machine -- the complex heart of the G-machine
unwind :: GmState -> GmState unwindI :: GmState -> GmState
unwind st = case hLookupUnsafe a h of unwindI st = case hLookupUnsafe a h of
NNum n -> st NNum n -> st
-- halt; discard all further instructions & gmCode .~ i'
& gmCode .~ [] & gmStack .~ s'
& gmDump .~ d'
where
s = st ^. gmStack
(i',s',d') = case st ^. gmDump of
-- if the dump is non-empty, restore the instruction
-- queue and stack, and pop the dump
((ii,ss):d) -> (ii,a:ss,d)
-- if the dump is empty, clear the instruction queue and
-- leave the stack as is
[] -> ([], s, [])
NAp f x -> st NAp f x -> st
-- leave the Unwind instr; continue unwinding -- leave the Unwind instr; continue unwinding
& gmStack %~ (f:) & gmStack %~ (f:)
@@ -293,6 +336,56 @@ step st = case head (st ^. gmCode) of
a = head s a = head s
h = st ^. gmHeap h = st ^. gmHeap
-- TODO: this desperately needs documentation
primitive1 :: (GmState -> b -> GmState) -- boxing function
-> (Addr -> GmState -> a) -- unboxing function
-> (a -> b) -- operator
-> GmState -> GmState -- state transition
primitive1 box unbox f st
= st
& unbox a
& f
& box (st & gmStack .~ s)
& advanceCode
where
putNewStack = gmStack .~ s
(a:s) = st ^. gmStack
r = box (putNewStack st) (f (unbox a st))
-- TODO: this desperately needs documentation
primitive2 :: (GmState -> b -> GmState) -- boxing function
-> (Addr -> GmState -> a) -- unboxing function
-> (a -> a -> b) -- operator
-> GmState -> GmState -- state transition
primitive2 box unbox f st
= st'
& advanceCode
where
(ax:ay:s) = st ^. gmStack
putNewStack = gmStack .~ s
x = unbox ax st
y = unbox ay st
st' = box (putNewStack st) (f x y)
boxInt :: GmState -> Int -> GmState
boxInt st n = st
& gmHeap .~ h'
& gmStack %~ (a:)
where
h = st ^. gmHeap
(h',a) = alloc h (NNum n)
unboxInt :: Addr -> GmState -> Int
unboxInt a st = case hLookup a h of
Just (NNum n) -> n
Just _ -> error "unboxInt received a non-int"
Nothing -> error "unboxInt received an invalid address"
where h = st ^. gmHeap
advanceCode :: GmState -> GmState
advanceCode = gmCode %~ drop 1
---------------------------------------------------------------------------------- ----------------------------------------------------------------------------------
compile :: Program -> GmState compile :: Program -> GmState
@@ -305,10 +398,25 @@ compile p = GmState c [] [] h g sts
type CompiledSC = (Name, Int, Code) type CompiledSC = (Name, Int, Code)
buildInitialHeap :: Program -> (GmHeap, Env) compiledPrims :: [CompiledSC]
buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiled compiledPrims =
[ ("whnf#", 1, [Push 0, Eval, Update 1, Pop 1, Unwind])
-- , unop "negate#" Neg
, ("negate#", 1, [Push 0, Eval, Neg, Update 1, Pop 1, Unwind])
, binop "+#" Add
, binop "-#" Sub
, binop "*#" Mul
, binop "/#" Div
]
where where
compiled = fmap compileSc ss unop k i = (k, 1, [Push 0, Eval, i, Update 1, Pop 1, Unwind])
binop k i = (k, 2, [Push 1, Eval, Push 1, Eval, i, Update 2, Pop 2, Unwind])
buildInitialHeap :: Program -> (GmHeap, Env)
buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs
where
compiledScs = fmap compileSc ss <> compiledPrims
-- note that we don't count sc allocations in the stats -- note that we don't count sc allocations in the stats
allocateSc :: GmHeap -> CompiledSC -> (GmHeap, (Name, Addr)) allocateSc :: GmHeap -> CompiledSC -> (GmHeap, (Name, Addr))