[various cleanups to E.Demand
John Meacham <john@repetae.net>**20090226082336
 Ignore-this: a75b7ee1c9ac044ffa3c90e26cb6654f
] hunk ./E/Demand.hs 8
-    solveDs,
hunk ./E/Demand.hs 15
-import Data.List
+import Data.List hiding(union)
hunk ./E/Demand.hs 31
+--import Debug.Trace
+
+trace _ x = x
hunk ./E/Demand.hs 37
-    | L SubDemand      -- lazy
-    | S SubDemand      -- strict
-    | Error SubDemand  -- diverges, might use arguments
+    | L !SubDemand      -- lazy
+    | S !SubDemand      -- strict
+    | Error !SubDemand  -- diverges, might use arguments
hunk ./E/Demand.hs 44
-instance Show Demand where
-    showsPrec _ Bottom = ("_|_" ++)
-    showsPrec _ Absent = ('A':)
-    showsPrec _ (L None) = ('L':)
-    showsPrec _ (L (Product ds)) = showString "L(" . foldr (.) id (map shows ds) . showString ")"
-    showsPrec _ (S None) = ('S':)
-    showsPrec _ (S (Product ds)) = showString "S(" . foldr (.) id (map shows ds) . showString ")"
-    showsPrec _ (Error None) = showString "Err"
-    showsPrec _ (Error (Product ds)) = showString "Err(" . foldr (.) id (map shows ds) . showString ")"
-
-instance DocLike d => PPrint d Demand where
-    pprint demand = tshow demand
-
-data SubDemand = None | Product [Demand]
-    deriving(Eq,Ord,Typeable)
+data SubDemand = None | Product ![Demand]
+    deriving(Eq,Ord)
hunk ./E/Demand.hs 48
-data DemandSignature = DemandSignature !Int DemandType
-    deriving(Eq,Ord,Typeable)
+data DemandEnv = DemandEnv !(IdMap Demand) !Demand
+    deriving(Eq,Ord)
hunk ./E/Demand.hs 51
-data DemandType = (:=>) DemandEnv [Demand]
-    deriving(Eq,Ord,Typeable)
+
+data DemandType = (:=>) !DemandEnv ![Demand]
+    deriving(Eq,Ord)
hunk ./E/Demand.hs 56
-data DemandEnv = DemandEnv (IdMap Demand) Demand
+data DemandSignature = DemandSignature !Int !DemandType
hunk ./E/Demand.hs 58
-
-instance Binary DemandEnv where
-    put (DemandEnv dt d) = do
-        put dt
-        put d
-    get = do
-        m <- get
-        d <- get
-        return $ DemandEnv m d
-
-
-instance Show DemandType where
-    showsPrec _ (DemandEnv e Absent :=> d) | isEmpty e = shows d
-    showsPrec _ (env :=> ds) = shows env . showString " :=> " .  shows ds
-
-instance Show DemandEnv where
-    showsPrec _ (DemandEnv m Absent) = showString "{" . foldr (.) id (intersperse (showString ",") [ showString (pprint t) . showString " -> " . shows v | (t,v) <- idMapToList m]) . showString "}"
-    showsPrec _ (DemandEnv _ Bottom) = showString "_|_"
-    showsPrec _ (DemandEnv m demand) = showString "{" . shows demand . showString " - " . foldr (.) id (intersperse (showString ",") [ showString (pprint t) . showString " -> " . shows v | (t,v) <- idMapToList m]) . showString "}"
+        {-! derive: Binary !-}
hunk ./E/Demand.hs 61
-instance Show DemandSignature where
-    showsPrec _ (DemandSignature n dt) = showString "<" . shows n . showString "," . shows dt . showString ">"
hunk ./E/Demand.hs 65
+--botType = (DemandEnv mempty Bottom) :=> []
hunk ./E/Demand.hs 114
-    lub (env :=> ts) (env' :=> ts') | length ts < length ts' = (env `lub` env') :=> zipWith lub (ts ++ repeat lazy) ts'
-                                    | otherwise = (env `lub` env') :=> zipWith lub ts (ts' ++ repeat lazy)
-    glb (env :=> ts) (env' :=> ts') | length ts < length ts' = (env `glb` env') :=> zipWith glb (ts ++ repeat lazy) ts'
-                                    | otherwise = (env `glb` env') :=> zipWith glb ts (ts' ++ repeat lazy)
+    lub (env :=> ts) (env' :=> ts') | length ts < length ts' = (env `lub` env') :=> strictList (zipWith lub (ts ++ repeat lazy) ts')
+                                    | otherwise = (env `lub` env') :=> strictList (zipWith lub ts (ts' ++ repeat lazy))
+    glb (env :=> ts) (env' :=> ts') | length ts < length ts' = (env `glb` env') :=> strictList (zipWith glb (ts ++ repeat lazy) ts')
+                                    | otherwise = (env `glb` env') :=> strictList (zipWith glb ts (ts' ++ repeat lazy))
hunk ./E/Demand.hs 123
+
+strictList (x:xs) = x `seq` xs' `seq` (x:xs') where
+    xs' = strictList xs
+strictList [] = []
+
hunk ./E/Demand.hs 194
-        m = fromList [ (x,lenv x d1 `lub` lenv x d2) | x <- mkeys m1 ++ mkeys m2]
+        m = fromList [ (x,lenv x d1 `lub` lenv x d2) | x <- mkeys (m1 `union` m2)]
hunk ./E/Demand.hs 196
-        m = fromList [ (x,lenv x d1 `glb` lenv x d2) | x <- mkeys m1 ++ mkeys m2]
+        m = fromList [ (x,lenv x d1 `glb` lenv x d2) | x <- mkeys (m1 `union` m2)]
hunk ./E/Demand.hs 213
-extEnvs ts = local  (\ (env,dt) -> (mappend (fromList [ (tvrIdent t,Left s) |  (t,s) <- ts, not (isEmptyId (tvrIdent t))]) env,dt))
hunk ./E/Demand.hs 285
-    return (ELam (tvrInfo_u (Info.insert sx) x) e',demandEnvMinus phi x :=> (sx:sigma))
+    return (ELam (tvrInfo_u (Info.insert $! sx) x) e',demandEnvMinus phi x :=> (sx:sigma))
hunk ./E/Demand.hs 289
-    return (ELam (tvrInfo_u (Info.insert sx) x) e',demandEnvMinus phi x :=> (sx:sigma))
+    return (ELam (tvrInfo_u (Info.insert $! sx) x) e',demandEnvMinus phi x :=> (sx:sigma))
hunk ./E/Demand.hs 294
-    return (ELam (tvrInfo_u (Info.insert sx) x) e',lazify (demandEnvMinus phi x) :=> (sx:sigma))
+    return (ELam (tvrInfo_u (Info.insert $! sx) x) e',lazify (demandEnvMinus phi x) :=> (sx:sigma))
hunk ./E/Demand.hs 313
-        let g (t,e) = (tvrInfo_u (Info.insert (lenv (tvrIdent t) phi)) t,e)
+        let g (t,e) = (tvrInfo_u (Info.insert $! (lenv (tvrIdent t) phi)) t,e)
hunk ./E/Demand.hs 359
-{-# NOINLINE solveDs #-}
-solveDs dataTable ds = do
-    nds <- runIM (solveDs' Nothing ds fixupDemandSignature return) dataTable
-    --flip mapM_ nds $ \ (t,_) ->
-    --    putStrLn $ "strictness: " ++ pprint t ++ ": " ++ show (maybe absSig id $ Info.lookup (tvrInfo t))
-    return nds
-
hunk ./E/Demand.hs 366
+solveDs' Nothing ds fixup wdone = do
+    let f (Left d:rs) xs = solveDs' (Just False) [d] fixup (\nds -> f rs (nds ++ xs))
+        f (Right ds:rs) xs = solveDs' (Just True) ds fixup (\nds -> f rs (nds ++ xs))
+        f [] xs = wdone xs
+    f (decomposeDs ds) []
hunk ./E/Demand.hs 377
-solveDs' (Just False) ds fixup wdone = solveDs' Nothing ds fixup wdone
-solveDs' Nothing ds fixup wdone = do
-    let f (Left d:rs) xs = solveDs' (Just False) [d] fixup (\nds -> f rs (nds ++ xs))
-        f (Right ds:rs) xs = solveDs' (Just True) ds fixup (\nds -> f rs (nds ++ xs))
-        f [] xs = wdone xs
-    f (decomposeDs ds) []
-solveDs' (Just True) ds fixup wdone = do
+--solveDs' (Just False) ds fixup wdone = solveDs' Nothing ds fixup wdone
+solveDs' (Just False) ds fixup wdone = error "solveDs' (Just False) called with more than one definition"
+solveDs' (Just True) ds fixup wdone = trace "solveDs': jt" $ do
hunk ./E/Demand.hs 381
-        g False [] ds = wdone [ (tvrInfo_u (Info.insert (fixup sig)) t,e) | ((t,e),sig) <- ds ]
-        g True [] ds = extEnvs [ (t,sig)| ((t,_),sig) <- ds] $ g False ds []
-        g ch (((t,e),sig):rs) fs = do
+        g 0 _ [] ds = trace "gdonetout" $ wdone [ (tvrInfo_u (Info.insert $! (fixup sig)) t,e) | ((t,e),sig) <- ds ]
+        g _ False [] ds = trace "gdone1" $ wdone [ (tvrInfo_u (Info.insert $! (fixup sig)) t,e) | ((t,e),sig) <- ds ]
+        g n True [] ds = do
+            (oe,dt) <- ask
+            let nenv = fromList [ (tvrIdent t,Left s) |  ((t,_),s) <- ds, not (isEmptyId (tvrIdent t))] `Util.SetLike.union` oe
+            local (const (nenv,dt)) $ trace ("grepeating: " ++ show (length ds)) $ g (n - 1) False ds []
+        g n ch (((t,e),sig):rs) fs = do
hunk ./E/Demand.hs 390
-            g (ch || (sig'' /= sig)) rs (((t,ne),sig''):fs)
-    g True [] ds'
+            --(if sig'' /= sig then trace ("signe: " ++ show(tvrIdent t,sig)) else id) $
+            g n (ch || (sig'' /= sig)) rs (((t,ne),sig''):fs)
+    g (5::Int) True [] ds'
hunk ./E/Demand.hs 396
-    dsOut <- solveDs (progDataTable prog) (programDs prog)
-    return $ programSetDs' dsOut prog
+    let ds = programDs prog
+    nds <- runIM (solveDs' Nothing ds fixupDemandSignature return) (progDataTable prog)
+    --flip mapM_ nds $ \ (t,_) ->
+    --    putStrLn $ "strictness: " ++ pprint t ++ ": " ++ show (maybe absSig id $ Info.lookup (tvrInfo t))
+    return $ programSetDs' nds prog
+
hunk ./E/Demand.hs 404
+----------------------------
+-- show and pprint instances
+----------------------------
hunk ./E/Demand.hs 408
+instance Show Demand where
+    showsPrec _ Bottom = ("_|_" ++)
+    showsPrec _ Absent = ('A':)
+    showsPrec _ (L None) = ('L':)
+    showsPrec _ (L (Product ds)) = showString "L(" . foldr (.) id (map shows ds) . showString ")"
+    showsPrec _ (S None) = ('S':)
+    showsPrec _ (S (Product ds)) = showString "S(" . foldr (.) id (map shows ds) . showString ")"
+    showsPrec _ (Error None) = showString "Err"
+    showsPrec _ (Error (Product ds)) = showString "Err(" . foldr (.) id (map shows ds) . showString ")"
+
+instance DocLike d => PPrint d Demand where
+    pprint demand = tshow demand
+
+instance Show DemandType where
+    showsPrec _ (DemandEnv e Absent :=> d) | isEmpty e = shows d
+    showsPrec _ (env :=> ds) = shows env . showString " :=> " .  shows ds
+
+instance Show DemandEnv where
+    showsPrec _ (DemandEnv m Absent) = showString "{" . foldr (.) id (intersperse (showString ",") [ showString (pprint t) . showString " -> " . shows v | (t,v) <- idMapToList m]) . showString "}"
+    showsPrec _ (DemandEnv _ Bottom) = showString "_|_"
+    showsPrec _ (DemandEnv m demand) = showString "{" . shows demand . showString " - " . foldr (.) id (intersperse (showString ",") [ showString (pprint t) . showString " -> " . shows v | (t,v) <- idMapToList m]) . showString "}"
+
+
+instance Show DemandSignature where
+    showsPrec _ (DemandSignature n dt) = showString "<" . shows n . showString "," . shows dt . showString ">"