[move a bunch of common routines to Grin.Noodle from their scattered locations
John Meacham <john@repetae.net>**20060817023041] addfile ./Grin/Noodle.hs
hunk ./Grin/Devolve.hs 11
+import Grin.Noodle
hunk ./Grin/FromE.hs 30
+import Grin.Noodle
hunk ./Grin/FromE.hs 46
-import Util.UniqueMonad()
hunk ./Grin/FromE.hs 47
+import Util.UniqueMonad()
hunk ./Grin/FromE.hs 197
+        a @>> b = a :>>= (unit :-> b)
+        sequenceG_ [] = Return unit
+        sequenceG_ (x:xs) = foldl (@>>) x xs
hunk ./Grin/Grin.hs 16
-    mapFBodies,
hunk ./Grin/Grin.hs 39
-    isMutableNodeTag,
-    isVar,isTup,modifyTail,valIsConstant,
+    isVar,isTup,
hunk ./Grin/Grin.hs 41
-    mapBodyM,
-    mapExpExp,
hunk ./Grin/Grin.hs 46
-    sequenceG_,
hunk ./Grin/Grin.hs 118
-
hunk ./Grin/Grin.hs 126
-a @>> b = a :>>= (unit :-> b)
-sequenceG_ [] = Return unit
-sequenceG_ (x:xs) = foldl (@>>) x xs
-
-
hunk ./Grin/Grin.hs 315
-mapBodyM f (x :-> y) = f y >>= return . (x :->)
-
-mapExpExp f (a :>>= v :-> b) = do
-    a <- f a
-    b <- f b
-    return (a :>>= v :-> b)
-mapExpExp f (Case e as) = do
-    as' <- mapM (mapBodyM f) as
-    return (Case e as')
-mapExpExp f l@Let { expBody = b, expDefs = defs } = do
-    b <- f b
-    defs' <- mapFBodies f defs
-    return l { expBody = b, expDefs = defs' }
-mapExpExp _ x = return x
-
-mapFBodies f xs = mapM f' xs where
-    f' fd@FuncDef { funcDefBody = l :-> r } = do
-        r' <- f r
-        return $  updateFuncDefProps fd { funcDefBody = l :-> r' }
-
hunk ./Grin/Grin.hs 767
-modifyTail :: Lam -> Exp -> Exp
-modifyTail lam@(_ :-> lb) e = f e where
-    f (Error s ty) = Error s (getType lb)
-    f (Case x ls) = Case x (map g ls)
-    f lt@Let {expBody = body } = lt { expBody = f body }
-    f lt@MkCont {expLam = lam, expCont = cont } = lt { expLam = g lam, expCont = g cont }
-    f (e1 :>>= p :-> e2) = e1 :>>= p :-> f e2
-    f e = e :>>= lam
-    g (p :-> e) = p :-> f e
hunk ./Grin/Grin.hs 768
--- | Is type mutable (currently IORef)
-isMutableNodeTag :: Tag -> Bool
-isMutableNodeTag t = t == ref_tag where ref_tag = toAtom "CData.IORef.IORef"
hunk ./Grin/Grin.hs 769
--- | Is a Val constant?
-valIsConstant :: Val -> Bool
-valIsConstant (Tup xs) = all valIsConstant xs
-valIsConstant (NodeC t _) | isMutableNodeTag t = False
-valIsConstant (NodeC _ xs) = all valIsConstant xs
-valIsConstant Tag {} = True
-valIsConstant Lit {} = True
-valIsConstant Const {} = True
-valIsConstant (Var v _) | v < v0 = True
-valIsConstant ValPrim {} = True
-valIsConstant _ = False
hunk ./Grin/Noodle.hs 1
+module Grin.Noodle where
+
+-- various routines for manipulating and exploring grin code.
+
+import Atom(Atom(),toAtom)
+import C.Prims
+import Grin.Grin
+import Support.CanType
+
+
+modifyTail :: Lam -> Exp -> Exp
+modifyTail lam@(_ :-> lb) e = f e where
+    f (Error s ty) = Error s (getType lb)
+    f (Case x ls) = Case x (map g ls)
+    f lt@Let {expBody = body } = lt { expBody = f body }
+    f lt@MkCont {expLam = lam, expCont = cont } = lt { expLam = g lam, expCont = g cont }
+    f (e1 :>>= p :-> e2) = e1 :>>= p :-> f e2
+    f e = e :>>= lam
+    g (p :-> e) = p :-> f e
+
+
+mapBodyM f (x :-> y) = f y >>= return . (x :->)
+
+mapExpExp f (a :>>= v :-> b) = do
+    a <- f a
+    b <- f b
+    return (a :>>= v :-> b)
+mapExpExp f (Case e as) = do
+    as' <- mapM (mapBodyM f) as
+    return (Case e as')
+mapExpExp f l@Let { expBody = b, expDefs = defs } = do
+    b <- f b
+    defs' <- mapFBodies f defs
+    return l { expBody = b, expDefs = defs' }
+mapExpExp _ x = return x
+
+mapFBodies f xs = mapM f' xs where
+    f' fd@FuncDef { funcDefBody = l :-> r } = do
+        r' <- f r
+        return $  updateFuncDefProps fd { funcDefBody = l :-> r' }
+
+
+--------------------------
+-- examining and reporting
+--------------------------
+
+isManifestNode :: Monad m => Exp -> m [Atom]
+isManifestNode (Return (Tag t)) = return [t]
+isManifestNode (Return (NodeC t _)) = return [t]
+isManifestNode Error {} = return []
+isManifestNode (Case _ ls) = do
+    cs <- Prelude.mapM isManifestNode [ e | _ :-> e <- ls ]
+    return $ concat cs
+isManifestNode (_ :>>= _ :-> e) = isManifestNode e
+isManifestNode _ = fail "not manifest node"
+
+
+-- | Is a Val constant?
+valIsConstant :: Val -> Bool
+valIsConstant (Tup xs) = all valIsConstant xs
+valIsConstant (NodeC t _) | isMutableNodeTag t = False
+valIsConstant (NodeC _ xs) = all valIsConstant xs
+valIsConstant Tag {} = True
+valIsConstant Lit {} = True
+valIsConstant Const {} = True
+valIsConstant (Var v _) | v < v0 = True
+valIsConstant ValPrim {} = True
+valIsConstant _ = False
+
+-- | Is type mutable (currently IORef)
+isMutableNodeTag :: Tag -> Bool
+isMutableNodeTag t = t == ref_tag where ref_tag = toAtom "CData.IORef.IORef"
+
+valIsMutable (NodeC t _) = isMutableNodeTag t
+valIsMutable _ = False
+
+
+
+isOmittable (Fetch {}) = True
+isOmittable (Return {}) = True
+isOmittable (Store (NodeC n _)) | isMutableNodeTag n || n == tagHole = False
+isOmittable (Store {}) = True
+isOmittable Prim { expPrimitive = Primitive { primAPrim = aprim } } = aprimIsCheap aprim
+isOmittable (Case x ds) = all isOmittable [ e | _ :-> e <- ds ]
+isOmittable Let { expBody = x } = isOmittable x
+isOmittable (e1 :>>= _ :-> e2) = isOmittable e1 && isOmittable e2
+isOmittable _ = False
+
+isErrOmittable Update {} = True
+isErrOmittable (e1 :>>= _ :-> e2) = isErrOmittable e1 && isErrOmittable e2
+isErrOmittable (Case x ds) = all isErrOmittable [ e | _ :-> e <- ds ]
+isErrOmittable x = isOmittable x
+
+
hunk ./Grin/Optimize.hs 4
-import qualified Data.Set as Set
hunk ./Grin/Optimize.hs 5
-import List
hunk ./Grin/Optimize.hs 6
+import List
+import qualified Data.Set as Set
hunk ./Grin/Optimize.hs 9
+import Atom
+import C.Prims
hunk ./Grin/Optimize.hs 12
+import Grin.Noodle
hunk ./Grin/Optimize.hs 14
-import C.Prims
-import Support.FreeVars
hunk ./Grin/Optimize.hs 15
+import Support.CanType
+import Support.FreeVars
hunk ./Grin/Optimize.hs 19
-import Atom
-import Support.CanType
hunk ./Grin/Optimize.hs 110
-isOmittable (Fetch {}) = True
-isOmittable (Return {}) = True
-isOmittable (Store (NodeC n _)) | isMutableNodeTag n || n == tagHole = False
-isOmittable (Store {}) = True
-isOmittable Prim { expPrimitive = Primitive { primAPrim = aprim } } = aprimIsCheap aprim
-isOmittable (Case x ds) = all isOmittable [ e | _ :-> e <- ds ]
-isOmittable Let { expBody = x } = isOmittable x
-isOmittable (e1 :>>= _ :-> e2) = isOmittable e1 && isOmittable e2
-isOmittable _ = False
hunk ./Grin/PointsToAnalysis.hs 16
-import Support.CanType
hunk ./Grin/PointsToAnalysis.hs 24
-import Grin.Show()
hunk ./Grin/PointsToAnalysis.hs 25
+import Grin.Noodle
+import Grin.Show()
hunk ./Grin/PointsToAnalysis.hs 28
-import qualified Doc.Chars as U
-import qualified FlagDump as FD
-import Util.UniqueMonad
-import Util.Once
hunk ./Grin/PointsToAnalysis.hs 29
-import Util.SameShape
+import Support.CanType
hunk ./Grin/PointsToAnalysis.hs 31
+import Util.Once
+import Util.SameShape
+import Util.UniqueMonad
+import qualified Doc.Chars as U
+import qualified FlagDump as FD
hunk ./Grin/Show.hs 29
+import Grin.Noodle
hunk ./Grin/Simplify.hs 15
-import Support.FreeVars
hunk ./Grin/Simplify.hs 17
+import Grin.Noodle
hunk ./Grin/Simplify.hs 22
+import Support.FreeVars
hunk ./Grin/Simplify.hs 54
-valIsMutable (NodeC t _) = isMutableNodeTag t
-valIsMutable _ = False
hunk ./Grin/Simplify.hs 223
-isManifestNode :: Monad m => Exp -> m [Atom]
-isManifestNode (Return (Tag t)) = return [t]
-isManifestNode (Return (NodeC t _)) = return [t]
-isManifestNode Error {} = return []
-isManifestNode (Case _ ls) = do
-    cs <- Prelude.mapM isManifestNode [ e | _ :-> e <- ls ]
-    return $ concat cs
-isManifestNode (_ :>>= _ :-> e) = isManifestNode e
-isManifestNode _ = fail "not manifest node"
hunk ./Grin/Simplify.hs 477
-isOmittable (Fetch {}) = True
-isOmittable (Return {}) = True
-isOmittable (Store {}) = True
-isOmittable Prim { expPrimitive = Primitive { primAPrim = aprim } } = aprimIsCheap aprim
-isOmittable (Case x ds) = all isOmittable [ e | _ :-> e <- ds ]
-isOmittable (e1 :>>= _ :-> e2) = isOmittable e1 && isOmittable e2
-isOmittable _ = False
-
-isErrOmittable Update {} = True
-isErrOmittable (e1 :>>= _ :-> e2) = isErrOmittable e1 && isErrOmittable e2
-isErrOmittable (Case x ds) = all isErrOmittable [ e | _ :-> e <- ds ]
-isErrOmittable x = isOmittable x