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

fixup

Browse Source 
fixup
This commit is contained in:
crumbtoo
2023-12-06 19:09:40 -07:00
parent 38e42752cf
commit ed8075a65f
2 changed files with 8 additions and 5 deletions
Download Patch File Download Diff File Expand all files Collapse all files

5
src/Data/Heap.hs
View File

@@ -24,7 +24,7 @@ module Data.Heap
---------------------------------------------------------------------------------- ----------------------------------------------------------------------------------
import Data.Map (Map, (!?)) import Data.Map (Map, (!?))
import Debug.Trace import Debug.Trace
import Data.Map qualified as M import Data.Map.Strict qualified as M
import Data.List (intersect) import Data.List (intersect)
import GHC.Stack (HasCallStack) import GHC.Stack (HasCallStack)
---------------------------------------------------------------------------------- ----------------------------------------------------------------------------------
@@ -60,10 +60,11 @@ instance Traversable Heap where
alloc :: Heap a -> a -> (Heap a, Addr) alloc :: Heap a -> a -> (Heap a, Addr)
alloc (Heap (u:us) m) v = (Heap us (M.insert u v m), u) alloc (Heap (u:us) m) v = (Heap us (M.insert u v m), u)
alloc (Heap [] _) _ = error "STG heap model ran out of memory..." alloc (Heap [] _) _ = error "heap model ran out of memory..."
update :: Addr -> a -> Heap a -> Heap a update :: Addr -> a -> Heap a -> Heap a
update k v (Heap u m) = Heap u (M.adjust (const v) k m) update k v (Heap u m) = Heap u (M.adjust (const v) k m)
-- update k v (Heap u m) = Heap u (M.adjust (undefined) k m)
adjust :: Addr -> (a -> a) -> Heap a -> Heap a adjust :: Addr -> (a -> a) -> Heap a -> Heap a
adjust k f (Heap u m) = Heap u (M.adjust f k m) adjust k f (Heap u m) = Heap u (M.adjust f k m)

8
src/GM.hs
View File

@@ -25,6 +25,7 @@ import Data.Foldable (traverse_)
import System.IO (Handle, hPutStrLn) import System.IO (Handle, hPutStrLn)
import Data.String (IsString) import Data.String (IsString)
import Data.Heap import Data.Heap
import Debug.Trace
import Core import Core
---------------------------------------------------------------------------------- ----------------------------------------------------------------------------------
@@ -181,10 +182,11 @@ step st = case head (st ^. gmCode) of
packI :: Tag -> Int -> GmState packI :: Tag -> Int -> GmState
packI t n = st packI t n = st
& advanceCode & advanceCode
& gmStack %~ (a:) & gmStack .~ s'
& gmHeap .~ h' & gmHeap .~ h'
where where
(as,s) = splitAt n (st ^. gmStack) (as,s) = splitAt n (st ^. gmStack)
s' = a:s
(h',a) = alloc (st ^. gmHeap) $ NConstr t as (h',a) = alloc (st ^. gmHeap) $ NConstr t as
pushGlobalI :: Name -> GmState pushGlobalI :: Name -> GmState
@@ -305,8 +307,8 @@ step st = case head (st ^. gmCode) of
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) h' = h `seq` update an (NInd e) h
popI :: Int -> GmState popI :: Int -> GmState
popI n = st popI n = st