[more changes to Grin implementation
John Meacham <john@repetae.net>**20060813082719] hunk ./Grin/Grin.hs 4
+    Callable(..),
hunk ./Grin/Grin.hs 6
+    FuncDef(..),
+    FuncProps(..),
hunk ./Grin/Grin.hs 21
+    combineItems,
hunk ./Grin/Grin.hs 33
-    isMutableNodeTag,
hunk ./Grin/Grin.hs 34
+    isMutableNodeTag,
+    isVar,isTup,modifyTail,valIsConstant,
+    itemTag,
+    mapBodyM,
+    mapExpExp,
hunk ./Grin/Grin.hs 47
-    valToItem,
hunk ./Grin/Grin.hs 55
-    combineItems,
hunk ./Grin/Grin.hs 56
-    mapBodyM,
-    mapExpExp,
-    itemTag,
hunk ./Grin/Grin.hs 57
-    isVar,isTup,modifyTail,valIsConstant,
+    valToItem,
hunk ./Grin/Grin.hs 81
+import Util.Perhaps
hunk ./Grin/Grin.hs 114
-    deriving(Eq,Ord)
+    deriving(Eq,Ord,Show)
hunk ./Grin/Grin.hs 116
-data Ty =
-    TyTag                      -- ^ a lone tag
-    | TyPtr Ty                 -- ^ pointer to a heap location which contains its argument
-    | TyNode                   -- ^ a whole tagged node
-    | Ty Atom                  -- ^ a basic type
-    | TyTup [Ty]               -- ^ unboxed list of values
-    | TyCall Callable [Ty] Ty  -- ^ something call,jump, or cut-to-able
-    | TyRegion                 -- ^ a region
-    | TyUnknown                -- ^ an unknown possibly undefined type, All of these must be eliminated by code generation
-    deriving(Eq,Ord)
-
-instance Show Ty where
-    show TyTag = "T"
-    show (Ty a) = fromAtom a
-    show TyNode = "N"
-    show (TyPtr t) = '&':show t
-    show (TyTup []) = "()"
-    show (TyTup ts) =  show ts
-    show TyUnknown = "?"
hunk ./Grin/Grin.hs 151
+    | Error     { expError :: String, expType :: Ty }                     -- ^ Abort with an error message, non recoverably.
hunk ./Grin/Grin.hs 156
+                  expFuncProps :: FuncProps,
hunk ./Grin/Grin.hs 163
-    | Let       { expDefs :: [(Atom,Lam)], expInfo :: Info.Info }         -- ^ A let of local functions
+    | Let       { expDefs :: [(Atom,Lam)],
+                  expBody :: Exp,
+                  expInfo :: Info.Info }                                  -- ^ A let of local functions
hunk ./Grin/Grin.hs 171
-    | MkCont    { expLam :: Lam, expInfo :: Info.Info }                   -- ^ Make a continuation, always alloced on smallest enclosing region
-    | Error     { expError :: String, expType :: Ty }                     -- ^ Abort with an error message, non recoverably.
+    | MkCont    { expCont :: Lam,                          -- ^ the continuation routine
+                  expRest :: Lam,                          -- ^ the computation that is passed the newly created computation
+                  expInfo :: Info.Info }                   -- ^ Make a continuation, always allocated on region encompasing expRest
hunk ./Grin/Grin.hs 190
+data Ty =
+    TyTag                      -- ^ a lone tag
+    | TyPtr Ty                 -- ^ pointer to a heap location which contains its argument
+    | TyNode                   -- ^ a whole tagged node
+    | Ty Atom                  -- ^ a basic type
+    | TyTup [Ty]               -- ^ unboxed list of values
+    | TyCall Callable [Ty] Ty  -- ^ something call,jump, or cut-to-able
+    | TyRegion                 -- ^ a region
+    | TyUnknown                -- ^ an unknown possibly undefined type, All of these must be eliminated by code generation
+    deriving(Eq,Ord)
+
+
+data FuncDef = FuncDef {
+    funcDefName  :: Atom,
+    funcDefBody  :: Lam,
+    funcDefCall  :: Val,
+    funcDefProps :: FuncProps
+    }
+
+createFuncDef local name body@(args :-> rest)  = FuncDef { funcDefName = name, funcDefBody = body, funcDefCall = call, funcDefProps = props } where
+    call = Item name (TyCall (if local then LocalFunction else Function) (map getType (fromTuple args)) (getType rest))
+    props = funcProps { funcFreeVars = freeVars body, funcTags = freeVars body }
+
+-- cached info
+data FuncProps = FuncProps {
+    funcInfo    :: Info.Info,
+    funcFreeVars :: Set.Set Var,
+    funcTags    :: Set.Set Tag,
+    funcExits   :: Perhaps,      -- ^ function quits the program
+    funcCuts    :: Perhaps,      -- ^ function cuts to a value
+    funcAllocs  :: Perhaps,      -- ^ function allocates memory
+    funcCreates :: Perhaps,      -- ^ function allocates memory and stores or returns it
+    funcLoops   :: Perhaps       -- ^ function may loop
+    }
+    deriving(Eq,Ord,Show)
+
+funcProps = FuncProps {
+    funcInfo = mempty,
+    funcFreeVars = mempty,
+    funcTags = mempty,
+    funcExits = Maybe,
+    funcCuts = Maybe,
+    funcAllocs = Maybe,
+    funcCreates = Maybe,
+    funcLoops = Maybe
+    }
+
+
+instance Show Ty where
+    show TyTag = "T"
+    show (Ty a) = fromAtom a
+    show TyNode = "N"
+    show (TyPtr t) = '&':show t
+    show (TyTup []) = "()"
+    show (TyTup ts) =  tupled (map show ts)
+    show TyRegion = "R"
+    show (TyCall c as rt) = show c <> tupled (map show as) <+> "->" <+> show rt
+    show TyUnknown = "?"
hunk ./Grin/Grin.hs 270
+    showsPrec _ (Item a  ty) = tshow a <> text "::" <> tshow ty
+    showsPrec _ (ValUnknown ty) = text "?::" <> tshow ty
hunk ./Grin/Grin.hs 320
-data Flag = No | Maybe | Yes
-    deriving(Eq,Ord,Enum,Show)
-
-
-instance Monoid Flag where
-    mempty = No
-    mappend a b = max a b
-    mconcat xs = maximum xs
-
hunk ./Grin/Grin.hs 321
-instance SemiBooleanAlgebra Flag where
-    (&&) = max
-    Yes || Yes = Yes
-    No || No = No
-    _ || _ = Maybe
hunk ./Grin/Grin.hs 562
+    getType NewRegion { expLam = _ :-> body } = getType body
+    getType Alloc { expValue = v } = TyPtr (getType v)
+    getType Let { expBody = body } = getType body
+    getType MkCont { expRest = _ :-> rbody } = getType rbody
+    getType Call { expType = ty } = ty
hunk ./Grin/Grin.hs 578
+    getType (ValUnknown ty) = ty
+    getType (Item _ ty) = ty
hunk ./Grin/Show.hs 87
+prettyExp vl NewRegion { expLam = (r :-> body)} = vl <> keyword "region" <+> text "\\" <> prettyVal r <+> text "-> do" <$> indent 2 (prettyExp empty body)
+--prettyExp vl MkCont { expCont = (r :-> body) } = vl <> keyword "continuation" <+> text "\\" <> prettyVal r <+> text "-> do" <$> indent 2 (prettyExp empty body)
+prettyExp vl Alloc { expValue = val, expCount = Lit n _, expRegion = r }| n == 1 = vl <> keyword "alloc" <+> prettyVal val <+> text "at" <+> prettyVal r
+prettyExp vl Alloc { expValue = val, expCount = count, expRegion = r } = vl <> keyword "alloc" <+> prettyVal val <> text "[" <> prettyVal count <> text "]" <+> text "at" <+> prettyVal r
+prettyExp vl Call { expValue = Item t (TyCall fun _ _), expArgs = vs, expJump = jump } | fun `elem` [Function,LocalFunction] =  vl <> f jump  <+> func (fromAtom t) <+> hsep (map prettyVal vs) where
+    f True = text "jump to"
+    f False = text "call"
+prettyExp vl Call { expValue = Var v (TyCall fun _ _), expArgs = vs, expJump = jump}  =  vl <> f jump fun  <+> color "lightgreen" (pprint v) <+> hsep (map prettyVal vs) where
+    f False Continuation = text "cut to"
+    f False Function = text "call"
+    f True Function = text "jump to"
+    f False Closure = text "enter"
+    f True Closure = text "jump into"
+prettyExp vl Call { expValue = ValPrim ap [] (TyCall Primitive' _ _), expArgs = vs } = vl <> prim (tshow ap) <+> hsep (map prettyVal vs)
hunk ./Grin/Show.hs 124
+prettyVal (ValUnknown ty) = text "?::" <> tshow ty
+prettyVal (Item a  ty) = tshow a <> text "::" <> tshow ty
hunk ./Grin/Val.hs 1
-module Grin.Val(FromVal(..),ToVal(..),tn_2Tup,world__,pworld__,valToList,convertName) where
+module Grin.Val(FromVal(..),ToVal(..),tn_2Tup,world__,pworld__,valToList,convertName,region_heap) where
hunk ./Grin/Val.hs 16
---tn_True  = convertName dc_True  -- toAtom "CPrelude.True"
---tn_False = convertName dc_False -- toAtom "CPrelude.False"
hunk ./Grin/Val.hs 19
+region_heap = Item (toAtom "heap") TyRegion
+