Implement lists for TI Mark 5

Author: jlam55555

examples/list.core

@@ -0,0 +1,3 @@
+-- List example
+-- Requires TI Mark 5.
+main = length (Cons (Cons 2 3) (Cons 2 (Cons 3 Nil)))

examples/pair.core

@@ -1,3 +1,3 @@
 -- Pair test
 -- Requires TI Mark 5.
-main = fst (snd (fst (MkPair (MkPair 1 (MkPair 2 3)) 4)))
+main = fst (snd (fst (Pair (Pair 1 (Pair 2 3)) 4)))

src/CorePrelude.hs

@@ -3,6 +3,7 @@ module CorePrelude
   , extraPreludeDefs
   ) where
 
+import           Evaluators.TemplateInstantiation.Node
 import           Language
 
 -- Standard Prelude for Core
@@ -28,21 +29,15 @@ preludeDefs =
   , ("twice", ["f"], EAp (EAp (EVar "compose") (EVar "f")) (EVar "f"))
   ]
 
--- Standard definitions for true/false
--- Mirrors definitions for nodes in Evaluators.TemplateInstantiation.Node
-trueExpr, falseExpr :: CoreExpr
-trueExpr = EConstr 1 0
-falseExpr = EConstr 2 0
-
 -- Introduced in section 2.3.4.
 -- Execise 2.20: Add definitions for conditionals.
 -- Exercise 2.22: Add definitions for pair.
 extraPreludeDefs :: CoreProgram
 extraPreludeDefs =
   [
   -- Standard definitions for true/false
-    ("True" , [], trueExpr)
-  , ("False", [], falseExpr)
+    ("True" , [], EConstr tagTrue 0)
+  , ("False", [], EConstr tagFalse 0)
   -- Conditionals
   , ( "and"
     , ["x", "y"]
@@ -62,7 +57,26 @@ extraPreludeDefs =
     , EAp (EAp (EAp (EVar "if") (EVar "x")) (EVar "False")) (EVar "True")
     )
   -- Pairs
-  , ("mkPair", []   , EConstr 1 2)
+  , ("Pair", []   , EConstr tagPair 2)
   , ("fst", ["p"], EAp (EAp (EVar "casePair") (EVar "p")) (EVar "K"))
   , ("snd", ["p"], EAp (EAp (EVar "casePair") (EVar "p")) (EVar "K1"))
+  -- Lists
+  , ("Nil" , []   , EConstr tagNil 0)
+  , ("Cons", []   , EConstr tagCons 2)
+  , ( "head"
+    , ["l"]
+    , EAp (EAp (EAp (EVar "caseList") (EVar "l")) (EVar "abort")) (EVar "K")
+    )
+  , ( "tail"
+    , ["l"]
+    , EAp (EAp (EAp (EVar "caseList") (EVar "l")) (EVar "abort")) (EVar "K1")
+    )
+  , ( "length"
+    , ["xs"]
+    , EAp (EAp (EAp (EVar "caseList") (EVar "xs")) (ENum 0)) (EVar "length2")
+    )
+  , ( "length2"
+    , ["x", "xs"]
+    , EAp (EAp (EVar "+") (ENum 1)) (EAp (EVar "length") (EVar "xs"))
+    )
   ]

src/Evaluators/TemplateInstantiation/Evaluator.hs

@@ -104,6 +104,8 @@ primitives =
   , ("=="      , Eq)
   , ("~="      , NotEq)
   , ("casePair", CasePair)
+  , ("caseList", CaseList)
+  , ("abort"   , Abort)
   ]
 
 allocatePrim :: TiHeap -> (Name, Primitive) -> (TiHeap, (Name, Addr))
@@ -227,6 +229,8 @@ primStep state NotEq              = primComp state (/=)
 primStep state (Constr tag arity) = primConstr state tag arity
 primStep state If                 = primIf state
 primStep state CasePair           = primCasePair state
+primStep state CaseList           = primCaseList state
+primStep state Abort              = primAbort state
 
 -- Exercise 2.16: evaluation of `negate` (the only unary primitive)
 primNeg :: TiState -> TiState
@@ -355,11 +359,47 @@ primCasePair (s, d, h, e, stats) = state' where
   d'                     = tail s : d
   -- Get arguments
   (pair1Addr, pair2Addr) = getPairAddrs pair
