[start adding storage analysis support
John Meacham <john@repetae.net>**20090905015718
 Ignore-this: 2a1f36882b7824cbb4f40403afd46ec1
] addfile ./src/Grin/StorageAnalysis.hs
hunk ./Makefile.am 42
-	src/Support/IniParse.hs src/E/Lint.hs src/Util/Progress.hs
+	src/Support/IniParse.hs src/E/Lint.hs src/Util/Progress.hs src/Grin/StorageAnalysis.hs
hunk ./src/Grin/Grin.hs 162
-    | Consume               -- consume a value, depending on the back end this may be needed to free memory
+    | Consume               -- consume a value, depending on the back end this may be used to free memory
hunk ./src/Grin/Grin.hs 308
+        | TyRegion <- t = text "r" <> tshow i
hunk ./src/Grin/NodeAnalyze.hs 135
-    (grin',stats) <- Stats.runStatT $ mapGrinFuncsM (fixupfs cmap (grinTypeEnv grin)) grin
+    (grin',stats) <- Stats.runStatT $ tickleM (fixupfs cmap (grinTypeEnv grin)) grin
hunk ./src/Grin/NodeAnalyze.hs 417
-    ans = do mapGrinFuncsM f grin
+    ans = do tickleM f grin
hunk ./src/Grin/NodeAnalyze.hs 448
-mapGrinFuncsM :: Monad m => (Lam -> m Lam) -> Grin -> m Grin
-mapGrinFuncsM f grin = liftM (`setGrinFunctions` grin) $ mapM  (\x -> do nb <- f (funcDefBody x); return (funcDefName x, nb)) (grinFunctions grin)
hunk ./src/Grin/Noodle.hs 39
-
hunk ./src/Grin/Noodle.hs 46
+instance Tickleable Lam Grin where
+    tickleM f grin = liftM (`setGrinFunctions` grin) $ mapM  (\x -> do nb <- f (funcDefBody x); return (funcDefName x, nb)) (grinFunctions grin)
+instance Tickleable Lam FuncDef where
+    tickleM f fd = funcDefBody_uM f fd
+instance Tickleable (Atom,Lam) FuncDef where
+    tickleM f fd@FuncDef { funcDefName = n, funcDefBody = b } = do
+    (n',b') <- f (n,b)
+    return $  updateFuncDefProps fd { funcDefBody = b', funcDefName = n' }
hunk ./src/Grin/Noodle.hs 261
+
+mapGrinFuncsM :: Monad m => (Atom -> Lam -> m Lam) -> Grin -> m Grin
+mapGrinFuncsM f grin = liftM (`setGrinFunctions` grin) $ mapM  (\x -> do nb <- f (funcDefName x) (funcDefBody x); return (funcDefName x, nb)) (grinFunctions grin)
+
+
hunk ./src/Grin/StorageAnalysis.hs 1
+module Grin.StorageAnalysis(storeAnalyze) where
+
+import Control.Monad
+import Control.Monad.Writer
+import Data.Maybe
+
+import Support.FreeVars
+import Support.CanType
+import Grin.Lint
+import StringTable.Atom
+import Support.Tickle
+import Util.UniqueMonad
+import Util.UnionSolve
+import Grin.Grin
+import Grin.Noodle
+import Util.Gen
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+
+data T = S | E
+    deriving(Eq,Show)
+
+instance Fixable T where
+    join S S = S
+    join _ _ = E
+
+    meet E E = E
+    meet _ _ = S
+
+    isTop x = E == x
+    isBottom x = S == x
+
+    eq = (==)
+
+    lte E S = False
+    lte _ _ = True
+
+data Vr
+    = Vb !Var         -- ^ inner variable
+    | Va !Atom !Int   -- ^ function argument
+    | Vr !Var         -- ^ region variable
+    deriving(Eq,Ord)
+
+instance Show Vr where
+    showsPrec _ (Vb v) = shows v
+    showsPrec _ (Va a i) = shows (a,i)
+    showsPrec _ (Vr (V n)) = showChar 'r' . shows n
+
+
+{-# NOINLINE storeAnalyze #-}
+storeAnalyze :: Grin -> IO Grin
+storeAnalyze grin = do
+    dumpGrin "storeAnalyze1" grin
+    let (grin',cs) = execUniq1 $ runWriterT (mapGrinFuncsM firstLam grin)
+    dumpGrin "storeAnalyze2" grin'
+    --(rm,res) <- solve (const $ return ()) cs
+    (rm,res) <- solve putStrLn cs
+    putStrLn "----------------------------"
+    mapM_ (\ (x,y) -> putStrLn $ show x ++ " -> " ++ show y) (Map.toList rm)
+    putStrLn "----------------------------"
+    mapM_ print (Map.elems res)
+    putStrLn "----------------------------"
+    let cmap = Map.map (lower . fromJust . flip Map.lookup res) rm
+        lower (ResultJust _ j) = j
+        lower ResultBounded { resultLB = Nothing } = S
+    mapM_ (\ (x,y) -> putStrLn $ show x ++ " -> " ++ show y) (Map.toList cmap)
+    return grin'
+
+
+isHeap TyNode = True
+isHeap TyINode = True
+--isHeap TyPtr {} = True
+isHeap _ = False
+
+firstLam fname lam = g Nothing fname lam where
+    g wtd fname (as :-> body) = do
+        tell $ mconcat [ Left (Vb v) `equals` Left (Va fname n) | (n,Var v t) <- zip naturals as, isHeap t ]
+        let f wtd (BaseOp (StoreNode sh) [n@(NodeC _ vs)]) = do
+                vu <- V `liftM` newUniq
+                g wtd [[Vr vu]]
+                tell $ mconcat [ Left (Vr vu) `islte` Left v | v' <- toVs vs, v <- v'  ]
+                return (BaseOp (StoreNode sh) [n,Var vu TyRegion])
+            f wtd (e :>>= as :-> body) = do
+                e' <- f (Just as) e
+                body' <- f wtd body
+                return (e' :>>= as :-> body')
+            f wtd (Case e as) = Case e `liftM` mapM (tickleM  (f wtd)) as
+            f wtd (Return xs) = g wtd (toVs xs) >> return (Return xs)
+            f wtd e@(BaseOp Promote xs) = g wtd (toVs xs) >> return e
+            f wtd e@(BaseOp Demote xs) = g wtd (toVs xs) >> return e
+            f wtd e@(BaseOp Redirect xs) = g Nothing (toVs xs) >> return e
+            f wtd e@(App fn vs ty) = do
+                tell $ mconcat [ Left (Va fn n) `islte` Left (Vb v) | (n,Var v t) <- zip naturals vs, isHeap t ]
+                return e
+            f wtd e@(Let { expDefs = defs, expBody = b }) = do
+                defs' <- mapM (tickleM (g' wtd)) defs
+                b <- f wtd b
+                return $ updateLetProps e { expDefs = defs', expBody = b }
+            f wtd e = return e
+
+            g Nothing vs = tell $ mconcat [ Right E `islte` Left v | v' <- vs, v <- v' ]
+            g (Just as) vs = tell $ mconcat [ Left a `islte` Left v | (a',v') <- zip (toVs as) vs, a <- a', v <- v']
+
+            toVs :: [Val] -> [[Vr]]
+            toVs xs = f xs [] where
+                f [] rs = reverse rs
+                f (x:xs) rs = f xs (Set.toList (Set.map (Vb . fst) $ Set.filter (isHeap . snd) (freeVars x)):rs)
+        b <- f wtd body
+        return (as :-> b)
+    g' wtd (fname,b) = do
+        b <- g wtd fname b
+        return (fname,b)
+
+
+
+
+
hunk ./src/Grin/Val.hs 35
+-- This allocates data on the stack, generally equivalent to 'block' for most back ends.
+region_stack = Item (toAtom "stack") TyRegion
hunk ./src/Main.hs 51
+import Grin.StorageAnalysis
hunk ./src/Main.hs 678
+--    x <- storeAnalyze x