From 05dd0ce8f554cb397a9949a6361a5a1395401b2b Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 24 Sep 2007 13:22:03 -0500 Subject: [PATCH 01/88] Improve install.sh -- shopt -s nocasematch is not portable, try it and variant nocaseglob --- misc/install.sh | 2 ++ 1 file changed, 2 insertions(+) diff --git a/misc/install.sh b/misc/install.sh index e7d822f6c9..10c0bfc0df 100755 --- a/misc/install.sh +++ b/misc/install.sh @@ -5,6 +5,7 @@ set +e # Case insensitive string comparison shopt -s nocaseglob +shopt -s nocasematch ensure_program_installed() { echo -n "Checking for $1..." @@ -44,6 +45,7 @@ uname_s=`uname -s` case $uname_s in CYGWIN_NT-5.2-WOW64) OS=windows-nt;; *CYGWIN_NT*) OS=windows-nt;; + *CYGWIN*) OS=windows-nt;; *darwin*) OS=macosx;; *linux*) OS=linux;; esac From 544c2370cf4830250bfca7e2a1eed83ae2598598 Mon Sep 17 00:00:00 2001 From: "U-3ADF\\Administrator" Date: Tue, 25 Sep 2007 10:37:45 +0200 Subject: [PATCH 02/88] Fix SEH and USING: errors on windows nt --- extra/io/windows/nt/backend/backend.factor | 3 +- vm/os-windows-nt.c | 67 +++++++++++++--------- vm/os-windows-nt.h | 11 ++++ vm/os-windows.c | 2 +- vm/os-windows.h | 17 +----- 5 files changed, 55 insertions(+), 45 deletions(-) diff --git a/extra/io/windows/nt/backend/backend.factor b/extra/io/windows/nt/backend/backend.factor index 9ec0a63c40..5eac9d6751 100644 --- a/extra/io/windows/nt/backend/backend.factor +++ b/extra/io/windows/nt/backend/backend.factor @@ -1,7 +1,8 @@ USING: alien alien.c-types arrays assocs combinators continuations destructors io io.backend io.nonblocking io.windows libc kernel math namespaces sequences threads tuples.lib windows -windows.errors windows.kernel32 prettyprint ; +windows.errors windows.kernel32 prettyprint strings splitting +io.files windows.winsock ; IN: io.windows.nt.backend : unicode-prefix ( -- seq ) diff --git a/vm/os-windows-nt.c b/vm/os-windows-nt.c index 6f816f4625..cf40745cdd 100644 --- a/vm/os-windows-nt.c +++ b/vm/os-windows-nt.c @@ -23,40 +23,53 @@ DEFINE_PRIMITIVE(cd) SetCurrentDirectory(unbox_u16_string()); } -long exception_handler(PEXCEPTION_RECORD rec, void *frame, void *ctx, void *dispatch) +long exception_handler(PEXCEPTION_POINTERS pe) { - CONTEXT *c = (CONTEXT*)ctx; - void *esp = NULL; + PEXCEPTION_RECORD e = (PEXCEPTION_RECORD)pe->ExceptionRecord; + CONTEXT *c = (CONTEXT*)pe->ContextRecord; + void *signal_callstack_top = NULL; + if(in_code_heap_p(c->Eip)) - esp = (void*)c->Esp; - printf("ExceptionCode = 0x%08x\n", rec->ExceptionCode); - printf("AccessViolationCode = 0x%08x\n", EXCEPTION_ACCESS_VIOLATION); - printf("DivideByZeroCode1 = 0x%08x\n", EXCEPTION_FLT_DIVIDE_BY_ZERO); - printf("DivideByZeroCode2 = 0x%08x\n", EXCEPTION_INT_DIVIDE_BY_ZERO); - printf("addr=0x%08x\n", rec->ExceptionInformation[1]); - printf("eax=0x%08x\n", c->Eax); - printf("eax=0x%08x\n", c->Ebx); - printf("eip=0x%08x\n", c->Eip); - printf("esp=0x%08x\n", c->Esp); + signal_callstack_top = (void*)c->Esp; - printf("calculated esp: 0x%08x\n", esp); - - if(rec->ExceptionCode == EXCEPTION_ACCESS_VIOLATION) - memory_protection_error(rec->ExceptionInformation[1], esp); - else if(rec->ExceptionCode == EXCEPTION_FLT_DIVIDE_BY_ZERO - || rec->ExceptionCode == EXCEPTION_INT_DIVIDE_BY_ZERO) - general_error(ERROR_DIVIDE_BY_ZERO,F,F,esp); + if(e->ExceptionCode == EXCEPTION_ACCESS_VIOLATION) + { + signal_fault_addr = e->ExceptionInformation[1]; + c->Eip = (CELL)memory_signal_handler_impl; + } + else if(e->ExceptionCode == EXCEPTION_FLT_DIVIDE_BY_ZERO + || e->ExceptionCode == EXCEPTION_INT_DIVIDE_BY_ZERO) + { + signal_number = ERROR_DIVIDE_BY_ZERO; + c->Eip = (CELL)divide_by_zero_signal_handler_impl; + } else - signal_error(11,esp); - return -1; /* unreachable */ + { + signal_number = 11; + c->Eip = (CELL)misc_signal_handler_impl; + } + + return EXCEPTION_CONTINUE_EXECUTION; } void c_to_factor_toplevel(CELL quot) { - exception_record_t record; - asm volatile("mov %%fs:0, %0" : "=r" (record.next_handler)); - asm volatile("mov %0, %%fs:0" : : "r" (&record)); - record.handler_func = exception_handler; + AddVectoredExceptionHandler(0, (void*)exception_handler); c_to_factor(quot); - asm volatile("mov %0, %%fs:0" : "=r" (record.next_handler)); + RemoveVectoredExceptionHandler((void*)exception_handler); +} + +void memory_signal_handler_impl(void) +{ + memory_protection_error(signal_fault_addr,signal_callstack_top); +} + +void divide_by_zero_signal_handler_impl(void) +{ + general_error(ERROR_DIVIDE_BY_ZERO,F,F,signal_callstack_top); +} + +void misc_signal_handler_impl(void) +{ + signal_error(signal_number,signal_callstack_top); } diff --git a/vm/os-windows-nt.h b/vm/os-windows-nt.h index 514da31477..4dc87d0f83 100644 --- a/vm/os-windows-nt.h +++ b/vm/os-windows-nt.h @@ -1,3 +1,6 @@ +#undef _WIN32_WINNT +#define _WIN32_WINNT 0x0501 // For AddVectoredExceptionHandler + #ifndef UNICODE #define UNICODE #endif @@ -10,3 +13,11 @@ typedef char F_SYMBOL; #define FACTOR_OS_STRING "windows" #define FACTOR_DLL L"factor-nt.dll" #define FACTOR_DLL_NAME "factor-nt.dll" + +CELL signal_number; +CELL signal_fault_addr; +void *signal_callstack_top; + +void memory_signal_handler_impl(void); +void divide_by_zero_signal_handler_impl(void); +void misc_signal_handler_impl(void); diff --git a/vm/os-windows.c b/vm/os-windows.c index 479f60a4fa..1be3e2a2af 100644 --- a/vm/os-windows.c +++ b/vm/os-windows.c @@ -52,7 +52,7 @@ void ffi_dlopen (F_DLL *dll, bool error) dll->dll = NULL; if(error) general_error(ERROR_FFI,F,F, - tag_object(get_error_message())); + (void*)tag_object(get_error_message())); else return; } diff --git a/vm/os-windows.h b/vm/os-windows.h index 04f5c87ac7..ed9b87aa93 100644 --- a/vm/os-windows.h +++ b/vm/os-windows.h @@ -49,20 +49,5 @@ s64 current_millis(void); INLINE void reset_stdio(void) {} -/* SEH support. Proceed with caution. */ -typedef long exception_handler_t( - PEXCEPTION_RECORD rec, void *frame, void *context, void *dispatch); +long exception_handler(PEXCEPTION_POINTERS pe); -typedef struct exception_record -{ - struct exception_record *next_handler; - void *handler_func; -} exception_record_t; - -long exception_handler(PEXCEPTION_RECORD rec, void *frame, void *ctx, void *dispatch); - -DECLARE_PRIMITIVE(open_file); -DECLARE_PRIMITIVE(stat); -DECLARE_PRIMITIVE(read_dir); -DECLARE_PRIMITIVE(cwd); -DECLARE_PRIMITIVE(cd); From d6d7f6771adeb742423d2a8dc3dcf97490580e5d Mon Sep 17 00:00:00 2001 From: "U-3ADF\\Administrator" Date: Wed, 26 Sep 2007 19:39:20 +0200 Subject: [PATCH 03/88] Change FASTCALL to F_FASTCALL Move impl functions to run.c Fix win32 SEH --- vm/cpu-ppc.h | 2 +- vm/cpu-x86.32.h | 3 ++- vm/cpu-x86.64.h | 2 +- vm/cpu-x86.S | 16 ++++++++-------- vm/cpu-x86.h | 12 ++++++------ vm/os-unix.c | 10 ---------- vm/os-windows-nt.c | 18 ++---------------- vm/os-windows-nt.h | 2 ++ vm/primitives.h | 12 ++++++------ vm/run.c | 17 ++++++++++++++++- vm/run.h | 2 +- vm/stack.c | 2 +- vm/stack.h | 2 +- 13 files changed, 47 insertions(+), 53 deletions(-) diff --git a/vm/cpu-ppc.h b/vm/cpu-ppc.h index e4ff35c15c..d629ce5286 100644 --- a/vm/cpu-ppc.h +++ b/vm/cpu-ppc.h @@ -1,5 +1,5 @@ #define FACTOR_CPU_STRING "ppc" -#define FASTCALL +#define F_FASTCALL register CELL ds asm("r14"); register CELL rs asm("r15"); diff --git a/vm/cpu-x86.32.h b/vm/cpu-x86.32.h index 4c4acb0ad3..a81c9987c4 100644 --- a/vm/cpu-x86.32.h +++ b/vm/cpu-x86.32.h @@ -3,4 +3,5 @@ register CELL ds asm("esi"); register CELL rs asm("edi"); -#define FASTCALL __attribute__ ((regparm (2))) +#define F_FASTCALL __attribute__ ((regparm (2))) + diff --git a/vm/cpu-x86.64.h b/vm/cpu-x86.64.h index 0b3b5a2471..6412355129 100644 --- a/vm/cpu-x86.64.h +++ b/vm/cpu-x86.64.h @@ -3,4 +3,4 @@ register CELL ds asm("r14"); register CELL rs asm("r15"); -#define FASTCALL +#define F_FASTCALL diff --git a/vm/cpu-x86.S b/vm/cpu-x86.S index 3e2a97dd5c..634e4bc75f 100644 --- a/vm/cpu-x86.S +++ b/vm/cpu-x86.S @@ -2,7 +2,7 @@ mov QUOT_XT_OFFSET(ARG0),XT_REG ; /* Load quot-xt */ \ jmp *XT_REG /* Jump to quot-xt */ -DEF(FASTCALL void,c_to_factor,(CELL quot)): +DEF(F_FASTCALL void,c_to_factor,(CELL quot)): PUSH_NONVOLATILE push ARG0 /* Save quot */ @@ -17,37 +17,37 @@ DEF(FASTCALL void,c_to_factor,(CELL quot)): POP_NONVOLATILE ret -DEF(FASTCALL void,undefined,(CELL word)): +DEF(F_FASTCALL void,undefined,(CELL word)): mov STACK_REG,ARG1 /* Pass callstack pointer */ jmp MANGLE(undefined_error) /* This throws an error */ -DEF(FASTCALL void,dosym,(CELL word)): +DEF(F_FASTCALL void,dosym,(CELL word)): add $CELL_SIZE,DS_REG /* Increment stack pointer */ mov ARG0,(DS_REG) /* Store word on stack */ ret /* Here we have two entry points. The first one is taken when profiling is enabled */ -DEF(FASTCALL void,docol_profiling,(CELL word)): +DEF(F_FASTCALL void,docol_profiling,(CELL word)): add $CELL_SIZE,PROFILING_OFFSET(ARG0) /* Increment profile-count slot */ -DEF(FASTCALL void,docol,(CELL word)): +DEF(F_FASTCALL void,docol,(CELL word)): mov WORD_DEF_OFFSET(ARG0),ARG0 /* Load word-def slot */ JUMP_QUOT /* We must pass the XT to the quotation in ECX. */ -DEF(FASTCALL void,primitive_call,(void)): +DEF(F_FASTCALL void,primitive_call,(void)): mov (DS_REG),ARG0 /* Load quotation from data stack */ sub $CELL_SIZE,DS_REG /* Pop data stack */ JUMP_QUOT /* We pass the word in EAX and the XT in ECX. Don't mess up EDX, it's the callstack top parameter to primitives. */ -DEF(FASTCALL void,primitive_execute,(void)): +DEF(F_FASTCALL void,primitive_execute,(void)): mov (DS_REG),ARG0 /* Load word from data stack */ sub $CELL_SIZE,DS_REG /* Pop data stack */ mov WORD_XT_OFFSET(ARG0),XT_REG /* Load word-xt slot */ jmp *XT_REG /* Go */ -DEF(FASTCALL void,throw_impl,(CELL quot, F_STACK_FRAME *rewind_to)): +DEF(F_FASTCALL void,throw_impl,(CELL quot, F_STACK_FRAME *rewind_to)): mov ARG1,STACK_REG /* rewind_to */ JUMP_QUOT diff --git a/vm/cpu-x86.h b/vm/cpu-x86.h index a535038eef..730354499f 100644 --- a/vm/cpu-x86.h +++ b/vm/cpu-x86.h @@ -22,11 +22,11 @@ typedef struct _F_STACK_FRAME INLINE void flush_icache(CELL start, CELL len) {} -FASTCALL void c_to_factor(CELL quot); -FASTCALL void throw_impl(CELL quot, F_STACK_FRAME *rewind_to); -FASTCALL void undefined(CELL word); -FASTCALL void dosym(CELL word); -FASTCALL void docol_profiling(CELL word); -FASTCALL void docol(CELL word); +F_FASTCALL void c_to_factor(CELL quot); +F_FASTCALL void throw_impl(CELL quot, F_STACK_FRAME *rewind_to); +F_FASTCALL void undefined(CELL word); +F_FASTCALL void dosym(CELL word); +F_FASTCALL void docol_profiling(CELL word); +F_FASTCALL void docol(CELL word); void set_callstack(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, void *memcpy); diff --git a/vm/os-unix.c b/vm/os-unix.c index 2d9ba02ca5..65ae79550c 100644 --- a/vm/os-unix.c +++ b/vm/os-unix.c @@ -179,11 +179,6 @@ INLINE F_STACK_FRAME *uap_stack_pointer(void *uap) return NULL; } -void memory_signal_handler_impl(void) -{ - memory_protection_error(signal_fault_addr,signal_callstack_top); -} - void memory_signal_handler(int signal, siginfo_t *siginfo, void *uap) { signal_fault_addr = (CELL)siginfo->si_addr; @@ -191,11 +186,6 @@ void memory_signal_handler(int signal, siginfo_t *siginfo, void *uap) UAP_PROGRAM_COUNTER(uap) = (CELL)memory_signal_handler_impl; } -void misc_signal_handler_impl(void) -{ - signal_error(signal_number,signal_callstack_top); -} - void misc_signal_handler(int signal, siginfo_t *siginfo, void *uap) { signal_number = signal; diff --git a/vm/os-windows-nt.c b/vm/os-windows-nt.c index cf40745cdd..8f7513a32a 100644 --- a/vm/os-windows-nt.c +++ b/vm/os-windows-nt.c @@ -27,10 +27,11 @@ long exception_handler(PEXCEPTION_POINTERS pe) { PEXCEPTION_RECORD e = (PEXCEPTION_RECORD)pe->ExceptionRecord; CONTEXT *c = (CONTEXT*)pe->ContextRecord; - void *signal_callstack_top = NULL; if(in_code_heap_p(c->Eip)) signal_callstack_top = (void*)c->Esp; + else + signal_callstack_top = NULL; if(e->ExceptionCode == EXCEPTION_ACCESS_VIOLATION) { @@ -58,18 +59,3 @@ void c_to_factor_toplevel(CELL quot) c_to_factor(quot); RemoveVectoredExceptionHandler((void*)exception_handler); } - -void memory_signal_handler_impl(void) -{ - memory_protection_error(signal_fault_addr,signal_callstack_top); -} - -void divide_by_zero_signal_handler_impl(void) -{ - general_error(ERROR_DIVIDE_BY_ZERO,F,F,signal_callstack_top); -} - -void misc_signal_handler_impl(void) -{ - signal_error(signal_number,signal_callstack_top); -} diff --git a/vm/os-windows-nt.h b/vm/os-windows-nt.h index 4dc87d0f83..f3017b0cbe 100644 --- a/vm/os-windows-nt.h +++ b/vm/os-windows-nt.h @@ -14,6 +14,8 @@ typedef char F_SYMBOL; #define FACTOR_DLL L"factor-nt.dll" #define FACTOR_DLL_NAME "factor-nt.dll" +void c_to_factor_toplevel(CELL quot); + CELL signal_number; CELL signal_fault_addr; void *signal_callstack_top; diff --git a/vm/primitives.h b/vm/primitives.h index ce22cff528..2c0040f13f 100644 --- a/vm/primitives.h +++ b/vm/primitives.h @@ -14,19 +14,19 @@ DEFINE_PRIMITIVE(name) Becomes -FASTCALL void primitive_name(CELL word, F_STACK_FRAME *callstack_top) +F_FASTCALL void primitive_name(CELL word, F_STACK_FRAME *callstack_top) { stack_chain->callstack_top = callstack_top; ... CODE ... } -On x86, FASTCALL expands into a GCC declaration which forces the two parameters -to be passed in registers. This simplifies the quotation compiler and support -code in cpu-x86.S. */ +On x86, F_FASTCALL expands into a GCC declaration which forces the two +parameters to be passed in registers. This simplifies the quotation compiler +and support code in cpu-x86.S. */ #define DEFINE_PRIMITIVE(name) \ INLINE void primitive_##name##_impl(void); \ \ - FASTCALL void primitive_##name(CELL word, F_STACK_FRAME *callstack_top) \ + F_FASTCALL void primitive_##name(CELL word, F_STACK_FRAME *callstack_top) \ { \ stack_chain->callstack_top = callstack_top; \ primitive_##name##_impl(); \ @@ -36,4 +36,4 @@ code in cpu-x86.S. */ /* Prototype for header files */ #define DECLARE_PRIMITIVE(name) \ - FASTCALL void primitive_##name(CELL word, F_STACK_FRAME *callstack_top) + F_FASTCALL void primitive_##name(CELL word, F_STACK_FRAME *callstack_top) diff --git a/vm/run.c b/vm/run.c index 2b946b0722..20f6d71377 100644 --- a/vm/run.c +++ b/vm/run.c @@ -199,7 +199,7 @@ void not_implemented_error(void) } /* This function is called from the undefined function in cpu_*.S */ -FASTCALL void undefined_error(CELL word, F_STACK_FRAME *callstack_top) +F_FASTCALL void undefined_error(CELL word, F_STACK_FRAME *callstack_top) { stack_chain->callstack_top = callstack_top; general_error(ERROR_UNDEFINED_WORD,word,F,NULL); @@ -246,6 +246,21 @@ void divide_by_zero_error(F_STACK_FRAME *native_stack) general_error(ERROR_DIVIDE_BY_ZERO,F,F,native_stack); } +void memory_signal_handler_impl(void) +{ + memory_protection_error(signal_fault_addr,signal_callstack_top); +} + +void divide_by_zero_signal_handler_impl(void) +{ + divide_by_zero_error(signal_callstack_top); +} + +void misc_signal_handler_impl(void) +{ + signal_error(signal_number,signal_callstack_top); +} + DEFINE_PRIMITIVE(throw) { uncurry(dpop()); diff --git a/vm/run.h b/vm/run.h index 4d031350d3..7b29f0dac1 100644 --- a/vm/run.h +++ b/vm/run.h @@ -197,7 +197,7 @@ void signal_error(int signal, F_STACK_FRAME *native_stack); void type_error(CELL type, CELL tagged); void not_implemented_error(void); -FASTCALL void undefined_error(CELL word, F_STACK_FRAME *callstack_top); +F_FASTCALL void undefined_error(CELL word, F_STACK_FRAME *callstack_top); DECLARE_PRIMITIVE(throw); diff --git a/vm/stack.c b/vm/stack.c index cf3c1df00a..40e682b241 100644 --- a/vm/stack.c +++ b/vm/stack.c @@ -19,7 +19,7 @@ void fix_stacks(void) } /* called before entry into Factor code. */ -FASTCALL void save_callstack_bottom(F_STACK_FRAME *callstack_bottom) +F_FASTCALL void save_callstack_bottom(F_STACK_FRAME *callstack_bottom) { stack_chain->callstack_bottom = callstack_bottom; } diff --git a/vm/stack.h b/vm/stack.h index 62ee1d9ba2..58be5ae52f 100644 --- a/vm/stack.h +++ b/vm/stack.h @@ -48,7 +48,7 @@ CELL ds_size, rs_size; void reset_datastack(void); void reset_retainstack(void); void fix_stacks(void); -FASTCALL void save_callstack_bottom(F_STACK_FRAME *callstack_bottom); +F_FASTCALL void save_callstack_bottom(F_STACK_FRAME *callstack_bottom); DLLEXPORT void save_stacks(void); DLLEXPORT void nest_stacks(void); DLLEXPORT void unnest_stacks(void); From dcaee61e0e6a3ba54fe025cebb1f16ba4d6ad25d Mon Sep 17 00:00:00 2001 From: "U-3ADF\\Administrator" Date: Wed, 26 Sep 2007 19:40:32 +0200 Subject: [PATCH 04/88] Unit tests would fail if malloc failed (e.g. when it's not compiled) --- core/compiler/test/intrinsics.factor | 24 +++++++++++++++--------- 1 file changed, 15 insertions(+), 9 deletions(-) diff --git a/core/compiler/test/intrinsics.factor b/core/compiler/test/intrinsics.factor index 23e94a7974..a1c708218a 100644 --- a/core/compiler/test/intrinsics.factor +++ b/core/compiler/test/intrinsics.factor @@ -360,20 +360,26 @@ cell 8 = [ [ 3 ] [ B{ 1 2 3 4 5 } 2 [ { simple-c-ptr fixnum } declare alien-unsigned-1 ] compile-1 ] unit-test [ ] [ B{ 1 2 3 4 5 } malloc-byte-array "b" set ] unit-test +[ t ] [ "b" get >boolean ] unit-test -[ 3 ] [ "b" get 2 [ alien-unsigned-1 ] compile-1 ] unit-test -[ 3 ] [ "b" get [ { simple-alien } declare 2 alien-unsigned-1 ] compile-1 ] unit-test -[ 3 ] [ "b" get 2 [ { simple-alien fixnum } declare alien-unsigned-1 ] compile-1 ] unit-test -[ 3 ] [ "b" get 2 [ { simple-c-ptr fixnum } declare alien-unsigned-1 ] compile-1 ] unit-test +"b" get [ + [ 3 ] [ "b" get 2 [ alien-unsigned-1 ] compile-1 ] unit-test + [ 3 ] [ "b" get [ { simple-alien } declare 2 alien-unsigned-1 ] compile-1 ] unit-test + [ 3 ] [ "b" get 2 [ { simple-alien fixnum } declare alien-unsigned-1 ] compile-1 ] unit-test + [ 3 ] [ "b" get 2 [ { simple-c-ptr fixnum } declare alien-unsigned-1 ] compile-1 ] unit-test -[ ] [ "b" get free ] unit-test + [ ] [ "b" get free ] unit-test +] when -[ ] [ "hello world" malloc-char-string "s" set ] unit-test +[ t ] [ "hello world" malloc-char-string "s" set ] unit-test +[ t ] [ "s" get >boolean ] unit-test -[ "hello world" ] [ "s" get [ { byte-array } declare *void* ] compile-1 alien>char-string ] unit-test -[ "hello world" ] [ "s" get [ { simple-c-ptr } declare *void* ] compile-1 alien>char-string ] unit-test +"s" get [ + [ "hello world" ] [ "s" get [ { byte-array } declare *void* ] compile-1 alien>char-string ] unit-test + [ "hello world" ] [ "s" get [ { simple-c-ptr } declare *void* ] compile-1 alien>char-string ] unit-test -[ ] [ "s" get free ] unit-test + [ ] [ "s" get free ] unit-test +] when [ ALIEN: 1234 ] [ ALIEN: 1234 [ { simple-alien } declare ] compile-1 *void* ] unit-test [ ALIEN: 1234 ] [ ALIEN: 1234 [ { simple-c-ptr } declare ] compile-1 *void* ] unit-test From 73d664a7d5abaad2fc698d9fb9ea5b6cf60c78f9 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 27 Sep 2007 03:59:37 -0400 Subject: [PATCH 05/88] Minor benchmark update --- extra/benchmark/benchmark.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/extra/benchmark/benchmark.factor b/extra/benchmark/benchmark.factor index 0e7aa60abd..95b42f28e0 100644 --- a/extra/benchmark/benchmark.factor +++ b/extra/benchmark/benchmark.factor @@ -6,7 +6,8 @@ IN: benchmark : run-benchmark ( vocab -- result ) "=== Benchmark " write dup print flush - dup require [ run ] benchmark 2array ; + dup require [ run ] benchmark 2array + dup . ; : run-benchmarks ( -- assoc ) "benchmark" load-children From 5e2c7e769d6d653ce24c7225db28ebe8f87da18e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 27 Sep 2007 04:00:54 -0400 Subject: [PATCH 06/88] Clean up inference and fix hygiene issue with macros --- core/alien/compiler/compiler.factor | 7 +- core/combinators/combinators-docs.factor | 8 - core/generator/generator.factor | 7 +- core/generic/math/math.factor | 2 +- core/inference/backend/backend.factor | 190 +++++++++--------- core/inference/inference.factor | 21 +- core/inference/known-words/known-words.factor | 4 +- core/inference/transforms/transforms.factor | 16 +- core/quotations/quotations.factor | 4 - extra/cocoa/messages/messages.factor | 5 +- 10 files changed, 133 insertions(+), 131 deletions(-) diff --git a/core/alien/compiler/compiler.factor b/core/alien/compiler/compiler.factor index b63a110d85..864af9af3e 100644 --- a/core/alien/compiler/compiler.factor +++ b/core/alien/compiler/compiler.factor @@ -206,7 +206,7 @@ M: alien-invoke-error summary pop-literal nip over set-alien-invoke-library pop-literal nip over set-alien-invoke-return ! Quotation which coerces parameters to required types - dup make-prep-quot infer-quot + dup make-prep-quot recursive-state get infer-quot ! If symbol doesn't resolve, no stack effect, no compile dup alien-invoke-dlsym 2drop ! Add node to IR @@ -243,7 +243,7 @@ M: alien-indirect-error summary pop-parameters over set-alien-indirect-parameters pop-literal nip over set-alien-indirect-return ! Quotation which coerces parameters to required types - dup make-prep-quot 1 make-dip infer-quot + dup make-prep-quot [ dip ] curry recursive-state get infer-quot ! Add node to IR dup node, ! Magic #: consume the function pointer, too @@ -282,7 +282,8 @@ M: alien-callback-error summary drop "Words calling ``alien-callback'' cannot run in the interpreter. Compile the caller word and try again." ; : callback-bottom ( node -- ) - alien-callback-xt [ word-xt ] curry infer-quot ; + alien-callback-xt [ word-xt ] curry + recursive-state get infer-quot ; \ alien-callback [ 4 ensure-values diff --git a/core/combinators/combinators-docs.factor b/core/combinators/combinators-docs.factor index 731b12b0b4..4cea78bc97 100644 --- a/core/combinators/combinators-docs.factor +++ b/core/combinators/combinators-docs.factor @@ -5,7 +5,6 @@ IN: combinators ARTICLE: "combinators-quot" "Quotation construction utilities" "Some words for creating quotations which can be useful for implementing method combinations and compiler transforms:" -{ $subsection make-dip } { $subsection cond>quot } { $subsection case>quot } { $subsection alist>quot } @@ -27,13 +26,6 @@ ARTICLE: "combinators" "Additional combinators" ABOUT: "combinators" -HELP: make-dip -{ $values { "quot" "a quotation" } { "n" "a non-negative integer" } { "newquot" "a new quotation" } } -{ $description "Constructs a quotation which retains the top " { $snippet "n" } " stack items, and applies " { $snippet "quot" } " to what is underneath." } -{ $examples - { $example "USE: quotations" "[ 3 + ] 2 make-dip ." "[ >r >r 3 + r> r> ]" } -} ; - HELP: alist>quot { $values { "default" "a quotation" } { "assoc" "a sequence of quotation pairs" } { "quot" "a new quotation" } } { $description "Constructs a quotation which calls the first quotation in each pair of " { $snippet "assoc" } " until one of them outputs a true value, and then calls the second quotation in the corresponding pair. Quotations are called in reverse order, and if no quotation outputs a true value then " { $snippet "default" } " is called." } diff --git a/core/generator/generator.factor b/core/generator/generator.factor index 3b1ea07f0f..0417049983 100644 --- a/core/generator/generator.factor +++ b/core/generator/generator.factor @@ -73,10 +73,9 @@ SYMBOL: profiler-prologues : word-dataflow ( word -- dataflow ) [ dup "no-effect" word-prop [ no-effect ] when - dup dup add-recursive-state - [ specialized-def (dataflow) ] keep - finish-word drop - ] with-infer ; + dup specialized-def over dup 2array 1array infer-quot + finish-word + ] with-infer nip ; SYMBOL: compiler-hook diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor index c61ce0598b..9e702a3583 100644 --- a/core/generic/math/math.factor +++ b/core/generic/math/math.factor @@ -34,7 +34,7 @@ PREDICATE: class math-class ( object -- ? ) : math-upgrade ( class1 class2 -- quot ) [ math-class-max ] 2keep >r over r> (math-upgrade) - >r (math-upgrade) dup empty? [ 1 make-dip ] unless + >r (math-upgrade) dup empty? [ [ dip ] curry ] unless r> append ; TUPLE: no-math-method left right generic ; diff --git a/core/inference/backend/backend.factor b/core/inference/backend/backend.factor index d046c31dab..a059b9bd38 100644 --- a/core/inference/backend/backend.factor +++ b/core/inference/backend/backend.factor @@ -20,9 +20,6 @@ debugger assocs combinators ; : recursive-quotation? ( quot -- ? ) local-recursive-state [ first eq? ] curry* contains? ; -: add-recursive-state ( word label -- ) - 2array recursive-state [ swap add* ] change ; - TUPLE: inference-error rstate major? ; : (inference-error) ( ... class important? -- * ) @@ -65,12 +62,11 @@ SYMBOL: terminated? SYMBOL: recorded -: init-inference ( recursive-state -- ) +: init-inference ( -- ) terminated? off V{ } clone meta-d set V{ } clone meta-r set 0 d-in set - recursive-state set dataflow-graph off current-node off ; @@ -86,25 +82,31 @@ M: wrapper apply-object wrapped apply-literal ; : terminate ( -- ) terminated? on #terminate node, ; -: infer-quot ( quot -- ) - [ apply-object terminated? get not ] all? drop ; +: infer-quot ( quot rstate -- ) + recursive-state get >r + recursive-state set + [ apply-object terminated? get not ] all? drop + r> recursive-state set ; -TUPLE: recursive-quotation-error quot ; +: infer-quot-recursive ( quot word label -- ) + 2array add* infer-quot ; + +: time-bomb ( error -- ) + [ throw ] curry recursive-state get infer-quot ; : bad-call ( -- ) - [ "call must be given a callable" throw ] infer-quot ; + "call must be given a callable" time-bomb ; + +TUPLE: recursive-quotation-error quot ; : infer-quot-value ( value -- ) dup recursive-quotation? [ value-literal recursive-quotation-error inference-error ] [ dup value-literal callable? [ - recursive-state get >r - [ - [ value-recursion ] keep f 2array add* - recursive-state set - ] keep value-literal infer-quot - r> recursive-state set + dup value-literal + over value-recursion + rot f infer-quot-recursive ] [ drop bad-call ] if @@ -141,17 +143,6 @@ TUPLE: too-many-r> ; : undo-infer ( -- ) recorded get [ f "inferred-effect" set-word-prop ] each ; -: with-infer ( quot -- ) - [ - [ - { } recursive-state set - V{ } clone recorded set - f init-inference - call - check->r - ] [ ] [ undo-infer ] cleanup - ] with-scope ; - : (consume-values) ( n -- ) meta-d get [ length swap - ] keep set-length ; @@ -216,6 +207,11 @@ M: object constructor drop f ; : reify-all ( -- ) meta-d get length reify-curries ; +: end-infer ( -- ) + check->r + reify-all + f #return node, ; + : unify-lengths ( seq -- newseq ) dup empty? [ dup [ length ] map supremum @@ -349,65 +345,6 @@ TUPLE: no-effect word ; : no-effect ( word -- * ) \ no-effect inference-warning ; -: nest-node ( -- ) #entry node, ; - -: unnest-node ( new-node -- new-node ) - dup node-param #return node, - dataflow-graph get 1array over set-node-children ; - -: inline-block ( word -- node-block data ) - [ - copy-inference nest-node - gensym 2dup add-recursive-state - over >r #label r> word-def infer-quot - unnest-node - ] H{ } make-assoc ; - -: apply-infer ( hash -- ) - { meta-d meta-r d-in terminated? } - [ swap [ at ] curry map ] keep - [ set ] 2each ; - -GENERIC: collect-recursion* ( label node -- ) - -M: node collect-recursion* 2drop ; - -M: #call-label collect-recursion* - tuck node-param eq? [ , ] [ drop ] if ; - -: collect-recursion ( #label -- seq ) - dup node-param - [ [ swap collect-recursion* ] curry each-node ] { } make ; - -: join-values ( node -- ) - collect-recursion [ node-in-d ] map meta-d get add - unify-lengths unify-stacks - meta-d [ length tail* ] change ; - -: splice-node ( node -- ) - dup node-successor [ - dup node, penultimate-node f over set-node-successor - dup current-node set - ] when drop ; - -: inline-closure ( word -- ) - dup inline-block over recursive-label? [ - flatten-meta-d >r - drop join-values inline-block apply-infer - r> over set-node-in-d - dup node, - collect-recursion [ - [ flatten-curries ] modify-values - ] each - ] [ - apply-infer node-child node-successor splice-node drop - ] if ; - -: infer-compound ( word -- hash ) - [ - recursive-state get init-inference inline-block nip - ] with-scope ; - GENERIC: infer-word ( word -- effect ) M: word infer-word no-effect ; @@ -421,15 +358,22 @@ TUPLE: effect-error word effect ; dup pick "declared-effect" word-prop effect<= [ 2drop ] [ effect-error ] if ; -: finish-word ( word -- effect ) +: finish-word ( word -- ) current-effect 2dup check-effect over recorded get push - tuck "inferred-effect" set-word-prop ; + "inferred-effect" set-word-prop ; + +: infer-compound ( word -- ) + [ + init-inference + dup word-def over dup infer-quot-recursive + finish-word + ] with-scope ; M: compound infer-word - [ dup infer-compound [ finish-word ] bind ] - [ ] [ t "no-effect" set-word-prop ] cleanup ; + [ infer-compound ] [ ] [ t "no-effect" set-word-prop ] + cleanup ; : custom-infer ( word -- ) #! Customized inference behavior @@ -459,6 +403,60 @@ TUPLE: recursive-declare-error word ; \ recursive-declare-error inference-error ] if* ; +: nest-node ( -- ) #entry node, ; + +: unnest-node ( new-node -- new-node ) + dup node-param #return node, + dataflow-graph get 1array over set-node-children ; + +: inline-block ( word -- node-block data ) + [ + copy-inference nest-node + dup word-def swap gensym + recursive-state get pick pick infer-quot-recursive + #label unnest-node + ] H{ } make-assoc ; + +GENERIC: collect-recursion* ( label node -- ) + +M: node collect-recursion* 2drop ; + +M: #call-label collect-recursion* + tuck node-param eq? [ , ] [ drop ] if ; + +: collect-recursion ( #label -- seq ) + dup node-param + [ [ swap collect-recursion* ] curry each-node ] { } make ; + +: join-values ( node -- ) + collect-recursion [ node-in-d ] map meta-d get add + unify-lengths unify-stacks + meta-d [ length tail* ] change ; + +: splice-node ( node -- ) + dup node-successor [ + dup node, penultimate-node f over set-node-successor + dup current-node set + ] when drop ; + +: apply-infer ( hash -- ) + { meta-d meta-r d-in terminated? } + [ swap [ at ] curry map ] keep + [ set ] 2each ; + +: inline-closure ( word -- ) + dup inline-block over recursive-label? [ + flatten-meta-d >r + drop join-values inline-block apply-infer + r> over set-node-in-d + dup node, + collect-recursion [ + [ flatten-curries ] modify-values + ] each + ] [ + apply-infer node-child node-successor splice-node drop + ] if ; + M: compound apply-object [ dup inline-recursive-label @@ -469,4 +467,16 @@ M: compound apply-object ] if-inline ; M: undefined apply-object - drop [ "Undefined" throw ] infer-quot ; + drop "Undefined word" time-bomb ; + +: with-infer ( quot -- effect dataflow ) + [ + [ + V{ } clone recorded set + init-inference + call + end-infer + current-effect + dataflow-graph get + ] [ ] [ undo-infer ] cleanup + ] with-scope ; diff --git a/core/inference/inference.factor b/core/inference/inference.factor index e43afe9ccc..6eeea9e9cd 100644 --- a/core/inference/inference.factor +++ b/core/inference/inference.factor @@ -9,19 +9,20 @@ namespaces quotations ; GENERIC: infer ( quot -- effect ) M: callable infer ( quot -- effect ) - [ infer-quot current-effect ] with-infer ; + [ f infer-quot ] with-infer drop ; : infer. ( quot -- ) infer effect>string print ; -: (dataflow) ( quot -- dataflow ) - infer-quot - reify-all - f #return node, - dataflow-graph get ; +GENERIC: dataflow ( quot -- dataflow ) -: dataflow ( quot -- dataflow ) - [ (dataflow) ] with-infer ; +M: callable dataflow + [ f infer-quot ] with-infer nip ; -: dataflow-with ( quot stack -- dataflow ) - [ V{ } like meta-d set (dataflow) ] with-infer ; +GENERIC# dataflow-with 1 ( quot stack -- dataflow ) + +M: callable dataflow-with + [ + V{ } like meta-d set + f infer-quot + ] with-infer nip ; diff --git a/core/inference/known-words/known-words.factor b/core/inference/known-words/known-words.factor index 81fc7f6f34..08879999d3 100644 --- a/core/inference/known-words/known-words.factor +++ b/core/inference/known-words/known-words.factor @@ -69,6 +69,7 @@ M: object infer-call ] [ drop [ "execute must be given a word" throw ] + recursive-state get infer-quot ] if ] "infer" set-word-prop @@ -76,7 +77,8 @@ M: object infer-call \ if [ 3 ensure-values 2 d-tail [ special? ] contains? [ - [ rot [ drop call ] [ nip call ] if ] infer-quot + [ rot [ drop call ] [ nip call ] if ] + recursive-state get infer-quot ] [ [ #values ] 2 #drop node, pop-d pop-d swap 2array diff --git a/core/inference/transforms/transforms.factor b/core/inference/transforms/transforms.factor index 8a0dbb94b2..75782c7e4d 100644 --- a/core/inference/transforms/transforms.factor +++ b/core/inference/transforms/transforms.factor @@ -5,16 +5,16 @@ quotations assocs combinators math.bitfields inference.backend inference.dataflow tuples.private ; IN: inference.transforms -: pop-literals ( n -- seq ) - [ ensure-values ] keep - [ d-tail ] keep - (consume-values) - [ value-literal ] map ; +: pop-literals ( n -- rstate seq ) + dup zero? [ drop f ] [ + [ ensure-values ] keep [ d-tail ] keep (consume-values) + dup value-recursion swap [ value-literal ] map + ] if ; : transform-quot ( quot n -- newquot ) - [ - , \ pop-literals , [ [ ] each ] % % \ infer-quot , - ] [ ] make ; + [ pop-literals [ ] each ] curry + swap + [ swap infer-quot ] 3compose ; : define-transform ( word quot n -- ) transform-quot "infer" set-word-prop ; diff --git a/core/quotations/quotations.factor b/core/quotations/quotations.factor index 0905abae5d..6b4e494125 100644 --- a/core/quotations/quotations.factor +++ b/core/quotations/quotations.factor @@ -26,10 +26,6 @@ M: quotation like drop dup quotation? [ >quotation ] unless ; INSTANCE: quotation immutable-sequence -: make-dip ( quot n -- newquot ) - dup \ >r -rot \ r> 3append - >quotation ; - : 1quotation ( obj -- quot ) 1array >quotation ; GENERIC: literalize ( obj -- wrapped ) diff --git a/extra/cocoa/messages/messages.factor b/extra/cocoa/messages/messages.factor index 5276e1598c..79aa91b02e 100644 --- a/extra/cocoa/messages/messages.factor +++ b/extra/cocoa/messages/messages.factor @@ -3,7 +3,8 @@ USING: alien alien.c-types alien.compiler arrays assocs combinators compiler inference.transforms kernel math namespaces parser prettyprint prettyprint.sections -quotations sequences strings words cocoa.runtime io macros ; +quotations sequences strings words cocoa.runtime io macros +combinators.lib ; IN: cocoa.messages : make-sender ( method function -- quot ) @@ -74,7 +75,7 @@ H{ } clone objc-methods set-global [ \ , ] when swap cache-selector , \ selector , ] [ ] make - swap second length 2 - make-dip ; + swap second length 2 - [ ndip ] curry ; MACRO: (send) ( selector super? -- quot ) [ From cdad6df4221d0260d59a45a17abc546a1b9e5746 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 27 Sep 2007 04:50:24 -0400 Subject: [PATCH 07/88] Fixing inference after cleanup --- core/generic/math/math.factor | 10 +++------- core/inference/backend/backend.factor | 11 ++++++----- core/inference/transforms/transforms.factor | 6 ++++-- core/quotations/quotations.factor | 2 +- 4 files changed, 14 insertions(+), 15 deletions(-) diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor index 9e702a3583..912ece3a30 100644 --- a/core/generic/math/math.factor +++ b/core/generic/math/math.factor @@ -25,16 +25,12 @@ PREDICATE: class math-class ( object -- ? ) [ [ math-precedence ] compare 0 > ] most ; : (math-upgrade) ( max class -- quot ) - dupd = [ - drop [ ] - ] [ - "coercer" word-prop [ ] or - ] if ; + dupd = [ drop [ ] ] [ "coercer" word-prop [ ] or ] if ; : math-upgrade ( class1 class2 -- quot ) [ math-class-max ] 2keep - >r over r> (math-upgrade) - >r (math-upgrade) dup empty? [ [ dip ] curry ] unless + >r over r> (math-upgrade) >r (math-upgrade) + dup empty? [ [ dip ] curry [ ] like ] unless r> append ; TUPLE: no-math-method left right generic ; diff --git a/core/inference/backend/backend.factor b/core/inference/backend/backend.factor index a059b9bd38..a5f9e65160 100644 --- a/core/inference/backend/backend.factor +++ b/core/inference/backend/backend.factor @@ -89,7 +89,7 @@ M: wrapper apply-object wrapped apply-literal ; r> recursive-state set ; : infer-quot-recursive ( quot word label -- ) - 2array add* infer-quot ; + recursive-state get -rot 2array add* infer-quot ; : time-bomb ( error -- ) [ throw ] curry recursive-state get infer-quot ; @@ -106,7 +106,7 @@ TUPLE: recursive-quotation-error quot ; dup value-literal callable? [ dup value-literal over value-recursion - rot f infer-quot-recursive + rot f 2array add* infer-quot ] [ drop bad-call ] if @@ -364,11 +364,12 @@ TUPLE: effect-error word effect ; over recorded get push "inferred-effect" set-word-prop ; -: infer-compound ( word -- ) +: infer-compound ( word -- effect ) [ init-inference dup word-def over dup infer-quot-recursive finish-word + current-effect ] with-scope ; M: compound infer-word @@ -413,8 +414,8 @@ TUPLE: recursive-declare-error word ; [ copy-inference nest-node dup word-def swap gensym - recursive-state get pick pick infer-quot-recursive - #label unnest-node + [ infer-quot-recursive ] 2keep + #label unnest-node ] H{ } make-assoc ; GENERIC: collect-recursion* ( label node -- ) diff --git a/core/inference/transforms/transforms.factor b/core/inference/transforms/transforms.factor index 75782c7e4d..85f3c85cff 100644 --- a/core/inference/transforms/transforms.factor +++ b/core/inference/transforms/transforms.factor @@ -8,7 +8,7 @@ IN: inference.transforms : pop-literals ( n -- rstate seq ) dup zero? [ drop f ] [ [ ensure-values ] keep [ d-tail ] keep (consume-values) - dup value-recursion swap [ value-literal ] map + dup first value-recursion swap [ value-literal ] map ] if ; : transform-quot ( quot n -- newquot ) @@ -19,6 +19,7 @@ IN: inference.transforms : define-transform ( word quot n -- ) transform-quot "infer" set-word-prop ; +! Combinators \ cond [ cond>quot ] 1 define-transform @@ -35,6 +36,7 @@ IN: inference.transforms ] if ] 1 define-transform +! Bitfields GENERIC: (bitfield-quot) ( spec -- quot ) M: integer (bitfield-quot) ( spec -- quot ) @@ -58,5 +60,5 @@ M: pair (bitfield-quot) ( spec -- quot ) \ set-slots [ [get-slots] ] 1 define-transform \ construct-boa [ - [ dup literalize , tuple-size , \ , ] [ ] make + dup tuple-size [ ] 2curry ] 1 define-transform diff --git a/core/quotations/quotations.factor b/core/quotations/quotations.factor index 6b4e494125..061ff04889 100644 --- a/core/quotations/quotations.factor +++ b/core/quotations/quotations.factor @@ -43,6 +43,6 @@ M: curry nth >r 1- r> curry-quot nth ] if ; -M: curry like drop [ ] like ; +M: curry like drop dup callable? [ >quotation ] unless ; INSTANCE: curry immutable-sequence From 9a0ac0e97558e58ffb717e28fb8ed26d9e82edde Mon Sep 17 00:00:00 2001 From: "U-C4\\Administrator" Date: Thu, 27 Sep 2007 15:10:37 -0500 Subject: [PATCH 08/88] Attempt to merge in changes F_FASTCALL --- core/compiler/test/intrinsics.factor | 22 +++++++++++++--------- vm/cpu-ppc.h | 2 +- vm/cpu-x86.32.h | 3 ++- vm/cpu-x86.64.h | 2 +- vm/cpu-x86.S | 16 ++++++++-------- vm/cpu-x86.h | 14 +++++++------- vm/jit.c | 2 +- vm/jit.h | 2 +- vm/os-unix.c | 10 ---------- vm/os-windows-nt.c | 18 ++---------------- vm/os-windows-nt.h | 2 ++ vm/primitives.h | 12 ++++++------ vm/run.c | 17 ++++++++++++++++- vm/run.h | 2 +- vm/stack.c | 2 +- vm/stack.h | 2 +- 16 files changed, 63 insertions(+), 65 deletions(-) diff --git a/core/compiler/test/intrinsics.factor b/core/compiler/test/intrinsics.factor index 23e94a7974..3a18f0ebe4 100644 --- a/core/compiler/test/intrinsics.factor +++ b/core/compiler/test/intrinsics.factor @@ -361,19 +361,23 @@ cell 8 = [ [ ] [ B{ 1 2 3 4 5 } malloc-byte-array "b" set ] unit-test -[ 3 ] [ "b" get 2 [ alien-unsigned-1 ] compile-1 ] unit-test -[ 3 ] [ "b" get [ { simple-alien } declare 2 alien-unsigned-1 ] compile-1 ] unit-test -[ 3 ] [ "b" get 2 [ { simple-alien fixnum } declare alien-unsigned-1 ] compile-1 ] unit-test -[ 3 ] [ "b" get 2 [ { simple-c-ptr fixnum } declare alien-unsigned-1 ] compile-1 ] unit-test +"b" get [ + [ 3 ] [ "b" get 2 [ alien-unsigned-1 ] compile-1 ] unit-test + [ 3 ] [ "b" get [ { simple-alien } declare 2 alien-unsigned-1 ] compile-1 ] unit-test + [ 3 ] [ "b" get 2 [ { simple-alien fixnum } declare alien-unsigned-1 ] compile-1 ] unit-test + [ 3 ] [ "b" get 2 [ { simple-c-ptr fixnum } declare alien-unsigned-1 ] compile-1 ] unit-test -[ ] [ "b" get free ] unit-test + [ ] [ "b" get free ] unit-test +] when -[ ] [ "hello world" malloc-char-string "s" set ] unit-test +[ t ] [ "hello world" malloc-char-string "s" set ] unit-test -[ "hello world" ] [ "s" get [ { byte-array } declare *void* ] compile-1 alien>char-string ] unit-test -[ "hello world" ] [ "s" get [ { simple-c-ptr } declare *void* ] compile-1 alien>char-string ] unit-test +"s" get [ + [ "hello world" ] [ "s" get [ { byte-array } declare *void* ] compile-1 alien>char-string ] unit-test + [ "hello world" ] [ "s" get [ { simple-c-ptr } declare *void* ] compile-1 alien>char-string ] unit-test -[ ] [ "s" get free ] unit-test + [ ] [ "s" get free ] unit-test +] when [ ALIEN: 1234 ] [ ALIEN: 1234 [ { simple-alien } declare ] compile-1 *void* ] unit-test [ ALIEN: 1234 ] [ ALIEN: 1234 [ { simple-c-ptr } declare ] compile-1 *void* ] unit-test diff --git a/vm/cpu-ppc.h b/vm/cpu-ppc.h index c74e13e68b..ac4a0a92ee 100644 --- a/vm/cpu-ppc.h +++ b/vm/cpu-ppc.h @@ -1,5 +1,5 @@ #define FACTOR_CPU_STRING "ppc" -#define FASTCALL +#define F_FASTCALL register CELL ds asm("r14"); register CELL rs asm("r15"); diff --git a/vm/cpu-x86.32.h b/vm/cpu-x86.32.h index 4c4acb0ad3..a81c9987c4 100644 --- a/vm/cpu-x86.32.h +++ b/vm/cpu-x86.32.h @@ -3,4 +3,5 @@ register CELL ds asm("esi"); register CELL rs asm("edi"); -#define FASTCALL __attribute__ ((regparm (2))) +#define F_FASTCALL __attribute__ ((regparm (2))) + diff --git a/vm/cpu-x86.64.h b/vm/cpu-x86.64.h index 0b3b5a2471..6412355129 100644 --- a/vm/cpu-x86.64.h +++ b/vm/cpu-x86.64.h @@ -3,4 +3,4 @@ register CELL ds asm("r14"); register CELL rs asm("r15"); -#define FASTCALL +#define F_FASTCALL diff --git a/vm/cpu-x86.S b/vm/cpu-x86.S index ec5d09291e..7032b77e18 100644 --- a/vm/cpu-x86.S +++ b/vm/cpu-x86.S @@ -2,7 +2,7 @@ mov QUOT_XT_OFFSET(ARG0),XT_REG ; /* Load quot-xt */ \ jmp *XT_REG /* Jump to quot-xt */ -DEF(FASTCALL void,c_to_factor,(CELL quot)): +DEF(F_FASTCALL void,c_to_factor,(CELL quot)): PUSH_NONVOLATILE push ARG0 /* Save quot */ @@ -17,38 +17,38 @@ DEF(FASTCALL void,c_to_factor,(CELL quot)): POP_NONVOLATILE ret -DEF(FASTCALL void,undefined,(CELL word)): +DEF(F_FASTCALL void,undefined,(CELL word)): mov STACK_REG,ARG1 /* Pass callstack pointer */ jmp MANGLE(undefined_error) /* This throws an error */ -DEF(FASTCALL void,dosym,(CELL word)): +DEF(F_FASTCALL void,dosym,(CELL word)): add $CELL_SIZE,DS_REG /* Increment stack pointer */ mov ARG0,(DS_REG) /* Store word on stack */ ret /* Here we have two entry points. The first one is taken when profiling is enabled */ -DEF(FASTCALL void,docol_profiling,(CELL word)): +DEF(F_FASTCALL void,docol_profiling,(CELL word)): add $CELL_SIZE,PROFILING_OFFSET(ARG0) /* Increment profile-count slot */ -DEF(FASTCALL void,docol,(CELL word)): +DEF(F_FASTCALL void,docol,(CELL word)): mov WORD_DEF_OFFSET(ARG0),ARG0 /* Load word-def slot */ JUMP_QUOT /* We must pass the XT to the quotation in ECX. */ -DEF(FASTCALL void,primitive_call,(void)): +DEF(F_FASTCALL void,primitive_call,(void)): mov (DS_REG),ARG0 /* Load quotation from data stack */ sub $CELL_SIZE,DS_REG /* Pop data stack */ JUMP_QUOT /* We pass the word in EAX and the XT in ECX. Don't mess up EDX, it's the callstack top parameter to primitives. */ -DEF(FASTCALL void,primitive_execute,(void)): +DEF(F_FASTCALL void,primitive_execute,(void)): mov (DS_REG),ARG0 /* Load word from data stack */ sub $CELL_SIZE,DS_REG /* Pop data stack */ mov WORD_XT_OFFSET(ARG0),XT_REG /* Load word-xt slot */ jmp *XT_REG /* Go */ -DEF(FASTCALL void,throw_impl,(CELL quot, F_STACK_FRAME *rewind_to)): +DEF(F_FASTCALL void,throw_impl,(CELL quot, F_STACK_FRAME *rewind_to)): mov ARG1,STACK_REG /* rewind_to */ JUMP_QUOT diff --git a/vm/cpu-x86.h b/vm/cpu-x86.h index 63bf2b08e1..91f1f8236a 100644 --- a/vm/cpu-x86.h +++ b/vm/cpu-x86.h @@ -22,12 +22,12 @@ typedef struct _F_STACK_FRAME INLINE void flush_icache(CELL start, CELL len) {} -FASTCALL void c_to_factor(CELL quot); -FASTCALL void throw_impl(CELL quot, F_STACK_FRAME *rewind_to); -FASTCALL void undefined(CELL word); -FASTCALL void dosym(CELL word); -FASTCALL void docol_profiling(CELL word); -FASTCALL void docol(CELL word); -FASTCALL void lazy_jit_compile(CELL quot); +F_FASTCALL void c_to_factor(CELL quot); +F_FASTCALL void throw_impl(CELL quot, F_STACK_FRAME *rewind_to); +F_FASTCALL void undefined(CELL word); +F_FASTCALL void dosym(CELL word); +F_FASTCALL void docol_profiling(CELL word); +F_FASTCALL void docol(CELL word); +F_FASTCALL void lazy_jit_compile(CELL quot); void set_callstack(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, void *memcpy); diff --git a/vm/jit.c b/vm/jit.c index 6faf0a6a17..51fa06ef86 100644 --- a/vm/jit.c +++ b/vm/jit.c @@ -34,7 +34,7 @@ bool jit_stack_frame_p(F_ARRAY *array) return false; } -FASTCALL CELL jit_compile(CELL tagged, F_STACK_FRAME *stack) +F_FASTCALL CELL jit_compile(CELL tagged, F_STACK_FRAME *stack) { stack_chain->callstack_top = stack; diff --git a/vm/jit.h b/vm/jit.h index a9f1399472..d1c91b631b 100644 --- a/vm/jit.h +++ b/vm/jit.h @@ -1,2 +1,2 @@ -DLLEXPORT FASTCALL CELL jit_compile(CELL tagged, F_STACK_FRAME *stack); +DLLEXPORT F_FASTCALL CELL jit_compile(CELL tagged, F_STACK_FRAME *stack); XT quot_offset_to_pc(F_QUOTATION *quot, F_FIXNUM offset); diff --git a/vm/os-unix.c b/vm/os-unix.c index 2d9ba02ca5..65ae79550c 100644 --- a/vm/os-unix.c +++ b/vm/os-unix.c @@ -179,11 +179,6 @@ INLINE F_STACK_FRAME *uap_stack_pointer(void *uap) return NULL; } -void memory_signal_handler_impl(void) -{ - memory_protection_error(signal_fault_addr,signal_callstack_top); -} - void memory_signal_handler(int signal, siginfo_t *siginfo, void *uap) { signal_fault_addr = (CELL)siginfo->si_addr; @@ -191,11 +186,6 @@ void memory_signal_handler(int signal, siginfo_t *siginfo, void *uap) UAP_PROGRAM_COUNTER(uap) = (CELL)memory_signal_handler_impl; } -void misc_signal_handler_impl(void) -{ - signal_error(signal_number,signal_callstack_top); -} - void misc_signal_handler(int signal, siginfo_t *siginfo, void *uap) { signal_number = signal; diff --git a/vm/os-windows-nt.c b/vm/os-windows-nt.c index cf40745cdd..8f7513a32a 100644 --- a/vm/os-windows-nt.c +++ b/vm/os-windows-nt.c @@ -27,10 +27,11 @@ long exception_handler(PEXCEPTION_POINTERS pe) { PEXCEPTION_RECORD e = (PEXCEPTION_RECORD)pe->ExceptionRecord; CONTEXT *c = (CONTEXT*)pe->ContextRecord; - void *signal_callstack_top = NULL; if(in_code_heap_p(c->Eip)) signal_callstack_top = (void*)c->Esp; + else + signal_callstack_top = NULL; if(e->ExceptionCode == EXCEPTION_ACCESS_VIOLATION) { @@ -58,18 +59,3 @@ void c_to_factor_toplevel(CELL quot) c_to_factor(quot); RemoveVectoredExceptionHandler((void*)exception_handler); } - -void memory_signal_handler_impl(void) -{ - memory_protection_error(signal_fault_addr,signal_callstack_top); -} - -void divide_by_zero_signal_handler_impl(void) -{ - general_error(ERROR_DIVIDE_BY_ZERO,F,F,signal_callstack_top); -} - -void misc_signal_handler_impl(void) -{ - signal_error(signal_number,signal_callstack_top); -} diff --git a/vm/os-windows-nt.h b/vm/os-windows-nt.h index 4dc87d0f83..f3017b0cbe 100644 --- a/vm/os-windows-nt.h +++ b/vm/os-windows-nt.h @@ -14,6 +14,8 @@ typedef char F_SYMBOL; #define FACTOR_DLL L"factor-nt.dll" #define FACTOR_DLL_NAME "factor-nt.dll" +void c_to_factor_toplevel(CELL quot); + CELL signal_number; CELL signal_fault_addr; void *signal_callstack_top; diff --git a/vm/primitives.h b/vm/primitives.h index ce22cff528..2c0040f13f 100644 --- a/vm/primitives.h +++ b/vm/primitives.h @@ -14,19 +14,19 @@ DEFINE_PRIMITIVE(name) Becomes -FASTCALL void primitive_name(CELL word, F_STACK_FRAME *callstack_top) +F_FASTCALL void primitive_name(CELL word, F_STACK_FRAME *callstack_top) { stack_chain->callstack_top = callstack_top; ... CODE ... } -On x86, FASTCALL expands into a GCC declaration which forces the two parameters -to be passed in registers. This simplifies the quotation compiler and support -code in cpu-x86.S. */ +On x86, F_FASTCALL expands into a GCC declaration which forces the two +parameters to be passed in registers. This simplifies the quotation compiler +and support code in cpu-x86.S. */ #define DEFINE_PRIMITIVE(name) \ INLINE void primitive_##name##_impl(void); \ \ - FASTCALL void primitive_##name(CELL word, F_STACK_FRAME *callstack_top) \ + F_FASTCALL void primitive_##name(CELL word, F_STACK_FRAME *callstack_top) \ { \ stack_chain->callstack_top = callstack_top; \ primitive_##name##_impl(); \ @@ -36,4 +36,4 @@ code in cpu-x86.S. */ /* Prototype for header files */ #define DECLARE_PRIMITIVE(name) \ - FASTCALL void primitive_##name(CELL word, F_STACK_FRAME *callstack_top) + F_FASTCALL void primitive_##name(CELL word, F_STACK_FRAME *callstack_top) diff --git a/vm/run.c b/vm/run.c index 255be845d3..d4f95a47f2 100644 --- a/vm/run.c +++ b/vm/run.c @@ -197,7 +197,7 @@ void not_implemented_error(void) } /* This function is called from the undefined function in cpu_*.S */ -FASTCALL void undefined_error(CELL word, F_STACK_FRAME *callstack_top) +F_FASTCALL void undefined_error(CELL word, F_STACK_FRAME *callstack_top) { stack_chain->callstack_top = callstack_top; general_error(ERROR_UNDEFINED_WORD,word,F,NULL); @@ -244,6 +244,21 @@ void divide_by_zero_error(F_STACK_FRAME *native_stack) general_error(ERROR_DIVIDE_BY_ZERO,F,F,native_stack); } +void memory_signal_handler_impl(void) +{ + memory_protection_error(signal_fault_addr,signal_callstack_top); +} + +void divide_by_zero_signal_handler_impl(void) +{ + divide_by_zero_error(signal_callstack_top); +} + +void misc_signal_handler_impl(void) +{ + signal_error(signal_number,signal_callstack_top); +} + DEFINE_PRIMITIVE(throw) { uncurry(dpop()); diff --git a/vm/run.h b/vm/run.h index 72ee7eea17..73454989ce 100644 --- a/vm/run.h +++ b/vm/run.h @@ -197,7 +197,7 @@ void signal_error(int signal, F_STACK_FRAME *native_stack); void type_error(CELL type, CELL tagged); void not_implemented_error(void); -FASTCALL void undefined_error(CELL word, F_STACK_FRAME *callstack_top); +F_FASTCALL void undefined_error(CELL word, F_STACK_FRAME *callstack_top); DECLARE_PRIMITIVE(throw); diff --git a/vm/stack.c b/vm/stack.c index b2a05b9181..9ba4e35bf5 100644 --- a/vm/stack.c +++ b/vm/stack.c @@ -19,7 +19,7 @@ void fix_stacks(void) } /* called before entry into Factor code. */ -FASTCALL void save_callstack_bottom(F_STACK_FRAME *callstack_bottom) +F_FASTCALL void save_callstack_bottom(F_STACK_FRAME *callstack_bottom) { stack_chain->callstack_bottom = callstack_bottom; } diff --git a/vm/stack.h b/vm/stack.h index 62ee1d9ba2..58be5ae52f 100644 --- a/vm/stack.h +++ b/vm/stack.h @@ -48,7 +48,7 @@ CELL ds_size, rs_size; void reset_datastack(void); void reset_retainstack(void); void fix_stacks(void); -FASTCALL void save_callstack_bottom(F_STACK_FRAME *callstack_bottom); +F_FASTCALL void save_callstack_bottom(F_STACK_FRAME *callstack_bottom); DLLEXPORT void save_stacks(void); DLLEXPORT void nest_stacks(void); DLLEXPORT void unnest_stacks(void); From 83f552fae8bcaf0dd7c6a43148cc5aa27750f95b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 27 Sep 2007 16:11:03 -0400 Subject: [PATCH 09/88] More inference bug fixes --- core/inference/known-words/known-words.factor | 4 +--- core/inference/transforms/transforms.factor | 9 ++++++--- extra/cocoa/messages/messages.factor | 2 +- 3 files changed, 8 insertions(+), 7 deletions(-) diff --git a/core/inference/known-words/known-words.factor b/core/inference/known-words/known-words.factor index 08879999d3..69614b134e 100644 --- a/core/inference/known-words/known-words.factor +++ b/core/inference/known-words/known-words.factor @@ -68,9 +68,7 @@ M: object infer-call apply-object ] [ drop - [ "execute must be given a word" throw ] - recursive-state get - infer-quot + "execute must be given a word" time-bomb ] if ] "infer" set-word-prop diff --git a/core/inference/transforms/transforms.factor b/core/inference/transforms/transforms.factor index 85f3c85cff..71ccbc3c35 100644 --- a/core/inference/transforms/transforms.factor +++ b/core/inference/transforms/transforms.factor @@ -6,9 +6,12 @@ inference.dataflow tuples.private ; IN: inference.transforms : pop-literals ( n -- rstate seq ) - dup zero? [ drop f ] [ - [ ensure-values ] keep [ d-tail ] keep (consume-values) - dup first value-recursion swap [ value-literal ] map + dup zero? [ drop recursive-state get f ] [ + [ ensure-values ] keep + [ d-tail ] keep + (consume-values) + dup [ value-literal ] map + swap first value-recursion swap ] if ; : transform-quot ( quot n -- newquot ) diff --git a/extra/cocoa/messages/messages.factor b/extra/cocoa/messages/messages.factor index 79aa91b02e..5b61f39384 100644 --- a/extra/cocoa/messages/messages.factor +++ b/extra/cocoa/messages/messages.factor @@ -75,7 +75,7 @@ H{ } clone objc-methods set-global [ \ , ] when swap cache-selector , \ selector , ] [ ] make - swap second length 2 - [ ndip ] curry ; + swap second length 2 - [ ndip ] 2curry ; MACRO: (send) ( selector super? -- quot ) [ From 514ee9dd3af4ee8cdf8a3ef76b1ce21209199ff6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 27 Sep 2007 16:11:37 -0400 Subject: [PATCH 10/88] ogg.player cleanup --- extra/ogg/player/player.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/extra/ogg/player/player.factor b/extra/ogg/player/player.factor index 08731f7a7f..9f6e1c418b 100644 --- a/extra/ogg/player/player.factor +++ b/extra/ogg/player/player.factor @@ -148,7 +148,7 @@ HINTS: yuv>rgb byte-array byte-array ; : process-video ( player -- player ) dup player-gadget [ dup { player-td player-yuv } get-slots theora_decode_YUVout drop - dup player-rgb over player-yuv yuv>rgb + dup player-rgb over player-yuv [ yuv>rgb ] time flush dup player-gadget find-world dup draw-world ] when ; @@ -158,7 +158,7 @@ HINTS: yuv>rgb byte-array byte-array ; : append-new-audio-buffer ( player -- player ) dup player-buffers 1 gen-buffers append over set-player-buffers - [ dup >r player-buffers second r> al-channel-format ] keep + [ [ player-buffers second ] keep al-channel-format ] keep [ player-audio-buffer dup length ] keep [ player-vi vorbis_info-rate alBufferData check-error ] keep [ player-source 1 ] keep @@ -182,7 +182,7 @@ HINTS: yuv>rgb byte-array byte-array ; } cond ; : start-audio ( player -- player bool ) - [ dup >r player-buffers first r> al-channel-format ] keep + [ [ player-buffers first ] keep al-channel-format ] keep [ player-audio-buffer dup length ] keep [ player-vi vorbis_info-rate alBufferData check-error ] keep [ player-source 1 ] keep From ab89a3b9025f51a39bca2d143dd4998b54036573 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 27 Sep 2007 17:30:02 -0400 Subject: [PATCH 11/88] Better .gitignore --- .gitignore | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/.gitignore b/.gitignore index a3f5d94252..6a748023af 100644 --- a/.gitignore +++ b/.gitignore @@ -10,3 +10,7 @@ Factor/factor *.image *.dylib factor +*#*# +.DS_Store +.gdb_history +*.*.marks From 480e6a8b2b438426547c45bef50dd7d53d7f56d4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 27 Sep 2007 17:30:34 -0400 Subject: [PATCH 12/88] Clean up generator.registers a bit --- core/alien/compiler/compiler.factor | 19 +++ core/compiler/test/templates-early.factor | 4 +- core/generator/generator.factor | 14 +- core/generator/registers/registers.factor | 175 +++++++++++----------- 4 files changed, 114 insertions(+), 98 deletions(-) diff --git a/core/alien/compiler/compiler.factor b/core/alien/compiler/compiler.factor index 864af9af3e..aa46271fed 100644 --- a/core/alien/compiler/compiler.factor +++ b/core/alien/compiler/compiler.factor @@ -62,6 +62,25 @@ GENERIC: alien-node-abi ( node -- str ) call f set-stack-frame ; inline +GENERIC: reg-size ( register-class -- n ) + +M: int-regs reg-size drop cell ; + +M: float-regs reg-size float-regs-size ; + +GENERIC: inc-reg-class ( register-class -- ) + +: (inc-reg-class) + dup class inc + fp-shadows-int? [ reg-size stack-params +@ ] [ drop ] if ; + +M: int-regs inc-reg-class + (inc-reg-class) ; + +M: float-regs inc-reg-class + dup (inc-reg-class) + fp-shadows-int? [ reg-size 4 / int-regs +@ ] [ drop ] if ; + : reg-class-full? ( class -- ? ) dup class get swap param-regs length >= ; diff --git a/core/compiler/test/templates-early.factor b/core/compiler/test/templates-early.factor index 5f6ece5d68..8286d0cda4 100644 --- a/core/compiler/test/templates-early.factor +++ b/core/compiler/test/templates-early.factor @@ -8,7 +8,7 @@ namespaces sequences words kernel math effects ; [ V{ 3 } ] [ 3 fresh-object fresh-objects get ] unit-test - [ ] [ 0 phantom-d get phantom-push ] unit-test + [ ] [ 0 phantom-push ] unit-test [ ] [ compute-free-vregs ] unit-test @@ -17,7 +17,7 @@ namespaces sequences words kernel math effects ; [ f ] [ [ copy-templates - 1 phantom-d get phantom-push + 1 phantom-push compute-free-vregs 1 T{ int-regs } free-vregs member? ] with-scope diff --git a/core/generator/generator.factor b/core/generator/generator.factor index 0417049983..fd82135651 100644 --- a/core/generator/generator.factor +++ b/core/generator/generator.factor @@ -228,7 +228,7 @@ M: #dispatch generate-node "true" resolve-label t "if-scratch" get load-literal "end" resolve-label - "if-scratch" get phantom-d get phantom-push ; inline + "if-scratch" get phantom-push ; inline : define-if>boolean-intrinsics ( word intrinsics -- ) [ @@ -281,26 +281,20 @@ M: #call-label generate-node node-param generate-call ; UNION: immediate fixnum POSTPONE: f ; M: #push generate-node - node-out-d phantom-d get phantom-append iterate-next ; + node-out-d [ phantom-push ] each iterate-next ; ! #shuffle -: phantom-shuffle ( shuffle -- ) - [ effect-in length phantom-d get phantom-input ] keep - shuffle* phantom-d get phantom-append ; - M: #shuffle generate-node node-shuffle phantom-shuffle iterate-next ; M: #>r generate-node node-in-d length - phantom-d get phantom-input - phantom-r get phantom-append + phantom->r iterate-next ; M: #r> generate-node node-out-d length - phantom-r get phantom-input - phantom-d get phantom-append + phantom-r> iterate-next ; ! #return diff --git a/core/generator/registers/registers.factor b/core/generator/registers/registers.factor index c77ec056cc..4797d68b39 100644 --- a/core/generator/registers/registers.factor +++ b/core/generator/registers/registers.factor @@ -2,10 +2,17 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays assocs classes classes.private combinators cpu.architecture generator.fixup generic hashtables -inference.dataflow kernel kernel.private layouts math memory -namespaces quotations sequences system vectors words ; +inference.dataflow inference.stack kernel kernel.private layouts +math memory namespaces quotations sequences system vectors words +effects ; IN: generator.registers +SYMBOL: +input+ +SYMBOL: +output+ +SYMBOL: +scratch+ +SYMBOL: +clobber+ +SYMBOL: known-tag + ! A scratch register for computations TUPLE: vreg n ; @@ -24,45 +31,8 @@ TUPLE: temp-reg ; : temp-reg T{ temp-reg T{ int-regs } } ; -: %move ( dst src -- ) - 2dup = [ - 2drop - ] [ - 2dup [ delegate class ] 2apply 2array { - { { int-regs int-regs } [ %move-int>int ] } - { { float-regs int-regs } [ %move-int>float ] } - { { int-regs float-regs } [ %move-float>int ] } - } case - ] if ; - -GENERIC: reg-size ( register-class -- n ) - -GENERIC: inc-reg-class ( register-class -- ) - -M: int-regs reg-size drop cell ; - -: (inc-reg-class) - dup class inc - fp-shadows-int? [ reg-size stack-params +@ ] [ drop ] if ; - -M: int-regs inc-reg-class - (inc-reg-class) ; - -M: float-regs reg-size float-regs-size ; - -M: float-regs inc-reg-class - dup (inc-reg-class) - fp-shadows-int? [ reg-size 4 / int-regs +@ ] [ drop ] if ; - M: vreg v>operand dup vreg-n swap vregs nth ; -: reg-spec>class ( spec -- class ) - float eq? - T{ float-regs f 8 } T{ int-regs } ? ; - -SYMBOL: phantom-d -SYMBOL: phantom-r - ! A data stack location. TUPLE: ds-loc n ; @@ -73,10 +43,18 @@ TUPLE: rs-loc n ; C: rs-loc + ( class -- stack ) >r V{ } clone 0 @@ -84,10 +62,6 @@ TUPLE: phantom-stack height ; phantom-stack construct r> construct-delegate ; -GENERIC: finalize-height ( stack -- ) - -GENERIC: ( n stack -- loc ) - : (loc) #! Utility for methods on phantom-stack-height - ; @@ -102,6 +76,8 @@ GENERIC: ( n stack -- loc ) 0 ] keep set-phantom-stack-height ; inline +GENERIC: ( n stack -- loc ) + TUPLE: phantom-datastack ; : phantom-datastack ; @@ -137,17 +113,14 @@ M: phantom-retainstack finalize-height : adjust-phantom ( n phantom -- ) [ phantom-stack-height + ] keep set-phantom-stack-height ; -: phantom-push ( obj stack -- ) - 1 over adjust-phantom push ; - -: phantom-append ( seq stack -- ) - over length over adjust-phantom push-all ; - GENERIC: cut-phantom ( n phantom -- seq ) M: phantom-stack cut-phantom [ delegate cut* swap ] keep set-delegate ; +: phantom-append ( seq stack -- ) + over length over adjust-phantom push-all ; + : phantom-input ( n phantom -- seq ) [ 2dup length <= [ @@ -160,6 +133,26 @@ M: phantom-stack cut-phantom ] if ] 2keep >r neg r> adjust-phantom ; +PRIVATE> + +: phantom-push ( obj -- ) + 1 phantom-d get adjust-phantom + phantom-d get push ; + +: phantom-shuffle ( shuffle -- ) + [ effect-in length phantom-d get phantom-input ] keep + shuffle* phantom-d get phantom-append ; + +: phantom->r ( n -- ) + phantom-d get phantom-input + phantom-r get phantom-append ; + +: phantom-r> ( n -- ) + phantom-r get phantom-input + phantom-d get phantom-append ; + +assoc \ free-vregs set drop ; -: init-templates ( -- ) - #! Initialize register allocator. - V{ } clone fresh-objects set - phantom-d set - phantom-r set - compute-free-vregs ; - -: copy-templates ( -- ) - #! Copies register allocator state, used when compiling - #! branches. - fresh-objects [ clone ] change - phantom-d [ clone ] change - phantom-r [ clone ] change - compute-free-vregs ; +: reg-spec>class ( spec -- class ) + float eq? + T{ float-regs f 8 } T{ int-regs } ? ; ! Copying vregs to stacks : alloc-vreg ( spec -- vreg ) reg-spec>class free-vregs pop ; +: %move ( dst src -- ) + 2dup = [ + 2drop + ] [ + 2dup [ delegate class ] 2apply 2array { + { { int-regs int-regs } [ %move-int>int ] } + { { float-regs int-regs } [ %move-int>float ] } + { { int-regs float-regs } [ %move-float>int ] } + } case + ] if ; + : vreg>vreg ( vreg spec -- vreg ) alloc-vreg dup rot %move ; @@ -382,13 +371,6 @@ M: object template-rhs ; %prepare-alien-invoke "simple_gc" f %alien-invoke ; -: end-basic-block ( -- ) - #! Commit all deferred stacking shuffling, and ensure the - #! in-memory data and retain stacks are up to date with - #! respect to the compiler's current picture. - finalize-contents finalize-heights - fresh-objects get dup empty? swap delete-all [ %gc ] unless ; - ! Loading stacks to vregs : free-vregs# ( -- int# float# ) T{ int-regs } T{ float-regs f 8 } @@ -433,11 +415,6 @@ M: object template-rhs ; dup length phantom-d get phantom-input swap lazy-load ] if ; -SYMBOL: +input+ -SYMBOL: +output+ -SYMBOL: +scratch+ -SYMBOL: +clobber+ - : output-vregs ( -- seq seq ) +output+ +clobber+ [ get [ get ] map ] 2apply ; @@ -489,11 +466,6 @@ SYMBOL: +clobber+ : template-outputs ( -- ) +output+ get [ get ] map phantom-d get phantom-append ; -: with-template ( quot hash -- ) - clone [ template-inputs call template-outputs ] bind - compute-free-vregs ; - inline - : value-matches? ( value spec -- ? ) #! If the spec is a quotation and the value is a literal #! fixnum, see if the quotation yields true when applied @@ -519,8 +491,6 @@ SYMBOL: +clobber+ dup length 1 = [ first tag-number ] [ drop f ] if ] if ; -SYMBOL: known-tag - : class-match? ( actual expected -- ? ) { { f [ drop t ] } @@ -545,6 +515,39 @@ SYMBOL: known-tag #! Depends on node@ [ second template-matches? ] find nip ; +PRIVATE> + +: end-basic-block ( -- ) + #! Commit all deferred stacking shuffling, and ensure the + #! in-memory data and retain stacks are up to date with + #! respect to the compiler's current picture. + finalize-contents finalize-heights + fresh-objects get dup empty? swap delete-all [ %gc ] unless ; + +: with-template ( quot hash -- ) + clone [ template-inputs call template-outputs ] bind + compute-free-vregs ; + inline + +: fresh-object ( obj -- ) fresh-objects get push ; + +: fresh-object? ( obj -- ? ) fresh-objects get memq? ; + +: init-templates ( -- ) + #! Initialize register allocator. + V{ } clone fresh-objects set + phantom-d set + phantom-r set + compute-free-vregs ; + +: copy-templates ( -- ) + #! Copies register allocator state, used when compiling + #! branches. + fresh-objects [ clone ] change + phantom-d [ clone ] change + phantom-r [ clone ] change + compute-free-vregs ; + : find-template ( templates -- pair/f ) #! Pair has shape { quot hash } #! Depends on node@ From 118772b63441fddbd1087949daf25ee1c2f6d78d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 27 Sep 2007 21:23:24 -0400 Subject: [PATCH 13/88] Cleaning up generator.registers --- core/compiler/test/intrinsics.factor | 2 +- core/compiler/test/templates-early.factor | 5 +- core/cpu/architecture/architecture.factor | 13 +- core/cpu/ppc/allot/allot.factor | 7 +- core/cpu/ppc/architecture/architecture.factor | 18 +-- core/cpu/x86/allot/allot.factor | 2 +- core/cpu/x86/architecture/architecture.factor | 9 +- core/cpu/x86/sse2/sse2.factor | 7 -- core/generator/registers/registers.factor | 113 ++++++++---------- 9 files changed, 72 insertions(+), 104 deletions(-) diff --git a/core/compiler/test/intrinsics.factor b/core/compiler/test/intrinsics.factor index d80b172c31..0b579084c8 100644 --- a/core/compiler/test/intrinsics.factor +++ b/core/compiler/test/intrinsics.factor @@ -371,7 +371,7 @@ cell 8 = [ [ ] [ "b" get free ] unit-test ] when -[ t ] [ "hello world" malloc-char-string "s" set ] unit-test +[ ] [ "hello world" malloc-char-string "s" set ] unit-test "s" get [ [ "hello world" ] [ "s" get [ { byte-array } declare *void* ] compile-1 alien>char-string ] unit-test diff --git a/core/compiler/test/templates-early.factor b/core/compiler/test/templates-early.factor index 8286d0cda4..3fe70d974a 100644 --- a/core/compiler/test/templates-early.factor +++ b/core/compiler/test/templates-early.factor @@ -1,7 +1,8 @@ ! Testing templates machinery without compiling anything IN: temporary -USING: compiler generator generator.registers tools.test -namespaces sequences words kernel math effects ; +USING: compiler generator generator.registers +generator.registers.private tools.test namespaces sequences +words kernel math effects ; [ [ ] [ init-templates ] unit-test diff --git a/core/cpu/architecture/architecture.factor b/core/cpu/architecture/architecture.factor index e501d548b3..a149575d2f 100644 --- a/core/cpu/architecture/architecture.factor +++ b/core/cpu/architecture/architecture.factor @@ -79,17 +79,14 @@ HOOK: %inc-d compiler-backend ( n -- ) HOOK: %inc-r compiler-backend ( n -- ) ! Load stack into vreg -GENERIC: (%peek) ( vreg loc reg-class -- ) -: %peek ( vreg loc -- ) over (%peek) ; +HOOK: %peek compiler-backend ( vreg loc -- ) ! Store vreg to stack -GENERIC: (%replace) ( vreg loc reg-class -- ) -: %replace ( vreg loc -- ) over (%replace) ; +HOOK: %replace compiler-backend ( vreg loc -- ) -! Move one vreg to another -HOOK: %move-int>int compiler-backend ( dst src -- ) -HOOK: %move-int>float compiler-backend ( dst src -- ) -HOOK: %move-float>int compiler-backend ( dst src -- ) +! Box and unbox floats +HOOK: %unbox-float compiler-backend ( dst src -- ) +HOOK: %box-float compiler-backend ( dst src -- ) ! FFI stuff diff --git a/core/cpu/ppc/allot/allot.factor b/core/cpu/ppc/allot/allot.factor index a31e4b7836..c73fd500a6 100644 --- a/core/cpu/ppc/allot/allot.factor +++ b/core/cpu/ppc/allot/allot.factor @@ -32,12 +32,7 @@ IN: cpu.ppc.allot 12 11 float tag-number ORI f fresh-object ; -M: float-regs (%replace) - drop - swap v>operand %allot-float - 12 swap loc>operand STW ; - -M: ppc-backend %move-float>int ( dst src -- ) +M: ppc-backend %box-float ( dst src -- ) [ v>operand ] 2apply %allot-float 12 MR ; : %allot-bignum ( #digits -- ) diff --git a/core/cpu/ppc/architecture/architecture.factor b/core/cpu/ppc/architecture/architecture.factor index d12139c550..604708ab9e 100644 --- a/core/cpu/ppc/architecture/architecture.factor +++ b/core/cpu/ppc/architecture/architecture.factor @@ -156,21 +156,13 @@ M: ppc-backend %return ( -- ) %epilogue-later BLR ; M: ppc-backend %unwind drop %return ; -M: int-regs (%peek) - drop >r v>operand r> loc>operand LWZ ; +M: ppc-backend %peek ( vreg loc -- ) + >r v>operand r> loc>operand LWZ ; -M: float-regs (%peek) - drop - 11 swap loc>operand LWZ - v>operand 11 float-offset LFD ; +M: ppc-backend %replace + >r v>operand r> loc>operand STW ; -M: int-regs (%replace) - drop >r v>operand r> loc>operand STW ; - -M: ppc-backend %move-int>int ( dst src -- ) - [ v>operand ] 2apply MR ; - -M: ppc-backend %move-int>float ( dst src -- ) +M: ppc-backend %unbox-float ( dst src -- ) [ v>operand ] 2apply float-offset LFD ; M: ppc-backend %inc-d ( n -- ) ds-reg dup rot cells ADDI ; diff --git a/core/cpu/x86/allot/allot.factor b/core/cpu/x86/allot/allot.factor index c6989615b2..330b51ecc3 100644 --- a/core/cpu/x86/allot/allot.factor +++ b/core/cpu/x86/allot/allot.factor @@ -37,7 +37,7 @@ IN: cpu.x86.allot temp-reg v>operand swap tag-number OR temp-reg v>operand MOV ; -M: x86-backend %move-float>int ( dst src -- ) +M: x86-backend %box-float ( dst src -- ) #! Only called by pentium4 backend, uses SSE2 instruction #! dest is a loc or a vreg float 16 [ diff --git a/core/cpu/x86/architecture/architecture.factor b/core/cpu/x86/architecture/architecture.factor index 91e8bf1460..e2232c36bb 100644 --- a/core/cpu/x86/architecture/architecture.factor +++ b/core/cpu/x86/architecture/architecture.factor @@ -121,15 +121,12 @@ M: x86-backend %call-dispatch ( word-table# -- ) M: x86-backend %jump-dispatch ( word-table# -- ) [ %epilogue-later JMP ] dispatch-template ; -M: x86-backend %move-int>int ( dst src -- ) - [ v>operand ] 2apply MOV ; - -M: x86-backend %move-int>float ( dst src -- ) +M: x86-backend %unbox-float ( dst src -- ) [ v>operand ] 2apply float-offset [+] MOVSD ; -M: int-regs (%peek) drop %move-int>int ; +M: x86-backend %peek [ v>operand ] 2apply MOV ; -M: int-regs (%replace) drop swap %move-int>int ; +M: x86-backend %replace swap %peek ; : (%inc) swap cells dup 0 > [ ADD ] [ neg SUB ] if ; diff --git a/core/cpu/x86/sse2/sse2.factor b/core/cpu/x86/sse2/sse2.factor index 3fa83a4ed7..397f9d3d93 100644 --- a/core/cpu/x86/sse2/sse2.factor +++ b/core/cpu/x86/sse2/sse2.factor @@ -6,13 +6,6 @@ namespaces sequences words generator generator.registers cpu.architecture math.floats.private layouts quotations ; IN: cpu.x86.sse2 -M: float-regs (%peek) - drop - temp-reg swap %move-int>int - temp-reg %move-int>float ; - -M: float-regs (%replace) drop swap %move-float>int ; - : define-float-op ( word op -- ) [ "x" operand "y" operand ] swap add H{ { +input+ { { float "x" } { float "y" } } } diff --git a/core/generator/registers/registers.factor b/core/generator/registers/registers.factor index 4797d68b39..f1f4130f6e 100644 --- a/core/generator/registers/registers.factor +++ b/core/generator/registers/registers.factor @@ -104,7 +104,7 @@ M: phantom-retainstack finalize-height dup length swap phantom-locs ; : (each-loc) ( phantom quot -- ) - >r dup phantom-locs* r> 2each ; inline + >r dup phantom-locs* swap r> 2each ; inline : each-loc ( quot -- ) >r phantom-d get r> phantom-r get over @@ -161,8 +161,6 @@ PRIVATE> phantoms [ finalize-height ] 2apply ; ! Phantom stacks hold values, locs, and vregs -UNION: pseudo loc value ; - : live-vregs ( -- seq ) phantoms append [ vreg? ] subset ; : live-loc? ( current actual -- ? ) @@ -211,34 +209,6 @@ SYMBOL: fresh-objects T{ float-regs f 8 } T{ int-regs } ? ; ! Copying vregs to stacks -: alloc-vreg ( spec -- vreg ) - reg-spec>class free-vregs pop ; - -: %move ( dst src -- ) - 2dup = [ - 2drop - ] [ - 2dup [ delegate class ] 2apply 2array { - { { int-regs int-regs } [ %move-int>int ] } - { { float-regs int-regs } [ %move-int>float ] } - { { int-regs float-regs } [ %move-float>int ] } - } case - ] if ; - -: vreg>vreg ( vreg spec -- vreg ) - alloc-vreg dup rot %move ; - -: value>int-vreg ( value spec -- vreg ) - alloc-vreg [ >r value-literal r> load-literal ] keep ; - -: value>float-vreg ( value spec -- vreg ) - alloc-vreg [ - >r value-literal temp-reg load-literal r> temp-reg %move - ] keep ; - -: loc>vreg ( loc spec -- vreg ) - alloc-vreg [ swap %peek ] keep ; - : allocation H{ { { int-regs f } f } @@ -252,17 +222,25 @@ SYMBOL: fresh-objects { { loc float } T{ float-regs 8 f } } } at ; +: alloc-vreg ( spec -- vreg ) + reg-spec>class free-vregs pop ; + +: value>float-vreg ( dst src -- ) + value-literal temp-reg load-literal + temp-reg %unbox-float ; + +: loc>float-vreg ( dst src -- ) + temp-reg swap %peek + temp-reg %unbox-float ; + : transfer { - { { int-regs f } [ drop ] } - { { int-regs float } [ vreg>vreg ] } - { { float-regs f } [ vreg>vreg ] } - { { float-regs float } [ drop ] } - { { value f } [ value>int-vreg ] } + { { int-regs float } [ %unbox-float ] } + { { float-regs f } [ %box-float ] } + { { value f } [ value-literal swap load-literal ] } { { value float } [ value>float-vreg ] } - { { value value } [ drop ] } - { { loc f } [ loc>vreg ] } - { { loc float } [ loc>vreg ] } + { { loc f } [ %peek ] } + { { loc float } [ loc>float-vreg ] } } case ; GENERIC: template-lhs ( obj -- lhs ) @@ -283,29 +261,47 @@ M: object template-rhs ; swap template-lhs swap template-rhs 2array ; : (lazy-load) ( value spec -- value ) - 2dup transfer-op transfer ; + 2dup transfer-op dup allocation + ! ( value spec transfer-op ) + [ + >r alloc-vreg dup rot r> transfer + ] [ + 2drop + ] if ; -: loc>loc ( fromloc toloc -- ) - #! Move a value from a stack location to another stack - #! location. - temp-reg rot %peek +: float-vreg>loc ( dst src -- ) + temp-reg swap %box-float temp-reg swap %replace ; -: lazy-store ( src dest -- ) +: value>loc ( src dst -- ) + #! Move a literal to a stack location. + value-literal temp-reg load-literal + temp-reg swap %replace ; + +: loc>loc ( dst src -- ) + temp-reg swap %peek + temp-reg swap %replace ; + +: (lazy-store) ( dst src -- ) + dup template-lhs { + { float-regs [ float-vreg>loc ] } + { int-regs [ swap %replace ] } + { value [ value>loc ] } + { loc [ loc>loc ] } + } case ; + +: lazy-store ( dst src live-locs -- ) #! Don't store a location to itself. - 2dup = [ - 2drop - ] [ - >r \ live-locs get at dup vreg? - [ r> %replace ] [ r> loc>loc ] if - ] if ; + >r 2dup = [ r> 3drop ] [ r> at (lazy-store) ] if ; : do-shuffle ( hash -- ) dup assoc-empty? [ drop ] [ - \ live-locs set - [ over loc? [ lazy-store ] [ 2drop ] if ] each-loc + [ + >r dup loc? + [ r> lazy-store ] [ r> 3drop ] if + ] curry each-loc ] if ; : fast-shuffle ( locs -- ) @@ -341,19 +337,16 @@ M: object template-rhs ; live-locs dup fast-shuffle? [ fast-shuffle ] [ slow-shuffle ] if ; -: value>loc ( literal toloc -- ) - #! Move a literal to a stack location. - >r value-literal temp-reg load-literal - temp-reg r> %replace ; - : finalize-values ( -- ) #! Store any deferred literals to their final stack #! locations. - [ over value? [ value>loc ] [ 2drop ] if ] each-loc ; + [ dup value? [ (lazy-store) ] [ 2drop ] if ] each-loc ; + +UNION: pseudo loc value ; : finalize-vregs ( -- ) #! Store any vregs to their final stack locations. - [ over pseudo? [ 2drop ] [ %replace ] if ] each-loc ; + [ dup pseudo? [ 2drop ] [ (lazy-store) ] if ] each-loc ; : reusing-vregs ( quot -- ) #! Any vregs allocated by quot are released again. From 5c6989cded739113c731b8a59f2db24c21aeaec8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 27 Sep 2007 22:20:17 -0400 Subject: [PATCH 14/88] Generic %move word cleans up a lot of boilerplate --- core/generator/registers/registers.factor | 142 +++++++--------------- 1 file changed, 42 insertions(+), 100 deletions(-) diff --git a/core/generator/registers/registers.factor b/core/generator/registers/registers.factor index f1f4130f6e..eaba9c700e 100644 --- a/core/generator/registers/registers.factor +++ b/core/generator/registers/registers.factor @@ -47,6 +47,26 @@ C: rs-loc UNION: loc ds-loc rs-loc ; +! Moving values between locations and registers +GENERIC: move-spec ( obj -- spec ) + +M: int-regs move-spec drop f ; +M: float-regs move-spec drop float ; +M: value move-spec class ; +M: loc move-spec drop loc ; +M: f move-spec drop loc ; + +: %move ( dst src -- ) + 2dup [ move-spec ] 2apply swap 2array { + { { f f } [ "Bug in generator.registers %move" throw ] } + { { f float } [ %unbox-float ] } + { { f loc } [ swap %replace ] } + { { float f } [ %box-float ] } + { { value f } [ value-literal swap load-literal ] } + { { loc f } [ %peek ] } + [ drop temp-reg swap %move temp-reg %move ] + } case ; + ! A compile-time stack TUPLE: phantom-stack height ; @@ -209,90 +229,26 @@ SYMBOL: fresh-objects T{ float-regs f 8 } T{ int-regs } ? ; ! Copying vregs to stacks -: allocation - H{ - { { int-regs f } f } - { { int-regs float } T{ float-regs 8 f } } - { { float-regs f } T{ int-regs f } } - { { float-regs float } f } - { { value value } f } - { { value f } T{ int-regs f } } - { { value float } T{ float-regs 8 f } } - { { loc f } T{ int-regs f } } - { { loc float } T{ float-regs 8 f } } - } at ; - -: alloc-vreg ( spec -- vreg ) +: alloc-vreg ( spec -- reg ) reg-spec>class free-vregs pop ; -: value>float-vreg ( dst src -- ) - value-literal temp-reg load-literal - temp-reg %unbox-float ; - -: loc>float-vreg ( dst src -- ) - temp-reg swap %peek - temp-reg %unbox-float ; - -: transfer - { - { { int-regs float } [ %unbox-float ] } - { { float-regs f } [ %box-float ] } - { { value f } [ value-literal swap load-literal ] } - { { value float } [ value>float-vreg ] } - { { loc f } [ %peek ] } - { { loc float } [ loc>float-vreg ] } - } case ; - -GENERIC: template-lhs ( obj -- lhs ) - -M: int-regs template-lhs class ; -M: float-regs template-lhs class ; -M: ds-loc template-lhs drop loc ; -M: rs-loc template-lhs drop loc ; -M: f template-lhs drop loc ; -M: value template-lhs class ; - -GENERIC: template-rhs ( obj -- rhs ) - -M: quotation template-rhs drop value ; -M: object template-rhs ; - -: transfer-op ( value spec -- pair ) - swap template-lhs swap template-rhs 2array ; - -: (lazy-load) ( value spec -- value ) - 2dup transfer-op dup allocation - ! ( value spec transfer-op ) - [ - >r alloc-vreg dup rot r> transfer +: allocation ( value spec -- reg-class ) + dup quotation? [ + 2drop f ] [ - 2drop + dup rot move-spec = [ + drop f + ] [ + reg-spec>class + ] if ] if ; -: float-vreg>loc ( dst src -- ) - temp-reg swap %box-float - temp-reg swap %replace ; - -: value>loc ( src dst -- ) - #! Move a literal to a stack location. - value-literal temp-reg load-literal - temp-reg swap %replace ; - -: loc>loc ( dst src -- ) - temp-reg swap %peek - temp-reg swap %replace ; - -: (lazy-store) ( dst src -- ) - dup template-lhs { - { float-regs [ float-vreg>loc ] } - { int-regs [ swap %replace ] } - { value [ value>loc ] } - { loc [ loc>loc ] } - } case ; +: (lazy-load) ( value spec -- value ) + 2dup allocation [ alloc-vreg dup rot %move ] [ drop ] if ; : lazy-store ( dst src live-locs -- ) #! Don't store a location to itself. - >r 2dup = [ r> 3drop ] [ r> at (lazy-store) ] if ; + >r 2dup = [ r> 3drop ] [ r> at %move ] if ; : do-shuffle ( hash -- ) dup assoc-empty? [ @@ -316,15 +272,14 @@ M: object template-rhs ; : slow-shuffle-mapping ( locs tmp -- pairs ) >r dup length r> - [ swap - ] curry map - 2array flip ; + [ swap - ] curry map swap 2array flip ; : slow-shuffle ( locs -- ) #! We don't have enough free registers to load all shuffle #! inputs, so we use a single temporary register, together #! with the area of the data stack above the stack pointer find-tmp-loc slow-shuffle-mapping - [ [ loc>loc ] assoc-each ] keep + [ [ %move ] assoc-each ] keep >hashtable do-shuffle ; : fast-shuffle? ( live-locs -- ? ) @@ -334,30 +289,18 @@ M: object template-rhs ; : finalize-locs ( -- ) #! Perform any deferred stack shuffling. - live-locs dup fast-shuffle? - [ fast-shuffle ] [ slow-shuffle ] if ; - -: finalize-values ( -- ) - #! Store any deferred literals to their final stack - #! locations. - [ dup value? [ (lazy-store) ] [ 2drop ] if ] each-loc ; - -UNION: pseudo loc value ; + [ + \ free-vregs [ [ clone ] assoc-map ] change + live-locs dup fast-shuffle? + [ fast-shuffle ] [ slow-shuffle ] if + ] with-scope ; : finalize-vregs ( -- ) #! Store any vregs to their final stack locations. - [ dup pseudo? [ 2drop ] [ (lazy-store) ] if ] each-loc ; - -: reusing-vregs ( quot -- ) - #! Any vregs allocated by quot are released again. - >r \ free-vregs get [ clone ] assoc-map \ free-vregs r> - with-variable ; inline + [ dup loc? [ 2drop ] [ %move ] if ] each-loc ; : finalize-contents ( -- ) - [ finalize-locs ] reusing-vregs - [ finalize-values ] reusing-vregs - finalize-vregs - [ delete-all ] each-phantom ; + finalize-locs finalize-vregs [ delete-all ] each-phantom ; : %gc ( -- ) 0 frame-required @@ -423,8 +366,7 @@ UNION: pseudo loc value ; : count-vregs ( reg-classes -- ) [ [ inc ] when* ] each ; : count-input-vregs ( phantom spec -- ) - phantom&spec [ transfer-op allocation ] 2map - count-vregs ; + phantom&spec [ allocation ] 2map count-vregs ; : count-scratch-regs ( spec -- ) [ first reg-spec>class ] map count-vregs ; From bf56a09b1a32b232f1f145343cc60db9217ef8e9 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 27 Sep 2007 22:20:34 -0400 Subject: [PATCH 15/88] Fix unit tests --- extra/combinators/lib/lib-tests.factor | 15 ++++++++------- extra/math/ranges/ranges-tests.factor | 2 +- 2 files changed, 9 insertions(+), 8 deletions(-) diff --git a/extra/combinators/lib/lib-tests.factor b/extra/combinators/lib/lib-tests.factor index aa7fc004c1..43385b911d 100644 --- a/extra/combinators/lib/lib-tests.factor +++ b/extra/combinators/lib/lib-tests.factor @@ -1,5 +1,5 @@ USING: combinators.lib kernel math math.ranges random sequences -tools.test ; +tools.test inference continuations arrays vectors ; IN: temporary [ 5 ] [ [ 10 random ] [ 5 = ] generate ] unit-test @@ -10,25 +10,26 @@ IN: temporary [ f ] [ { 0 1 1 2 3 5 } all-unique? ] unit-test [ t ] [ { 0 1 2 3 4 5 } all-unique? ] unit-test +: infers? [ infer drop ] curry catch not ; [ { 910 911 912 } ] [ 10 900 3 [ + + ] map-with2 ] unit-test { 6 2 } [ 1 2 [ 5 + ] dip ] unit-test { 6 2 1 } [ 1 2 1 [ 5 + ] dipd ] unit-test -{ t } [ [ [ 99 ] 1 2 3 4 5 5 nslip ] compile-quot compiled? ] unit-test +{ t } [ [ [ 99 ] 1 2 3 4 5 5 nslip ] infers? ] unit-test { 99 1 2 3 4 5 } [ [ 99 ] 1 2 3 4 5 5 nslip ] unit-test -{ t } [ [ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] compile-quot compiled? ] unit-test +{ t } [ [ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] infers? ] unit-test { 2 1 2 3 4 5 } [ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] unit-test [ [ 1 2 3 + ] ] [ 1 2 3 [ + ] 3 ncurry ] unit-test -{ t } [ [ 1 2 { 3 4 } [ + + ] 2 map-withn ] compile-quot compiled? ] unit-test +{ t } [ [ 1 2 { 3 4 } [ + + ] 2 map-withn ] infers? ] unit-test { { 6 7 } } [ 1 2 { 3 4 } [ + + ] 2 map-withn ] unit-test { { 16 17 18 19 20 } } [ 1 2 3 4 { 6 7 8 9 10 } [ + + + + ] 4 map-withn ] unit-test -{ t } [ [ 1 2 { 3 4 } [ + + drop ] 2 each-withn ] compile-quot compiled? ] unit-test +{ t } [ [ 1 2 { 3 4 } [ + + drop ] 2 each-withn ] infers? ] unit-test { 13 } [ 1 2 { 3 4 } [ + + ] 2 each-withn + ] unit-test [ 1 1 2 2 3 3 ] [ 1 2 3 [ dup ] 3apply ] unit-test [ 1 4 9 ] [ 1 2 3 [ sq ] 3apply ] unit-test -[ t ] [ [ [ sq ] 3apply ] compile-quot compiled? ] unit-test +[ t ] [ [ [ sq ] 3apply ] infers? ] unit-test [ { 1 2 } { 2 4 } { 3 8 } { 4 16 } { 5 32 } ] [ 1 2 3 4 5 [ dup 2^ 2array ] 5 napply ] unit-test -[ t ] [ [ [ dup 2^ 2array ] 5 napply ] compile-quot compiled? ] unit-test +[ t ] [ [ [ dup 2^ 2array ] 5 napply ] infers? ] unit-test ! && diff --git a/extra/math/ranges/ranges-tests.factor b/extra/math/ranges/ranges-tests.factor index f70f70ad24..98a7525910 100644 --- a/extra/math/ranges/ranges-tests.factor +++ b/extra/math/ranges/ranges-tests.factor @@ -1,4 +1,4 @@ -USING: math.ranges sequences tools.test ; +USING: math.ranges sequences tools.test arrays ; IN: temporary [ { } ] [ 1 1 (a,b) >array ] unit-test From 3afcd7453e5e8d741b65948cfdcb1098de2600fb Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 28 Sep 2007 00:15:58 -0400 Subject: [PATCH 16/88] Fix old generator.registers regression --- core/cpu/architecture/architecture.factor | 5 +- core/generator/registers/registers.factor | 106 +++++++++++++++------- 2 files changed, 76 insertions(+), 35 deletions(-) diff --git a/core/cpu/architecture/architecture.factor b/core/cpu/architecture/architecture.factor index a149575d2f..f2ee24cd65 100644 --- a/core/cpu/architecture/architecture.factor +++ b/core/cpu/architecture/architecture.factor @@ -2,7 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays generic kernel kernel.private math memory namespaces sequences layouts system hashtables classes alien -byte-arrays bit-arrays float-arrays combinators words ; +byte-arrays bit-arrays float-arrays combinators words +inference.dataflow ; IN: cpu.architecture SYMBOL: compiler-backend @@ -152,6 +153,8 @@ M: integer v>operand tag-bits get shift ; M: f v>operand drop \ f tag-number ; +M: value v>operand value-literal ; + M: object load-literal v>operand load-indirect ; PREDICATE: integer small-slot cells small-enough? ; diff --git a/core/generator/registers/registers.factor b/core/generator/registers/registers.factor index eaba9c700e..9c860603eb 100644 --- a/core/generator/registers/registers.factor +++ b/core/generator/registers/registers.factor @@ -33,6 +33,10 @@ TUPLE: temp-reg ; M: vreg v>operand dup vreg-n swap vregs nth ; +TUPLE: cached loc vreg ; + +C: cached + ! A data stack location. TUPLE: ds-loc n ; @@ -53,17 +57,19 @@ GENERIC: move-spec ( obj -- spec ) M: int-regs move-spec drop f ; M: float-regs move-spec drop float ; M: value move-spec class ; +M: cached move-spec drop cached ; M: loc move-spec drop loc ; M: f move-spec drop loc ; - +USE: prettyprint : %move ( dst src -- ) - 2dup [ move-spec ] 2apply swap 2array { + dup [ "FUCK" throw ] unless + 2dup [ move-spec ] 2apply 2array { { { f f } [ "Bug in generator.registers %move" throw ] } - { { f float } [ %unbox-float ] } - { { f loc } [ swap %replace ] } - { { float f } [ %box-float ] } - { { value f } [ value-literal swap load-literal ] } - { { loc f } [ %peek ] } + { { float f } [ %unbox-float ] } + { { loc f } [ swap %replace ] } + { { f float } [ %box-float ] } + { { f value } [ value-literal swap load-literal ] } + { { f loc } [ %peek ] } [ drop temp-reg swap %move temp-reg %move ] } case ; @@ -177,31 +183,33 @@ PRIVATE> : each-phantom ( quot -- ) phantoms rot 2apply ; inline -: finalize-heights ( -- ) - phantoms [ finalize-height ] 2apply ; +: finalize-heights ( -- ) [ finalize-height ] each-phantom ; ! Phantom stacks hold values, locs, and vregs -: live-vregs ( -- seq ) phantoms append [ vreg? ] subset ; +GENERIC: live-vregs* ( obj -- ) -: live-loc? ( current actual -- ? ) - over loc? [ = not ] [ 2drop f ] if ; +M: cached live-vregs* cached-vreg , ; +M: vreg live-vregs* , ; +M: object live-vregs* drop ; + +: live-vregs ( -- seq ) + [ [ [ live-vregs* ] each ] each-phantom ] { } make ; + +GENERIC: live-loc? ( actual current -- ? ) + +M: cached live-loc? cached-loc live-loc? ; +M: loc live-loc? = not ; +M: object live-loc? 2drop f ; : (live-locs) ( phantom -- seq ) #! Discard locs which haven't moved - dup phantom-locs* 2array flip + dup phantom-locs* swap 2array flip [ live-loc? ] assoc-subset - keys ; + values ; : live-locs ( -- seq ) [ (live-locs) ] each-phantom append prune ; -: minimal-ds-loc ( phantom -- n ) - #! When shuffling more values than can fit in registers, we - #! need to find an area on the data stack which isn't in - #! use. - dup phantom-stack-height neg - [ dup ds-loc? [ ds-loc-n min ] [ drop ] if ] reduce ; - ! Operands holding pointers to freshly-allocated objects which ! are guaranteed to be in the nursery SYMBOL: fresh-objects @@ -221,7 +229,8 @@ SYMBOL: fresh-objects #! Create a new hashtable for thee free-vregs variable. live-vregs { T{ int-regs } T{ float-regs f 8 } } - [ 2dup (compute-free-vregs) ] H{ } map>assoc \ free-vregs set + [ 2dup (compute-free-vregs) ] H{ } map>assoc + \ free-vregs set drop ; : reg-spec>class ( spec -- class ) @@ -243,21 +252,31 @@ SYMBOL: fresh-objects ] if ] if ; -: (lazy-load) ( value spec -- value ) +GENERIC# (lazy-load) 1 ( value spec -- value ) + +M: cached (lazy-load) + >r cached-vreg r> (lazy-load) ; + +M: object (lazy-load) 2dup allocation [ alloc-vreg dup rot %move ] [ drop ] if ; -: lazy-store ( dst src live-locs -- ) - #! Don't store a location to itself. - >r 2dup = [ r> 3drop ] [ r> at %move ] if ; +GENERIC: lazy-store ( dst src -- ) + +M: loc lazy-store + 2dup = [ 2drop ] [ \ live-locs get at %move ] if ; + +M: cached lazy-store + 2dup cached-loc = [ 2drop ] [ cached-vreg %move ] if ; + +M: object lazy-store + 2drop ; : do-shuffle ( hash -- ) dup assoc-empty? [ drop ] [ - [ - >r dup loc? - [ r> lazy-store ] [ r> 3drop ] if - ] curry each-loc + \ live-locs set + [ lazy-store ] each-loc ] if ; : fast-shuffle ( locs -- ) @@ -265,6 +284,18 @@ SYMBOL: fresh-objects #! at once [ dup f (lazy-load) ] H{ } map>assoc do-shuffle ; +GENERIC: minimal-ds-loc* ( min obj -- min ) + +M: cached minimal-ds-loc* cached-loc minimal-ds-loc* ; +M: ds-loc minimal-ds-loc* ds-loc-n min ; +M: object minimal-ds-loc* drop ; + +: minimal-ds-loc ( phantom -- n ) + #! When shuffling more values than can fit in registers, we + #! need to find an area on the data stack which isn't in + #! use. + dup phantom-stack-height neg [ minimal-ds-loc* ] reduce ; + : find-tmp-loc ( -- n ) #! Find an area of the data stack which is not referenced #! from the phantom stacks. We can clobber there all we want @@ -297,7 +328,9 @@ SYMBOL: fresh-objects : finalize-vregs ( -- ) #! Store any vregs to their final stack locations. - [ dup loc? [ 2drop ] [ %move ] if ] each-loc ; + [ + dup loc? over cached? or [ 2drop ] [ %move ] if + ] each-loc ; : finalize-contents ( -- ) finalize-locs finalize-vregs [ delete-all ] each-phantom ; @@ -342,7 +375,8 @@ SYMBOL: fresh-objects flip first2 >r dupd [ (lazy-load) ] 2map dup r> [ >r dup value? [ value-literal ] when r> set ] 2each - 2array flip substitute-vregs ; + dupd [ ] 2map 2array flip [ first loc? ] subset + substitute-vregs ; : fast-input ( template -- ) dup empty? [ @@ -355,7 +389,9 @@ SYMBOL: fresh-objects +output+ +clobber+ [ get [ get ] map ] 2apply ; : clash? ( seq -- ? ) - phantoms append swap [ member? ] curry contains? ; + phantoms append [ + dup cached? [ cached-vreg ] when swap member? + ] curry* contains? ; : outputs-clash? ( -- ? ) output-vregs append clash? ; @@ -366,7 +402,9 @@ SYMBOL: fresh-objects : count-vregs ( reg-classes -- ) [ [ inc ] when* ] each ; : count-input-vregs ( phantom spec -- ) - phantom&spec [ allocation ] 2map count-vregs ; + phantom&spec [ + >r dup cached? [ cached-vreg ] when r> allocation + ] 2map count-vregs ; : count-scratch-regs ( spec -- ) [ first reg-spec>class ] map count-vregs ; From a75c6ebb22e5ad27cb7043edacfb796b36162a7a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 28 Sep 2007 00:16:09 -0400 Subject: [PATCH 17/88] Update unit test --- core/generic/generic-tests.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/core/generic/generic-tests.factor b/core/generic/generic-tests.factor index 112fe4844d..931f5b3872 100644 --- a/core/generic/generic-tests.factor +++ b/core/generic/generic-tests.factor @@ -123,9 +123,9 @@ TUPLE: delegating ; [ "SYMBOL: not-a-class C: not-a-class ;" parse ] unit-test-fails ! Test math-combination -[ [ >r >float r> ] ] [ \ real \ float math-upgrade ] unit-test +[ [ [ >float ] dip ] ] [ \ real \ float math-upgrade ] unit-test [ [ >float ] ] [ \ float \ real math-upgrade ] unit-test -[ [ >r >bignum r> ] ] [ \ fixnum \ bignum math-upgrade ] unit-test +[ [ [ >bignum ] dip ] ] [ \ fixnum \ bignum math-upgrade ] unit-test [ [ >float ] ] [ \ float \ integer math-upgrade ] unit-test [ number ] [ \ number \ float math-class-max ] unit-test [ float ] [ \ real \ float math-class-max ] unit-test From 3995a5c824134cf51fe614899e11f0903281b17a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 28 Sep 2007 00:26:58 -0400 Subject: [PATCH 18/88] Cleanups --- core/compiler/test/stack-trace.factor | 13 ++++++++----- core/generator/registers/registers.factor | 16 ++++++++-------- 2 files changed, 16 insertions(+), 13 deletions(-) diff --git a/core/compiler/test/stack-trace.factor b/core/compiler/test/stack-trace.factor index ee94f0c9a2..4c47ca8a12 100644 --- a/core/compiler/test/stack-trace.factor +++ b/core/compiler/test/stack-trace.factor @@ -1,25 +1,28 @@ IN: temporary USING: compiler tools.test namespaces sequences kernel.private kernel math continuations continuations.private -words ; +words splitting ; : symbolic-stack-trace ( -- newseq ) - error-continuation get continuation-call callstack>array ; + error-continuation get continuation-call callstack>array + 2 group flip first ; : foo 3 throw 7 ; : bar foo 4 ; : baz bar 5 ; \ baz compile [ 3 ] [ [ baz ] catch ] unit-test -[ { baz bar foo throw } ] [ - symbolic-stack-trace [ word? ] subset +[ t ] [ + symbolic-stack-trace + [ word? ] subset + { baz bar foo throw } tail? ] unit-test : bleh [ 3 + ] map [ 0 > ] subset ; \ bleh compile : stack-trace-contains? symbolic-stack-trace memq? ; - + [ t ] [ [ { 1 "hi" } bleh ] catch drop \ + stack-trace-contains? ] unit-test diff --git a/core/generator/registers/registers.factor b/core/generator/registers/registers.factor index 9c860603eb..7e31f83abc 100644 --- a/core/generator/registers/registers.factor +++ b/core/generator/registers/registers.factor @@ -365,17 +365,17 @@ M: object minimal-ds-loc* drop ; 2dup [ length ] 2apply <= [ drop { } swap ] [ length swap cut* ] if ; -: substitute-vregs ( alist -- ) - >hashtable - { phantom-d phantom-r } - [ get substitute ] curry* each ; +: vreg-substitution ( value vreg -- pair ) + dupd 2array ; + +: substitute-vregs ( values vregs -- ) + [ vreg-substitution ] 2map [ first loc? ] subset >hashtable + [ swap substitute ] curry each-phantom ; : lazy-load ( values template -- ) #! Set operand vars here. - flip first2 - >r dupd [ (lazy-load) ] 2map dup r> - [ >r dup value? [ value-literal ] when r> set ] 2each - dupd [ ] 2map 2array flip [ first loc? ] subset + 2dup [ first (lazy-load) ] 2map dup rot + [ >r dup value? [ value-literal ] when r> second set ] 2each substitute-vregs ; : fast-input ( template -- ) From 15057fd3491e059401a7d0db00bbc6e89959f9fc Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 28 Sep 2007 04:02:06 -0400 Subject: [PATCH 19/88] Don't allow byte arrays to be stored in aliens --- core/alien/alien-tests.factor | 4 ++++ vm/alien.c | 37 +++++++++++++++++++++++------------ 2 files changed, 29 insertions(+), 12 deletions(-) diff --git a/core/alien/alien-tests.factor b/core/alien/alien-tests.factor index 0adc5f08ef..c84a745795 100644 --- a/core/alien/alien-tests.factor +++ b/core/alien/alien-tests.factor @@ -56,3 +56,7 @@ cell 8 = [ ] when [ "ALIEN: 1234" ] [ 1234 unparse ] unit-test + +[ 0 B{ 1 2 3 } alien-address ] unit-test-fails + +[ 1 1 ] unit-test-fails diff --git a/vm/alien.c b/vm/alien.c index 8f62ee37fd..18f81f0acf 100644 --- a/vm/alien.c +++ b/vm/alien.c @@ -26,6 +26,27 @@ void *alien_offset(CELL object) } } +/* gets the address of an object representing a C pointer, with the +intention of storing the pointer across code which may potentially GC. */ +void *pinned_alien_offset(CELL object) +{ + F_ALIEN *alien; + + switch(type_of(object)) + { + case ALIEN_TYPE: + alien = untag_object(object); + if(alien->expired != F) + general_error(ERROR_EXPIRED,object,F,NULL); + return alien_offset(alien->alien) + alien->displacement; + case F_TYPE: + return NULL; + default: + type_error(ALIEN_TYPE,object); + return NULL; /* can't happen */ + } +} + /* pop an object representing a C pointer */ void *unbox_alien(void) { @@ -57,6 +78,8 @@ void box_alien(void *ptr) DEFINE_PRIMITIVE(displaced_alien) { CELL alien = dpop(); + if(type_of(alien) != F_TYPE && type_of(alien) != ALIEN_TYPE) + type_error(ALIEN_TYPE,alien); CELL displacement = to_cell(dpop()); if(alien == F && displacement == 0) dpush(F); @@ -68,17 +91,7 @@ DEFINE_PRIMITIVE(displaced_alien) if the object is a byte array, as a sanity check. */ DEFINE_PRIMITIVE(alien_address) { - CELL object = dpop(); - switch(type_of(object)) - { - case ALIEN_TYPE: - case F_TYPE: - box_unsigned_cell((CELL)alien_offset(object)); - break; - default: - type_error(ALIEN_TYPE,object); - break; - } + box_unsigned_cell((CELL)pinned_alien_offset(dpop())); } /* pop ( alien n ) from datastack, return alien's address plus n */ @@ -113,7 +126,7 @@ DEFINE_ALIEN_ACCESSOR(signed_1,s8,box_signed_1,to_fixnum) DEFINE_ALIEN_ACCESSOR(unsigned_1,u8,box_unsigned_1,to_cell) DEFINE_ALIEN_ACCESSOR(float,float,box_float,to_float) DEFINE_ALIEN_ACCESSOR(double,double,box_double,to_double) -DEFINE_ALIEN_ACCESSOR(cell,void *,box_alien,alien_offset) +DEFINE_ALIEN_ACCESSOR(cell,void *,box_alien,pinned_alien_offset) /* for FFI calls passing structs by value */ void to_value_struct(CELL src, void *dest, CELL size) From f7c2c9e4411b8b721c9e3467b18789655d6d4cc9 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 28 Sep 2007 04:02:33 -0400 Subject: [PATCH 20/88] Working on improved alien intrinsics --- core/compiler/test/templates-early.factor | 4 +- core/compiler/test/templates.factor | 32 +++++++- core/cpu/architecture/architecture.factor | 19 ++--- core/cpu/ppc/allot/allot.factor | 18 ++--- core/cpu/ppc/architecture/architecture.factor | 30 +++----- core/cpu/ppc/intrinsics/intrinsics.factor | 77 +++++++++++-------- core/generator/registers/registers.factor | 66 ++++++++++++++-- 7 files changed, 163 insertions(+), 83 deletions(-) diff --git a/core/compiler/test/templates-early.factor b/core/compiler/test/templates-early.factor index 3fe70d974a..0eee6aabbf 100644 --- a/core/compiler/test/templates-early.factor +++ b/core/compiler/test/templates-early.factor @@ -119,12 +119,12 @@ SYMBOL: template-chosen ! This is not empty since a load instruction is emitted [ f ] [ - [ { { f "x" } } fast-input ] { } make empty? + [ { { f "x" } } fast-input ] { } make empty? ] unit-test ! This is empty since we already loaded the value [ t ] [ - [ { { f "x" } } fast-input ] { } make empty? + [ { { f "x" } } fast-input ] { } make empty? ] unit-test ! This is empty since we didn't change the stack diff --git a/core/compiler/test/templates.factor b/core/compiler/test/templates.factor index 8877126902..d26ba8ec1a 100644 --- a/core/compiler/test/templates.factor +++ b/core/compiler/test/templates.factor @@ -1,9 +1,9 @@ -! Black box testing of templater optimization +! Black box testing of templating optimization USING: arrays compiler kernel kernel.private math hashtables.private math.private math.ratios.private namespaces sequences sequences.private tools.test namespaces.private -slots.private combinators.private ; +slots.private combinators.private byte-arrays alien layouts ; IN: temporary ! Oops! @@ -185,3 +185,31 @@ TUPLE: my-tuple ; [ 4 ] [ T{ my-tuple } foox ] unit-test [ 5 ] [ "hi" foox ] unit-test + +! Making sure we don't needlessly unbox/rebox +[ t 3.0 ] [ 1.0 dup [ dup 2.0 float+ >r eq? r> ] compile-1 ] unit-test + +[ t 3.0 ] [ 1.0 dup [ dup 2.0 float+ ] compile-1 >r eq? r> ] unit-test + +[ t ] [ 1.0 dup [ [ 2.0 float+ ] keep ] compile-1 nip eq? ] unit-test + +[ 1 B{ 1 2 3 4 } ] [ + B{ 1 2 3 4 } [ + { byte-array } declare + [ 0 alien-unsigned-1 ] keep + ] compile-1 +] unit-test + +[ 1 t ] [ + B{ 1 2 3 4 } [ + { simple-c-ptr } declare + [ 0 alien-unsigned-1 ] keep type + ] compile-1 byte-array type-number = +] unit-test + +[ t ] [ + B{ 1 2 3 4 } [ + { simple-c-ptr } declare + 0 alien-cell type + ] compile-1 alien type-number = +] unit-test diff --git a/core/cpu/architecture/architecture.factor b/core/cpu/architecture/architecture.factor index f2ee24cd65..2645d4476d 100644 --- a/core/cpu/architecture/architecture.factor +++ b/core/cpu/architecture/architecture.factor @@ -183,24 +183,15 @@ PREDICATE: integer inline-array 32 < ; ] if-small-struct ; ! Alien accessors -HOOK: %unbox-byte-array compiler-backend ( quot src -- ) inline +HOOK: %unbox-byte-array compiler-backend ( dst src -- ) -HOOK: %unbox-alien compiler-backend ( quot src -- ) inline +HOOK: %unbox-alien compiler-backend ( dst src -- ) -HOOK: %unbox-f compiler-backend ( quot src -- ) inline +HOOK: %unbox-f compiler-backend ( dst src -- ) -HOOK: %complex-alien-accessor compiler-backend ( quot src -- ) -inline +HOOK: %unbox-c-ptr compiler-backend ( dst src -- ) -: %alien-accessor ( quot src class -- ) - { - { [ dup \ f class< ] [ drop %unbox-f ] } - { [ dup simple-alien class< ] [ drop %unbox-alien ] } - { [ dup byte-array class< ] [ drop %unbox-byte-array ] } - { [ dup bit-array class< ] [ drop %unbox-byte-array ] } - { [ dup float-array class< ] [ drop %unbox-byte-array ] } - { [ t ] [ drop %complex-alien-accessor ] } - } cond ; inline +HOOK: %box-alien compiler-backend ( dst src -- ) : operand ( var -- op ) get v>operand ; inline diff --git a/core/cpu/ppc/allot/allot.factor b/core/cpu/ppc/allot/allot.factor index c73fd500a6..872ffd794c 100644 --- a/core/cpu/ppc/allot/allot.factor +++ b/core/cpu/ppc/allot/allot.factor @@ -78,22 +78,22 @@ M: ppc-backend %box-float ( dst src -- ) "end" resolve-label ] with-scope ; -: %allot-alien ( ptr -- ) - "temp" set +M: ppc-backend %box-alien ( dst src -- ) "f" define-label "end" define-label - 0 "temp" operand 0 CMPI + 0 over v>operand 0 CMPI "f" get BEQ alien 4 cells %allot - "temp" operand 11 3 cells STW - f v>operand "temp" operand LI + ! Store offset + v>operand 11 3 cells STW + f v>operand 12 LI ! Store expired slot - "temp" operand 11 1 cells STW + 12 11 1 cells STW ! Store underlying-alien slot - "temp" operand 11 2 cells STW + 12 11 2 cells STW ! Store tagged ptr in reg - "temp" get object %store-tagged + dup object %store-tagged "end" get B "f" resolve-label - f v>operand "temp" operand LI + f v>operand swap v>operand LI "end" resolve-label ; diff --git a/core/cpu/ppc/architecture/architecture.factor b/core/cpu/ppc/architecture/architecture.factor index 604708ab9e..4942020e2a 100644 --- a/core/cpu/ppc/architecture/architecture.factor +++ b/core/cpu/ppc/architecture/architecture.factor @@ -315,34 +315,28 @@ M: ppc-backend %unbox-small-struct drop "No small structs" throw ; ! Alien intrinsics -M: ppc-backend %unbox-byte-array ( quot src -- ) - "address" operand "alien" operand "offset" operand ADD - "address" operand byte-array-offset - roll call ; +M: ppc-backend %unbox-byte-array ( dst src -- ) + [ v>operand ] 2apply byte-array-offset ADDI ; -M: ppc-backend %unbox-alien ( quot src -- ) - "address" operand "alien" operand alien-offset LWZ - "address" operand dup "offset" operand ADD - "address" operand 0 - roll call ; +M: ppc-backend %unbox-alien ( dst src -- ) + [ v>operand ] 2apply alien-offset LWZ ; -M: ppc-backend %unbox-f ( quot src -- ) - "offset" operand 0 - roll call ; +M: ppc-backend %unbox-f ( dst src -- ) + drop 0 swap v>operand LI ; -M: ppc-backend %complex-alien-accessor ( quot src -- ) +M: ppc-backend %unbox-c-ptr ( dst src -- ) "is-f" define-label "is-alien" define-label "end" define-label - 0 "alien" operand f v>operand CMPI + 0 over v>operand f v>operand CMPI "is-f" get BEQ - "address" operand "alien" operand header-offset LWZ - 0 "address" operand alien type-number tag-header CMPI + 12 over v>operand header-offset LWZ + 0 12 alien type-number tag-header CMPI "is-alien" get BEQ - [ %unbox-byte-array ] 2keep + 2dup %unbox-byte-array "end" get B "is-alien" resolve-label - [ %unbox-alien ] 2keep + 2dup %unbox-alien "end" get B "is-f" resolve-label %unbox-f diff --git a/core/cpu/ppc/intrinsics/intrinsics.factor b/core/cpu/ppc/intrinsics/intrinsics.factor index 97d866d883..27398b6404 100644 --- a/core/cpu/ppc/intrinsics/intrinsics.factor +++ b/core/cpu/ppc/intrinsics/intrinsics.factor @@ -601,41 +601,48 @@ IN: cpu.ppc.intrinsics } define-intrinsic ! Alien intrinsics +: %alien-get ( quot -- ) + "offset" operand dup %untag-fixnum + "offset" operand dup "alien" operand ADD + "output" operand "offset" operand 0 roll call ; inline + +: %alien-set ( quot -- ) + "offset" operand dup %untag-fixnum + "offset" operand dup "alien" operand ADD + "value" operand "offset" operand 0 roll call ; inline + : alien-integer-get-template H{ { +input+ { - { f "alien" simple-c-ptr } + { unboxed-c-ptr "alien" simple-c-ptr } { f "offset" fixnum } } } - { +scratch+ { { f "output" } } } + { +scratch+ { { f "output" } { f "address" } } } { +output+ { "output" } } { +clobber+ { "offset" } } } ; -: %alien-get ( quot -- ) - "output" get "address" set - "offset" operand dup %untag-fixnum - "output" operand "alien" operand-class %alien-accessor ; - : %alien-integer-get ( quot -- ) %alien-get "output" operand dup %tag-fixnum ; inline -: %alien-integer-set ( quot -- ) - { "offset" "value" } %untag-fixnums - "value" operand "alien" operand-class %alien-accessor ; inline - : alien-integer-set-template H{ { +input+ { { f "value" fixnum } - { f "alien" simple-c-ptr } + { unboxed-c-ptr "alien" simple-c-ptr } { f "offset" fixnum } } } { +scratch+ { { f "address" } } } { +clobber+ { "value" "offset" } } } ; +: %alien-integer-set ( quot -- ) + "offset" get "value" get = [ + "value" operand dup %untag-fixnum + ] unless + %alien-set ; inline + : define-alien-integer-intrinsics ( word get-quot word set-quot -- ) [ %alien-integer-set ] curry alien-integer-set-template @@ -660,41 +667,56 @@ define-alien-integer-intrinsics \ set-alien-signed-2 [ STH ] define-alien-integer-intrinsics -: %alien-float-get ( quot -- ) - "offset" operand dup %untag-fixnum - "output" operand "alien" operand-class %alien-accessor ; inline +\ alien-cell [ + [ LWZ ] %alien-get +] H{ + { +input+ { + { unboxed-c-ptr "alien" simple-c-ptr } + { f "offset" fixnum } + } } + ! should be unboxed-alien + { +scratch+ { { unboxed-c-ptr "output" } } } + { +output+ { "output" } } + { +clobber+ { "offset" } } +} define-intrinsic + +\ set-alien-cell [ + [ STW ] %alien-set +] H{ + { +input+ { + { unboxed-c-ptr "value" simple-c-ptr } + { unboxed-c-ptr "alien" simple-c-ptr } + { f "offset" fixnum } + } } + { +clobber+ { "offset" } } +} define-intrinsic : alien-float-get-template H{ { +input+ { - { f "alien" simple-c-ptr } + { unboxed-c-ptr "alien" simple-c-ptr } { f "offset" fixnum } } } - { +scratch+ { { float "output" } { f "address" } } } + { +scratch+ { { float "output" } } } { +output+ { "output" } } { +clobber+ { "offset" } } } ; -: %alien-float-set ( quot -- ) - "offset" operand dup %untag-fixnum - "value" operand "alien" operand-class %alien-accessor ; inline - : alien-float-set-template H{ { +input+ { { float "value" float } - { f "alien" simple-c-ptr } + { unboxed-c-ptr "alien" simple-c-ptr } { f "offset" fixnum } } } - { +scratch+ { { f "address" } } } { +clobber+ { "offset" } } } ; : define-alien-float-intrinsics ( word get-quot word set-quot -- ) - [ %alien-float-set ] curry + [ %alien-set ] curry alien-float-set-template define-intrinsic - [ %alien-float-get ] curry + [ %alien-get ] curry alien-float-get-template define-intrinsic ; @@ -705,8 +727,3 @@ define-alien-float-intrinsics \ alien-float [ LFS ] \ set-alien-float [ STFS ] define-alien-float-intrinsics - -\ alien-cell [ - [ LWZ ] %alien-get - "output" get %allot-alien -] alien-integer-get-template define-intrinsic diff --git a/core/generator/registers/registers.factor b/core/generator/registers/registers.factor index 7e31f83abc..6527bed056 100644 --- a/core/generator/registers/registers.factor +++ b/core/generator/registers/registers.factor @@ -47,6 +47,23 @@ TUPLE: rs-loc n ; C: rs-loc +! Unboxed alien pointers +TUPLE: unboxed-alien vreg ; +C: unboxed-alien +M: unboxed-alien v>operand unboxed-alien-vreg v>operand ; + +TUPLE: unboxed-byte-array vreg ; +C: unboxed-byte-array +M: unboxed-byte-array v>operand unboxed-byte-array-vreg v>operand ; + +TUPLE: unboxed-f vreg ; +C: unboxed-f +M: unboxed-f v>operand unboxed-f-vreg v>operand ; + +TUPLE: unboxed-c-ptr vreg ; +C: unboxed-c-ptr +M: unboxed-c-ptr v>operand unboxed-c-ptr-vreg v>operand ; + ! Phantom stacks hold values, locs, and vregs GENERIC: live-vregs* ( obj -- ) -M: cached live-vregs* cached-vreg , ; +M: cached live-vregs* cached-vreg live-vregs* ; +M: unboxed-alien live-vregs* unboxed-alien-vreg , ; +M: unboxed-byte-array live-vregs* unboxed-byte-array-vreg , ; +M: unboxed-f live-vregs* unboxed-f-vreg , ; +M: unboxed-c-ptr live-vregs* unboxed-c-ptr-vreg , ; M: vreg live-vregs* , ; M: object live-vregs* drop ; @@ -239,7 +272,13 @@ SYMBOL: fresh-objects ! Copying vregs to stacks : alloc-vreg ( spec -- reg ) - reg-spec>class free-vregs pop ; + dup reg-spec>class free-vregs pop swap { + { unboxed-alien [ ] } + { unboxed-byte-array [ ] } + { unboxed-f [ ] } + { unboxed-c-ptr [ ] } + [ drop ] + } case ; : allocation ( value spec -- reg-class ) dup quotation? [ @@ -368,8 +407,19 @@ M: object minimal-ds-loc* drop ; : vreg-substitution ( value vreg -- pair ) dupd 2array ; +: substitute-vreg? ( old new -- ? ) + #! We don't substitute locs for float or alien vregs, + #! since in those cases the boxing overhead might kill us. + cached-vreg { + { [ dup vreg? not ] [ f ] } + { [ dup delegate int-regs? not ] [ f ] } + { [ over loc? not ] [ f ] } + { [ t ] [ t ] } + } cond 2nip ; + : substitute-vregs ( values vregs -- ) - [ vreg-substitution ] 2map [ first loc? ] subset >hashtable + [ vreg-substitution ] 2map + [ substitute-vreg? ] assoc-subset >hashtable [ swap substitute ] curry each-phantom ; : lazy-load ( values template -- ) From 73cd2090486f66b36a8869bf177f64db8a2f0bf3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 28 Sep 2007 04:03:09 -0400 Subject: [PATCH 21/88] Update TUPLE: docs --- core/syntax/syntax-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor index b42a69616e..7072b98b48 100644 --- a/core/syntax/syntax-docs.factor +++ b/core/syntax/syntax-docs.factor @@ -514,7 +514,7 @@ HELP: PREDICATE: HELP: TUPLE: { $syntax "TUPLE: class slots... ;" } { $values { "class" "a new tuple class to define" } { "slots" "a list of slot names" } } -{ $description "Defines a new tuple class with membership predicate " { $snippet "name?" } " and constructor " { $snippet "" } "." +{ $description "Defines a new tuple class with membership predicate " { $snippet "name?" } "." $nl "Tuples are user-defined classes with instances composed of named slots. All tuple classes are subtypes of the built-in " { $link tuple } " type." } ; From 23e85d674c7adfcf7e64c6967c13f428aa97a7b1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 28 Sep 2007 04:11:06 -0400 Subject: [PATCH 22/88] Remove obsolete target from Makefile --- Makefile | 3 --- 1 file changed, 3 deletions(-) diff --git a/Makefile b/Makefile index c5db03896e..c893c8f2e7 100644 --- a/Makefile +++ b/Makefile @@ -130,9 +130,6 @@ factor: $(DLL_OBJS) $(EXE_OBJS) $(CC) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \ $(CFLAGS) -o $@$(EXE_SUFFIX)$(EXE_EXTENSION) $(EXE_OBJS) -pull: - darcs pull http://factorcode.org/repos/ - clean: rm -f vm/*.o From 31e59f209874af25166748d570eb0bff14384427 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 28 Sep 2007 17:06:16 -0400 Subject: [PATCH 23/88] check-slice inline --- core/sequences/sequences.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 1a8e5c9561..a31c869f24 100644 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -194,7 +194,7 @@ TUPLE: slice-error reason ; : check-slice ( from to seq -- from to seq ) pick 0 < [ "start < 0" slice-error ] when dup length pick < [ "end > sequence" slice-error ] when - pick pick > [ "start > end" slice-error ] when ; + pick pick > [ "start > end" slice-error ] when ; inline : ( from to seq -- slice ) dup slice? [ collapse-slice ] when From 3f62ef3a2da24cf7315090f45336df53c040fbd9 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 29 Sep 2007 13:25:36 -0500 Subject: [PATCH 24/88] colors.hsv is the old cfdg.hsv --- extra/colors/hsv/hsv.factor | 52 +++++++++++++++++++++++-------------- 1 file changed, 32 insertions(+), 20 deletions(-) diff --git a/extra/colors/hsv/hsv.factor b/extra/colors/hsv/hsv.factor index 88c8c2f427..102f45ce8a 100644 --- a/extra/colors/hsv/hsv.factor +++ b/extra/colors/hsv/hsv.factor @@ -1,29 +1,41 @@ -! Copyright (C) 2003, 2007 Slava Pestov. +! Copyright (C) 2007 Eduardo Cavazos ! See http://factorcode.org/license.txt for BSD license. -USING: kernel sequences math ; + +USING: kernel combinators arrays sequences math combinators.lib ; + IN: colors.hsv r swap rot >r 2dup r> 6 * r> - ; -: p ( v s x -- v p x ) >r dupd neg 1 + * r> ; -: q ( v s f -- q ) * neg 1 + * ; -: t_ ( v s f -- t_ ) neg 1 + * neg 1 + * ; +: H ( hsv -- H ) first ; + +: S ( hsv -- S ) second ; + +: V ( hsv -- V ) third ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: Hi ( hsv -- Hi ) H 60 / floor 6 mod ; + +: f ( hsv -- f ) [ H 60 / ] [ Hi ] bi - ; + +: p ( hsv -- p ) [ S 1 swap - ] [ V ] bi * ; + +: q ( hsv -- q ) [ [ f ] [ S ] bi * 1 swap - ] [ V ] bi * ; + +: t ( hsv -- t ) [ [ f 1 swap - ] [ S ] bi * 1 swap - ] [ V ] bi * ; PRIVATE> -: mod-cond ( p vector -- ) - #! Call p mod q'th entry of the vector of quotations, where - #! q is the length of the vector. The value q remains on the - #! stack. - [ dupd length mod ] keep nth call ; +! h [0,360) +! s [0,1] +! v [0,1] -: hsv>rgb ( h s v -- r g b ) - pick 6 * >fixnum { - [ f_ t_ p swap ] ! v p t - [ f_ q p -rot ] ! q v p - [ f_ t_ p swapd ] ! p v t - [ f_ q p rot ] ! p q v - [ f_ t_ p swap rot ] ! t p v - [ f_ q p ] ! v p q - } mod-cond ; +: hsv>rgb ( hsv -- rgb ) +dup Hi +{ { 0 [ [ V ] [ t ] [ p ] tri ] } + { 1 [ [ q ] [ V ] [ p ] tri ] } + { 2 [ [ p ] [ V ] [ t ] tri ] } + { 3 [ [ p ] [ q ] [ V ] tri ] } + { 4 [ [ t ] [ p ] [ V ] tri ] } + { 5 [ [ V ] [ p ] [ q ] tri ] } } case 3array ; From 8f4d158f8acfe245dc27ffaa24b077dd8e2133b5 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 29 Sep 2007 13:26:21 -0500 Subject: [PATCH 25/88] remove cfdg.hsv (now colors.hsv) --- extra/cfdg/hsv/hsv.factor | 39 --------------------------------------- 1 file changed, 39 deletions(-) delete mode 100644 extra/cfdg/hsv/hsv.factor diff --git a/extra/cfdg/hsv/hsv.factor b/extra/cfdg/hsv/hsv.factor deleted file mode 100644 index 3714416d2e..0000000000 --- a/extra/cfdg/hsv/hsv.factor +++ /dev/null @@ -1,39 +0,0 @@ - -USING: kernel combinators arrays sequences math combinators.lib ; - -IN: cfdg.hsv - - - -! h [0,360) -! s [0,1] -! v [0,1] - -: hsv>rgb ( hsv -- rgb ) -dup Hi -{ { 0 [ [ V ] [ t ] [ p ] tri ] } - { 1 [ [ q ] [ V ] [ p ] tri ] } - { 2 [ [ p ] [ V ] [ t ] tri ] } - { 3 [ [ p ] [ q ] [ V ] tri ] } - { 4 [ [ t ] [ p ] [ V ] tri ] } - { 5 [ [ V ] [ p ] [ q ] tri ] } } case 3array ; From 8c0f4def820843c817fd8adf87c0e57ceb0a2c70 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 29 Sep 2007 13:26:51 -0500 Subject: [PATCH 26/88] Refactor cfdg --- extra/cfdg/cfdg.factor | 174 ++++++++++++++++++----------------------- 1 file changed, 76 insertions(+), 98 deletions(-) diff --git a/extra/cfdg/cfdg.factor b/extra/cfdg/cfdg.factor index cbb7417640..f007e9f757 100644 --- a/extra/cfdg/cfdg.factor +++ b/extra/cfdg/cfdg.factor @@ -2,36 +2,43 @@ USING: kernel alien.c-types combinators namespaces arrays sequences sequences.lib namespaces.lib splitting math math.functions math.vectors math.trig - opengl.gl opengl.glu ui ui.gadgets.slate vars mortar slot-accessors - random-weighted cfdg.hsv cfdg.gl ; + opengl.gl opengl.glu opengl ui ui.gadgets.slate + combinators.lib vars + random-weighted colors.hsv cfdg.gl ; IN: cfdg ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -SYMBOL: +! hsba { hue saturation brightness alpha } - - { "hue" "saturation" "brightness" "alpha" } accessors -define-independent-class - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: hsv>rgb* ( h s v -- r g b ) 3array hsv>rgb first3 ; - -: gl-set-hsba ( color -- ) object-values first4 >r hsv>rgb* r> glColor4d ; - -: gl-clear-hsba ( color -- ) object-values first4 >r hsv>rgb* r> glClearColor ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +: 4array ; VAR: color -: init-color ( -- ) 0 0 0 1 new >color ; +! ( -- val ) -: hue ( num -- ) color> tuck $hue + 360 mod >>hue drop ; +: hue>> 0 color> nth ; +: saturation>> 1 color> nth ; +: brightness>> 2 color> nth ; +: alpha>> 3 color> nth ; -: h ( num -- ) hue ; +! ( val -- ) + +: >>hue 0 color> set-nth ; +: >>saturation 1 color> set-nth ; +: >>brightness 2 color> set-nth ; +: >>alpha 3 color> set-nth ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: hsva>rgba ( hsva -- rgba ) [ 3 head hsv>rgb ] [ peek ] bi add ; + +: gl-set-hsba ( hsva -- ) hsva>rgba gl-color ; + +: gl-clear-hsba ( hsva -- ) hsva>rgba gl-clear ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! if (adjustment < 0) ! base + base * adjustment @@ -41,17 +48,20 @@ VAR: color : adjust ( val num -- val ) dup 0 > [ 1 pick - * + ] [ dupd * + ] if ; -: saturation ( num -- ) color> dup $saturation rot adjust >>saturation drop ; +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: sat ( num -- ) saturation ; +: hue ( num -- ) hue>> + 360 mod >>hue ; -: brightness ( num -- ) color> dup $brightness rot adjust >>brightness drop ; +: saturation ( num -- ) saturation>> swap adjust >>saturation ; +: brightness ( num -- ) brightness>> swap adjust >>brightness ; +: alpha ( num -- ) alpha>> swap adjust >>alpha ; -: b ( num -- ) brightness ; +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: alpha ( num -- ) color> dup $alpha rot adjust >>alpha drop ; - -: a ( num -- ) alpha ; +: h hue ; +: sat saturation ; +: b brightness ; +: a alpha ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -59,38 +69,19 @@ VAR: color-stack : init-color-stack ( -- ) V{ } clone >color-stack ; -: clone-color ( hsba -- hsba ) object-values first4 new ; - -: push-color ( -- ) -color> color-stack> push -color> clone-color >color ; +: push-color ( -- ) color> color-stack> push color> clone >color ; : pop-color ( -- ) color-stack> pop dup >color gl-set-hsba ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! : check-size ( modelview-matrix -- num ) -! { 0 1 4 5 } swap [ double-nth ] curry map -! [ abs ] map -! [ <=> ] maximum ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -! : check-size ( modelview-matrix -- num ) -! { 0 1 4 5 } swap [ double-nth ] curry map -! [ abs ] map -! biggest ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - : double-nth* ( c-array indices -- seq ) swap [ double-nth ] curry map ; -: check-size ( modelview-matrix -- num ) - { 0 1 4 5 } double-nth* [ abs ] map biggest ; +: check-size ( modelview -- num ) { 0 1 4 5 } double-nth* [ abs ] map biggest ; VAR: threshold -: iterate? ( -- ? ) get-modelview-matrix check-size threshold get > ; +: iterate? ( -- ? ) get-modelview-matrix check-size threshold> > ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -101,65 +92,65 @@ VAR: threshold ! column major order -: gl-flip ( angle -- ) deg>rad -{ [ dup 2 * cos ] [ dup 2 * sin ] 0 0 - [ dup 2 * sin ] [ 2 * cos neg ] 0 0 - 0 0 1 0 - 0 0 0 1 } make* >c-double-array glMultMatrixd ; +: gl-flip ( angle -- ) deg>rad dup dup dup + [ 2 * cos , 2 * sin , 0 , 0 , + 2 * sin , 2 * cos neg , 0 , 0 , + 0 , 0 , 1 , 0 , + 0 , 0 , 0 , 1 , ] + { } make >c-double-array glMultMatrixd ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : circle ( -- ) -color> gl-set-hsba -gluNewQuadric dup 0 0.5 20 10 gluDisk gluDeleteQuadric ; + color> gl-set-hsba + gluNewQuadric dup 0 0.5 20 10 gluDisk gluDeleteQuadric ; : triangle ( -- ) -color> gl-set-hsba -GL_POLYGON glBegin - 0 0.577 glVertex2d - 0.5 -0.289 glVertex2d - -0.5 -0.289 glVertex2d -glEnd ; + color> gl-set-hsba + GL_POLYGON glBegin + 0 0.577 glVertex2d + 0.5 -0.289 glVertex2d + -0.5 -0.289 glVertex2d + glEnd ; : square ( -- ) -color> gl-set-hsba -GL_POLYGON glBegin - -0.5 0.5 glVertex2d - 0.5 0.5 glVertex2d - 0.5 -0.5 glVertex2d - -0.5 -0.5 glVertex2d -glEnd ; + color> gl-set-hsba + GL_POLYGON glBegin + -0.5 0.5 glVertex2d + 0.5 0.5 glVertex2d + 0.5 -0.5 glVertex2d + -0.5 -0.5 glVertex2d + glEnd ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : size ( scale -- ) dup 1 glScaled ; -: s ( scale -- ) size ; - : size* ( scale-x scale-y -- ) 1 glScaled ; -: s* ( scale-x scale-y -- ) size* ; - : rotate ( angle -- ) 0 0 1 glRotated ; -: r ( angle -- ) rotate ; - : x ( x -- ) 0 0 glTranslated ; : y ( y -- ) 0 swap 0 glTranslated ; : flip ( angle -- ) gl-flip ; -: f ( angle -- ) flip ; +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: s size ; +: s* size* ; +: r rotate ; +: f flip ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : do ( quot -- ) -push-modelview-matrix -push-color -call -pop-modelview-matrix -pop-color ; + push-modelview-matrix + push-color + call + pop-modelview-matrix + pop-color ; inline ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -171,10 +162,10 @@ pop-color ; VAR: background -: initial-background ( -- hsba ) 0 0 1 1 new ; +: set-initial-background ( -- ) { 0 0 1 1 } clone >color ; : set-background ( -- ) - initial-background >color + set-initial-background background> call color> gl-clear-hsba ; @@ -186,23 +177,10 @@ VAR: viewport ! { left width bottom height } VAR: start-shape -: initial-color ( -- hsba ) 0 0 0 1 new ; +: set-initial-color ( -- ) { 0 0 0 1 } clone >color ; : display ( -- ) -! GL_LINE_SMOOTH glEnable -! GL_BLEND glEnable -! GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA glBlendFunc -! GL_POINT_SMOOTH_HINT GL_NICEST glHint - -! GL_FOG glEnable -! GL_FOG_MODE GL_LINEAR glFogi -! GL_FOG_COLOR { 0.5 0.5 0.5 1.0 } >c-double-array glFogfv -! GL_FOG_DENSITY 0.35 glFogf -! GL_FOG_HINT GL_DONT_CARE glHint -! GL_FOG_START 1.0 glFogf -! GL_FOG_END 5.0 glFogf - GL_PROJECTION glMatrixMode glLoadIdentity viewport> first dup viewport> second + @@ -218,14 +196,14 @@ VAR: start-shape init-modelview-matrix-stack init-color-stack - initial-color >color + set-initial-color color> gl-set-hsba start-shape> call ; : cfdg-window* ( -- ) -[ display ] closed-quot + [ display ] closed-quot { 500 500 } over set-slate-dim dup "CFDG" open-window ; From ce4486d00f69705bf378ad9d55e8c444e82c52dc Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 29 Sep 2007 13:28:09 -0500 Subject: [PATCH 27/88] Update benchmark.mandel for new colors.hsv --- extra/benchmark/mandel/mandel.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/benchmark/mandel/mandel.factor b/extra/benchmark/mandel/mandel.factor index 5099a5e0a7..0ad7c5e26d 100644 --- a/extra/benchmark/mandel/mandel.factor +++ b/extra/benchmark/mandel/mandel.factor @@ -19,8 +19,8 @@ math.functions math.parser io.files colors.hsv ; : ( nb-cols -- map ) dup [ - 360 * swap 1+ / 360 / sat val - hsv>rgb scale-rgb + 360 * swap 1+ / sat val + 3array hsv>rgb first3 scale-rgb ] curry* map ; : iter ( c z nb-iter -- x ) From 601ae65af6419759a4dd47be6d4fb2c8efe084f4 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 29 Sep 2007 13:28:53 -0500 Subject: [PATCH 28/88] random-weighted: add call-random-weighted macro --- extra/random-weighted/random-weighted.factor | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/extra/random-weighted/random-weighted.factor b/extra/random-weighted/random-weighted.factor index 0ec366beb0..cc050eb4df 100644 --- a/extra/random-weighted/random-weighted.factor +++ b/extra/random-weighted/random-weighted.factor @@ -1,10 +1,10 @@ -USING: kernel quotations sequences math math.vectors random ; +USING: kernel namespaces arrays quotations sequences assocs combinators + mirrors math math.vectors random combinators.lib macros bake ; IN: random-weighted -: probabilities ( weights -- probabilities ) -dup sum [ / ] curry map ; +: probabilities ( weights -- probabilities ) dup sum [ / ] curry map ; : layers ( probabilities -- layers ) dup length 1+ [ head ] curry* map 1 tail [ sum ] map ; @@ -13,4 +13,8 @@ dup length 1+ [ head ] curry* map 1 tail [ sum ] map ; probabilities layers [ 1000 * ] map 1000 random [ > ] curry find drop ; : random-weighted* ( seq -- elt ) -dup [ second ] map swap [ first ] map random-weighted swap nth ; \ No newline at end of file +dup [ second ] map swap [ first ] map random-weighted swap nth ; + +MACRO: call-random-weighted ( exp -- ) + [ keys ] [ values >alist ] bi swap + [ , random-weighted , case ] bake ; From 9ab46a94db5798aa8bcfdfe819fa6605de39d48b Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 29 Sep 2007 13:29:29 -0500 Subject: [PATCH 29/88] cfdg.models.chiaroscuro: uses call-random-weighted --- .../models/chiaroscuro/chiaroscuro.factor | 20 +++++++++++-------- 1 file changed, 12 insertions(+), 8 deletions(-) diff --git a/extra/cfdg/models/chiaroscuro/chiaroscuro.factor b/extra/cfdg/models/chiaroscuro/chiaroscuro.factor index 08c4308159..a87b3602d9 100644 --- a/extra/cfdg/models/chiaroscuro/chiaroscuro.factor +++ b/extra/cfdg/models/chiaroscuro/chiaroscuro.factor @@ -8,17 +8,21 @@ IN: cfdg.models.chiaroscuro DEFER: white : black ( -- ) iterate? [ -{ { 60 [ [ 0.6 s circle ] do - [ 0.1 x 5 r 0.99 s -0.01 b -0.01 a black ] do ] } - { 1 [ white black ] } } -random-weighted* call + { { 60 [ [ 0.6 s circle ] do + [ 0.1 x 5 r 0.99 s -0.01 b -0.01 a black ] do ] } + { 1 [ white black ] } } + call-random-weighted ] when ; : white ( -- ) iterate? [ -{ { 60 [ [ 0.6 s circle ] do - [ 0.1 x -5 r 0.99 s 0.01 b -0.01 a white ] do ] } - { 1 [ black white ] } } -random-weighted* call + { { 60 [ + [ 0.6 s circle ] do + [ 0.1 x -5 r 0.99 s 0.01 b -0.01 a white ] do + ] } + { 1 [ + black white + ] } } + call-random-weighted ] when ; : chiaroscuro ( -- ) [ 0.5 b black ] do ; From 3747cff69c798d56dfd2598c6b882d4236aea5bf Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 29 Sep 2007 13:30:00 -0500 Subject: [PATCH 30/88] Minor updates --- extra/bake/bake.factor | 3 +-- extra/cfdg/gl/gl.factor | 7 +++---- 2 files changed, 4 insertions(+), 6 deletions(-) diff --git a/extra/bake/bake.factor b/extra/bake/bake.factor index d229b19a0e..5e1700c6e2 100644 --- a/extra/bake/bake.factor +++ b/extra/bake/bake.factor @@ -48,5 +48,4 @@ DEFER: bake : bake-items ( seq -- ) [ bake-item ] each ; : bake ( seq -- seq ) - [ reset-building save-exemplar bake-items finish-baking ] with-scope ; - + [ reset-building save-exemplar bake-items finish-baking ] with-scope ; \ No newline at end of file diff --git a/extra/cfdg/gl/gl.factor b/extra/cfdg/gl/gl.factor index e40576907a..35e7de0bb7 100644 --- a/extra/cfdg/gl/gl.factor +++ b/extra/cfdg/gl/gl.factor @@ -4,14 +4,13 @@ USING: kernel alien.c-types namespaces sequences opengl.gl ; IN: cfdg.gl : get-modelview-matrix ( -- alien ) -GL_MODELVIEW_MATRIX 16 "GLdouble" tuck glGetDoublev ; + GL_MODELVIEW_MATRIX 16 "GLdouble" tuck glGetDoublev ; SYMBOL: modelview-matrix-stack -: init-modelview-matrix-stack ( -- ) -V{ } clone modelview-matrix-stack set ; +: init-modelview-matrix-stack ( -- ) V{ } clone modelview-matrix-stack set ; : push-modelview-matrix ( -- ) -get-modelview-matrix modelview-matrix-stack get push ; + get-modelview-matrix modelview-matrix-stack get push ; : pop-modelview-matrix ( -- ) modelview-matrix-stack get pop glLoadMatrixd ; \ No newline at end of file From af8ec16cf56ded60f2e912610721a5d09ab5e13d Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 29 Sep 2007 13:46:32 -0500 Subject: [PATCH 31/88] Move trees and gap-buffer to unmaintained for now. --- {extra => unmaintained}/gap-buffer/authors.txt | 0 {extra => unmaintained}/gap-buffer/cursortree/authors.txt | 0 .../gap-buffer/cursortree/cursortree-tests.factor | 0 {extra => unmaintained}/gap-buffer/cursortree/cursortree.factor | 0 {extra => unmaintained}/gap-buffer/cursortree/summary.txt | 0 {extra => unmaintained}/gap-buffer/gap-buffer-tests.factor | 0 {extra => unmaintained}/gap-buffer/gap-buffer.factor | 0 {extra => unmaintained}/gap-buffer/summary.txt | 0 {extra => unmaintained}/gap-buffer/tags.txt | 0 {extra => unmaintained}/trees/authors.txt | 0 {extra => unmaintained}/trees/avl-tree/avl-tree-tests.factor | 0 {extra => unmaintained}/trees/avl-tree/avl-tree.factor | 0 {extra => unmaintained}/trees/bst/bst-tests.factor | 0 {extra => unmaintained}/trees/bst/bst.factor | 0 {extra => unmaintained}/trees/summary.txt | 0 {extra => unmaintained}/trees/tags.txt | 0 {extra => unmaintained}/trees/trees.factor | 0 17 files changed, 0 insertions(+), 0 deletions(-) rename {extra => unmaintained}/gap-buffer/authors.txt (100%) rename {extra => unmaintained}/gap-buffer/cursortree/authors.txt (100%) rename {extra => unmaintained}/gap-buffer/cursortree/cursortree-tests.factor (100%) rename {extra => unmaintained}/gap-buffer/cursortree/cursortree.factor (100%) rename {extra => unmaintained}/gap-buffer/cursortree/summary.txt (100%) rename {extra => unmaintained}/gap-buffer/gap-buffer-tests.factor (100%) rename {extra => unmaintained}/gap-buffer/gap-buffer.factor (100%) rename {extra => unmaintained}/gap-buffer/summary.txt (100%) rename {extra => unmaintained}/gap-buffer/tags.txt (100%) rename {extra => unmaintained}/trees/authors.txt (100%) rename {extra => unmaintained}/trees/avl-tree/avl-tree-tests.factor (100%) rename {extra => unmaintained}/trees/avl-tree/avl-tree.factor (100%) rename {extra => unmaintained}/trees/bst/bst-tests.factor (100%) rename {extra => unmaintained}/trees/bst/bst.factor (100%) rename {extra => unmaintained}/trees/summary.txt (100%) rename {extra => unmaintained}/trees/tags.txt (100%) rename {extra => unmaintained}/trees/trees.factor (100%) diff --git a/extra/gap-buffer/authors.txt b/unmaintained/gap-buffer/authors.txt similarity index 100% rename from extra/gap-buffer/authors.txt rename to unmaintained/gap-buffer/authors.txt diff --git a/extra/gap-buffer/cursortree/authors.txt b/unmaintained/gap-buffer/cursortree/authors.txt similarity index 100% rename from extra/gap-buffer/cursortree/authors.txt rename to unmaintained/gap-buffer/cursortree/authors.txt diff --git a/extra/gap-buffer/cursortree/cursortree-tests.factor b/unmaintained/gap-buffer/cursortree/cursortree-tests.factor similarity index 100% rename from extra/gap-buffer/cursortree/cursortree-tests.factor rename to unmaintained/gap-buffer/cursortree/cursortree-tests.factor diff --git a/extra/gap-buffer/cursortree/cursortree.factor b/unmaintained/gap-buffer/cursortree/cursortree.factor similarity index 100% rename from extra/gap-buffer/cursortree/cursortree.factor rename to unmaintained/gap-buffer/cursortree/cursortree.factor diff --git a/extra/gap-buffer/cursortree/summary.txt b/unmaintained/gap-buffer/cursortree/summary.txt similarity index 100% rename from extra/gap-buffer/cursortree/summary.txt rename to unmaintained/gap-buffer/cursortree/summary.txt diff --git a/extra/gap-buffer/gap-buffer-tests.factor b/unmaintained/gap-buffer/gap-buffer-tests.factor similarity index 100% rename from extra/gap-buffer/gap-buffer-tests.factor rename to unmaintained/gap-buffer/gap-buffer-tests.factor diff --git a/extra/gap-buffer/gap-buffer.factor b/unmaintained/gap-buffer/gap-buffer.factor similarity index 100% rename from extra/gap-buffer/gap-buffer.factor rename to unmaintained/gap-buffer/gap-buffer.factor diff --git a/extra/gap-buffer/summary.txt b/unmaintained/gap-buffer/summary.txt similarity index 100% rename from extra/gap-buffer/summary.txt rename to unmaintained/gap-buffer/summary.txt diff --git a/extra/gap-buffer/tags.txt b/unmaintained/gap-buffer/tags.txt similarity index 100% rename from extra/gap-buffer/tags.txt rename to unmaintained/gap-buffer/tags.txt diff --git a/extra/trees/authors.txt b/unmaintained/trees/authors.txt similarity index 100% rename from extra/trees/authors.txt rename to unmaintained/trees/authors.txt diff --git a/extra/trees/avl-tree/avl-tree-tests.factor b/unmaintained/trees/avl-tree/avl-tree-tests.factor similarity index 100% rename from extra/trees/avl-tree/avl-tree-tests.factor rename to unmaintained/trees/avl-tree/avl-tree-tests.factor diff --git a/extra/trees/avl-tree/avl-tree.factor b/unmaintained/trees/avl-tree/avl-tree.factor similarity index 100% rename from extra/trees/avl-tree/avl-tree.factor rename to unmaintained/trees/avl-tree/avl-tree.factor diff --git a/extra/trees/bst/bst-tests.factor b/unmaintained/trees/bst/bst-tests.factor similarity index 100% rename from extra/trees/bst/bst-tests.factor rename to unmaintained/trees/bst/bst-tests.factor diff --git a/extra/trees/bst/bst.factor b/unmaintained/trees/bst/bst.factor similarity index 100% rename from extra/trees/bst/bst.factor rename to unmaintained/trees/bst/bst.factor diff --git a/extra/trees/summary.txt b/unmaintained/trees/summary.txt similarity index 100% rename from extra/trees/summary.txt rename to unmaintained/trees/summary.txt diff --git a/extra/trees/tags.txt b/unmaintained/trees/tags.txt similarity index 100% rename from extra/trees/tags.txt rename to unmaintained/trees/tags.txt diff --git a/extra/trees/trees.factor b/unmaintained/trees/trees.factor similarity index 100% rename from extra/trees/trees.factor rename to unmaintained/trees/trees.factor From 894a657056c4fd134117483c10b7e60f71d997f4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 29 Sep 2007 19:43:03 -0400 Subject: [PATCH 32/88] Alien unboxing --- core/compiler/test/templates-early.factor | 10 +- core/cpu/architecture/architecture.factor | 7 +- core/cpu/ppc/architecture/architecture.factor | 4 +- core/cpu/ppc/intrinsics/intrinsics.factor | 7 +- core/effects/effects.factor | 15 + core/generator/generator.factor | 21 +- core/generator/registers/registers.factor | 474 +++++++++++------- core/inference/inference.factor | 5 +- core/inference/known-words/known-words.factor | 90 +++- core/inference/stack/authors.txt | 1 - core/inference/stack/stack-docs.factor | 11 - core/inference/stack/stack.factor | 64 --- core/inference/stack/summary.txt | 1 - 13 files changed, 385 insertions(+), 325 deletions(-) delete mode 100644 core/inference/stack/authors.txt delete mode 100644 core/inference/stack/stack-docs.factor delete mode 100644 core/inference/stack/stack.factor delete mode 100644 core/inference/stack/summary.txt diff --git a/core/compiler/test/templates-early.factor b/core/compiler/test/templates-early.factor index 0eee6aabbf..4ea304f0d8 100644 --- a/core/compiler/test/templates-early.factor +++ b/core/compiler/test/templates-early.factor @@ -4,6 +4,8 @@ USING: compiler generator generator.registers generator.registers.private tools.test namespaces sequences words kernel math effects ; +: ( n -- vreg ) T{ int-regs } ; + [ [ ] [ init-templates ] unit-test @@ -58,8 +60,6 @@ words kernel math effects ; { +input+ { { f "x" } } } } clone [ [ 1 0 ] [ +input+ get { } { } guess-vregs ] unit-test - [ ] [ 1 0 ensure-vregs ] unit-test - ! [ t ] [ +input+ get phantom-d get compatible? ] unit-test [ ] [ finalize-contents ] unit-test [ ] [ [ template-inputs ] { } make drop ] unit-test ] bind @@ -119,12 +119,14 @@ SYMBOL: template-chosen ! This is not empty since a load instruction is emitted [ f ] [ - [ { { f "x" } } fast-input ] { } make empty? + [ { { f "x" } } +input+ set load-inputs ] { } make + empty? ] unit-test ! This is empty since we already loaded the value [ t ] [ - [ { { f "x" } } fast-input ] { } make empty? + [ { { f "x" } } +input+ set load-inputs ] { } make + empty? ] unit-test ! This is empty since we didn't change the stack diff --git a/core/cpu/architecture/architecture.factor b/core/cpu/architecture/architecture.factor index 2645d4476d..22efad5c4d 100644 --- a/core/cpu/architecture/architecture.factor +++ b/core/cpu/architecture/architecture.factor @@ -2,8 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays generic kernel kernel.private math memory namespaces sequences layouts system hashtables classes alien -byte-arrays bit-arrays float-arrays combinators words -inference.dataflow ; +byte-arrays bit-arrays float-arrays combinators words ; IN: cpu.architecture SYMBOL: compiler-backend @@ -153,8 +152,6 @@ M: integer v>operand tag-bits get shift ; M: f v>operand drop \ f tag-number ; -M: value v>operand value-literal ; - M: object load-literal v>operand load-indirect ; PREDICATE: integer small-slot cells small-enough? ; @@ -189,7 +186,7 @@ HOOK: %unbox-alien compiler-backend ( dst src -- ) HOOK: %unbox-f compiler-backend ( dst src -- ) -HOOK: %unbox-c-ptr compiler-backend ( dst src -- ) +HOOK: %unbox-any-c-ptr compiler-backend ( dst src -- ) HOOK: %box-alien compiler-backend ( dst src -- ) diff --git a/core/cpu/ppc/architecture/architecture.factor b/core/cpu/ppc/architecture/architecture.factor index 4942020e2a..87955c5080 100644 --- a/core/cpu/ppc/architecture/architecture.factor +++ b/core/cpu/ppc/architecture/architecture.factor @@ -269,7 +269,7 @@ M: ppc-backend %alien-invoke ( symbol dll -- ) 11 %load-dlsym (%call) ; M: ppc-backend %alien-callback ( quot -- ) - 0 load-literal "c_to_factor" f %alien-invoke ; + 3 load-indirect "c_to_factor" f %alien-invoke ; M: ppc-backend %prepare-alien-indirect ( -- ) "unbox_alien" f %alien-invoke @@ -324,7 +324,7 @@ M: ppc-backend %unbox-alien ( dst src -- ) M: ppc-backend %unbox-f ( dst src -- ) drop 0 swap v>operand LI ; -M: ppc-backend %unbox-c-ptr ( dst src -- ) +M: ppc-backend %unbox-any-c-ptr ( dst src -- ) "is-f" define-label "is-alien" define-label "end" define-label diff --git a/core/cpu/ppc/intrinsics/intrinsics.factor b/core/cpu/ppc/intrinsics/intrinsics.factor index 27398b6404..53fc237c37 100644 --- a/core/cpu/ppc/intrinsics/intrinsics.factor +++ b/core/cpu/ppc/intrinsics/intrinsics.factor @@ -15,7 +15,7 @@ IN: cpu.ppc.intrinsics "val" operand "obj" operand "n" get cells - "obj" operand-tag - ; + "obj" get operand-tag - ; : %slot-literal-any-tag "obj" operand "scratch" operand %untag @@ -58,7 +58,7 @@ IN: cpu.ppc.intrinsics "cards_offset" f pick %load-dlsym dup 0 LWZ ; : %write-barrier ( -- ) - "val" operand-immediate? "obj" get fresh-object? or [ + "val" get operand-immediate? "obj" get fresh-object? or [ "obj" operand "scratch" operand card-bits SRWI "val" operand load-cards-offset "scratch" operand dup "val" operand ADD @@ -674,8 +674,7 @@ define-alien-integer-intrinsics { unboxed-c-ptr "alien" simple-c-ptr } { f "offset" fixnum } } } - ! should be unboxed-alien - { +scratch+ { { unboxed-c-ptr "output" } } } + { +scratch+ { { unboxed-alien "output" } } } { +output+ { "output" } } { +clobber+ { "offset" } } } define-intrinsic diff --git a/core/effects/effects.factor b/core/effects/effects.factor index 62d6afc393..d881184508 100644 --- a/core/effects/effects.factor +++ b/core/effects/effects.factor @@ -51,3 +51,18 @@ M: integer (stack-picture) drop "object" ; M: effect clone [ effect-in clone ] keep effect-out clone ; + +: split-shuffle ( stack shuffle -- stack1 stack2 ) + effect-in length swap cut* ; + +: load-shuffle ( stack shuffle -- ) + effect-in [ set ] 2each ; + +: shuffled-values ( shuffle -- values ) + effect-out [ get ] map ; + +: shuffle* ( stack shuffle -- newstack ) + [ [ load-shuffle ] keep shuffled-values ] with-scope ; + +: shuffle ( stack shuffle -- newstack ) + [ split-shuffle ] keep shuffle* append ; diff --git a/core/generator/generator.factor b/core/generator/generator.factor index fd82135651..5d233cd166 100644 --- a/core/generator/generator.factor +++ b/core/generator/generator.factor @@ -2,9 +2,9 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays assocs classes combinators cpu.architecture effects generator.fixup generator.registers generic hashtables -inference inference.backend inference.dataflow inference.stack -io kernel kernel.private layouts math namespaces optimizer -prettyprint quotations sequences system threads words ; +inference inference.backend inference.dataflow io kernel +kernel.private layouts math namespaces optimizer prettyprint +quotations sequences system threads words ; IN: generator SYMBOL: compiled-xts @@ -246,10 +246,8 @@ M: #dispatch generate-node : define-if-intrinsic ( word quot inputs -- ) 2array 1array define-if-intrinsics ; -: do-intrinsic ( pair -- ) first2 with-template ; - : do-if-intrinsic ( #call pair -- next ) -