[make freeVars take rules into account by default. Move a bunch of code around. move E binary stuff to E.Binary
John Meacham <john@repetae.net>**20061127040207] addfile ./E/Binary.hs
hunk ./DataConstructors.hs 40
+import E.Binary()
hunk ./E/Binary.hs 1
+module E.Binary() where
+
+import E.Type
+import {-# SOURCE #-} Info.Binary(putInfo,getInfo)
+import Binary
+import Atom
+import Monad
+
+{-!derive: is !-}
+
+-- Binary instance
+data TvrBinary = TvrBinaryNone | TvrBinaryAtom Atom | TvrBinaryInt Int
+
+instance Binary TVr where
+    put_ bh (TVr { tvrIdent = 0, tvrType =  e, tvrInfo = nf} ) = do
+        put_ bh (TvrBinaryNone)
+        put_ bh e
+        putInfo bh nf
+    put_ bh (TVr { tvrIdent = i, tvrType =  e, tvrInfo = nf}) | Just x <- intToAtom i = do
+        put_ bh (TvrBinaryAtom x)
+        put_ bh e
+        putInfo bh nf
+    put_ bh (TVr { tvrIdent = i, tvrType =  e, tvrInfo = nf}) = do
+        unless (even i) $ fail "number not even"
+        put_ bh (TvrBinaryInt i)
+        put_ bh e
+        putInfo bh nf
+    get bh = do
+        (x ) <- get bh
+        e <- get bh
+        nf <- getInfo bh
+        case x of
+            TvrBinaryNone -> return $ TVr 0 e nf
+            TvrBinaryAtom a -> return $ TVr (atomIndex a) e nf
+            TvrBinaryInt i -> return $ TVr (i) e nf
+
+
+instance Binary RuleType where
+    put_ bh RuleSpecialization = do
+	    putByte bh 0
+    put_ bh RuleUser = do
+	    putByte bh 1
+    put_ bh RuleCatalyst = do
+	    putByte bh 2
+    get bh = do
+	    h <- getByte bh
+	    case h of
+	      0 -> do
+		    return RuleSpecialization
+	      1 -> do
+		    return RuleUser
+	      2 -> do
+		    return RuleCatalyst
+	      _ -> fail "invalid binary data found"
+
+instance Binary Rule where
+    put_ bh (Rule aa ab ac ad ae af ag ah) = do
+	    put_ bh aa
+	    put_ bh ab
+	    put_ bh ac
+	    put_ bh ad
+	    put_ bh ae
+	    put_ bh af
+	    put_ bh ag
+	    put_ bh ah
+    get bh = do
+    aa <- get bh
+    ab <- get bh
+    ac <- get bh
+    ad <- get bh
+    ae <- get bh
+    af <- get bh
+    ag <- get bh
+    ah <- get bh
+    return (Rule aa ab ac ad ae af ag ah)
+
+instance (Binary e,Binary t) => Binary (Lit e t) where
+    put_ bh (LitInt aa ab) = do
+	    putByte bh 0
+	    put_ bh aa
+	    put_ bh ab
+    put_ bh (LitCons ac ad ae af) = do
+	    putByte bh 1
+	    put_ bh ac
+	    put_ bh ad
+	    put_ bh ae
+	    put_ bh af
+    get bh = do
+	    h <- getByte bh
+	    case h of
+	      0 -> do
+		    aa <- get bh
+		    ab <- get bh
+		    return (LitInt aa ab)
+	      1 -> do
+		    ac <- get bh
+		    ad <- get bh
+		    ae <- get bh
+		    af <- get bh
+		    return (LitCons ac ad ae af)
+	      _ -> fail "invalid binary data found"
+
+
+instance Binary ESort where
+    put_ bh EStar = do
+	    putByte bh 0
+    put_ bh EBang = do
+	    putByte bh 1
+    put_ bh EHash = do
+	    putByte bh 2
+    put_ bh ETuple = do
+	    putByte bh 3
+    put_ bh EHashHash = do
+	    putByte bh 4
+    put_ bh EStarStar = do
+	    putByte bh 5
+    put_ bh (ESortNamed aa) = do
+	    putByte bh 6
+	    put_ bh aa
+    get bh = do
+	    h <- getByte bh
+	    case h of
+	      0 -> do
+		    return EStar
+	      1 -> do
+		    return EBang
+	      2 -> do
+		    return EHash
+	      3 -> do
+		    return ETuple
+	      4 -> do
+		    return EHashHash
+	      5 -> do
+		    return EStarStar
+	      6 -> do
+		    aa <- get bh
+		    return (ESortNamed aa)
+	      _ -> fail "invalid binary data found"
+
+
+instance Binary E where
+    put_ bh (EAp aa ab) = do
+	    putByte bh 0
+	    put_ bh aa
+	    put_ bh ab
+    put_ bh (ELam ac ad) = do
+	    putByte bh 1
+	    put_ bh ac
+	    put_ bh ad
+    put_ bh (EPi ae af) = do
+	    putByte bh 2
+	    put_ bh ae
+	    put_ bh af
+    put_ bh (EVar ag) = do
+	    putByte bh 3
+	    put_ bh ag
+    put_ bh Unknown = do
+	    putByte bh 4
+    put_ bh (ESort ah) = do
+	    putByte bh 5
+	    put_ bh ah
+    put_ bh (ELit ai) = do
+	    putByte bh 6
+	    put_ bh ai
+    put_ bh (ELetRec aj ak) = do
+	    putByte bh 7
+	    put_ bh aj
+	    put_ bh ak
+    put_ bh (EPrim al am an) = do
+	    putByte bh 8
+	    put_ bh al
+	    put_ bh am
+	    put_ bh an
+    put_ bh (EError ao ap) = do
+	    putByte bh 9
+	    put_ bh ao
+	    put_ bh ap
+    put_ bh (ECase aq ar as at au) = do
+	    putByte bh 10
+	    put_ bh aq
+	    put_ bh ar
+	    put_ bh as
+	    put_ bh at
+	    put_ bh au
+    get bh = do
+	    h <- getByte bh
+	    case h of
+	      0 -> do
+		    aa <- get bh
+		    ab <- get bh
+		    return (EAp aa ab)
+	      1 -> do
+		    ac <- get bh
+		    ad <- get bh
+		    return (ELam ac ad)
+	      2 -> do
+		    ae <- get bh
+		    af <- get bh
+		    return (EPi ae af)
+	      3 -> do
+		    ag <- get bh
+		    return (EVar ag)
+	      4 -> do
+		    return Unknown
+	      5 -> do
+		    ah <- get bh
+		    return (ESort ah)
+	      6 -> do
+		    ai <- get bh
+		    return (ELit ai)
+	      7 -> do
+		    aj <- get bh
+		    ak <- get bh
+		    return (ELetRec aj ak)
+	      8 -> do
+		    al <- get bh
+		    am <- get bh
+		    an <- get bh
+		    return (EPrim al am an)
+	      9 -> do
+		    ao <- get bh
+		    ap <- get bh
+		    return (EError ao ap)
+	      10 -> do
+		    aq <- get bh
+		    ar <- get bh
+		    as <- get bh
+		    at <- get bh
+		    au <- get bh
+		    return (ECase aq ar as at au)
+	      _ -> fail "invalid binary data found"
+
+
+instance (Binary e) => Binary (Alt e) where
+    put_ bh (Alt aa ab) = do
+	    put_ bh aa
+	    put_ bh ab
+    get bh = do
+    aa <- get bh
+    ab <- get bh
+    return (Alt aa ab)
+
+instance Binary TvrBinary where
+    put_ bh TvrBinaryNone = do
+	    putByte bh 0
+    put_ bh (TvrBinaryAtom aa) = do
+	    putByte bh 1
+	    put_ bh aa
+    put_ bh (TvrBinaryInt ab) = do
+	    putByte bh 2
+	    put_ bh ab
+    get bh = do
+	    h <- getByte bh
+	    case h of
+	      0 -> do
+		    return TvrBinaryNone
+	      1 -> do
+		    aa <- get bh
+		    return (TvrBinaryAtom aa)
+	      2 -> do
+		    ab <- get bh
+		    return (TvrBinaryInt ab)
+	      _ -> fail "invalid binary data found"
+
+--  Imported from other files :-
hunk ./E/CPR.hs 83
-cprAnalyzeBinds dataTable env bs = f env  (decomposeDefns bs) [] where
+cprAnalyzeBinds dataTable env bs = f env  (decomposeDs bs) [] where
hunk ./E/E.hs 2
-module E.E(module E.Type, module E.E) where
+module E.E(module E.Type, module E.E, module E.FreeVars) where
hunk ./E/E.hs 11
+import E.FreeVars
hunk ./E/E.hs 26
-
-
-litCons = LitCons { litName = error "litName: name not set", litArgs = [], litType = error "litCons: type not set", litAliasFor = Nothing }
-
-
-
--- | extract out EAp nodes a value and the arguments it is applied to.
-fromAp :: E -> (E,[E])
-fromAp e = f [] e where
-    f as (EAp e a) = f (a:as) e
-    f as e  =  (e,as)
-
--- | deconstruct EPi terms, getting function argument types.
-
-fromPi :: E -> (E,[TVr])
-fromPi e = f [] e where
-    f as (EPi v e) = f (v:as) e
-    f as e  =  (e,reverse as)
-
--- | deconstruct ELam term.
-
-fromLam :: E -> (E,[TVr])
-fromLam e = f [] e where
-    f as (ELam v e) = f (v:as) e
-    f as e  =  (e,reverse as)
-
-
-tVr x y = tvr { tvrIdent = x, tvrType = y }
-tvr = TVr { tvrIdent = 0, tvrType = Unknown, tvrInfo = mempty }
-
-
-
-altHead :: Alt E -> Lit () ()
-altHead (Alt l _) = litHead  l
-litHead :: Lit a b -> Lit () ()
-litHead (LitInt x _) = LitInt x ()
-litHead LitCons { litName = s, litAliasFor = af } = litCons { litName = s, litType = (), litAliasFor = af }
-
-litBinds (LitCons { litArgs = xs } ) = xs
-litBinds _ = []
-
-patToLitEE LitCons { litName = n, litArgs = [a,b], litType = t } | t == eStar, n == tc_Arrow = EPi (tVr 0 (EVar a)) (EVar b)
-patToLitEE LitCons { litName = n, litArgs = xs, litType = t, litAliasFor = af } = ELit $ LitCons { litName = n, litArgs = (map EVar xs), litType = t, litAliasFor = af }
-patToLitEE (LitInt x t) = ELit $ LitInt x t
-
-
-caseBodies :: E -> [E]
-caseBodies ec = [ b | Alt _ b <- eCaseAlts ec] ++ maybeToMonad (eCaseDefault ec)
-casePats ec =  [ p | Alt p _ <- eCaseAlts ec]
-caseBinds ec = eCaseBind ec : concat [ xs  | LitCons { litArgs = xs } <- casePats ec]
-
-
-
-
hunk ./E/E.hs 78
-eStar :: E
-eStar = ESort EStar
-
-eHash :: E
-eHash = ESort EHash
-
hunk ./E/E.hs 120
-    fromChar (ELit (LitCons { litName = dc, litArgs = [ELit (LitInt ch t)], litType = _ot })) | dc == dc_Char && t == tCharzh = return (chr $ fromIntegral ch)
+    fromChar (ELit LitCons { litName = dc, litArgs = [ELit (LitInt ch t)] }) | dc == dc_Char && t == tCharzh = return (chr $ fromIntegral ch)
hunk ./E/Eval.hs 37
-    eval' ELetRec { eDefs = ds, eBody = e } stack = eval' (f (decomposeDefns ds) e) stack where
+    eval' ELetRec { eDefs = ds, eBody = e } stack = eval' (f (decomposeDs ds) e) stack where
hunk ./E/FreeVars.hs 2
-module E.FreeVars(decomposeLet, decomposeDefns, freeIds) where
+module E.FreeVars(
+    decomposeLet,
+    decomposeDs,
+    bindingFreeVars,
+    freeIds
+    ) where
hunk ./E/FreeVars.hs 9
-import Data.Graph as G
hunk ./E/FreeVars.hs 10
-import E.E
+
+import E.Type
hunk ./E/FreeVars.hs 16
+import Util.Graph
+import qualified Info.Info as Info
hunk ./E/FreeVars.hs 52
-decomposeDefns :: [(TVr, E)] -> [Either (TVr, E) [(TVr,E)]]
-decomposeDefns bs = map f mp where
-    mp = G.stronglyConnComp [ (v,i,freeVars t `mappend` freeVars e) | v@(TVr i t _ ,e) <- bs]
-    f (AcyclicSCC v) = Left v
-    f (CyclicSCC vs) = Right vs
+decomposeDs :: [(TVr, E)] -> [Either (TVr, E) [(TVr,E)]]
+decomposeDs bs = scc g where
+    g = newGraph bs (tvrIdent . fst ) (toList . uncurry bindingFreeVars)
hunk ./E/FreeVars.hs 58
-decomposeLet ELetRec { eDefs = ds, eBody = e } = (decomposeDefns ds,e)
+decomposeLet ELetRec { eDefs = ds, eBody = e } = (decomposeDs ds,e)
hunk ./E/FreeVars.hs 66
-    --fv (EVar tvr@TVr { tvrIdent = i, tvrType = t }) = insert i (fv t)
-    fv (EVar tvr@TVr { tvrIdent = i, tvrType = t }) = singleton i
+    fv (EVar tvr@TVr { tvrIdent = i }) = singleton i <> freeVarsInfo (tvrInfo tvr)
hunk ./E/FreeVars.hs 71
-            map (\(tvr@(TVr { tvrIdent = j, tvrType =  t}),y) -> (j, fv t, fv y)) dl
+            map (\(tvr@(TVr { tvrIdent = j }),y) -> (j, freeVars tvr, fv y)) dl
hunk ./E/FreeVars.hs 87
-    --fv (EVar tvr@TVr { tvrIdent = i, tvrType = t }) = minsert i tvr (fv t)
-    fv (EVar tvr@TVr { tvrIdent = i, tvrType = t }) = msingleton i tvr
+    fv (EVar tvr@TVr { tvrIdent = i }) = msingleton i tvr
hunk ./E/FreeVars.hs 102
+-- | determine free variables of a binding site
+instance FreeVars TVr IdSet where
+    freeVars t = freeVars (tvrType t) `mappend` freeVarsInfo (tvrInfo t)
+
+-- | this determines all free variables of a definition taking rules into account
+bindingFreeVars :: TVr -> E -> IdSet
+bindingFreeVars t e = freeVars t `mappend` freeVars e
+
+freeVarsInfo nfo = maybe mempty freeVars (Info.lookup (Info.getInfo nfo) :: Maybe ARules)
+--instance FreeVars TVr (IdMap TVr) where
+--    freeVars t = freeVars (tvrType t) `mappend` freeVars (Info.fetch (tvrInfo t) :: ARules)
+
hunk ./E/FreeVars.hs 115
+instance FreeVars ARules IdSet where
+    freeVars a = aruleFreeVars a
hunk ./E/FreeVars.hs 118
+instance FreeVars Rule IdSet where
+    freeVars rule = freeVars (ruleBody rule) S.\\ fromList (map tvrIdent $ ruleBinds rule)
+instance FreeVars Rule (IdMap TVr) where
+    freeVars rule = freeVars (ruleBody rule) S.\\ fromList [ (tvrIdent t,t) | t <- ruleBinds rule]
hunk ./E/Inline.hs 9
-    baseInlinability,
-    decomposeDs
+    baseInlinability
hunk ./E/Inline.hs 130
-decomposeDs :: [(TVr, E)] -> [Either (TVr, E) [(TVr,E)]]
-decomposeDs bs = scc g where
-    g = newGraph bs (tvrIdent . fst ) (toList . uncurry bindingFreeVars)
-    --mp = G.stronglyConnComp [ (v,i, idSetToList $ bindingFreeVars t e) | v@(t@TVr { tvrIdent = i },e) <- bs]
-    --f (G.AcyclicSCC v) = Left v
-    --f (G.CyclicSCC vs) = Right vs
hunk ./E/Rules.hs 8
-    bindingFreeVars,
hunk ./E/Rules.hs 37
+import E.Binary()
hunk ./E/Rules.hs 109
-instance FreeVars ARules IdSet where
-    freeVars a = aruleFreeVars a
-
-instance FreeVars Rule IdSet where
-    freeVars rule = freeVars (ruleBody rule) S.\\ fromList (map tvrIdent $ ruleBinds rule)
-instance FreeVars Rule (IdMap TVr) where
-    freeVars rule = freeVars (ruleBody rule) S.\\ fromList [ (tvrIdent t,t) | t <- ruleBinds rule]
hunk ./E/Rules.hs 261
--- | this determines all free variables of a definition taking rules into account
-bindingFreeVars :: TVr -> E -> IdSet
-bindingFreeVars t e = freeVars (tvrType t) `mappend` freeVars e `mappend` freeVars (Info.fetch (tvrInfo t) :: ARules)
hunk ./E/Traverse.hs 18
-import E.E
+import E.Type
hunk ./E/Type.hs 4
+import Maybe
hunk ./E/Type.hs 9
-import Binary
hunk ./E/Type.hs 13
+import Util.Gen
hunk ./E/Type.hs 15
+import Name.Names
hunk ./E/Type.hs 22
- {-! derive: GhcBinary !-}
hunk ./E/Type.hs 35
- {-! derive: GhcBinary !-}
hunk ./E/Type.hs 45
-        {-!derive: is, GhcBinary !-}
+        {-!derive: is !-}
hunk ./E/Type.hs 65
-    {-! derive: is, GhcBinary !-}
+    {-! derive: is !-}
hunk ./E/Type.hs 86
-    {-! derive: is, from, GhcBinary !-}
+    {-! derive: is, from !-}
hunk ./E/Type.hs 123
-       {-!derive: GhcBinary !-}
hunk ./E/Type.hs 144
--- Binary instance
-data TvrBinary = TvrBinaryNone | TvrBinaryAtom Atom | TvrBinaryInt Int
-    {-! derive: GhcBinary !-}
hunk ./E/Type.hs 145
-instance Binary TVr where
-    put_ bh (TVr { tvrIdent = 0, tvrType =  e, tvrInfo = nf} ) = do
-        put_ bh (TvrBinaryNone)
-        put_ bh e
-        putInfo bh nf
-    put_ bh (TVr { tvrIdent = i, tvrType =  e, tvrInfo = nf}) | Just x <- intToAtom i = do
-        put_ bh (TvrBinaryAtom x)
-        put_ bh e
-        putInfo bh nf
-    put_ bh (TVr { tvrIdent = i, tvrType =  e, tvrInfo = nf}) = do
-        unless (even i) $ fail "number not even"
-        put_ bh (TvrBinaryInt i)
-        put_ bh e
-        putInfo bh nf
-    get bh = do
-        (x ) <- get bh
-        e <- get bh
-        nf <- getInfo bh
-        case x of
-            TvrBinaryNone -> return $ TVr 0 e nf
-            TvrBinaryAtom a -> return $ TVr (atomIndex a) e nf
-            TvrBinaryInt i -> return $ TVr (i) e nf
+-- simple querying routines
+altHead :: Alt E -> Lit () ()
+altHead (Alt l _) = litHead  l
+
+litHead :: Lit a b -> Lit () ()
+litHead (LitInt x _) = LitInt x ()
+litHead LitCons { litName = s, litAliasFor = af } = litCons { litName = s, litType = (), litAliasFor = af }
+
+litBinds (LitCons { litArgs = xs } ) = xs
+litBinds _ = []
+
+patToLitEE LitCons { litName = n, litArgs = [a,b], litType = t } | t == eStar, n == tc_Arrow = EPi (tVr 0 (EVar a)) (EVar b)
+patToLitEE LitCons { litName = n, litArgs = xs, litType = t, litAliasFor = af } = ELit $ LitCons { litName = n, litArgs = (map EVar xs), litType = t, litAliasFor = af }
+patToLitEE (LitInt x t) = ELit $ LitInt x t
+
+caseBodies :: E -> [E]
+caseBodies ec = [ b | Alt _ b <- eCaseAlts ec] ++ maybeToMonad (eCaseDefault ec)
+casePats ec =  [ p | Alt p _ <- eCaseAlts ec]
+caseBinds ec = eCaseBind ec : concat [ xs  | LitCons { litArgs = xs } <- casePats ec]
+
+
+-- | extract out EAp nodes a value and the arguments it is applied to.
+fromAp :: E -> (E,[E])
+fromAp e = f [] e where
+    f as (EAp e a) = f (a:as) e
+    f as e  =  (e,as)
+
+-- | deconstruct EPi terms, getting function argument types.
+
+fromPi :: E -> (E,[TVr])
+fromPi e = f [] e where
+    f as (EPi v e) = f (v:as) e
+    f as e  =  (e,reverse as)
+
+-- | deconstruct ELam term.
+
+fromLam :: E -> (E,[TVr])
+fromLam e = f [] e where
+    f as (ELam v e) = f (v:as) e
+    f as e  =  (e,reverse as)
+
+
+litCons = LitCons { litName = error "litName: name not set", litArgs = [], litType = error "litCons: type not set", litAliasFor = Nothing }
+
+-----------------
+-- E constructors
+-----------------
+
+eStar :: E
+eStar = ESort EStar
+
+eHash :: E
+eHash = ESort EHash
+
+tVr x y = tvr { tvrIdent = x, tvrType = y }
+tvr = TVr { tvrIdent = 0, tvrType = Unknown, tvrInfo = Info.empty }
hunk ./Grin/FromE.hs 585
-    doLet ds e = f (decomposeDefns ds) e where
+    doLet ds e = f (decomposeDs ds) e where