begin gm
This commit is contained in:
crumbtoo
@@ -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
|
||||
}
|
||||
|
||||
|
||||
@@ -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}{[\,]}
|
||||
'''
|
||||
|
||||
|
||||
@@ -20,6 +20,7 @@ library
|
||||
import: warnings
|
||||
exposed-modules: Core
|
||||
, TIM
|
||||
, GM
|
||||
, Compiler.RLPC
|
||||
|
||||
other-modules: Data.Heap
|
||||
|
||||
216
src/GM.hs
Normal file
216
src/GM.hs
Normal file
@@ -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)
|
||||
|
||||
10
src/TIM.hs
10
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
|
||||
rootAddr = (s !! length as)
|
||||
h' = instantiateU e rootAddr h env
|
||||
s' = rootAddr : drop (length as + 1) s -- 3., 4.
|
||||
h' = instantiateU e rootAddr h env -- 2.
|
||||
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
|
||||
|
||||
Reference in New Issue
Block a user