[clean up type analysis code some, be sure to specialize arguments of applications
John Meacham <john@repetae.net>**20070606030040] hunk ./E/TypeAnalysis.hs 7
-import Control.Monad.Reader
hunk ./E/TypeAnalysis.hs 30
-import GenUtil
hunk ./E/TypeAnalysis.hs 36
-import Support.FreeVars
hunk ./E/TypeAnalysis.hs 82
-    let (prog',stats) = Stats.runStatM $ specializeProgram doSpecialize (Set.fromList unusedRules) (Set.fromList unusedValues) prog
+    let (prog',stats) = Stats.runStatM $ specializeProgram doSpecialize (fromList unusedRules) (fromList unusedValues) prog
hunk ./E/TypeAnalysis.hs 203
-getValue e = value `liftM` fuzzyConstant e  -- TODO - make more accurate
+getValue e = return $ value $ fuzzyConstant e -- TODO - make more accurate
hunk ./E/TypeAnalysis.hs 206
-fuzzyConstant e | Just c <- typConstant e = return c
-fuzzyConstant e | Just (n,as) <- toLit e = do
-    as' <- mapM fuzzyConstant as
-    return $ vmapValue n as'
-fuzzyConstant _ = return $ (vmapPlaceholder ())
-
+fuzzyConstant :: E -> Typ
+fuzzyConstant e | Just (n,as) <- toLit e = vmapValue n (map fuzzyConstant as)
+fuzzyConstant _ = vmapPlaceholder ()
hunk ./E/TypeAnalysis.hs 211
-typConstant (EPi TVr { tvrType = a} b) = do
-    ab <- mapM typConstant [a,b]
-    return $ vmapValue tc_Arrow ab
-typConstant (ELit LitCons { litName = n, litArgs = xs }) = do
-    xs' <- mapM typConstant xs
-    return $ vmapValue n xs'
+typConstant e | Just (n,as) <- toLit e = return (vmapValue n) `ap` mapM typConstant as
hunk ./E/TypeAnalysis.hs 215
--- pruning the unused branches of typecase statements
-
-
-pruneE :: E -> IO E
-pruneE e = return $ runIdentity (prune e)  where
-    prune ec@ECase { eCaseScrutinee = EVar v } | sortKindLike (getType v), Just vm <- Info.lookup (tvrInfo v) = do
-        ec' <- pruneCase ec vm
-        emapE' prune ec'
-    prune e = emapE' prune e
-
-pruneCase :: (Monad m) => E -> VMap () Name -> m E
-pruneCase ec ns = return $ if null (caseBodies nec) then err else nec where
-    err = EError "pruneCase: all alternatives pruned" (getType ec)
-    nec = caseUpdate ec { eCaseAlts = f [] $ eCaseAlts ec, eCaseDefault = cd (eCaseDefault ec)}
-    f xs [] = reverse xs
-    f xs (alt@(Alt LitCons { litName = n } _):rs) | not (n `vmapMember` ns) = f xs rs
-    f xs (alt:rs) = f (alt:xs) rs
-    cd (Just d) | Just nns <- vmapHeads ns, or [ n `notElem` as | n <- nns ] = Just d
-                | Nothing <- vmapHeads ns = Just d
-    cd Nothing = Nothing
-    -- The reason we do this is because for a typecase, we need a valid default in order to get the most general type
-    cd (Just d) = Just $ EError "pruneCase: default pruned" (getType d)
-    as = [ n | LitCons { litName = n } <- casePats ec ]
-
hunk ./E/TypeAnalysis.hs 228
-    -- f n kind vm | Just [] <- vmapHeads vm = return $ tAbsurd kind  TODO - absurdize values properly
+    f n kind vm | Just [] <- vmapHeads vm = return $ tAbsurd kind  -- TODO - absurdize values properly
hunk ./E/TypeAnalysis.hs 252
-specializeDef _ env  (tvr,e) | isUnused env tvr = return (tvr,EError ("Unused Def: " ++ tvrShowName tvr) (tvrType tvr))
-specializeDef _ _ (t,e) | getProperty prop_PLACEHOLDER t = return (t,e)
-specializeDef True SpecEnv { senvDataTable = dataTable }  (tvr,e) = ans where
+specializeDef _ env  (tvr,e) | isUnused env tvr = return ((tvr,EError ("Unused Def: " ++ tvrShowName tvr) (tvrType tvr)), mempty)
+specializeDef _ _ (t,e) | getProperty prop_PLACEHOLDER t = return ((t,e), mempty)
+specializeDef True SpecEnv { senvDataTable = dataTable }  (tvr,e) | needsSpec = ans where
hunk ./E/TypeAnalysis.hs 261
+    vs = [ (n,v) | ((_,Just v),n) <- zip sts naturals ]
+    needsSpec = not $ null vs
hunk ./E/TypeAnalysis.hs 265
-        let vs = [ (n,v) | ((_,Just v),n) <- zip sts naturals ]
-            sd = not $ null vs
-        when sd $ tell (msingleton tvr (fsts vs))
-        return (if sd then tvr { tvrType = infertype dataTable ne, tvrInfo = infoMap (dropArguments vs) (tvrInfo tvr) } else tvr,ne)
-specializeDef _ _ (t,e) = return (t,e)
+        return ((tvr { tvrType = infertype dataTable ne, tvrInfo = infoMap (dropArguments vs) (tvrInfo tvr) },ne),msingleton tvr (fsts vs))
+specializeDef _ _ (t,e) = return ((t,e),mempty)
hunk ./E/TypeAnalysis.hs 269
+
hunk ./E/TypeAnalysis.hs 322
-isUnused SpecEnv { senvUnusedVars = unusedVars } v = v `Set.member` unusedVars && isJust (Info.lookup $ tvrInfo v :: Maybe Typ)
+isUnused SpecEnv { senvUnusedVars = unusedVars } v = v `member` unusedVars && isJust (Info.lookup $ tvrInfo v :: Maybe Typ)
hunk ./E/TypeAnalysis.hs 328
-specBody True SpecEnv { senvArgs = dmap } e | (EVar h,as) <- fromAp e, Just os <- mlookup h dmap = do
+specBody True env@SpecEnv { senvArgs = dmap } e | (EVar h,as) <- fromAp e, Just os <- mlookup h dmap = do
hunk ./E/TypeAnalysis.hs 330
-    return $ foldl EAp (EVar h) [ a | (a,i) <- zip as naturals, i `notElem` os ]
+    as' <- mapM (specBody True env) as
+    return $ foldl EAp (EVar h) [ a | (a,i) <- zip as' naturals, i `notElem` os ]
hunk ./E/TypeAnalysis.hs 343
-    (ds,nenv) <- runWriterT $ mapM (specializeDef doSpecialize env) ds
+    (ds,nenv) <- mapAndUnzipM (specializeDef doSpecialize env) ds
+    let tenv = env { senvArgs = unions nenv `union` senvArgs env }
+        sb = specBody doSpecialize tenv
hunk ./E/TypeAnalysis.hs 349
-            nfo <- infoMapM (return . arules . filter ( not . (`Set.member` unusedRules) . ruleUniq) . rulesFromARules) nfo
+            nfo <- infoMapM (return . arules . filter ( not . (`member` unusedRules) . ruleUniq) . rulesFromARules) nfo
hunk ./E/TypeAnalysis.hs 351
-        tenv = env { senvArgs = nenv `mappend` senvArgs env }
-        sb = specBody doSpecialize tenv
hunk ./E/TypeAnalysis.hs 386
+{-
+
+-- pruning the unused branches of typecase statements
+
+
+pruneE :: E -> IO E
+pruneE e = return $ runIdentity (prune e)  where
+    prune ec@ECase { eCaseScrutinee = EVar v } | sortKindLike (getType v), Just vm <- Info.lookup (tvrInfo v) = do
+        ec' <- pruneCase ec vm
+        emapE' prune ec'
+    prune e = emapE' prune e
+
+pruneCase :: (Monad m) => E -> VMap () Name -> m E
+pruneCase ec ns = return $ if null (caseBodies nec) then err else nec where
+    err = EError "pruneCase: all alternatives pruned" (getType ec)
+    nec = caseUpdate ec { eCaseAlts = f [] $ eCaseAlts ec, eCaseDefault = cd (eCaseDefault ec)}
+    f xs [] = reverse xs
+    f xs (alt@(Alt LitCons { litName = n } _):rs) | not (n `vmapMember` ns) = f xs rs
+    f xs (alt:rs) = f (alt:xs) rs
+    cd (Just d) | Just nns <- vmapHeads ns, or [ n `notElem` as | n <- nns ] = Just d
+                | Nothing <- vmapHeads ns = Just d
+    cd Nothing = Nothing
+    -- The reason we do this is because for a typecase, we need a valid default in order to get the most general type
+    cd (Just d) = Just $ EError "pruneCase: default pruned" (getType d)
+    as = [ n | LitCons { litName = n } <- casePats ec ]
hunk ./E/TypeAnalysis.hs 412
+-}