[clean up FromE generation a lot. add some minor optimizations. don't bother evaluating unlifted values, just fetch them.
John Meacham <john@repetae.net>**20060316125702] hunk ./Grin/FromE.hs 294
-    ce e |  (EVar v,as) <- fromAp e = do
+    ce (EVar tvr) | not $ isLifted (EVar tvr)  = do
+        mtick "Grin.FromE.strict-unlifted"
+        return (Fetch (toVal tvr))
+    ce e | (EVar tvr,as) <- fromAp e = do
hunk ./Grin/FromE.hs 300
-        case Map.lookup (tvrNum v) (ccafMap cenv) of
+        case Map.lookup (tvrNum tvr) (ccafMap cenv) of
hunk ./Grin/FromE.hs 303
-            Nothing -> case Map.lookup (tvrNum v) (scMap cenv) of
+            Nothing -> case Map.lookup (tvrNum tvr) (scMap cenv) of
hunk ./Grin/FromE.hs 311
-                Nothing -> app fty (gEval $ toVal v) as
-    ce e | (v,as@(_:_)) <- fromAp e = do
-        let fty = toType TyNode (getType e)
-        as <- return $ args as
-        e <- ce v
-        app fty e as
-    ce (EPi (TVr { tvrIdent = 0, tvrType = a}) b) = do
-        a' <- cc a
-        b' <- cc b
-        p1 <- newNodePtrVar
-        p2 <- newNodePtrVar
-        return (a' :>>= p1 :-> b' :>>= p2 :-> Return (NodeC tagArrow [p1,p2]))
+                Nothing | not (isLifted $ EVar tvr) -> do
+                    mtick "Grin.FromE.app-unlifted"
+                    app fty (Fetch $ toVal tvr) as
+                Nothing -> app fty (gEval $ toVal tvr) as
hunk ./Grin/FromE.hs 331
-    ce (EPrim ap@(APrim (Func True fn as "void") _) (_:es) _) = do
-        let p = Primitive { primName = Atom.fromString (pprint ap), primRets = Nothing, primType = ((map (Ty . toAtom) as),tyUnit), primAPrim = ap }
-        return $  Prim p (args es)
-    ce (EPrim ap@(APrim (Func True fn as r) _) (_:es) rt) = do
-        let p = Primitive { primName = Atom.fromString (pprint ap), primRets = Nothing, primType = ((map (Ty . toAtom) as),Ty (toAtom r)), primAPrim = ap }
-            ptv = Var v2 pt
-            pt = Ty (toAtom r)
-        return $ Prim p (args es) :>>= ptv :-> Return (tuple [ptv])
-    ce (EPrim ap@(APrim (Func False _ as r) _) es (ELit (LitCons tname [] _))) | RawType <- nameType tname = do
-        let p = Primitive { primName = Atom.fromString (pprint ap), primRets = Nothing, primType = ((map (Ty . toAtom) as),Ty (toAtom r)), primAPrim = ap }
-        return $ Prim p (args es)
-    ce (EPrim ap@(APrim (Peek pt') _) [_,addr] rt) = do
-        let p = Primitive { primName = Atom.fromString (pprint ap), primRets = Nothing, primType = ([Ty (toAtom "HsPtr")],pt), primAPrim = ap }
-            ptv = Var v2 pt
-            pt = Ty (toAtom pt')
-        return $  Prim p (args [addr]) :>>= ptv :-> Return (tuple [ptv])
-    ce (EPrim ap@(APrim (Poke pt') _) [_,addr,val] _) = do
-        let p = Primitive { primName = Atom.fromString (pprint ap), primRets = Nothing, primType = ([Ty (toAtom "HsPtr"),pt],tyUnit), primAPrim = ap }
-            pt = Ty (toAtom pt')
-        return $  Prim p (args [addr,val])
-    ce (EPrim aprim@(APrim (AddrOf s) _) [] (ELit (LitCons tname [] _))) | RawType <- nameType tname = do
-        let p = Primitive { primName = toAtom ('&':s), primRets = Nothing, primType = ([],ptype), primAPrim = aprim }
-            ptype = Ty $ toAtom (show tname)
-        return $ Prim p []
-    ce (EPrim aprim@(APrim (CConst s t) _) [] (ELit (LitCons n [] _))) | RawType <- nameType n = do
-        let p = Primitive { primName = toAtom s, primRets = Nothing, primType = ([],ptype), primAPrim = aprim }
-            ptype = Ty $ toAtom t
-        return $ Prim p []
-    ce ee@(EPrim aprim@(APrim (CCast from to) _) [e] t)  = do
-        let ptypeto' = Ty $ toAtom to
-            ptypefrom' = Ty $ toAtom from
-        let p = Primitive { primName = toAtom ("(" ++ to ++ ")"), primRets = Nothing, primType = ([ptypefrom'],ptypeto'), primAPrim = aprim }
-        return $  Prim p (args [e])
-    ce (EPrim ap@(APrim (Operator n as r) _) es (ELit (LitCons tname [] _))) | RawType <- nameType tname = do
-        let p = Primitive { primName = Atom.fromString (pprint ap), primRets = Nothing, primType = ((map (Ty . toAtom) as),Ty (toAtom r)), primAPrim = ap }
-        return $ Prim p (args es)
+    ce (EPrim ap@(APrim p _) xs ty) = let
+      prim = Primitive { primName = Atom.fromString (pprint ap), primAPrim = ap, primRets = Nothing, primType = ([],tyUnit) }
+      in case p of
+        Func True fn as "void" -> return $ Prim prim { primType = ((map (Ty . toAtom) as),tyUnit) } (args $ tail xs)
+        Func True fn as r -> do
+            let p = prim { primType = ((map (Ty . toAtom) as),Ty (toAtom r)) }
+                ptv = Var v2 pt
+                pt = Ty (toAtom r)
+            return $ Prim p (args $ tail xs)
+        Func False _ as r | Just _ <- fromRawType ty ->  do
+            let p = prim { primType = ((map (Ty . toAtom) as),Ty (toAtom r)) }
+            return $ Prim p (args xs)
+        Peek pt' -> do
+            let p = prim { primType = ([Ty $ toAtom (show rt_HsPtr)],pt) }
+                [_,addr] = xs
+                ptv = Var v2 pt
+                pt = Ty (toAtom pt')
+            return $ Prim p (args [addr])
+        Poke pt' ->  do
+            let p = prim { primType = ([Ty $ toAtom (show rt_HsPtr)],tyUnit) }
+                [_,addr,val] = xs
+                pt = Ty (toAtom pt')
+            return $  Prim p (args [addr,val])
+        CCast from to -> do
+            let ptypeto' = Ty $ toAtom to
+                ptypefrom' = Ty $ toAtom from
+            let p = prim { primName = toAtom ("(" ++ to ++ ")"), primType = ([ptypefrom'],ptypeto') }
+            return $  Prim p (args xs)
+        Operator n as r | Just _ <- fromRawType ty -> do
+            let p = prim { primType = ((map (Ty . toAtom) as),Ty (toAtom r)) }
+            return $ Prim p (args xs)
hunk ./Grin/FromE.hs 388
+    fromRawType (ELit (LitCons tname [] _))
+        | RawType <- nameType tname = return (Ty $ toAtom (show tname))
+    fromRawType _ = fail "not a raw type"
+
hunk ./Grin/FromE.hs 398
---    cp (Alt lc@(LitCons n es _) e) | Just v <- fromUnboxedNameTuple n, DataConstructor <- nameType n = do
---        putStrLn $ "Print alt: " ++ show lc
---        x <- ce e
---        return (Tup (map toVal es) :-> x)
hunk ./Grin/FromE.hs 450
-    cc (EPrim (APrim (PrimPrim "newWorld__") _) [_] _) = return $ Return unit
-    cc (EPrim (APrim (PrimPrim "theWorld__") _) [] _) = return $ Return unit
hunk ./Grin/FromE.hs 451
-    cc e | Just _ <- literal e = error "literal in lazy context"
+    cc e | Just _ <- literal e = error "unboxed literal in lazy context"
hunk ./Grin/FromE.hs 464
-    cc e |  (EVar v,as) <- fromAp e = do
+    cc e | (EVar v,as@(_:_)) <- fromAp e = do
hunk ./Grin/FromE.hs 475
-                | otherwise -> do
+                | length as < length as', all valIsConstant as -> do
hunk ./Grin/FromE.hs 477
-                    return $ Store (NodeC pt as)
-            Nothing
-                | [] <- as -> return $ Return (toVal v)
-                | otherwise  -> app' (toVal v) as
-    cc (EPrim aprim@(APrim prim _) es pt) = do
-        V vn <- newVar
-        te <- readIORef (tyEnv cenv)
-        let s = pprint prim
-            fn' = toAtom ('B':s ++ "_" ++ show vn)
-            fn = toAtom ('b':s ++ "_" ++ show vn)
-        case findArgsType te fn of
-            Just _ -> return $ Store $ NodeC fn' (args es)
-            Nothing -> do
-                let es' = args es
-                ts <- mapM (typecheck te) es'
-                let nvs = [ Var v t | t <- ts | v <- [v2,V 4..] ]
-                x <- ce (EPrim aprim [ EVar (tvr { tvrIdent = v, tvrType =  t}) | t <- map getType es | v <- [2,4..]] pt)
-                addNewFunction (fn,Tup nvs :-> x)
-                return $ Store $ NodeC fn' es'
+                    mtick "Grin.FromE.partial-constant"
+                    return $ Return (Const (NodeC pt as))
+                | length as < length as' -> do
+                    let pt = partialTag v (length as' - length as)
+                    return $ if all valIsConstant as then
+                        Return (Const (NodeC pt as))
+                            else Store (NodeC pt as)
+                | otherwise -> do -- length as == length as'
+                    return $ Store (NodeC (tagFlipFunction v) as)
+            Nothing -> app' (toVal v) as
hunk ./Grin/FromE.hs 488
+
+
hunk ./Grin/FromE.hs 492
+        f (Left (t,e):ds) x | not (isLifted (EVar t)) = do
+            mtick "Grin.FromE.let-unlifted"
+            e <- ce e
+            v <- f ds x
+            return $ (e :>>= n1 :-> Store n1) :>>= toVal t :-> v
hunk ./Grin/FromE.hs 526
-    literal (EPrim aprim@(APrim p _) xs (ELit (LitCons n [] (ESort EHash)))) | RawType <- nameType n, primIsConstant p = do
+    literal (EPrim aprim@(APrim p _) xs ty) | Just ptype <- fromRawType ty, primIsConstant p = do
hunk ./Grin/FromE.hs 528
-        return $ ValPrim aprim xs (Ty $ toAtom (show n))
+        return $ ValPrim aprim xs ptype
hunk ./Grin/Linear.hs 57
+    h (Fetch (Var v _)) = eval v -- XXX can this be weakened?