[major changes to E, now all lets are checked for types and they are inlined when they are created, strictness is taken into account properly, lots of bug fixes
John Meacham <john@repetae.net>**20051006050708] hunk ./E/E.hs 267
-eLetRec :: [(TVr,E)] -> E -> E
-eLetRec ds e = f (filter ((/= 0) . tvrNum . fst) ds) where
-    f [] = e
-    f ds = ELetRec ds e
+--eLetRec :: [(TVr,E)] -> E -> E
+--eLetRec ds e = f (filter ((/= 0) . tvrNum . fst) ds) where
+--    f [] = e
+--    f ds = ELetRec ds e
hunk ./E/FreeVars.hs 9
+import qualified Data.Map as Map
hunk ./E/FreeVars.hs 43
+instance FreeVars E (Map.Map Id (Maybe E)) where
+    freeVars e = Map.fromAscList [ (v,Nothing) |  v <- IM.keys (freeVars e :: IM.IntMap TVr )]
hunk ./E/FromHs.hs 200
-                | ELam x e <- defe, not (isAtomic (tipe t)) = return $ calt $ eLetRec [(x,tipe t)] e
+                | ELam x e <- defe, not (isAtomic (tipe t)) = return $ calt $ substLet [(x,tipe t)] e
hunk ./E/Inline.hs 1
-module E.Inline(inlineDecompose, basicDecompose, emapE, emapE',emapEG, emapE_, bindingFreeVars) where
+module E.Inline(inlineDecompose, basicDecompose, emapE, emapE',emapEG, app, emapE_, bindingFreeVars) where
hunk ./E/Inline.hs 7
+import Atom
hunk ./E/Inline.hs 10
+import E.Subst
hunk ./E/Inline.hs 15
+import Stats
hunk ./E/Inline.hs 73
+app (e,[]) = return e
+app (e,xs) = app' e xs
+
+app' (ELit (LitCons n xs t)) (a:as)  = do
+    mtick (toAtom $ "E.Simplify.typecon-reduce.{" ++ show n ++ "}" )
+    app (ELit (LitCons n (xs ++ [a]) (eAp t a)),as)
+app' (ELam tvr e) (a:as) = do
+    mtick (toAtom "E.Simplify.beta-reduce")
+    app (subst tvr a e,as)   -- TODO Fix quadradic substitution
+app' (EPi tvr e) (a:as) = do
+    mtick (toAtom "E.Simplify.pi-reduce")
+    app (subst tvr a e,as)     -- Okay, types are small
+app' ec@ECase {} xs = do
+    mtick (toAtom "E.Simplify.case-application")
+    let f e = app' e xs
+    caseBodiesMapM f ec
+app' (ELetRec ds e) xs = do
+    mtick (toAtom "E.Simplify.let-application")
+    e' <- app' e xs
+    return $ eLetRec ds e'
+app' (EError s t) xs = do
+    mtick (toAtom "E.Simplify.error-application")
+    return $ EError s (foldl eAp t xs)
+app' e as = do
+    return $ foldl EAp e as
hunk ./E/LambdaLift.hs 17
+import E.Values
hunk ./E/LambdaLift.hs 195
-            tell [ (t,ls,eLetRec rs' e) | (t,ls,e) <- concat ts]
+            tell [ (t,ls,substLet rs' e) | (t,ls,e) <- concat ts]
hunk ./E/LetFloat.hs 23
-import E.Subst(app)
hunk ./E/LetFloat.hs 24
+import E.Values
hunk ./E/LetFloat.hs 35
-    return $ ELetRec ds e
+    return $ substLet ds e
hunk ./E/SSimplify.hs 17
+import E.Inline
hunk ./E/SSimplify.hs 96
+            calcStrictInfo t _
+                | t `Set.member` cycNodes = setProperty prop_CYCLIC
+                | otherwise = id
+
+            {-
hunk ./E/SSimplify.hs 105
+            -}
hunk ./E/SSimplify.hs 110
-        -- return (eLetRec [ (tvrInfo_u (Info.insert (calcStrictInfo v e)) v,e) | (v,(e,_,_)) <- ds'' ] e', fvs, finalS  )
-        return (eLetRec [ (v,e) | (v,(e,_,_)) <- ds'' ] e', fvs, finalS  )
+        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  )
hunk ./E/SSimplify.hs 297
-            [(t,e)] | worthStricting e, Just (Strict.S _) <- Info.lookup (tvrInfo t) -> do
+            [(t,e)] | worthStricting e, Just (Strict.S _) <- Info.lookup (tvrInfo t), not (getProperty prop_CYCLIC t) -> do
hunk ./E/SSimplify.hs 346
-        return $ ELetRec ds e'
+        return $ substLet' ds e'
hunk ./E/Strictness.hs 1
-module E.Strictness where
+module E.Strictness(SA(..), solveDs) where
hunk ./E/Strictness.hs 12
+import Binary
hunk ./E/Strictness.hs 16
-import E.Subst
-import E.Values
+import E.Inline
hunk ./E/Strictness.hs 43
+        {-! derive: GhcBinary !-}
hunk ./E/Subst.hs 1
-module E.Subst(subst,subst',eAp, substMap,substMap',noShadow,doSubst,substMap'',litSMapM, app, substLet) where
+module E.Subst(subst,subst',eAp, substMap,substMap',noShadow,doSubst,typeSubst,typeSubst',substMap'',litSMapM ) where
hunk ./E/Subst.hs 8
-import E.E
-import FreeVars
-import E.FreeVars()
-import GenUtil
hunk ./E/Subst.hs 12
-import Stats
-import Atom
+import qualified Data.Set as Set
hunk ./E/Subst.hs 14
+import E.E
+import E.FreeVars()
+import FreeVars
+import GenUtil
hunk ./E/Subst.hs 19
-substLet :: [(TVr,E)] -> E -> E
-substLet ds e  = ans where
-    (as,nas) = partition (isAtomic . snd) (filter ((/= 0) . tvrNum . fst) ds)
-    ans = eLetRec nas (substMap' (Map.fromList [ (n,e) | (TVr { tvrIdent = n },e) <- as]) e)
+eLetRec :: [(TVr,E)] -> E -> E
+eLetRec ds e = f (filter ((/= 0) . tvrNum . fst) ds) where
+    f [] = e
+    f ds = ELetRec ds e
hunk ./E/Subst.hs 24
+
hunk ./E/Subst.hs 55
-litSMapM f l = fmapM f l
+litSMapM f (LitInt n t) = do
+    t' <- f t
+    return $ LitInt n t'
+--litSMapM f l = fmapM f l
hunk ./E/Subst.hs 73
-substMap' :: Map.Map Int E -> E -> E
+substMap' :: Map.Map Id E -> E -> E
hunk ./E/Subst.hs 77
-substMap'' :: Map.Map Int E -> E -> E
+substMap'' :: Map.Map Id E -> E -> E
hunk ./E/Subst.hs 81
-doSubst :: Bool -> Bool -> Map.Map Int (Maybe E) -> E -> E
+doSubst :: Bool -> Bool -> Map.Map Id (Maybe E) -> E -> E
hunk ./E/Subst.hs 83
-    f :: E -> Map.Map Int (Maybe E) -> E
+    f :: E -> Map.Map Id (Maybe E) -> E
hunk ./E/Subst.hs 170
-app (e,[]) = return e
-app (e,xs) = app' e xs
-
-app' (ELit (LitCons n xs t)) (a:as)  = do
-    mtick (toAtom $ "E.Simplify.typecon-reduce.{" ++ show n ++ "}" )
-    app (ELit (LitCons n (xs ++ [a]) (eAp t a)),as)
-app' (ELam tvr e) (a:as) = do
-    mtick (toAtom "E.Simplify.beta-reduce")
-    app (subst tvr a e,as)   -- TODO Fix quadradic substitution
-app' (EPi tvr e) (a:as) = do
-    mtick (toAtom "E.Simplify.pi-reduce")
-    app (subst tvr a e,as)     -- Okay, types are small
-app' ec@ECase {} xs = do
-    mtick (toAtom "E.Simplify.case-application")
-    let f e = app' e xs
-    caseBodiesMapM f ec
-app' (ELetRec ds e) xs = do
-    mtick (toAtom "E.Simplify.let-application")
-    e' <- app' e xs
-    return $ eLetRec ds e'
-app' (EError s t) xs = do
-    mtick (toAtom "E.Simplify.error-application")
-    return $ EError s (foldl eAp t xs)
-app' e as = do
-    return $ foldl EAp e as
hunk ./E/Subst.hs 178
-{-
+typeSubst' :: Map.Map Id E -> Map.Map Id E -> E -> E
+typeSubst' termSub typeSub e | Map.null termSub && Map.null typeSub = e
+typeSubst' termSub typeSub e = typeSubst  (Map.map Just termSub `Map.union` Map.fromAscList [ (x,Map.lookup x termSub) | x <- fvs]) typeSub e  where
+    fvs = Set.toAscList (freeVars e `Set.union` fvmap termSub `Set.union` fvmap typeSub)
+    fvmap m = Set.unions (map freeVars (Map.elems m))
hunk ./E/Subst.hs 184
+substType t e e' = typeSubst (freeVars e) (Map.singleton t e) e'
hunk ./E/Subst.hs 186
-typeSubst :: Map.Map Int (Maybe E) -> E -> E
-typeSubst bm e  = f e (False,bm) where
-    f :: E -> Map.Map Int (Maybe E) -> E
+typeSubst :: Map.Map Id (Maybe E) -> Map.Map Id E -> E -> E
+typeSubst termSubst typeSubst e | Map.null termSubst && Map.null typeSubst = e
+typeSubst termSubst typeSubst e  = f e (False,termSubst',typeSubst) where
+    termSubst' = termSubst `Map.union` Map.map (const Nothing) typeSubst
+    f :: E -> (Bool,Map.Map Id (Maybe E),Map.Map Id E) -> E
hunk ./E/Subst.hs 192
-        (v,mp) <- ask
-        case (v,Map.lookup i mp) of
-          (True,Just (Just v)) -> return v
+        (wh,trm,tp) <- ask
+        case (wh,Map.lookup i trm, Map.lookup i tp) of
+          (False,(Just (Just v)),_) -> return v
+          (True,_,(Just v)) -> return v
hunk ./E/Subst.hs 200
-    f (EError x e) = liftM (EError x) (f e)
-    f (EPrim x es e) = liftM2 (EPrim x) (mapM f es) (f e)
+    f (EError x e) = liftM (EError x) (inType $ f e)
+    f (EPrim x es e) = liftM2 (EPrim x) (mapM f es) (inType $ f e)
hunk ./E/Subst.hs 208
-    f (ELit l) = liftM ELit $ litSMapM f l
+    f (ELit l) = liftM ELit $ litSMapM l
hunk ./E/Subst.hs 216
-                t' <- f t
+                t' <- inType $ f t
hunk ./E/Subst.hs 220
-            da (Alt l e) = do
-                l' <- fmapM f l
+            da (Alt (LitInt n t) e) = do
+                t' <- inType (f t)
hunk ./E/Subst.hs 223
-                return $ Alt l' e'
+                return $ Alt (LitInt n t') e'
hunk ./E/Subst.hs 226
-        lp lam tvr@(TVr { tvrIdent = n, tvrType = t}) e | n == 0 = do
-        t' <- f t
-        e' <- local (Map.insert n Nothing) $ f e
+    lp lam tvr@(TVr { tvrIdent = 0, tvrType = t}) e  = do
+        t' <- inType (f t)
+        e' <- f e
hunk ./E/Subst.hs 240
-
-    --mapMntvr [] = return []
-    --mapMntvr (t:ts) = do
-    --    (t',r) <- ntvr t
-    --    ts' <- local r (mapMntvr ts)
-    --    return ((t',r):ts')
-    --ntvr :: TVr -> Map Int (Maybe E) -> (TVr, Map Int (Maybe E) -> Map Int (Maybe E))
+    inType = local (\ (_,trm,typ) -> (True,trm,typ) )
+    addMap i (Just e) (b,trm,typ) = (b,Map.insert i (Just e) trm, Map.insert i e typ)
+    addMap i Nothing (b,trm,typ) = (b,Map.insert i Nothing trm, typ)
+    litSMapM (LitCons s es t) = do
+        t' <- inType $ f t
+        es' <- mapM f es
+        return $ LitCons s es' t'
+    litSMapM (LitInt n t) = do
+        t' <- inType $ f t
+        return $ LitInt n t'
hunk ./E/Subst.hs 251
-        t' <- f t
+        t' <- inType (f t)
hunk ./E/Subst.hs 255
-        t' <- f t
-        i' <- mnv allShadow xs i
+        t' <- inType (f t)
+        (_,map,_) <- ask
+        let i' = mnv False xs i map
hunk ./E/Subst.hs 260
-            True -> return (nvr,Map.insert i (Just $ EVar nvr))
-            False -> return (nvr,Map.insert i (Just $ EVar nvr) . Map.insert i' Nothing)
--}
+            True -> return (nvr,addMap i  (Just $ EVar nvr))
+            False -> return (nvr,addMap i (Just $ EVar nvr) . addMap i' Nothing)
+
+
hunk ./E/TypeCheck.hs 23
-typ (ESort _) = error "What sort of sort is this?"
hunk ./E/Values.hs 5
+import Data.Monoid
+import List
+import qualified Data.Map as Map
hunk ./E/Values.hs 79
-    toE ch = ELit (litCons DataConstructor ("Prelude","Integer") [toEzh ch] tInteger)
+    toE ch = ELit (LitCons dc_Integer [toEzh ch] tInteger)
hunk ./E/Values.hs 83
-    toE ch = ELit (litCons DataConstructor ("Prelude","Int") [toEzh ch] tInt)
+    toE ch = ELit (LitCons dc_Int [toEzh ch] tInt)
hunk ./E/Values.hs 89
-    typeE (_::[a]) = ELit (litCons TypeConstructor ("Prelude","[]") [typeE (undefined::a)] eStar)
+    typeE (_::[a]) = ELit (LitCons tc_List [typeE (undefined::a)] eStar)
hunk ./E/Values.hs 100
-eJustIO w x = ELit (LitCons dc_JustIO [w,x] (ELit (LitCons (toName TypeConstructor ("Jhc.IO","IOResult")) [getType x] eStar)))
-tIO t = ELit (LitCons (toName TypeConstructor ("Jhc.IO", "IO")) [t] eStar)
+eJustIO w x = ELit (LitCons dc_JustIO [w,x] (ELit (LitCons tc_IOResult [getType x] eStar)))
+tIO t = ELit (LitCons tc_IO [t] eStar)
hunk ./E/Values.hs 108
-eLet TVr { tvrIdent = 0 } _ = id
-eLet t@(TVr { tvrType =  ty}) e | sortStarLike ty && isAtomic e = subst t e
-eLet t e = ELetRec [(t,e)]
+eLet TVr { tvrIdent = 0 } _ e' = e'
+eLet t@(TVr { tvrType =  ty}) e e' | sortStarLike ty && isAtomic e = subst t e e'
+eLet t@(TVr { tvrType =  ty}) e e' | sortStarLike ty = ELetRec [(t,e)] (typeSubst mempty (Map.singleton (tvrIdent t) e) e')
+eLet t e e' = ELetRec [(t,e)] e'
hunk ./E/Values.hs 114
-eStrictLet t@(TVr { tvrType =  ty }) v e | sortStarLike ty && isAtomic v = subst t v e
+eStrictLet t@(TVr { tvrType =  ty }) v e | sortStarLike ty  = eLet t v e
hunk ./E/Values.hs 117
+substLet :: [(TVr,E)] -> E -> E
+substLet ds e  = ans where
+    (as,nas) = partition (isAtomic . snd) (filter ((/= 0) . tvrNum . fst) ds)
+    tas = filter (sortStarLike . tvrType . fst) nas
+    ans = eLetRec (as ++ nas) (typeSubst' (Map.fromList [ (n,e) | (TVr { tvrIdent = n },e) <- as]) (Map.fromList [ (n,e) | (TVr { tvrIdent = n },e) <- tas]) e)
+
+substLet' :: [(TVr,E)] -> E -> E
+substLet' ds e  = ans where
+    nas = filter ((/= 0) . tvrNum . fst) ds
+    tas = filter (sortStarLike . tvrType . fst) nas
+    ans = case (nas,tas) of
+        ([],_) -> e
+        (nas,[]) -> ELetRec nas e
+        _  -> let
+                    f = typeSubst' mempty (Map.fromList [ (n,e) | (TVr { tvrIdent = n },e) <- tas])
+                    nas' = [ (v,f e) | (v,e) <- nas]
+               in ELetRec nas' (f e)
+
+eLetRec = substLet'
hunk ./E/Values.hs 167
-    (_,e',p) = unsafeCoerceOpt $ EPrim (primPrim "unsafeCoerce") [e] t
+    (_,e',p) = unsafeCoerceOpt $ EPrim p_unsafeCoerce [e] t
hunk ./E/Values.hs 186
-prim_integralCast e t = EPrim (primPrim "integralCast") [e] t
+prim_integralCast e t = EPrim p_integralCast [e] t
hunk ./Info/Binary.hs 12
+import E.Strictness
hunk ./Info/Binary.hs 30
-    cb (u :: E.CPR.Val)
- --   cb (u :: E.Strictness.SA)
+    cb (u :: E.CPR.Val),
+    cb (u :: E.Strictness.SA)
hunk ./Info/Types.hs 59
+prop_CYCLIC = toAtom "_CYCLIC"
hunk ./Main.hs 161
-        --mangle = mangle' (Just $ Set.fromList $ inscope) fullDataTable
-        mangle = mangle' Nothing fullDataTable
+        mangle = mangle' (Just $ Set.fromList $ inscope) fullDataTable
hunk ./Main.hs 163
+        classNames = Set.fromList $ map tvrNum (methodNames (hoClassHierarchy allHo))
+        namesInscope = Set.fromList inscope -- classNames `Set.union` (Set.fromAscList $ Map.keys smap)
hunk ./Main.hs 177
+        let namesInscope' = Set.fromAscList (Map.keys smap) `Set.union` namesInscope
hunk ./Main.hs 185
+        let mangle = mangle' (Just $ namesInscope' `Set.union` Set.fromList (map (tvrIdent . fst) cds)) fullDataTable
hunk ./Main.hs 203
+        let mangle = mangle' (Just $ namesInscope' `Set.union` Set.fromList (map (tvrIdent . fst) cds')) fullDataTable
hunk ./Main.hs 342
-        e' <- doopt (mangle dataTable) False finalStats "SuperSimplify" cm e
+        e' <- doopt (mangle' Nothing dataTable) False finalStats "SuperSimplify" cm e