lists!

docs/src/commentary/stg.rst

@@ -257,7 +257,7 @@ Evaluate the first argument if necessary
    & g
    }
    { p : \nillist
-   & (c : a_1 : a_2 : \nillist) : d
+   & (a_1 : a_2 : \nillist) : d
    & h
    & g
    }
@@ -287,3 +287,50 @@ Perform the reduction if the first argument is in normal form
    & g
    }
 
+Lists
+-----
+
+Evaluate the scrutinee
+
+.. math::
+   \transrule
+   { c : a_1 : a_2 : a_3 : \nillist
+   & d
+   & h
+   \begin{bmatrix}
+        c : \mathtt{NPrim} \; \mathtt{CaseListP} \\
+        a_1 : \mathtt{NAp} \; c \; x
+   \end{bmatrix}
+   & g
+   }
+   { x
+   & (a_1 : a_2 : a_3) : \nillist
+   & h
+   & g
+   }
+
+If the scrutinee is :code:`Nil`, perform the appropriate reduction.
+
+.. math::
+   \transrule
+   { c : a_1 : a_2 : a_3 : s
+   & d
+   & h
+   \begin{bmatrix}
+        c : \mathtt{NPrim} \; \mathtt{CaseListP} \\
+        p : \mathtt{NData} \; 1 \; \nillist \\
+        a_1 : \mathtt{NAp} \; c \; p \\
+        a_2 : \mathtt{NAp} \; p \; f_\text{nil} \\
+        a_3 : \mathtt{NAp} \; a_2 \; f_\text{cons}
+   \end{bmatrix}
+   & g
+   }
+   { a_3 : s
+   & d
+   & h
+   \begin{bmatrix}
+        a_3 : \mathtt{NAp} \; f_\text{nil}
+   \end{bmatrix}
+   & g
+   }
+

src/Core/Examples.hs

@@ -86,6 +86,16 @@ pairExample2 = [coreProg|
     main = (if# False fst snd) (MkPair 2 3);
 |]
 
+listExample1 = [coreProg|
+    main = caseList# (Cons 2 Nil) 3 k;
+|]
+
+listExample2 = [coreProg|
+    cc f x xs = Cons (f x) (map f xs)
+    map f l = caseList# l Nil (cc f)
+    main = map negate# list;
+|]
+
 corePrelude :: Module
 corePrelude = Module (Just ("Prelude", [])) $ Program
     [ ScDef "id" ["x"] $ "x"
@@ -99,5 +109,7 @@ corePrelude = Module (Just ("Prelude", [])) $ Program
     , ScDef "MkPair" [] $ Con 0 2
     , ScDef "fst" ["p"] $ "casePair#" :$ "p" :$ "k"
     , ScDef "snd" ["p"] $ "casePair#" :$ "p" :$ "k1"
+    , ScDef "Nil" [] $ Con 1 0
+    , ScDef "Cons" [] $ Con 2 2
     ]
 

src/TIM.hs

@@ -48,6 +48,7 @@ data Prim = ConP Int Int -- ConP Tag Arity
           | IntNegP
           | IntEqP
           | CasePairP
+          | CaseListP
           deriving (Show, Eq)
 
 instance Pretty Prim where
@@ -103,6 +104,7 @@ primitives =
     , ("==#",       IntEqP)
     , ("if#",       IfP)
     , ("casePair#", CasePairP)
+    , ("caseList#", CaseListP)
     ]
 
 instantiate :: Expr -> TiHeap -> [(Name, Addr)] -> (TiHeap, Addr)
@@ -291,6 +293,7 @@ step st =
                         d' = drop 1 s : d
                 False -> TiState s' d h' g sts
                     where
+                        -- TODO: maybe should be a drop 2 perhaps
                         s' = drop 1 s
                         h' = h & update a1 (NAp f x)
                                & update a2 (NAp a1 y)
@@ -302,6 +305,28 @@ step st =
                 (p:f:_) = getArgs h s
                 pn = hLookupUnsafe p h
 
+        primStep _ CaseListP (TiState s d h g sts) =
+            case needsEval ln of
+                True  -> TiState s' d' h g sts
+                    where
+                        s' = [l]
+                        d' = drop 1 s : d
+                False -> TiState s' d h' g sts
+                    where
+                        s' = drop 3 s
+                        a2 = s !! 2
+                        a3 = s !! 3
+                        h' = case ln of
+                            NData 1 [] ->
+                                h & update a3 (NInd cn)
+                            NData 2 [x,xs] ->
+                                h & update a2 (NAp cc x)
+                                  & update a3 (NAp a2 xs)
+                            _ -> error "bad list"
+            where
+                (l:cn:cc:_) = getArgs h s
+                ln = hLookupUnsafe l h
+
         primStep n (ConP t a) (TiState s d h g sts) =
             TiState s' d h' g sts
             where
@@ -437,15 +462,15 @@ dbgProg p = do
 
 hdbgProg :: Program -> Handle -> IO (Node, Stats)
 hdbgProg p hio = do
-    hPrintf hio "==== Stats ====\n\
+    -- hPrintf hio "==== Stats ====\n\
-                \result       : %s\n\
+    --             \result       : %s\n\
-                \allocations  : %4d\n\
+    --             \allocations  : %4d\n\
-                \reductions   : %4d\n\
+    --             \reductions   : %4d\n\
-                \dereferences : %4d\n\n"
+    --             \dereferences : %4d\n\n"
-                (show res)
+    --             (show res)
-                (sts ^. stsAllocations)
+    --             (sts ^. stsAllocations)
-                (sts ^. stsReductions)
+    --             (sts ^. stsReductions)
-                (sts ^. stsDereferences)
+    --             (sts ^. stsDereferences)
     (hPutStr hio . prettyShow) `traverse_` p'
     pure (res, sts)
     where