New patches: [add rts/test directory John Meacham **20120212004706 Ignore-this: 1e6d0cb4ba809a1d6089d04704d5a60f ] move ./src/data/HsFFI.h ./rts/HsFFI.h adddir ./rts/test hunk ./Makefile.am 96 test -f "$$lib" && $(INSTALL_DATA) $$lib $(DESTDIR)$(datadir)/@PACKAGE@-@SHORTVERSION@ ; \ test -f "$(srcdir)/$$lib" && $(INSTALL_DATA) "$(srcdir)/$$lib" $(DESTDIR)$(datadir)/@PACKAGE@-@SHORTVERSION@ ; \ done - $(INSTALL_DATA) "$(srcdir)/src/data/HsFFI.h" $(DESTDIR)$(datadir)/@PACKAGE@-@SHORTVERSION@/include + $(INSTALL_DATA) "$(srcdir)/rts/HsFFI.h" $(DESTDIR)$(datadir)/@PACKAGE@-@SHORTVERSION@/include $(INSTALL_DATA) "$(srcdir)/src/data/targets.ini" $(DESTDIR)$(sysconfdir)/@PACKAGE@-@SHORTVERSION@ uninstall-hook: hunk ./Makefile.am 113 UTILS = utils/op_process.prl utils/opt_sets.prl utils/gen_props.prl utils/op_names.prl utils/op_raw.prl RAWFILES = src/data/ViaGhc.hs src/data/prelude.m4 \ - src/data/targets.ini rts/rts_constants.h rts/stableptr.c rts/queue.h src/data/HsFFI.h \ + src/data/targets.ini rts/rts_constants.h rts/stableptr.c rts/queue.h rts/HsFFI.h \ rts/wsize.h rts/bitarray.h ChangeLog src/data/shortchange.txt RTSFILES = rts/jhc_rts_header.h rts/jhc_jgc.h \ hunk ./rts/jhc_jgc.c 80 static void gc_add_grey(struct stack *stack, entry_t *s) { - VALGRIND_MAKE_MEM_DEFINED(s,S_BLOCK(s)->pi.size * sizeof(uintptr_t)); + VALGRIND_MAKE_MEM_DEFINED(s,(S_BLOCK(s))->pi.size * sizeof(uintptr_t)); if(gc_check_heap(s) && s_set_used_bit(s)) stack->stack[stack->ptr++] = s; } hunk ./rts/slub.c 6 #define BLOCK_SIZE (1UL << 12) #define MEGABLOCK_SIZE (1UL << 20) -#define S_BLOCK(val) (struct s_block *)((uintptr_t)(val) & ~ (BLOCK_SIZE - 1)) +#define S_BLOCK(val) ((struct s_block *)((uintptr_t)(val) & ~ (BLOCK_SIZE - 1))) struct s_arena { struct s_megablock *current_megablock; hunk ./rts/slub.c 351 } } -#ifdef SLAB_TEST - -#define NUM_CACHES 15 -#define FACTOR (1 << 16) - -void -stress_test(int n) { - struct s_arena *arena = new_arena(); - struct s_cache *caches[NUM_CACHES]; - - void *ptrs[n]; - memset(ptrs,0,n*sizeof(void *)); - for(int i = 0; i < NUM_CACHES; i++) - caches[i] = new_cache(arena,sizeof(void *)*(i + 1), 0); - for(int i = 0; i < FACTOR * n; i++) { - int wp = rand() % n; - if (ptrs[wp]) { - s_free(ptrs[wp]); - //free(ptrs[wp]); - ptrs[wp] = NULL; - } else { - ptrs[wp] = s_alloc(caches[rand() % NUM_CACHES]); - //ptrs[wp] = malloc((rand() % NUM_CACHES) * sizeof(uintptr_t)); - } - } -} - -int -main(int argc, char *argv[]) -{ - - setbuf(stdout,NULL); - stress_test(1 << 8); - struct s_arena *arena = new_arena(); - for(int i = 0;i < 10; i++) { - struct s_cache *sc = new_cache(arena,i,0); - print_cache(sc); - } - struct s_cache *sc1 = new_cache(arena,7,4); - struct s_cache *sc2 = new_cache(arena,1,3); - - printf("Alloc1: %p\n", s_alloc(sc1)); - printf("Alloc1: %p\n", s_alloc(sc1)); - printf("Alloc1: %p\n", s_alloc(sc1)); - printf("Alloc2: %p\n", s_alloc(sc2)); - printf("Alloc2: %p\n", s_alloc(sc2)); - printf("Alloc2: %p\n", s_alloc(sc2)); - - print_cache(sc1); - print_cache(sc2); - - return 0; -} - -#endif #endif addfile ./rts/test/Makefile hunk ./rts/test/Makefile 1 +# tests of the rts + +CFLAGS=-I.. -I../.. -std=gnu99 -g -O2 + +slab_test: slab_test.c + +clean: + rm -f slab_test addfile ./rts/test/slab_test.c hunk ./rts/test/slab_test.c 1 +char jhc_c_compile[] = "(compile)"; +char jhc_command[] = "(command)"; +char jhc_version[] = "(version)"; + +#define JHC_VALGRIND 1 + +#define _JHC_STANDALONE 0 +#define _JHC_GC _JHC_GC_JGC + +#include "jhc_rts_header.h" +#include "jhc_jgc.h" +#include "debug.c" +#include "jhc_rts_alloc.c" +#include "jhc_rts.c" +#include "profile.c" +#include "jhc_rts2.c" +#include "slub.c" +#include "jhc_jgc.c" + +#define NUM_CACHES 15 +#define FACTOR (1 << 16) + +static void jhc_hs_init(void) {} +static const void * const nh_stuff[] = { NULL }; + +void +stress_test(int n) { + jhc_alloc_init(); + struct s_arena *arena = new_arena(); + struct s_cache *caches[NUM_CACHES]; + + void *ptrs[n]; + memset(ptrs,0,n*sizeof(void *)); + for(int i = 0; i < NUM_CACHES; i++) + caches[i] = new_cache(arena,sizeof(void *)*(i + 1), 0); + for(int i = 0; i < FACTOR * n; i++) { + int wp = rand() % n; + if (ptrs[wp]) { + //s_free(ptrs[wp]); + //free(ptrs[wp]); + ptrs[wp] = NULL; + } else { + ptrs[wp] = s_alloc(saved_gc, caches[rand() % NUM_CACHES]); + //ptrs[wp] = malloc((rand() % NUM_CACHES) * sizeof(uintptr_t)); + } + } +} + +int +main(int argc, char *argv[]) +{ + + setbuf(stdout,NULL); + stress_test(1 << 2); + struct s_arena *arena = new_arena(); + for(int i = 0;i < 10; i++) { + struct s_cache *sc = new_cache(arena,i,0); + print_cache(sc); + } + struct s_cache *sc1 = new_cache(arena,7,4); + struct s_cache *sc2 = new_cache(arena,1,3); + + printf("Alloc1: %p\n", s_alloc(saved_gc, sc1)); + printf("Alloc1: %p\n", s_alloc(saved_gc, sc1)); + printf("Alloc1: %p\n", s_alloc(saved_gc, sc1)); + printf("Alloc2: %p\n", s_alloc(saved_gc, sc2)); + printf("Alloc2: %p\n", s_alloc(saved_gc, sc2)); + printf("Alloc2: %p\n", s_alloc(saved_gc, sc2)); + + print_cache(sc1); + print_cache(sc2); + + return 0; +} [reorganize rts/ directory, add README for it John Meacham **20120212022718 Ignore-this: c8a9f067696233958757830b62a7264b ] adddir ./rts/sys move ./rts/bitarray.h ./rts/sys/bitarray.h move ./rts/queue.h ./rts/sys/queue.h adddir ./rts/lib move ./rts/lib_cbits.c ./rts/lib/lib_cbits.c adddir ./rts/rts move ./rts/region.c ./rts/rts/region.c move ./rts/rts_constants.h ./rts/rts/constants.h move ./rts/stableptr.c ./rts/rts/stableptr.c move ./rts/wsize.h ./rts/sys/wsize.h hunk ./Makefile.am 113 UTILS = utils/op_process.prl utils/opt_sets.prl utils/gen_props.prl utils/op_names.prl utils/op_raw.prl RAWFILES = src/data/ViaGhc.hs src/data/prelude.m4 \ - src/data/targets.ini rts/rts_constants.h rts/stableptr.c rts/queue.h rts/HsFFI.h \ - rts/wsize.h rts/bitarray.h ChangeLog src/data/shortchange.txt + src/data/targets.ini rts/rts/constants.h rts/rts/stableptr.c rts/sys/queue.h rts/HsFFI.h \ + rts/sys/wsize.h rts/sys/bitarray.h ChangeLog src/data/shortchange.txt RTSFILES = rts/jhc_rts_header.h rts/jhc_jgc.h \ rts/debug.c rts/jhc_rts_alloc.c rts/jhc_rts.c rts/profile.c rts/jhc_rts2.c \ hunk ./Makefile.am 118 - rts/slub.c rts/jhc_jgc.c rts/lib_cbits.c + rts/slub.c rts/jhc_jgc.c rts/lib/lib_cbits.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 \ addfile ./rts/README.txt hunk ./rts/README.txt 1 +directory layout for rts + +sys/ - non rts specific support files and system compatibility files. +test/ - rts testing routines +lib/ - C code to support the haskell libraries. hunk ./rts/jhc_jgc.c 2 #if _JHC_GC == _JHC_GC_JGC + +#include "sys/queue.h" + static struct s_arena *arena; #ifdef JHC_JGC_STACK hunk ./rts/jhc_rts_header.h 30 #include "HsFFI.h" #include "rts/wsize.h" -#include "rts/bitarray.h" -#include "sys/queue.h" // #define our options hunk ./rts/rts/stableptr.c 1 +#include "sys/queue.h" + struct StablePtr { LIST_ENTRY(StablePtr) link; sptr_t contents; hunk ./rts/slub.c 3 #if _JHC_GC == _JHC_GC_JGC +#include "sys/bitarray.h" +#include "sys/queue.h" + #define BLOCK_SIZE (1UL << 12) #define MEGABLOCK_SIZE (1UL << 20) hunk ./src/Grin/Main.hs 6 import Control.Monad import Data.Monoid(mappend) import System.Directory +import System.Process import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS import qualified Data.ByteString.Lazy.UTF8 as LBS hunk ./src/Grin/Main.hs 95 | otherwise -> fileInTempDir ("main_code.c") (\_ -> return ()) (argstring,sversion) <- getArgString (cc,args) <- fetchCompilerFlags - forM_ [("rts/rts_constants.h",rts_constants_h),("rts/stableptr.c",stableptr_c), - ("sys/queue.h",queue_h),("HsFFI.h",hsffi_h),("rts/wsize.h",wsize_h), - ("rts/bitarray.h",bitarray_h)] $ \ (fn,bs) -> do + forM_ [("rts/constants.h",constants_h), + ("rts/stableptr.c",stableptr_c), + ("sys/queue.h",queue_h), + ("HsFFI.h",hsffi_h), + ("rts/wsize.h",wsize_h), + ("sys/bitarray.h",bitarray_h)] $ \ (fn,bs) -> do fileInTempDir fn $ flip BS.writeFile bs tdir <- getTempDir [add unit tests for stableptr John Meacham **20120212031148 Ignore-this: 17b41baeec806fb53ca2c10c6489097 ] hunk ./rts/jhc_rts_header.h 29 #endif #include "HsFFI.h" -#include "rts/wsize.h" +#include "sys/wsize.h" // #define our options hunk ./rts/rts/stableptr.c 29 return sp->contents; } +/* +wptr_t c_castPtrToStablePtr(void *) +void * c_castStablePtrToPtr(wptr_t) +*/ + hunk ./rts/test/Makefile 3 # tests of the rts +CC=gcc CFLAGS=-I.. -I../.. -std=gnu99 -g -O2 hunk ./rts/test/Makefile 6 +all: slab_test stableptr_test + slab_test: slab_test.c clean: hunk ./rts/test/Makefile 12 rm -f slab_test + +test: all + ./slab_test + ./stableptr_test + +stableptr_test: stableptr_test.c seatest.c addfile ./rts/test/seatest.c hunk ./rts/test/seatest.c 1 +#include "seatest.h" +#include +#ifdef WIN32 +#include +#include "windows.h" +#else +unsigned int GetTickCount() { return 0;} +void _getch( void ) { } +#endif + +static int sea_tests_run = 0; +static int sea_tests_passed = 0; +static int sea_tests_failed = 0; +static char* seatest_current_fixture; + +static void (*seatest_suite_setup_func)( void ) = 0; +static void (*seatest_suite_teardown_func)( void ) = 0; +static void (*seatest_fixture_setup)( void ) = 0; +static void (*seatest_fixture_teardown)( void ) = 0; + + + +void suite_setup(void (*setup)( void )) +{ + seatest_suite_setup_func = setup; +} +void suite_teardown(void (*teardown)( void )) +{ + seatest_suite_teardown_func = teardown; +} + +void seatest_suite_setup( void ) +{ + if(seatest_suite_setup_func != 0) seatest_suite_setup_func(); +} + +void seatest_suite_teardown( void ) +{ + if(seatest_suite_teardown_func != 0) seatest_suite_teardown_func(); +} + +void fixture_setup(void (*setup)( void )) +{ + seatest_fixture_setup = setup; +} +void fixture_teardown(void (*teardown)( void )) +{ + seatest_fixture_teardown = teardown; +} + +void seatest_setup( void ) +{ + if(seatest_fixture_setup != 0) seatest_fixture_setup(); +} + +void seatest_teardown( void ) +{ + if(seatest_fixture_teardown != 0) seatest_fixture_teardown(); +} + +char* test_file_name(char* path) +{ + char* file = path + strlen(path); + while(file != path && *file!= '\\' ) file--; + if(*file == '\\') file++; + return file; +} + +static int seatest_fixture_tests_run; +static int seatest_fixture_tests_failed; + +void seatest_simple_test_result(int passed, char* reason, const char* function, unsigned int line) +{ + if (!passed) + { + printf("%-20s Line %-5d %s\r\n", function, line, reason ); + sea_tests_failed++; + } + else + { + sea_tests_passed++; + } +} + +void seatest_assert_true(int test, const char* function, unsigned int line) +{ + seatest_simple_test_result(test, "Should of been true", function, line); + +} + +void seatest_assert_false(int test, const char* function, unsigned int line) +{ + seatest_simple_test_result(!test, "Should of been false", function, line); +} + + +void seatest_assert_int_equal(int expected, int actual, const char* function, unsigned int line) +{ + char s[SEATEST_PRINT_BUFFER_SIZE]; + sprintf(s, "Expected %d but was %d", expected, actual); + seatest_simple_test_result(expected==actual, s, function, line); +} + +void seatest_assert_ulong_equal(unsigned long expected, unsigned long actual, const char* function, unsigned int line) +{ + char s[SEATEST_PRINT_BUFFER_SIZE]; + sprintf(s, "Expected %lu but was %lu", 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]; + float result = expected-actual; + sprintf(s, "Expected %f but was %f", expected, actual); + if(result < 0.0) result = 0.0f - result; + seatest_simple_test_result( result <= delta, s, function, line); +} + +void seatest_assert_double_equal( double expected, double actual, double delta, const char* function, unsigned int line ) +{ + char s[SEATEST_PRINT_BUFFER_SIZE]; + double result = expected-actual; + sprintf(s, "Expected %f but was %f", expected, actual); + if(result < 0.0) result = 0.0 - result; + seatest_simple_test_result( result <= delta, s, function, line); +} + +void seatest_assert_string_equal(char* expected, char* actual, const char* function, unsigned int line) +{ + char s[SEATEST_PRINT_BUFFER_SIZE]; + sprintf(s, "Expected %s but was %s", expected, actual); + seatest_simple_test_result(strcmp(expected, actual)==0, s, function, line); +} + +void seatest_assert_string_ends_with(char* expected, char* actual, const char* function, unsigned int line) +{ + char s[SEATEST_PRINT_BUFFER_SIZE]; + sprintf(s, "Expected %s to end with %s", actual, expected); + seatest_simple_test_result(strcmp(expected, actual+(strlen(actual)-strlen(expected)))==0, s, function, line); +} + +void seatest_assert_string_starts_with(char* expected, char* actual, const char* function, unsigned int line) +{ + char s[SEATEST_PRINT_BUFFER_SIZE]; + sprintf(s, "Expected %s to start with %s", actual, expected); + seatest_simple_test_result(strncmp(expected, actual, strlen(expected))==0, s, function, line); +} + +void seatest_assert_string_contains(char* expected, char* actual, const char* function, unsigned int line) +{ + char s[SEATEST_PRINT_BUFFER_SIZE]; + sprintf(s, "Expected %s to be in %s", expected, actual); + seatest_simple_test_result(strstr(actual, expected)!=0, s, function, line); +} + +void seatest_assert_string_doesnt_contain(char* expected, char* actual, const char* function, unsigned int line) +{ + char s[SEATEST_PRINT_BUFFER_SIZE]; + sprintf(s, "Expected %s not to have %s in it", actual, expected); + seatest_simple_test_result(strstr(actual, expected)==0, s, function, line); +} + +void seatest_run_test(void) +{ + sea_tests_run++; +} + +void seatest_header_printer(char* s, int length, char f) +{ + int l = strlen(s); + int d = (length- (l + 2)) / 2; + int i; + for(i = 0; i 0) { + printf(" Failed\r\n"); + } + else { + printf(" ALL TESTS PASSED\r\n"); + } + printf(" %d tests run\r\n", sea_tests_run); + printf(" in %lu ms\r\n",end - start); + printf("==================================================\r\n"); + + _getch(); + return sea_tests_failed == 0; +} + addfile ./rts/test/seatest.h hunk ./rts/test/seatest.h 1 +#ifndef SEATEST_H +#define SEATEST_H +#include + +/* +Defines +*/ + +#define SEATEST_VERSION "0.5" +#define SEATEST_PROJECT_HOME "http://code.google.com/p/seatest/" +#define SEATEST_PRINT_BUFFER_SIZE 100000 + +/* +Declarations +*/ + +void seatest_test_fixture_start(char* filepath); +void seatest_test_fixture_end( void ); +void seatest_simple_test_result(int passed, char* reason, const char* function, unsigned int line); +void seatest_assert_true(int test, const char* function, unsigned int line); +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_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); +void seatest_assert_string_ends_with(char* expected, char* actual, const char* function, unsigned int line); +void seatest_assert_string_starts_with(char* expected, char* actual, const char* function, unsigned int line); +void seatest_assert_string_contains(char* expected, char* actual, const char* function, unsigned int line); +void seatest_assert_string_doesnt_contain(char* expected, char* actual, const char* function, unsigned int line); +int seatest_should_run( char* fixture, char* test); +void seatest_run_test(void); +void seatest_setup( void ); +void seatest_teardown( void ); +void seatest_suite_teardown( void ); +void seatest_suite_setup( void ); + +/* +Assert Macros +*/ + +#define assert_true(test) do { seatest_assert_true(test, __FUNCTION__, __LINE__); } while (0) +#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_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**20120212040246 Ignore-this: a40354544b8908732c733bf8a38e7e68 ] move ./rts/jhc_jgc.c ./rts/rts/gc_jgc.c move ./rts/slub.c ./rts/rts/slub.c hunk ./Makefile.am 114 RAWFILES = src/data/ViaGhc.hs src/data/prelude.m4 \ src/data/targets.ini rts/rts/constants.h rts/rts/stableptr.c rts/sys/queue.h rts/HsFFI.h \ - rts/sys/wsize.h rts/sys/bitarray.h ChangeLog src/data/shortchange.txt + rts/sys/wsize.h rts/sys/bitarray.h ChangeLog src/data/shortchange.txt rts/rts/slub.c \ + rts/rts/gc_jgc.c hunk ./Makefile.am 117 -RTSFILES = rts/jhc_rts_header.h rts/jhc_jgc.h \ +RTSFILES = rts/jhc_rts_header.h \ rts/debug.c rts/jhc_rts_alloc.c rts/jhc_rts.c rts/profile.c rts/jhc_rts2.c \ hunk ./Makefile.am 119 - rts/slub.c rts/jhc_jgc.c rts/lib/lib_cbits.c + rts/lib/lib_cbits.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 ./Makefile.am 283 jhc_man.mkd: $(JHC_MANUAL_FILES) perl $(srcdir)/utils/stitch.prl -h $(srcdir)/docs/man_header.mkd -c Using,Options $^ > $@ - man: jhc_man.mkd pandoc $< -s -f markdown -t man -s -o jhc.1 hunk ./rts/jhc_jgc.h 1 -#if _JHC_GC == _JHC_GC_JGC - -#ifdef JHC_JGC_STACK -struct frame; -typedef struct frame *gc_t; -#else -typedef void* *gc_t; -static gc_t gc_stack_base; -#endif - -static gc_t saved_gc; - -#define GC_BASE sizeof(void *) - -#define TO_BLOCKS(x) ((x) <= GC_BASE ? 1 : (((x) - 1)/GC_BASE) + 1) - -struct s_cache; -static void gc_perform_gc(gc_t gc); -static void *gc_alloc(gc_t gc,struct s_cache **sc, unsigned count, unsigned nptrs); - -#endif rmfile ./rts/jhc_jgc.h hunk ./rts/jhc_rts2.c 290 GETHEAD(thunk) = (fptr_t)new; } +#include "rts/slub.c" +#include "rts/gc_jgc.c" + hunk ./rts/jhc_rts_header.h 139 #define debugf(...) do { } while (0) #endif + +#define JHC_HEADER +#include "rts/gc_jgc.c" +#include "rts/slub.c" +#undef JHC_HEADER + hunk ./rts/rts/gc_jgc.c 2 #if _JHC_GC == _JHC_GC_JGC +#ifdef JHC_HEADER + +#ifdef JHC_JGC_STACK +struct frame; +typedef struct frame *gc_t; +#else +typedef void* *gc_t; +static gc_t gc_stack_base; +static unsigned number_gcs; // number of garbage collections +static unsigned number_allocs; // number of allocations since last garbage collection +#endif + +static gc_t saved_gc; + +#define GC_BASE sizeof(void *) +#define TO_BLOCKS(x) ((x) <= GC_BASE ? 1 : (((x) - 1)/GC_BASE) + 1) + +static void gc_perform_gc(gc_t gc); + +#else #include "sys/queue.h" hunk ./rts/rts/gc_jgc.c 25 +//static gc_t saved_gc; static struct s_arena *arena; #ifdef JHC_JGC_STACK hunk ./rts/rts/gc_jgc.c 236 profile_pop(&gc_gc_time); } -A_UNUSED static void * -(gc_alloc)(gc_t gc,struct s_cache **sc, unsigned count, unsigned nptrs) -{ - profile_push(&gc_alloc_time); - if (JHC_STATUS) - number_allocs++; - assert(nptrs <= count); - entry_t *e = s_alloc(gc, find_cache(sc, arena, count, nptrs)); - VALGRIND_MAKE_MEM_UNDEFINED(e,sizeof(uintptr_t)*count); - debugf("allocated: %p %i %i\n",(void *)e, count, nptrs); - profile_pop(&gc_alloc_time); - return (void *)e; -} - static void jhc_alloc_print_stats(void) { } static const void * const nh_stuff[]; hunk ./rts/rts/gc_jgc.c 269 } } } + +#endif #endif hunk ./rts/rts/slub.c 3 #if _JHC_GC == _JHC_GC_JGC -#include "sys/bitarray.h" -#include "sys/queue.h" +#ifdef JHC_HEADER + +struct s_arena; +struct s_cache; +static void *s_alloc(gc_t gc, struct s_cache *sc); +static struct s_cache *find_cache(struct s_cache **rsc, struct s_arena *arena, + unsigned short size, unsigned short num_ptrs); +static bool s_set_used_bit(void *val); +static void clear_used_bits(struct s_arena *arena); hunk ./rts/rts/slub.c 13 +#define S_BLOCK(val) ((struct s_block *)((uintptr_t)(val) & ~ (BLOCK_SIZE - 1))) #define BLOCK_SIZE (1UL << 12) #define MEGABLOCK_SIZE (1UL << 20) hunk ./rts/rts/slub.c 17 -#define S_BLOCK(val) ((struct s_block *)((uintptr_t)(val) & ~ (BLOCK_SIZE - 1))) +#else + +#include "sys/bitarray.h" +#include "sys/queue.h" struct s_arena { struct s_megablock *current_megablock; hunk ./rts/rts/slub.c 366 } #endif +#endif hunk ./src/Grin/Main.hs 97 (cc,args) <- fetchCompilerFlags forM_ [("rts/constants.h",constants_h), ("rts/stableptr.c",stableptr_c), + ("rts/slub.c",slub_c), ("sys/queue.h",queue_h), ("HsFFI.h",hsffi_h), hunk ./src/Grin/Main.hs 100 - ("rts/wsize.h",wsize_h), + ("sys/wsize.h",wsize_h), + ("rts/gc_jgc.c",gc_jgc_c), ("sys/bitarray.h",bitarray_h)] $ \ (fn,bs) -> do fileInTempDir fn $ flip BS.writeFile bs [make 'Requires' a simple set, include the calling convention with the requirements. John Meacham **20120212053838 Ignore-this: b7fa6f8ece79c96073d8638a876456de ] hunk ./src/C/FFI.hs 14 import Data.Binary import Data.Typeable -type CName = String - -data CallConv = CCall | StdCall | CApi | Primitive | DotNet deriving(Eq,Ord,Show) - {-! derive: Binary !-} +type CName = String data Safety = Safe | Unsafe deriving(Eq,Ord,Show) {-! derive: Binary !-} hunk ./src/C/FFI.hs 29 deriving(Eq,Ord,Show) data FfiExport = FfiExport { - ffiExportCName :: CName, - ffiExportSafety :: Safety, + ffiExportCName :: CName, + ffiExportSafety :: Safety, ffiExportCallConv :: CallConv, hunk ./src/C/FFI.hs 32 - ffiExportArgTypes ::[ExtType], + ffiExportArgTypes :: [ExtType], ffiExportRetType :: ExtType } deriving(Eq,Ord,Show,Typeable) hunk ./src/C/FromGrin2.hs 127 -------------- {-# NOINLINE compileGrin #-} -compileGrin :: Grin -> (LBS.ByteString,[String]) -compileGrin grin = (LBS.fromChunks code, snub (reqLibraries req)) where +compileGrin :: Grin -> (LBS.ByteString,Requires) +compileGrin grin = (LBS.fromChunks code, req) where code = [ theData, BS.fromString $ P.render ans, hunk ./src/C/FromGrin2.hs 135 BS.fromString "\n" ] ans = vcat [ - vcat includes, vcat jgcs, hunk ./src/C/FromGrin2.hs 136 - vcat cincludes, + vcat includes, +-- vcat cincludes, text "", enum_tag_t, header, hunk ./src/C/FromGrin2.hs 150 ] jgcs | fopts FO.Jgc = [ text "static struct s_cache *" <> tshow (nodeCacheName m) <> char ';' | (m,_) <- Set.toList wAllocs] | otherwise = empty - nh_stuff = text "static const void * const nh_stuff[] = {" $$ fsep (punctuate (char ',') (cafnames ++ constnames ++ [text "NULL"])) $$ text "};" - includes = map include (filter ((".h" ==) . takeExtension) $ snub $ reqIncludes req) - cincludes = map include (filter ((".c" ==) . takeExtension) $ snub $ reqIncludes req) + fromRequires (Requires s) = map (unpackPS . snd) (Set.toList s) + nh_stuff = text "static const void * const nh_stuff[] = {" $$ fsep (punctuate (char ',') (cafnames ++ constnames ++ [text "NULL"])) $$ text "};" + includes = map include (filter ((".h" ==) . takeExtension) $ fromRequires req) +-- cincludes = map include (filter ((".c" ==) . takeExtension) $ fromRequires req) include fn = text "#include <" <> text fn <> text ">" (header,body) = generateC (function (name "jhc_hs_init") voidType [] [] icaches:Map.elems fm) (Map.elems sm) icaches :: Statement hunk ./src/C/Prims.hs 7 import Data.Binary import Data.Monoid import Data.Typeable +import qualified Data.Set as Set import Doc.DocLike import Doc.PPrint hunk ./src/C/Prims.hs 16 import qualified Cmm.Op as Op import GHC.Exts -{- -data PrimTypeType = PrimTypeIntegral | PrimTypeFloating | PrimTypePointer | PrimTypeVoid - deriving(Show,Eq,Ord) hunk ./src/C/Prims.hs 17 -data PrimType = PrimType { - primTypeName :: ExtType, - primTypeType :: {-# UNPACK #-} !PrimTypeType, - primTypeAlignmentOf :: {-# UNPACK #-} !Int, - primTypeIsSigned :: {-# UNPACK #-} !Bool, - primTypeSizeOf :: {-# UNPACK #-} !Int - } deriving(Show) --} +data CallConv = CCall | StdCall | CApi | Primitive | DotNet + deriving(Eq,Ord,Show) + {-! derive: Binary !-} newtype ExtType = ExtType PackedString deriving(Binary,IsString,Eq,Ord) hunk ./src/C/Prims.hs 28 show (ExtType p) = unpackPS p instance Show Requires where - show (Requires [] []) = "()" - show (Requires xs ys) = show (xs,ys) + show (Requires s) = show (Set.toList s) hunk ./src/C/Prims.hs 30 -data Requires = Requires { - reqIncludes :: [String], - reqLibraries :: [String] - } deriving(Eq, Ord) - {-! derive: Monoid, Binary !-} +newtype Requires = Requires (Set.Set (CallConv,PackedString)) + deriving(Eq,Ord,Monoid,Binary) data DotNetPrim = DotNetField | DotNetCtor | DotNetMethod deriving(Typeable, Eq, Ord, Show) hunk ./src/C/Prims.hs 135 primEagerSafe Op { primCOp = op } = Op.isEagerSafe op primEagerSafe _ = False -parsePrimString s = do - ws@(_:_) <- return $ words s - let v = case last ws of - '&':s -> AddrOf { primConst = (packString s), primRequires = reqs } - s -> Func { funcName = (packString s), primArgTypes = [], primRetType = "", primRequires = reqs, primRetArgs = [] } - f opt@('-':'l':_) = Requires [] [opt] - f s = Requires [s] [] - reqs = (mconcat (map f (init ws))) - return v - primPrim s = PrimPrim $ toAtom s instance DocLike d => PPrint d ExtType where hunk ./src/FrontEnd/ParseUtils.hs 17 ----------------------------------------------------------------------------- module FrontEnd.ParseUtils ( - splitTyConApp -- HsType -> P (HsName,[HsType]) + splitTyConApp -- HsType -> P (Name,[HsType]) , mkRecConstrOrUpdate -- HsExp -> [HsFieldUpdate] -> P HsExp , checkPrec -- Integer -> P Int , checkContext -- HsType -> P HsContext hunk ./src/FrontEnd/ParseUtils.hs 21 - , checkDataHeader -- HsQualType -> P (HsContext,HsName,[HsName]) + , checkDataHeader -- HsQualType -> P (HsContext,Name,[Name]) , checkPattern -- HsExp -> P HsPat , checkPatterns , checkExpr -- HsExp -> P HsExp hunk ./src/FrontEnd/ParseUtils.hs 26 , checkValDef -- SrcLoc -> HsExp -> HsRhs -> [HsDecl] -> P HsDecl - , checkUnQual -- HsQName -> P HsName + , checkUnQual -- Name -> P Name , readInteger , readRational , fixupHsDecls hunk ./src/FrontEnd/ParseUtils.hs 41 import Data.Maybe import Data.Monoid import Ratio +import qualified Data.Set as Set import qualified Data.Traversable as T import C.FFI hunk ./src/FrontEnd/ParseUtils.hs 50 import FrontEnd.SrcLoc import Name.Name import Name.Names - -type HsQName = HsName +import PackedString parseError :: String -> P a parseError = fail hunk ./src/FrontEnd/ParseUtils.hs 55 -splitTyConApp :: HsType -> P (HsName,[HsType]) +splitTyConApp :: HsType -> P (Name,[HsType]) splitTyConApp t0 = split t0 [] where hunk ./src/FrontEnd/ParseUtils.hs 58 - split :: HsType -> [HsType] -> P (HsName,[HsType]) + split :: HsType -> [HsType] -> P (Name,[HsType]) split (HsTyApp t u) ts = split t (u:ts) split (HsTyCon t) ts = return (t,ts) split _ _ = fail "Illegal data/newtype declaration" hunk ./src/FrontEnd/ParseUtils.hs 102 checkPatterns :: [HsExp] -> P [HsPat] checkPatterns es = mapM checkPattern es -checkDataHeader :: HsQualType -> P (HsContext,HsName,[HsName]) +checkDataHeader :: HsQualType -> P (HsContext,Name,[Name]) checkDataHeader (HsQualType cs t) = do (c,ts) <- checkSimple "data/newtype" t [] return (cs,c,ts) hunk ./src/FrontEnd/ParseUtils.hs 107 -checkSimple :: String -> HsType -> [HsName] -> P ((HsName,[HsName])) +checkSimple :: String -> HsType -> [Name] -> P ((Name,[Name])) checkSimple kw (HsTyApp l (HsTyVar a)) xs = checkSimple kw l (a:xs) checkSimple _kw (HsTyCon t) xs = return (t,xs) checkSimple kw _ _ = fail ("Illegal " ++ kw ++ " declaration") hunk ./src/FrontEnd/ParseUtils.hs 113 --checkSimple kw t ts = fail ("Illegal " ++ kw ++ " declaration: " ++ show (t,ts)) -checkInstHeader :: HsQualType -> P (HsContext,HsQName,[HsType]) +checkInstHeader :: HsQualType -> P (HsContext,Name,[HsType]) checkInstHeader (HsQualType cs t) = do (c,ts) <- checkInsts t [] return (cs,c,ts) hunk ./src/FrontEnd/ParseUtils.hs 118 -checkInsts :: HsType -> [HsType] -> P ((HsQName,[HsType])) +checkInsts :: HsType -> [HsType] -> P ((Name,[HsType])) checkInsts (HsTyApp l t) ts = checkInsts l (t:ts) checkInsts (HsTyCon c) ts = return (c,ts) checkInsts _ _ = fail "Illegal instance declaration" hunk ./src/FrontEnd/ParseUtils.hs 299 -- A variable binding is parsed as an HsPatBind. -isFunLhs :: HsExp -> [HsExp] -> Maybe (HsName, [HsExp]) +isFunLhs :: HsExp -> [HsExp] -> Maybe (Name, [HsExp]) isFunLhs (HsInfixApp l (HsVar ( op)) r) es = Just (op, l:r:es) isFunLhs (HsApp (HsVar ( f)) e) es = Just (f, e:es) isFunLhs (HsApp (HsParen f) e) es = isFunLhs f (e:es) hunk ./src/FrontEnd/ParseUtils.hs 324 -- Check that an identifier or symbol is unqualified. -- For occasions when doing this in the grammar would cause conflicts. -checkUnQual :: HsQName -> P HsName +checkUnQual :: Name -> P Name checkUnQual n = if isJust (getModule n) then fail "Illegal qualified name" else return n --checkUnQual (Qual _ _) = fail "Illegal qualified name" --checkUnQual n@(UnQual _) = return n hunk ./src/FrontEnd/ParseUtils.hs 379 -- True if the decl is a HsFunBind and binds the same name as the -- first argument, False otherwise -sameFun :: HsName -> HsDecl -> Bool +sameFun :: Name -> HsDecl -> Bool sameFun name (HsFunBind matches@(_:_)) = name == (matchName $ head matches) sameFun _ _ = False hunk ./src/FrontEnd/ParseUtils.hs 383 -doForeign :: Monad m => SrcLoc -> [HsName] -> Maybe (String,HsName) -> HsQualType -> m HsDecl +doForeign :: Monad m => SrcLoc -> [Name] -> Maybe (String,Name) -> HsQualType -> m HsDecl doForeign srcLoc names ms qt = ans where ans = do (mstring,vname@(nameParts -> (_,Nothing,cname)),names') <- case ms of hunk ./src/FrontEnd/ParseUtils.hs 395 f ["import","dotnet"] cname = return $ HsForeignDecl srcLoc (FfiSpec (Import cname mempty) Safe DotNet) vname qt f ("import":rs) cname = do let (safe,conv) = pconv rs - im <- parseImport mstring vname + im <- parseImport conv mstring vname + conv <- return (if conv == CApi then CCall else conv) return $ HsForeignDecl srcLoc (FfiSpec im safe conv) vname qt f ("export":rs) cname = do let (safe,conv) = pconv rs hunk ./src/FrontEnd/ParseUtils.hs 406 g _ cc ("safe":rs) = g Safe cc rs g _ cc ("unsafe":rs) = g Unsafe cc rs g s _ ("ccall":rs) = g s CCall rs - g s _ ("capi":rs) = g s CCall rs + g s _ ("capi":rs) = g s CApi rs g s _ ("stdcall":rs) = g s StdCall rs g s c [] = (s,c) g _ _ rs = error $ "FrontEnd.ParseUtils: unknown foreign flags " ++ show rs hunk ./src/FrontEnd/ParseUtils.hs 411 -doForeignEq :: Monad m => SrcLoc -> [HsName] -> Maybe (String,HsName) -> HsQualType -> HsExp -> m HsDecl +doForeignEq :: Monad m => SrcLoc -> [Name] -> Maybe (String,Name) -> HsQualType -> HsExp -> m HsDecl doForeignEq srcLoc names ms qt e = undefined -- FFI parsing hunk ./src/FrontEnd/ParseUtils.hs 416 -parseExport :: Monad m => String -> HsName -> m String +parseExport :: Monad m => String -> Name -> m String parseExport cn hn = case words cn of [x] | isCName x -> return x hunk ./src/FrontEnd/ParseUtils.hs 423 [] -> return (show hn) _ -> fail ("Invalid cname in export declaration: "++show cn) -parseImport :: Monad m => Maybe String -> HsName -> m FfiType -parseImport Nothing hn = return $ Import (show hn) mempty -parseImport (Just cn) hn = +parseImport :: Monad m => CallConv -> Maybe String -> Name -> m FfiType +parseImport _ Nothing hn = return $ Import (show hn) mempty +parseImport cc (Just cn) hn = case words cn of ["dynamic"] -> return Dynamic ["wrapper"] -> return Wrapper hunk ./src/FrontEnd/ParseUtils.hs 430 [] -> return $ Import (show hn) mempty - ("static":xs) -> parseIS [] [] xs - xs -> parseIS [] [] xs + ("static":xs) -> parseIS cc xs + xs -> parseIS cc xs hunk ./src/FrontEnd/ParseUtils.hs 433 -parseIS a b ['&':n] | isCName n = return $ ImportAddr n $ Requires a b -parseIS a b [n] | isCName n = return $ Import n $ Requires a b -parseIS a b ["&",n] | isCName n = return $ ImportAddr n $ Requires a b -parseIS a b (('-':'l':l):r) = parseIS a (l:b) r -parseIS a b (i:r) = parseIS (i:a) b r -parseIS _ _ x = fail ("Syntax error parsing foreign import: "++show x) +parseIS cc rs = f Set.empty rs where + f s ['&':n] | isCName n = return $ ImportAddr n $ Requires s + f s [n] | isCName n = return $ Import n $ Requires s + f s ["&",n] | isCName n = return $ ImportAddr n $ Requires s + f s (i:r) = f (Set.insert (cc,packString i) s) r + f s x = fail ("Syntax error parsing foreign import: "++show x) isCName [] = False isCName (c:cs) = p1 c && all p2 cs hunk ./src/Grin/Main.hs 4 module Grin.Main(compileToGrin) where import Control.Monad +import Data.List import Data.Monoid(mappend) import System.Directory hunk ./src/Grin/Main.hs 7 -import System.Process import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS import qualified Data.ByteString.Lazy.UTF8 as LBS hunk ./src/Grin/Main.hs 11 import qualified Data.Map as Map +import qualified Data.Set as Set import qualified System import qualified System.FilePath as FP hunk ./src/Grin/Main.hs 15 +import C.Prims import Grin.DeadCode import Grin.Devolve(twiddleGrin,devolveTransform) import Grin.EvalInline(createEvalApply) hunk ./src/Grin/Main.hs 29 import Grin.StorageAnalysis import Ho.ReadSource import Options +import PackedString import RawFiles import Support.TempDir import Support.Transform hunk ./src/Grin/Main.hs 89 wdump FD.GrinFinal $ dumpGrin "final" grin compileGrinToC grin = do - let (cg,rls) = FG2.compileGrin grin + let (cg,Requires reqs) = FG2.compileGrin grin + rls = filter ("-l" `isPrefixOf`) $ map (unpackPS . snd) (Set.toList reqs) fn = outputName ++ lup "executable_extension" lup k = maybe "" id $ Map.lookup k (optInis options) cf <- case (optOutName options,optStop options) of hunk ./src/Grin/Main.hs 112 tdir <- getTempDir ds <- catch (getDirectoryContents (tdir FP. "cbits")) (\_ -> return []) let extraCFiles = ["-I" ++ tdir ++ "/cbits", "-I" ++ tdir ] ++ [ tdir FP. "cbits" FP. fn | fn@(reverse -> 'c':'.':_) <- ds ] - let comm = shellQuote $ [cc] ++ ["-o", fn, cf] ++ args ++ (map ("-l" ++) rls) ++ extraCFiles + let comm = shellQuote $ [cc] ++ ["-o", fn, cf] ++ args ++ rls ++ extraCFiles globalvar n c = LBS.fromString $ "char " ++ n ++ "[] = \"" ++ c ++ "\";" putProgressLn ("Writing " ++ show cf) LBS.writeFile cf $ LBS.intercalate (LBS.fromString "\n") [ Context: [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 **20120211052157 Ignore-this: 12155286186022f896d3474a2bb5d23a ] [fix Options.hs makefile dependency John Meacham **20120211024909 Ignore-this: a0742d7ce4eba41314741b6ca2d6498d ] [added user defined kind extension John Meacham **20120211042248 Ignore-this: ded329985c5c81aa8c4612f7aa19559b ] [Add missing src/Options.hs to jhc tarball Sergei Trofimovich **20120209065334 Ignore-this: dfc50115ee26986ab2d303a462cd29b9 ] [added mingw32-gcc to MINGW search Sergei Trofimovich **20110414073938 Ignore-this: 87fa46f0e4532663a9d92930c9c38152 ] [add c-- types for complex and vector values John Meacham **20120210051026 Ignore-this: 4a1e4c8cec01f73b75913622c22fa55 ] [add documentation for the multi-return ccall extension, clean up code. John Meacham **20120209201351 Ignore-this: 47504b653ee9f71bde40e91959238292 ] [add extension to allow multiple return values from c functions John Meacham **20120209142228 Ignore-this: 51e4a3f9ca80ff2eae7f21376f0a0992 ] [fix obscure error message for invalid instance reported by roman John Meacham **20120209114221 Ignore-this: 98d60e20cb63caaebbe1269887160b9f ] [remove APrim type, use Prim directly, clean up corresponding cruft. John Meacham **20120209104920 Ignore-this: 8a3fbeea72e7f52809a3468df2b8b228 ] [turn ExtType into a real abstract type John Meacham **20120209100704 Ignore-this: c802a07fee0f2461cca19aa28f99ff61 ] [add 'capi' foreign function call type, simplify type of E.FromHs monad, check for more FFI related errors John Meacham **20120209091611 Ignore-this: 1945b5336e6001d6da6cd63a77bd1efd ] [add md5lazyIO, check for bad paths in createTempFile John Meacham **20120209091527 Ignore-this: f9e5f0dafc9615d5c5c50cb49829c5a5 ] [add foreign types, interpret Ptr when creating external C types John Meacham **20120209090647 Ignore-this: c49bea3938e2edabda9d7528cfb1121a ] [Add some more exotic primitive ops, ffs,clz,ctz,byteswap,popcount,parity. John Meacham **20120209070848 Ignore-this: b61b1c08db35ccad33f24536b99913df ] [jhc.spec fixes John Meacham **20120209015329 Ignore-this: 64488edc34893a734f81b1c01c0b1ff4 ] [TAG 0.8.0 John Meacham **20120208020026 Ignore-this: 2d0d963331a43650879ae72d81ff62e8 ] Patch bundle hash: 871aa264568e5a2e04a7a67e9091a615aee6177d