[code cleanups, apply main to world at E stage rather than waiting until grin stage, worker wrapper will be sure not to turn functions into updatable thunks
John Meacham <john@repetae.net>**20051021041045] hunk ./E/CPR.hs 98
-    f (EPi _ _) = Tup tArrow
+    f (EPi _ _) = Tup tc_Arrow
hunk ./E/E.hs 168
-patToLitEE (LitCons n [a,b] t) | t == eStar, n == tArrow = EPi (tVr 0 (EVar a)) (EVar b)
+patToLitEE (LitCons n [a,b] t) | t == eStar, n == tc_Arrow = EPi (tVr 0 (EVar a)) (EVar b)
hunk ./E/E.hs 337
+tPtr t = ELit (LitCons tc_Ptr [t] eStar)
hunk ./E/E.hs 349
-tc_Arrow = toName TypeConstructor ("Prelude","->")
+tc_Arrow = toName TypeConstructor ("Jhc@","->")
hunk ./E/E.hs 353
+tc_Ptr = toName TypeConstructor ("Foreign.Ptr","Ptr")
hunk ./E/E.hs 356
-
-tArrow = tc_Arrow
hunk ./E/FromHs.hs 125
-getMainFunction :: Monad m => Name -> (Map.Map Name (TVr,E)) -> m (Name,TVr,E)
-getMainFunction name ds = ans where
+getMainFunction :: Monad m => DataTable -> Name -> (Map.Map Name (TVr,E)) -> m (Name,TVr,E)
+getMainFunction dataTable name ds = ans where
hunk ./E/FromHs.hs 135
-            theMain = (theMainName,theMainTvr,e)
-            theMainTvr =  tVr (nameToInt theMainName) (getType e)
+            ans' = eStrictLet (tvr { tvrIdent = 0, tvrType = (infertype dataTable be)}) be vUnit
+            be = eAp e vWorld__
+            theMain = (theMainName,theMainTvr,be)
+            theMainTvr =  tVr (nameToInt theMainName) (getType be)
hunk ./E/FromHs.hs 169
-        valToPat' (EPi (TVr { tvrType =  a}) b)  = ELit $ LitCons tArrow [ EVar (tVr ( j) (getType z)) | z <- [a,b] | j <- [2,4 ..]]  eStar
+        valToPat' (EPi (TVr { tvrType =  a}) b)  = ELit $ LitCons tc_Arrow [ EVar (tVr ( j) (getType z)) | z <- [a,b] | j <- [2,4 ..]]  eStar
hunk ./E/FromHs.hs 205
-                (EPi (TVr { tvrType = a}) b) -> (tArrow,[a,b],eStar)
+                (EPi (TVr { tvrType = a}) b) -> (tc_Arrow,[a,b],eStar)
hunk ./E/TypeCheck.hs 91
-        let ck (tv@(TVr { tvrType =  t}),e) = withContextDoc (hsep [text "Checking Let: ", parens (pprint tv),text  " = ", parens $ prettyE e ])  $  valid' nds t >>  fceq nds e t
+        let ck (tv@(TVr { tvrType =  t}),e) = withContextDoc (hsep [text "Checking Let: ", parens (pprint tv),text  " = ", parens $ prettyE e ])  $ do
+                when (getType t == eHash && not (isEPi t)) $ fail $ "Let binding unboxed value: " ++ show (tv,e)
+                valid' nds t
+                fceq nds e t
hunk ./E/Values.hs 109
-eLet t@(TVr { tvrType =  ty}) e e' | sortStarLike ty && isAtomic e = subst t e e'
-eLet t@(TVr { tvrType =  ty}) e e' | sortStarLike ty = ELetRec [(t,e)] (typeSubst mempty (Map.singleton (tvrIdent t) e) e')
+eLet t@(TVr { tvrType =  ty}) e e'
+    | sortStarLike ty && isAtomic e = subst t e e'
+    | sortStarLike ty = ELetRec [(t,e)] (typeSubst mempty (Map.singleton (tvrIdent t) e) e')
+    | isUnboxed ty && isAtomic e = subst t e e'
+    | isUnboxed ty  = eStrictLet t e e'
hunk ./E/Values.hs 126
+
hunk ./E/Values.hs 128
-substLet' ds e  = ans where
+substLet' ds' e  = ans where
+    (hh,ds) = partition (isUnboxed . tvrType . fst) ds'
hunk ./E/Values.hs 133
-        ([],_) -> e
-        (nas,[]) -> ELetRec nas e
+        ([],_) -> hhh hh $ e
+        (nas,[]) -> hhh hh $ ELetRec nas e
hunk ./E/Values.hs 138
-               in ELetRec nas' (f e)
+               in hhh hh $ ELetRec nas' (f e)
+    hhh [] e = e
+    hhh ((h,v):hh) e = eLet h v (hhh hh e)
hunk ./E/Values.hs 153
-safeToDup ec@ECase {} | EVar _ <- eCaseScrutinee ec = all safeToDup (caseBodies ec)
+-- Determine if a type represents an unboxed value
+isUnboxed :: E -> Bool
+isUnboxed e@EPi {} = False
+isUnboxed e = getType e == eHash
+
+safeToDup ec@ECase {}
+    | EVar _ <- eCaseScrutinee ec = all safeToDup (caseBodies ec)
+    | EPrim p _ _ <- eCaseScrutinee ec, aprimIsCheap p = all safeToDup (caseBodies ec)
+safeToDup (EPrim p _ _) = aprimIsCheap p
hunk ./E/Values.hs 205
-
-tPtr t = ELit (LitCons (toName TypeConstructor ("Foreign.Ptr","Ptr")) [t] eStar)
hunk ./E/WorkerWrapper.hs 49
+
hunk ./E/WorkerWrapper.hs 80
-    worker = foldr ELam body' args' where
+    worker = foldr ELam body' (args' ++ navar) where
hunk ./E/WorkerWrapper.hs 86
-        ne | Just cname <- cname, isSingleton = cases $ eStrictLet sv (foldl EAp (EVar tvr') (map EVar args'))  (ELit $ LitCons cname [EVar sv] bodyTyp)
-           | Just cname <- cname = let ca = Alt (unboxedTuple vars) (ELit $ LitCons cname (map EVar vars) bodyTyp) in  cases $ eCase (foldl EAp (EVar tvr') (map EVar args')) [ca] Unknown
-           | otherwise = cases $ (foldl EAp (EVar tvr') (map EVar args'))
+        workerCall = (foldl EAp (EVar tvr') (map EVar args' ++ navalue))
+        ne | Just cname <- cname, isSingleton = cases $ eStrictLet sv workerCall  (ELit $ LitCons cname [EVar sv] bodyTyp)
+           | Just cname <- cname = let ca = Alt (unboxedTuple vars) (ELit $ LitCons cname (map EVar vars) bodyTyp) in  cases $ eCase workerCall [ca] Unknown
+           | otherwise = cases $ workerCall
hunk ./E/WorkerWrapper.hs 96
+    -- This is to add a dummy arg so workers arn't turned into updatable CAFs
+    needsArg =  all (isJust . fst) sargs && null (concat [ xs | (Just (_,xs),_) <- sargs])
+    (navar,navalue) = if needsArg then ([tvr { tvrType = ltTuple' []}],[eTuple' []]) else ([],[])
hunk ./Grin/FromE.hs 74
+tagArrow = convertName tc_Arrow
+
+convertName n = toAtom (t':s) where
+    (t,s) = fromName n
+    t' | t == TypeConstructor = 'T'
+       | t == DataConstructor = 'C'
+       | t == Val = 'f'
+       | otherwise = error $ "convertName: " ++ show (t,s)
hunk ./Grin/FromE.hs 140
-    (_,(Tup [] :-> theMain)) <- doCompile ((mt,[],EAp (EVar mt) vWorld__))
+    (_,(Tup [] :-> theMain)) <- doCompile ((mt,[],EVar mt))
hunk ./Grin/FromE.hs 150
-    let (main,as,rtype) = runIdentity $ Map.lookup (tvrNum mt) scMap
-        main' =  if not $ null as then  (Return $ NodeC (partialTag main (length as)) []) else App main [] rtype
-        tags = Set.toList $ ep $ Set.unions (freeVars (main',initCafs):[ freeVars e | (_,(_ :-> e)) <- ds ])
-        ep s = Set.fromList $ concatMap partialLadder $ Set.toList s
+    -- let (main,as,rtype) = runIdentity $ Map.lookup (tvrNum mt) scMap
+        -- main' =  if not $ null as then  (Return $ NodeC (partialTag main (length as)) []) else App main [] rtype
+        -- tags = Set.toList $ ep $ Set.unions (freeVars (main',initCafs):[ freeVars e | (_,(_ :-> e)) <- ds ])
+    let ep s = Set.fromList $ concatMap partialLadder $ Set.toList s
hunk ./Grin/FromE.hs 185
-convertName n = toAtom (t':s) where
-    (t,s) = fromName n
-    t' | t == TypeConstructor = 'T'
-       | t == DataConstructor = 'C'
-       | t == Val = 'f'
-       | otherwise = error $ "convertName: " ++ show (t,s)
hunk ./Grin/FromE.hs 188
-    (toAtom "TAbsurd#", ([],TyNode)),
+    (convertName tc_Absurd, ([],TyNode)),
hunk ./Grin/Grin.hs 17
-    tagArrow,
hunk ./Grin/Grin.hs 73
-tagArrow = toAtom "TPrelude.->"
hunk ./Grin/Grin.hs 231
+
hunk ./Main.hs 313
-    (_,main,mainv) <- getMainFunction mainFunc es
+    (_,main,mainv) <- getMainFunction dataTable mainFunc es