Tue Feb 21 05:23:13 PST 2012 John Meacham <[email protected]> * implement finalizers in the RTS, add foreignptr rts routines, properly set saved_gc on safe ffi calls
New patches:
[implement finalizers in the RTS, add foreignptr rts routines, properly set saved_gc on safe ffi calls John Meacham <[email protected]>**20120221132313 Ignore-this: 1a27919674abc4a6955c245eec88aaf9 ] hunk ./Makefile.am 117 rts/sys/wsize.h rts/sys/bitarray.h ChangeLog src/data/shortchange.txt rts/rts/slub.c \ rts/rts/gc_jgc.c rts/rts/gc_jgc.h rts/rts/profile.c rts/rts/profile.h rts/rts/cdefs.h rts/rts/rts_support.c \ rts/rts/rts_support.h rts/rts/gc.h rts/rts/gc_none.c rts/rts/gc_none.h rts/rts/jhc_rts.c rts/rts/jhc_rts.h \ - rts/lib/lib_cbits.c rts/jhc_rts_header.h rts/lib/lib_cbits.h + rts/lib/lib_cbits.c rts/jhc_rts_header.h rts/lib/lib_cbits.h rts/rts/gc_jgc_internal.h 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 ./lib/jhc/System/Mem.hs 7 import Jhc.Prim.IO -foreign import ccall "hs_perform_gc" performGC :: IO () +foreign import ccall safe "hs_perform_gc" performGC :: IO () hunk ./rts/rts/constants.h 30 // of things. // virtual flag to indicate location is a value -#define SLAB_VIRTUAL_VALUE 256 +#define SLAB_VIRTUAL_VALUE 256 // virtual flag to indicate location has a special intererpretation. hunk ./rts/rts/constants.h 33 -#define SLAB_VIRTUAL_SPECIAL 512 +#define SLAB_VIRTUAL_SPECIAL 512 // virtual flag to indication location is a constant. hunk ./rts/rts/constants.h 36 -#define SLAB_VIRTUAL_CONSTANT 1024 +#define SLAB_VIRTUAL_CONSTANT 1024 + +// virtual flag to indication location has been freed. (for debugging) +#define SLAB_VIRTUAL_FREED 2048 + +// virtual flag to indication location is lazy. +#define SLAB_VIRTUAL_LAZY 4096 + +// virtual flag to indication location is func. +#define SLAB_VIRTUAL_FUNC 8192 #endif hunk ./rts/rts/gc_jgc.c 6 #include "sys/bitarray.h" #include "rts/cdefs.h" #include "rts/constants.h" +#include "rts/gc_jgc_internal.h" #if _JHC_GC == _JHC_GC_JGC hunk ./rts/rts/gc_jgc.c 10 -struct s_arena { - struct s_megablock *current_megablock; - SLIST_HEAD(,s_block) free_blocks; - unsigned block_used; - unsigned block_threshold; - SLIST_HEAD(,s_cache) caches; - SLIST_HEAD(,s_block) monolithic_blocks; - SLIST_HEAD(,s_megablock) megablocks; - unsigned number_gcs; // number of garbage collections - unsigned number_allocs; // number of allocations since last garbage collection -}; - -struct s_megablock { - void *base; - unsigned next_free; - SLIST_ENTRY(s_megablock) next; -}; - -struct s_block { - SLIST_ENTRY(s_block) link; - unsigned char flags; // defined in rts/constants.h - unsigned char color; // offset in words to first entry. - union { - // A normal block. - struct { - unsigned char num_ptrs; - unsigned char size; - unsigned short num_free; - unsigned short next_free; - } pi; - // A monolithic block. - struct { - unsigned num_ptrs; - } m; - } u; - bitarray_t used[]; -}; - -struct s_cache { - SLIST_ENTRY(s_cache) next; - SLIST_HEAD(,s_block) blocks; - SLIST_HEAD(,s_block) full_blocks; - unsigned char color; - unsigned char size; - unsigned char num_ptrs; - unsigned char flags; - unsigned short num_entries; - struct s_arena *arena; - void (*init_fn)(void *); - void (*fini_fn)(void *); -#if _JHC_PROFILE - unsigned allocations; -#endif -}; - gc_t saved_gc; struct s_arena *arena; static gc_t gc_stack_base; hunk ./rts/rts/gc_jgc.c 16 #define TO_GCPTR(x) (entry_t *)(FROM_SPTR(x)) -static void gc_perform_gc(gc_t gc); +void gc_perform_gc(gc_t gc) A_STD; static bool s_set_used_bit(void *val) A_UNUSED; static void clear_used_bits(struct s_arena *arena) A_UNUSED; static void s_cleanup_blocks(struct s_arena *arena); hunk ./rts/rts/gc_jgc.c 84 stack->stack[stack->ptr++] = s; } -static void +void A_STD gc_perform_gc(gc_t gc) { profile_push(&gc_gc_time); hunk ./rts/rts/gc_jgc.c 167 } free(stack.stack); s_cleanup_blocks(arena); - if(JHC_STATUS) { + if (JHC_STATUS) { fprintf(stderr, "%3u - %6u Used: %4u Thresh: %4u Ss: %5u Ps: %5u Rs: %5u Root: %3u\n", arena->number_gcs, arena->number_allocs, hunk ./rts/rts/gc_jgc.c 185 // 7 to share caches with the first 7 tuples #define GC_STATIC_ARRAY_NUM 7 -#define GC_MAX_BLOCK_ENTRIES 100 +#define GC_MAX_BLOCK_ENTRIES 150 static struct s_cache *array_caches[GC_STATIC_ARRAY_NUM]; hunk ./rts/rts/gc_jgc.c 188 -static struct s_cache *array_atomic_caches[GC_STATIC_ARRAY_NUM]; +static struct s_cache *array_caches_atomic[GC_STATIC_ARRAY_NUM]; void jhc_alloc_init(void) { hunk ./rts/rts/gc_jgc.c 206 } for (int i = 0; i < GC_STATIC_ARRAY_NUM; i++) { find_cache(&array_caches[i], arena, i + 1, i + 1); + find_cache(&array_caches_atomic[i], arena, i + 1, 0); } } hunk ./rts/rts/gc_jgc.c 216 fprintf(stderr, "arena: %p\n", arena); fprintf(stderr, " block_used: %i\n", arena->block_used); fprintf(stderr, " block_threshold: %i\n", arena->block_threshold); - struct s_cache *sc = SLIST_FIRST(&arena->caches); - for(;sc;sc = SLIST_NEXT(sc,next)) { + struct s_cache *sc; + SLIST_FOREACH(sc,&arena->caches,next) print_cache(sc); hunk ./rts/rts/gc_jgc.c 219 - } } } hunk ./rts/rts/gc_jgc.c 233 } static heap_t A_STD -s_monoblock(struct s_arena *arena, unsigned size, unsigned nptrs) { +s_monoblock(struct s_arena *arena, unsigned size, unsigned nptrs, unsigned flags) { struct s_block *b = aligned_alloc(size * sizeof(uintptr_t)); hunk ./rts/rts/gc_jgc.c 235 - b->flags = SLAB_MONOLITH; + b->flags = flags | SLAB_MONOLITH; b->color = (sizeof(struct s_block) + BITARRAY_SIZE_IN_BYTES(1) + sizeof(uintptr_t) - 1) / sizeof(uintptr_t); b->u.m.num_ptrs = nptrs; hunk ./rts/rts/gc_jgc.c 244 return (void *)b + b->color*sizeof(uintptr_t); } -// Allocate an array of count garbage collectable locations in the garbage collected heap +// Allocate an array of count garbage collectable locations in the garbage +// collected heap. heap_t A_STD gc_array_alloc(gc_t gc, unsigned count) { hunk ./rts/rts/gc_jgc.c 255 return (wptr_t)s_alloc(gc,array_caches[count - 1]); if (count < GC_MAX_BLOCK_ENTRIES) return s_alloc(gc, find_cache(NULL, arena, count, count)); - return s_monoblock(arena, count, count); + return s_monoblock(arena, count, count, 0); + abort(); +} + +// Allocate an array of count non-garbage collectable locations in the garbage +// collected heap. +heap_t A_STD +gc_array_alloc_atomic(gc_t gc, unsigned count, unsigned flags) +{ + if (!count) + return NULL; + if (count <= GC_STATIC_ARRAY_NUM && !flags) + return (wptr_t)s_alloc(gc,array_caches_atomic[count - 1]); + if (count < GC_MAX_BLOCK_ENTRIES && !flags) + return s_alloc(gc, find_cache(NULL, arena, count, 0)); + return s_monoblock(arena, count, count, flags); abort(); } hunk ./rts/rts/gc_jgc.c 299 void *base; #if defined(__WIN32__) base = _aligned_malloc(MEGABLOCK_SIZE, BLOCK_SIZE); - int ret = !mb->base; + int ret = !base; #elif defined(__ARM_EABI__) base = memalign(BLOCK_SIZE, MEGABLOCK_SIZE); hunk ./rts/rts/gc_jgc.c 302 - int ret = !mb->base; + int ret = !base; #elif (defined(__ENVIRONMENT_MAC_OS_X_VERSION_MIN_REQUIRED__) && __ENVIRONMENT_MAC_OS_X_VERSION_MIN_REQUIRED__ < 1060) assert(sysconf(_SC_PAGESIZE) == BLOCK_SIZE); base = valloc(MEGABLOCK_SIZE); hunk ./rts/rts/gc_jgc.c 306 - int ret = !mb->base; + int ret = !base; #else int ret = posix_memalign(&base,BLOCK_SIZE,MEGABLOCK_SIZE); #endif hunk ./rts/rts/gc_jgc.c 359 } } +typedef void (*finalizer_ptr)(HsPtr arg); +typedef void (*finalizer_env_ptr)(HsPtr env, HsPtr arg); + +void hs_foreignptr_env_helper(HsPtr env, HsPtr arg) { + ((finalizer_ptr)env)(arg); +} + static void s_cleanup_blocks(struct s_arena *arena) { struct s_block *pg = SLIST_FIRST(&arena->monolithic_blocks); hunk ./rts/rts/gc_jgc.c 371 SLIST_INIT(&arena->monolithic_blocks); while (pg) { - if(BIT_IS_SET(pg->used, 0)) { + if (pg->used[0]) { SLIST_INSERT_HEAD(&arena->monolithic_blocks, pg, link); pg = SLIST_NEXT(pg,link); hunk ./rts/rts/gc_jgc.c 374 - } - else { + } else { + if (pg->flags & SLAB_FLAG_FINALIZER) { + HsPtr *ptr = (HsPtr *)pg; + if(ptr[pg->color + 1]) { + finalizer_ptr *fp = ptr[pg->color + 1]; + do { + fp[0](ptr[pg->color]); + } while(*++fp); + } + } void *ptr = pg; pg = SLIST_NEXT(pg,link); free(ptr); hunk ./rts/rts/gc_jgc.c 599 return arena; } +uint32_t +get_heap_flags(void * sp) { + uint32_t ret = 0; + switch (GET_PTYPE(sp)) { + case P_VALUE: return SLAB_VIRTUAL_VALUE; + case P_FUNC: return SLAB_VIRTUAL_FUNC; + case P_LAZY: + ret |= SLAB_VIRTUAL_LAZY; + case P_WHNF: + if (S_BLOCK(sp) == NULL) + return (ret | SLAB_VIRTUAL_SPECIAL); + if ((void *)sp >= nh_start && (void *)sp <= nh_end) + return (ret | SLAB_VIRTUAL_CONSTANT); + return ret |= S_BLOCK(sp)->flags; + } + return ret; +} + +heap_t A_STD +gc_malloc_foreignptr(unsigned alignment, unsigned size, bool finalizer) { + // we don't allow higher alignments yet. + assert (alignment <= sizeof(uintptr_t)); + // no finalizers yet + assert (!finalizer); + unsigned spacing = 1 + finalizer; + wptr_t *res = gc_array_alloc_atomic(saved_gc, spacing + TO_BLOCKS(size), + finalizer ? SLAB_FLAG_FINALIZER : SLAB_FLAG_NONE); + res[0] = (wptr_t)(res + spacing); + if (finalizer) + res[1] = NULL; + return TO_SPTR(P_WHNF, res); +} + +heap_t A_STD +gc_new_foreignptr(HsPtr ptr) { + HsPtr *res = gc_array_alloc_atomic(saved_gc, 2, SLAB_FLAG_FINALIZER); + res[0] = ptr; + res[1] = NULL; + return TO_SPTR(P_WHNF, res); +} + +bool A_STD +gc_add_foreignptr_finalizer(wptr_t fp, HsFunPtr finalizer) { + if (!(SLAB_FLAG_FINALIZER & get_heap_flags(fp))) + return false; + HsFunPtr **res = (HsFunPtr**)FROM_SPTR(fp); + unsigned len = 0; + if (res[1]) + while(res[1][len++]); + else + len = 1; + res[1] = realloc(res[1], (len + 1) * sizeof(HsFunPtr)); + HsFunPtr *ptrs = res[1]; + ptrs[len - 1] = finalizer; + ptrs[len] = NULL; + return true; +} + void print_cache(struct s_cache *sc) { fprintf(stderr, "num_entries: %i with %lu bytes of header\n", hunk ./rts/rts/gc_jgc.c 678 fprintf(stderr, "%20p %9i %9i %c\n", pg, pg->u.pi.num_free, pg->u.pi.next_free, 'F'); } +void hs_perform_gc(void) { + gc_perform_gc(saved_gc); +} + #endif hunk ./rts/rts/gc_jgc.h 5 #define JHC_GC_JGC_H #include <stdbool.h> +#include <stdint.h> #include "sys/queue.h" hunk ./rts/rts/gc_jgc.h 7 +#include "HsFFI.h" struct sptr; struct s_arena; hunk ./rts/rts/gc_jgc.h 18 #define BLOCK_SIZE (1UL << 12) #define MEGABLOCK_SIZE (1UL << 20) #define S_BLOCK(val) ((struct s_block *)((uintptr_t)(val) & ~(BLOCK_SIZE - 1))) -#define GC_BASE sizeof(void *) -#define TO_BLOCKS(x) ((x) <= GC_BASE ? 1 : (((x) - 1)/GC_BASE) + 1) +#define TO_BLOCKS(x) (((x) + sizeof(uintptr_t) - 1)/sizeof(uintptr_t)) extern struct s_arena *arena; extern gc_t saved_gc; hunk ./rts/rts/gc_jgc.h 30 struct s_cache *find_cache(struct s_cache **rsc, struct s_arena *arena, unsigned short size, unsigned short num_ptrs); void gc_add_root(gc_t gc, void * root); +void A_STD gc_perform_gc(gc_t gc); +uint32_t get_heap_flags(void* sp); heap_t s_alloc(gc_t gc, struct s_cache *sc) A_STD; hunk ./rts/rts/gc_jgc.h 34 -heap_t (gc_alloc)(gc_t gc,struct s_cache **sc, unsigned count, unsigned nptrs); -heap_t gc_array_alloc(gc_t gc, unsigned count); -heap_t gc_array_alloc_atomic(gc_t gc, unsigned count); +heap_t (gc_alloc)(gc_t gc,struct s_cache **sc, unsigned count, unsigned nptrs) A_STD; +heap_t gc_array_alloc(gc_t gc, unsigned count) A_STD; +heap_t gc_array_alloc_atomic(gc_t gc, unsigned count, unsigned slab_flags) A_STD; +/* foreignptr, saved_gc must be set properly. */ +heap_t gc_malloc_foreignptr(unsigned alignment, unsigned size, bool finalizer) A_STD; +heap_t gc_new_foreignptr(HsPtr ptr) A_STD; +bool gc_add_foreignptr_finalizer(struct sptr* fp, HsFunPtr finalizer) A_STD; #define gc_frame0(gc,n,...) void *ptrs[n] = { __VA_ARGS__ }; \ for(int i = 0; i < n; i++) gc[i] = (sptr_t)ptrs[i]; \ addfile ./rts/rts/gc_jgc_internal.h hunk ./rts/rts/gc_jgc_internal.h 1 +#ifndef GC_JGC_INTERNAL_H +#define GC_JGC_INTERNAL_H + +#include "rts/gc_jgc.h" +#include "sys/bitarray.h" +#include "sys/queue.h" + +#if _JHC_GC == _JHC_GC_JGC + +struct s_arena { + struct s_megablock *current_megablock; + SLIST_HEAD(,s_block) free_blocks; + unsigned block_used; + unsigned block_threshold; + SLIST_HEAD(,s_cache) caches; + SLIST_HEAD(,s_block) monolithic_blocks; + SLIST_HEAD(,s_megablock) megablocks; + unsigned number_gcs; // number of garbage collections + unsigned number_allocs; // number of allocations since last garbage collection +}; + +struct s_megablock { + void *base; + unsigned next_free; + SLIST_ENTRY(s_megablock) next; +}; + +struct s_block { + SLIST_ENTRY(s_block) link; + unsigned char flags; // defined in rts/constants.h + unsigned char color; // offset in words to first entry. + union { + // A normal block. + struct { + unsigned char num_ptrs; + unsigned char size; + unsigned short num_free; + unsigned short next_free; + } pi; + // A monolithic block. + struct { + unsigned num_ptrs; + } m; + } u; + bitarray_t used[]; +}; + +struct s_cache { + SLIST_ENTRY(s_cache) next; + SLIST_HEAD(,s_block) blocks; + SLIST_HEAD(,s_block) full_blocks; + unsigned char color; + unsigned char size; + unsigned char num_ptrs; + unsigned char flags; + unsigned short num_entries; + struct s_arena *arena; +#if _JHC_PROFILE + unsigned allocations; +#endif +}; +#endif +#endif hunk ./rts/test/Makefile 8 -D_JHC_GC=_JHC_GC_JGC -DJHC_UNIT -D_JHC_STANDALONE=0 \ -DJHC_VALGRIND=1 -TESTS=slab_test stableptr_test +TESTS=slab_test stableptr_test jgc_test all: $(TESTS) RTSFILES=hs_fake.c ../rts/profile.c ../rts/jhc_rts.c ../rts/gc_jgc.c \ hunk ./rts/test/Makefile 14 ../rts/stableptr.c ../rts/gc_none.c ../rts/rts_support.c -slab_test: slab_test.c $(RTSFILES) - clean: rm -f $(TESTS) hunk ./rts/test/Makefile 20 test: all ./slab_test ./stableptr_test + ./jgc_test stableptr_test: stableptr_test.c seatest.c $(RTSFILES) hunk ./rts/test/Makefile 23 +slab_test: slab_test.c $(RTSFILES) +jgc_test: jgc_test.c seatest.c $(RTSFILES) addfile ./rts/test/jgc_test.c hunk ./rts/test/jgc_test.c 1 +#include "jhc_rts_header.h" +#include "rts/gc_jgc_internal.h" +#include "rts/constants.h" +#include "seatest.h" + +bool +block_aligned(void *p) { + return (S_BLOCK(p) == p); +} + +void +block_sanity(struct s_arena *arena, struct s_cache *sc, struct s_block *b) { + assert_true (!sc == !!(b->flags & SLAB_MONOLITH)); + assert_true (block_aligned(b)); +} + +void +cache_sanity(struct s_arena *arena, struct s_cache *sc) { + struct s_block *b; + assert_true(sc->arena == arena); + SLIST_FOREACH(b, &sc->blocks, link) + block_sanity(arena, sc, b); +} + +void +arena_sanity(struct s_arena *arena) { + assert_true(!!arena); + struct s_cache *sc; + struct s_block *b; + SLIST_FOREACH(sc, &arena->caches, next) + cache_sanity(arena, sc); + SLIST_FOREACH(b, &arena->monolithic_blocks, link) + block_sanity(arena, NULL, b); + +} + +#define PTR1 (HsPtr)0xDEADBEEF +#define PTR2 (HsPtr)0xB00B1E5 + +void foreignptr_test(void) { + gc_t gc = saved_gc; + HsPtr **ptr = gc_new_foreignptr(PTR1); + assert_ptr_equal(PTR1, ptr[0]); + assert_ptr_equal(NULL, ptr[1]); + assert_true(gc_add_foreignptr_finalizer((sptr_t)ptr, PTR2)); + assert_bit_mask_matches(get_heap_flags(ptr), SLAB_FLAG_FINALIZER); + assert_ptr_equal(PTR1, ptr[0]); + assert_true(!!ptr[1]); + assert_ptr_equal(ptr[1][0], PTR2); + arena_sanity(arena); +} + +void basic_test(void) { + arena_sanity(arena); + gc_t gc = saved_gc; + heap_t e = gc_alloc(gc, NULL, 2, 2); + ((void **)e)[0] = e; + ((void **)e)[1] = e; + gc[0] = e; + arena_sanity(arena); + gc_perform_gc(gc + 1); + arena_sanity(arena); +} + +int main(int argc, char *argv[]) +{ + hs_init(&argc, &argv); + test_fixture_start(); + run_test(basic_test); + run_test(foreignptr_test); + test_fixture_end(); + hs_exit(); + return 0; +} hunk ./rts/test/seatest.c 108 seatest_simple_test_result(expected==actual, s, function, line); } +void seatest_assert_ptr_equal(void * expected, void * actual, const char* function, unsigned int line) +{ + char s[SEATEST_PRINT_BUFFER_SIZE]; + sprintf(s, "Expected %p but was %p", expected, actual); + seatest_simple_test_result(expected==actual, s, function, line); +} + void seatest_assert_float_equal( float expected, float actual, float delta, const char* function, unsigned int line ) { char s[SEATEST_PRINT_BUFFER_SIZE]; hunk ./rts/test/seatest.h 24 void seatest_assert_false(int test, const char* function, unsigned int line); void seatest_assert_int_equal(int expected, int actual, const char* function, unsigned int line); void seatest_assert_ulong_equal(unsigned long expected, unsigned long actual, const char* function, unsigned int line); +void seatest_assert_ptr_equal(void * expected, void * actual, const char* function, unsigned int line); void seatest_assert_float_equal(float expected, float actual, float delta, const char* function, unsigned int line); void seatest_assert_double_equal(double expected, double actual, double delta, const char* function, unsigned int line); void seatest_assert_string_equal(char* expected, char* actual, const char* function, unsigned int line); hunk ./rts/test/seatest.h 47 #define assert_false(test) do { seatest_assert_false(test, __FUNCTION__, __LINE__); } while (0) #define assert_int_equal(expected, actual) do { seatest_assert_int_equal((int)(expected), (int)(actual), __FUNCTION__, __LINE__); } while (0) #define assert_ulong_equal(expected, actual) do { seatest_assert_ulong_equal(expected, actual, __FUNCTION__, __LINE__); } while (0) +#define assert_ptr_equal(expected, actual) do { seatest_assert_ptr_equal(expected, actual, __FUNCTION__, __LINE__); } while (0) #define assert_string_equal(expected, actual) do { seatest_assert_string_equal(expected, actual, __FUNCTION__, __LINE__); } while (0) #define assert_n_array_equal(expected, actual, n) do { int seatest_count; for(seatest_count=0; seatest_count<n; seatest_count++) { char s_seatest[SEATEST_PRINT_BUFFER_SIZE]; sprintf(s_seatest,"Expected %d to be %d at position %d", actual[seatest_count], expected[seatest_count], seatest_count); seatest_simple_test_result((expected[seatest_count] == actual[seatest_count]), s_seatest, __FUNCTION__, __LINE__);} } while (0) #define assert_bit_set(bit_number, value) { seatest_simple_test_result(((1 << bit_number) & value), " Expected bit to be set" , __FUNCTION__, __LINE__); } while (0) hunk ./rts/test/slab_test.c 1 -#define JHC_VALGRIND 1 - -#define _JHC_STANDALONE 0 -#define _JHC_GC _JHC_GC_JGC - #include "jhc_rts_header.h" #define NUM_CACHES 15 hunk ./src/C/FFI.hs 16 type CName = String -data Safety = Safe | Unsafe deriving(Eq,Ord,Show) - {-! derive: Binary !-} - data FfiType = Import CName Requires | ImportAddr CName Requires | Wrapper hunk ./src/C/FromGrin2.hs 533 _ -> error "simpleRet: odd rTodo" nodeAssign :: Val -> Atom -> [Val] -> Exp -> C Statement -nodeAssign v t as e' = cna where - cna = do - cpr <- asks rCPR - v' <- convertVal v - case mlookup t cpr of - Just (TyRepRawVal signed) -> do - [arg] <- return as - t <- convertType $ getType arg - arg' <- iDeclare $ convertVal arg - let s = arg' =* cast t (if signed then f_RAW_GET_F v' else f_RAW_GET_UF v') - ss <- convertBody e' - return $ s & ss - _ -> do - declareStruct t - as' <- iDeclare $ mapM convertVal as - let ass = concat [perhapsM (a `Set.member` fve) $ a' =* (project' (arg i) (concrete t v')) | a' <- as' | Var a _ <- as | i <- [( 1 :: Int) ..] ] - fve = freeVars e' - ss' <- convertBody e' - return $ mconcat ass & ss' +nodeAssign v t as e' = do + cpr <- asks rCPR + v' <- convertVal v + case mlookup t cpr of + Just (TyRepRawVal signed) -> do + [arg] <- return as + t <- convertType $ getType arg + arg' <- iDeclare $ convertVal arg + let s = arg' =* cast t (if signed then f_RAW_GET_F v' else f_RAW_GET_UF v') + ss <- convertBody e' + return $ s & ss + _ -> do + declareStruct t + as' <- iDeclare $ mapM convertVal as + let ass = concat [perhapsM (a `Set.member` fve) $ a' =* (project' (arg i) (concrete t v')) | a' <- as' | Var a _ <- as | i <- [( 1 :: Int) ..] ] + fve = freeVars e' + ss' <- convertBody e' + return $ mconcat ass & ss' --isCompound Fetch {} = False isCompound BaseOp {} = False hunk ./src/C/FromGrin2.hs 563 mgct = if fopts FO.Jgc then ((name "gc",gc_t):) else id convertExp :: Exp -> C (Statement,Expression) -convertExp (Prim (Func _ n as r rs@(_:_)) vs ty) = do - vs' <- mapM convertVal vs - rt <- mapM convertType ty - let rrs = map basicType' (r:rs) - ras <- mapM (newVar . basicType') rs - (stmt,rv) <- basicType' r `newTmpVar` (functionCall (name $ unpackPS n) ([ cast (basicType' t) v | v <- vs' | t <- as ] ++ map reference ras)) - return $ (stmt, structAnon (zip (rv:ras) rt)) +convertExp (Prim Func { primArgTypes = as, primRetType = r, primRetArgs = rs@(_:_), ..} vs ty) = do + tell mempty { wRequires = primRequires } + vs' <- mapM convertVal vs + rt <- mapM convertType ty + let rrs = map basicType' (r:rs) + ras <- mapM (newVar . basicType') rs + (stmt,rv) <- basicType' r `newTmpVar` (functionCall (name $ unpackPS funcName) ([ cast (basicType' t) v | v <- vs' | t <- as ] ++ map reference ras)) + return $ (stmt, structAnon (zip (rv:ras) rt)) +convertExp (Prim Func { primRetArgs = [], .. } vs ty) = do + tell mempty { wRequires = primRequires } + vs' <- mapM convertVal vs + rt <- convertTypes ty + let fcall = cast rt (functionCall (name $ unpackPS funcName) [ cast (basicType' t) v | v <- vs' | t <- primArgTypes ]) + return (if primSafety == Safe && fopts FO.Jgc then v_saved_gc =* v_gc else mempty,fcall) convertExp (Prim p vs ty) = do tell mempty { wRequires = primReqs p } e <- convertPrim p vs ty hunk ./src/C/FromGrin2.hs 612 let ass = [project' (arg i) tmp' =* a | a <- as' | i <- [(1 :: Int) ..] ] return (mconcat $ s:ass,emptyExpression) -convertExp Alloc { expValue = v, expCount = c, expRegion = r } | r == region_heap, TyINode == getType v = do +convertExp Alloc { expValue = v, expCount = c, expRegion = r } + | r == region_heap, TyINode == getType v = do v' <- convertVal v c' <- convertVal c (malloc,tmp) <- jhc_malloc_ptrs c' =:: ptrType sptr_t hunk ./src/C/FromGrin2.hs 627 r == region_atomic_heap, TyPrim Op.bits_ptr == getType v = do v' <- convertVal v c' <- convertVal c - (malloc,tmp) <- jhc_malloc_atomic (operator "*" (sizeof uintptr_t) c') =:: ptrType uintptr_t + (malloc,tmp) <- jhc_malloc_atomic c' =:: ptrType uintptr_t fill <- case v of ValUnknown _ -> return mempty _ -> do hunk ./src/C/FromGrin2.hs 638 convertExp e = return (err (show e),err "nothing") ccaf :: (Var,Val) -> P.Doc -ccaf (v,val) = text "/* " <> text (show v) <> text " = " <> (text $ P.render (pprint val)) <> text "*/\n" <> +ccaf (v,val) = text "/* " <> text (show v) <> text " = " <> + (text $ P.render (pprint val)) <> text "*/\n" <> text "static node_t _" <> tshow (varName v) <> text ";\n" <> hunk ./src/C/FromGrin2.hs 641 - text "#define " <> tshow (varName v) <+> text "(MKLAZY_C(&_" <> tshow (varName v) <> text "))\n"; + text "#define " <> tshow (varName v) <+> text "(MKLAZY_C(&_" <> + tshow (varName v) <> text "))\n"; buildConstants cpr grin fh = P.vcat (map cc (Grin.HashConst.toList fh)) where tyenv = grinTypeEnv grin hunk ./src/C/FromGrin2.hs 703 | Op {} <- p = do let [rt] = ty convertVal (ValPrim p vs rt) - | (Func _ n as r []) <- p = do - vs' <- mapM convertVal vs - rt <- convertTypes ty - return $ cast rt (functionCall (name $ unpackPS n) [ cast (basicType' t) v | v <- vs' | t <- as ]) | (IFunc _ as r) <- p = do v':vs' <- mapM convertVal vs rt <- convertTypes ty hunk ./src/C/FromGrin2.hs 919 -- c constants and utilities ---------------------------- ---gc_roots vs = functionCall (name "gc_begin_frame0") (constant (number (fromIntegral $ length vs)):vs) ---gc_roots vs = functionCall (name "gc_frame0") (v_gc:constant (number (fromIntegral $ length vs)):vs) gc_roots vs = case length vs of -- 1 -> functionCall (name "gc_frame1") (v_gc:vs) -- 2 -> functionCall (name "gc_frame2") (v_gc:vs) hunk ./src/C/FromGrin2.hs 926 gc_end = functionCall (name "gc_end") [] tbsize sz = functionCall (name "TO_BLOCKS") [sz] -jhc_malloc_atomic sz | fopts FO.Jgc = functionCall (name "gc_alloc") [v_gc,nullPtr, tbsize sz, toExpression (0::Int)] - | otherwise = jhc_malloc nullPtr (0::Int) sz +jhc_malloc_atomic sz | fopts FO.Jgc = functionCall (name "gc_array_alloc_atomic") [v_gc,nullPtr, sz, toExpression (0::Int)] + | otherwise = jhc_malloc nullPtr (0::Int) (sizeof sptr_t *# sz) jhc_malloc ntn nptrs sz | fopts FO.Jgc = functionCall (name "gc_alloc") [v_gc,ntn, tbsize sz, toExpression nptrs] -- | fopts FO.Jgc = functionCall (name "gc_alloc") [v_gc,tbsize sz, toExpression nptrs] hunk ./src/C/FromGrin2.hs 975 wptr_t = basicGCType "wptr_t" gc_t = basicGCType "gc_t" v_gc = variable (name "gc") +v_saved_gc = variable (name "saved_gc") a_STD = Attribute "A_STD" a_FALIGNED = Attribute "A_FALIGNED" hunk ./src/C/Prims.hs 17 import GHC.Exts -data CallConv = CCall | StdCall | CApi | Primitive | DotNet +data CallConv = CCall | StdCall | CApi | Primitive | DotNet deriving(Eq,Ord,Show) {-! derive: Binary !-} hunk ./src/C/Prims.hs 21 +data Safety = Safe | Unsafe deriving(Eq,Ord,Show) + {-! derive: Binary !-} + newtype ExtType = ExtType PackedString deriving(Binary,IsString,Eq,Ord) hunk ./src/C/Prims.hs 58 funcName :: !PackedString, primArgTypes :: [ExtType], primRetType :: ExtType, - primRetArgs :: [ExtType] + primRetArgs :: [ExtType], + primSafety :: Safety } -- function call with C calling convention | IFunc { primRequires :: Requires, hunk ./src/E/FromHs.hs 402 let cFun = createFunc (map tvrType es) prim = myPrim (map extTypeInfoExtType cts) (extTypeInfoExtType pt) (map extTypeInfoExtType ras') case (isIO,pt,ras') of - (True,ExtTypeVoid,[]) -> cFun $ \rs -> return (ELam tvrWorld, + (True,ExtTypeVoid,[]) -> cFun $ \rs -> return (ELam tvrWorld, eStrictLet tvrWorld2 (prim (EVar tvrWorld :[EVar t | t <- rs ]) tWorld__) (eJustIO (EVar tvrWorld2) vUnit)) (False,ExtTypeVoid,_) -> invalidDecl "pure foreign function must return a non void value" hunk ./src/E/FromHs.hs 462 expr $ eStrictLet uvar (EPrim prim [] st) (ELit (litCons { litName = cn, litArgs = [EVar uvar], litType = rt })) _ -> invalidDecl "foreign import of address must be of a boxed type" - cDecl (HsForeignDecl _ (FfiSpec (Import rcn req) _ CCall) n _) = do + cDecl (HsForeignDecl _ (FfiSpec (Import rcn req) safe CCall) n _) = do let name = toName Name.Val n (var,ty,lamt) <- convertValue name result <- ccallHelper hunk ./src/E/FromHs.hs 467 (\cts crt cras args rt -> - EPrim (Func req (packString rcn) cts crt cras) args rt) + EPrim (Func req (packString rcn) cts crt cras safe) args rt) ty return [(name,setProperty prop_INLINE var,lamt result)] cDecl (HsForeignDecl _ (FfiSpec Dynamic _ CCall) n _) = do hunk ./src/E/FromHs.hs 1003 liftIO $ warn sl InvalidFFIType $ printf "Type '%s' cannot be used in a foreign declaration" (pprint t :: String) return bad - unboxedVersion t = do ffiTypeInfo Unknown t $ \eti -> case eti of ExtTypeBoxed _ uv _ -> return uv hunk ./src/Grin/Main.hs 118 ("sys/wsize.h",wsize_h), ("rts/gc_jgc.c",gc_jgc_c), ("rts/gc_jgc.h",gc_jgc_h), + ("rts/gc_jgc_internal.h",gc_jgc_internal_h), ("rts/gc_none.c",gc_none_c), ("rts/gc_none.h",gc_none_h), ("sys/bitarray.h",bitarray_h)] $ \ (fn,bs) -> do Context: [add support for monolithic blocks that are plain malloced memory and can be big. John Meacham <[email protected]>**20120221032043 Ignore-this: 201ba4e67027f3336cfa5e984aefa89 ] [introduce dedicated array allocation routine. clean up jgc garbage collector John Meacham <[email protected]>**20120221011655 Ignore-this: b8e153205aeaf94af76a97b0ee9aa895 ] [make 'div' and 'mod' round to -Infinity properly John Meacham <[email protected]>**20120220094634 Ignore-this: c46b383b9a2a6a63ff44e30a8a63f376 ] [add prototype for gc_alloc John Meacham <[email protected]>**20120220050616 Ignore-this: 444b34148332459dc0e3d32b7c55d3e0 ] [fix deriving rules for read/show when it comes to labels John Meacham <[email protected]>**20120220044322 Ignore-this: 20c9c89ae066716fe3ec8eb4d37c6034 ] [disabled buggy unused transformation in type analysis pass John Meacham <[email protected]>**20120220031442 Ignore-this: 8ad84739daff7f4faff0ba251898ea1a ] [move debugging routines to rts/profile.c John Meacham <[email protected]>**20120217052015 Ignore-this: d2e087faf6e3408dc135fd905d85244b ] [fix rts unit tests John Meacham <[email protected]>**20120217035045 Ignore-this: 460d7eadde056908b668ea27d5a69aa5 ] [export gc_alloc John Meacham <[email protected]>**20120217002235 Ignore-this: dcb70b3ad303f0343147b4e1d6d413b9 ] [Makes the class deriving mechanism more robust: [email protected]**20120216214017 Ignore-this: 6d93691849d255c310b2af7098572ea8 - the names of the classes to be derived may be given qualified. - the functions from the Prelude internally used need not be in scope and won't clash with other bindings. ] [Moved Jhc.List.drop to module Jhc.Basics (since it is used in instance deriving) [email protected]**20120214222939 Ignore-this: f95d4818bad6d79d8fc7566ee0912714 ] [The typechecker now verifies that the main function has a type that can be unified with IO a. This is required by the Haskell 98 Report. [email protected]**20120211050446 Ignore-this: 8a1d8ca36929c0de0fb4357538ea6c5b Failing to do so allows both to accept invalid programs like: > main :: [()] > main = return () and to reject valid programs like: > main = return () ] [Improves the error message shown when a monomorphic pattern has a polymorphic type that cannot be defaulted. [email protected]**20120211045931 Ignore-this: efd70b7535eb0444148aabdbe96ed0b9 The previous error message seemed more like an internal error ("withDefaults.ambiguity: ...") ] [fix for building rts in different modes, profile,debug,windows John Meacham <[email protected]>**20120216201402 Ignore-this: 39b08c82b7239beaeaa6e77a3b986cd4 ] [move rest of rts into seperate c files rather than including it directly. John Meacham <[email protected]>**20120216090215 Ignore-this: d0bf719a38e306f78e182a5c0107573d ] [add pragmaExp to the lexer/parser John Meacham <[email protected]>**20120216044837 Ignore-this: 77393cb5bdd28fba526d57d26ac099b8 ] [update documentation with new extensions John Meacham <[email protected]>**20120214172359 Ignore-this: 2f412f29f20127ce3f97f200674ed8b6 ] [fixes for android John Meacham <[email protected]>**20120213150333 Ignore-this: cf6df59b212e3402ec21507410485270 ] [make += work with '-m' command line options John Meacham <[email protected]>**20120213102300 Ignore-this: 36cb4039cd34ba73d2cc973b7c00798b ] [move jhc_rts_alloc to gc_none John Meacham <[email protected]>**20120213100906 Ignore-this: 1c2e9028d72127acd5a448971266f627 ] [added rts/rts_support, cleaned up rts code. John Meacham <[email protected]>**20120213070644 Ignore-this: 79533860331fbd02057748e3d1b81666 ] [make 'Requires' a simple set, include the calling convention with the requirements. John Meacham <[email protected]>**20120212053838 Ignore-this: b7fa6f8ece79c96073d8638a876456de ] [move slub.c and jhc_jgc.* to rts directory John Meacham <[email protected]>**20120212040246 Ignore-this: a40354544b8908732c733bf8a38e7e68 ] [add unit tests for stableptr John Meacham <[email protected]>**20120212031148 Ignore-this: 17b41baeec806fb53ca2c10c6489097 ] [reorganize rts/ directory, add README for it John Meacham <[email protected]>**20120212022718 Ignore-this: c8a9f067696233958757830b62a7264b ] [add rts/test directory John Meacham <[email protected]>**20120212004706 Ignore-this: 1e6d0cb4ba809a1d6089d04704d5a60f ] [allow being explicit in export/import lists by specifying 'kind', 'class', 'type', or 'data'. add PTS rule to allow proper typing of Complex_ John Meacham <[email protected]>**20120211052157 Ignore-this: 12155286186022f896d3474a2bb5d23a ] [fix Options.hs makefile dependency John Meacham <[email protected]>**20120211024909 Ignore-this: a0742d7ce4eba41314741b6ca2d6498d ] [added user defined kind extension John Meacham <[email protected]>**20120211042248 Ignore-this: ded329985c5c81aa8c4612f7aa19559b ] [Add missing src/Options.hs to jhc tarball Sergei Trofimovich <[email protected]>**20120209065334 Ignore-this: dfc50115ee26986ab2d303a462cd29b9 ] [added mingw32-gcc to MINGW search Sergei Trofimovich <[email protected]>**20110414073938 Ignore-this: 87fa46f0e4532663a9d92930c9c38152 ] [add c-- types for complex and vector values John Meacham <[email protected]>**20120210051026 Ignore-this: 4a1e4c8cec01f73b75913622c22fa55 ] [add documentation for the multi-return ccall extension, clean up code. John Meacham <[email protected]>**20120209201351 Ignore-this: 47504b653ee9f71bde40e91959238292 ] [add extension to allow multiple return values from c functions John Meacham <[email protected]>**20120209142228 Ignore-this: 51e4a3f9ca80ff2eae7f21376f0a0992 ] [fix obscure error message for invalid instance reported by roman John Meacham <[email protected]>**20120209114221 Ignore-this: 98d60e20cb63caaebbe1269887160b9f ] [remove APrim type, use Prim directly, clean up corresponding cruft. John Meacham <[email protected]>**20120209104920 Ignore-this: 8a3fbeea72e7f52809a3468df2b8b228 ] [turn ExtType into a real abstract type John Meacham <[email protected]>**20120209100704 Ignore-this: c802a07fee0f2461cca19aa28f99ff61 ] [add 'capi' foreign function call type, simplify type of E.FromHs monad, check for more FFI related errors John Meacham <[email protected]>**20120209091611 Ignore-this: 1945b5336e6001d6da6cd63a77bd1efd ] [add md5lazyIO, check for bad paths in createTempFile John Meacham <[email protected]>**20120209091527 Ignore-this: f9e5f0dafc9615d5c5c50cb49829c5a5 ] [add foreign types, interpret Ptr when creating external C types John Meacham <[email protected]>**20120209090647 Ignore-this: c49bea3938e2edabda9d7528cfb1121a ] [Add some more exotic primitive ops, ffs,clz,ctz,byteswap,popcount,parity. John Meacham <[email protected]>**20120209070848 Ignore-this: b61b1c08db35ccad33f24536b99913df ] [jhc.spec fixes John Meacham <[email protected]>**20120209015329 Ignore-this: 64488edc34893a734f81b1c01c0b1ff4 ] [TAG 0.8.0 John Meacham <[email protected]>**20120208020026 Ignore-this: 2d0d963331a43650879ae72d81ff62e8 ] Patch bundle hash: 1d29dfc476536246378a74286f223116d471725d
_______________________________________________ jhc mailing list [email protected] http://www.haskell.org/mailman/listinfo/jhc
