Implement pairs for TI Mark 5

Author: jlam55555

examples/pair.core

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

src/CorePrelude.hs

@@ -35,25 +35,34 @@ trueExpr = EConstr 1 0
 falseExpr = EConstr 2 0
 
 -- Introduced in section 2.3.4.
--- Execise 2.20: definitions for conditionals added.
+-- 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)
+  -- Conditionals
   , ( "and"
     , ["x", "y"]
-    , EAp (EAp (EAp (EVar "if") (EVar "x")) (EVar "y")) falseExpr
+    , EAp (EAp (EAp (EVar "if") (EVar "x")) (EVar "y")) (EVar "False")
     )
   , ( "or"
     , ["x", "y"]
-    , EAp (EAp (EAp (EVar "if") (EVar "x")) trueExpr) (EVar "y")
+    , EAp (EAp (EAp (EVar "if") (EVar "x")) (EVar "True")) (EVar "y")
     )
   , ( "xor"
     , ["x", "y"]
     , EAp (EAp (EAp (EVar "if") (EVar "x")) (EAp (EVar "not") (EVar "y")))
           (EVar "y")
     )
-  , ("not", ["x"], EAp (EAp (EAp (EVar "if") (EVar "x")) falseExpr) trueExpr)
+  , ( "not"
+    , ["x"]
+    , EAp (EAp (EAp (EVar "if") (EVar "x")) (EVar "False")) (EVar "True")
+    )
+  -- Pairs
+  , ("mkPair", []   , EConstr 1 2)
+  , ("fst", ["p"], EAp (EAp (EVar "casePair") (EVar "p")) (EVar "K"))
+  , ("snd", ["p"], EAp (EAp (EVar "casePair") (EVar "p")) (EVar "K1"))
   ]

src/Evaluators/TemplateInstantiation/Evaluator.hs

@@ -91,18 +91,19 @@ allocateSc h (name, args, body) = (h', (name, a))
 -- Add primitives to the heap
 primitives :: AssocList Name Primitive
 primitives =
-  [ ("negate", Neg)
-  , ("+"     , Add)
-  , ("-"     , Sub)
-  , ("*"     , Mul)
-  , ("/"     , Div)
-  , ("if"    , If)
-  , (">"     , Greater)
-  , (">="    , GreaterEq)
-  , ("<"     , Less)
-  , ("<="    , LessEq)
-  , ("=="    , Eq)
-  , ("~="    , NotEq)
+  [ ("negate"  , Neg)
+  , ("+"       , Add)
+  , ("-"       , Sub)
+  , ("*"       , Mul)
+  , ("/"       , Div)
+  , ("if"      , If)
+  , (">"       , Greater)
+  , (">="      , GreaterEq)
+  , ("<"       , Less)
+  , ("<="      , LessEq)
+  , ("=="      , Eq)
+  , ("~="      , NotEq)
+  , ("casePair", CasePair)
   ]
 
 allocatePrim :: TiHeap -> (Name, Primitive) -> (TiHeap, (Name, Addr))
@@ -225,6 +226,7 @@ primStep state Eq                 = primComp state (==)
 primStep state NotEq              = primComp state (/=)
 primStep state (Constr tag arity) = primConstr state tag arity
 primStep state If                 = primIf state
+primStep state CasePair           = primCasePair state
 
 -- Exercise 2.16: evaluation of `negate` (the only unary primitive)
 primNeg :: TiState -> TiState
@@ -331,11 +333,33 @@ primIf (s, d, h, e, stats) = state' where
          | otherwise         = error "primIf: conditional is not a boolean"
   -- Stack and dump if argument is not evaluated
   s''  = [condAddr]
-  d'   = s' : d
+  d'   = tail s : d
   -- Get arguments
   condAddr : thenAddr : elseAddr : _ = getArgs h s
   cond = hLookup h condAddr
 
+-- Exercise 2.22: implement `casePair` primitive. This is fairly similar
+-- to the evaluation of primIf
+primCasePair :: TiState -> TiState
+primCasePair (s, d, h, e, stats) = state' where
+  state' | s' == [] = error "primCasePair: not enough arguments to casePair"
+         | isDataNode pair = (s', d, h'', e, stats)
+         | otherwise = (s'', d', h, e, stats)
+  -- Stack, heap, and n if conditional is already evaluated
+  s'                     = drop 2 s
+  rootAddr : _           = s'
+  (h', ap)               = hAlloc h $ NAp handlerAddr pair1Addr
+  h''                    = hUpdate h' rootAddr $ NAp ap pair2Addr
+  -- Stack and dump if argument is not evaluated
+  s''                    = [pairAddr]
+  d'                     = tail s : d
+  -- Get arguments
+  (pair1Addr, pair2Addr) = getPairAddrs pair
+  getPairAddrs (NData 1 [pair1Addr', pair2Addr']) = (pair1Addr', pair2Addr')
+  getPairAddrs _ = error "primCasePair: argument is not a pair"
+  pairAddr : handlerAddr : _ = getArgs h s
+  pair                       = hLookup h pairAddr
+
 -- 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

@@ -19,7 +19,7 @@ data Node = NAp Addr Addr                   -- Application
   deriving (Eq, Show)
 
 data Primitive = Neg | Add | Sub | Mul | Div
-  | Constr Int Int | If
+  | Constr Int Int | If | CasePair
   | Greater | GreaterEq | Less | LessEq | Eq | NotEq
   deriving (Eq, Show)
 

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 :: String
+progFac, progFib, progPair :: String
 
 -- Exercise 2.4
 progSKK3 = "main = S K K 3"
@@ -108,6 +108,9 @@ progFac = "fac n = if (n == 0) 1 (n * fac (n - 1)) ;\
 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)))"
+
 tests :: Test
 tests = test
   [ "exercise 2.4" ~: runGetNumResult progSKK3 ~=? 3
@@ -141,4 +144,5 @@ tests = test
   , "xor T T" ~: not (runGetBoolResult progXor4) ~? ""
   , "factorial" ~: runGetNumResult progFac ~=? 6
   , "naive fib" ~: runGetNumResult progFib ~=? 8
+  , "pairs" ~: runGetNumResult progPair ~=? 2
   ]