From d84fe56fbb7f7f06b1a228322040666de66a3a5c Mon Sep 17 00:00:00 2001 From: crumbtoo Date: Thu, 23 Nov 2023 00:56:47 -0700 Subject: [PATCH] pairs :3 --- app/Main.hs | 2 +- docs/src/commentary/stg.rst | 2 +- src/Core/Examples.hs | 6 +++--- src/Data/Heap.hs | 10 +++++----- src/TIM.hs | 37 +++++++++++++++++++++++-------------- 5 files changed, 33 insertions(+), 24 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index 014e204..78b53fd 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -55,7 +55,7 @@ whenView l m = view l >>= \a -> when a m dumpEval :: RLPCIO () () dumpEval = whenView rlpcDumpEval do fs <- view rlpcInputFiles - forM_ fs $ \f -> liftIO (readFile f) >>= doProg + forM_ fs $ \f -> liftIO (readFile f) >>= doProg where doProg :: String -> RLPCIO () () diff --git a/docs/src/commentary/stg.rst b/docs/src/commentary/stg.rst index 622ae26..6e09367 100644 --- a/docs/src/commentary/stg.rst +++ b/docs/src/commentary/stg.rst @@ -277,7 +277,7 @@ Perform the reduction if the first argument is in normal form \end{bmatrix} & g } - { a_2 : s + { a_1 : a_2 : s & d & h \begin{bmatrix} diff --git a/src/Core/Examples.hs b/src/Core/Examples.hs index 529e164..8a334f2 100644 --- a/src/Core/Examples.hs +++ b/src/Core/Examples.hs @@ -12,13 +12,13 @@ letrecExample :: Program letrecExample = [coreProg| pair x y f = f x y - fst p = p k - snd p = p k1 + fst' p = p k + snd' p = p k1 f x y = letrec a = pair x b b = pair y a - in fst (snd (snd (snd a))); + in fst' (snd' (snd' (snd' a))); main = f 3 4; |] diff --git a/src/Data/Heap.hs b/src/Data/Heap.hs index 9acd7b9..74f07ad 100644 --- a/src/Data/Heap.hs +++ b/src/Data/Heap.hs @@ -47,13 +47,13 @@ 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 "STG heap model ran out of memory..." -update :: Heap a -> Addr -> a -> Heap a -update (Heap u m) k v = Heap u (M.adjust (const v) k m) +update :: Addr -> a -> Heap a -> Heap a +update k v (Heap u m) = Heap u (M.adjust (const v) k m) -free :: Heap a -> Addr -> Heap a -free (Heap u m) k = Heap (k:u) (M.delete k m) +free :: Addr -> Heap a -> Heap a +free k (Heap u m) = Heap (k:u) (M.delete k m) hLookup :: Addr -> Heap a -> Maybe a hLookup k (Heap _ m) = m !? k diff --git a/src/TIM.hs b/src/TIM.hs index 2c7aa40..ae3988f 100644 --- a/src/TIM.hs +++ b/src/TIM.hs @@ -145,18 +145,18 @@ instantiate _ _ _ = error "unimplemented" -- instantiate and update instantiateU :: Expr -> Addr -> TiHeap -> [(Name, Addr)] -> TiHeap -instantiateU (App f x) root h g = update h'' root (NAp f' x') +instantiateU (App f x) root h g = update root (NAp f' x') h'' where (h',f') = instantiate f h g (h'',x') = instantiate x h' g instantiateU (Case _ _) _ _ _ = error "cannot instantiate case expressions" -instantiateU (Con t a) root h g = update h root c +instantiateU (Con t a) root h g = update root c h where c = NPrim "Pack" (ConP t a) -instantiateU (Var k) root h g = update h' root (NInd a) +instantiateU (Var k) root h g = update root (NInd a) h' where (h',a) = instantiate (Var k) h g -- i don't really know if this is correct tbh i'm gonna cry @@ -170,7 +170,7 @@ instantiateU (Let NonRec bs e) root h g = h'' let (h',a) = instantiate v h g in (h',(k,a)) -instantiateU (IntE n) root h _ = update h root (NNum n) +instantiateU (IntE n) root h _ = update root (NNum n) h ---------------------------------------------------------------------------------- @@ -211,7 +211,7 @@ step st = NAp f (hViewUnsafe h -> NInd a) -> TiState (ap:s) d h' g sts' where - h' = (update h ap $ NAp f a) + h' = update ap (NAp f a) h sts' = sts & stsDereferences %~ succ _ -> @@ -240,7 +240,7 @@ step st = case isDataNode arg of True -> TiState s'' d h' g sts where - h' = update h rootAddr (NNum $ negate n) + h' = update rootAddr (NNum $ negate n) h s'' = rootAddr : s' (_:rootAddr:s') = s NNum n = arg @@ -273,7 +273,7 @@ step st = h' | needsEval cn = h | otherwise = - update h rootAddr (NInd $ if isTrue then t else f) + update rootAddr (NInd $ if isTrue then t else f) h [cn,tn,fn] = hViewUnsafe h <$> [c,t,f] [c,t,f] = getArgs h s @@ -287,18 +287,27 @@ step st = primStep _ CasePairP (TiState s d h g sts) = case needsEval pn of True -> TiState s' d' h g sts - where s' = undefined; d' = undefined + where + s' = [p] + d' = drop 1 s : d False -> TiState s' d h' g sts - where s' = undefined; h' = undefined + where + s' = drop 1 s + h' = h & update a1 (NAp f x) + & update a2 (NAp a1 y) + rootAddr = head s' + a1 = s' !! 0 + a2 = s' !! 1 + NData 0 [x,y] = pn where [p,f] = getArgs h s - pn = undefined + pn = hLookupUnsafe p h primStep n (ConP t a) (TiState s d h g sts) = TiState s' d h' g sts where s' = drop a s - h' = update h rootAddr $ NData t argAddrs + h' = update rootAddr (NData t argAddrs) h rootAddr = s !! a argAddrs = getArgs h s @@ -322,8 +331,8 @@ primArbitrary f (TiState s d h g sts) = Nothing -> d h' = case unevaled of Just _ -> h - Nothing -> update h rootAddr $ - onList f (fmap (\a -> hLookupUnsafe a h) argAddrs) + Nothing -> update rootAddr x h + where x = onList f (fmap (\a -> hLookupUnsafe a h) argAddrs) unevaled = find (\ (_,a) -> needsEval $ hLookupUnsafe a h) ans ans = [1..] `zip` argAddrs @@ -356,7 +365,7 @@ primBinary f (TiState s d h g sts) = h' | needsEval xarg = h | needsEval yarg = h - | otherwise = update h rootAddr (xarg `f` yarg) + | otherwise = update rootAddr (xarg `f` yarg) h d' | needsEval xarg = drop 1 s : d | needsEval yarg = drop 2 s : d