[determine absence information as well as strictness
John Meacham <john@repetae.net>**20060714021330] hunk ./E/Demand.hs 18
-import Doc.PPrint
+import Binary
+import DataConstructors
hunk ./E/Demand.hs 21
-import E.Inline
+import Doc.PPrint
hunk ./E/Demand.hs 23
-import GenUtil
-import DataConstructors
-import qualified Info.Info as Info
+import E.Inline
hunk ./E/Demand.hs 25
+import GenUtil
hunk ./E/Demand.hs 27
+import qualified Info.Info as Info
hunk ./E/Demand.hs 32
-    Bottom    -- hyperstrict
-    | L       -- lazy
+    Bottom             -- always diverges
+    | L SubDemand      -- lazy
hunk ./E/Demand.hs 35
+    | Error SubDemand  -- diverges, might use arguments
+    | Absent           -- Not used
hunk ./E/Demand.hs 38
+        {-! derive: GhcBinary !-}
hunk ./E/Demand.hs 42
-    showsPrec _ L = ('L':)
+    showsPrec _ Absent = ('A':)
+    showsPrec _ (L None) = ('L':)
+    showsPrec _ (L (Product ds)) = showString "L(" . foldr (.) id (map shows ds) . showString ")"
hunk ./E/Demand.hs 47
+    showsPrec _ (Error None) = showString "Err"
+    showsPrec _ (Error (Product ds)) = showString "Err(" . foldr (.) id (map shows ds) . showString ")"
hunk ./E/Demand.hs 55
+        {-! derive: GhcBinary !-}
hunk ./E/Demand.hs 59
-data DemandType = DemandEnv :=> [Demand]
+        {-! derive: GhcBinary !-}
+data DemandType = (:=>) DemandEnv [Demand]
hunk ./E/Demand.hs 62
+        {-! derive: GhcBinary !-}
hunk ./E/Demand.hs 65
+        {-! derive: GhcBinary !-}
hunk ./E/Demand.hs 68
-    showsPrec _ (DemandEnv e L :=> d) | isEmpty e = shows d
+    showsPrec _ (DemandEnv e Absent :=> d) | isEmpty e = shows d
hunk ./E/Demand.hs 72
-    showsPrec _ (DemandEnv m L) = pprint m
+    showsPrec _ (DemandEnv m Absent) = pprint m
hunk ./E/Demand.hs 79
-idGlb = L
+idGlb = Absent
hunk ./E/Demand.hs 93
+sp [] = S None
hunk ./E/Demand.hs 97
-    sp' allLazy (L:rs) = sp' allLazy rs
-    sp' _ (Bottom:_) = Bottom
+    sp' allLazy (L _:rs) = sp' allLazy rs
+    sp' _ (Bottom:_) = Error (Product s)
hunk ./E/Demand.hs 106
+lazy = L None
+strict = S None
+err = Error None
+
+comb _ None None = None
+comb f None (Product xs) = Product $ zipWith f (repeat lazy) xs
+comb f (Product xs) None = Product $ zipWith f xs (repeat lazy)
+comb f (Product xs) (Product ys) = Product $ zipWith f xs ys
+
+
hunk ./E/Demand.hs 119
-    lub L _  = L
-    lub _ L  = L
-    lub (S (Product xs)) (S (Product ys)) | length xs == length ys = sp (zipWith lub xs ys)
-    lub (S _) (S _) = S None
+    lub Absent Absent = Absent
+    lub (S x) Absent = L x
+    lub Absent (S x) = L x
+    lub Absent sa = lazy
+    lub sa Absent = lazy
+
+    lub (S x) (S y) = S (comb lub x y)
+    lub (L x) (L y) = L (comb lub x y)
+    lub (Error x) (Error y) = Error (comb lub x y)
+
+    lub (S x) (L y) = L (comb lub x y)
+    lub (L x) (S y) = L (comb lub x y)
+
+    lub (S x) (Error y) = S (comb lub x y)
+    lub (Error x) (S y) = S (comb lub x y)
+
+    lub (L x) (Error y) = lazy
+    lub (Error x) (L y) = lazy
+
hunk ./E/Demand.hs 139
+    glb Bottom Bottom = Bottom
+    glb Absent sa = sa
+    glb sa Absent = sa
+
+    glb Bottom _ = err
+    glb _ Bottom = err
+
+    glb (S x) (S y) = S (comb glb x y)
+    glb (L x) (L y) = L (comb glb x y)
+    glb (Error x) (Error y) = Error (comb glb x y)
+
+    glb (S _) (Error _) = err
+    glb (Error _) (S _) = err
+
+    glb (S x) (L y) = S (comb glb x y)
+    glb (L x) (S y) = S (comb glb x y)
+
+    glb (L _) (Error _) = err
+    glb (Error _) (L _) = err
hunk ./E/Demand.hs 159
-    glb Bottom _ = Bottom
-    glb _ Bottom = Bottom
-    glb L s = s
-    glb s L = s
-    glb (S None) (S None) = S None
-    glb s1 s2 = sp (zipWith glb (sargs s1) (sargs s2))
hunk ./E/Demand.hs 160
-sargs (S None) = repeat L
-sargs (S (Product xs)) = xs
hunk ./E/Demand.hs 166
-demandEnvSingleton _ L = DemandEnv mempty idGlb
+demandEnvSingleton _ Absent = DemandEnv mempty idGlb
hunk ./E/Demand.hs 205
-splitSigma [] = (L,[])
+splitSigma [] = (lazy,[])
hunk ./E/Demand.hs 209
-analyze e L = return (e,absType)
+analyze e Absent = return (e,absType)
hunk ./E/Demand.hs 228
+analyze (ELit lc@LitCons { litArgs = ts }) _s = do
+    rts <- mapM (\e -> analyze e lazy) ts
+    return (ELit lc { litArgs = fsts rts }, foldr glb absType (snds rts))
+analyze (EPrim ap ts pt) _s = do
+    rts <- mapM (\e -> analyze e lazy) ts
+    return (EPrim ap (fsts rts) pt, foldr glb absType (snds rts))
+analyze (EPi tvr@TVr { tvrType = t1 } t2)  _s = do
+    (t1',dt1) <- analyze t1 lazy
+    (t2',dt2) <- analyze t2 lazy
+    return (EPi tvr { tvrType = t1' } t2',dt1 `glb` dt2)
+
hunk ./E/Demand.hs 243
-analyze (ELam x e) (S None) = analyze (ELam x e) (S (Product [L]))  -- simply to ensure binder is annotated
+analyze (ELam x e) (S None) = analyze (ELam x e) (S (Product [lazy]))  -- simply to ensure binder is annotated