[convert linear analysis to use Fixer.Fixer rather than UnionFind
John Meacham <john@repetae.net>**20060125023148] hunk ./Grin/Linear.hs 1
-module Grin.Linear(grinLinear,W(One,Omega)) where
+module Grin.Linear(grinLinear,W(..)) where
hunk ./Grin/Linear.hs 3
-import Control.Monad.Identity
-import Data.IORef
-import Data.Monoid
hunk ./Grin/Linear.hs 4
-import qualified Data.Set as Set
hunk ./Grin/Linear.hs 5
-import Fixer.Supply
-import Fixer.Fixer
hunk ./Grin/Linear.hs 6
-import Atom
+import Fixer.Fixer
+import Fixer.Supply
hunk ./Grin/Linear.hs 9
-import Util.UnionFind
hunk ./Grin/Linear.hs 10
-data W = One | Omega | LessThan (Set.Set E)
+data W = One | Omega
hunk ./Grin/Linear.hs 12
-type E = Element W Var
hunk ./Grin/Linear.hs 13
-{-
-instance Monoid W where
-    --mappend Omega Omega = Omega
-    mappend Omega _ = Omega
-    mappend _ Omega = Omega
-    mappend One x = x
-    mappend x One = x
-    mappend (LessThan xs) (LessThan ys) = LessThan (Set.union xs ys)
-    mappend x y = error $ "mappend: " ++ show (x,y)
-    mempty = LessThan Set.empty
--}
+instance Fixable W where
+    bottom = One
+    isBottom One = True
+    isBottom _ = False
+    lub a b = max a b
+    minus a b | a > b = a
+    minus _ _ = bottom
hunk ./Grin/Linear.hs 21
-emptyW = LessThan Set.empty
hunk ./Grin/Linear.hs 24
-    fm <- flip mapM grinFunctions $ \ (a,Tup xs :-> _) ->  do
-        xs' <- flip mapM xs $ \ (Var v _) -> new (emptyW :: W) v
-        return $ Map.fromList [ ((a,x),y) | x <- [0::Int ..] | y <- xs']
-    storeVars <- newIORef []
-    mapM_ (go (Map.unions fm) storeVars) grinFunctions
-    svs <- readIORef storeVars
-    mapM_ (updateW (\x -> case x of LessThan {} -> One ; _ -> x)) svs
-    svs <- mapM (\x -> do w <- getW x; return (fromElement x,w))  svs
-    return svs
+    fixer <- newFixer
+    argSupply <- newSupply fixer
+    varSupply <- newSupply fixer
+    mapM_ (go argSupply varSupply) grinFunctions
+    findFixpoint fixer
+    supplyReadValues varSupply
hunk ./Grin/Linear.hs 31
-go (fm:: Map.Map (Atom,Int) E) storeVars (fn,Tup vs :-> fb) = f fb (Map.fromList [ (v,(0::Int, runIdentity $ Map.lookup (fn,z) fm)) | ~(Var v _) <- vs | z <- [ 0 ..]]) where
+go argSupply varSupply (fn,~(Tup vs) :-> fb) = ans where
+    ans = do
+        ms <- flip mapM [ (v,z) | ~(Var v _) <- vs | z <- [ 0::Int ..]] $ \ (v,z) -> do
+            vv <- supplyValue argSupply (fn,z)
+            return (v,(0::Int,vv))
+        f fb (Map.fromList ms)
hunk ./Grin/Linear.hs 39
-        ee <- new emptyW v
-        modifyIORef storeVars (ee:)
+        ee <- supplyValue varSupply v
hunk ./Grin/Linear.hs 62
-    h Cast {} = return ()   -- casts argument are never node pointers
+    h Cast {} = return ()   -- casts argument is never a node pointer
hunk ./Grin/Linear.hs 73
-            Just (_,v) -> toOmega v
+            Just (_,v) -> lift $ toOmega v
hunk ./Grin/Linear.hs 79
-        ea <- Map.lookup an fm
+        ea <- lift $ supplyValue argSupply an
hunk ./Grin/Linear.hs 82
-            Just (_,ev) -> ea `isLessThan` ev
+            Just (_,ev) -> lift $ addRule $ ev `isSuperSetOf` ea
hunk ./Grin/Linear.hs 89
-            Just (1,e) -> toOmega e
+            Just (1,e) -> lift $ toOmega e
hunk ./Grin/Linear.hs 93
+toOmega e = addRule $ e `isSuperSetOf` value Omega
hunk ./Grin/Linear.hs 96
-e1 `isLessThan` e2 = do
-    w <- getW e2
-    case w of
-        Omega -> return ()
-        _ -> do
-            w <- getW e1
-            case w of
-                Omega -> toOmega e2
-                LessThan xs -> updateW (const $ LessThan $ Set.insert e2 xs) e1
-
-toOmega e = do
-    w <- getW e
-    case w of
-        Omega -> return ()
-        LessThan ss -> do
-            updateW (const Omega) e
-            mapM_ toOmega (Set.toList ss)
hunk ./Grin/Linear.hs 97
-{-
-unify e1 e2 = do
-    w1 <- getW e1
-    w2 <- getW e2
-    union mappend e1 e2
-    let f Omega (LessThan ss) = mapM_ toOmega (Set.toList ss)
-        f _ _ = return ()
-    f w1 w2
-    f w2 w1
--}