[clean up some code, add beginnings of grin arity raising optimizationp
John Meacham <john@repetae.net>**20060129123404] addfile ./Grin/Arity.hs
hunk ./Grin/Arity.hs 1
+module Grin.Arity(grinRaiseArity) where
+
+import IO(stdout)
+import qualified Data.Map as Map
+
+import Fixer.Fixer
+import Fixer.Supply
+import Grin.Grin
+import Support.ShowTable
+import Support.FreeVars
+import GenUtil
+
+
+grinRaiseArity :: Grin -> IO Grin
+grinRaiseArity grin = do
+    fixer <- newFixer
+    argSupply <- newSupply fixer
+
+    mapM_ (go argSupply) (grinFunctions grin)
+
+    findFixpoint (Just ("grin arity raising",stdout)) fixer
+
+    rv <- supplyReadValues argSupply
+    printTable "Grin.Arity: arguments" rv
+
+
+    return grin
+
+
+go argSupply (fn,~(Tup as) :-> e) = do
+    vs <- mapM (\ (Var v _,i) -> supplyValue argSupply (fn,i)) (zip as naturals)
+    let env = Map.fromList (zip [ v | ~(Var v _) <- as ] vs)
+        f Fetch {} = return ()
+        f (App n as _) = mapM_ (g n) (zip as naturals)
+        f (Store (NodeC nn as)) | Just (_,n) <- tagUnfunction nn = mapM_ (g n) (zip as naturals)
+        f (e1 :>>= p :-> e2) = f e1 >> f e2
+        f (Case x as) = mapM_ bf (freeVars x) >> sequence_ [ f e  | _ :-> e <- as]
+        f e = mapM_ bf (freeVars e)
+        g fn (Var v _,i) | Just value <- Map.lookup v env = do
+            vv <- supplyValue argSupply (fn,i)
+            addRule $ vv `implies` value
+        g _ _ = return ()
+        bf v | Just val <- Map.lookup v env = addRule $ value True `implies` val
+        bf _ = return ()
+    f e
+
+implies :: Value Bool -> Value Bool -> Rule
+implies x y = y `isSuperSetOf` x
+
hunk ./Grin/Show.hs 82
-    | t == Ty "uint32_t" = char 'c' <> tshow i
+    | t == Ty (toAtom "uint32_t") = char 'c' <> tshow i
hunk ./Grin/Show.hs 113
+showSome xs = f 7 xs [] where
+    f 0 _ xs = reverse ("...":xs)
+    f _ [] xs = reverse xs
+    f n (x:xs) rs = f (n - 1) xs (x:rs)
+
hunk ./Grin/Show.hs 120
-    show (HeapValue hv) = braces $ hcat $ punctuate "," (map show (Set.toList hv))
-    show (NodeValue hv) = braces $ hcat $ punctuate "," (map show (Set.toList hv))
+    show (HeapValue hv) = braces $ hcat $ punctuate "," (showSome $ map show (Set.toList hv))
+    show (NodeValue hv) = braces $ hcat $ punctuate "," (showSome $ map show (Set.toList hv))
hunk ./Main.hs 46
+import Grin.Arity
hunk ./Main.hs 480
+--    x <- grinRaiseArity x
+--    x <- return $ normalizeGrin x
+--    typecheckGrin x
+--    x <- opt "After Arity Optimization" x
+--    wdump FD.OptimizationStats $ Stats.print "AE Optimization" stats
+--    x <- return $ normalizeGrin x
+
hunk ./Main.hs 488
-    printTable "Argument points-to" (Map.map (map dereferenceItem) $ grinArgTags x)
+    printTable "Argument points-to" (grinArgTags x)