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

finally fix dispatch scope

Browse Source
This commit is contained in:
crumbtoo
2023-12-06 11:23:44 -07:00
parent 1b51ee0c64
commit 87d3aac1fb
1 changed files with 85 additions and 80 deletions
Download Patch File Download Diff File Expand all files Collapse all files

165
src/GM.hs
View File

@@ -50,6 +50,7 @@ data Key = NameKey Name
data Instr = Unwind data Instr = Unwind
| PushGlobal Name | PushGlobal Name
| PushConstr Tag Int
| PushInt Int | PushInt Int
| Push Int | Push Int
| MkAp | MkAp
@@ -142,31 +143,32 @@ isFinal :: GmState -> Bool
isFinal st = null $ st ^. gmCode isFinal st = null $ st ^. gmCode
step :: GmState -> GmState step :: GmState -> GmState
step state = case head (state ^. gmCode) of step st = case head (st ^. gmCode) of
-- TODO: clean this up. let transition functions use the 'state' parameter -- TODO: clean this up. let transition functions use the 'state' parameter
-- instead of passing it to them. -- instead of passing it to them.
Unwind -> unwindI state Unwind -> unwindI
PushGlobal n -> pushGlobalI n state PushGlobal n -> pushGlobalI n
PushInt n -> pushIntI n state PushConstr t n -> pushConstrI t n
Push n -> pushI n state PushInt n -> pushIntI n
MkAp -> mkApI state Push n -> pushI n
Slide n -> slideI n state MkAp -> mkApI
Pop n -> popI n state Slide n -> slideI n
Update n -> updateI n state Pop n -> popI n
Alloc n -> allocI n state Update n -> updateI n
Eval -> evalI state Alloc n -> allocI n
Neg -> negI state Eval -> evalI
Add -> addI state Neg -> negI
Sub -> subI state Add -> addI
Mul -> mulI state Sub -> subI
Div -> divI state Mul -> mulI
Split n -> splitI n state Div -> divI
Split n -> splitI n
where where
pushGlobalI :: Name -> GmState -> GmState pushGlobalI :: Name -> GmState
pushGlobalI k st = st pushGlobalI k = st
& advanceCode & advanceCode
& gmStack .~ s' & gmStack .~ s'
where where
s = st ^. gmStack s = st ^. gmStack
m = st ^. gmEnv m = st ^. gmEnv
@@ -175,9 +177,12 @@ step state = case head (state ^. gmCode) of
a = lookupN k m a = lookupN k m
& fromMaybe (error $ "undefined var: " <> show k) & fromMaybe (error $ "undefined var: " <> show k)
pushConstrI :: Tag -> Int -> GmState
pushConstrI = undefined
-- Extension Rules 1,2 (sharing) -- Extension Rules 1,2 (sharing)
pushIntI :: Int -> GmState -> GmState pushIntI :: Int -> GmState
pushIntI n st = case lookupN n' m of pushIntI n = case lookupN n' m of
Just a -> st Just a -> st
& advanceCode & advanceCode
& gmStack .~ s' & gmStack .~ s'
@@ -201,12 +206,12 @@ step state = case head (state ^. gmCode) of
n' = show n n' = show n
-- Core Rule 2. (no sharing) -- Core Rule 2. (no sharing)
-- pushIntI :: Int -> GmState -> GmState -- pushIntI :: Int -> GmState
-- pushIntI n st = st -- pushIntI n = st
-- & advanceCode -- & advanceCode
-- & gmStack .~ s' -- & gmStack .~ s'
-- & gmHeap .~ h' -- & gmHeap .~ h'
-- & gmStats . stsAllocations %~ succ -- & gmStats . stsAllocations %~ succ
-- where -- where
-- s = st ^. gmStack -- s = st ^. gmStack
-- h = st ^. gmHeap -- h = st ^. gmHeap
@@ -214,13 +219,13 @@ step state = case head (state ^. gmCode) of
-- s' = a : s -- s' = a : s
-- (h',a) = alloc h (NNum n) -- (h',a) = alloc h (NNum n)
mkApI :: GmState -> GmState mkApI :: GmState
mkApI st = st mkApI = st
& advanceCode & advanceCode
& gmStack .~ s' & gmStack .~ s'
& gmHeap .~ h' & gmHeap .~ h'
-- record the application we allocated -- record the application we allocated
& gmStats . stsAllocations %~ succ & gmStats . stsAllocations %~ succ
where where
(f:x:ss) = st ^. gmStack (f:x:ss) = st ^. gmStack
h = st ^. gmHeap h = st ^. gmHeap
@@ -230,10 +235,10 @@ step state = case head (state ^. gmCode) of
-- 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.
pushI :: Int -> GmState -> GmState pushI :: Int -> GmState
pushI n st = st pushI n = st
& advanceCode & advanceCode
& gmStack %~ (a:) & gmStack %~ (a:)
where where
s = st ^. gmStack s = st ^. gmStack
a = s !! n a = s !! n
@@ -246,35 +251,35 @@ step state = case head (state ^. 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
slideI :: Int -> GmState -> GmState slideI :: Int -> GmState
slideI n st = st slideI n = st
& advanceCode & advanceCode
& gmStack .~ s' & gmStack .~ s'
where where
(a:s) = st ^. gmStack (a:s) = st ^. gmStack
s' = a : drop n s s' = a : drop n s
updateI :: Int -> GmState -> GmState updateI :: Int -> GmState
updateI n st = st updateI n = st
& advanceCode & advanceCode
& gmStack .~ s & gmStack .~ s
& gmHeap .~ h' & gmHeap .~ h'
where where
(e:s) = st ^. gmStack (e:s) = st ^. gmStack
an = s !! n an = s !! n
h' = st ^. gmHeap h' = st ^. gmHeap
& update an (NInd e) & update an (NInd e)
popI :: Int -> GmState -> GmState popI :: Int -> GmState
popI n st = st popI n = st
& advanceCode & advanceCode
& gmStack %~ drop n & gmStack %~ drop n
allocI :: Int -> GmState -> GmState allocI :: Int -> GmState
allocI n st = st allocI n = st
& advanceCode & advanceCode
& gmStack .~ s' & gmStack .~ s'
& gmHeap .~ h' & gmHeap .~ h'
where where
s = st ^. gmStack s = st ^. gmStack
h = st ^. gmHeap h = st ^. gmHeap
@@ -286,32 +291,32 @@ step state = case head (state ^. gmCode) of
allocNode k g = allocNode (k-1) g' & _2 %~ (a:) allocNode k g = allocNode (k-1) g' & _2 %~ (a:)
where (g',a) = alloc g NUninitialised where (g',a) = alloc g NUninitialised
evalI :: GmState -> GmState evalI :: GmState
evalI st = st evalI = st
-- Unwind performs the actual evaluation; we just set the stage -- Unwind performs the actual evaluation; we just set the stage
-- so Unwind knows what to do -- so Unwind knows what to do
& gmCode .~ [Unwind] & gmCode .~ [Unwind]
-- leave lone scrutinee on stk to be eval'd by Unwind -- leave lone scrutinee on stk to be eval'd by Unwind
& gmStack .~ [a] & gmStack .~ [a]
-- push remaining code & stk to dump -- push remaining code & stk to dump
& gmDump %~ ((i,s):) & gmDump %~ ((i,s):)
where where
(_:i) = st ^. gmCode (_:i) = st ^. gmCode
(a:s) = st ^. gmStack (a:s) = st ^. gmStack
negI :: GmState -> GmState negI :: GmState
negI = primitive1 boxInt unboxInt negate negI = primitive1 boxInt unboxInt negate st
addI, subI, mulI, divI :: GmState -> GmState addI, subI, mulI, divI :: GmState
addI = primitive2 boxInt unboxInt (+) addI = primitive2 boxInt unboxInt (+) st
subI = primitive2 boxInt unboxInt (-) subI = primitive2 boxInt unboxInt (-) st
mulI = primitive2 boxInt unboxInt (*) mulI = primitive2 boxInt unboxInt (*) st
divI = primitive2 boxInt unboxInt div divI = primitive2 boxInt unboxInt div st
splitI :: Int -> GmState -> GmState splitI :: Int -> GmState
splitI n st = st splitI n = st
& advanceCode & advanceCode
& gmStack .~ s' & gmStack .~ s'
where where
h = st ^. gmHeap h = st ^. gmHeap
(a:s) = st ^. gmStack (a:s) = st ^. gmStack
@@ -319,8 +324,8 @@ step state = case head (state ^. gmCode) of
NConstr _ components = hLookupUnsafe a h NConstr _ components = hLookupUnsafe a h
-- the complex heart of the G-machine -- the complex heart of the G-machine
unwindI :: GmState -> GmState unwindI :: GmState
unwindI st = case hLookupUnsafe a h of unwindI = case hLookupUnsafe a h of
NNum _ -> st NNum _ -> st
& gmCode .~ i' & gmCode .~ i'
& gmStack .~ s' & gmStack .~ s'