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

use Key to index Env

Browse Source
This commit is contained in:
crumbtoo
2023-12-06 11:17:26 -07:00
parent 3a17eb473f
commit 1b51ee0c64
1 changed files with 74 additions and 22 deletions
Download Patch File Download Diff File Expand all files Collapse all files

96
src/GM.hs
View File

@@ -3,7 +3,7 @@ Module : GM
Description : The G-Machine Description : The G-Machine
-} -}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE ViewPatterns, LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
module GM module GM
( hdbgProg ( hdbgProg
@@ -14,7 +14,7 @@ module GM
---------------------------------------------------------------------------------- ----------------------------------------------------------------------------------
import Data.Default.Class import Data.Default.Class
import Data.List (mapAccumL) import Data.List (mapAccumL)
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe, mapMaybe)
import Data.Tuple (swap) import Data.Tuple (swap)
import Lens.Micro import Lens.Micro
import Lens.Micro.TH import Lens.Micro.TH
@@ -41,9 +41,13 @@ data GmState = GmState
type Code = [Instr] type Code = [Instr]
type Stack = [Addr] type Stack = [Addr]
type Dump = [(Code, Stack)] type Dump = [(Code, Stack)]
type Env = [(Name, Addr)] type Env = [(Key, Addr)]
type GmHeap = Heap Node type GmHeap = Heap Node
data Key = NameKey Name
| ConstrKey Tag Int
deriving (Show, Eq)
data Instr = Unwind data Instr = Unwind
| PushGlobal Name | PushGlobal Name
| PushInt Int | PushInt Int
@@ -54,10 +58,10 @@ data Instr = Unwind
| Pop Int | Pop Int
| Alloc Int | Alloc Int
| Eval | Eval
-- primitive ops -- arith
| Neg | Add | Sub | Mul | Div | Neg | Add | Sub | Mul | Div
| Pack Int Int -- Pack Tag Arity | Pack Tag Int -- Pack Tag Arity
| CaseJump [(Int, Code)] | CaseJump [(Tag, Code)]
| Split Int | Split Int
deriving (Show, Eq) deriving (Show, Eq)
@@ -69,9 +73,10 @@ data Node = NNum Int
| NGlobal Int Code | NGlobal Int Code
| NInd Addr | NInd Addr
| NUninitialised | NUninitialised
| NConstr Int [Addr] -- NConstr Tag Components | NConstr Tag [Addr] -- NConstr Tag Components
deriving (Show, Eq) deriving (Show, Eq)
-- TODO: log executed instructions
data Stats = Stats data Stats = Stats
{ _stsReductions :: Int { _stsReductions :: Int
, _stsPrimReductions :: Int , _stsPrimReductions :: Int
@@ -138,6 +143,8 @@ isFinal st = null $ st ^. gmCode
step :: GmState -> GmState step :: GmState -> GmState
step state = case head (state ^. gmCode) of step state = case head (state ^. gmCode) of
-- TODO: clean this up. let transition functions use the 'state' parameter
-- instead of passing it to them.
Unwind -> unwindI state Unwind -> unwindI state
PushGlobal n -> pushGlobalI n state PushGlobal n -> pushGlobalI n state
PushInt n -> pushIntI n state PushInt n -> pushIntI n state
@@ -153,6 +160,7 @@ step state = case head (state ^. gmCode) of
Sub -> subI state Sub -> subI state
Mul -> mulI state Mul -> mulI state
Div -> divI state Div -> divI state
Split n -> splitI n state
where where
pushGlobalI :: Name -> GmState -> GmState pushGlobalI :: Name -> GmState -> GmState
@@ -164,12 +172,12 @@ step state = case head (state ^. gmCode) of
m = st ^. gmEnv m = st ^. gmEnv
s' = a : s s' = a : s
a = lookup k m a = lookupN k m
& fromMaybe (error $ "undefined var: " <> show k) & fromMaybe (error $ "undefined var: " <> show k)
-- Extension Rules 1,2 (sharing) -- Extension Rules 1,2 (sharing)
pushIntI :: Int -> GmState -> GmState pushIntI :: Int -> GmState -> GmState
pushIntI n st = case lookup n' m of pushIntI n st = case lookupN n' m of
Just a -> st Just a -> st
& advanceCode & advanceCode
& gmStack .~ s' & gmStack .~ s'
@@ -185,7 +193,7 @@ step state = case head (state ^. gmCode) of
where where
s' = a : s s' = a : s
(h',a) = alloc h (NNum n) (h',a) = alloc h (NNum n)
m' = (n',a) : m m' = (NameKey n', a) : m
where where
m = st ^. gmEnv m = st ^. gmEnv
s = st ^. gmStack s = st ^. gmStack
@@ -216,7 +224,7 @@ step state = case head (state ^. gmCode) of
where where
(f:x:ss) = st ^. gmStack (f:x:ss) = st ^. gmStack
h = st ^. gmHeap h = st ^. gmHeap
s' = a : ss s' = a : ss
(h',a) = alloc h (NAp f x) (h',a) = alloc h (NAp f x)
@@ -300,6 +308,16 @@ step state = case head (state ^. gmCode) of
mulI = primitive2 boxInt unboxInt (*) mulI = primitive2 boxInt unboxInt (*)
divI = primitive2 boxInt unboxInt div divI = primitive2 boxInt unboxInt div
splitI :: Int -> GmState -> GmState
splitI n st = st
& advanceCode
& gmStack .~ s'
where
h = st ^. gmHeap
(a:s) = st ^. gmStack
s' = components ++ s
NConstr _ components = hLookupUnsafe a h
-- the complex heart of the G-machine -- the complex heart of the G-machine
unwindI :: GmState -> GmState unwindI :: GmState -> GmState
unwindI st = case hLookupUnsafe a h of unwindI st = case hLookupUnsafe a h of
@@ -446,8 +464,8 @@ buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs
compiledScs = fmap compileSc ss <> compiledPrims 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, (Key, Addr))
allocateSc h (n,d,c) = (h', (n, a)) allocateSc h (n,d,c) = (h', (NameKey n, a))
where (h',a) = alloc h $ NGlobal d c where (h',a) = alloc h $ NGlobal d c
-- >> [ref/compileSc] -- >> [ref/compileSc]
@@ -456,7 +474,7 @@ buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs
compileSc :: ScDef -> CompiledSC compileSc :: ScDef -> CompiledSC
compileSc (ScDef n as b) = (n, d, compileR env b) compileSc (ScDef n as b) = (n, d, compileR env b)
where where
env = as `zip` [0..] env = (NameKey <$> as) `zip` [0..]
d = length as d = length as
-- << [ref/compileSc] -- << [ref/compileSc]
@@ -471,8 +489,10 @@ buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs
| k `elem` domain = [Push n] | k `elem` domain = [Push n]
| otherwise = [PushGlobal k] | otherwise = [PushGlobal k]
where where
n = fromMaybe (error $ "undeclared var: " <> k) $ lookup k g n = fromMaybe (error $ "undeclared var: " <> k) $ lookupN k g
domain = fmap fst g domain = f `mapMaybe` g
f (NameKey n, _) = Just n
f _ = Nothing
compileC _ (IntE n) = [PushInt n] compileC _ (IntE n) = [PushInt n]
@@ -493,7 +513,7 @@ buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs
compileBinder :: Env -> (Binding, Int) -> (Env, Code) compileBinder :: Env -> (Binding, Int) -> (Env, Code)
compileBinder m (k := v, a) = (m',c) compileBinder m (k := v, a) = (m',c)
where where
m' = (k,a) : m m' = (NameKey k, a) : m
-- make note that we use m rather than m'! -- make note that we use m rather than m'!
c = compileC m v c = compileC m v
@@ -501,7 +521,7 @@ buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs
where where
d = length bs d = length bs
g' = fmap toEnv addressed ++ argOffset d g g' = fmap toEnv addressed ++ argOffset d g
toEnv (k := _, a) = (k,a) toEnv (k := _, a) = (NameKey k, a)
-- kinda gross. revisit this -- kinda gross. revisit this
addressed = bs `zip` reverse [0 .. d-1] addressed = bs `zip` reverse [0 .. d-1]
@@ -511,6 +531,10 @@ buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs
compileBinder :: (Binding, Int) -> Code compileBinder :: (Binding, Int) -> Code
compileBinder (_ := v, a) = compileC g' v <> [Update a] compileBinder (_ := v, a) = compileC g' v <> [Update a]
-- kinda evil; better system eventually
compileC g (Con t n) = [PushGlobal p]
where p = idPack t n
compileC _ _ = error "yet to be implemented!" compileC _ _ = error "yet to be implemented!"
-- compile an expression in a strict context such that a pointer to the -- compile an expression in a strict context such that a pointer to the
@@ -529,7 +553,7 @@ buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs
compileBinder :: Env -> (Binding, Int) -> (Env, Code) compileBinder :: Env -> (Binding, Int) -> (Env, Code)
compileBinder m (k := v, a) = (m',c) compileBinder m (k := v, a) = (m',c)
where where
m' = (k,a) : m m' = (NameKey k, a) : m
-- make note that we use m rather than m'! -- make note that we use m rather than m'!
c = compileC m v c = compileC m v
@@ -538,7 +562,7 @@ buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs
where where
d = length bs d = length bs
g' = fmap toEnv addressed ++ argOffset d g g' = fmap toEnv addressed ++ argOffset d g
toEnv (k := _, a) = (k,a) toEnv (k := _, a) = (NameKey k, a)
-- kinda gross. revisit this -- kinda gross. revisit this
addressed = bs `zip` reverse [0 .. d-1] addressed = bs `zip` reverse [0 .. d-1]
initialisers = mconcat $ compileBinder <$> addressed initialisers = mconcat $ compileBinder <$> addressed
@@ -550,19 +574,37 @@ buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs
compileBinder :: (Binding, Int) -> Code compileBinder :: (Binding, Int) -> Code
compileBinder (_ := v, a) = compileC g' v <> [Update a] compileBinder (_ := v, a) = compileC g' v <> [Update a]
-- special cases for prim functions -- special cases for prim functions; essentially inlining
compileE g ("negate#" :$ a) = compileE g a <> [Neg] compileE g ("negate#" :$ a) = compileE g a <> [Neg]
compileE g ("+#" :$ a :$ b) = compileE g a <> compileE g b <> [Add] compileE g ("+#" :$ a :$ b) = compileE g a <> compileE g b <> [Add]
compileE g ("-#" :$ a :$ b) = compileE g a <> compileE g b <> [Sub] compileE g ("-#" :$ a :$ b) = compileE g a <> compileE g b <> [Sub]
compileE g ("*#" :$ a :$ b) = compileE g a <> compileE g b <> [Mul] compileE g ("*#" :$ a :$ b) = compileE g a <> compileE g b <> [Mul]
compileE g ("/#" :$ a :$ b) = compileE g a <> compileE g b <> [Div] compileE g ("/#" :$ a :$ b) = compileE g a <> compileE g b <> [Div]
compileE g (Case e as) = compileE g e <> [CaseJump (compileD g as)]
-- TODO: inline case for satiated Con applications
-- compileE g (Con t n) =
compileE g e = compileC g e ++ [Eval] compileE g e = compileC g e ++ [Eval]
compileD :: Env -> [Alter] -> [(Tag, Code)]
compileD g as = fmap (compileA g) as
compileA :: Env -> Alter -> (Tag, Code)
compileA g (Alter t as e) = (t, [Split n] <> c <> [Slide n])
where
n = length as
binds = (NameKey <$> as) `zip` [0..]
g' = binds ++ argOffset n g
c = compileE g' e
-- | offset each address in the environment by n -- | offset each address in the environment by n
argOffset :: Int -> Env -> Env argOffset :: Int -> Env -> Env
argOffset n = each . _2 %~ (+n) argOffset n = each . _2 %~ (+n)
idPack :: Tag -> Int -> String
idPack t n = printf "Pack{%d,%d}" t n
---------------------------------------------------------------------------------- ----------------------------------------------------------------------------------
pprTabstop :: Int pprTabstop :: Int
@@ -680,7 +722,9 @@ showNodeAtP p st a = case hLookup a h of
Just (NGlobal _ _) -> text name Just (NGlobal _ _) -> text name
where where
g = st ^. gmEnv g = st ^. gmEnv
name = fromMaybe errTxtInvalidAddress $ lookup a (swap <$> g) name = case lookup a (swap <$> g) of
Just (NameKey n) -> n
_ -> errTxtInvalidAddress
Just (NAp f x) -> pprec $ showNodeAtP (p+1) st f <+> showNodeAtP (p+1) st x Just (NAp f x) -> pprec $ showNodeAtP (p+1) st f <+> showNodeAtP (p+1) st x
where pprec = maybeParens (p > 0) where pprec = maybeParens (p > 0)
Just (NInd a') -> pprec $ "NInd -> " <> showNodeAtP (p+1) st a' Just (NInd a') -> pprec $ "NInd -> " <> showNodeAtP (p+1) st a'
@@ -713,3 +757,11 @@ showInstr (CaseJump alts) = "CaseJump" $$ nest pprTabstop alternatives
alternatives = foldr (\a acc -> showAlt a $$ acc) mempty alts alternatives = foldr (\a acc -> showAlt a $$ acc) mempty alts
showInstr i = text $ show i showInstr i = text $ show i
----------------------------------------------------------------------------------
lookupN :: Name -> Env -> Maybe Addr
lookupN k = lookup (NameKey k)
lookupC :: Tag -> Int -> Env -> Maybe Addr
lookupC t n = lookup (ConstrKey t n)