[when skipping eval-apply optimization, generate generic apply and eval functions
John Meacham <john@repetae.net>**20060404120908] hunk ./Grin/EvalInline.hs 4
+    createEvalApply,
hunk ./Grin/EvalInline.hs 9
-import List
-import Grin.Grin
+import Char
hunk ./Grin/EvalInline.hs 11
+import List
+import qualified Data.Set as Set
+import qualified Data.Map as Map
+
hunk ./Grin/EvalInline.hs 16
-import Char
+import Grin.Grin
+import GenUtil
+import Support.FreeVars
+import Support.CanType
+import Util.Once
+import Util.UniqueMonad
hunk ./Grin/EvalInline.hs 29
-createEval shared  te ts
+createEval shared  te ts'
hunk ./Grin/EvalInline.hs 66
+    ts = sortUnder toPackedString ts'
hunk ./Grin/EvalInline.hs 104
-createApply argType retType te ts
+createApply argType retType te ts'
hunk ./Grin/EvalInline.hs 108
+    ts = sortUnder toPackedString ts'
hunk ./Grin/EvalInline.hs 110
-    cs = [ f t | t <- ts, tagIsPartialAp t]
+    cs = [ f t | t <- ts, tagGood t]
+    tagGood t | Just (n,fn) <- tagUnfunction t, n > 0 = let
+        ptag = argType == ts !! (length ts - n)
+        rtag = retType == TyNode || (n == 1 && rt == retType)
+        (ts,rt) = runIdentity $ findArgsType te fn
+        in rtag && ptag
+    tagGood _ = False
hunk ./Grin/EvalInline.hs 120
-        ('P':cs) = fromAtom t
-        (n','_':rs) = span isDigit cs
-        n = read n'
-        g
-            | n == (1::Int) =  App fname (vs ++ [a2]) ty
-            | n > 1 = Return $ NodeC (toAtom $ 'P':show (n - 1) ++ "_" ++ rs) (vs ++ [a2])
-            | otherwise = error "createApply"
+        Just (n,fn) = tagUnfunction t
+        g | n == 1 =  App fn (vs ++ [a2]) ty
+          | n > 1 = Return $ NodeC (partialTag fn (n - 1)) (vs ++ [a2])
+          | otherwise = error "createApply"
hunk ./Grin/EvalInline.hs 125
-            fname = (toAtom $ 'f':rs)
-            Just (_,ty) = findArgsType te fname
+            Just (_,ty) = findArgsType te fn
+
+{-# NOINLINE createEvalApply #-}
+createEvalApply :: Grin -> IO Grin
+createEvalApply grin = do
+    let eval = (funcEval,Tup [earg] :-> ebody) where
+            earg :-> ebody  =  createEval TrailingUpdate (grinTypeEnv grin) tags
+        tags = Set.toList $ ftags `Set.union` plads
+        ftags = freeVars (map (lamExp . snd) $ grinFunctions grin)
+        plads = Set.fromList $ concatMap mplad (Set.toList ftags)
+        mplad t | Just (n,tag) <- tagUnfunction t, n > 1 = t:mplad (partialTag tag (n - 1))
+        mplad t = [t]
+    appMap <- newOnceMap
+    let f (ls :-> exp) = do
+            exp' <- g exp
+            return $ ls :-> exp'
+        g (exp :>>= lam) = do
+            exp' <- g exp
+            lam' <- f lam
+            return (exp' :>>= lam')
+        g (Case v ls) = do
+            ls' <- mapM f ls
+            return $ Case v ls'
+        g (App fn [fun,arg] ty) | fn == funcApply = do
+            fn' <- runOnceMap appMap (getType arg,ty) $ do
+                u <- newUniq
+                return (toAtom $ "@apply_" ++ show u)
+            return (App fn' [fun,arg] ty)
+        g x = return x
+    funcs <- mapMsnd f (grinFunctions grin)
+    as <- onceMapToList appMap
+    let (apps,ntyenv) = unzip $ map cf as
+        cf ((targ,tret),name) = ((name,appBody),(name,([TyNode,targ],tret))) where
+            appBody = createApply targ tret (grinTypeEnv grin) tags
+        TyEnv tyEnv = grinTypeEnv grin
+        appTyEnv = Map.fromList ntyenv
+    return $ grin { grinTypeEnv = TyEnv (tyEnv `Map.union` appTyEnv), grinFunctions = apps ++ eval:funcs}
+
+
+
hunk ./Main.hs 43
+import Grin.EvalInline(createEvalApply)
hunk ./Main.hs 608
-    wdump FD.Grin $ printGrin x
+    --wdump FD.Grin $ printGrin x
hunk ./Main.hs 652
+        x <- createEvalApply x
+        x <- return $ normalizeGrin x
+        typecheckGrin x