[drop unused arguments from functions completely
John Meacham <john@repetae.net>**20060129080855] hunk ./GenUtil.hs 2
---  $Id: GenUtil.hs,v 1.47 2006/01/28 02:15:30 john Exp $
+--  $Id: GenUtil.hs,v 1.48 2006/01/29 05:22:26 john Exp $
hunk ./GenUtil.hs 57
+    naturals,
hunk ./GenUtil.hs 723
+{-# INLINE naturals #-}
+naturals :: [Int]
+naturals = [0..]
hunk ./Grin/DeadCode.hs 7
+import qualified Data.Map as Map
hunk ./Grin/DeadCode.hs 13
+import GenUtil
hunk ./Grin/DeadCode.hs 52
+    pappFuncs <- readValue pappFuncs
+    suspFuncs <- readValue suspFuncs
hunk ./Grin/DeadCode.hs 57
+        directFuncs =  funSet Set.\\ suspFuncs Set.\\ pappFuncs
hunk ./Grin/DeadCode.hs 63
-        r <- runStatIO stats $ removeDeadArgs postInline cafSet argSet (x,y)
+        r <- runStatIO stats $ removeDeadArgs postInline funSet directFuncs cafSet argSet (x,y)
hunk ./Grin/DeadCode.hs 65
-    pappFuncs <- readValue pappFuncs
-    suspFuncs <- readValue suspFuncs
+    let (TyEnv mp) = grinTypeEnv grin
+    mp' <- flip mconcatMapM (Map.toList mp) $ \ (x,(ts,rt)) -> case Just x  of
+        Just _ | tagIsFunction x, not $ x `Set.member` funSet -> return []
+        Just fn | fn `Set.member` directFuncs -> do
+            let da (t,i)
+                    | Set.member (fn,i) argSet = return [t]
+                    | otherwise = tick stats ("Optimize.dead-code.arg-func.{" ++ show x ++ "-" ++ show i) >> return []
+            ts' <- mconcatMapM da (zip ts naturals)
+            return [(x,(ts',rt))]
+        _ -> return [(x,(ts,rt))]
+
+
hunk ./Grin/DeadCode.hs 87
+        grinTypeEnv = TyEnv $ Map.fromList mp',
hunk ./Grin/DeadCode.hs 150
-removeDeadArgs :: MonadStats m => Bool -> (Set.Set Var) -> (Set.Set (Atom,Int)) -> (Atom,Lam) -> m (Atom,Lam)
-removeDeadArgs postInline usedCafs usedArgs (a,l) =  whizExps f l >>= return . (,) a where
+removeDeadArgs :: MonadStats m => Bool -> Set.Set Atom -> Set.Set Atom -> (Set.Set Var) -> (Set.Set (Atom,Int)) -> (Atom,Lam) -> m (Atom,Lam)
+removeDeadArgs postInline funSet directFuncs usedCafs usedArgs (a,l) =  whizExps f (margs l) >>= return . (,) a where
+    margs (Tup as :-> e) | a `Set.member` directFuncs = (Tup (removeArgs a as) :-> e)
+    margs x = x
hunk ./Grin/DeadCode.hs 174
-    dff' fn as | postInline = return as
-    dff' fn as = dff fn as
-    dff fn as = mapM df  (zip as [0..]) where
-        deadVal (Lit 0 _) = True
-        deadVal x =  isHole x
+    dff' fn as | fn `Set.member` directFuncs = return as
+    dff' fn as = dff'' fn as
+    dff fn as | fn `Set.member` directFuncs = return (removeArgs fn as)
+    dff fn as = dff'' fn as
+    dff'' fn as | not (fn `Set.member` funSet) = return as -- if function was dropped, we don't have argument use information.
+    dff'' fn as = mapM df  (zip as naturals) where
hunk ./Grin/DeadCode.hs 200
-    deadCaf v =  v < v0 && not (v `Set.member` usedCafs)
+    deadCaf v = v < v0 && not (v `Set.member` usedCafs)
+    deadVal (Lit 0 _) = True
+    deadVal x = isHole x
+    removeArgs fn as = concat [ perhapsM ((fn,i) `Set.member` usedArgs) a | a <- as | i <- naturals ]
hunk ./Grin/FromE.hs 122
-    wdump FD.Tags $ do
-        dumpTyEnv initTyEnv
hunk ./Grin/FromE.hs 145
-    te <- readIORef tyEnv
+    TyEnv endTyEnv <- readIORef tyEnv
+    let newTyEnv = TyEnv $ Map.fromList $ concatMap makePartials (Map.toList endTyEnv)
+    wdump FD.Tags $ do
+        dumpTyEnv newTyEnv
hunk ./Grin/FromE.hs 165
-            grinTypeEnv = te,
+            grinTypeEnv = newTyEnv,
hunk ./Grin/FromE.hs 182
+makePartials (fn,(ts,rt)) | tagIsFunction fn, head (show fn) /= '@'  = (fn,(ts,rt)):[(partialTag fn i,(reverse $ drop i $ reverse ts ,TyNode)) |  i <- [0.. end] ]  where
+    end | 'b':_ <- show fn = 0
+        | otherwise = length ts
+makePartials x = [x]
hunk ./Grin/FromE.hs 193
+    (funcMain, ([],tyUnit)),
hunk ./Grin/Grin.hs 4
-    Builtin,
hunk ./Grin/Grin.hs 283
-type Builtin = [Val] -> IO Val
-
hunk ./Grin/Grin.hs 381
-findArgsType (TyEnv m) a | ('F':rs) <- fromAtom a = case Map.lookup (toAtom ('f':rs)) m of
-    Just x -> return x
-    Nothing -> fail $ "findArgsType: " ++ show a
-findArgsType (TyEnv m) a | ('B':rs) <- fromAtom a = case Map.lookup (toAtom ('b':rs)) m of
-    Just x -> return x
-    Nothing -> fail $ "findArgsType: " ++ show a
-findArgsType (TyEnv m) a | ('P':rs) <- fromAtom a, (ns,'_':rs) <- span isDigit rs  = case Map.lookup (toAtom ('f':rs)) m of
-    Just (ts,n) -> return (take (length ts - read ns) ts,n)
-    Nothing -> fail $ "findArgsType: " ++ show a
hunk ./Grin/Grin.hs 384
-findArgsType _ a | a == toAtom "TAbsurd#" = return ([],TyNode)
-findArgsType _ a | a == funcEval = return ([TyPtr TyNode],TyNode)
-findArgsType _ a | a == funcApply = return ([TyNode, TyPtr TyNode],TyNode)
-findArgsType _ a | a == funcMain = return ([],tyUnit)
-findArgsType _ a | a == tagHole = return ([],TyNode)
hunk ./Grin/Interpret.hs 21
+
+type Builtin = [Val] -> IO Val
hunk ./Grin/PointsToAnalysis.hs 757
-naturals = [0::Int ..]
hunk ./Main.hs 441
-        --deadFunctions stats' [funcMain] x
hunk ./Main.hs 444
+        wdump FD.Tags $ do
+            dumpTyEnv (grinTypeEnv x)
hunk ./Main.hs 602
+dumpTyEnv (TyEnv tt) = mapM_ putStrLn $ sort [ show n <+> hsep (map show as) <+> "::" <+> show t |  (n,(as,t)) <- Map.toList tt]