[start adding support for mark-sweep garbage collector
John Meacham <john@repetae.net>**20090627015752
 Ignore-this: c9a923ff21e4e95692dc88d2619151a1
] hunk ./C/FromGrin2.hs 60
+    rStowed :: Set.Set Name,  -- names that the garbage collector knows about
hunk ./C/FromGrin2.hs 74
-runC grin (C m) =  execUniq1 (runRWST m Env { rCPR = cpr, rGrin = grin, rDeclare = False, rTodo = TodoExp [], rEMap = mempty, rInscope = mempty } emptyHcHash) where
+runC grin (C m) =  execUniq1 (runRWST m startEnv  emptyHcHash) where
hunk ./C/FromGrin2.hs 76
+    startEnv = Env {
+        rCPR = cpr,
+        rGrin = grin,
+        rStowed = Set.empty,
+        rDeclare = False,
+        rTodo = TodoExp [],
+        rEMap = mempty,
+        rInscope = mempty
+        }
hunk ./C/FromGrin2.hs 329
-        am ~(NodeC t2 _) e = do 
+        am ~(NodeC t2 _) e = do
hunk ./C/FromGrin2.hs 451
+convertBody (GcRoots vs b) = do
+    vs <- mapM convertVal vs
+    b' <- convertBody b
+    return $ gc_roots vs & b' & gc_end
+
hunk ./C/FromGrin2.hs 839
+gc_roots vs = functionCall (name "gc_begin_frame0") (constant (number (fromIntegral $ length vs)):vs)
+gc_end =      functionCall (name "gc_end") []
hunk ./C/Generate.hs 92
+
hunk ./C/Generate.hs 483
+drawFunction :: Function -> G (Doc,Doc)
hunk ./Grin/Devolve.hs 13
+import Support.CanType
hunk ./Grin/Devolve.hs 17
-import Options (verbose)
+import Options (verbose,fopts)
+import qualified FlagOpts as FO
hunk ./Grin/Devolve.hs 69
+-- twiddle does some final clean up before translation to C
+-- it replaces unused arguments with 'v0' and adds GC notations
+
hunk ./Grin/Devolve.hs 73
-    envMap :: Map.Map Var Var,
-    envVar :: Var
+    envMap   :: Map.Map Var Var,
+    envRoots :: Set.Set Val,
+    envVar   :: Var
+    }
+
+data Written = Written {
+    wPotentialRoots :: Set.Set Val,
+    wIsAllocing  :: Bool
hunk ./Grin/Devolve.hs 86
-runR (R x) = fst $ evalRWS x Env { envMap = mempty, envVar = v1 } ()
+runR (R x) = fst $ evalRWS x Env { envRoots = mempty, envMap = mempty, envVar = v1 } ()
hunk ./Grin/Devolve.hs 103
+    f (x :>>= lam) | fopts FO.Jgc && isAllocing x = do
+        roots <- asks envRoots
+        let nroots = Set.fromList [ Var v t | (v,t) <- Set.toList (freeVars lam), isNode t, v > v0] Set.\\ roots
+        local (\e -> e { envRoots = envRoots e `Set.union` nroots}) $ do
+            ne <- return (:>>=) `ap` twiddle x `ap` twiddle lam
+            return $ gcRoots (Set.toList nroots) ne
hunk ./Grin/Devolve.hs 117
+    isAllocing Store {} = True
+    isAllocing (Return [Var {}]) = False
+    isAllocing (Return [NodeC {}]) = True
+    isAllocing App {} = True
+    isAllocing Call {} = True
+    isAllocing Let {} = True
+    isAllocing (Case _ as) = any isAllocing [ b | _ :-> b <- as]
+    isAllocing Alloc {} = True
+    isAllocing (e :>>= _ :-> y) = isAllocing e || isAllocing y
+    isAllocing _ = False
+
+    gcRoots [] x = x
+    gcRoots xs e = GcRoots xs e
+
+    isNode TyNode = True
+    isNode (TyPtr TyNode) = True
+    isNode _ = False
+
hunk ./Grin/Grin.hs 136
+--data VContext = Demoted Val VContext  | Promoted Val VContext | Evaled Val VContext |
+
hunk ./Grin/Grin.hs 183
+    | GcRoots   { expValues :: [Val],                  -- ^ add some new variables to the GC roots for a subcomputation
+                  expBody :: Exp }
hunk ./Grin/Grin.hs 226
-setGrinFunctions xs _grin | flint && hasRepeatUnder fst xs = error $ "setGrinFunctions: grin has redundent defeninitions" ++ show (fsts xs)
+setGrinFunctions xs _grin | flint && hasRepeatUnder fst xs = error $ "setGrinFunctions: grin has redundent definitions" ++ show (fsts xs)
hunk ./Grin/Grin.hs 474
+    getType GcRoots { expBody = body } = getType body
hunk ./Grin/Grin.hs 534
+    freeVars GcRoots { expValues = v, expBody = b } = freeVars (v,b)
hunk ./Grin/Grin.hs 552
+    freeVars GcRoots { expValues = v, expBody = b } = freeVars (v,b)
hunk ./Grin/Grin.hs 593
+    freeVars GcRoots { expValues = v, expBody = b } = freeVars (v,b)
hunk ./Grin/Noodle.hs 188
+        cfunc GcRoots { expBody = b} = cfunc b
hunk ./Grin/Show.hs 104
+prettyExp vl (GcRoots vs b) = vl <> keyword "withRoots" <> tupled (map prettyVal vs) <$> indent 2 (prettyExp empty b)
hunk ./Main.hs 752
-
hunk ./Main.hs 758
-
hunk ./Main.hs 759
+    wdump FD.GrinFinal $ dumpGrin "predevolve" x
hunk ./Main.hs 787
-        boehmOpts | fopts FO.Boehm || lup "gc" == "boehm"  = ["-D_JHC_GC=2", "-lgc"]
+        boehmOpts | fopts FO.Boehm || lup "gc" == "boehm"  = ["-D_JHC_GC=_JHC_GC_BOEHM", "-lgc"]
+                  | fopts FO.Jgc || lup "gc" == "jgc"  = ["-D_JHC_GC=_JHC_GC_JGC"]
hunk ./data/rts/jhc_rts_alloc.c 138
-#error "jgc not supported yet."
+#define GC_STACK_LIMIT 8192
+static sptr_t *gc_stack_base;
+
+static inline void
+jhc_malloc_init(void) {
+        gc_stack_base = malloc(sizeof(sptr_t) * GC_STACK_LIMIT);
+}
+
+