[clean up FromGrin2 code, add a whole lot of sanity checking when compiled with debug mode
John Meacham <john@repetae.net>**20070227035224] hunk ./C/FromGrin2.hs 97
-  --      flip mapM_ tags $ \ (n,ts) -> do
-  --          ts' <- mapM convertType ts
-  --          tell Written { wStructures = Map.singleton (nodeStructName n) (zip [ name $ 'a':show i | i <-  [1 ..] ] ts') }
-
-
-
-
-
hunk ./C/FromGrin2.hs 105
-            ats = (if isNothing ffie then Attribute "A_REGPARM" else Public):mmalloc bt
+            ats = (if isNothing ffie then Attribute "A_STD" else Public):mmalloc bt
hunk ./C/FromGrin2.hs 113
-        return $ function fnname fr as' ats (profile_function_inc `mappend` s)
+        return $ function fnname fr as' ats (profile_function_inc & s)
hunk ./C/FromGrin2.hs 182
-    return $ mconcat [ assign q' (operator "/" a' b'), assign r' (operator "%" a' b'), ss' ]
+    return $ mconcat [ q' =* (operator "/" a' b'), r' =* (operator "%" a' b'), ss' ]
hunk ./C/FromGrin2.hs 195
-       return (annotate (show as) (label (toName (show name ++ show u))) `mappend` indentBlock ss)
-    return (ss `mappend` goto done `mappend` mconcat (intersperse (goto done) rs) `mappend` label done);
+       return (annotate (show as) (label (toName (show name ++ show u))) & indentBlock ss)
+    return (ss & goto done & mconcat (intersperse (goto done) rs) & label done);
hunk ./C/FromGrin2.hs 201
-    return (ss `mappend` ss')
+    return (ss & ss')
hunk ./C/FromGrin2.hs 206
-    return (ss `mappend` ss')
+    return (ss & ss')
hunk ./C/FromGrin2.hs 213
-    return $  ss `mappend` mconcat [ v `assign` projectAnon i st | v <- vs | i <- [0..] ] `mappend` ss'
+    return $  ss & mconcat [ v =* projectAnon i st | v <- vs | i <- [0..] ] & ss'
hunk ./C/FromGrin2.hs 219
-        da v@Var {} _ = do
+        da v@Var {} e = do
hunk ./C/FromGrin2.hs 221
-            return $ assign v'' scrut
+            e' <- convertBody e
+            return $ v'' =* scrut & e'
hunk ./C/FromGrin2.hs 227
-                ass = mconcat [if needed a then assign  a' (project' (arg i) tmp) else mempty | a' <- as' | a <- as | i <- [(1 :: Int) ..] ]
+                ass = mconcat [if needed a then a' =* (project' (arg i) tmp) else mempty | a' <- as' | a <- as | i <- [(1 :: Int) ..] ]
hunk ./C/FromGrin2.hs 230
-            return ass
-        am | isVar p2 = id
-           | otherwise = annotate (show p2)
-    e1' <- convertBody e1
-    e2' <- convertBody e2
+            e' <- convertBody e
+            return (ass & e')
+        am Var {} e = e
+        am (NodeC t2 _) e = annotate (show p2) (f_assert ((constant $ enum (nodeTagName t2)) `eq` tag) & e)
hunk ./C/FromGrin2.hs 235
-    p2' <- liftM am $ da p2 e2
-    return $ profile_case_inc `mappend` cif (operator "==" (constant $ enum (nodeTagName t)) tag) (p1' `mappend` e1') (p2' `mappend` e2')
+    p2' <- liftM (am p2) $ da p2 e2
+    return $ profile_case_inc & cif ((constant $ enum (nodeTagName t)) `eq` tag) p1' p2'
+
hunk ./C/FromGrin2.hs 246
-        am | isVar p2 = id
-           | otherwise = annotate (show p2)
+        am e | isVar p2 = e
+             | otherwise = annotate (show p2) (f_assert ((cp p2) `eq` scrut') & e)
hunk ./C/FromGrin2.hs 250
-    return $ profile_case_inc `mappend` cif (operator "==" (cp p1) scrut') e1' (am e2')
+    return $ profile_case_inc & cif (cp p1 `eq` scrut') e1' (am e2')
hunk ./C/FromGrin2.hs 257
-            return $ (Nothing,assign v'' scrut `mappend` e')
+            return $ (Nothing,v'' =* scrut & e')
hunk ./C/FromGrin2.hs 265
-                ass = mconcat [if needed a then assign  a' (project' (arg i) tmp) else mempty | a' <- as' | a <- as | i <- [(1 :: Int) ..] ]
+                ass = mconcat [if needed a then a' =* (project' (arg i) tmp) else mempty | a' <- as' | a <- as | i <- [(1 :: Int) ..] ]
hunk ./C/FromGrin2.hs 268
-            return $ (Just (enum (nodeTagName t)), ass `mappend` e')
+            return $ (Just (enum (nodeTagName t)), ass & e')
hunk ./C/FromGrin2.hs 270
-    return $ profile_case_inc `mappend` switch' tag ls'
+    return $ profile_case_inc & switch' tag ls'
hunk ./C/FromGrin2.hs 278
-            return (Nothing,assign v'' scrut `mappend` e')
+            return (Nothing,v'' =* scrut & e')
hunk ./C/FromGrin2.hs 287
-    return $ profile_case_inc `mappend` switch' scrut' ls'
+    return $ profile_case_inc & switch' scrut' ls'
hunk ./C/FromGrin2.hs 294
-        TodoReturn -> return (ss `mappend` creturn er)
+        TodoReturn -> return (ss & creturn er)
hunk ./C/FromGrin2.hs 296
-        TodoExp v -> return (ss `mappend` (v `assign` er))
+        TodoExp v -> return (ss & (v =* er))
hunk ./C/FromGrin2.hs 298
-        TodoNothing -> return (ss `mappend` expr er)
+        TodoNothing -> return (ss & er)
hunk ./C/FromGrin2.hs 303
-    let ass = concat [perhapsM (a `Set.member` fve) $ assign  a' (project' (arg i) (concrete t v')) | a' <- as' | Var a _ <- as |  i <- [( 1 :: Int) ..] ]
+    let ass = concat [perhapsM (a `Set.member` fve) $ a' =* (project' (arg i) (concrete t v')) | a' <- as' | Var a _ <- as |  i <- [( 1 :: Int) ..] ]
hunk ./C/FromGrin2.hs 306
-    return $  mconcat ass `mappend` ss'
-
-{-
-
-convertBody (Return v :>>= (NodeV t []) :-> e') = nodeAssignV v t e'
-convertBody (Fetch v :>>= (NodeV t []) :-> e') = nodeAssignV v t e'
+    return $  mconcat ass & ss'
hunk ./C/FromGrin2.hs 309
-
--}
-
hunk ./C/FromGrin2.hs 348
-            let ss = [ a `assign` v | a <- as | v <- vs' ]
-            return (mconcat ss `mappend` goto nm, emptyExpression)
+            let ss = [ a =* v | a <- as | v <- vs' ]
+            return (mconcat ss & goto nm, emptyExpression)
hunk ./C/FromGrin2.hs 356
-        s = getTag tmp' `assign` constant (enum (nodeTagName t))
-        ass = [project' (arg i) tmp' `assign` a | a <- as' | i <- [(1 :: Int) ..] ]
+        s = getTag tmp' =* constant (enum (nodeTagName t))
+        ass = [project' (arg i) tmp' =* a | a <- as' | i <- [(1 :: Int) ..] ]
hunk ./C/FromGrin2.hs 397
-
hunk ./C/FromGrin2.hs 399
-{-
-convertExp (Fetch v) | getType v == TyPtr TyNode = do
-    v <- convertVal v
-    return (mempty,v)
-convertExp (Fetch (Index base off)) | getType base == TyPtr (TyPtr TyNode) = do
-    base <- convertVal base
-    off <- convertVal off
-    ure.eturn (mempty,indexArray base off)
-convertExp (Fetch v) | getType v == TyPtr (TyPtr TyNode) = do
-    v <- convertVal v
-    return (mempty,dereference v)
-convertExp (Store n@NodeV {}) = newNode n
-convertExp (Return n@NodeV {}) = newNode n
-convertExp (Store n@NodeC {}) = newNode n
-convertExp (Return n@NodeC {}) = newNode n
-
-convertExp (Store n@Var {}) | getType n == TyNode = do
-    (ss,nn) <- newNode (NodeC tagHole [])
-    tmp <- newVar pnode_t
-    n <- convertVal n
-    let tag = project' anyTag n
-        update = expr (functionCall (name "memcpy") [tmp,n,functionCall  (name "jhc_sizeof") [tag]])
-    return (ss `mappend` (tmp `assign` nn) `mappend` update, tmp)
-convertExp (Store v) | TyPtr TyNode == getType v = do
-    v <- convertVal v
-    tmp <- newVar ppnode_t
-    return ((tmp `assign` jhc_malloc (sizeof pnode_t)) `mappend` (dereference tmp `assign` v),tmp)
-convertExp Alloc { expValue = v, expCount = c, expRegion = r } | r == region_heap, TyPtr TyNode == getType v  = do
-    v' <- convertVal v
-    c' <- convertVal c
-    tmp <- newVar ppnode_t
-    let malloc = tmp `assign` jhc_malloc (operator "*" (sizeof pnode_t) c')
-    fill <- case v of
-        ValUnknown _ -> return mempty
-        _ -> do
-            i <- newVar (basicType "int")
-            return $ forLoop i (expressionRaw "0") c' $ indexArray tmp i `assign` v'
-    return (malloc `mappend` fill, tmp)
-convertExp e@(Update v z) | getType v /= TyPtr (getType z) = do
-    return (err (show e),err "nothing")
-convertExp (Update v@Var {} (NodeV t [])) | getType v == TyPtr TyNode = do
-    v' <- convertVal v
-    t' <- convertVal (Var t TyTag)
-    let tag = project' anyTag v'
-    return (tag `assign` t',emptyExpression)
-convertExp (Update (Index base off) z) | getType z == TyPtr TyNode = do
-    base <- convertVal base
-    off <- convertVal off
-    z' <- convertVal z
-    return $ (indexArray base off `assign` z',emptyExpression)
-convertExp (Update v z) | getType z == TyPtr TyNode = do
-    v' <- convertVal v
-    z' <- convertVal z
-    return $ (dereference v' `assign` z',emptyExpression)
-convertExp (Update v z) | getType z == TyNode = do  -- TODO eliminate unknown updates
-    v' <- convertVal v
-    z' <- convertVal z
-    let tag = project' anyTag z'
-    return $ (profile_update_inc,functionCall (name "memcpy") [v',z',functionCall  (name "jhc_sizeof") [tag]])
-convertExp e = return (err (show e),err "nothing")
-
--}
hunk ./C/FromGrin2.hs 431
-        malloc =  tmp `assign` jhc_malloc (sizeof  node_t)
-        tagassign = tmp' `assign` var
+        malloc =  tmp =* jhc_malloc (sizeof  node_t)
+        tagassign = tmp' =* var
hunk ./C/FromGrin2.hs 442
-        malloc =  tmp `assign` jhc_malloc (sizeof st)
-        tagassign = getTag tmp' `assign` functionCall (name "EVALTAG") [reference (variable en)]
-        ass = [ project' (arg i) tmp' `assign` a | a <- as' | i <- [(1 :: Int) ..] ]
+        malloc =  tmp =* jhc_malloc (sizeof st)
+        tagassign = getTag tmp' =* functionCall (name "EVALTAG") [reference (variable en)]
+        ass = [ project' (arg i) tmp' =* a | a <- as' | i <- [(1 :: Int) ..] ]
hunk ./C/FromGrin2.hs 458
-        malloc =  tmp `assign` wmalloc (sizeof  (if tagIsWHNF t then st else node_t))
-        tagassign = getTag tmp' `assign` constant (enum $ nodeTagName t)
+        malloc =  tmp =* wmalloc (sizeof  (if tagIsWHNF t then st else node_t))
+        tagassign = getTag tmp' =* constant (enum $ nodeTagName t)
hunk ./C/FromGrin2.hs 461
-        ass = [ project' (arg i) tmp' `assign` a | a <- as' | i <- [(1 :: Int) ..] ]
+        ass = [ project' (arg i) tmp' =* a | a <- as' | i <- [(1 :: Int) ..] ]
hunk ./C/FromGrin2.hs 489
-        body = rvar `assign` functionCall (toName (show $ fn)) [ project' (arg i) (variable aname) | _ <- ts | i <- [1 .. ] ]
-        update =  expr $ functionCall (toName "update") [cast sptr_t (variable aname),rvar]
-    tellFunctions [function fname sptr_t [(aname,atype)] [] (body `mappend` update `mappend` creturn rvar )]
+        body = rvar =* functionCall (toName (show $ fn)) [ project' (arg i) (variable aname) | _ <- ts | i <- [1 .. ] ]
+        update =  functionCall (toName "update") [cast sptr_t (variable aname),rvar]
+    tellFunctions [function fname sptr_t [(aname,atype)] [] (body & update & creturn rvar )]
hunk ./C/FromGrin2.hs 532
+f_assert e = expr $ functionCall (name "assert") [e]
hunk ./C/FromGrin2.hs 567
+------------
+-- C helpers
+------------
+
+infix 3 `eq`
+
+eq :: Expression -> Expression -> Expression
+eq = operator "=="
+
+infix 2 =*
+
+(=*) :: Expression -> Expression -> Statement
+x =* y = x `assign` y
+
+class ToStatement a  where
+    toStatement :: a -> Statement
+
+instance ToStatement Statement where
+    toStatement x = x
+
+instance ToStatement Expression where
+    toStatement e = expr e
+
+infixl 1 &
+
+(&) :: (ToStatement a,ToStatement b) => a -> b -> Statement
+x & y = toStatement x `mappend` toStatement y
+
+
+{-
+convertExp (Fetch v) | getType v == TyPtr TyNode = do
+    v <- convertVal v
+    return (mempty,v)
+convertExp (Fetch (Index base off)) | getType base == TyPtr (TyPtr TyNode) = do
+    base <- convertVal base
+    off <- convertVal off
+    ure.eturn (mempty,indexArray base off)
+convertExp (Fetch v) | getType v == TyPtr (TyPtr TyNode) = do
+    v <- convertVal v
+    return (mempty,dereference v)
+convertExp (Store n@NodeV {}) = newNode n
+convertExp (Return n@NodeV {}) = newNode n
+convertExp (Store n@NodeC {}) = newNode n
+convertExp (Return n@NodeC {}) = newNode n
+
+convertExp (Store n@Var {}) | getType n == TyNode = do
+    (ss,nn) <- newNode (NodeC tagHole [])
+    tmp <- newVar pnode_t
+    n <- convertVal n
+    let tag = project' anyTag n
+        update = expr (functionCall (name "memcpy") [tmp,n,functionCall  (name "jhc_sizeof") [tag]])
+    return (ss `mappend` (tmp `assign` nn) `mappend` update, tmp)
+convertExp (Store v) | TyPtr TyNode == getType v = do
+    v <- convertVal v
+    tmp <- newVar ppnode_t
+    return ((tmp `assign` jhc_malloc (sizeof pnode_t)) `mappend` (dereference tmp `assign` v),tmp)
+convertExp Alloc { expValue = v, expCount = c, expRegion = r } | r == region_heap, TyPtr TyNode == getType v  = do
+    v' <- convertVal v
+    c' <- convertVal c
+    tmp <- newVar ppnode_t
+    let malloc = tmp `assign` jhc_malloc (operator "*" (sizeof pnode_t) c')
+    fill <- case v of
+        ValUnknown _ -> return mempty
+        _ -> do
+            i <- newVar (basicType "int")
+            return $ forLoop i (expressionRaw "0") c' $ indexArray tmp i `assign` v'
+    return (malloc `mappend` fill, tmp)
+convertExp e@(Update v z) | getType v /= TyPtr (getType z) = do
+    return (err (show e),err "nothing")
+convertExp (Update v@Var {} (NodeV t [])) | getType v == TyPtr TyNode = do
+    v' <- convertVal v
+    t' <- convertVal (Var t TyTag)
+    let tag = project' anyTag v'
+    return (tag `assign` t',emptyExpression)
+convertExp (Update (Index base off) z) | getType z == TyPtr TyNode = do
+    base <- convertVal base
+    off <- convertVal off
+    z' <- convertVal z
+    return $ (indexArray base off `assign` z',emptyExpression)
+convertExp (Update v z) | getType z == TyPtr TyNode = do
+    v' <- convertVal v
+    z' <- convertVal z
+    return $ (dereference v' `assign` z',emptyExpression)
+convertExp (Update v z) | getType z == TyNode = do  -- TODO eliminate unknown updates
+    v' <- convertVal v
+    z' <- convertVal z
+    let tag = project' anyTag z'
+    return $ (profile_update_inc,functionCall (name "memcpy") [v',z',functionCall  (name "jhc_sizeof") [tag]])
+convertExp e = return (err (show e),err "nothing")
hunk ./C/FromGrin2.hs 657
+-}
+{-
+convertBody (Return v :>>= (NodeV t []) :-> e') = nodeAssignV v t e'
+convertBody (Fetch v :>>= (NodeV t []) :-> e') = nodeAssignV v t e'
+-}
hunk ./data/jhc_rts.c 26
+#ifdef __i386__
+#define A_REGPARM __attribute__ ((fastcall))
+#else
+#define A_REGPARM
+#endif
+#define A_STD    A_REGPARM __attribute__ ((nothrow))
hunk ./data/jhc_rts.c 38
+#define A_STD
hunk ./data/jhc_rts.c 41
-#if defined(__GNUC__) && defined(__i386__)
-#define A_REGPARM __attribute__ ((regparm(2)))
-#else
-#define A_REGPARM
-#endif
hunk ./data/jhc_rts.c 44
+#define ALIGN(a,n) ((n) - 1 + ((a) - ((n) - 1) % (a)))
hunk ./data/jhc_rts.c 77
-        jhc_mem += n;
+        jhc_mem += ALIGN(__alignof__(void *),n);
+#ifndef NDEBUG
+        memset(ret,7,(char *)jhc_mem - (char *)ret);
+        memset(jhc_mem,8,2*sizeof(void *));
+#endif
hunk ./data/jhc_rts2.c 15
+#define BLACK_HOLE 0xDEADBEEF
hunk ./data/jhc_rts2.c 104
+                assert(h != BLACK_HOLE);
hunk ./data/jhc_rts2.c 106
-                        return ((eval_fn)DETAG(h))(NODEP(ds));
+                        eval_fn fn = (eval_fn)DETAG(h);
+#ifndef NDEBUG
+                        GETHEAD(ds) = BLACK_HOLE;
+#endif
+                        sptr_t r = (*fn)(NODEP(ds));
+#ifndef NDEBUG
+                        assert(GETHEAD(ds) != BLACK_HOLE);
+#endif
+                        return r;
hunk ./data/jhc_rts2.c 126
-        assert(ISLAZY(GETHEAD(thunk)));
+        assert(GETHEAD(thunk) == BLACK_HOLE);