[for fgrin, don't generate tags for CPR types, just store the raw values directly
John Meacham <john@repetae.net>**20070228034353] hunk ./C/FromGrin.hs 476
-    (header,body) = generateC (functions) structs
+    (header,body) = generateC True functions structs
hunk ./C/FromGrin2.hs 47
+    wEnums :: Map.Map Name Int,
hunk ./C/FromGrin2.hs 81
-    ans = vcat $ includes ++ [text "", enum_tag_t, header, cafs,buildConstants finalHcHash, body]
+    ans = vcat $ includes ++ [text "", enum_tag_t, header, cafs,buildConstants (grinTypeEnv grin) finalHcHash, body]
hunk ./C/FromGrin2.hs 84
-    (header,body) = generateC (Map.elems fm) (Map.assocs sm)
-    ((),finalHcHash,Written { wRequires = req, wFunctions = fm, wStructures = sm, wTags = ts }) = runC grin go
-    enum_tag_t = text "enum {" $$ nest 4 (P.vcat (punctuate P.comma (zipWith f [0 ..] (tagHole:Set.toList ts)))) $$ text "};" where
-        f n t = tshow (nodeTagName t) <> text " = " <> tshow (n :: Int) -- (n * 4 + 2 :: Int)
-    tags = (tagHole,[]):sortUnder (show . fst) [ (t,runIdentity $ findArgs (grinTypeEnv grin) t) | t <- Set.toList ts, tagIsTag t]
+    (header,body) = generateC False (Map.elems fm) (Map.assocs sm)
+    ((),finalHcHash,Written { wRequires = req, wFunctions = fm, wEnums = wenum, wStructures = sm, wTags = ts }) = runC grin go
+    enum_tag_t = text "enum {" $$ nest 4 (P.vcat (punctuate P.comma $ map (uncurry g) (Map.toList wenum) ++ (zipWith f (Set.toList ts) [0 ..]))) $$ text "};" where
+        f t n = tshow (nodeTagName t) <> text " = " <> tshow (n :: Int)
+        g t n = tshow t <> text " = " <> tshow (n :: Int)
hunk ./C/FromGrin2.hs 96
-        tell mempty { wTags = tset }
+        mapM_ tellTags (Set.toList tset)
hunk ./C/FromGrin2.hs 140
-convertVal (Tag t) = do tell mempty { wTags = Set.singleton t } ; return $ constant (enum $ nodeTagName t)
+convertVal (Tag t) = do tellTags t ; return $ constant (enum $ nodeTagName t)
hunk ./C/FromGrin2.hs 217
-    tell mempty { wTags = Set.singleton t }
-    let tag = getTag scrut
+    tellTags t
+    let tag = getWhat scrut
hunk ./C/FromGrin2.hs 225
-            tell mempty { wTags = Set.singleton t }
+            tellTags t
hunk ./C/FromGrin2.hs 254
-    let tag = getTag scrut
+    let tag = getWhat scrut
hunk ./C/FromGrin2.hs 260
-            tell mempty { wTags = Set.singleton t }
+            tellTags t
hunk ./C/FromGrin2.hs 264
-            tell mempty { wTags = Set.singleton t }
+            tellTags t
hunk ./C/FromGrin2.hs 350
-convertExp (Store n@NodeC {}) = newNode n
-convertExp (Return n@NodeC {}) = newNode n
+convertExp (Store n@NodeC {})  = newNode n >>= \(x,y) -> return (x,cast sptr_t y)
+convertExp (Return n@NodeC {}) = newNode n >>= \(x,y) -> return (x,cast wptr_t y)
hunk ./C/FromGrin2.hs 354
-    return (mempty,n')
+    return (mempty,cast sptr_t n')
hunk ./C/FromGrin2.hs 374
-        return (nns & getTag (f_NODEP(f_DETAG v')) =* nn,emptyExpression)
+        return (nns & getHead (f_NODEP(f_DETAG v')) =* cast fptr_t nn,emptyExpression)
hunk ./C/FromGrin2.hs 376
-        s <- if tagIsSuspFunction t then do
-            en <- declareEvalFunc t
-            return $ getTag tmp' =* f_EVALTAG (reference (variable en))
-         else do
-            declareStruct t
-            tell mempty { wTags = Set.singleton t }
-            return $ getTag tmp' =* constant (enum (nodeTagName t))
+        s <- tagAssign tmp' t
hunk ./C/FromGrin2.hs 387
-buildConstants fh = P.vcat (map cc (Grin.HashConst.toList fh)) where
+buildConstants tyenv fh = P.vcat (map cc (Grin.HashConst.toList fh)) where
hunk ./C/FromGrin2.hs 390
-        cd = text "const static struct " <> tshow (nodeStructName a) <+> text "_c" <> tshow i <+> text "= {" <> hsep (punctuate P.comma (tshow (nodeTagName a):rs)) <> text "};"
+        cd = text "const static struct " <> tshow (nodeStructName a) <+> text "_c" <> tshow i <+> text "= {" <> hsep (punctuate P.comma (ntag ++ rs)) <> text "};"
+        Just TyTy { tySiblings = sibs } = findTyTy tyenv a
+        ntag = case sibs of
+            Just [a'] | a' == a -> []
+            _ -> [tshow (nodeTagName a)]
hunk ./C/FromGrin2.hs 456
+
+tagAssign :: Expression -> Atom -> C Statement
+tagAssign e t | tagIsSuspFunction t = do
+    en <- declareEvalFunc t
+    return $ getHead e =* f_EVALTAG (reference (variable en))
+tagAssign e t = do
+    declareStruct t
+    tyenv <- asks (grinTypeEnv . rGrin)
+    TyTy { tySiblings = sib } <- findTyTy tyenv t
+    tellTags t
+    case sib of
+        Just [n'] | n' == t -> return mempty
+        _ -> do return $ getWhat e =* constant (enum $ nodeTagName t)
+
+tellTags :: Atom -> C ()
+tellTags t | tagIsSuspFunction t = return ()
+tellTags t = do
+    tyenv <- asks (grinTypeEnv . rGrin)
+    TyTy { tySiblings = sib } <- findTyTy tyenv t
+    case sib of
+        Just [n'] | n' == t -> return ()
+        Just rs -> tell mempty { wEnums = Map.fromList (zip (map nodeTagName rs) [0..]) }
+        Nothing -> tell mempty { wTags = Set.singleton t }
+
+
+
hunk ./C/FromGrin2.hs 484
+newNode (NodeC t as) = do
+    let sf = tagIsSuspFunction t
+    st <- nodeType t
+    as' <- mapM convertVal as
+    tmp <- newVar (if sf then sptr_t else wptr_t)
+    let tmp' = concrete t tmp
+        wmalloc = if not sf && all (nonPtr . getType) as then jhc_malloc_atomic else jhc_malloc
+        malloc =  tmp =* wmalloc (sizeof st)
+        ass = [ if isValUnknown aa then mempty else project' i tmp' =* a | a <- as' | aa <- as | i <- map arg [(1 :: Int) ..] ]
+        nonPtr TyPtr {} = False
+        nonPtr TyNode = False
+        nonPtr (TyTup xs) = all nonPtr xs
+        nonPtr _ = True
+    tagassign <- tagAssign tmp' t
+    let res = if sf then (f_EVALTAG tmp) else tmp
+    return (mconcat $ malloc:tagassign:ass,res)
+
+
+{-
+
hunk ./C/FromGrin2.hs 526
+        wmalloc = if all (nonPtr . getType) as then jhc_malloc_atomic else jhc_malloc
hunk ./C/FromGrin2.hs 538
+-}
+
hunk ./C/FromGrin2.hs 546
-    let ts = runIdentity $ findArgs (grinTypeEnv grin) n
+    let TyTy { tySlots = ts, tySiblings = ss } = runIdentity $ findTyTy (grinTypeEnv grin) n
hunk ./C/FromGrin2.hs 548
-    tell mempty { wStructures = Map.singleton (nodeStructName n) (zip [ name $ 'a':show i | i <-  [1 ..] ] ts') }
+    let tag | tagIsSuspFunction n = [(name "head",fptr_t)]
+            | Just [n'] <- ss, n == n' = []
+            | otherwise = [(name "what",what_t)]
+    tell mempty { wStructures = Map.singleton (nodeStructName n) (tag ++ zip [ name $ 'a':show i | i <-  [1 ..] ] ts') }
hunk ./C/FromGrin2.hs 564
-        update =  f_update (cast wptr_t (variable aname)) rvar
+        update =  f_update (cast sptr_t (variable aname)) rvar
hunk ./C/FromGrin2.hs 630
+fptr_t    = basicType "fptr_t"
+what_t    = basicType "what_t"
hunk ./C/FromGrin2.hs 643
-getTag :: Expression -> Expression
-getTag e = project' (name "tag") e
+
+getHead :: Expression -> Expression
+getHead e = project' (name "head") e
+
+getWhat :: Expression -> Expression
+getWhat e = project' (name "what") e
hunk ./C/Generate.hs 420
-
-generateC :: [Function]        -- ^ functions
+generateC :: Bool              -- ^ whether to add tag nodes
+    -> [Function]              -- ^ functions
hunk ./C/Generate.hs 424
-generateC fs ss = ans where
+generateC genTag fs ss = ans where
hunk ./C/Generate.hs 429
-        shead2 <- declStructs True ss
+        shead2 <- declStructs genTag ss
hunk ./C/Generate.hs 446
+
hunk ./Grin/Grin.hs 32
+    findTyTy,
hunk ./Grin/Grin.hs 448
-findArgsType (TyEnv m) a | Just TyTy { tySlots = ss, tyReturn = r } <-  Map.lookup a m = return (ss,r)
-findArgsType (TyEnv m) a | ('Y':rs) <- fromAtom a, (ns,'_':rs) <- span isDigit rs  = case Map.lookup (toAtom ('T':rs)) m of
-    Just TyTy { tySlots = ts, tyReturn = n } -> return (take (length ts - read ns) ts,n)
+findTyTy (TyEnv m) a | Just tyty <-  Map.lookup a m = return tyty
+findTyTy (TyEnv m) a | ('Y':rs) <- fromAtom a, (ns,'_':rs) <- span isDigit rs  = case Map.lookup (toAtom ('T':rs)) m of
+    Just TyTy { tySlots = ts, tyReturn = n } -> return tyTy { tySlots = take (length ts - read ns) ts, tyReturn = n }
hunk ./Grin/Grin.hs 452
-findArgsType _ a | "@hole" `isPrefixOf` fromAtom a  = return ([],TyNode)
-findArgsType _ a =  fail $ "findArgsType: " ++ show a
+findTyTy _ a | "@hole" `isPrefixOf` fromAtom a  = return tyTy { tySlots = [], tyReturn = TyNode }
+findTyTy _ a =  fail $ "findArgsType: " ++ show a
hunk ./Grin/Grin.hs 455
-findType (TyEnv m) a = case Map.lookup a m of
+findArgsType m a = liftM (\tyty -> (tySlots tyty,tyReturn tyty)) (findTyTy m a)
+
+findType m a = case findArgsType m a of
hunk ./Grin/Grin.hs 459
-    Just TyTy { tyReturn = x }-> return x
+    Just (_,x) -> return x
hunk ./data/jhc_rts2.c 5
-#define DETAG(x)    ((uintptr_t)(x) & ~0x3)
+#define DETAG(x)    ((uintptr_t)(x) & ~0x1)
hunk ./data/jhc_rts2.c 7
-#define GETHEAD(x)  (NODEP(x)->tag)
+#define GETHEAD(x)  (NODEP(x)->head)
+#define GETWHAT(x)  (DNODEP(x)->what)
hunk ./data/jhc_rts2.c 10
-#define EVALTAG(fn) (assert(((uintptr_t)(fn) & 0x3) == 0),(tag_t)((uintptr_t)(fn) | P_LAZY))
+#define DNODEP(x)   ((dnode_t *)(x))
+#define EVALTAG(fn) (assert(((uintptr_t)(fn) & 0x3) == 0),(sptr_t)((uintptr_t)(fn) | P_LAZY))
hunk ./data/jhc_rts2.c 17
-#define BLACK_HOLE 0xDEADBEEF
+#define BLACK_HOLE ((fptr_t)0xDEADBEEF)
hunk ./data/jhc_rts2.c 31
- * |   lazy location   | u1|
+ * |   lazy location   | 01|
hunk ./data/jhc_rts2.c 51
- * |    code pointer   | u1|
+ * |    code pointer   | 01|
hunk ./data/jhc_rts2.c 76
- * node_t - definitely a pointer to a lazy location
- * tag_t - the first value in a lazy location, has a tag indicating what it is
+ * fptr_t - a pointer to a whnf or a function pointer to something to evaluate, first value in a lazy location.
+ * what_t  - the discriminator of a discriminated union
hunk ./data/jhc_rts2.c 81
-typedef struct node enode_t;
-typedef struct node * sptr_t;
-typedef struct node * wptr_t;
-typedef uintptr_t tag_t;
+typedef struct node *  sptr_t;
+typedef struct dnode * wptr_t;
+typedef void *         fptr_t;
+typedef unsigned       what_t;
+
hunk ./data/jhc_rts2.c 88
-        tag_t tag;
+        fptr_t head;
hunk ./data/jhc_rts2.c 92
+typedef struct dnode {
+        what_t what;
+        sptr_t rest[];
+} dnode_t;
+
hunk ./data/jhc_rts2.c 98
-typedef sptr_t (*eval_fn)(node_t *node) A_STD;
+typedef wptr_t (*eval_fn)(node_t *node) A_STD;
hunk ./data/jhc_rts2.c 105
-        return s;
+        return (wptr_t)s;
hunk ./data/jhc_rts2.c 126
-                return h;
+                return (wptr_t)h;
hunk ./data/jhc_rts2.c 128
-        return s;
+        return (wptr_t)s;
hunk ./data/jhc_rts2.c 138
-        GETHEAD(thunk) = (tag_t)new;
+        GETHEAD(thunk) = (fptr_t)new;