[unfinished changes to SStrictness analyzer
John Meacham <john@repetae.net>**20060708010820] hunk ./E/SStrictness.hs 17
-import Util.UnionSolve
+import Util.BooleanSolver
hunk ./E/SStrictness.hs 22
--- simple 2 point lattice for the moment
-data SL = L | S
-    deriving (Eq,Typeable,Show)
+-- our 2 point lattice
+-- True == strict
+-- False == not strict
hunk ./E/SStrictness.hs 26
-instance Fixable SL where
-    isTop s = s == S
-    isBottom l = l == L
-    join L L = L
-    join _ _ = S
-    meet S S = S
-    meet _ _ = L
-    eq = (==)
-    lte S L = False
-    lte _ _ = True
+type SL = Bool
hunk ./E/SStrictness.hs 29
+x `islte` y = x `implies` y
+x `isgte` y = y `implies` x
+
hunk ./E/SStrictness.hs 39
-type Typ = TAnot (Either Var SL)
+type Typ = TAnot (CV (CA Var))
hunk ./E/SStrictness.hs 49
+instance FunctorM TAnot where
+    fmapM f (TAnot l t) = do l <- f l; t <- fmapM f t; return $ TAnot l t
+
+instance FunctorM TTyp where
+    fmapM _ TAtomic = return TAtomic
+    fmapM f (x `TFun` y) = do x <- fmapM f x; y <- fmapM f y; return $ x `TFun` y
+    fmapM f (TCPR xs) = do xs <- mapM (fmapM f) xs; return $ TCPR xs
+
hunk ./E/SStrictness.hs 72
-type Constraints = C SL Var
+type Constraints = C (CA Var)
hunk ./E/SStrictness.hs 76
-newtype IM t a = IM (RWST Environment Constraints Int t a)
-    deriving(MonadState Int,MonadReader Environment,MonadWriter Constraints,Monad,Functor)
+newtype IM a = IM (RWST Environment Constraints Int IO a)
+    deriving(MonadState Int,MonadReader Environment,MonadWriter Constraints,Monad,Functor,MonadIO)
hunk ./E/SStrictness.hs 79
-newVar :: Monad m => IM m Var
+newVar :: IM Var
hunk ./E/SStrictness.hs 90
-fn (Left v) = ShowString (show v)
-fn (Right v) = ShowString (show v)
+fn (CJust v) = ShowString (show v)
+fn CTrue = ShowString "S"
+fn CFalse = ShowString "L"
+
+strict,lazy :: CV (CA Var)
+strict = CTrue
+lazy = CFalse
+
+data Variance = Nowhere | Positive | Negative | Both
+    deriving(Eq,Ord,Show)
+
+instance Monoid Variance where
+    mempty = Nowhere
+    mappend x y | x == y = x
+    mappend Positive Negative = Both
+    mappend Negative Positive = Both
+    mappend Nowhere x = x
+    mappend x Nowhere = x
+
+flipVariance Positive = Negative
+flipVariance Negative = Positive
+flipVariance x = x
+
+collect :: Typ -> [(Var,Variance)]
+collect t = execWriter $ f Positive t where
+    f p (TAnot (CJust v) t) = tell [(fromCA v,p)] >> g p t
+    f p (TAnot _ t) = g p t
+    g p TAtomic = return ()
+    g p (x `TFun` y) = f (flipVariance p) x >> f p y
+
hunk ./E/SStrictness.hs 121
+{-# NOINLINE analyzeProgram #-}
hunk ./E/SStrictness.hs 128
-            let cc (TAnot l TAtomic) = Right S `islte` l
+            let cc (TAnot l TAtomic) = strict `islte` l
hunk ./E/SStrictness.hs 132
-            (mp,rs) <- solve c
-            let fn' (Right v) = ShowString (show v)
-                fn' (Left x)
-                    | Just x <- Map.lookup x mp, Just (ResultJust _ x) <- Map.lookup x rs = ShowString (show x)
-                    | Just x <- Map.lookup x mp = ShowString (show x)
-                    | otherwise = ShowString (show x)
-            print (fmap fn' ty)
-            mapM_ print (Map.elems rs)
-            putStrLn "solving:"
-            (mp,rs) <- solve $ c `mappend` cc ty
-            let fn' (Right v) = ShowString (show v)
-                fn' (Left x)
-                    | Just x <- Map.lookup x mp, Just (ResultJust _ x) <- Map.lookup x rs = ShowString (show x)
-                    | Just x <- Map.lookup x mp = ShowString (show x)
-                    | otherwise = ShowString (show x)
-            print (fmap fn' ty)
-            mapM_ print (Map.elems rs)
+            --(cc,cvs) <- groundConstraints $ c -- `mappend` cc ty
+            processConstraints True c
+--            rs <- flip mapM cvs $ \cv -> do
+--                res <- readValue cv
+--                let rr = case res of
+--                        ResultJust True -> CTrue
+--                        ResultJust False -> CFalse
+--                        ResultBounded a _ _ -> CJust (fromCA a)
+--                return (fromCA cv, rr )
+--            let mp :: Map.Map Var (CV Var)
+--                mp = Map.fromList rs
+--                zz (CJust x) | Just y <- Map.lookup x (Map.fromList rs) = y
+--                zz (CJust y) = CJust y
+--                zz CTrue = CTrue
+--                zz CFalse = CFalse
+--                ty' = fmap zz ty
+--            print (fmap fn ty)
+--            let varmap = (Map.fromListWith mappend $ collect ty')
+--            print varmap
+--            flip mapM_ cvs $ \cv -> do
+--                res <- readValue cv
+--                print (fromCA cv,fmap fromCA res)
+--            --print (fmap (zz . CJust . fromCA) cc)
hunk ./E/SStrictness.hs 159
-runIM :: Monad m => IM m a -> m (Constraints,a)
+runIM :: MonadIO m => IM a -> m (Constraints,a)
hunk ./E/SStrictness.hs 161
-    (a,_,c) <- runRWST s mempty 1
+    (a,_,c) <- liftIO $ runRWST s mempty 1
hunk ./E/SStrictness.hs 164
-atom = TAnot (Right L) TAtomic
+atom = TAnot lazy TAtomic
+
+mkVar :: IM (CV (CA Var))
+mkVar = do
+    v <- newVar
+    ca <- mkCA v
+    return (CJust ca)
hunk ./E/SStrictness.hs 172
-infer :: Monad m => E -> IM m (TAnot (Either Var SL),E)
+infer :: E -> IM (Typ,E)
hunk ./E/SStrictness.hs 174
-    v <- fmap Left newVar
-    return (TAnot v TAtomic,e)
+    return (TAnot strict TAtomic,e)
+    --return (atom,e)
hunk ./E/SStrictness.hs 177
-    return (atom,e)
+    return (TAnot strict TAtomic,e)
+    --return (atom,e)
hunk ./E/SStrictness.hs 189
-    v <- fmap Left newVar
+    v <- mkVar
hunk ./E/SStrictness.hs 193
-    return (atom,EError s t)
+    v <- mkVar
+    return (TAnot v TAtomic,EError s t)
hunk ./E/SStrictness.hs 199
-    return (TAnot (Right L) $ s1 `TFun` s2,ELam x e)
+    v <- mkVar
+    return (TAnot strict $ s1 `TFun` s2,ELam x e)
hunk ./E/SStrictness.hs 202
+    nv <- mkVar
hunk ./E/SStrictness.hs 204
+    tell (nv `implies` t)
hunk ./E/SStrictness.hs 206
-    rt@(TAnot res _) <- foldM freshGLB ty tys
-    tell (t `isgte` res)
-    return (rt,ec { eCaseScrutinee = e' })
+    (TAnot res rt) <- foldM freshGLB ty tys
+    tell (nv `implies` res)
+    return (TAnot nv rt,ec { eCaseScrutinee = e' })
hunk ./E/SStrictness.hs 210
-    (TAnot k (s1 `TFun` s2@(TAnot res _)),a) <- infer a
-    (s1',b) <- infer b
-    s1' `subsA` s1
-    res <- fmap Left newVar
+    (TAnot k (s1 `TFun` (TAnot rst s2)),a) <- infer a
+    (s1'@(TAnot zz _),b) <- infer b
+    s1 `subsA` s1'
+    res <- mkVar
hunk ./E/SStrictness.hs 215
-    tell (k `isgte` res)
-    return (s2,EAp a b)
+    tell (res `implies` k)
+    tell (res `implies` rst)
+    return (TAnot res s2,EAp a b)
hunk ./E/SStrictness.hs 219
-    
+
hunk ./E/SStrictness.hs 237
-    v <- fmap Left newVar
-    return (TAnot v $ TAnot (Right L) t1 `TFun` t2)
+    v <- mkVar
+    return (TAnot v $ TAnot lazy t1 `TFun` t2)
hunk ./E/SStrictness.hs 240
-    v <- newVar
-    return (TAnot (Left v) TAtomic)
+    v <- mkVar
+    return (TAnot v TAtomic)
hunk ./E/SStrictness.hs 246
-    v <- fmap Left newVar
+    v <- mkVar
hunk ./E/SStrictness.hs 249
-    v <- newVar
-    return (TAnot (Left v) TAtomic)
+    v <- mkVar
+    return (TAnot v TAtomic)
hunk ./E/SStrictness.hs 253
-    v <- fmap Left newVar
+    v <- mkVar
hunk ./E/SStrictness.hs 260
-    v <- fmap Left newVar
+    v <- mkVar
hunk ./E/SStrictness.hs 268
-    v <- fmap Left newVar
+    v <- mkVar
hunk ./E/SStrictness.hs 274
-    v <- fmap Left newVar
+    v <- mkVar