pairs :3

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}

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;
 |]

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

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