New patches: [implement grey set as stack rather than judy array John Meacham **20100327224532 Ignore-this: 56428458f1f456f6b6d85e1aa61f2155 ] hunk ./src/data/rts/jhc_jgc.h 56 #define gc_mk_alloc_tag_s(ty, np, tag) static inline ty *gc_alloc_ ## ty ## _s(gc_t gc, ty v) { ty *x = gc_alloc(gc,gc_count(ty),np); gc_tag(x) = tag; *x = v; return x; } #define gc_tag(p) (((entry_header_t *)((void *)p - sizeof(void *)))->tag) -#define FOOF 0xF00DF00FACEBAFFUL - -void gc_print_stats(gc_t gc); -void gc_perform_gc(gc_t gc); -void *gc_alloc_tag(gc_t gc,unsigned count, unsigned nptrs, int tag); +static void gc_print_stats(gc_t gc); +static void gc_perform_gc(gc_t gc); +static void *gc_alloc_tag(gc_t gc,unsigned count, unsigned nptrs, int tag); static inline void * gc_alloc_bytes(gc_t gc,size_t count) { hunk ./src/data/rts/jhc_jgc.h 65 return gc_alloc_tag(gc, TO_BLOCKS(count), 0, 0); } -bool gc_add_root(gc_t gc, void *root); -bool gc_del_root(gc_t gc, void *root); #endif hunk ./src/data/rts/jhc_jgc.h 81 #endif -static Pvoid_t gc_roots = NULL; // extra roots in addition to the stack -static Pvoid_t gc_allocated = NULL; // black set of currently allocated memory -static size_t heap_threshold = 2048; // threshold at which we want to run a gc rather than malloc more memory -static size_t mem_inuse; // amount of memory in use by gc'ed memory -static unsigned number_gcs; // number of garbage collections -static unsigned number_allocs; // number of allocations since last garbage collection +static Pvoid_t gc_roots = NULL; // extra roots in addition to the stack +static Pvoid_t gc_allocated = NULL; // black set of currently allocated memory +static size_t heap_threshold = 2048; // threshold at which we want to run a gc rather than malloc more memory +static size_t mem_inuse; // amount of memory in use by gc'ed memory +static unsigned number_gcs; // number of garbage collections +static unsigned number_allocs; // number of allocations since last garbage collection #define SHOULD_FOLLOW(w) IS_PTR(w) hunk ./src/data/rts/jhc_jgc.h 106 int r; J1S(r,gc_roots,((Word_t)root / GC_BASE) - 1 ); return (bool)r; - } else + } else return false; } hunk ./src/data/rts/jhc_jgc.h 117 int r; J1U(r,gc_roots,((Word_t)root / GC_BASE) - 1); return (bool)r; - } else + } else return false; } hunk ./src/data/rts/jhc_jgc.h 130 fprintf(stderr,"allocated: %5lu roots: %3lu mem_inuse: %5lu heap_threshold: %5lu gcs: %3u\n",n_allocated,n_roots,(long unsigned)mem_inuse,(long unsigned)heap_threshold,number_gcs); } + +struct stack { + unsigned size; + unsigned ptr; + uintptr_t *stack; +}; + +#define EMPTY_STACK { 0, 0, NULL } + +static void +stack_check(struct stack *s, unsigned n) { + while(s->size - s->ptr <= n) { + s->size += 4096; + s->stack = realloc(s->stack, sizeof(uintptr_t)*s->size); + assert(s->stack); + debugf(stderr, "stack:"); + for(unsigned i = 0; i < s->ptr; i++) { + debugf(stderr, " %p", (void *)s->stack[i]); + } + debugf(stderr, "\n"); + } +} + static void gc_perform_gc(gc_t gc) { hunk ./src/data/rts/jhc_jgc.h 157 profile_push(&gc_gc_time); + number_gcs++; + unsigned number_redirects = 0; unsigned number_stack = 0; unsigned number_ptr = 0; hunk ./src/data/rts/jhc_jgc.h 162 - unsigned number_whnf = 0; - number_gcs++; + struct stack stack = EMPTY_STACK; + Pvoid_t gc_grey = NULL; hunk ./src/data/rts/jhc_jgc.h 165 - Pvoid_t gc_black = NULL; Word_t ix; hunk ./src/data/rts/jhc_jgc.h 166 - int r; - // initialize the grey set with the roots debugf("Setting Roots:"); hunk ./src/data/rts/jhc_jgc.h 167 - for(ix = 0,(J1F(r,gc_roots,ix)); r; (J1N(r,gc_roots,ix))) { + Word_t n_roots; + J1C(n_roots,gc_roots,0,-1); + stack_check(&stack, n_roots); + int r; for(ix = 0,(J1F(r,gc_roots,ix)); r; (J1N(r,gc_roots,ix))) { debugf(" %p",(void *)(ix * GC_BASE)); hunk ./src/data/rts/jhc_jgc.h 172 + stack.stack[stack.ptr++] = ix*GC_BASE; int d; J1S(d,gc_grey,ix); } debugf("\n"); hunk ./src/data/rts/jhc_jgc.h 179 debugf("Trace:"); for(;gc;gc = gc->prev) { debugf(" |"); + stack_check(&stack, gc->nptrs); for(unsigned i = 0;i < gc->nptrs; i++) { number_stack++; hunk ./src/data/rts/jhc_jgc.h 182 - //if(IS_LAZY(gc->ptrs[i])) { - // if(!IS_LAZY(GETHEAD(FROM_SPTR(gc->ptrs[i])))) { - // number_redirects++; - // debugf(" *"); - // gc->ptrs[i] = GETHEAD(FROM_SPTR(gc->ptrs[i])); - // number_whnf++; - // } - //} else { - // number_whnf++; - //} + // TODO - short circuit redirects on stack if(__predict_false(!SHOULD_FOLLOW(gc->ptrs[i]))) { debugf(" -"); continue; hunk ./src/data/rts/jhc_jgc.h 191 entry_t *e = (entry_t *)FROM_SPTR(gc->ptrs[i]) - 1; debugf(" %p",(void *)e); int d; J1S(d,gc_grey,(Word_t)e / GC_BASE); + if(d) + stack.stack[stack.ptr++] = (uintptr_t)e; } } debugf("\n"); hunk ./src/data/rts/jhc_jgc.h 196 - // trace the grey - while(ix = 0,(J1F(r,gc_grey,ix)),r) { + + while(stack.ptr) { + uintptr_t ix = stack.stack[--stack.ptr] / GC_BASE; + J1T(r,gc_grey,ix); + assert(r); debugf("Processing Grey: %p ",(void *)(ix * GC_BASE)); hunk ./src/data/rts/jhc_jgc.h 202 - J1U(r,gc_grey,ix); J1U(r,gc_allocated,ix); if(__predict_false(r == 0)) { hunk ./src/data/rts/jhc_jgc.h 204 + J1U(r,gc_grey,ix); debugf("Skipping.\n"); continue; } hunk ./src/data/rts/jhc_jgc.h 209 debugf("Blackening\n"); - J1S(r,gc_black,ix); + //J1S(r,gc_black,ix); entry_t *e = (entry_t *)(ix * GC_BASE); int offset = e->u.v.tag ? 1 : 0; hunk ./src/data/rts/jhc_jgc.h 213 - for(int i = 0 + offset;i < e->u.v.nptrs + offset; i++) { + stack_check(&stack, e->u.v.nptrs); + for(int i = offset; i < e->u.v.nptrs + offset; i++) { if(P_LAZY == GET_PTYPE(e->ptrs[i])) { if(!IS_LAZY(GETHEAD(FROM_SPTR(e->ptrs[i])))) { number_redirects++; hunk ./src/data/rts/jhc_jgc.h 222 e->ptrs[i] = GETHEAD(FROM_SPTR(e->ptrs[i])); } } - entry_t * ptr = e->ptrs[i]; - if(SHOULD_FOLLOW(ptr)) { - ptr = FROM_SPTR(ptr); - debugf("Following: %p %p\n",e->ptrs[i], (void *)(ptr - 1)); - Word_t p = (Word_t)(ptr - 1) / GC_BASE; - int r; - J1T(r,gc_black,p); - if(__predict_true(!r)) - J1S(r,gc_grey,p); + if(SHOULD_FOLLOW(e->ptrs[i])) { + entry_t * ptr = (entry_t *)(FROM_SPTR(e->ptrs[i])) - 1; + debugf("Following: %p %p\n",e->ptrs[i], (void *)ptr); + Word_t p = (Word_t)ptr / GC_BASE; + int d; + J1S(d,gc_grey,p); + if(d) + stack.stack[stack.ptr++] = (uintptr_t)ptr; } hunk ./src/data/rts/jhc_jgc.h 231 - } } hunk ./src/data/rts/jhc_jgc.h 233 - assert(gc_grey == NULL); + free(stack.stack); for(ix = 0, (J1F(r,gc_allocated,ix)); r; (J1N(r,gc_allocated,ix))) { entry_t *e = (entry_t *)(ix * GC_BASE); mem_inuse -= (e->u.v.count + 1)*GC_BASE; hunk ./src/data/rts/jhc_jgc.h 240 free(e); } J1FA(r,gc_allocated); - gc_allocated = gc_black; -#if JGC_STATUS - fprintf(stderr, "Ss: %5u Ws: %5u Ps: %5u Rs: %5u As: %5u ", number_stack, number_whnf, number_ptr, number_redirects, number_allocs); + gc_allocated = gc_grey; number_allocs = 0; hunk ./src/data/rts/jhc_jgc.h 242 +#if JGC_STATUS + fprintf(stderr, "Ss: %5u Ps: %5u Rs: %5u As: %5u ", number_stack, number_ptr, number_redirects, number_allocs); gc_print_stats(gc); #endif profile_pop(&gc_gc_time); [clean up gc code, rearrange some tests John Meacham **20100328223243 Ignore-this: 654cf92de7199b56d1ca6a0eeb5d6e20 ] hunk ./src/data/rts/jhc_jgc.h 41 // be reused more often. #define GC_MINIMUM_SIZE 3 #define GC_BASE sizeof(void *) +#define GC_ALIGNMENT (2*sizeof(void *)) #define TO_BLOCKS(x) ((x) <= GC_MINIMUM_SIZE*GC_BASE ? GC_MINIMUM_SIZE : (((x) - 1)/GC_BASE) + 1) hunk ./src/data/rts/jhc_jgc.h 46 #define INITIAL_GC NULL -//typedef struct frame *gc_t; #define gc_frame0(gc,n,...) struct { struct frame *prev; unsigned nptrs;void *ptrs[n]; } l \ = { gc, n, { __VA_ARGS__ } }; gc_t gc = (gc_t)(void *)&l; hunk ./src/data/rts/jhc_jgc.h 56 #define gc_mk_alloc_tag_s(ty, np, tag) static inline ty *gc_alloc_ ## ty ## _s(gc_t gc, ty v) { ty *x = gc_alloc(gc,gc_count(ty),np); gc_tag(x) = tag; *x = v; return x; } #define gc_tag(p) (((entry_header_t *)((void *)p - sizeof(void *)))->tag) -static void gc_print_stats(gc_t gc); static void gc_perform_gc(gc_t gc); static void *gc_alloc_tag(gc_t gc,unsigned count, unsigned nptrs, int tag); hunk ./src/data/rts/jhc_jgc.h 102 gc_add_root(gc_t gc, void *root) { if(SHOULD_FOLLOW(root)) { - int r; - J1S(r,gc_roots,((Word_t)root / GC_BASE) - 1 ); + int r; J1S(r,gc_roots,(((Word_t)root - sizeof(entry_t)) / GC_ALIGNMENT)); return (bool)r; } else return false; hunk ./src/data/rts/jhc_jgc.h 108 } -static bool -gc_del_root(gc_t gc, void *root) -{ - if(SHOULD_FOLLOW(root)) { - int r; - J1U(r,gc_roots,((Word_t)root / GC_BASE) - 1); - return (bool)r; - } else - return false; -} hunk ./src/data/rts/jhc_jgc.h 109 -static void -gc_print_stats(gc_t gc) -{ - Word_t n_allocated,n_roots; - J1C(n_allocated,gc_allocated,0,-1); - J1C(n_roots,gc_roots,0,-1); - fprintf(stderr,"allocated: %5lu roots: %3lu mem_inuse: %5lu heap_threshold: %5lu gcs: %3u\n",n_allocated,n_roots,(long unsigned)mem_inuse,(long unsigned)heap_threshold,number_gcs); -} - struct stack { unsigned size; hunk ./src/data/rts/jhc_jgc.h 120 static void stack_check(struct stack *s, unsigned n) { - while(s->size - s->ptr <= n) { - s->size += 4096; + if(__predict_false(s->size - s->ptr < n)) { + s->size += 1024 + n; s->stack = realloc(s->stack, sizeof(uintptr_t)*s->size); assert(s->stack); hunk ./src/data/rts/jhc_jgc.h 124 - debugf(stderr, "stack:"); + debugf("stack:"); for(unsigned i = 0; i < s->ptr; i++) { hunk ./src/data/rts/jhc_jgc.h 126 - debugf(stderr, " %p", (void *)s->stack[i]); + debugf(" %p", (void *)s->stack[i]); } hunk ./src/data/rts/jhc_jgc.h 128 - debugf(stderr, "\n"); + debugf("\n"); } } hunk ./src/data/rts/jhc_jgc.h 150 J1C(n_roots,gc_roots,0,-1); stack_check(&stack, n_roots); int r; for(ix = 0,(J1F(r,gc_roots,ix)); r; (J1N(r,gc_roots,ix))) { - debugf(" %p",(void *)(ix * GC_BASE)); - stack.stack[stack.ptr++] = ix*GC_BASE; - int d; J1S(d,gc_grey,ix); + debugf(" %p", (void *)(ix * GC_ALIGNMENT)); + J1U(r, gc_allocated, ix); + if(r) { + J1S(r, gc_grey, ix); + if(r) + stack.stack[stack.ptr++] = (uintptr_t)ix * GC_ALIGNMENT; + } } debugf("\n"); debugf("Trace:"); hunk ./src/data/rts/jhc_jgc.h 166 for(unsigned i = 0;i < gc->nptrs; i++) { number_stack++; // TODO - short circuit redirects on stack - if(__predict_false(!SHOULD_FOLLOW(gc->ptrs[i]))) { + sptr_t ptr = gc->ptrs[i]; + if(P_LAZY == GET_PTYPE(ptr)) { + if(!IS_LAZY(GETHEAD(FROM_SPTR(ptr)))) { + J1U(r,gc_allocated,((uintptr_t)FROM_SPTR(ptr) - sizeof(entry_t))/GC_ALIGNMENT); + if(r) + J1S(r,gc_grey,((uintptr_t)FROM_SPTR(ptr) - sizeof(entry_t))/GC_ALIGNMENT); + number_redirects++; + debugf(" *"); + ptr = GETHEAD(FROM_SPTR(ptr)); + } + } + if(__predict_false(!SHOULD_FOLLOW(ptr))) { debugf(" -"); continue; } hunk ./src/data/rts/jhc_jgc.h 182 number_ptr++; - entry_t *e = (entry_t *)FROM_SPTR(gc->ptrs[i]) - 1; + entry_t *e = (entry_t *)FROM_SPTR(ptr) - 1; debugf(" %p",(void *)e); hunk ./src/data/rts/jhc_jgc.h 184 - int d; J1S(d,gc_grey,(Word_t)e / GC_BASE); - if(d) - stack.stack[stack.ptr++] = (uintptr_t)e; + ix = (Word_t)e / GC_ALIGNMENT; + J1U(r,gc_allocated,ix); + if(r) { + J1S(r,gc_grey,ix); + if(r) + stack.stack[stack.ptr++] = (uintptr_t)ix * GC_ALIGNMENT; + } } } debugf("\n"); hunk ./src/data/rts/jhc_jgc.h 196 while(stack.ptr) { - uintptr_t ix = stack.stack[--stack.ptr] / GC_BASE; - J1T(r,gc_grey,ix); - assert(r); - debugf("Processing Grey: %p ",(void *)(ix * GC_BASE)); - J1U(r,gc_allocated,ix); - if(__predict_false(r == 0)) { - J1U(r,gc_grey,ix); - debugf("Skipping.\n"); - continue; - } - debugf("Blackening\n"); - //J1S(r,gc_black,ix); + uintptr_t ix = stack.stack[--stack.ptr] / GC_ALIGNMENT; + //J1T(r,gc_grey,ix); + //assert(r); + debugf("Processing Grey: %p\n",(void *)(ix * GC_ALIGNMENT)); hunk ./src/data/rts/jhc_jgc.h 201 - entry_t *e = (entry_t *)(ix * GC_BASE); + entry_t *e = (entry_t *)(ix * GC_ALIGNMENT); int offset = e->u.v.tag ? 1 : 0; stack_check(&stack, e->u.v.nptrs); for(int i = offset; i < e->u.v.nptrs + offset; i++) { hunk ./src/data/rts/jhc_jgc.h 215 if(SHOULD_FOLLOW(e->ptrs[i])) { entry_t * ptr = (entry_t *)(FROM_SPTR(e->ptrs[i])) - 1; debugf("Following: %p %p\n",e->ptrs[i], (void *)ptr); - Word_t p = (Word_t)ptr / GC_BASE; - int d; - J1S(d,gc_grey,p); - if(d) - stack.stack[stack.ptr++] = (uintptr_t)ptr; + Word_t ix = (Word_t)ptr / GC_ALIGNMENT; + J1U(r,gc_allocated,ix); + if(r) { + J1S(r,gc_grey,ix); + if(r) + stack.stack[stack.ptr++] = (uintptr_t)ix * GC_ALIGNMENT; + } } } } hunk ./src/data/rts/jhc_jgc.h 227 free(stack.stack); for(ix = 0, (J1F(r,gc_allocated,ix)); r; (J1N(r,gc_allocated,ix))) { - entry_t *e = (entry_t *)(ix * GC_BASE); + entry_t *e = (entry_t *)(ix * GC_ALIGNMENT); mem_inuse -= (e->u.v.count + 1)*GC_BASE; free(e); } hunk ./src/data/rts/jhc_jgc.h 234 J1FA(r,gc_allocated); gc_allocated = gc_grey; number_allocs = 0; -#if JGC_STATUS - fprintf(stderr, "Ss: %5u Ps: %5u Rs: %5u As: %5u ", number_stack, number_ptr, number_redirects, number_allocs); - gc_print_stats(gc); -#endif + if(JGC_STATUS) { + fprintf(stderr, "Ss: %5u Ps: %5u Rs: %5u As: %5u ", number_stack, number_ptr, number_redirects, number_allocs); + Word_t n_allocated,n_roots; + J1C(n_allocated,gc_allocated,0,-1); + J1C(n_roots,gc_roots,0,-1); + fprintf(stderr,"allocated: %5lu roots: %3lu mem_inuse: %5lu heap_threshold: %5lu gcs: %3u\n",n_allocated,n_roots,(long unsigned)mem_inuse,(long unsigned)heap_threshold,number_gcs); + } profile_pop(&gc_gc_time); } hunk ./src/data/rts/jhc_jgc.h 265 e->u.v.nptrs = nptrs; e->u.v.tag = tag; debugf("allocated: %p %i %i %i\n",(void *)e, count, nptrs, tag); - int r; J1S(r,gc_allocated,(Word_t)e / GC_BASE); + int r; J1S(r,gc_allocated,(Word_t)e / GC_ALIGNMENT); profile_pop(&gc_alloc_time); return (void *)(e + 1); } [store constant parts of the rts as ByteStrings rather than Haskell Strings John Meacham **20100328223258 Ignore-this: 596d1612e4d70c9fbb870aed3134547f ] hunk ./src/C/FromGrin2.hs 39 import Util.UniqueMonad import qualified Cmm.Op as Op import qualified FlagOpts as FO +import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString.UTF8 as BS +import qualified Data.ByteString as BS --------------- hunk ./src/C/FromGrin2.hs 132 -------------- {-# NOINLINE compileGrin #-} -compileGrin :: Grin -> (String,[String]) -compileGrin grin = (hsffi_h ++ jhc_rts_header_h ++ jhc_rts_alloc_c ++ jhc_rts_c ++ jhc_rts2_c ++ generateArchAssertions ++ P.render ans ++ "\n", snub (reqLibraries req)) where +compileGrin :: Grin -> (LBS.ByteString,[String]) +compileGrin grin = (LBS.fromChunks [hsffi_h,jhc_rts_header_h,jhc_rts_alloc_c,jhc_rts_c,jhc_rts2_c,BS.fromString generateArchAssertions,BS.fromString $ P.render ans, BS.fromString "\n"], snub (reqLibraries req)) where ans = vcat $ includes ++ [text "", enum_tag_t, header,cafs, buildConstants cpr grin finalHcHash, body] includes = map include (snub $ reqIncludes req) include fn = text "#include <" <> text fn <> text ">" hunk ./src/Grin/Main.hs 3 module Grin.Main(compileToGrin) where +import Control.Monad import Directory hunk ./src/Grin/Main.hs 5 +import qualified Data.ByteString.Lazy.UTF8 as LBS +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Map as Map +import qualified System hunk ./src/Grin/Main.hs 10 -import Control.Monad import Grin.DeadCode import Grin.Devolve(twiddleGrin,devolveTransform) import Grin.EvalInline(createEvalApply) hunk ./src/Grin/Main.hs 14 import Grin.FromE -import Grin.FromE import Grin.Grin import Grin.Lint import Grin.NodeAnalyze hunk ./src/Grin/Main.hs 18 import Grin.Optimize +import Grin.SSimplify import Grin.Show import Grin.StorageAnalysis import Options hunk ./src/Grin/Main.hs 25 import Support.Transform import Util.Gen import qualified C.FromGrin2 as FG2 -import qualified Data.Map as Map import qualified FlagDump as FD import qualified FlagOpts as FO hunk ./src/Grin/Main.hs 27 -import Grin.SSimplify import qualified Stats hunk ./src/Grin/Main.hs 28 -import qualified System {-# NOINLINE compileToGrin #-} compileToGrin prog = do hunk ./src/Grin/Main.hs 99 comm = shellQuote $ [lup "cc"] ++ words (lup "cflags") ++ ["-o", fn, cf] ++ (map ("-l" ++) rls) ++ debug ++ optCCargs options ++ boehmOpts ++ profileOpts debug = if fopts FO.Debug then words (lup "cflags_debug") else words (lup "cflags_nodebug") - globalvar n c = "char " ++ n ++ "[] = \"" ++ c ++ "\";" + globalvar n c = LBS.fromString $ "char " ++ n ++ "[] = \"" ++ c ++ "\";" putProgressLn ("Writing " ++ show cf) hunk ./src/Grin/Main.hs 101 - writeFile cf $ unlines [globalvar "jhc_c_compile" comm, globalvar "jhc_command" argstring,globalvar "jhc_version" sversion,"",cg] + LBS.writeFile cf $ LBS.intercalate (LBS.fromString "\n") [globalvar "jhc_c_compile" comm, globalvar "jhc_command" argstring,globalvar "jhc_version" sversion,LBS.empty,cg] putProgressLn ("Running: " ++ comm) r <- System.system comm when (r /= System.ExitSuccess) $ fail "C code did not compile." hunk ./src/Ho/Build.hs 19 import Data.Monoid import Data.Tree import Data.Version(Version,parseVersion,showVersion) -import Version.Config(version) import Maybe import Monad import Prelude hiding(print,putStrLn) hunk ./src/Ho/Build.hs 25 import System.IO hiding(print,putStrLn) import System.Mem import Text.Printf +import Version.Config(version) +import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS import qualified Data.ByteString.Lazy.UTF8 as LBSU import qualified Data.Map as Map hunk ./src/Ho/Build.hs 650 m4Prelude :: IO FilePath -m4Prelude = writeFile "/tmp/jhc_prelude.m4" prelude_m4 >> return "/tmp/jhc_prelude.m4" +m4Prelude = BS.writeFile "/tmp/jhc_prelude.m4" prelude_m4 >> return "/tmp/jhc_prelude.m4" langmap = [ "m4" ==> "m4", hunk ./src/Main.hs 8 import IO(hFlush,stderr) import Prelude hiding(putStrLn, putStr,print) import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString.UTF8 as BS import CharIO import DataConstructors hunk ./src/Main.hs 47 ShowHo ho -> dumpHoFile ho Version -> putStrLn versionString PrintHscOptions -> putStrLn $ "-I" ++ VC.datadir ++ "/" ++ VC.package ++ "-" ++ VC.shortVersion ++ "/include" - VersionCtx -> putStrLn (versionString ++ versionContext) + VersionCtx -> putStrLn (versionString ++ BS.toString versionContext) Preprocess -> forM_ (optArgs o) $ \fn -> do LBS.readFile fn >>= preprocess fn >>= LBS.putStr _ -> darg >> processFiles (optArgs o) hunk ./src/Options.hs 42 import System.IO.Unsafe import qualified Data.Map as M import qualified Data.Set as S +import qualified Data.ByteString.UTF8 as BS import RawFiles(targets_ini) import Support.IniParse hunk ./src/Options.hs 328 mapM_ (\ (x,y) -> putStrLn (x ++ ": " ++ y)) configs exitSuccess Just home <- fmap (`mplus` Just "/") $ lookupEnv "HOME" - inis <- parseIniFiles (optVerbose o2 > 0) targets_ini [confDir ++ "/targets.ini", confDir ++ "/targets-local.ini", home ++ "/etc/jhc/targets.ini", home ++ "/.jhc/targets.ini"] (optArch o2) + inis <- parseIniFiles (optVerbose o2 > 0) (BS.toString targets_ini) [confDir ++ "/targets.ini", confDir ++ "/targets-local.ini", home ++ "/etc/jhc/targets.ini", home ++ "/.jhc/targets.ini"] (optArch o2) when (FlagDump.Ini `S.member` optDumpSet o2) $ flip mapM_ (M.toList inis) $ \(a,b) -> putStrLn (a ++ "=" ++ b) let autoloads = maybe [] (tokens (',' ==)) (M.lookup "autoload" inis) o3 = o2 { optArgs = ns, optInis = inis } hunk ./src/Version/Version.hs 10 import Data.Version import System.Info +import qualified Data.ByteString.UTF8 as BS import Version.Config import RawFiles hunk ./src/Version/Version.hs 16 {-# NOINLINE versionSimple #-} -versionSimple = concat [package, " ", version, " (", shortchange_txt, ")"] +versionSimple = concat [package, " ", version, " (", BS.toString shortchange_txt, ")"] {-# NOINLINE versionString #-} versionString = concat [versionSimple, "\n", "compiled by ",compilerName,"-",showVersion compilerVersion," on a ",arch," running ",os] hunk ./utils/op_raw.prl 9 my $mod = shift @ARGV; $mod =~ s/^.*\///; -print "module $mod where\n\n\n"; +print "module $mod where\n\n"; +print "import Data.ByteString.Unsafe\n"; +print "import Data.ByteString\n"; +print "import System.IO.Unsafe\n\n"; while (@ARGV) { my $fn = shift @ARGV; hunk ./utils/op_raw.prl 25 $fn =~ s{/}{\\/}g; print "-- | Generated from $fn on " . `date`; print "{-# NOINLINE $nn #-}\n"; - print "$nn :: String\n"; - print "$nn = \"\\\n \\"; + print "$nn :: ByteString\n"; + print "$nn = unsafePerformIO \$ unsafePackAddress \"\\\n \\"; #print "$nn = \""; while () { s/\\/\\\\/g; hunk ./utils/op_raw.prl 37 print "$_\\\n \\"; } - print "\"\n\n"; + print "\"#\n\n"; } [clean up gc code John Meacham **20100329030742 Ignore-this: e216c60ce9bdc1cc4d9d5363266ed809 ] hunk ./src/data/rts/jhc_jgc.h 14 // #define __predict_false(exp) (exp) // #endif -#include -#include -#include - #define JGC_STATUS 0 #define ALIGN(a,n) ((n) - 1 + ((a) - ((n) - 1) % (a))) hunk ./src/data/rts/jhc_jgc.h 64 #endif +#ifdef NDEBUG +#define JUDYERROR_NOTEST 1 +#endif + #include #include #include hunk ./src/data/rts/jhc_jgc.h 76 #if JGC_STATUS > 1 #define debugf(...) fprintf(stderr,__VA_ARGS__) #else -#define debugf(...) +#define debugf(...) do { } while (0) #endif hunk ./src/data/rts/jhc_jgc.h 174 J1S(r,gc_grey,((uintptr_t)FROM_SPTR(ptr) - sizeof(entry_t))/GC_ALIGNMENT); number_redirects++; debugf(" *"); - ptr = GETHEAD(FROM_SPTR(ptr)); + ptr = (sptr_t)GETHEAD(FROM_SPTR(ptr)); } } if(__predict_false(!SHOULD_FOLLOW(ptr))) { hunk ./src/data/rts/jhc_jgc.h 233 } J1FA(r,gc_allocated); gc_allocated = gc_grey; - number_allocs = 0; if(JGC_STATUS) { hunk ./src/data/rts/jhc_jgc.h 234 - fprintf(stderr, "Ss: %5u Ps: %5u Rs: %5u As: %5u ", number_stack, number_ptr, number_redirects, number_allocs); + fprintf(stderr, "%3u - Ss: %5u Ps: %5u Rs: %5u As: %6u ", number_gcs, number_stack, number_ptr, number_redirects, number_allocs); Word_t n_allocated,n_roots; J1C(n_allocated,gc_allocated,0,-1); J1C(n_roots,gc_roots,0,-1); hunk ./src/data/rts/jhc_jgc.h 238 - fprintf(stderr,"allocated: %5lu roots: %3lu mem_inuse: %5lu heap_threshold: %5lu gcs: %3u\n",n_allocated,n_roots,(long unsigned)mem_inuse,(long unsigned)heap_threshold,number_gcs); + fprintf(stderr,"live: %5lu root: %3lu inuse: %6lu threshold: %6lu\n",n_allocated,n_roots,(long unsigned)mem_inuse,(long unsigned)heap_threshold); } hunk ./src/data/rts/jhc_jgc.h 240 + number_allocs = 0; profile_pop(&gc_gc_time); } hunk ./src/data/rts/jhc_jgc.h 254 gc_perform_gc(gc); if(__predict_false(mem_inuse > ((heap_threshold * 6) / 10))) { heap_threshold *= 2; -#if JGC_STATUS - fprintf(stderr, "Increasing heap threshold to %u bytes because mem usage is %u.\n", (unsigned) heap_threshold, (unsigned)mem_inuse); -#endif + if(JGC_STATUS) + fprintf(stderr, "Increasing heap threshold to %u bytes because mem usage is %u.\n", (unsigned) heap_threshold, (unsigned)mem_inuse); } } entry_t *e = malloc((count + 1)*GC_BASE); [add JHC_RTS_INCLUDE #define to easily recompile generated c code with an alternate rts without recompiling via jhc John Meacham **20100329202732 Ignore-this: 36bc112c53b95ed45779ee2e2038bad1 ] hunk ./src/data/rts/jhc_rts.c 1 +#ifdef JHC_RTS_INCLUDE +#undef JHC_RTS_INCLUDE +#include "jhc_rts.c" +#define JHC_RTS_INCLUDE +#else static void _amain(void); static void jhc_arch_assert(void); hunk ./src/data/rts/jhc_rts.c 253 +#endif hunk ./src/data/rts/jhc_rts2.c 1 +#ifdef JHC_RTS_INCLUDE +#undef JHC_RTS_INCLUDE +#include "jhc_rts2.c" +#define JHC_RTS_INCLUDE +#else /*@Internals hunk ./src/data/rts/jhc_rts2.c 319 +#endif hunk ./src/data/rts/jhc_rts_alloc.c 1 +#ifdef JHC_RTS_INCLUDE +#undef JHC_RTS_INCLUDE +#include "jhc_rts_alloc.c" +#define JHC_RTS_INCLUDE +#else // some default definitions hunk ./src/data/rts/jhc_rts_alloc.c 267 #endif +#endif + + hunk ./src/data/rts/jhc_rts_header.h 1 +#ifdef JHC_RTS_INCLUDE +#undef JHC_RTS_INCLUDE +#include "jhc_rts_header.h" +#define JHC_RTS_INCLUDE +#else // jhc_rts_header.h hunk ./src/data/rts/jhc_rts_header.h 108 #define JHC_isPosix (!JHC_isWindows) +#endif [add support for using a supplimental stack for garbage collectable pointers rather than the C stack John Meacham **20100329205156 Ignore-this: 6fba6d1e4ac1412da75ad9e161f93652 ] hunk ./src/data/rts/jhc_jgc.h 7 #define JGC_H // #if __GNUC_PREREQ__(2, 96) -#define __predict_true(exp) __builtin_expect(!!(exp), 1) -#define __predict_false(exp) __builtin_expect(!!(exp), 0) -// #else -// #define __predict_true(exp) (exp) -// #define __predict_false(exp) (exp) -// #endif +#if 1 +# define __predict_true(exp) __builtin_expect(!!(exp), 1) +# define __predict_false(exp) __builtin_expect(!!(exp), 0) +#else +# define __predict_true(exp) (exp) +# define __predict_false(exp) (exp) +#endif #define JGC_STATUS 0 hunk ./src/data/rts/jhc_jgc.h 44 #define INITIAL_GC NULL +#ifdef JHC_JGC_STACK #define gc_frame0(gc,n,...) struct { struct frame *prev; unsigned nptrs;void *ptrs[n]; } l \ = { gc, n, { __VA_ARGS__ } }; gc_t gc = (gc_t)(void *)&l; hunk ./src/data/rts/jhc_jgc.h 47 - -#define gc_count(ty) (TO_BLOCKS(sizeof(ty))) -#define gc_mk_alloc_tag(ty, np, tag) static inline ty *gc_alloc_ ## ty(gc_t gc) { ty *x = gc_alloc(gc,gc_count(ty),np); gc_tag(x) = tag; return x; } -#define gc_mk_alloc(ty, np) gc_mk_alloc_tag(ty,np,0) -#define gc_mk_alloc_tag_s(ty, np, tag) static inline ty *gc_alloc_ ## ty ## _s(gc_t gc, ty v) { ty *x = gc_alloc(gc,gc_count(ty),np); gc_tag(x) = tag; *x = v; return x; } -#define gc_tag(p) (((entry_header_t *)((void *)p - sizeof(void *)))->tag) +#else +#define gc_frame0(gc,n,...) void *ptrs[n] = { __VA_ARGS__ }; for(int i = 0; i < n; i++) gc[i] = (sptr_t)ptrs[i]; gc_t sgc = gc; gc_t gc = sgc + n; +#endif static void gc_perform_gc(gc_t gc); static void *gc_alloc_tag(gc_t gc,unsigned count, unsigned nptrs, int tag); hunk ./src/data/rts/jhc_jgc.h 79 #endif -static Pvoid_t gc_roots = NULL; // extra roots in addition to the stack -static Pvoid_t gc_allocated = NULL; // black set of currently allocated memory +static Pvoid_t gc_roots = NULL; // extra roots in addition to the stack +static Pvoid_t gc_allocated = NULL; // black set of currently allocated memory static size_t heap_threshold = 2048; // threshold at which we want to run a gc rather than malloc more memory static size_t mem_inuse; // amount of memory in use by gc'ed memory static unsigned number_gcs; // number of garbage collections hunk ./src/data/rts/jhc_jgc.h 131 } } +static void +gc_add_grey(Pvoid_t gc_grey[1], struct stack *stack, uintptr_t ix) +{ + int r; + J1U(r, gc_allocated, ix); + if(r) { + J1S(r, *gc_grey, ix); + if(r) + stack->stack[stack->ptr++] = (uintptr_t)ix * GC_ALIGNMENT; + } +} + static void gc_perform_gc(gc_t gc) { hunk ./src/data/rts/jhc_jgc.h 162 stack_check(&stack, n_roots); int r; for(ix = 0,(J1F(r,gc_roots,ix)); r; (J1N(r,gc_roots,ix))) { debugf(" %p", (void *)(ix * GC_ALIGNMENT)); - J1U(r, gc_allocated, ix); - if(r) { - J1S(r, gc_grey, ix); - if(r) - stack.stack[stack.ptr++] = (uintptr_t)ix * GC_ALIGNMENT; - } + gc_add_grey(&gc_grey, &stack, ix); } debugf("\n"); debugf("Trace:"); hunk ./src/data/rts/jhc_jgc.h 166 +#ifdef JHC_JGC_STACK for(;gc;gc = gc->prev) { debugf(" |"); stack_check(&stack, gc->nptrs); hunk ./src/data/rts/jhc_jgc.h 191 number_ptr++; entry_t *e = (entry_t *)FROM_SPTR(ptr) - 1; debugf(" %p",(void *)e); - ix = (Word_t)e / GC_ALIGNMENT; - J1U(r,gc_allocated,ix); - if(r) { - J1S(r,gc_grey,ix); + gc_add_grey(&gc_grey, &stack, (uintptr_t)e / GC_ALIGNMENT); + } + } +#else + stack_check(&stack, gc - gc_stack_base); + number_stack = gc - gc_stack_base; + for(int i = 0; i < number_stack; i++) { + debugf(" |"); + // TODO - short circuit redirects on stack + sptr_t ptr = gc_stack_base[i]; + if(P_LAZY == GET_PTYPE(ptr)) { + if(!IS_LAZY(GETHEAD(FROM_SPTR(ptr)))) { + J1U(r,gc_allocated,((uintptr_t)FROM_SPTR(ptr) - sizeof(entry_t))/GC_ALIGNMENT); if(r) hunk ./src/data/rts/jhc_jgc.h 205 - stack.stack[stack.ptr++] = (uintptr_t)ix * GC_ALIGNMENT; + J1S(r,gc_grey,((uintptr_t)FROM_SPTR(ptr) - sizeof(entry_t))/GC_ALIGNMENT); + number_redirects++; + debugf(" *"); + ptr = (sptr_t)GETHEAD(FROM_SPTR(ptr)); } } hunk ./src/data/rts/jhc_jgc.h 211 + if(__predict_false(!SHOULD_FOLLOW(ptr))) { + debugf(" -"); + continue; + } + number_ptr++; + entry_t *e = (entry_t *)FROM_SPTR(ptr) - 1; + debugf(" %p",(void *)e); + ix = (Word_t)e / GC_ALIGNMENT; + gc_add_grey(&gc_grey, &stack, ix); } hunk ./src/data/rts/jhc_jgc.h 221 +#endif debugf("\n"); while(stack.ptr) { hunk ./src/data/rts/jhc_jgc.h 226 uintptr_t ix = stack.stack[--stack.ptr] / GC_ALIGNMENT; - //J1T(r,gc_grey,ix); - //assert(r); debugf("Processing Grey: %p\n",(void *)(ix * GC_ALIGNMENT)); entry_t *e = (entry_t *)(ix * GC_ALIGNMENT); hunk ./src/data/rts/jhc_jgc.h 239 e->ptrs[i] = GETHEAD(FROM_SPTR(e->ptrs[i])); } } - if(SHOULD_FOLLOW(e->ptrs[i])) { + if(__predict_true(SHOULD_FOLLOW(e->ptrs[i]))) { entry_t * ptr = (entry_t *)(FROM_SPTR(e->ptrs[i])) - 1; debugf("Following: %p %p\n",e->ptrs[i], (void *)ptr); hunk ./src/data/rts/jhc_jgc.h 242 - Word_t ix = (Word_t)ptr / GC_ALIGNMENT; - J1U(r,gc_allocated,ix); - if(r) { - J1S(r,gc_grey,ix); - if(r) - stack.stack[stack.ptr++] = (uintptr_t)ix * GC_ALIGNMENT; - } + gc_add_grey(&gc_grey, &stack, (uintptr_t)ptr / GC_ALIGNMENT); } } } hunk ./src/data/rts/jhc_jgc.h 259 Word_t n_allocated,n_roots; J1C(n_allocated,gc_allocated,0,-1); J1C(n_roots,gc_roots,0,-1); - fprintf(stderr,"live: %5lu root: %3lu inuse: %6lu threshold: %6lu\n",n_allocated,n_roots,(long unsigned)mem_inuse,(long unsigned)heap_threshold); +#ifdef JHC_JGC_STACK + void * gc_stack_base = &gc_stack_base; +#endif + fprintf(stderr,"live: %5lu root: %3lu inuse: %6lu threshold: %6lu %p %p\n",n_allocated,n_roots,(long unsigned)mem_inuse,(long unsigned)heap_threshold, gc_stack_base, gc); } number_allocs = 0; profile_pop(&gc_gc_time); hunk ./src/data/rts/jhc_rts_alloc.c 82 static unsigned mem_chunks,mem_offset; -static inline void -jhc_malloc_init(void) { return; } +#define jhc_malloc_init() do { } while(0) static void jhc_alloc_print_stats(void) { hunk ./src/data/rts/jhc_rts_alloc.c 147 #if _JHC_GC == _JHC_GC_JGC +#ifdef JHC_JGC_STACK typedef struct frame *gc_t; hunk ./src/data/rts/jhc_rts_alloc.c 149 +#else +typedef void* *gc_t; +#endif static gc_t saved_gc; hunk ./src/data/rts/jhc_rts_alloc.c 154 +#ifndef JHC_JGC_STACK +static gc_t gc_stack_base; +#undef jhc_malloc_init +static void +jhc_malloc_init(void) { + saved_gc = gc_stack_base = malloc(8*8192*sizeof(gc_stack_base[0])); +} + +#endif + // #define GC_STACK_LIMIT 8192 // `static sptr_t *gc_stack_base; [split up gc rts file into c and h files, handle it similarly to other rts files, clean up code. John Meacham **20100329215133 Ignore-this: 8ac1988fc3d408fcb956c1cd01b4d984 ] addfile ./src/data/rts/jhc_jgc.c hunk ./Makefile.am 108 UTILS = utils/op_process.prl utils/opt_sets.prl utils/gen_props.prl utils/op_names.prl utils/op_raw.prl -RAWFILES = src/data/HsFFI.h src/data/rts/jhc_rts.c src/data/rts/jhc_rts_header.h src/data/wsize.h src/data/rts/jhc_rts_alloc.c src/data/rts/jhc_rts2.c src/data/ViaGhc.hs ChangeLog src/data/shortchange.txt src/data/prelude.m4 src/data/targets.ini +RAWFILES = src/data/HsFFI.h src/data/rts/jhc_rts.c src/data/rts/jhc_rts_header.h src/data/wsize.h src/data/rts/jhc_rts_alloc.c src/data/rts/jhc_rts2.c src/data/ViaGhc.hs ChangeLog src/data/shortchange.txt src/data/prelude.m4 src/data/targets.ini src/data/rts/jhc_jgc.h src/data/rts/jhc_jgc.c DRIFTFILES = drift_processed/C/FFI.hs drift_processed/C/FromGrin2.hs drift_processed/Cmm/Op.hs drift_processed/C/Prims.hs drift_processed/DataConstructors.hs \ drift_processed/DerivingDrift/StandardRules.hs drift_processed/E/CPR.hs drift_processed/E/Demand.hs drift_processed/E/LambdaLift.hs \ hunk ./src/C/FromGrin2.hs 133 {-# NOINLINE compileGrin #-} compileGrin :: Grin -> (LBS.ByteString,[String]) -compileGrin grin = (LBS.fromChunks [hsffi_h,jhc_rts_header_h,jhc_rts_alloc_c,jhc_rts_c,jhc_rts2_c,BS.fromString generateArchAssertions,BS.fromString $ P.render ans, BS.fromString "\n"], snub (reqLibraries req)) where +compileGrin grin = (LBS.fromChunks [hsffi_h,jhc_rts_header_h,jhc_jgc_h,jhc_rts_alloc_c,jhc_rts_c,jhc_rts2_c,jhc_jgc_c,BS.fromString generateArchAssertions,BS.fromString $ P.render ans, BS.fromString "\n"], snub (reqLibraries req)) where ans = vcat $ includes ++ [text "", enum_tag_t, header,cafs, buildConstants cpr grin finalHcHash, body] includes = map include (snub $ reqIncludes req) include fn = text "#include <" <> text fn <> text ">" hunk ./src/data/rts/jhc_jgc.c 1 +#ifdef JHC_RTS_INCLUDE +#undef JHC_RTS_INCLUDE +#include "jhc_jgc.c" +#define JHC_RTS_INCLUDE +#else +#if _JHC_GC == _JHC_GC_JGC + + +#define TO_BLOCKS(x) ((x) <= GC_MINIMUM_SIZE*GC_BASE ? GC_MINIMUM_SIZE : (((x) - 1)/GC_BASE) + 1) + + +#ifdef JHC_JGC_STACK +#define gc_frame0(gc,n,...) struct { struct frame *prev; unsigned nptrs;void *ptrs[n]; } l \ + = { gc, n, { __VA_ARGS__ } }; gc_t gc = (gc_t)(void *)&l; +#else +#define gc_frame0(gc,n,...) void *ptrs[n] = { __VA_ARGS__ }; for(int i = 0; i < n; i++) gc[i] = (sptr_t)ptrs[i]; gc_t sgc = gc; gc_t gc = sgc + n; +#endif + +static void gc_perform_gc(gc_t gc); +static void *gc_alloc_tag(gc_t gc,unsigned count, unsigned nptrs, int tag); + + +static Pvoid_t gc_roots = NULL; // extra roots in addition to the stack +static Pvoid_t gc_allocated = NULL; // black set of currently allocated memory +static size_t heap_threshold = 2048; // threshold at which we want to run a gc rather than malloc more memory +static size_t mem_inuse; // amount of memory in use by gc'ed memory +static unsigned number_gcs; // number of garbage collections +static unsigned number_allocs; // number of allocations since last garbage collection + +#define SHOULD_FOLLOW(w) IS_PTR(w) + +typedef struct { + union { + entry_header_t v; + void * _dummy; + } u; + void * ptrs[0]; +} entry_t; + + +static bool +gc_add_root(gc_t gc, void *root) +{ + if(SHOULD_FOLLOW(root)) { + int r; J1S(r,gc_roots,(((Word_t)root - sizeof(entry_t)) / GC_ALIGNMENT)); + return (bool)r; + } else + return false; +} + + +struct stack { + unsigned size; + unsigned ptr; + uintptr_t *stack; +}; + +#define EMPTY_STACK { 0, 0, NULL } + +static void +stack_check(struct stack *s, unsigned n) { + if(__predict_false(s->size - s->ptr < n)) { + s->size += 1024 + n; + s->stack = realloc(s->stack, sizeof(uintptr_t)*s->size); + assert(s->stack); + debugf("stack:"); + for(unsigned i = 0; i < s->ptr; i++) { + debugf(" %p", (void *)s->stack[i]); + } + debugf("\n"); + } +} + +static void +gc_add_grey(Pvoid_t gc_grey[1], struct stack *stack, uintptr_t ix) +{ + int r; + J1U(r, gc_allocated, ix); + if(r) { + J1S(r, *gc_grey, ix); + if(r) + stack->stack[stack->ptr++] = (uintptr_t)ix * GC_ALIGNMENT; + } +} + +static void +gc_perform_gc(gc_t gc) +{ + profile_push(&gc_gc_time); + number_gcs++; + + unsigned number_redirects = 0; + unsigned number_stack = 0; + unsigned number_ptr = 0; + struct stack stack = EMPTY_STACK; + + Pvoid_t gc_grey = NULL; + Word_t ix; + debugf("Setting Roots:"); + Word_t n_roots; + J1C(n_roots,gc_roots,0,-1); + stack_check(&stack, n_roots); + int r; for(ix = 0,(J1F(r,gc_roots,ix)); r; (J1N(r,gc_roots,ix))) { + debugf(" %p", (void *)(ix * GC_ALIGNMENT)); + gc_add_grey(&gc_grey, &stack, ix); + } + debugf("\n"); + debugf("Trace:"); +#ifdef JHC_JGC_STACK + for(;gc;gc = gc->prev) { + debugf(" |"); + stack_check(&stack, gc->nptrs); + for(unsigned i = 0;i < gc->nptrs; i++) { + number_stack++; + // TODO - short circuit redirects on stack + sptr_t ptr = gc->ptrs[i]; + if(P_LAZY == GET_PTYPE(ptr)) { + if(!IS_LAZY(GETHEAD(FROM_SPTR(ptr)))) { + J1U(r,gc_allocated,((uintptr_t)FROM_SPTR(ptr) - sizeof(entry_t))/GC_ALIGNMENT); + if(r) + J1S(r,gc_grey,((uintptr_t)FROM_SPTR(ptr) - sizeof(entry_t))/GC_ALIGNMENT); + number_redirects++; + debugf(" *"); + ptr = (sptr_t)GETHEAD(FROM_SPTR(ptr)); + } + } + if(__predict_false(!SHOULD_FOLLOW(ptr))) { + debugf(" -"); + continue; + } + number_ptr++; + entry_t *e = (entry_t *)FROM_SPTR(ptr) - 1; + debugf(" %p",(void *)e); + gc_add_grey(&gc_grey, &stack, (uintptr_t)e / GC_ALIGNMENT); + } + } +#else + stack_check(&stack, gc - gc_stack_base); + number_stack = gc - gc_stack_base; + for(unsigned i = 0; i < number_stack; i++) { + debugf(" |"); + // TODO - short circuit redirects on stack + sptr_t ptr = gc_stack_base[i]; + if(P_LAZY == GET_PTYPE(ptr)) { + if(!IS_LAZY(GETHEAD(FROM_SPTR(ptr)))) { + J1U(r,gc_allocated,((uintptr_t)FROM_SPTR(ptr) - sizeof(entry_t))/GC_ALIGNMENT); + if(r) + J1S(r,gc_grey,((uintptr_t)FROM_SPTR(ptr) - sizeof(entry_t))/GC_ALIGNMENT); + number_redirects++; + debugf(" *"); + ptr = (sptr_t)GETHEAD(FROM_SPTR(ptr)); + } + } + if(__predict_false(!SHOULD_FOLLOW(ptr))) { + debugf(" -"); + continue; + } + number_ptr++; + entry_t *e = (entry_t *)FROM_SPTR(ptr) - 1; + debugf(" %p",(void *)e); + ix = (Word_t)e / GC_ALIGNMENT; + gc_add_grey(&gc_grey, &stack, ix); + } +#endif + debugf("\n"); + + while(stack.ptr) { + uintptr_t ix = stack.stack[--stack.ptr] / GC_ALIGNMENT; + debugf("Processing Grey: %p\n",(void *)(ix * GC_ALIGNMENT)); + + entry_t *e = (entry_t *)(ix * GC_ALIGNMENT); + int offset = e->u.v.tag ? 1 : 0; + stack_check(&stack, e->u.v.nptrs); + for(int i = offset; i < e->u.v.nptrs + offset; i++) { + if(P_LAZY == GET_PTYPE(e->ptrs[i])) { + if(!IS_LAZY(GETHEAD(FROM_SPTR(e->ptrs[i])))) { + number_redirects++; + debugf(" *"); + e->ptrs[i] = GETHEAD(FROM_SPTR(e->ptrs[i])); + } + } + if(__predict_true(SHOULD_FOLLOW(e->ptrs[i]))) { + entry_t * ptr = (entry_t *)(FROM_SPTR(e->ptrs[i])) - 1; + debugf("Following: %p %p\n",e->ptrs[i], (void *)ptr); + gc_add_grey(&gc_grey, &stack, (uintptr_t)ptr / GC_ALIGNMENT); + } + } + } + free(stack.stack); + for(ix = 0, (J1F(r,gc_allocated,ix)); r; (J1N(r,gc_allocated,ix))) { + entry_t *e = (entry_t *)(ix * GC_ALIGNMENT); + mem_inuse -= (e->u.v.count + 1)*GC_BASE; + free(e); + } + J1FA(r,gc_allocated); + gc_allocated = gc_grey; + if(JGC_STATUS) { + fprintf(stderr, "%3u - Ss: %5u Ps: %5u Rs: %5u As: %6u ", number_gcs, number_stack, number_ptr, number_redirects, number_allocs); + Word_t n_allocated,n_roots; + J1C(n_allocated,gc_allocated,0,-1); + J1C(n_roots,gc_roots,0,-1); +#ifdef JHC_JGC_STACK + void * gc_stack_base = &gc_stack_base; +#endif + fprintf(stderr,"live: %5lu root: %3lu inuse: %6lu threshold: %6lu %p %p\n",n_allocated,n_roots,(long unsigned)mem_inuse,(long unsigned)heap_threshold, gc_stack_base, gc); + } + number_allocs = 0; + profile_pop(&gc_gc_time); +} + +static void * +gc_alloc_tag(gc_t gc,unsigned count, unsigned nptrs, int tag) +{ + profile_push(&gc_alloc_time); + number_allocs++; + assert(nptrs <= count); + if(__predict_false(mem_inuse > heap_threshold)) { + gc_perform_gc(gc); + if(__predict_false(mem_inuse > ((heap_threshold * 6) / 10))) { + heap_threshold *= 2; + if(JGC_STATUS) + fprintf(stderr, "Increasing heap threshold to %u bytes because mem usage is %u.\n", (unsigned) heap_threshold, (unsigned)mem_inuse); + } + } + entry_t *e = malloc((count + 1)*GC_BASE); + mem_inuse += (count + 1)*GC_BASE; + e->u.v.count = count; + e->u.v.nptrs = nptrs; + e->u.v.tag = tag; + debugf("allocated: %p %i %i %i\n",(void *)e, count, nptrs, tag); + int r; J1S(r,gc_allocated,(Word_t)e / GC_ALIGNMENT); + profile_pop(&gc_alloc_time); + return (void *)(e + 1); +} + +// static void * +// gc_alloc_bytes(gc_t gc,size_t count) { +// return gc_alloc_tag(gc, TO_BLOCKS(count), 0, 0); +// } + +static void jhc_alloc_print_stats(void) { } + +#ifdef JHC_JGC_STACK +static void jhc_malloc_init(void) { } +#else +static void +jhc_malloc_init(void) { + saved_gc = gc_stack_base = malloc(8*8192*sizeof(gc_stack_base[0])); +} +#endif + +#endif +#endif hunk ./src/data/rts/jhc_jgc.h 2 +#ifdef JHC_RTS_INCLUDE +#undef JHC_RTS_INCLUDE +#include "jhc_jgc.h" +#define JHC_RTS_INCLUDE +#else + +#if _JHC_GC == _JHC_GC_JGC + +#define JGC_STATUS 0 + + +#ifdef JHC_JGC_STACK + +struct frame { + struct frame *prev; + unsigned nptrs; + void *ptrs[0]; +}; hunk ./src/data/rts/jhc_jgc.h 21 -#ifndef JGC_H -#define JGC_H +typedef struct frame *gc_t; hunk ./src/data/rts/jhc_jgc.h 23 -// #if __GNUC_PREREQ__(2, 96) -#if 1 -# define __predict_true(exp) __builtin_expect(!!(exp), 1) -# define __predict_false(exp) __builtin_expect(!!(exp), 0) #else hunk ./src/data/rts/jhc_jgc.h 24 -# define __predict_true(exp) (exp) -# define __predict_false(exp) (exp) + +typedef void* *gc_t; + +#endif + +static gc_t saved_gc; + +#ifndef JHC_JGC_STACK +static gc_t gc_stack_base; #endif hunk ./src/data/rts/jhc_jgc.h 35 -#define JGC_STATUS 0 #define ALIGN(a,n) ((n) - 1 + ((a) - ((n) - 1) % (a))) hunk ./src/data/rts/jhc_jgc.h 44 uint16_t tag; } entry_header_t; -struct frame { - struct frame *prev; - unsigned nptrs; - void *ptrs[0]; -}; // round all allocations up to this many blocks. hunk ./src/data/rts/jhc_jgc.h 56 #define TO_BLOCKS(x) ((x) <= GC_MINIMUM_SIZE*GC_BASE ? GC_MINIMUM_SIZE : (((x) - 1)/GC_BASE) + 1) -#define INITIAL_GC NULL hunk ./src/data/rts/jhc_jgc.h 57 -#ifdef JHC_JGC_STACK -#define gc_frame0(gc,n,...) struct { struct frame *prev; unsigned nptrs;void *ptrs[n]; } l \ - = { gc, n, { __VA_ARGS__ } }; gc_t gc = (gc_t)(void *)&l; -#else -#define gc_frame0(gc,n,...) void *ptrs[n] = { __VA_ARGS__ }; for(int i = 0; i < n; i++) gc[i] = (sptr_t)ptrs[i]; gc_t sgc = gc; gc_t gc = sgc + n; -#endif static void gc_perform_gc(gc_t gc); static void *gc_alloc_tag(gc_t gc,unsigned count, unsigned nptrs, int tag); hunk ./src/data/rts/jhc_jgc.h 61 -static inline void * -gc_alloc_bytes(gc_t gc,size_t count) { - return gc_alloc_tag(gc, TO_BLOCKS(count), 0, 0); -} - - -#endif #ifdef NDEBUG hunk ./src/data/rts/jhc_jgc.h 68 #endif #include -#include -#include #if JGC_STATUS > 1 hunk ./src/data/rts/jhc_jgc.h 77 #endif -static Pvoid_t gc_roots = NULL; // extra roots in addition to the stack -static Pvoid_t gc_allocated = NULL; // black set of currently allocated memory -static size_t heap_threshold = 2048; // threshold at which we want to run a gc rather than malloc more memory -static size_t mem_inuse; // amount of memory in use by gc'ed memory -static unsigned number_gcs; // number of garbage collections -static unsigned number_allocs; // number of allocations since last garbage collection - -#define SHOULD_FOLLOW(w) IS_PTR(w) - -typedef struct { - union { - entry_header_t v; - void * _dummy; - } u; - void * ptrs[0]; -} entry_t; - - -static bool -gc_add_root(gc_t gc, void *root) -{ - if(SHOULD_FOLLOW(root)) { - int r; J1S(r,gc_roots,(((Word_t)root - sizeof(entry_t)) / GC_ALIGNMENT)); - return (bool)r; - } else - return false; -} - - - -struct stack { - unsigned size; - unsigned ptr; - uintptr_t *stack; -}; hunk ./src/data/rts/jhc_jgc.h 78 -#define EMPTY_STACK { 0, 0, NULL } - -static void -stack_check(struct stack *s, unsigned n) { - if(__predict_false(s->size - s->ptr < n)) { - s->size += 1024 + n; - s->stack = realloc(s->stack, sizeof(uintptr_t)*s->size); - assert(s->stack); - debugf("stack:"); - for(unsigned i = 0; i < s->ptr; i++) { - debugf(" %p", (void *)s->stack[i]); - } - debugf("\n"); - } -} - -static void -gc_add_grey(Pvoid_t gc_grey[1], struct stack *stack, uintptr_t ix) -{ - int r; - J1U(r, gc_allocated, ix); - if(r) { - J1S(r, *gc_grey, ix); - if(r) - stack->stack[stack->ptr++] = (uintptr_t)ix * GC_ALIGNMENT; - } -} - -static void -gc_perform_gc(gc_t gc) -{ - profile_push(&gc_gc_time); - number_gcs++; - - unsigned number_redirects = 0; - unsigned number_stack = 0; - unsigned number_ptr = 0; - struct stack stack = EMPTY_STACK; - - Pvoid_t gc_grey = NULL; - Word_t ix; - debugf("Setting Roots:"); - Word_t n_roots; - J1C(n_roots,gc_roots,0,-1); - stack_check(&stack, n_roots); - int r; for(ix = 0,(J1F(r,gc_roots,ix)); r; (J1N(r,gc_roots,ix))) { - debugf(" %p", (void *)(ix * GC_ALIGNMENT)); - gc_add_grey(&gc_grey, &stack, ix); - } - debugf("\n"); - debugf("Trace:"); -#ifdef JHC_JGC_STACK - for(;gc;gc = gc->prev) { - debugf(" |"); - stack_check(&stack, gc->nptrs); - for(unsigned i = 0;i < gc->nptrs; i++) { - number_stack++; - // TODO - short circuit redirects on stack - sptr_t ptr = gc->ptrs[i]; - if(P_LAZY == GET_PTYPE(ptr)) { - if(!IS_LAZY(GETHEAD(FROM_SPTR(ptr)))) { - J1U(r,gc_allocated,((uintptr_t)FROM_SPTR(ptr) - sizeof(entry_t))/GC_ALIGNMENT); - if(r) - J1S(r,gc_grey,((uintptr_t)FROM_SPTR(ptr) - sizeof(entry_t))/GC_ALIGNMENT); - number_redirects++; - debugf(" *"); - ptr = (sptr_t)GETHEAD(FROM_SPTR(ptr)); - } - } - if(__predict_false(!SHOULD_FOLLOW(ptr))) { - debugf(" -"); - continue; - } - number_ptr++; - entry_t *e = (entry_t *)FROM_SPTR(ptr) - 1; - debugf(" %p",(void *)e); - gc_add_grey(&gc_grey, &stack, (uintptr_t)e / GC_ALIGNMENT); - } - } -#else - stack_check(&stack, gc - gc_stack_base); - number_stack = gc - gc_stack_base; - for(int i = 0; i < number_stack; i++) { - debugf(" |"); - // TODO - short circuit redirects on stack - sptr_t ptr = gc_stack_base[i]; - if(P_LAZY == GET_PTYPE(ptr)) { - if(!IS_LAZY(GETHEAD(FROM_SPTR(ptr)))) { - J1U(r,gc_allocated,((uintptr_t)FROM_SPTR(ptr) - sizeof(entry_t))/GC_ALIGNMENT); - if(r) - J1S(r,gc_grey,((uintptr_t)FROM_SPTR(ptr) - sizeof(entry_t))/GC_ALIGNMENT); - number_redirects++; - debugf(" *"); - ptr = (sptr_t)GETHEAD(FROM_SPTR(ptr)); - } - } - if(__predict_false(!SHOULD_FOLLOW(ptr))) { - debugf(" -"); - continue; - } - number_ptr++; - entry_t *e = (entry_t *)FROM_SPTR(ptr) - 1; - debugf(" %p",(void *)e); - ix = (Word_t)e / GC_ALIGNMENT; - gc_add_grey(&gc_grey, &stack, ix); - } #endif hunk ./src/data/rts/jhc_jgc.h 79 - debugf("\n"); - - while(stack.ptr) { - uintptr_t ix = stack.stack[--stack.ptr] / GC_ALIGNMENT; - debugf("Processing Grey: %p\n",(void *)(ix * GC_ALIGNMENT)); - - entry_t *e = (entry_t *)(ix * GC_ALIGNMENT); - int offset = e->u.v.tag ? 1 : 0; - stack_check(&stack, e->u.v.nptrs); - for(int i = offset; i < e->u.v.nptrs + offset; i++) { - if(P_LAZY == GET_PTYPE(e->ptrs[i])) { - if(!IS_LAZY(GETHEAD(FROM_SPTR(e->ptrs[i])))) { - number_redirects++; - debugf(" *"); - e->ptrs[i] = GETHEAD(FROM_SPTR(e->ptrs[i])); - } - } - if(__predict_true(SHOULD_FOLLOW(e->ptrs[i]))) { - entry_t * ptr = (entry_t *)(FROM_SPTR(e->ptrs[i])) - 1; - debugf("Following: %p %p\n",e->ptrs[i], (void *)ptr); - gc_add_grey(&gc_grey, &stack, (uintptr_t)ptr / GC_ALIGNMENT); - } - } - } - free(stack.stack); - for(ix = 0, (J1F(r,gc_allocated,ix)); r; (J1N(r,gc_allocated,ix))) { - entry_t *e = (entry_t *)(ix * GC_ALIGNMENT); - mem_inuse -= (e->u.v.count + 1)*GC_BASE; - free(e); - } - J1FA(r,gc_allocated); - gc_allocated = gc_grey; - if(JGC_STATUS) { - fprintf(stderr, "%3u - Ss: %5u Ps: %5u Rs: %5u As: %6u ", number_gcs, number_stack, number_ptr, number_redirects, number_allocs); - Word_t n_allocated,n_roots; - J1C(n_allocated,gc_allocated,0,-1); - J1C(n_roots,gc_roots,0,-1); -#ifdef JHC_JGC_STACK - void * gc_stack_base = &gc_stack_base; #endif hunk ./src/data/rts/jhc_jgc.h 80 - fprintf(stderr,"live: %5lu root: %3lu inuse: %6lu threshold: %6lu %p %p\n",n_allocated,n_roots,(long unsigned)mem_inuse,(long unsigned)heap_threshold, gc_stack_base, gc); - } - number_allocs = 0; - profile_pop(&gc_gc_time); -} - -static void * -gc_alloc_tag(gc_t gc,unsigned count, unsigned nptrs, int tag) -{ - profile_push(&gc_alloc_time); - number_allocs++; - assert(nptrs <= count); - if(__predict_false(mem_inuse > heap_threshold)) { - gc_perform_gc(gc); - if(__predict_false(mem_inuse > ((heap_threshold * 6) / 10))) { - heap_threshold *= 2; - if(JGC_STATUS) - fprintf(stderr, "Increasing heap threshold to %u bytes because mem usage is %u.\n", (unsigned) heap_threshold, (unsigned)mem_inuse); - } - } - entry_t *e = malloc((count + 1)*GC_BASE); - mem_inuse += (count + 1)*GC_BASE; - e->u.v.count = count; - e->u.v.nptrs = nptrs; - e->u.v.tag = tag; - debugf("allocated: %p %i %i %i\n",(void *)e, count, nptrs, tag); - int r; J1S(r,gc_allocated,(Word_t)e / GC_ALIGNMENT); - profile_pop(&gc_alloc_time); - return (void *)(e + 1); -} - hunk ./src/data/rts/jhc_rts2.c 266 return (wptr_t)s; } -#if _JHC_GC == _JHC_GC_JGC -#include "src/data/rts/jhc_jgc.h" -#endif - static wptr_t A_STD A_UNUSED A_HOT #if _JHC_GC == _JHC_GC_JGC eval(gc_t gc,sptr_t s) hunk ./src/data/rts/jhc_rts_alloc.c 7 #define JHC_RTS_INCLUDE #else +static void jhc_malloc_init(void); +static void jhc_alloc_print_stats(void); + // some default definitions #define jhc_malloc_whnf jhc_malloc hunk ./src/data/rts/jhc_rts_alloc.c 21 extern void _start,_end; + +#ifdef JHC_ALLOC_NEEDS_STUBS void hs_perform_gc(void) {} void hs_free_stable_ptr(HsStablePtr sp) {} void hs_free_fun_ptr(HsFunPtr fp) {} hunk ./src/data/rts/jhc_rts_alloc.c 26 +#endif #if _JHC_PROFILE hunk ./src/data/rts/jhc_rts_alloc.c 77 static inline void jhc_malloc_init(void) { GC_INIT(); } static inline void jhc_alloc_print_stats(void) { GC_dump(); } -#elif _JHC_GC == _JHC_GC_NONE || _JHC_GC == _JHC_GC_JGC +#elif _JHC_GC == _JHC_GC_NONE // memory allocated in 1MB chunks. #define JHC_MEM_CHUNK_SIZE (1 << 20) hunk ./src/data/rts/jhc_rts_alloc.c 149 } #endif -#endif - -#if _JHC_GC == _JHC_GC_JGC - -#ifdef JHC_JGC_STACK -typedef struct frame *gc_t; -#else -typedef void* *gc_t; -#endif -static gc_t saved_gc; - -#ifndef JHC_JGC_STACK -static gc_t gc_stack_base; -#undef jhc_malloc_init -static void -jhc_malloc_init(void) { - saved_gc = gc_stack_base = malloc(8*8192*sizeof(gc_stack_base[0])); -} - -#endif - -// #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); -// } #elif _JHC_GC == _JHC_GC_REGION hunk ./src/data/rts/jhc_rts_header.h 60 // GNU attributes +#ifdef __GNUC__ +# define __predict_true(exp) __builtin_expect(!!(exp), 1) +# define __predict_false(exp) __builtin_expect(!!(exp), 0) +#else +# define __predict_true(exp) (exp) +# define __predict_false(exp) (exp) +#endif #ifdef __GNUC__ #define A_ALIGNED __attribute__ ((aligned)) Context: [GC cleanups John Meacham **20100327185913 Ignore-this: a54268e31dc24ba007829a110bde67f5 ] [greatly simplify garbage collection algorithm, trust underlying malloc implementation more. John Meacham **20100327185011 Ignore-this: 6fcbd7449f187ab148d9c3c08232b2cd ] [short circuit redirects in the garbage collector John Meacham **20100327044542 Ignore-this: 836b0fd0c0e7c0999723b5f2648b89e3 ] [save gc pointer in evaluator function rather than in eval itself John Meacham **20100327021222 Ignore-this: 554d0ca6576d8467741ce6243782cf97 ] [fix GC bugs so garbage collection works John Meacham **20100327005713 Ignore-this: 4f0b2cc940c1e6223b56276aee18d3f5 ] [remove caf initialization from main routine, let cafs be statically initialized. John Meacham **20100327000012 Ignore-this: 257f92957d68790ed69ff5e8b53d549a ] [add a lot more of jgc garbage collector John Meacham **20100320005531 Ignore-this: 5a233c4c3ede86aa398bb66002f20a2d ] [don't allocate on the stack when using jgc yet John Meacham **20100320005502 Ignore-this: a53083bcc2267022fada38cdc99dbc3 ] [include free variables of allocating command when figuring out what to save John Meacham **20100320005417 Ignore-this: ae514b3855b2790c50e4eeaee2c67eb ] [add some more ToExpression instances John Meacham **20100320001034 Ignore-this: 27fafe7a4c355fa6cf2a14f62774dd10 ] [omit discriminator when it isn't important in structures John Meacham **20100319054850 Ignore-this: 5b7eb5c905d946d4c32f3e1d06eb2e95 ] [when storing values inside of smart pointers, be sure to use the proper signedness when extracting/inserting values John Meacham **20100319021048 Ignore-this: 709af4301eed95813a0a9d57a7dda13e ] [redo documentation of internals, clean up terminology dealing with smart pointers John Meacham **20100318230404 Ignore-this: c0bd01a9d8129db5d4097cf2ba86e9c9 ] [produce more compact C names from Grin John Meacham **20100318230254 Ignore-this: cfca768d7e4d957792581486c035d0e3 ] [add gc argument to be passed around for gc context when using jgc John Meacham **20100303100826 Ignore-this: fd804f8ea446f671dd8cd0a0dfe83531 ] [move core compilation code to E.Main, out of Main John Meacham **20100301210817 Ignore-this: 2030663cfb9500ec6ee2f23e9634e4c1 ] [fix warnings John Meacham **20100301210754 Ignore-this: 827e4966af1fdc6730528fc4e6522c60 ] [add support for ghc 6.12 John Meacham **20100301003819 Ignore-this: 528368518e97e273dc5859742c2ab9c7 ] [TAG 0.7.3 John Meacham **20100228231444 Ignore-this: af492cb9e2fd814cd6d774184b657ae8 ] Patch bundle hash: 61088db6831891453859b8f29db247de9e85d99a