[cache substitutions inside of environment for speed. no longer environment and substitution separately. fix several case optimizations.
John Meacham <john@repetae.net>**20060411113722] hunk ./E/SSimplify.hs 255
-data Range = Done E | Susp E Subst
+data Range = Done E | Susp E Subst E
hunk ./E/SSimplify.hs 275
+    envCachedSubst :: IdMap (Maybe E),
+    envSubst :: Subst,
hunk ./E/SSimplify.hs 282
+susp:: E -> Subst -> Range
+susp e sub =  Susp e sub (substMap'' (fmap mkSubst sub) e)
+
+insertSuspSubst :: TVr -> E -> Env -> Env
+insertSuspSubst t e env = cacheSubst env { envSubst = minsert (tvrIdent t) (susp e (envSubst env)) (envSubst env) }
+insertSuspSubst' :: Id -> E -> Env -> Env
+insertSuspSubst' t e env = cacheSubst env { envSubst = minsert t (susp e (envSubst env)) (envSubst env) }
+
+insertDoneSubst :: TVr -> E -> Env -> Env
+insertDoneSubst t e env = cacheSubst env { envSubst = minsert (tvrIdent t) (Done e) (envSubst env) }
+insertDoneSubst' :: Id -> E -> Env -> Env
+insertDoneSubst' t e env = cacheSubst env { envSubst = minsert t (Done e) (envSubst env) }
+
+substLookup :: Id -> Env -> Maybe Range
+substLookup id env = mlookup id (envSubst env)
+
+substAddList ls env = env { envSubst = fromList ls `union` envSubst env }
+
+--applySubst :: Subst -> IdMap a -> E -> E
+--applySubst s nn = applySubst' s where
+--    nn' = fmap (const Nothing) s `mappend` fmap (const Nothing) nn
+--    applySubst' s = substMap'' (tm `mappend` nn') where
+--        tm = fmap g s
+--        g (Done e) = Just e
+--        g (Susp e s') = Just $ applySubst' s' e
+
hunk ./E/SSimplify.hs 314
-        g (Susp e s') = Just $ applySubst' s' e
+        g (Susp _ _ e)  = Just e
+        --g (Susp e s')  = Just $ applySubst' s' e
hunk ./E/SSimplify.hs 317
-dosub sub inb e = coerceOpt return $ applySubst sub (envInScope inb) e
+mkSubst :: Range -> Maybe E
+mkSubst (Done e) = Just e
+mkSubst (Susp _ _ e) = Just e
+--mkSubst (Susp e s' e) = Just $ substMap'' (fmap mkSubst s') e
+
+cacheSubst env = env { envCachedSubst = fmap mkSubst (envSubst env) }
+
+dosub inb e = coerceOpt return $ substMap'' (envCachedSubst inb) e
+
+--dosub inb e = coerceOpt return $ applySubst (envSubst inb) (envInScope inb) e
hunk ./E/SSimplify.hs 342
-    collocc dsIn = do
-        --let (dsIn',fvs) = collectDs dsIn (fromList $ map (flip (,) Many) (map (tvrIdent . fst) dsIn))
-        --addNames (mkeys fvs)
-        --addNames (map tvrIdent $ Map.keys occ)
-        --let occ' = Map.mapKeysMonotonic tvrIdent occ
-        --    dsIn'' = runIdentity $ annotateDs mempty (\t nfo -> return $ maybe (Info.delete Many nfo) (flip Info.insert nfo) (mlookup t occ')) (\_ -> return) (\_ -> return) dsIn'
-        return dsIn
+    collocc dsIn = do return dsIn
hunk ./E/SSimplify.hs 351
-                        f e mempty initialB'  -- ^ do not inline into functions which themself will be inlined
-                            else f e mempty initialB
+                        f e initialB'  -- ^ do not inline into functions which themself will be inlined
+                            else f e initialB
hunk ./E/SSimplify.hs 358
-        f e' mempty inb
-    f :: E -> Subst -> Env -> IdNameT (StatT Identity) E
-    f e sub inb | (ELam t b,(x:xs)) <- fromAp e = do
-        xs' <- mapM (dosub sub inb) xs
-        b' <- f b (minsert (tvrIdent t) (Susp x sub) sub) inb
+        f e' (cacheSubst inb { envSubst = mempty })
+    f :: E -> Env -> IdNameT (StatT Identity) E
+    f e inb | (ELam t b,(x:xs)) <- fromAp e = do
+        xs' <- mapM (dosub inb) xs
+        b' <- f b (insertSuspSubst t x inb) -- minsert (tvrIdent t) (Susp x sub) sub) inb
hunk ./E/SSimplify.hs 365
-    f e sub inb | (EPi t b,(x:xs)) <- fromAp e = do
-        xs' <- mapM (dosub sub inb) xs
-        b' <- f b (minsert (tvrIdent t) (Susp x sub) sub) inb
+    f e inb | (EPi t b,(x:xs)) <- fromAp e = do
+        xs' <- mapM (dosub inb) xs
+        b' <- f b (insertSuspSubst t x inb) -- (minsert (tvrIdent t) (Susp x sub) sub) inb
hunk ./E/SSimplify.hs 370
-    f e sub inb | (EVar v,xs) <- fromAp e = do
-        xs' <- mapM (dosub sub inb) xs
-        case mlookup (tvrIdent v) sub of
+    f e inb | (EVar v,xs) <- fromAp e = do
+        xs' <- mapM (dosub inb) xs
+        case substLookup (tvrIdent v) inb of
hunk ./E/SSimplify.hs 374
-            Just (Susp e s) -> do
-                e' <- f e s inb
+            Just (Susp e s _) -> do
+                e' <- f e (cacheSubst inb { envSubst = s })
hunk ./E/SSimplify.hs 377
-                --app (e',xs')
hunk ./E/SSimplify.hs 378
-            -- Nothing -> error $ "Var with no subst: " ++ show e ++ "\n" ++  show  sub -- h (EVar v) xs' inb
-    f e sub inb | (x,xs) <- fromAp e = do
+    f e inb | (x,xs) <- fromAp e = do
hunk ./E/SSimplify.hs 381
-            Just (_,e) -> f e sub inb -- go e inb
+            Just (_,e) -> f e inb -- go e inb
hunk ./E/SSimplify.hs 383
-                xs' <- mapM (dosub sub inb) xs
-                x' <- g x sub inb
+                xs' <- mapM (dosub inb) xs
+                x' <- g x inb
hunk ./E/SSimplify.hs 388
-    g (EPrim a es t) sub inb = do
-        es' <- mapM (dosub sub inb) es
-        t' <- dosub sub inb t
+    g (EPrim a es t) inb = do
+        es' <- mapM (dosub inb) es
+        t' <- dosub inb t
hunk ./E/SSimplify.hs 392
-    g (ELit (LitCons n es t)) sub inb = do
-        es' <- mapM (dosub sub inb) es
-        t' <- dosub sub inb t
+    g (ELit (LitCons n es t)) inb = do
+        es' <- mapM (dosub inb) es
+        t' <- dosub inb t
hunk ./E/SSimplify.hs 396
-    g (ELit (LitInt n t)) sub inb = do
-        t' <- dosub sub inb t
+    g (ELit (LitInt n t)) inb = do
+        t' <- dosub inb t
hunk ./E/SSimplify.hs 399
-    g e@(EPi (TVr { tvrIdent = n }) b) sub inb = do
+    g e@(EPi (TVr { tvrIdent = n }) b) inb = do
hunk ./E/SSimplify.hs 401
-        e' <- dosub sub inb e
+        e' <- dosub inb e
hunk ./E/SSimplify.hs 403
-    g (EError s t) sub inb = do
-        t' <- dosub sub inb t
+    g (EError s t) inb = do
+        t' <- dosub inb t
hunk ./E/SSimplify.hs 406
-    g ec@ECase { eCaseScrutinee = e, eCaseBind = b, eCaseAlts = as, eCaseDefault = d} sub inb = do
+    g ec@ECase { eCaseScrutinee = e, eCaseBind = b, eCaseAlts = as, eCaseDefault = d} inb = do
hunk ./E/SSimplify.hs 408
-        e' <- f e sub inb
-        doCase e' (eCaseType ec) b as d sub inb
-    g (ELam v e) sub inb  = do
+        e' <- f e inb
+        doCase e' (eCaseType ec) b as d inb
+    g (ELam v e) inb  = do
hunk ./E/SSimplify.hs 412
-        v' <- nname v sub inb
-        e' <- f e (minsert (tvrIdent v) (Done $ EVar v') sub) (envInScope_u (minsert (tvrIdent v') NotKnown) inb)
+        v' <- nname v inb
+        e' <- f e (insertDoneSubst v (EVar v') . envInScope_u (minsert (tvrIdent v') NotKnown) $ inb) --        minsert (tvrIdent v) (Done $ EVar v') sub)
hunk ./E/SSimplify.hs 415
---    g (ELetRec [] e) sub inb = g e sub inb
-    g (ELetRec ds e) sub inb = do
+    g (ELetRec ds@(_:_) e) inb = do
hunk ./E/SSimplify.hs 418
-                t'' <- nname t sub inb
+                t'' <- nname t inb
hunk ./E/SSimplify.hs 422
-                t' <- nname t sub inb
+                t' <- nname t inb
hunk ./E/SSimplify.hs 430
-            w ((t,Once,t',e):rs) sub inb ds = do
+            w ((t,Once,t',e):rs) inb ds = do
hunk ./E/SSimplify.hs 432
-                w rs (minsert t (Susp e sub) sub) inb ds
-            w ((t,n,t',e):rs) sub inb ds = do
-                e' <- f e sub inb
+                w rs (insertSuspSubst' t e inb) ds -- (minsert t (Susp e sub) sub) inb ds
+            w ((t,n,t',e):rs) inb ds = do
+                e' <- f e inb
hunk ./E/SSimplify.hs 438
-                        w rs (minsert t (Done e') sub) (envInScope_u (minsert (tvrIdent t') (isBoundTo n e')) inb) ((t',e'):ds)
+                        w rs (insertDoneSubst' t e' . envInScope_u (minsert (tvrIdent t') (isBoundTo n e')) $ inb) ((t',e'):ds) -- (minsert t (Done e') sub) (envInScope_u (minsert (tvrIdent t') (isBoundTo n e')) inb) ((t',e'):ds)
hunk ./E/SSimplify.hs 440
-                    False -> w rs sub (if n /= LoopBreaker then (envInScope_u (minsert (tvrIdent t') (isBoundTo n e')) inb) else inb) ((t',e'):ds)
-            w [] sub inb ds = return (ds,sub,inb)
+                    False -> w rs (if n /= LoopBreaker then (envInScope_u (minsert (tvrIdent t') (isBoundTo n e')) inb) else inb) ((t',e'):ds)
+            w [] inb ds = return (ds,inb)
hunk ./E/SSimplify.hs 445
-            sub'' = {- Map.fromList [ (t,Susp e sub'') | (t,Once,_,e) <- s'] `Map.union`-} (fromList [ (t,Done (EVar t'))  | (t,n,t',_) <- s', n /= Once]) `union` sub
-        (ds',sub',inb') <- w s' sub'' (envInScope_u (fromList [ (tvrIdent t',NotKnown) | (_,n,t',_) <- s', n /= Once] `union`) inb) []
-        e' <- f e sub' inb'
+            --sub'' = {- Map.fromList [ (t,Susp e sub'') | (t,Once,_,e) <- s'] `Map.union`-} ([ (t,Done (EVar t'))  | (t,n,t',_) <- s', n /= Once]) `union` sub
+            sub'' = [ (t,Done (EVar t'))  | (t,n,t',_) <- s', n /= Once]
+        (ds',inb') <- w s'  (substAddList sub'' $ envInScope_u (fromList [ (tvrIdent t',NotKnown) | (_,n,t',_) <- s', n /= Once] `union`) inb) []
+        e' <- f e inb'
hunk ./E/SSimplify.hs 461
-                --when (hasRepeatUnder fst ds'') $ fail "hasRepeats!"
+                when (flint && hasRepeatUnder fst ds'') $ fail "hasRepeats!"
hunk ./E/SSimplify.hs 464
-                {-
-                let z (v,ELetRec ds e) = (ds,(v,e))
-                    z (v,e) = ([],(v,e))
-                    (ds''',ds'') = unzip (map z ds')
-                    nds = (concat ds''' ++ ds'')
-                --mticks (length (concat ds''')) (toAtom $ "E.Simplify.let-coalesce.{" ++ unwords (sort (map tvrShowName $ map fst (concat ds'''))) ++ "}")
-
-                if hasRepeatUnder fst nds then
-                    return $ eLetRec ds' e'
-                  else do
-                    mticks (length (concat ds''')) (toAtom $ "E.Simplify.let-coalesce")
-                    return $ eLetRec nds  e'
-                  -}
-    g e _ _ = error $ "SSimplify.simplify.g: " ++ show e ++ "\n" ++ pprint e
+    g e _ = error $ "SSimplify.simplify.g: " ++ show e ++ "\n" ++ pprint e
hunk ./E/SSimplify.hs 468
-    nname tvr@(TVr { tvrIdent = n, tvrType =  t}) sub inb  = do
-        t' <- dosub sub inb t
+    nname tvr@(TVr { tvrIdent = n, tvrType =  t}) inb  = do
+        t' <- dosub inb t
hunk ./E/SSimplify.hs 473
---        case n `Map.member` inb of
---            True -> do
---                n' <- newName
---                return $ TVr n' t'
---            False -> do
---                n' <- uniqueName n
---                return $ TVr n' t'
-
hunk ./E/SSimplify.hs 474
-
-    doCase (ELetRec ds e) t b as d sub inb = do
+    doCase (ELetRec ds e) t b as d inb = do
hunk ./E/SSimplify.hs 476
-        e' <- doCase e t b as d sub inb
+        e' <- doCase e t b as d inb
hunk ./E/SSimplify.hs 479
-    doCase (EVar v) t b as d sub inb |  Just IsBoundTo { bindingE = ELit l } <- mlookup (tvrIdent v) (envInScope inb)  = doConstCase l t  b as d sub inb
-    doCase (ELit l) t b as d sub inb  = doConstCase l t b as d sub inb
+    doCase (EVar v) t b as d inb |  Just IsBoundTo { bindingE = ELit l } <- mlookup (tvrIdent v) (envInScope inb)  = doConstCase l t  b as d inb
+    doCase (ELit l) t b as d inb  = doConstCase l t b as d inb
hunk ./E/SSimplify.hs 482
-    doCase (EVar v) t b as d sub inb | Just IsBoundTo { bindingE = e } <- mlookup (tvrIdent v) (envInScope inb) , isBottom e = do
+    doCase (EVar v) t b as d inb | Just IsBoundTo { bindingE = e } <- mlookup (tvrIdent v) (envInScope inb) , isBottom e = do
hunk ./E/SSimplify.hs 484
-        t' <- dosub sub inb t
+        t' <- dosub inb t
hunk ./E/SSimplify.hs 486
-    doCase e t b as d sub inb | isBottom e = do
+    doCase e t b as d inb | isBottom e = do
hunk ./E/SSimplify.hs 488
-        t' <- dosub sub inb t
+        t' <- dosub inb t
hunk ./E/SSimplify.hs 491
-    doCase ic@ECase { eCaseScrutinee = e, eCaseBind =  b, eCaseAlts =  as, eCaseDefault =  d } t b' as' d' sub inb | length (filter (not . isBottom) (caseBodies ic)) <= 1 || all whnfOrBot (caseBodies ic)  || all whnfOrBot (caseBodies emptyCase { eCaseAlts = as', eCaseDefault = d'} )  = do
+    doCase ic@ECase { eCaseScrutinee = e, eCaseBind =  b, eCaseAlts =  as, eCaseDefault =  d } t b' as' d' inb | length (filter (not . isBottom) (caseBodies ic)) <= 1 || all whnfOrBot (caseBodies ic)  || all whnfOrBot (caseBodies emptyCase { eCaseAlts = as', eCaseDefault = d'} )  = do
hunk ./E/SSimplify.hs 494
-                e' <- doCase e t b' as' d' sub (envInScope_u (fromList [ (n,NotKnown) | TVr { tvrIdent = n } <- litBinds l ] `union`) inb)
+                e' <- doCase e t b' as' d' (envInScope_u (fromList [ (n,NotKnown) | TVr { tvrIdent = n } <- litBinds l ] `union`) inb)
hunk ./E/SSimplify.hs 497
-            g x = doCase x t b' as' d' sub (envInScope_u (minsert (tvrIdent b) NotKnown) inb)
+            g x = doCase x t b' as' d' (envInScope_u (minsert (tvrIdent b) NotKnown) inb)
hunk ./E/SSimplify.hs 500
-        t' <- dosub sub inb t
+        t' <- dosub inb t
hunk ./E/SSimplify.hs 502
-    doCase e t b as@(Alt (LitCons n _ _) _:_) (Just d) sub inb | Just ss <- getSiblings (so_dataTable sopts) n, length ss <= length as = do
+    doCase e t b as@(Alt (LitCons n _ _) _:_) (Just d) inb | Just ss <- getSiblings (so_dataTable sopts) n, length ss <= length as = do
hunk ./E/SSimplify.hs 504
-        doCase e t b as Nothing sub inb
-    doCase e t b as (Just d) sub inb | te /= tWorld__, (ELit (LitCons cn _ _)) <- followAliases dt te, Just Constructor { conChildren = Just cs } <- getConstructor cn dt, length as == length cs - 1 || (False && length as < length cs && isAtomic d)  = do
+        doCase e t b as Nothing inb
+    doCase e t b as (Just d) inb | te /= tWorld__, (ELit (LitCons cn _ _)) <- followAliases dt te, Just Constructor { conChildren = Just cs } <- getConstructor cn dt, length as == length cs - 1 || (False && length as < length cs && isAtomic d)  = do
hunk ./E/SSimplify.hs 518
-        doCase e t b (as ++ ls') Nothing sub inb
+        doCase e t b (as ++ ls') Nothing inb
hunk ./E/SSimplify.hs 520
-        te = getType e
+        te = getType b
hunk ./E/SSimplify.hs 522
-    doCase e _ b [] (Just d) sub inb | not (isLifted e || isUnboxed (getType e)) = do
+    doCase e _ b [] (Just d) inb | not (isLifted e || isUnboxed (getType e)) = do
hunk ./E/SSimplify.hs 524
-        b' <- nname b sub inb
-        d' <- f d (minsert (tvrIdent b) (Done (EVar b')) sub) (envInScope_u  (minsert (tvrIdent b') (isBoundTo Many e)) inb)
+        b' <- nname b inb
+        d' <- f d (insertDoneSubst b (EVar b') (envInScope_u  (minsert (tvrIdent b') (isBoundTo Many e)) inb)) -- minsert (tvrIdent b) (Done (EVar b')) sub) (envInScope_u  (minsert (tvrIdent b') (isBoundTo Many e)) inb)
hunk ./E/SSimplify.hs 528
-    doCase e _ b [] (Just d) sub inb | isUnboxed (getType e), isAtomic e = do
+    doCase e _ b [] (Just d) inb | isUnboxed (getType e), isAtomic e = do
hunk ./E/SSimplify.hs 530
-        f d (minsert (tvrIdent b) (Done e) sub) inb
+        f d (insertDoneSubst b e inb) -- minsert (tvrIdent b) (Done e) sub) inb
hunk ./E/SSimplify.hs 532
-    doCase (EVar v) _ b [] (Just d) sub inb | Just (NotAmong _) <-  mlookup (tvrIdent v) (envInScope inb)  = do
+    doCase (EVar v) _ b [] (Just d) inb | Just (NotAmong _) <-  mlookup (tvrIdent v) (envInScope inb)  = do
hunk ./E/SSimplify.hs 534
-        d' <- f d (minsert (tvrIdent b) (Done (EVar v)) sub) inb
+        d' <- f d (insertDoneSubst b (EVar v) inb) -- minsert (tvrIdent b) (Done (EVar v)) sub) inb
hunk ./E/SSimplify.hs 536
-    doCase scrut _ v [] (Just sc@ECase { eCaseScrutinee = EVar v'} ) sub inb | v == v', tvrIdent v `notMember` (freeVars (caseBodies sc) :: IdSet)  = do
+    doCase scrut _ v [] (Just sc@ECase { eCaseScrutinee = EVar v'} ) inb | v == v', tvrIdent v `notMember` (freeVars (caseBodies sc) :: IdSet)  = do
hunk ./E/SSimplify.hs 538
-        doCase scrut (eCaseType sc) (eCaseBind sc) (eCaseAlts sc) (eCaseDefault sc) sub inb
+        doCase scrut (eCaseType sc) (eCaseBind sc) (eCaseAlts sc) (eCaseDefault sc) inb
hunk ./E/SSimplify.hs 540
-    doCase e t b as d sub inb = do
-        b' <- nname b sub inb
-        let dd e' = f e' (minsert (tvrIdent b) (Done $ EVar b') sub) (envInScope_u (newinb `union`) inb) where
+    doCase e t b as d inb = do
+        b' <- nname b inb
+        let dd e' = f e' (insertDoneSubst b (EVar b') $ envInScope_u (newinb `union`) inb) where
hunk ./E/SSimplify.hs 546
-                t' <- dosub sub inb t
+                t' <- dosub inb t
hunk ./E/SSimplify.hs 548
-                e' <- f ae sub (mins e (patToLitEE p') inb)
+                e' <- f ae (mins e (patToLitEE p') inb)
hunk ./E/SSimplify.hs 551
-                t' <- dosub sub inb t
-                ns' <- mapM (\v -> nname v sub inb) ns
+                t' <- dosub inb t
+                ns' <- mapM (\v -> nname v inb) ns
hunk ./E/SSimplify.hs 554
-                    nsub = fromList [ (n,Done (EVar t))  | TVr { tvrIdent = n } <- ns | t <- ns' ]
+                    nsub =  [ (n,Done (EVar t))  | TVr { tvrIdent = n } <- ns | t <- ns' ]
hunk ./E/SSimplify.hs 556
-                e' <- f ae (nsub `union` sub) (envInScope_u (ninb `union`) $ mins e (patToLitEE p') inb)
+                e' <- f ae (substAddList nsub (envInScope_u (ninb `union`) $ mins e (patToLitEE p') inb))
hunk ./E/SSimplify.hs 563
-        t' <- dosub sub inb t
+        t' <- dosub inb t
hunk ./E/SSimplify.hs 566
-    doConstCase l t b as d sub inb = do
-        t' <- dosub sub inb t
+    doConstCase l t b as d inb = do
+        t' <- dosub inb t
hunk ./E/SSimplify.hs 572
-                binds <- mapM (\ (v,e) -> nname v sub inb >>= return . (,,) e v) bs'
-                e' <- f e (fromList [ (n,Done $ EVar nt) | (_,TVr { tvrIdent = n },nt) <- binds] `union` sub)   (envInScope_u (fromList [ (n,isBoundTo Many e) | (e,_,TVr { tvrIdent = n }) <- binds] `union`) inb)
+                binds <- mapM (\ (v,e) -> nname v inb >>= return . (,,) e v) bs'
+                e' <- f e (substAddList [ (n,Done $ EVar nt) | (_,TVr { tvrIdent = n },nt) <- binds] $ envInScope_u (fromList [ (n,isBoundTo Many e) | (e,_,TVr { tvrIdent = n }) <- binds] `union`) inb)
hunk ./E/SSimplify.hs 644
-    --app' (ELam tvr e) (a:as) = do
-    --    mtick (toAtom "E.Simplify.beta-reduce")
-    --    app (subst tvr a e,as)   -- TODO Fix quadradic substitution
-        --app (eLet 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