-  getPairAddrs (NData 1 [pair1Addr', pair2Addr']) = (pair1Addr', pair2Addr')
+  getPairAddrs (NData tagPair' [pair1Addr', pair2Addr'])
+    | tagPair == tagPair' = (pair1Addr', pair2Addr')
+    | otherwise = error "primCasePair: argument is not a pair (incorrect tag)"
   getPairAddrs _ = error "primCasePair: argument is not a pair"
   pairAddr : handlerAddr : _ = getArgs h s
   pair                       = hLookup h pairAddr
 
+-- Exercise 2.24: implement `caseList` primitive. This is like a combination
+-- of `caseIf` and `casePair`.
+primCaseList :: TiState -> TiState
+primCaseList (s, d, h, e, stats) = state' where
+  state' | s' == [] = error "primCaseList: not enough arguments to caseList"
+         | isDataNode lst = (s', d, h', e, stats)
+         | otherwise = (s'', d', h, e, stats)
+  -- Stack, heap, and n if conditional is already evaluated
+  s'           = drop 3 s
+  rootAddr : _ = s'
+  h'           = updateHeap lst
+   where
+    updateHeap (NData tag _)
+      | tag == tagNil  = updateHeapNil
+      | tag == tagCons = updateHeapCons lst
+      | otherwise      = error "primCaseList: argument is not a list"
+    updateHeap _ = error "primCaseList: argument is not a list"
+    updateHeapNil = hUpdate h rootAddr $ NInd f1Addr
+    updateHeapCons (NData _ [cons1Addr, cons2Addr]) = h'''
+     where
+      (h'', ap) = hAlloc h $ NAp f2Addr cons1Addr
+      h'''      = hUpdate h'' rootAddr $ NAp ap cons2Addr
+    updateHeapCons _ = error "primCaseList: Cons: wrong number of arguments"
+  -- Stack and dump if argument is not evaluated
+  s''                           = [lstAddr]
+  d'                            = tail s : d
+  -- Get arguments
+  lstAddr : f1Addr : f2Addr : _ = getArgs h s
+  lst                           = hLookup h lstAddr
+
+-- Exercise 2.24: Implement primitive `abort`.
+primAbort :: TiState -> TiState
+primAbort = error "primAbort: abort: fatal error"
+
 -- Looks up all the arguments (names) for NAp nodes on the spine
 getArgs :: TiHeap -> TiStack -> [Addr]
 getArgs _ []      = error "getArgs: empty stack"

src/Evaluators/TemplateInstantiation/Node.hs

@@ -4,6 +4,11 @@ module Evaluators.TemplateInstantiation.Node
   , trueNode
   , falseNode
   , boolToNode
+  , tagTrue
+  , tagFalse
+  , tagPair
+  , tagNil
+  , tagCons
   ) where
 
 import           Alloc
@@ -19,14 +24,22 @@ data Node = NAp Addr Addr                   -- Application
   deriving (Eq, Show)
 
 data Primitive = Neg | Add | Sub | Mul | Div
-  | Constr Int Int | If | CasePair
+  | Constr Int Int | If | CasePair | CaseList
   | Greater | GreaterEq | Less | LessEq | Eq | NotEq
+  | Abort
   deriving (Eq, Show)
 
--- Standard representations of booleans in Core
+-- Standard representations of special structured datatypes in Core
+tagTrue, tagFalse, tagPair, tagNil, tagCons :: Int
+tagTrue = 0
+tagFalse = 1
+tagPair = 2
+tagNil = 3
+tagCons = 4
+
 trueNode, falseNode :: Node
-trueNode = NData 1 []
-falseNode = NData 2 []
+trueNode = NData tagTrue []
+falseNode = NData tagFalse []
 
 boolToNode :: Bool -> Node
 boolToNode True  = trueNode

test/Evaluators/TemplateInstantiation/EvaluatorTests.hs

@@ -12,7 +12,7 @@ progChurch, progCons, progInfinite1, progInfinite2, progInfinite3 :: String
 progAnd1, progAnd2, progAnd3, progAnd4 :: String
 progOr1, progOr2, progOr3, progOr4 :: String
 progXor1, progXor2, progXor3, progXor4 :: String
-progFac, progFib, progPair :: String
+progFac, progFib, progPair, progList :: String
 
 -- Exercise 2.4
 progSKK3 = "main = S K K 3"
@@ -109,7 +109,10 @@ progFib = "fib n = if (n < 2) n (fib (n - 1) + fib (n - 2)) ;\
   \main = fib 6"
 
 -- Exercise 2.22: Pair
-progPair = "main = fst (snd (fst (MkPair (MkPair 1 (MkPair 2 3)) 4)))"
+progPair = "main = fst (snd (fst (Pair (Pair 1 (Pair 2 3)) 4)))"
+
+-- Lists
+progList = "main = length (Cons (Cons 2 3) (Cons 2 (Cons 3 Nil)))"
 
 tests :: Test
 tests = test
@@ -145,4 +148,5 @@ tests = test
   , "factorial" ~: runGetNumResult progFac ~=? 6
   , "naive fib" ~: runGetNumResult progFib ~=? 8
   , "pairs" ~: runGetNumResult progPair ~=? 2
+  , "list" ~: runGetNumResult progList ~=? 3
   ]