Implement exercise 3.38

Author: jlam55555

src/Evaluators/GMachine/Compiler.hs

@@ -114,7 +114,7 @@ compileC (ELet isRec defs e) env | isRec     = compileLetrec compileC defs e env
                                  | otherwise = compileLet compileC defs e env
 -- Mark 6: need to handle constructors
 compileC e@(EAp e1 e2) env
-  | saturatedConstr $ spine = compiledConstr
+  | saturatedConstr spine = compiledConstr
   | otherwise = compileC e2 env ++ compileC e1 (argOffset 1 env) ++ [Mkap]
  where
   -- Compiled code if constructor
@@ -132,11 +132,12 @@ compileC e@(EAp e1 e2) env
   spine' e'            = [e']
 -- Special handling for nullary constructors
 compileC (EConstr t 0) _ = [Pack t 0]
--- Other forms are invalid; they can only be reached via program transformations
-compileC (EConstr _ _) _ =
-  error "compileC: constr incorrectly tagged with 0 args"
-compileC (ECase _ _) _ = error "compileC: case in non-strict context"
-compileC (ELam  _ _) _ = error "compileC: lambda not implemented"
+-- Constructor applied to too few arguments; exercise 3.38
+compileC (EConstr t a) _ =
+  [Pushglobal $ "Pack{" ++ show t ++ "," ++ show a ++ "}"]
+compileC (ECase _ _) _ =
+  error "compileC: case in non-strict context; rewrite case as sc"
+compileC (ELam _ _) _ = error "compileC: lambda not implemented"
 
 -- Compile a letrec expression
 compileLetrec :: GmCompiler -> [(Name, CoreExpr)] -> GmCompiler

src/Evaluators/GMachine/Evaluator.hs

@@ -7,6 +7,8 @@ import           Evaluators.GMachine.State
 import           Alloc
 import           Data.AssocList
 import           Language
+import           Lexer
+import           Parser.Core
 
 eval :: GmState -> [GmState]
 eval state = state : restStates
@@ -56,10 +58,28 @@ dispatch Print            = printI
 
 -- Push global onto stack
 pushglobal :: Name -> GmStateT
-pushglobal f state = state { gmStack = a : gmStack state }
+pushglobal f state = state { gmStack = a : gmStack state
+                           , gmHeap  = h'
+                           , gmEnv   = e'
+                           }
  where
-  a =
-    lookupDef (error $ "pushglobal: undeclared global: " ++ f) f $ gmEnv state
+  -- Exercise 3.38: Pack{t,n} may need to be dynamically generated
+  -- (introduced in Mark 6). These can also be generated at compile-
+  -- time, but this complicates the signatures of the compile schemes.
+  -- Probably inefficient to use a full parser for this, but it is
+  -- convenient and only needs to be called when the Pack{t,n} is
+  -- encountered for the first time. If the looked up variable is
+  -- not of the form Pack{t,n}, then there is an undeclared global.
+  h           = gmHeap state
+  e           = gmEnv state
+  (h', a, e') = getHeapAddr $ lookupDef hNull f $ gmEnv state
+   where
+    getHeapAddr a' | a' == hNull = updateEnv $ makePackSc $ pConstr $ clex f
+                   | otherwise   = (h, a', e)
+    updateEnv (h'', a') = (h'', a', (f, a') : e)
+    makePackSc ((EConstr t n, []) : []) =
+      hAlloc h $ NGlobal n [Pack t n, Update 0, Unwind]
+    makePackSc _ = error $ "pushglobal: undeclared global: " ++ f
 
 -- Allocate int and push onto stack
 -- Exercise 3.6: Reuse number nodes

src/Parser/Core.hs

@@ -7,6 +7,7 @@ module Parser.Core
   , pLam
   , pLet
   , pCase
+  , pConstr
   ) where
 
 import           Language
@@ -34,21 +35,23 @@ pSc = pThen4 mk_sc pVar (pZeroOrMore pVar) pEq pExpr
   where mk_sc name args _ body = (name, args, body)
 
 -- Parse an expression
-pExpr, pAtom, pCase, pLam, pAp, pLet :: Parser CoreExpr
+pExpr, pAtom, pCase, pLam, pAp, pLet, pConstr :: Parser CoreExpr
 pExpr = foldl1 pAlt [pLet, pCase, pLam, pExpr1]
 
 -- Exercise 1.21: Complete the parser, except for EAp (and infix ops).
 -- Exercise 1.23: Implement mk_ap_chain for function application.
 pAtom = foldl1 pAlt [pEVar, pENum, pConstr, pWrappedExpr]
  where
-  mk_constr _ eConstr _ = eConstr
   pEVar        = pApply pVar EVar
   pENum        = pApply pNum ENum
-  pConstr      = pThen3 mk_constr pPre pInd pRBkt
-  pPre         = pThen undefined pKwPack pLBkt
-  pInd         = pThen3 (\n1 _ n2 -> EConstr n1 n2) pNum pCom pNum
   pWrappedExpr = pThen3 (\_ e _ -> e) pLPar pExpr pRPar
 
+pConstr = pThen3 mk_constr pPre pInd pRBkt
+ where
+  mk_constr _ eConstr _ = eConstr
+  pPre = pThen undefined pKwPack pLBkt
+  pInd = pThen3 (\n1 _ n2 -> EConstr n1 n2) pNum pCom pNum
+
 pAp = pApply (pOneOrMore pAtom) mk_ap_chain where mk_ap_chain = foldl1 EAp
 
 pLet = pThen4 mk_let pLetKw pDefns pKwIn pExpr