[added fields to TyEnv to include siblings of constructors
John Meacham <john@repetae.net>**20070227140735] hunk ./C/FromGrin2.hs 47
---    wCAFS :: [Doc],
hunk ./C/FromGrin2.hs 81
-    --ans = vcat $ includes ++ [text "", enum_tag_t, header, text "/* CAFS */", vcat cafs,buildConstants finalHcHash, body]
hunk ./C/FromGrin2.hs 89
-        --cs <- mapM doCAF (grinCafs grin)
-        --tell mempty { wCAFS = cs }
hunk ./C/FromGrin2.hs 96
-
-
hunk ./C/FromGrin2.hs 102
-            mmalloc (TyPtr _) = [Attribute "A_MALLOC"]
-            mmalloc TyNode = [Attribute "A_MALLOC"]
+            mmalloc (TyPtr _) = [a_MALLOC]
+            mmalloc TyNode = [a_MALLOC]
hunk ./C/FromGrin2.hs 105
-            ats = (if isNothing ffie then Attribute "A_STD" else Public):mmalloc bt
+            ats = (if isNothing ffie then a_STD else Public):mmalloc bt
hunk ./C/FromGrin2.hs 243
-        scrut' = (if t `elem` ptrs then cast (basicType "uintptr_t") scrut else scrut)
+        scrut' = (if t `elem` ptrs then cast uintptr_t scrut else scrut)
hunk ./C/FromGrin2.hs 276
-        scrut' = (if t `elem` ptrs then cast (basicType "uintptr_t") scrut else scrut)
+        scrut' = (if t `elem` ptrs then cast uintptr_t scrut else scrut)
hunk ./C/FromGrin2.hs 294
-    (ss,er) <- convertExp e -- lift $  runSubCGen $ cexp e
+    (ss,er) <- convertExp e
hunk ./C/FromGrin2.hs 337
-    return (mempty,(functionCall (name "fetch") [v]))
+    return (mempty,f_fetch v)
hunk ./C/FromGrin2.hs 348
-    return (mempty,(functionCall (name "eval") [v']))
+    return (mempty,f_eval v')
hunk ./C/FromGrin2.hs 514
-    tellFunctions [function fname wptr_t [(aname,atype)] [Attribute "A_STD"] (body & update & creturn rvar )]
+    tellFunctions [function fname wptr_t [(aname,atype)] [a_STD] (body & update & creturn rvar )]
hunk ./C/FromGrin2.hs 555
-f_assert e = expr $ functionCall (name "assert") [e]
-f_DETAG e = functionCall (name "DETAG") [e]
-f_NODEP e = functionCall (name "NODEP") [e]
-f_EVALTAG e = functionCall (name "EVALTAG") [e]
-f_update x y = functionCall (name "update") [x,y]
+f_assert e    = functionCall (name "assert") [e]
+f_DETAG e     = functionCall (name "DETAG") [e]
+f_NODEP e     = functionCall (name "NODEP") [e]
+f_EVALTAG e   = functionCall (name "EVALTAG") [e]
+f_eval e      = functionCall (name "eval") [e]
+f_fetch e     = functionCall (name "fetch") [e]
+f_update x y  = functionCall (name "update") [x,y]
hunk ./C/FromGrin2.hs 563
-profile_update_inc = expr $ functionCall (name "update_inc") []
-profile_case_inc = expr $ functionCall (name "case_inc") []
+profile_update_inc   = expr $ functionCall (name "update_inc") []
+profile_case_inc     = expr $ functionCall (name "case_inc") []
hunk ./C/FromGrin2.hs 578
-sptr_t = basicType "sptr_t"
-wptr_t = basicType "wptr_t"
-size_t = basicType "size_t"
-tag_t = basicType "tag_t"
+sptr_t    = basicType "sptr_t"
+wptr_t    = basicType "wptr_t"
+size_t    = basicType "size_t"
+tag_t     = basicType "tag_t"
+uintptr_t = basicType "uintptr_t"
+
+a_STD = Attribute "A_STD"
+a_MALLOC = Attribute "A_MALLOC"
hunk ./DataConstructors.hs 131
-    conName      :: Name,        -- name of constructor
+    conName      :: Name,         -- name of constructor
hunk ./DataConstructors.hs 134
-    conOrigSlots :: [Slot],      -- original slots
+    conOrigSlots :: [Slot],       -- original slots
hunk ./DataConstructors.hs 137
-    conInhabits  :: Name,        -- what constructor it inhabits, similar to conType, but not quite.
+    conInhabits  :: Name,         -- what constructor it inhabits, similar to conType, but not quite.
hunk ./Grin/DeadCode.hs 72
-    mp' <- flip mconcatMapM (Map.toList mp) $ \ (x,(ts,rt)) -> case Just x  of
+    mp' <- flip mconcatMapM (Map.toList mp) $ \ (x,tyty@TyTy { tySlots = ts }) -> case Just x  of
hunk ./Grin/DeadCode.hs 79
-            return [(x,(ts',rt))]
-        _ -> return [(x,(ts,rt))]
+            return [(x,tyty { tySlots = ts' })]
+        _ -> return [(x,tyty)]
hunk ./Grin/EvalInline.hs 157
-        cf ((targ,tret),name) = ((name,appBody),(name,([TyNode,targ],tret))) where
+        cf ((targ,tret),name) = ((name,appBody),(name,tyTy { tySlots = [TyNode,targ],tyReturn = tret })) where
hunk ./Grin/FromE.hs 110
-dumpTyEnv (TyEnv tt) = mapM_ putStrLn $ sort [ fromAtom n <+> hsep (map show as) <+> "::" <+> show t |  (n,(as,t)) <- Map.toList tt]
+dumpTyEnv (TyEnv tt) = mapM_ putStrLn $ sort [ fromAtom n <+> hsep (map show as) <+> "::" <+> show t <> f z |  (n,TyTy { tySlots = as, tyReturn = t, tySiblings = z }) <- Map.toList tt] where
+    f Nothing = mempty
+    f (Just v) = text " " <> tshow v
hunk ./Grin/FromE.hs 155
+toTyTy (as,r) = tyTy { tySlots = as, tyReturn = r }
+
+
hunk ./Grin/FromE.hs 218
-    let newTyEnv = TyEnv $ Map.fromList (concatMap makePartials (Map.toList endTyEnv) ++ [(funcMain, ([],tyUnit))] ++ [(en, ([],tyUnit)) | en <- enames])
+    let newTyEnv = TyEnv $ Map.fromList (concatMap makePartials (Map.toList endTyEnv) ++ [(funcMain, toTyTy ([],tyUnit))] ++ [(en, toTyTy ([],tyUnit)) | en <- enames])
hunk ./Grin/FromE.hs 246
-    initTyEnv = mappend primTyEnv $ TyEnv $ Map.fromList $ [ (a,(b,c)) | (_,(a,b,c)) <-  Map.toList scMap] ++ concat [con x| x <- Map.elems $ constructorMap dataTable, conType x /= eHash]
-    con c | (EPi (TVr { tvrType = a }) b,_) <- fromLam $ conExpr c = return (tagArrow,([TyPtr TyNode, TyPtr TyNode],TyNode))
-    con c | keepIt = return (n,(as,TyNode)) where
+    initTyEnv = mappend primTyEnv $ TyEnv $ Map.fromList $ [ (a,toTyTy (b,c)) | (_,(a,b,c)) <-  Map.toList scMap] ++ concat [con x| x <- Map.elems $ constructorMap dataTable, conType x /= eHash]
+    con c | (EPi (TVr { tvrType = a }) b,_) <- fromLam $ conExpr c = return $ (tagArrow,toTyTy ([TyPtr TyNode, TyPtr TyNode],TyNode))
+    con c | keepIt = return $ (n,toTyTy (as,TyNode)) where
hunk ./Grin/FromE.hs 271
-makePartials (fn,(ts,rt)) | tagIsFunction fn, head (show fn) /= '@'  = (fn,(ts,rt)):[(partialTag fn i,(reverse $ drop i $ reverse ts ,TyNode)) |  i <- [0.. end] ]  where
+makePartials (fn,TyTy { tySlots = ts, tyReturn = rt }) | tagIsFunction fn, head (show fn) /= '@'  = (fn,toTyTy (ts,rt)):[(partialTag fn i,toTyTy (reverse $ drop i $ reverse ts ,TyNode)) |  i <- [0.. end] ]  where
hunk ./Grin/FromE.hs 276
-primTyEnv = TyEnv . Map.fromList $ [
+primTyEnv = TyEnv . Map.map toTyTy $ Map.fromList $ [
hunk ./Grin/FromE.hs 283
-    ] ++ [ (toAtom ('C':show dc), ([Ty $ toAtom y],TyNode)) | (dc,tc,_,y,_) <- allCTypes, y /= "void" ]
+    ]
hunk ./Grin/FromE.hs 582
-        let addt (TyEnv mp) =  TyEnv $ Map.insert n (map getType args,getType body) mp
+        let addt (TyEnv mp) =  TyEnv $ Map.insert n (toTyTy (map getType args,getType body)) mp
hunk ./Grin/Grin.hs 20
+    TyTy(..),
+    tyTy,
hunk ./Grin/Grin.hs 94
-newtype TyEnv = TyEnv (Map.Map Atom ([Ty],Ty))
+data TyTy = TyTy {
+    tySlots :: [Ty],
+    tyReturn :: Ty,
+    tySiblings :: Maybe [Atom]
+}
+
+tyTy = TyTy { tySlots = [], tyReturn = TyUnknown, tySiblings = Nothing }
+
+newtype TyEnv = TyEnv (Map.Map Atom TyTy)
hunk ./Grin/Grin.hs 230
-    xs = [ (funcDefName d,funcType $ funcDefProps d) |  d <- ds]
+    xs = [ (funcDefName d,tyTy { tySlots = ss, tyReturn = r }) |  d <- ds, let (ss,r) = funcType $ funcDefProps d]
hunk ./Grin/Grin.hs 447
-findArgsType (TyEnv m) a | Just x <-  Map.lookup a m = return x
+findArgsType (TyEnv m) a | Just TyTy { tySlots = ss, tyReturn = r } <-  Map.lookup a m = return (ss,r)
hunk ./Grin/Grin.hs 449
-    Just (ts,n) -> return (take (length ts - read ns) ts,n)
+    Just TyTy { tySlots = ts, tyReturn = n } -> return (take (length ts - read ns) ts,n)
hunk ./Grin/Grin.hs 456
-    Just (_,x) -> return x
+    Just TyTy { tyReturn = x }-> return x
hunk ./Grin/Unboxing.hs 87
-        retTe fn (ts,_) | Just (_,_,ret,_) <- Map.lookup fn fns = (ts,ret)
+        retTe fn tyty | Just (_,_,ret,_) <- Map.lookup fn fns = tyty { tyReturn = ret }
hunk ./Main.hs 1047
-dumpTyEnv (TyEnv tt) = mapM_ putStrLn $ sort [ show n <+> hsep (map show as) <+> "::" <+> show t |  (n,(as,t)) <- Map.toList tt]
+dumpTyEnv (TyEnv tt) = mapM_ putStrLn $ sort [ show n <+> hsep (map show as) <+> "::" <+> show t |  (n,TyTy { tySlots = as, tyReturn = t }) <- Map.toList tt]