[don't create CAFs due to dropping unused argument
John Meacham <john@repetae.net>**20060313123522] hunk ./Grin/FromE.hs 6
+import Data.Typeable
hunk ./Grin/FromE.hs 22
+import qualified Info.Info as Info
hunk ./Grin/FromE.hs 74
-
hunk ./Grin/FromE.hs 76
+-- after pruning the E, we should not accidentally turn things into CAFs that wern't already.
+newtype IsCAF = IsCAF Bool
+    deriving(Typeable,Show,Eq)
+
hunk ./Grin/FromE.hs 122
-compile prog@Program { progDataTable = dataTable, progCombinators = cm, progMainEntry = mt } = do
+compile prog@Program { progDataTable = dataTable, progMainEntry = mainEntry } = do
+    prog <- return $ prog { progCombinators  = map stripTheWorld (progCombinators prog) }
hunk ./Grin/FromE.hs 127
-    let (cc,reqcc) = constantCaf prog
+    let (cc,reqcc,rcafs) = constantCaf prog
hunk ./Grin/FromE.hs 130
+        putErrLn "Recursive"
hunk ./Grin/FromE.hs 132
+        putErrLn "Constant"
hunk ./Grin/FromE.hs 134
+        putErrLn "CAFS"
+        putDocMLn putStr $ vcat [ pprint v <+> pprint n <+> pprint e | (v,n,e) <- rcafs ]
hunk ./Grin/FromE.hs 144
-            ccafMap = Map.fromList [ (tvrNum v,e) |(v,_,e) <- cc]
+            ccafMap = Map.fromList $ [(tvrNum v,e) |(v,_,e) <- cc ]  ++ [ (tvrNum v,Var vv (TyPtr TyNode)) | (v,vv,_) <- rcafs]
hunk ./Grin/FromE.hs 146
-    ds <- mapM doCompile [ c | c@(v,_,_) <- cm, v `notElem` [x | (x,_,_) <- cc]]
-    (_,(Tup [] :-> theMain)) <- doCompile ((mt,[],EVar mt))
+    ds <- mapM doCompile [ c | c@(v,_,_) <- progCombinators prog, v `notElem` [x | (x,_,_) <- cc]]
+    (_,(Tup [] :-> theMain)) <- doCompile ((mainEntry,[],EVar mainEntry))
hunk ./Grin/FromE.hs 164
-        cafs = [ ((V $ - atomIndex tag),NodeC tag []) | (x,(Tup [] :-> _)) <- ds, let tag = partialTag x 0 ] ++ [ (y,z') |(x,y,z) <- cc, y `elem` reqcc, let Const z' = z ]
+        -- cafs = [ ((V $ - atomIndex tag),NodeC tag []) | (x,(Tup [] :-> _)) <- ds, let tag = partialTag x 0 ] ++ [ (y,z') |(x,y,z) <- cc, y `elem` reqcc, let Const z' = z ]
+        cafs = [ (x,y) | (_,x,y) <- rcafs ]
hunk ./Grin/FromE.hs 176
-    typecheckGrin grin
+    --typecheckGrin grin
hunk ./Grin/FromE.hs 189
-stripTheWorld (t,as,e) = (t,filter (shouldKeep . getType) as,e)
+stripTheWorld (t,as,e) = (tvrInfo_u (Info.insert (IsCAF caf)) t,filter (shouldKeep . getType) as,e) where
+    caf = null as
hunk ./Grin/FromE.hs 218
-constantCaf :: Program -> ([(TVr,Var,Val)],[Var])
+constantCaf :: Program -> ([(TVr,Var,Val)],[Var],[(TVr,Var,Val)])
hunk ./Grin/FromE.hs 220
-    (lbs',cafs) = G.findLoopBreakers (const 0) (const True) $ G.newGraph [ (v,e) | (v,[],e) <- ds, canidate e] (tvrNum . fst) (freeVars . snd)
+    -- All CAFS
+    ecafs = [ (v,e) | (v,[],e) <- ds, Just (IsCAF True) == Info.lookup (tvrInfo v) ]
+    -- just CAFS that can be converted to constants need dependency analysis
+    (lbs',cafs) = G.findLoopBreakers (const 0) (const True) $ G.newGraph (filter (canidate . snd) ecafs) (tvrNum . fst) (freeVars . snd)
hunk ./Grin/FromE.hs 229
-    ans = ([ (v,cafNum v,conv e) | (v,e) <- cafs ],[ cafNum v | (v,_) <- cafs, v `Set.member` lbs ])
+    ans = ([ (v,cafNum v,conv e) | (v,e) <- cafs ],[ cafNum v | (v,_) <- cafs, v `Set.member` lbs ], [(v,cafNum v, NodeC (partialTag n 0) []) | (v,e) <- ecafs, not (canidate e), let n = scTag v ])
hunk ./Grin/FromE.hs 231
-    coMap = Map.fromList [  (v,ce)| (v,_,ce) <- fst ans]
+    coMap = Map.fromList [  (v,ce)| (v,_,ce) <- fst3 ans]
hunk ./Grin/FromE.hs 245
+    fst3 (x,_,_) = x
hunk ./Grin/FromE.hs 301
-        case Map.lookup (tvrNum v) (scMap cenv) of
-            Just (_,[],_) -> do
-                case constant (EVar v) of
-                    Just (Const x) -> app fty (Return x) as
-                    Just x@Var {} -> app fty (gEval x) as
-            Just (v,as',es)
-                | length as >= length as' -> do
-                    let (x,y) = splitAt (length as') as
-                    app fty (App v x es) y
-                | otherwise -> do
-                    let pt = partialTag v (length as' - length as)
-                    return $ Return (NodeC pt as)
-            Nothing -> app fty (gEval $ toVal v) as
+        case Map.lookup (tvrNum v) (ccafMap cenv) of
+            Just (Const c) -> app fty (Return c) as
+            Just x@Var {} -> app fty (gEval x) as
+            Nothing -> case Map.lookup (tvrNum v) (scMap cenv) of
+                Just (v,as',es)
+                    | length as >= length as' -> do
+                        let (x,y) = splitAt (length as') as
+                        app fty (App v x es) y
+                    | otherwise -> do
+                        let pt = partialTag v (length as' - length as)
+                        return $ Return (NodeC pt as)
+                Nothing -> app fty (gEval $ toVal v) as
hunk ./Grin/FromE.hs 561
-                         , t <- partialTag v (length as)  = case tagIsWHNF t of
-                            True -> return $ Const $ NodeC t []
-                            False -> return $ Var (V $ - atomIndex t) (TyPtr TyNode)
-                            --case constant e of
-                            --    Just x -> return x
-                            --    Nothing -> return $ Var (V $ - atomIndex t) (TyPtr TyNode)
+                         , t <- partialTag v (length as), tagIsWHNF t = return $ Const $ NodeC t []
+    --                        False -> return $ Var (V $ - atomIndex t) (TyPtr TyNode)