diff --git a/docs/src/commentary/gm.rst b/docs/src/commentary/gm.rst index 3757a59..962c8b1 100644 --- a/docs/src/commentary/gm.rst +++ b/docs/src/commentary/gm.rst @@ -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 + } diff --git a/docs/src/conf.py b/docs/src/conf.py index 7013b9a..9d5374d 100644 --- a/docs/src/conf.py +++ b/docs/src/conf.py @@ -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}{[\,]} ''' diff --git a/rlp.cabal b/rlp.cabal index 3d6efbf..acff6e4 100644 --- a/rlp.cabal +++ b/rlp.cabal @@ -20,6 +20,7 @@ library import: warnings exposed-modules: Core , TIM + , GM , Compiler.RLPC other-modules: Data.Heap diff --git a/src/GM.hs b/src/GM.hs new file mode 100644 index 0000000..adac732 --- /dev/null +++ b/src/GM.hs @@ -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) + diff --git a/src/TIM.hs b/src/TIM.hs index 1bad037..ecc8133 100644 --- a/src/TIM.hs +++ b/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