From ed8075a65f7209b0ca1b745d3a20dafc020e8ac3 Mon Sep 17 00:00:00 2001 From: crumbtoo Date: Wed, 6 Dec 2023 19:09:40 -0700 Subject: [PATCH] fixup fixup --- src/Data/Heap.hs | 5 +++-- src/GM.hs | 8 +++++--- 2 files changed, 8 insertions(+), 5 deletions(-) diff --git a/src/Data/Heap.hs b/src/Data/Heap.hs index 77bddd7..2fa28de 100644 --- a/src/Data/Heap.hs +++ b/src/Data/Heap.hs @@ -24,7 +24,7 @@ module Data.Heap ---------------------------------------------------------------------------------- import Data.Map (Map, (!?)) import Debug.Trace -import Data.Map qualified as M +import Data.Map.Strict qualified as M import Data.List (intersect) import GHC.Stack (HasCallStack) ---------------------------------------------------------------------------------- @@ -60,10 +60,11 @@ instance Traversable Heap where alloc :: Heap a -> a -> (Heap a, Addr) 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 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 k f (Heap u m) = Heap u (M.adjust f k m) diff --git a/src/GM.hs b/src/GM.hs index 6c55718..1f7cb37 100644 --- a/src/GM.hs +++ b/src/GM.hs @@ -25,6 +25,7 @@ import Data.Foldable (traverse_) import System.IO (Handle, hPutStrLn) import Data.String (IsString) import Data.Heap +import Debug.Trace import Core ---------------------------------------------------------------------------------- @@ -181,10 +182,11 @@ step st = case head (st ^. gmCode) of packI :: Tag -> Int -> GmState packI t n = st & advanceCode - & gmStack %~ (a:) + & gmStack .~ s' & gmHeap .~ h' where (as,s) = splitAt n (st ^. gmStack) + s' = a:s (h',a) = alloc (st ^. gmHeap) $ NConstr t as pushGlobalI :: Name -> GmState @@ -305,8 +307,8 @@ step st = case head (st ^. gmCode) of where (e:s) = st ^. gmStack an = s !! n - h' = st ^. gmHeap - & update an (NInd e) + h = st ^. gmHeap + h' = h `seq` update an (NInd e) h popI :: Int -> GmState popI n = st