[make grin blind application work with unboxed args and return values
John Meacham <john@repetae.net>**20051024071337] hunk ./E/WorkerWrapper.hs 3
-import Control.Monad.Identity
hunk ./E/WorkerWrapper.hs 8
-import Atom
hunk ./E/WorkerWrapper.hs 101
-            Just n -> mtick ("E.Workwrap.CPR.{" ++ tvrShowName tvr ++ "." ++ show n ++ "}")
+            --Just n -> mtick ("E.Workwrap.CPR.{" ++ tvrShowName tvr ++ "." ++ show n ++ "}")
+            Just n -> mtick ("E.Workwrap.CPR.{"  ++ show n ++ "}")
hunk ./E/WorkerWrapper.hs 105
-            (Just (n,_),_) ->  mtick ("E.Workwrap.arg.{" ++ tvrShowName tvr ++ "." ++ show (conName n) ++ "}")
+            --(Just (n,_),_) ->  mtick ("E.Workwrap.arg.{" ++ tvrShowName tvr ++ "." ++ show (conName n) ++ "}")
+            (Just (n,_),_) ->  mtick ("E.Workwrap.arg.{"  ++ show (conName n) ++ "}")
hunk ./E/WorkerWrapper.hs 110
-
-a_workWrap = toAtom "E.Simplify.WorkerWrapper"
hunk ./Grin/EvalInline.hs 57
-createApply :: TyEnv -> [Tag] -> Lam
-createApply te ts
-    | null cs = Tup [n1,p2] :-> Error ("Empty Apply:" ++ show ts)  TyNode
-    | otherwise = Tup [n1,p2] :-> Case n1 cs
+createApply :: Ty -> Ty -> TyEnv -> [Tag] -> Lam
+createApply argType retType te ts
+    | null cs = Tup [n1,a2] :-> Error ("Empty Apply:" ++ show ts)  retType
+    | otherwise = Tup [n1,a2] :-> Case n1 cs
hunk ./Grin/EvalInline.hs 62
+    a2 = Var v2 argType
hunk ./Grin/EvalInline.hs 71
-            | n == (1::Int) =  App fname (vs ++ [p2]) ty
-            | n > 1 = Return $ NodeC (toAtom $ 'P':show (n - 1) ++ "_" ++ rs) (vs ++ [p2])
+            | n == (1::Int) =  App fname (vs ++ [a2]) ty
+            | n > 1 = Return $ NodeC (toAtom $ 'P':show (n - 1) ++ "_" ++ rs) (vs ++ [a2])
hunk ./Grin/FromE.hs 276
+        let fty = toType TyNode (getType e)
hunk ./Grin/FromE.hs 280
-                    Just (Const x) -> app (Return x) as
-                    Just x@Var {} -> app (gEval x) as
+                    Just (Const x) -> app fty (Return x) as
+                    Just x@Var {} -> app fty (gEval x) as
hunk ./Grin/FromE.hs 284
-                        app (gEval var) as   -- CAFs are looked up in global env
+                        app fty (gEval var) as   -- CAFs are looked up in global env
hunk ./Grin/FromE.hs 288
-                    app (App v x es) y
+                    app fty (App v x es) y
hunk ./Grin/FromE.hs 292
-            Nothing -> app (gEval $ toVal v) as
+            Nothing -> app fty (gEval $ toVal v) as
hunk ./Grin/FromE.hs 294
+        let fty = toType TyNode (getType e)
hunk ./Grin/FromE.hs 297
-        app e as
+        app fty e as
hunk ./Grin/FromE.hs 410
-        --let (e',as') = fromLam e
hunk ./Grin/FromE.hs 411
-        --es <- mapM (\_ -> newNodePtrVar) (drop (length as') es)
-        --x <- app x es
hunk ./Grin/FromE.hs 421
-            --z <- const $ ELit l
hunk ./Grin/FromE.hs 427
-    app e [] = return e
-    app e (a:as) = do
+    app _ e [] = return e
+    app ty e [a] = do
hunk ./Grin/FromE.hs 430
-        app (e :>>= v :-> gApply v a) as
+        return (e :>>= v :-> App funcApply [v,a] ty)
+    app ty e (a:as) = do
+        v <- newNodeVar
+        app ty (e :>>= v :-> gApply v a) as
hunk ./Grin/FromE.hs 458
-        d <- app (gEval p1) (tail args)
+        d <- app TyNode (gEval p1) (tail args) --TODO
hunk ./Grin/FromE.hs 489
-                    --fail "thinking still..."
hunk ./Grin/FromE.hs 525
-
-                    --return (e :>>= v :->
-                    --        Fetch v :>>= v' :->
-                    --        Update (toVal tvr) v')
hunk ./Grin/Grin.hs 397
+    typecheck te ap@(App fn [v,a] t) | fn == funcApply = do
+        [v',a'] <- mapM (typecheck te) [v,a]
+        if v' == TyNode then return t
+         else fail $ "App apply arg doesn't match: " ++ show ap
hunk ./Grin/PointsToAnalysis.hs 301
-        g app@(App a [vr@(Var v _),y] _)
+        g app@(App a [vr@(Var v _),y] ty)
hunk ./Grin/PointsToAnalysis.hs 303
-                Just ts ->  Return (Tup [vr,y]) :>>= createApply typeEnv ts
+                Just ts ->  Return (Tup [vr,y]) :>>= createApply (getType y) ty typeEnv ts