[get rid of old occurrance checking code, separate occurance checking from simplification pass
John Meacham <john@repetae.net>**20060411001610] {
hunk ./E/SSimplify.hs 6
+    programSSimplify,
hunk ./E/SSimplify.hs 63
-{-
-combineOccInfo k a b | a == b = a
-combineOccInfo k a b =  error $ "Conflicting occurance info: " ++ show (k,a,b)
-
-
--- | This collects occurance info for variables, deletes dead expressions, and reorders let-bound variables in dependency order.
-collectOcc :: SimplifyOpts ->  E -> (E,IdSet,Map.Map TVr Occurance)
-collectOcc sopts  e = (e',fvs,occ) where
-    topLevels = so_exports sopts
-    rules  = so_rules sopts
-    dataTable = so_dataTable sopts
-    ((e',fvs,_),occ') = runWriter $ f e
-    rule_set = ruleAllFreeVars rules
-    occ = foldl (Map.unionWithKey combineOccInfo) mempty (Seq.toList occ')
-    f e@(EPi (TVr { tvrIdent = 0, tvrType =  a}) b) = return (e,(freeVars [a,b]),(args [a,b]))
-    f e@(EPi tvr@(TVr { tvrIdent = n, tvrType =  a}) b) = if n `member` fvs || n `mmember` ags then return (e,delete n fvs ,mdelete n ags) else return (EPi (tvr { tvrIdent =  0 } ) b,fvs,ags)  where
-        fvs = (freeVars [a,b])
-        ags = args [a,b]
-    f e@(ELit (LitCons n as t)) = return (e,freeVars (t:as),args as)
-    f e@ELit {} = return (e,freeVars e,mempty)
-    f e@(EPrim _ as t) = return (e,freeVars (t:as),args as)
-    f e@(EError _ t) =  return (e,freeVars t,mempty)
-    f e@ELam {} | (b,as) <- fromLam e = do
-        (b',fvs,bs) <- f b
-        return (foldr ELam b' as,foldr delete  (freeVars (map tvrType as) `mappend` fvs) (map tvrIdent as), fmap inLam $ foldr mdelete bs (map tvrIdent as))
-    f e | Just (x,t) <- from_unsafeCoerce e  = do (a,b,c) <- f x ; return (prim_unsafeCoerce a t, b `mappend` freeVars t, c)
-    f e | (EVar (TVr { tvrIdent = n, tvrType =  t}),xs) <- fromAp e = do
-        return (e,freeVars (t:xs), msingleton n Once `andOM` args xs)
-    f ec@ECase { eCaseScrutinee = e, eCaseBind = b, eCaseAlts = as, eCaseDefault = d} = do
-        (e',fva,sa) <- f e
-        (d',fvb,sb) <- case d of
-            Nothing -> return (Nothing,mempty,mempty)
-            Just e -> do (a,b,c) <- f e; return (Just a,b,c)
-        (as',fvas,ass) <- mapAndUnzip3M alt as
-        let fvs = mconcat $ [fva,freeVars $ eCaseType ec, freeVars $ tvrType b, fvb] ++ fvas
-        return (ec { eCaseScrutinee = e', eCaseAlts = as', eCaseDefault = d'}, fvs, sa `andOM` orMaps (sb:ass) )
-    f (ELetRec ds e) = do
-        ds' <- mapM  (censor (const mempty) . listen . f . snd) ds
-        (e',fve,se) <- f e
-        let gfv (_,fv,i) = fvs ++ idSetToList (mconcat (map (ruleFreeVars' rules) (fvs)))  where
-                fvs = idSetToList (fromDistinctAscList (Map.keys i) `union` fv)
-            gr = newGraph (zip (fsts ds) ds') (tvrIdent . fst) (gfv . fst . snd )
-            nn' = reachable gr (idSetToList fve ++ Map.keys se ++  topLevels)
-        nn <- sequence [ tell t >> return (x,y) |  (x,(y,t)) <- nn' ]
-        let gr' = newGraph nn (tvrIdent . fst) (gfv . snd )
-            (lb,ds'') = findLoopBreakers (\ (t,(e,_,_)) -> loopFunc t e) (const True) gr'
-            cycNodes = (fromList $ [ tvrIdent v | (v,_) <- cyclicNodes gr'] :: IdSet)
-            calcStrictInfo t _
-                | tvrIdent t `member` cycNodes = setProperty prop_CYCLIC
-                | otherwise = id
-        let dvars = map (tvrIdent . fst) ds
-            fvs = foldr delete (mconcat (fve:[ fv `mappend` freeVars t | (TVr { tvrType =  t},(_,fv,_)) <- ds'' ])) dvars
-            finalS = union (fromList [(n,LoopBreaker) | (TVr { tvrIdent = n },_) <- lb ]) $   foldl andOM se ([ s | (_,(_,_,s)) <- ds'' ])
-        tell $ Seq.singleton (fromList [ (t,Map.findWithDefault Unused n (Map.mapWithKey frules finalS)) | (t@(TVr { tvrIdent = n }),_) <- ds'' ])
-        return (eLetRec [ (tvrInfo_u ((calcStrictInfo v e)) v,e) | (v,(e,_,_)) <- ds'' ] e', fvs, finalS  )
-        --return (substLet' [ (v,e) | (v,(e,_,_)) <- ds'' ] e', fvs, finalS  )
-    f e@(EAp a b)  = case runIdentity $ app (fromAp e) of
-            EAp a' b' | a == a' && b == b' -> error $ "SSimplify.collectOcc.f: " ++ show e
-            e -> f e
-    f e = error $ "SSimplify.collectOcc.f: " ++ show e
-    frules k _ | k `member` rule_set = Many
-    frules _ x = x
-    alt (Alt l e) = do
-        (e',b,c) <- f e
-        return (Alt l e',foldr delete (freeVars l `mappend` b) (map tvrIdent $ litBinds l),foldr mdelete c (map tvrIdent $ litBinds l))
-    args as = ans where
-        ans = fromList [ (i,Many) | Just (EVar (TVr { tvrIdent = i }),_) <- map (\e -> from_unsafeCoerce e `mplus` Just (e,Unknown)) as]
-
--}
-
hunk ./E/SSimplify.hs 83
+
+maybeLetRec [] e = e
+maybeLetRec ds e = ELetRec ds e
+
hunk ./E/SSimplify.hs 150
-        return (ELetRec ds''' e')
+        return (maybeLetRec ds''' e')
hunk ./E/SSimplify.hs 282
+programSSimplify :: SimplifyOpts -> Program -> Program
+programSSimplify sopts prog =
+    let (stats,dsIn) = simplifyDs sopts (programDs prog)
+    in (programSetDs dsIn prog) { progStats = progStats prog `mappend` stats }
+
+
hunk ./E/SSimplify.hs 293
-        let (dsIn',fvs) = collectDs dsIn (fromList $ map (flip (,) Many) (map (tvrIdent . fst) dsIn))
-        addNames (mkeys fvs)
+        --let (dsIn',fvs) = collectDs dsIn (fromList $ map (flip (,) Many) (map (tvrIdent . fst) dsIn))
+        --addNames (mkeys fvs)
hunk ./E/SSimplify.hs 298
-        return dsIn'
+        return dsIn
hunk ./E/SSimplify.hs 336
-    g e@(EVar tvr) sub inb = f e sub inb
hunk ./E/SSimplify.hs 363
-    g (ELetRec [] e) sub inb = g e sub inb
+--    g (ELetRec [] e) sub inb = g e sub inb
hunk ./E/SSimplify.hs 425
-    g e _ _ = error $ "SSimplify.simplify.g: " ++ show e
+    g e _ _ = error $ "SSimplify.simplify.g: " ++ show e ++ "\n" ++ pprint e
}
