[perform incremental strictness analysis
John Meacham <john@repetae.net>**20051006014258] hunk ./E/Diff.hs 24
+findOddFreeVars _ e = e
hunk ./E/SSimplify.hs 20
+import E.TypeCheck
hunk ./E/SSimplify.hs 97
-                | Just s <- Map.lookup (tvrNum t) (so_strictness sopts) = s
+                | Just s <- Info.lookup (tvrInfo t) = s
hunk ./E/SSimplify.hs 103
-        return (eLetRec [ (tvrInfo_u (Info.insert (calcStrictInfo v e)) v,e) | (v,(e,_,_)) <- ds'' ] e', fvs, finalS  )
+        -- 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  )
hunk ./E/SSimplify.hs 290
-            [(t,e)] | worthStricting e, Just Strict <- Info.lookup (tvrInfo t) -> do
-                mtick "E.Simplify.let-to-case"
+            [(t,e)] | worthStricting e, Just (Strict.S _) <- Info.lookup (tvrInfo t) -> do
+                mtick "E.Simplify.strictness.let-to-case"
hunk ./E/SSimplify.hs 527
-worthStricting x = isLifted x && not (isELit x)
+worthStricting EError {} = True
+worthStricting ELit {} = False
+worthStricting ELam {} = False
+worthStricting x = sortTermLike x
+--worthStricting x = isLifted x && not (isELit x)
hunk ./E/Strictness.hs 6
+import Data.Typeable
+import Monad
hunk ./E/Strictness.hs 13
-import Data.Typeable
+import E.Annotate
hunk ./E/Strictness.hs 19
+import Info.Info as Info
hunk ./E/Strictness.hs 36
-    | U [SA]  -- Unary Constructor.
-    | O Var Int Int -- depends on some other value, called with first int number of arguments and is the second ints argument number.
+--    | U [SA]  -- Unary Constructor.
+    | O TVr Int Int -- depends on some other value, called with first int number of arguments and is the second ints argument number.
hunk ./E/Strictness.hs 41
-    | If Var Int SA SA  -- if
+    | If TVr Int SA SA  -- if
hunk ./E/Strictness.hs 44
-type SAMap = Map.Map Var SA
+type SAMap = Map.Map TVr SA
hunk ./E/Strictness.hs 48
-type CResult = [(Var,SA)]
+type CResult = [(TVr,SA)]
hunk ./E/Strictness.hs 52
-    cr = collect mempty (tVr (-1) Unknown,e)
-    ans = E.Strictness.solve [ c  | c@(x,_) <- cr, x /= (V $ -1) ]
+    cr = collect (tvrSilly,e)
+    ans = E.Strictness.solve [ c  | c@(x,_) <- cr, x /= tvrSilly ]
+
+solveDs :: [(TVr,E)] -> IO [(TVr,E)]
+solveDs ds = do
+    let idclear _ nfo = return $ Info.delete L nfo
+        ds' = runIdentity (annotateDs mempty idclear (\_ -> return) (\_ -> return) ds)
+        vs = concatMap collect ds'
+    cr <- E.Strictness.solve [ c | c@(x,_) <- vs, x /= tvrSilly ]
+    let idm = Map.fromList $ (0,L):[ (tvrIdent x,y) | (x,y) <- cr]
+    mapM_ (\ (tvr,n) -> print (tvrShowName tvr,n)) cr
+    let idann id nfo = case Map.lookup id idm of
+            Just x -> return $ Info.insert x nfo
+            Nothing -> return nfo -- error $ "Could not find :" ++ tvrShowName tvr { tvrIdent = id }
+    return $ runIdentity (annotateDs mempty idann (\_ -> return) (\_ -> return) ds')
+
+
hunk ./E/Strictness.hs 109
-collect :: SAMap -> (TVr,E) -> CResult
-collect env e = ans where
+collect ::  (TVr,E) -> CResult
+collect e = ans where
hunk ./E/Strictness.hs 119
-    f e | (EVar (TVr { tvrIdent = n } ),as) <- fromAp e = return $ andSA  ((Map.singleton (V n) (S (length as))):[ arg (O (V n) (length as) i) a | a <- as | i <- [0..] ])
+    f e | (EVar tvr,as) <- fromAp e = return $ andSA  ((Map.singleton tvr (S (length as))):[ arg (saO tvr (length as) i) a | a <- as | i <- [0..] ])
hunk ./E/Strictness.hs 136
-        tell [ (V i,Map.findWithDefault A (V i) sm) | (TVr { tvrIdent = i }) <- ts]
-        return $ Map.fromAscList [ (V i,L) | (V i,v) <- Map.toAscList sm, i `notElem` map tvrNum ts]
+        tell [ (tvr,Map.findWithDefault A tvr sm) | tvr <- ts]
+        return $ Map.fromAscList [ (i,L) | (i,v) <- Map.toAscList sm, i `notElem` ts]
hunk ./E/Strictness.hs 139
-        return $ Map.fromAscList [ (V i,v) | (V i,v) <- Map.toAscList sm, i `notElem` map tvrNum ts]
+        return $ Map.fromAscList [ (i,v) | (i,v) <- Map.toAscList sm, i `notElem` ts]
hunk ./E/Strictness.hs 144
-            when (not $ null as) $ tell [(V (tvrNum t),Lam [ Map.findWithDefault A (V t) samap |  TVr { tvrIdent = t } <- as])]
-            return $ Map.fromAscList [ (V i,saIf (V $ tvrNum t) (length as) v L) | (V i,v) <- Map.toAscList samap, i `notElem` map tvrNum as]
-    arg sa (EVar (TVr { tvrIdent = i })) = Map.singleton (V i) sa
+            unless (null as) $ tell [(t,Lam [ Map.findWithDefault A tvr samap |  tvr <- as])]
+            return $ Map.fromAscList [ (i,saIf t (length as) v L) | (i,v) <- Map.toAscList samap, i `notElem`  as]
+    arg sa (EVar tvr) = Map.singleton tvr sa
hunk ./E/Strictness.hs 154
+saIf t n a b | Just s <- Info.lookup (tvrInfo t) = case s of
+    S n' | n' >= n -> a
+    _ -> b
hunk ./E/Strictness.hs 158
+
+saO v a i | Just s <- Info.lookup (tvrInfo v) = case s of
+    Lam as | length as <= a && i < length as -> as !! i
+    _ -> L
+saO x y z = O x y z
+
hunk ./E/Strictness.hs 178
-instance SemiBooleanAlgebra (SAMap,[(Var,SA)]) where
+instance SemiBooleanAlgebra (SAMap,[(TVr,SA)]) where
hunk ./Main.hs 157
-        mangle = mangle' (Just $ Set.fromList $ inscope) fullDataTable
+        --mangle = mangle' (Just $ Set.fromList $ inscope) fullDataTable
+        mangle = mangle' Nothing fullDataTable
hunk ./Main.hs 173
+        let cm stats e = do
+            let sopt = mempty { SS.so_superInline = True, SS.so_exports = inscope, SS.so_boundVars = smap, SS.so_rules = allRules, SS.so_dataTable = fullDataTable }
+            let (e',stat,occ) = SS.simplify sopt e
+            Stats.tickStat stats stat
+            return e'
hunk ./Main.hs 180
-            let cm stats e = do
-                let sopt = mempty { SS.so_superInline = True, SS.so_exports = inscope, SS.so_boundVars = smap, SS.so_rules = allRules, SS.so_dataTable = fullDataTable }
-                let (e',stat,occ) = SS.simplify sopt e
-                Stats.tickStat stats stat
-                return e'
hunk ./Main.hs 183
+            return (v,lc)
+        wdump FD.Lambdacube $ mapM_ (\ (v,lc) -> printCheckName' fullDataTable v lc) cds
+        cds <- E.Strictness.solveDs cds
+        cds <- flip mapM (zip names cds) $ \ (n,(v,lc)) -> do
hunk ./Main.hs 188
-            --wdump FD.Lambdacube $ printCheckName' fullDataTable lc
+            lc <- mangle (return ()) False ("Barendregt: " ++ show n) (return . barendregt) lc
hunk ./Main.hs 190
-            --return ((n,v,lc):ds, (Map.insert (tvrNum v) lc smap, Map.insert (tvrNum v) (Just (EVar v)) annmap))
+
+        -- cds <- E.Strictness.solveDs cds
hunk ./Main.hs 197
-            let cm stats e = do
-                let sopt = mempty { SS.so_superInline = True, SS.so_exports = inscope, SS.so_boundVars = smap, SS.so_rules = allRules, SS.so_dataTable = fullDataTable }
-                let (e',stat,occ) = SS.simplify sopt e
-                Stats.tickStat stats stat
-                return e'
hunk ./Main.hs 202
-            wdump FD.Lambdacube $ printCheckName' fullDataTable v lc
+            --wdump FD.Lambdacube $ printCheckName' fullDataTable v lc
hunk ./Main.hs 204
+        cds <- E.Strictness.solveDs cds
+        cds <- return $ fst (E.CPR.cprAnalyzeBinds mempty cds)
hunk ./Main.hs 207
+        wdump FD.Lambdacube $ mapM_ (\ (v,lc) -> printCheckName' fullDataTable v lc) cds
hunk ./Main.hs 310
-    lc <- if fopts FO.FloatIn then  opt "Float Inward..." (\stats x -> return (floatInward rules  x))  lc  else return lc
-    vs <- if fopts FO.Strictness then (collectSolve lc) else return []
+    --lc <- if fopts FO.FloatIn then  opt "Float Inward..." (\stats x -> return (floatInward rules  x))  lc  else return lc
+    --vs <- if fopts FO.Strictness then (collectSolve lc) else return []
hunk ./Main.hs 314
-        let sopt = mempty { SS.so_rules = rules, SS.so_dataTable = dataTable,  SS.so_strictness = Map.fromList [ (i,S n) | (E.Strictness.V i,S n) <- vs] }
+        let sopt = mempty { SS.so_rules = rules, SS.so_dataTable = dataTable }