From de7e596622427c02efa7728e798ec14b7b2732c2 Mon Sep 17 00:00:00 2001 From: "U-SLAVA-FB3999113\\Slava" Date: Sat, 13 Oct 2007 00:57:24 -0400 Subject: [PATCH 01/20] Fix trailing whitespace --- core/cpu/arm/architecture/architecture.factor | 2 +- core/cpu/arm/bootstrap.factor | 116 +- vm/cpu-arm.S | 129 +- vm/cpu-arm.h | 21 +- vm/errors.h | 6 + vm/os-unix.h | 6 - vm/os-windows-ce-arm.S | 11 +- vm/os-windows-ce.c | 16 +- vm/os-windows-ce.h | 6 +- vm/os-windows-nt.h | 8 +- vm/os-windows.c | 12 +- vm/os-windows.h | 3 - vm/run.s | 1117 +++++++++++++++++ 13 files changed, 1403 insertions(+), 50 deletions(-) mode change 100644 => 100755 core/cpu/arm/architecture/architecture.factor mode change 100644 => 100755 core/cpu/arm/bootstrap.factor mode change 100644 => 100755 vm/cpu-arm.S mode change 100644 => 100755 vm/cpu-arm.h mode change 100644 => 100755 vm/errors.h mode change 100644 => 100755 vm/os-unix.h mode change 100644 => 100755 vm/os-windows-ce-arm.S mode change 100644 => 100755 vm/os-windows-ce.c mode change 100644 => 100755 vm/os-windows-ce.h mode change 100644 => 100755 vm/os-windows-nt.h mode change 100644 => 100755 vm/os-windows.c mode change 100644 => 100755 vm/os-windows.h create mode 100644 vm/run.s diff --git a/core/cpu/arm/architecture/architecture.factor b/core/cpu/arm/architecture/architecture.factor old mode 100644 new mode 100755 index 5a4a2bda3f..411d8047c0 --- a/core/cpu/arm/architecture/architecture.factor +++ b/core/cpu/arm/architecture/architecture.factor @@ -22,7 +22,7 @@ M: temp-reg v>operand drop R12 ; M: int-regs return-reg drop R0 ; M: int-regs param-regs drop { R0 R1 R2 R3 } ; -M: int-regs vregs drop { R0 R1 R2 R3 } ; +M: int-regs vregs drop { R0 R1 R2 R3 R4 R7 R8 R9 R10 R11 } ; ! No FPU support yet M: float-regs param-regs drop { } ; diff --git a/core/cpu/arm/bootstrap.factor b/core/cpu/arm/bootstrap.factor old mode 100644 new mode 100755 index 3ef3ffcee5..c124de8162 --- a/core/cpu/arm/bootstrap.factor +++ b/core/cpu/arm/bootstrap.factor @@ -1,4 +1,118 @@ -USING: bootstrap.image.private kernel namespaces system ; +! Copyright (C) 2007 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: bootstrap.image.private kernel namespaces system +cpu.arm.assembler math math.functions layouts words vocabs ; +IN: bootstrap.arm 4 \ cell set big-endian off + +4 jit-code-format set + +: ds-reg R5 ; + +: word-reg R0 ; +: quot-reg R0 ; +: scan-reg R2 ; +: temp-reg R3 ; +: xt-reg R12 ; + +: lr-save bootstrap-cell ; + +: stack-frame 8 bootstrap-cells ; + +: next-save stack-frame bootstrap-cell - ; +: xt-save stack-frame 2 bootstrap-cells - ; +: array-save stack-frame 3 bootstrap-cells - ; +: scan-save stack-frame 4 bootstrap-cells - ; + +[ + temp-reg quot-reg quot-array@ <+> LDR ! load array + scan-reg temp-reg scan@ ADD ! initialize scan pointer +] { } make jit-setup set + +[ + SP SP stack-frame SUB + xt-reg SP xt-save <+> STR ! save XT + xt-reg stack-frame MOV + xt-reg SP next-save <+> STR ! save frame size + temp-reg SP array-save <+> STR ! save array + LR SP lr-save stack-frame + <+> STR ! save return address +] { } make jit-prolog set + +[ + temp-reg scan-reg 4 LDR ! load literal and advance + temp-reg ds-reg 4 STR ! push literal +] { } make jit-push-literal set + +[ + temp-reg scan-reg 4 LDR ! load wrapper and advance + temp-reg dup wrapper@ <+> LDR ! load wrapped object + temp-reg ds-reg 4 STR ! push wrapped object +] { } make jit-push-wrapper set + +[ + R1 SP MOV ! pass stack pointer to primitive +] { } make jit-word-primitive-jump set + +[ + R1 SP MOV ! pass stack pointer to primitive +] { } make jit-word-primitive-call set + +: load-word-xt ( -- ) + word-reg scan-reg 4 LDR ! load word and advance + xt-reg word-reg word-xt@ <+> LDR ; + +: jit-call + scan-reg SP scan-save <+> STR ! save scan pointer + LR PC MOV ! save return address + PC xt-reg MOV ! call + scan-reg SP scan-save <+> LDR ! restore scan pointer + ; + +: jit-jump + PC xt-reg MOV ; + +[ load-word-xt jit-call ] { } make jit-word-call set + +[ load-word-xt jit-jump ] { } make jit-word-jump set + +: load-quot-xt + xt-reg quot-reg quot-xt@ <+> LDR ; + +: load-branch + temp-reg ds-reg -4 <-!> LDR ! pop boolean + temp-reg \ f tag-number CMP ! compare it with f + scan-reg quot-reg MOV ! point quot-reg at false branch + quot-reg dup 4 NE ADD ! point quot-reg at true branch + quot-reg dup 4 <+> LDR ! load the branch + scan-reg dup 12 ADD ! advance scan pointer + load-quot-xt + ; + +[ + load-branch jit-jump +] { } make jit-if-jump set + +[ + load-branch jit-call +] { } make jit-if-call set + +[ + temp-reg ds-reg 4 <-!> LDR ! pop index + temp-reg dup 1 MOV ! turn it into an array offset + scan-reg dup 4 <+> LDR ! load array + temp-reg dup scan-reg ADD ! compute quotation location + quot-reg temp-reg array-start <+> LDR ! load quotation + load-quot-xt + jit-jump +] { } make jit-dispatch set + +[ + SP SP stack-frame ADD ! pop stack frame + LR SP lr-save stack-frame + <+> LDR ! load return address +] { } make jit-epilog set + +[ PC LR MOV ] { } make jit-return set + +"bootstrap.arm" forget-vocab diff --git a/vm/cpu-arm.S b/vm/cpu-arm.S old mode 100644 new mode 100755 index f609b1f40c..86255dd96b --- a/vm/cpu-arm.S +++ b/vm/cpu-arm.S @@ -1,8 +1,125 @@ #include "asm.h" -/* Callable from C as -void *native_stack_pointer(void) */ - .globl MANGLE(native_stack_pointer) -MANGLE(native_stack_pointer): - mov r0,sp - mov pc,lr +/* Note that the XT is passed to the quotation in r12 */ +#define CALL_QUOT \ + ldr r12,[r0, #9] /* load quotation-xt slot */ ; \ + mov pc,lr ; \ + mov r11,pc + +#define JUMP_QUOT \ + ldr pc,[r0, #9] /* load quotation-xt slot */ + +#define SAVED_REGS_SIZE 32 + +#define FRAME (RESERVED_SIZE + SAVED_REGS_SIZE + 8) + +#define LR_SAVE [sp, #4] +#define RESERVED_SIZE 8 + +#define SAVE_LR str lr,LR_SAVE + +#define LOAD_LR ldr lr,LR_SAVE + +#define SAVE_AT(offset) (RESERVED_SIZE + 4 * offset) + +#define SAVE(register,offset) str register,[sp, #SAVE_AT(offset)] + +#define RESTORE(register,offset) ldr register,[sp, #SAVE_AT(offset)] + +#define PROLOGUE \ + sub sp,sp,#FRAME ; \ + SAVE_LR + +#define EPILOGUE \ + LOAD_LR ; \ + sub sp,sp,#FRAME + +DEF(void,c_to_factor,(CELL quot)): + PROLOGUE + + SAVE(r4,0) /* save GPRs */ + /* don't save ds pointer */ + /* don't save rs pointer */ + SAVE(r7,3) + SAVE(r8,4) + SAVE(r9,5) + SAVE(r10,6) + SAVE(r11,7) + SAVE(r0,8) /* save quotation since we're about to mangle it */ + + mov sp,r1 /* pass call stack pointer as an argument */ + bl MANGLE(save_callstack_bottom) + + RESTORE(r0,8) /* restore quotation */ + CALL_QUOT + + RESTORE(r11,7) /* restore GPRs */ + RESTORE(r10,6) + RESTORE(r9,5) + RESTORE(r8,4) + RESTORE(r7,3) + /* don't restore rs pointer */ + /* don't restore ds pointer */ + RESTORE(r4,0) + + EPILOGUE + mov lr,pc + +/* The JIT compiles an 'mov sp,r1' in front of every primitive call, since a +word which was defined as a primitive will not change its definition for the +lifetime of the image -- adding new primitives requires a bootstrap. However, +an undefined word can certainly become defined, + +DEFER: foo +... +: foo ... ; + +And calls to non-primitives do not have this one-instruction prologue, so we +set the XT of undefined words to this symbol. */ +DEF(void,undefined,(CELL word)): + mov sp,r1 + b MANGLE(undefined_error) + +DEF(void,dosym,(CELL word)): + str r0,[r5], #4 /* push word to stack */ + mov lr,pc /* return */ + +/* Here we have two entry points. The first one is taken when profiling is +enabled */ +DEF(void,docol_profiling,(CELL word)): + ldr r1,[r0, #25] /* load profile-count slot */ + add r1,r1,#8 /* increment count */ + str r1,[r0, #25] /* store profile-count slot */ +DEF(void,docol,(CELL word)): + ldr r0,[r0, #13] /* load word-def slot */ + JUMP_QUOT + +/* We must pass the XT to the quotation in r11. */ +DEF(void,primitive_call,(void)): + ldr r0,[r5, #-4]! /* load quotation from data stack */ + JUMP_QUOT + +/* We must preserve r1 here in case we're calling a primitive */ +DEF(void,primitive_execute,(void)): + ldr r0,[r5, #-4]! /* load word from data stack */ + ldr pc,[r0, #29] /* jump to word-xt */ + +DEF(void,set_callstack,(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length)): + sub sp,r0,r2 /* compute new stack pointer */ + mov r0,r1 /* start of destination of memcpy() */ + str sp,[sp, #-64] /* setup fake stack frame for memcpy() */ + bl MANGLE(memcpy) /* go */ + ldr sp,[sp] /* tear down fake stack frame */ + ldr pc,LR_SAVE /* return */ + +DEF(void,throw_impl,(CELL quot, F_STACK_FRAME *rewind_to)): + mov r1,sp /* compute new stack pointer */ + ldr lr,LR_SAVE /* we have rewound the stack; load return address */ + JUMP_QUOT /* call the quotation */ + +DEF(void,lazy_jit_compile,(CELL quot)): + mov sp,r1 /* save stack pointer */ + PROLOGUE + bl MANGLE(primitive_jit_compile) + EPILOGUE + JUMP_QUOT /* call the quotation */ diff --git a/vm/cpu-arm.h b/vm/cpu-arm.h old mode 100644 new mode 100755 index ae8b4e5a8d..cdb66ff0ef --- a/vm/cpu-arm.h +++ b/vm/cpu-arm.h @@ -2,16 +2,17 @@ register CELL ds asm("r5"); register CELL rs asm("r6"); -register void **primitives asm("r7"); -void *native_stack_pointer(void); +#define F_FASTCALL -typedef CELL F_COMPILED_FRAME; +void c_to_factor(CELL quot); +void dosym(CELL word); +void docol_profiling(CELL word); +void docol(CELL word); +void undefined(CELL word); +void set_callstack(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, void *memcpy); +void throw_impl(CELL quot, F_STACK_FRAME *rewind); +void lazy_jit_compile(CELL quot); +void flush_icache(CELL start, CELL len); -#define PREVIOUS_FRAME(frame) (frame + 1) -#define RETURN_ADDRESS(frame) (*(frame)) - -INLINE void execute(CELL word) -{ - untag_object(word)->xt(word); -} +#define FRAME_RETURN_ADDRESS(frame) *((XT *)(frame_successor(frame) + 1) + 1) diff --git a/vm/errors.h b/vm/errors.h old mode 100644 new mode 100755 index 5295197f40..cbb8bed016 --- a/vm/errors.h +++ b/vm/errors.h @@ -41,3 +41,9 @@ INLINE void type_check(CELL type, CELL tagged) { if(type_of(tagged) != type) type_error(type,tagged); } + +/* Global variables used to pass fault handler state from signal handler to +user-space */ +CELL signal_number; +CELL signal_fault_addr; +void *signal_callstack_top; diff --git a/vm/os-unix.h b/vm/os-unix.h old mode 100644 new mode 100755 index c1239bb83c..f5dcf8dda5 --- a/vm/os-unix.h +++ b/vm/os-unix.h @@ -40,11 +40,5 @@ void sleep_millis(CELL msec); void reset_stdio(void); -/* Global variables used to pass fault handler state from signal handler to -user-space */ -CELL signal_number; -CELL signal_fault_addr; -void *signal_callstack_top; - void memory_signal_handler_impl(void); void misc_signal_handler_impl(void); diff --git a/vm/os-windows-ce-arm.S b/vm/os-windows-ce-arm.S old mode 100644 new mode 100755 index 9e9ed2ae37..b8b1d41d6c --- a/vm/os-windows-ce-arm.S +++ b/vm/os-windows-ce-arm.S @@ -2,17 +2,18 @@ .globl run_toplevel - .word exception_handler + .word exception_handler .word 0 -run_toplevel: - ldr pc, _Prun +c_to_factor_toplevel: + ldr pc, _Pc_to_factor -_Prun: .word run +_Pc_to_factor: + .word c_to_factor .section .pdata - .word run_toplevel + .word c_to_factor_toplevel .word 0xc0000002 | (0xFFFFF << 8) diff --git a/vm/os-windows-ce.c b/vm/os-windows-ce.c old mode 100644 new mode 100755 index 1d6547dc4b..9ebbd8fe7a --- a/vm/os-windows-ce.c +++ b/vm/os-windows-ce.c @@ -23,10 +23,10 @@ DEFINE_PRIMITIVE(cd) char *strerror(int err) { /* strerror() is not defined on WinCE */ - return "strerror() is not defined on WinCE. Use native io"; + return "strerror() is not defined on WinCE. Use native I/O."; } -void flush_icache() +void flush_icache(CELL start, CELL end) { FlushInstructionCache(GetCurrentProcess(), 0, 0); } @@ -37,10 +37,14 @@ char *getenv(char *name) return 0; /* unreachable */ } + + long exception_handler(PEXCEPTION_RECORD rec, void *frame, void *ctx, void *dispatch) { - memory_protection_error( - rec->ExceptionInformation[1] & 0x1ffffff, - native_stack_pointer()); - return -1; /* unreachable */ + return 0; +} + +void c_to_factor_toplevel(CELL quot) +{ + c_to_factor(quot); } diff --git a/vm/os-windows-ce.h b/vm/os-windows-ce.h old mode 100644 new mode 100755 index 10103593f8..f73fb0a08c --- a/vm/os-windows-ce.h +++ b/vm/os-windows-ce.h @@ -2,6 +2,7 @@ #define UNICODE #endif +#include #include typedef wchar_t F_SYMBOL; @@ -23,7 +24,4 @@ char *getenv(char *name); #define EINTR 0 s64 current_millis(void); - -DECLARE_PRIMITIVE(cwd); -DECLARE_PRIMITIVE(cd); - +void c_to_factor_toplevel(CELL quot); diff --git a/vm/os-windows-nt.h b/vm/os-windows-nt.h old mode 100644 new mode 100755 index f3017b0cbe..452e42448b --- a/vm/os-windows-nt.h +++ b/vm/os-windows-nt.h @@ -5,6 +5,8 @@ #define UNICODE #endif +#include + typedef char F_SYMBOL; #define unbox_symbol_string unbox_char_string @@ -16,10 +18,8 @@ typedef char F_SYMBOL; void c_to_factor_toplevel(CELL quot); -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); + +long exception_handler(PEXCEPTION_POINTERS pe); diff --git a/vm/os-windows.c b/vm/os-windows.c old mode 100644 new mode 100755 index 1be3e2a2af..6e39422134 --- a/vm/os-windows.c +++ b/vm/os-windows.c @@ -1,6 +1,6 @@ #include "master.h" -F_STRING *get_error_message() +F_STRING *get_error_message(void) { DWORD id = GetLastError(); F_CHAR *msg = error_message(id); @@ -36,7 +36,7 @@ F_CHAR *error_message(DWORD id) HMODULE hFactorDll; -void init_ffi() +void init_ffi(void) { hFactorDll = GetModuleHandle(FACTOR_DLL); if(!hFactorDll) @@ -120,8 +120,12 @@ DEFINE_PRIMITIVE(stat) dpush(tag_fixnum(0)); box_unsigned_8( (u64)st.nFileSizeLow | (u64)st.nFileSizeHigh << 32); - box_unsigned_8( - ((*(u64*)&st.ftLastWriteTime - EPOCH_OFFSET) / 10000000)); + + u64 lo = st.ftLastWriteTime.dwLowDateTime; + u64 hi = st.ftLastWriteTime.dwHighDateTime; + u64 modTime = (hi << 32) + lo; + + box_unsigned_8((modTime - EPOCH_OFFSET) / 10000000); FindClose(h); } } diff --git a/vm/os-windows.h b/vm/os-windows.h old mode 100644 new mode 100755 index ed9b87aa93..f252c214af --- a/vm/os-windows.h +++ b/vm/os-windows.h @@ -1,4 +1,3 @@ -#include #include #ifndef wcslen @@ -49,5 +48,3 @@ s64 current_millis(void); INLINE void reset_stdio(void) {} -long exception_handler(PEXCEPTION_POINTERS pe); - diff --git a/vm/run.s b/vm/run.s new file mode 100644 index 0000000000..8700b6cce8 --- /dev/null +++ b/vm/run.s @@ -0,0 +1,1117 @@ + .file "run.c" + .text + .align 0 + .global reset_datastack + .def reset_datastack; .scl 2; .type 32; .endef +reset_datastack: + @ args = 0, pretend = 0, frame = 0 + @ frame_needed = 0, uses_anonymous_args = 0 + @ link register save eliminated. + ldr r3, .L3 + @ lr needed for prologue + ldr r2, [r3, #0] + ldr r1, [r2, #24] + ldr r3, [r1, #0] + sub r5, r3, #4 + mov pc, lr +.L4: + .align 0 +.L3: + .word stack_chain + .align 0 + .global reset_retainstack + .def reset_retainstack; .scl 2; .type 32; .endef +reset_retainstack: + @ args = 0, pretend = 0, frame = 0 + @ frame_needed = 0, uses_anonymous_args = 0 + @ link register save eliminated. + ldr r3, .L7 + @ lr needed for prologue + ldr r2, [r3, #0] + ldr r1, [r2, #28] + ldr r3, [r1, #0] + sub r6, r3, #4 + mov pc, lr +.L8: + .align 0 +.L7: + .word stack_chain + .align 0 + .global save_stacks + .def save_stacks; .scl 2; .type 32; .endef +save_stacks: + @ args = 0, pretend = 0, frame = 0 + @ frame_needed = 0, uses_anonymous_args = 0 + @ link register save eliminated. + ldr r3, .L11 + @ lr needed for prologue + ldr r2, [r3, #0] + str r6, [r2, #12] + str r5, [r2, #8] + mov pc, lr +.L12: + .align 0 +.L11: + .word stack_chain + .align 0 + .global init_stacks + .def init_stacks; .scl 2; .type 32; .endef +init_stacks: + @ args = 0, pretend = 0, frame = 0 + @ frame_needed = 0, uses_anonymous_args = 0 + @ link register save eliminated. + ldr r3, .L15 + ldr r2, .L15+4 + str r0, [r3, #0] + ldr r3, .L15+8 + str r1, [r2, #0] + mov r1, #0 + @ lr needed for prologue + str r1, [r3, #0] + mov pc, lr +.L16: + .align 0 +.L15: + .word ds_size + .word rs_size + .word stack_chain + .align 0 + .global enable_word_profiling + .def enable_word_profiling; .scl 2; .type 32; .endef +enable_word_profiling: + @ args = 0, pretend = 0, frame = 0 + @ frame_needed = 0, uses_anonymous_args = 0 + @ link register save eliminated. + ldr r3, .L21 + ldr r2, [r0, #32] + @ lr needed for prologue + cmp r2, r3 + ldreq r3, .L21+4 + streq r3, [r0, #32] + mov pc, lr +.L22: + .align 0 +.L21: + .word docol + .word docol_profiling + .align 0 + .global disable_word_profiling + .def disable_word_profiling; .scl 2; .type 32; .endef +disable_word_profiling: + @ args = 0, pretend = 0, frame = 0 + @ frame_needed = 0, uses_anonymous_args = 0 + @ link register save eliminated. + ldr r3, .L27 + ldr r2, [r0, #32] + @ lr needed for prologue + cmp r2, r3 + ldreq r3, .L27+4 + streq r3, [r0, #32] + mov pc, lr +.L28: + .align 0 +.L27: + .word docol_profiling + .word docol + .align 0 + .global primitive_3drop + .def primitive_3drop; .scl 2; .type 32; .endef +primitive_3drop: + @ args = 0, pretend = 0, frame = 0 + @ frame_needed = 0, uses_anonymous_args = 0 + str lr, [sp, #-4]! + mov r0, r1 + bl save_callstack_top + sub r5, r5, #12 + ldr pc, [sp], #4 + .align 0 + .global primitive_2drop + .def primitive_2drop; .scl 2; .type 32; .endef +primitive_2drop: + @ args = 0, pretend = 0, frame = 0 + @ frame_needed = 0, uses_anonymous_args = 0 + str lr, [sp, #-4]! + mov r0, r1 + bl save_callstack_top + sub r5, r5, #8 + ldr pc, [sp], #4 + .align 0 + .global primitive_millis + .def primitive_millis; .scl 2; .type 32; .endef +primitive_millis: + @ args = 0, pretend = 0, frame = 0 + @ frame_needed = 0, uses_anonymous_args = 0 + str lr, [sp, #-4]! + mov r0, r1 + bl save_callstack_top + bl current_millis + ldr lr, [sp], #4 + b box_unsigned_8 + .align 0 + .global array_to_stack + .def array_to_stack; .scl 2; .type 32; .endef +array_to_stack: + @ args = 0, pretend = 0, frame = 0 + @ frame_needed = 0, uses_anonymous_args = 0 + stmfd sp!, {r4, r7, lr} + ldr r4, [r0, #4] + mov r7, r1 + mov r4, r4, lsr #3 + mov r4, r4, asl #2 + add r1, r0, #8 + mov r2, r4 + mov r0, r7 + bl memcpy + add r4, r4, r7 + sub r0, r4, #4 + ldmfd sp!, {r4, r7, pc} + .align 0 + .global unnest_stacks + .def unnest_stacks; .scl 2; .type 32; .endef +unnest_stacks: + @ args = 0, pretend = 0, frame = 0 + @ frame_needed = 0, uses_anonymous_args = 0 + stmfd sp!, {r4, lr} + ldr r4, .L39 + ldr r3, [r4, #0] + ldr r0, [r3, #24] + bl dealloc_segment + ldr r3, [r4, #0] + ldr r0, [r3, #28] + bl dealloc_segment + ldr r0, [r4, #0] + ldr r1, .L39+4 + ldr r2, [r0, #36] + ldr r5, [r0, #16] + ldr r6, [r0, #20] + str r2, [r1, #8] + ldr r3, [r0, #32] + str r3, [r1, #4] + ldr r2, [r0, #40] + ldr r1, [r0, #44] + ldr r3, .L39+8 + str r1, [r4, #0] + str r2, [r3, #0] + ldmfd sp!, {r4, lr} + b free +.L40: + .align 0 +.L39: + .word stack_chain + .word userenv + .word extra_roots + .align 0 + .global primitive_drop + .def primitive_drop; .scl 2; .type 32; .endef +primitive_drop: + @ args = 0, pretend = 0, frame = 0 + @ frame_needed = 0, uses_anonymous_args = 0 + str lr, [sp, #-4]! + mov r0, r1 + bl save_callstack_top + sub r5, r5, #4 + ldr pc, [sp], #4 + .align 0 + .global primitive_swapd + .def primitive_swapd; .scl 2; .type 32; .endef +primitive_swapd: + @ args = 0, pretend = 0, frame = 0 + @ frame_needed = 0, uses_anonymous_args = 0 + mov r0, r1 + str lr, [sp, #-4]! + bl save_callstack_top + ldr r1, [r5, #-4] + ldr r2, [r5, #-8] + stmdb r5, {r1, r2} @ phole stm + ldr pc, [sp], #4 + .align 0 + .global primitive_swap + .def primitive_swap; .scl 2; .type 32; .endef +primitive_swap: + @ args = 0, pretend = 0, frame = 0 + @ frame_needed = 0, uses_anonymous_args = 0 + mov r0, r1 + str lr, [sp, #-4]! + bl save_callstack_top + ldr r1, [r5, #0] + ldr r2, [r5, #-4] + stmda r5, {r1, r2} @ phole stm + ldr pc, [sp], #4 + .align 0 + .global primitive__rot + .def primitive__rot; .scl 2; .type 32; .endef +primitive__rot: + @ args = 0, pretend = 0, frame = 0 + @ frame_needed = 0, uses_anonymous_args = 0 + mov r0, r1 + str lr, [sp, #-4]! + bl save_callstack_top + ldr r0, [r5, #0] + ldmdb r5, {r1, r2} @ phole ldm + stmda r5, {r0, r1, r2} @ phole stm + ldr pc, [sp], #4 + .align 0 + .global primitive_rot + .def primitive_rot; .scl 2; .type 32; .endef +primitive_rot: + @ args = 0, pretend = 0, frame = 0 + @ frame_needed = 0, uses_anonymous_args = 0 + mov r0, r1 + str lr, [sp, #-4]! + bl save_callstack_top + ldr r0, [r5, #0] + ldr r2, [r5, #-8] + ldr r1, [r5, #-4] + stmda r5, {r0, r2} @ phole stm + str r1, [r5, #-8] + ldr pc, [sp], #4 + .align 0 + .global primitive_3dup + .def primitive_3dup; .scl 2; .type 32; .endef +primitive_3dup: + @ args = 0, pretend = 0, frame = 0 + @ frame_needed = 0, uses_anonymous_args = 0 + mov r0, r1 + str lr, [sp, #-4]! + bl save_callstack_top + ldmda r5, {r0, r1, r2} @ phole ldm + mov r3, r5 + add r5, r5, #12 + str r2, [r3, #12] + stmdb r5, {r0, r1} @ phole stm + ldr pc, [sp], #4 + .align 0 + .global primitive_2dup + .def primitive_2dup; .scl 2; .type 32; .endef +primitive_2dup: + @ args = 0, pretend = 0, frame = 0 + @ frame_needed = 0, uses_anonymous_args = 0 + mov r0, r1 + str lr, [sp, #-4]! + bl save_callstack_top + ldr r0, [r5, #0] + ldr r2, [r5, #-4] + add r1, r5, #8 + mov r5, r1 + str r2, [r5, #-4] + str r0, [r5, #0] + ldr pc, [sp], #4 + .align 0 + .global primitive_sleep + .def primitive_sleep; .scl 2; .type 32; .endef +primitive_sleep: + @ args = 0, pretend = 0, frame = 0 + @ frame_needed = 0, uses_anonymous_args = 0 + mov r0, r1 + str lr, [sp, #-4]! + bl save_callstack_top + mov r3, r5 + ldr r0, [r3], #-4 + mov r5, r3 + bl to_cell + ldr lr, [sp], #4 + b sleep_millis + .align 0 + .global primitive_exit + .def primitive_exit; .scl 2; .type 32; .endef +primitive_exit: + @ args = 0, pretend = 0, frame = 0 + @ frame_needed = 0, uses_anonymous_args = 0 + mov r0, r1 + str lr, [sp, #-4]! + bl save_callstack_top + mov r3, r5 + ldr r0, [r3], #-4 + mov r5, r3 + bl to_fixnum + bl exit + .align 0 + .global primitive_to_r + .def primitive_to_r; .scl 2; .type 32; .endef +primitive_to_r: + @ args = 0, pretend = 0, frame = 0 + @ frame_needed = 0, uses_anonymous_args = 0 + mov r0, r1 + str lr, [sp, #-4]! + bl save_callstack_top + mov r3, r5 + ldr r1, [r3], #-4 + add r2, r6, #4 + mov r6, r2 + mov r5, r3 + str r1, [r6, #0] + ldr pc, [sp], #4 + .align 0 + .global primitive_eq + .def primitive_eq; .scl 2; .type 32; .endef +primitive_eq: + @ args = 0, pretend = 0, frame = 0 + @ frame_needed = 0, uses_anonymous_args = 0 + mov r0, r1 + str lr, [sp, #-4]! + bl save_callstack_top + mov r0, r5 + ldr r1, [r5, #-4] + ldr r2, [r0], #-4 + mov r3, #7 + cmp r2, r1 + ldreq r3, .L66 + mov r5, r0 + ldreq r3, [r3, #0] + str r3, [r0, #0] + ldr pc, [sp], #4 +.L67: + .align 0 +.L66: + .word T + .align 0 + .global primitive_getenv + .def primitive_getenv; .scl 2; .type 32; .endef +primitive_getenv: + @ args = 0, pretend = 0, frame = 0 + @ frame_needed = 0, uses_anonymous_args = 0 + mov r0, r1 + str lr, [sp, #-4]! + bl save_callstack_top + ldr r3, [r5, #0] + ldr r2, .L70 + mov r3, r3, asr #3 + ldr r1, [r2, r3, asl #2] + str r1, [r5, #0] + ldr pc, [sp], #4 +.L71: + .align 0 +.L70: + .word userenv + .align 0 + .global primitive_2nip + .def primitive_2nip; .scl 2; .type 32; .endef +primitive_2nip: + @ args = 0, pretend = 0, frame = 0 + @ frame_needed = 0, uses_anonymous_args = 0 + str lr, [sp, #-4]! + mov r0, r1 + bl save_callstack_top + ldr r2, [r5, #0] + mov r3, r5 + sub r5, r5, #8 + str r2, [r3, #-8] + ldr pc, [sp], #4 + .align 0 + .global primitive_nip + .def primitive_nip; .scl 2; .type 32; .endef +primitive_nip: + @ args = 0, pretend = 0, frame = 0 + @ frame_needed = 0, uses_anonymous_args = 0 + mov r0, r1 + str lr, [sp, #-4]! + bl save_callstack_top + mov r2, r5 + ldr r1, [r2], #-4 + str r1, [r5, #-4] + mov r5, r2 + ldr pc, [sp], #4 + .align 0 + .global primitive_os_env + .def primitive_os_env; .scl 2; .type 32; .endef +primitive_os_env: + @ args = 0, pretend = 0, frame = 0 + @ frame_needed = 0, uses_anonymous_args = 0 + str lr, [sp, #-4]! + mov r0, r1 + bl save_callstack_top + bl unbox_char_string + bl getenv + add r3, r5, #4 + cmp r0, #0 + moveq r5, r3 + moveq r3, #7 + streq r3, [r5, #0] + ldreq pc, [sp], #4 + ldr lr, [sp], #4 + b box_char_string + .align 0 + .global stack_to_array + .def stack_to_array; .scl 2; .type 32; .endef +stack_to_array: + @ args = 0, pretend = 0, frame = 0 + @ frame_needed = 0, uses_anonymous_args = 0 + stmfd sp!, {r4, r7, r8, lr} + mov r8, r0 + rsb r1, r8, r1 + adds r7, r1, #4 + mov r0, #8 + mov r1, r7, asr #2 + mov r3, #0 + bmi .L85 + bl allot_array_internal + mov r1, r8 + mov r4, r0 + mov r2, r7 + add r0, r0, #8 + bl memcpy + bic r4, r4, #7 + add r3, r5, #4 + mov r5, r3 + orr r4, r4, #3 + str r4, [r5, #0] + mov r3, #1 +.L85: + mov r0, r3 + ldmfd sp!, {r4, r7, r8, pc} + .align 0 + .global primitive_from_r + .def primitive_from_r; .scl 2; .type 32; .endef +primitive_from_r: + @ args = 0, pretend = 0, frame = 0 + @ frame_needed = 0, uses_anonymous_args = 0 + mov r0, r1 + str lr, [sp, #-4]! + bl save_callstack_top + mov r3, r6 + ldr r1, [r3], #-4 + add r2, r5, #4 + mov r5, r2 + mov r6, r3 + str r1, [r5, #0] + ldr pc, [sp], #4 + .align 0 + .global primitive_pick + .def primitive_pick; .scl 2; .type 32; .endef +primitive_pick: + @ args = 0, pretend = 0, frame = 0 + @ frame_needed = 0, uses_anonymous_args = 0 + str lr, [sp, #-4]! + mov r0, r1 + bl save_callstack_top + ldr r2, [r5, #-8] + mov r3, r5 + add r5, r5, #4 + str r2, [r3, #4] + ldr pc, [sp], #4 + .align 0 + .global primitive_over + .def primitive_over; .scl 2; .type 32; .endef +primitive_over: + @ args = 0, pretend = 0, frame = 0 + @ frame_needed = 0, uses_anonymous_args = 0 + str lr, [sp, #-4]! + mov r0, r1 + bl save_callstack_top + ldr r2, [r5, #-4] + mov r3, r5 + add r5, r5, #4 + str r2, [r3, #4] + ldr pc, [sp], #4 + .align 0 + .global primitive_tuck + .def primitive_tuck; .scl 2; .type 32; .endef +primitive_tuck: + @ args = 0, pretend = 0, frame = 0 + @ frame_needed = 0, uses_anonymous_args = 0 + mov r0, r1 + str lr, [sp, #-4]! + bl save_callstack_top + ldr r0, [r5, #0] + ldr r2, [r5, #-4] + add r1, r5, #4 + mov r3, r5 + mov r5, r1 + stmda r3, {r0, r2} @ phole stm + str r0, [r5, #0] + ldr pc, [sp], #4 + .align 0 + .global primitive_dupd + .def primitive_dupd; .scl 2; .type 32; .endef +primitive_dupd: + @ args = 0, pretend = 0, frame = 0 + @ frame_needed = 0, uses_anonymous_args = 0 + mov r0, r1 + str lr, [sp, #-4]! + bl save_callstack_top + ldr r0, [r5, #0] + ldr r2, [r5, #-4] + add r1, r5, #4 + mov r3, r5 + mov r5, r1 + str r2, [r3, #0] + str r0, [r5, #0] + ldr pc, [sp], #4 + .align 0 + .global primitive_dup + .def primitive_dup; .scl 2; .type 32; .endef +primitive_dup: + @ args = 0, pretend = 0, frame = 0 + @ frame_needed = 0, uses_anonymous_args = 0 + mov r0, r1 + str lr, [sp, #-4]! + bl save_callstack_top + mov r2, r5 + ldr r1, [r2], #4 + str r1, [r5, #4] + mov r5, r2 + ldr pc, [sp], #4 + .align 0 + .global primitive_set_slot + .def primitive_set_slot; .scl 2; .type 32; .endef +primitive_set_slot: + @ args = 0, pretend = 0, frame = 0 + @ frame_needed = 0, uses_anonymous_args = 0 + mov r0, r1 + str lr, [sp, #-4]! + bl save_callstack_top + mov r0, r5 + ldr r1, [r0], #-4 + ldr ip, [r5, #-4] + ldr lr, [r0, #-4] + mov r1, r1, asr #3 + bic r3, ip, #7 + ldr r2, .L101 + str lr, [r3, r1, asl #2] + ldr r1, [r2, #0] + sub lr, r0, #4 + ldrb r3, [r1, ip, lsr #6] @ zero_extendqisi2 + mov r5, r0 + mvn r3, r3, asl #26 + mvn r3, r3, lsr #26 + mov r5, lr + sub r5, lr, #4 + strb r3, [r1, ip, lsr #6] + ldr pc, [sp], #4 +.L102: + .align 0 +.L101: + .word cards_offset + .align 0 + .global primitive_slot + .def primitive_slot; .scl 2; .type 32; .endef +primitive_slot: + @ args = 0, pretend = 0, frame = 0 + @ frame_needed = 0, uses_anonymous_args = 0 + mov r0, r1 + str lr, [sp, #-4]! + bl save_callstack_top + mov r1, r5 + ldr r2, [r1], #-4 + ldr r3, [r5, #-4] + mov r2, r2, asr #3 + bic r3, r3, #7 + ldr ip, [r3, r2, asl #2] + mov r0, r5 + mov r5, r1 + sub r5, r1, #4 + mov r5, r1 + str ip, [r0, #-4] + ldr pc, [sp], #4 + .align 0 + .global primitive_setenv + .def primitive_setenv; .scl 2; .type 32; .endef +primitive_setenv: + @ args = 0, pretend = 0, frame = 0 + @ frame_needed = 0, uses_anonymous_args = 0 + mov r0, r1 + str lr, [sp, #-4]! + bl save_callstack_top + mov r1, r5 + ldr r3, [r1], #-4 + ldr r0, [r5, #-4] + ldr r2, .L107 + mov r3, r3, asr #3 + mov r5, r1 + sub r5, r1, #4 + str r0, [r2, r3, asl #2] + ldr pc, [sp], #4 +.L108: + .align 0 +.L107: + .word userenv + .align 0 + .global primitive_class_hash + .def primitive_class_hash; .scl 2; .type 32; .endef +primitive_class_hash: + @ args = 0, pretend = 0, frame = 0 + @ frame_needed = 0, uses_anonymous_args = 0 + mov r0, r1 + str lr, [sp, #-4]! + bl save_callstack_top + ldr r3, [r5, #0] + and r2, r3, #7 + cmp r2, #2 + bic r0, r3, #7 + beq .L116 + cmp r2, #3 + bic r3, r3, #7 + ldreq r3, [r3, #0] + mov r0, r2, asl #3 + streq r3, [r5, #0] + strne r0, [r5, #0] + ldr pc, [sp], #4 +.L116: + ldr r3, [r0, #8] + bic r3, r3, #7 + ldr r2, [r3, #4] + str r2, [r5, #0] + ldr pc, [sp], #4 + .align 0 + .global primitive_tag + .def primitive_tag; .scl 2; .type 32; .endef +primitive_tag: + @ args = 0, pretend = 0, frame = 0 + @ frame_needed = 0, uses_anonymous_args = 0 + str lr, [sp, #-4]! + mov r0, r1 + bl save_callstack_top + ldr r3, [r5, #0] + and r3, r3, #7 + mov r3, r3, asl #3 + str r3, [r5, #0] + ldr pc, [sp], #4 + .align 0 + .global nest_stacks + .def nest_stacks; .scl 2; .type 32; .endef +nest_stacks: + @ args = 0, pretend = 0, frame = 0 + @ frame_needed = 0, uses_anonymous_args = 0 + stmfd sp!, {r4, lr} + mov r0, #48 + bl safe_malloc + mov r4, r0 + ldr r0, .L121 + str r5, [r4, #16] + str r6, [r4, #20] + ldr r3, [r0, #8] + mvn r2, #0 + str r3, [r4, #36] + ldr r1, [r0, #4] + ldr r3, .L121+4 + str r1, [r4, #32] + str r2, [r4, #0] + str r2, [r4, #4] + ldr r0, [r3, #0] + bl alloc_segment + ldr r3, .L121+8 + str r0, [r4, #24] + ldr r0, [r3, #0] + bl alloc_segment + ldr r3, .L121+12 + ldr ip, [r4, #24] + ldr r2, [r3, #0] + ldr r1, .L121+16 + str r2, [r4, #40] + ldr lr, [ip, #0] + ldr r2, [r0, #0] + ldr r3, [r1, #0] + sub r5, lr, #4 + sub r6, r2, #4 + str r3, [r4, #44] + str r0, [r4, #28] + str r4, [r1, #0] + ldmfd sp!, {r4, pc} +.L122: + .align 0 +.L121: + .word userenv + .word ds_size + .word rs_size + .word extra_roots + .word stack_chain + .align 0 + .global fix_stacks + .def fix_stacks; .scl 2; .type 32; .endef +fix_stacks: + @ args = 0, pretend = 0, frame = 0 + @ frame_needed = 0, uses_anonymous_args = 0 + ldr r2, .L131 + add r3, r5, #4 + ldr r2, [r2, #0] + stmfd sp!, {r4, lr} + ldr r0, [r2, #24] + add r4, r6, #256 + ldr ip, [r0, #0] + add lr, r5, #256 + cmp r3, ip + add r1, r6, #4 + bcc .L124 + ldr r3, [r0, #8] + cmp lr, r3 + bcs .L124 +.L126: + ldr r2, [r2, #28] + ldr r0, [r2, #0] + cmp r1, r0 + bcc .L127 + ldr r3, [r2, #8] + cmp r4, r3 + ldmccfd sp!, {r4, pc} +.L127: + sub r6, r0, #4 + ldmfd sp!, {r4, pc} +.L124: + sub r5, ip, #4 + b .L126 +.L132: + .align 0 +.L131: + .word stack_chain + .align 0 + .global primitive_type + .def primitive_type; .scl 2; .type 32; .endef +primitive_type: + @ args = 0, pretend = 0, frame = 0 + @ frame_needed = 0, uses_anonymous_args = 0 + mov r0, r1 + str lr, [sp, #-4]! + bl save_callstack_top + ldr r3, [r5, #0] + bic r1, r3, #7 + and r3, r3, #7 + cmp r3, #3 + ldreq r3, [r1, #0] + moveq r3, r3, lsr #3 + mov r3, r3, asl #3 + str r3, [r5, #0] + ldr pc, [sp], #4 + .align 0 + .global default_word_xt + .def default_word_xt; .scl 2; .type 32; .endef +default_word_xt: + @ args = 0, pretend = 0, frame = 0 + @ frame_needed = 0, uses_anonymous_args = 0 + ldr r3, .L154 + ldr r0, [r0, #16] + ldr r2, [r3, #0] + str lr, [sp, #-4]! + cmp r0, r2 + ldreq r0, .L154+4 + ldreq pc, [sp], #4 + and r1, r0, #7 + cmp r1, #3 + biceq r3, r0, #7 + ldreq r2, [r3, #0] + movne r2, r1 + moveq r2, r2, lsr #3 + cmp r2, #14 + beq .L153 + cmp r1, #3 + biceq r3, r0, #7 + ldreq r2, [r3, #0] + moveq r1, r2, lsr #3 + cmp r1, #0 + ldrne r0, .L154+8 + ldrne pc, [sp], #4 + bl to_fixnum + ldr r3, .L154+12 + ldr r0, [r3, r0, asl #2] + ldr pc, [sp], #4 +.L153: + ldr r3, .L154+16 + ldr r2, .L154+20 + ldrb r1, [r3, #0] @ zero_extendqisi2 + ldr r3, .L154+24 + cmp r1, #0 + moveq r0, r2 + movne r0, r3 + ldr pc, [sp], #4 +.L155: + .align 0 +.L154: + .word T + .word dosym + .word undefined + .word primitives + .word profiling + .word docol + .word docol_profiling + .align 0 + .global primitive_profiling + .def primitive_profiling; .scl 2; .type 32; .endef +primitive_profiling: + @ args = 0, pretend = 0, frame = 0 + @ frame_needed = 0, uses_anonymous_args = 0 + stmfd sp!, {r4, r7, r8, lr} + mov r0, r1 + bl save_callstack_top + mov r3, r5 + ldr r0, [r3], #-4 + ldr r4, .L175 + mov r5, r3 + bl to_boolean + strb r0, [r4, #0] + bl begin_scan + ldr r8, .L175+4 + ldr r7, .L175+8 +.L173: + bl next_object + cmp r0, #7 + bic r2, r0, #7 + and r3, r0, #7 + beq .L174 +.L158: + cmp r3, #3 + ldreq r3, [r2, #0] + moveq r3, r3, lsr #3 + cmp r3, #17 + bne .L173 + ldrb r3, [r4, #0] @ zero_extendqisi2 + bic r2, r0, #7 + cmp r3, #0 + bic r0, r0, #7 + beq .L162 + ldr r3, [r2, #32] + cmp r3, r8 + streq r7, [r2, #32] + bl next_object + cmp r0, #7 + bic r2, r0, #7 + and r3, r0, #7 + bne .L158 +.L174: + ldr r3, .L175+12 + mov r2, #0 + strb r2, [r3, #0] + ldmfd sp!, {r4, r7, r8, pc} +.L162: + ldr r3, [r0, #32] + cmp r3, r7 + streq r8, [r0, #32] + b .L173 +.L176: + .align 0 +.L175: + .word profiling + .word docol + .word docol_profiling + .word gc_off + .align 0 + .global primitive_set_retainstack + .def primitive_set_retainstack; .scl 2; .type 32; .endef +primitive_set_retainstack: + @ args = 0, pretend = 0, frame = 0 + @ frame_needed = 0, uses_anonymous_args = 0 + mov r0, r1 + stmfd sp!, {r4, r7, lr} + bl save_callstack_top + mov r3, r5 + ldr r1, [r3], #-4 + mov r0, #8 + and r2, r1, #7 + cmp r2, #3 + bic r4, r1, #7 + mov r5, r3 + ldreq r3, [r4, #0] + moveq r2, r3, lsr #3 + cmp r2, #8 + blne type_error +.L181: + ldr r3, .L184 + ldr r7, [r4, #4] + ldr r2, [r3, #0] + add r1, r4, #8 + ldr r0, [r2, #28] + mov r7, r7, lsr #3 + ldr r4, [r0, #0] + mov r7, r7, asl #2 + mov r0, r4 + mov r2, r7 + bl memcpy + add r4, r4, r7 + sub r6, r4, #4 + ldmfd sp!, {r4, r7, pc} +.L185: + .align 0 +.L184: + .word stack_chain + .align 0 + .global primitive_set_datastack + .def primitive_set_datastack; .scl 2; .type 32; .endef +primitive_set_datastack: + @ args = 0, pretend = 0, frame = 0 + @ frame_needed = 0, uses_anonymous_args = 0 + mov r0, r1 + stmfd sp!, {r4, r7, lr} + bl save_callstack_top + mov r3, r5 + ldr r1, [r3], #-4 + mov r0, #8 + and r2, r1, #7 + cmp r2, #3 + bic r4, r1, #7 + mov r5, r3 + ldreq r3, [r4, #0] + moveq r2, r3, lsr #3 + cmp r2, #8 + blne type_error +.L190: + ldr r3, .L193 + ldr r7, [r4, #4] + ldr r2, [r3, #0] + add r1, r4, #8 + ldr r0, [r2, #24] + mov r7, r7, lsr #3 + ldr r4, [r0, #0] + mov r7, r7, asl #2 + mov r0, r4 + mov r2, r7 + bl memcpy + add r4, r4, r7 + sub r5, r4, #4 + ldmfd sp!, {r4, r7, pc} +.L194: + .align 0 +.L193: + .word stack_chain + .align 0 + .global primitive_retainstack + .def primitive_retainstack; .scl 2; .type 32; .endef +primitive_retainstack: + @ args = 0, pretend = 0, frame = 0 + @ frame_needed = 0, uses_anonymous_args = 0 + stmfd sp!, {r4, r7, r8, lr} + mov r0, r1 + bl save_callstack_top + ldr ip, .L200 + mov r1, #7 + ldr lr, [ip, #0] + mov r0, #8 + ldr r4, [lr, #28] + mov r2, r1 + ldr r8, [r4, #0] + mov r3, #0 + rsb ip, r8, r6 + adds r7, ip, #4 + bmi .L196 + mov r1, r7, asr #2 + bl allot_array_internal + mov r1, r8 + mov r4, r0 + mov r2, r7 + add r0, r0, #8 + bl memcpy + bic r4, r4, #7 + add r3, r5, #4 + mov r5, r3 + orr r4, r4, #3 + str r4, [r5, #0] + ldmfd sp!, {r4, r7, r8, pc} +.L196: + mov r0, #13 + ldmfd sp!, {r4, r7, r8, lr} + b general_error +.L201: + .align 0 +.L200: + .word stack_chain + .align 0 + .global primitive_datastack + .def primitive_datastack; .scl 2; .type 32; .endef +primitive_datastack: + @ args = 0, pretend = 0, frame = 0 + @ frame_needed = 0, uses_anonymous_args = 0 + stmfd sp!, {r4, r7, r8, lr} + mov r0, r1 + bl save_callstack_top + ldr ip, .L207 + mov r1, #7 + ldr lr, [ip, #0] + mov r0, #8 + ldr r4, [lr, #24] + mov r2, r1 + ldr r8, [r4, #0] + mov r3, #0 + rsb ip, r8, r5 + adds r7, ip, #4 + bmi .L203 + mov r1, r7, asr #2 + bl allot_array_internal + mov r1, r8 + mov r4, r0 + mov r2, r7 + add r0, r0, #8 + bl memcpy + bic r4, r4, #7 + add r3, r5, #4 + mov r5, r3 + orr r4, r4, #3 + str r4, [r5, #0] + ldmfd sp!, {r4, r7, r8, pc} +.L203: + mov r0, #11 + ldmfd sp!, {r4, r7, r8, lr} + b general_error +.L208: + .align 0 +.L207: + .word stack_chain + .comm errno, 4 @ 4 + .comm profiling, 4 @ 1 + .comm userenv, 160 @ 160 + .comm T, 4 @ 4 + .comm stack_chain, 4 @ 4 + .comm ds_size, 4 @ 4 + .comm rs_size, 4 @ 4 + .comm signal_number, 4 @ 4 + .comm signal_fault_addr, 4 @ 4 + .comm signal_callstack_top, 4 @ 4 + .comm secure_gc, 4 @ 1 + .comm data_heap, 4 @ 4 + .comm cards_offset, 4 @ 4 + .comm newspace, 4 @ 4 + .comm nursery, 4 @ 4 + .comm gc_time, 8 @ 8 + .comm minor_collections, 4 @ 4 + .comm cards_scanned, 4 @ 4 + .comm performing_gc, 4 @ 1 + .comm collecting_gen, 4 @ 4 + .comm collecting_code, 4 @ 1 + .comm collecting_aging_again, 4 @ 1 + .comm last_code_heap_scan, 4 @ 4 + .comm growing_data_heap, 4 @ 1 + .comm old_data_heap, 4 @ 4 + .comm gc_jmp, 44 @ 44 + .comm heap_scan_ptr, 4 @ 4 + .comm gc_off, 4 @ 1 + .comm extra_roots_region, 4 @ 4 + .comm extra_roots, 4 @ 4 + .comm bignum_zero, 4 @ 4 + .comm bignum_pos_one, 4 @ 4 + .comm bignum_neg_one, 4 @ 4 + .comm code_heap, 8 @ 8 + .comm data_relocation_base, 4 @ 4 + .comm code_relocation_base, 4 @ 4 + .comm posix_argc, 4 @ 4 + .comm posix_argv, 4 @ 4 + .def memcpy; .scl 2; .type 32; .endef + .def type_error; .scl 2; .type 32; .endef + .def safe_malloc; .scl 2; .type 32; .endef + .def alloc_segment; .scl 2; .type 32; .endef + .def dealloc_segment; .scl 2; .type 32; .endef + .def free; .scl 2; .type 32; .endef + .def allot_array_internal; .scl 2; .type 32; .endef + .def general_error; .scl 2; .type 32; .endef + .def memcpy; .scl 2; .type 32; .endef + .def dosym; .scl 2; .type 32; .endef + .def undefined; .scl 2; .type 32; .endef + .def exit; .scl 2; .type 32; .endef + .def to_fixnum; .scl 2; .type 32; .endef + .def unbox_char_string; .scl 2; .type 32; .endef + .def getenv; .scl 2; .type 32; .endef + .def box_char_string; .scl 2; .type 32; .endef + .def box_unsigned_8; .scl 2; .type 32; .endef + .def current_millis; .scl 2; .type 32; .endef + .def sleep_millis; .scl 2; .type 32; .endef + .def to_cell; .scl 2; .type 32; .endef + .def docol_profiling; .scl 2; .type 32; .endef + .def docol; .scl 2; .type 32; .endef + .def save_callstack_top; .scl 2; .type 32; .endef + .def to_boolean; .scl 2; .type 32; .endef + .def begin_scan; .scl 2; .type 32; .endef + .def next_object; .scl 2; .type 32; .endef + .section .drectve + .ascii " -export:nursery,data" + .ascii " -export:cards_offset,data" + .ascii " -export:stack_chain,data" + .ascii " -export:userenv,data" + .ascii " -export:profiling,data" + .ascii " -export:nest_stacks" + .ascii " -export:unnest_stacks" + .ascii " -export:save_stacks" From 8d358ea3703f9155248c74560252b9feb0b3fb21 Mon Sep 17 00:00:00 2001 From: "U-SLAVA-FB3999113\\Slava" Date: Sat, 13 Oct 2007 00:57:40 -0400 Subject: [PATCH 02/20] core/cpu/ppc cleanup --- core/cpu/ppc/bootstrap.factor | 13 +++---------- 1 file changed, 3 insertions(+), 10 deletions(-) mode change 100644 => 100755 core/cpu/ppc/bootstrap.factor diff --git a/core/cpu/ppc/bootstrap.factor b/core/cpu/ppc/bootstrap.factor old mode 100644 new mode 100755 index d8644e24a6..c22d1f243c --- a/core/cpu/ppc/bootstrap.factor +++ b/core/cpu/ppc/bootstrap.factor @@ -62,6 +62,7 @@ big-endian on ] { } make jit-word-primitive-call set : load-xt ( -- ) + word-reg scan-reg 4 LWZU ! load word and advance xt-reg word-reg word-xt@ LWZ ; : jit-call @@ -74,17 +75,9 @@ big-endian on : jit-jump xt-reg MTCTR BCTR ; -[ - word-reg scan-reg 4 LWZU ! load word and advance - load-xt - jit-call -] { } make jit-word-call set +[ load-xt jit-call ] { } make jit-word-call set -[ - word-reg scan-reg 4 LWZ ! load word - load-xt ! jump to word XT - jit-jump -] { } make jit-word-jump set +[ load-xt jit-jump ] { } make jit-word-jump set : load-branch temp-reg ds-reg 0 LWZ ! load boolean From 4d30644576ef94f69e8421143c345c97b5823b13 Mon Sep 17 00:00:00 2001 From: "U-SLAVA-FB3999113\\Slava" Date: Sat, 13 Oct 2007 17:57:29 -0400 Subject: [PATCH 03/20] Got various things working on CE/ARM --- core/cpu/arm/bootstrap.factor | 24 +++++++-------- vm/callstack.c | 0 vm/cpu-arm.S | 57 ++++++++++++++++++----------------- vm/cpu-arm.h | 24 +++++++++++++-- vm/cpu-ppc.h | 17 +++++++++++ vm/cpu-x86.h | 17 +++++++++++ vm/debug.c | 0 vm/errors.c | 0 vm/factor.c | 4 ++- vm/layouts.h | 17 ----------- vm/os-windows-ce-arm.S | 2 +- vm/os-windows-ce.c | 7 ----- 12 files changed, 100 insertions(+), 69 deletions(-) mode change 100644 => 100755 vm/callstack.c mode change 100644 => 100755 vm/cpu-ppc.h mode change 100644 => 100755 vm/cpu-x86.h mode change 100644 => 100755 vm/debug.c mode change 100644 => 100755 vm/errors.c mode change 100644 => 100755 vm/factor.c mode change 100644 => 100755 vm/layouts.h diff --git a/core/cpu/arm/bootstrap.factor b/core/cpu/arm/bootstrap.factor index c124de8162..4a4fe6a8d3 100755 --- a/core/cpu/arm/bootstrap.factor +++ b/core/cpu/arm/bootstrap.factor @@ -17,14 +17,12 @@ big-endian off : temp-reg R3 ; : xt-reg R12 ; -: lr-save bootstrap-cell ; - : stack-frame 8 bootstrap-cells ; -: next-save stack-frame bootstrap-cell - ; -: xt-save stack-frame 2 bootstrap-cells - ; -: array-save stack-frame 3 bootstrap-cells - ; -: scan-save stack-frame 4 bootstrap-cells - ; +: next-save stack-frame 2 bootstrap-cells - ; +: xt-save stack-frame 3 bootstrap-cells - ; +: array-save stack-frame 4 bootstrap-cells - ; +: scan-save stack-frame 5 bootstrap-cells - ; [ temp-reg quot-reg quot-array@ <+> LDR ! load array @@ -32,12 +30,12 @@ big-endian off ] { } make jit-setup set [ + LR SP 4 <-> STR ! save return address SP SP stack-frame SUB xt-reg SP xt-save <+> STR ! save XT xt-reg stack-frame MOV xt-reg SP next-save <+> STR ! save frame size temp-reg SP array-save <+> STR ! save array - LR SP lr-save stack-frame + <+> STR ! save return address ] { } make jit-prolog set [ @@ -52,11 +50,11 @@ big-endian off ] { } make jit-push-wrapper set [ - R1 SP MOV ! pass stack pointer to primitive + R1 SP 4 SUB ! pass stack pointer to primitive ] { } make jit-word-primitive-jump set [ - R1 SP MOV ! pass stack pointer to primitive + R1 SP 4 SUB ! pass stack pointer to primitive ] { } make jit-word-primitive-call set : load-word-xt ( -- ) @@ -81,10 +79,10 @@ big-endian off xt-reg quot-reg quot-xt@ <+> LDR ; : load-branch - temp-reg ds-reg -4 <-!> LDR ! pop boolean + temp-reg ds-reg 4 <-!> LDR ! pop boolean temp-reg \ f tag-number CMP ! compare it with f - scan-reg quot-reg MOV ! point quot-reg at false branch - quot-reg dup 4 NE ADD ! point quot-reg at true branch + quot-reg scan-reg MOV ! point quot-reg at false branch + quot-reg dup 4 EQ ADD ! point quot-reg at true branch quot-reg dup 4 <+> LDR ! load the branch scan-reg dup 12 ADD ! advance scan pointer load-quot-xt @@ -110,7 +108,7 @@ big-endian off [ SP SP stack-frame ADD ! pop stack frame - LR SP lr-save stack-frame + <+> LDR ! load return address + LR SP 4 <-> LDR ! load return address ] { } make jit-epilog set [ PC LR MOV ] { } make jit-return set diff --git a/vm/callstack.c b/vm/callstack.c old mode 100644 new mode 100755 diff --git a/vm/cpu-arm.S b/vm/cpu-arm.S index 86255dd96b..acc4dc6ad6 100755 --- a/vm/cpu-arm.S +++ b/vm/cpu-arm.S @@ -3,17 +3,18 @@ /* Note that the XT is passed to the quotation in r12 */ #define CALL_QUOT \ ldr r12,[r0, #9] /* load quotation-xt slot */ ; \ - mov pc,lr ; \ - mov r11,pc + mov lr,pc ; \ + mov pc,r12 #define JUMP_QUOT \ - ldr pc,[r0, #9] /* load quotation-xt slot */ + ldr r12,[r0, #9] /* load quotation-xt slot */ ; \ + mov pc,r12 #define SAVED_REGS_SIZE 32 #define FRAME (RESERVED_SIZE + SAVED_REGS_SIZE + 8) -#define LR_SAVE [sp, #4] +#define LR_SAVE [sp, #-4] #define RESERVED_SIZE 8 #define SAVE_LR str lr,LR_SAVE @@ -27,12 +28,12 @@ #define RESTORE(register,offset) ldr register,[sp, #SAVE_AT(offset)] #define PROLOGUE \ - sub sp,sp,#FRAME ; \ - SAVE_LR + SAVE_LR ; \ + sub sp,sp,#FRAME #define EPILOGUE \ - LOAD_LR ; \ - sub sp,sp,#FRAME + add sp,sp,#FRAME ; \ + LOAD_LR DEF(void,c_to_factor,(CELL quot)): PROLOGUE @@ -47,7 +48,7 @@ DEF(void,c_to_factor,(CELL quot)): SAVE(r11,7) SAVE(r0,8) /* save quotation since we're about to mangle it */ - mov sp,r1 /* pass call stack pointer as an argument */ + mov r0,sp /* pass call stack pointer as an argument */ bl MANGLE(save_callstack_bottom) RESTORE(r0,8) /* restore quotation */ @@ -63,9 +64,9 @@ DEF(void,c_to_factor,(CELL quot)): RESTORE(r4,0) EPILOGUE - mov lr,pc + mov pc,lr -/* The JIT compiles an 'mov sp,r1' in front of every primitive call, since a +/* The JIT compiles an 'mov r1',sp in front of every primitive call, since a word which was defined as a primitive will not change its definition for the lifetime of the image -- adding new primitives requires a bootstrap. However, an undefined word can certainly become defined, @@ -77,12 +78,12 @@ DEFER: foo And calls to non-primitives do not have this one-instruction prologue, so we set the XT of undefined words to this symbol. */ DEF(void,undefined,(CELL word)): - mov sp,r1 + mov r1,sp b MANGLE(undefined_error) DEF(void,dosym,(CELL word)): - str r0,[r5], #4 /* push word to stack */ - mov lr,pc /* return */ + str r0,[r5, #4]! /* push word to stack */ + mov pc,lr /* return */ /* Here we have two entry points. The first one is taken when profiling is enabled */ @@ -94,32 +95,32 @@ DEF(void,docol,(CELL word)): ldr r0,[r0, #13] /* load word-def slot */ JUMP_QUOT -/* We must pass the XT to the quotation in r11. */ +/* We must pass the XT to the quotation in r12. */ DEF(void,primitive_call,(void)): - ldr r0,[r5, #-4]! /* load quotation from data stack */ + ldr r0,[r5], #-4 /* load quotation from data stack */ JUMP_QUOT /* We must preserve r1 here in case we're calling a primitive */ DEF(void,primitive_execute,(void)): - ldr r0,[r5, #-4]! /* load word from data stack */ + ldr r0,[r5], #-4 /* load word from data stack */ ldr pc,[r0, #29] /* jump to word-xt */ DEF(void,set_callstack,(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length)): - sub sp,r0,r2 /* compute new stack pointer */ - mov r0,r1 /* start of destination of memcpy() */ - str sp,[sp, #-64] /* setup fake stack frame for memcpy() */ - bl MANGLE(memcpy) /* go */ - ldr sp,[sp] /* tear down fake stack frame */ - ldr pc,LR_SAVE /* return */ + sub sp,r0,r2 /* compute new stack pointer */ + mov r0,sp /* start of destination of memcpy() */ + sub sp,sp,#12 /* alignment */ + bl MANGLE(memcpy) /* go */ + add sp,sp,#16 /* point SP at innermost frame */ + ldr pc,LR_SAVE /* return */ DEF(void,throw_impl,(CELL quot, F_STACK_FRAME *rewind_to)): - mov r1,sp /* compute new stack pointer */ - ldr lr,LR_SAVE /* we have rewound the stack; load return address */ - JUMP_QUOT /* call the quotation */ + mov sp,r1 /* compute new stack pointer */ + ldr lr,LR_SAVE /* we have rewound the stack; load return address */ + JUMP_QUOT /* call the quotation */ DEF(void,lazy_jit_compile,(CELL quot)): - mov sp,r1 /* save stack pointer */ + mov r1,sp /* save stack pointer */ PROLOGUE bl MANGLE(primitive_jit_compile) EPILOGUE - JUMP_QUOT /* call the quotation */ + JUMP_QUOT /* call the quotation */ diff --git a/vm/cpu-arm.h b/vm/cpu-arm.h index cdb66ff0ef..037bb26715 100755 --- a/vm/cpu-arm.h +++ b/vm/cpu-arm.h @@ -5,6 +5,28 @@ register CELL rs asm("r6"); #define F_FASTCALL +typedef struct +{ + /* In compiled quotation frames, position within the array. + In compiled word frames, unused. */ + CELL scan; + + /* In compiled quotation frames, the quot->array slot. + In compiled word frames, unused. */ + CELL array; + + /* In all compiled frames, the XT on entry. */ + XT xt; + + /* Frame size in bytes */ + CELL size; + + /* Return address */ + XT return_address; +} F_STACK_FRAME; + +#define FRAME_RETURN_ADDRESS(frame) (frame)->return_address + void c_to_factor(CELL quot); void dosym(CELL word); void docol_profiling(CELL word); @@ -14,5 +36,3 @@ void set_callstack(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, void *me void throw_impl(CELL quot, F_STACK_FRAME *rewind); void lazy_jit_compile(CELL quot); void flush_icache(CELL start, CELL len); - -#define FRAME_RETURN_ADDRESS(frame) *((XT *)(frame_successor(frame) + 1) + 1) diff --git a/vm/cpu-ppc.h b/vm/cpu-ppc.h old mode 100644 new mode 100755 index 88bbde5661..dc9e0bbbf6 --- a/vm/cpu-ppc.h +++ b/vm/cpu-ppc.h @@ -1,3 +1,20 @@ +typedef struct +{ + /* In compiled quotation frames, position within the array. + In compiled word frames, unused. */ + CELL scan; + + /* In compiled quotation frames, the quot->array slot. + In compiled word frames, unused. */ + CELL array; + + /* In all compiled frames, the XT on entry. */ + XT xt; + + /* Frame size in bytes */ + CELL size; +} F_STACK_FRAME; + #define FACTOR_CPU_STRING "ppc" #define F_FASTCALL diff --git a/vm/cpu-x86.h b/vm/cpu-x86.h old mode 100644 new mode 100755 index 7983c139af..f119db5761 --- a/vm/cpu-x86.h +++ b/vm/cpu-x86.h @@ -1,5 +1,22 @@ #define FRAME_RETURN_ADDRESS(frame) *(XT *)(frame_successor(frame) + 1) +typedef struct +{ + /* In compiled quotation frames, position within the array. + In compiled word frames, unused. */ + CELL scan; + + /* In compiled quotation frames, the quot->array slot. + In compiled word frames, unused. */ + CELL array; + + /* In all compiled frames, the XT on entry. */ + XT xt; + + /* Frame size in bytes */ + CELL size; +} F_STACK_FRAME; + INLINE void flush_icache(CELL start, CELL len) {} F_FASTCALL void c_to_factor(CELL quot); diff --git a/vm/debug.c b/vm/debug.c old mode 100644 new mode 100755 diff --git a/vm/errors.c b/vm/errors.c old mode 100644 new mode 100755 diff --git a/vm/factor.c b/vm/factor.c old mode 100644 new mode 100755 index 270ad29208..3541a4513c --- a/vm/factor.c +++ b/vm/factor.c @@ -134,7 +134,9 @@ void init_factor_from_args(F_CHAR *image, int argc, F_CHAR **argv, bool embedded if(p.fep) factorbug(); - c_to_factor_toplevel(userenv[BOOT_ENV]); + printf("about to call boot\n"); + c_to_factor(userenv[BOOT_ENV]); + printf("return from call boot\n"); unnest_stacks(); for(i = 0; i < argc; i++) diff --git a/vm/layouts.h b/vm/layouts.h old mode 100644 new mode 100755 index cd1c242303..92a42d33f4 --- a/vm/layouts.h +++ b/vm/layouts.h @@ -239,20 +239,3 @@ typedef struct { /* tagged */ CELL length; } F_CALLSTACK; - -typedef struct -{ - /* In compiled quotation frames, position within the array. - In compiled word frames, unused. */ - CELL scan; - - /* In compiled quotation frames, the quot->array slot. - In compiled word frames, unused. */ - CELL array; - - /* In all compiled frames, the XT on entry. */ - XT xt; - - /* Frame size in bytes */ - CELL size; -} F_STACK_FRAME; diff --git a/vm/os-windows-ce-arm.S b/vm/os-windows-ce-arm.S index b8b1d41d6c..bde0c3d8ed 100755 --- a/vm/os-windows-ce-arm.S +++ b/vm/os-windows-ce-arm.S @@ -1,6 +1,6 @@ .text - .globl run_toplevel + .globl c_to_factor_toplevel .word exception_handler .word 0 diff --git a/vm/os-windows-ce.c b/vm/os-windows-ce.c index 9ebbd8fe7a..7113cd4498 100755 --- a/vm/os-windows-ce.c +++ b/vm/os-windows-ce.c @@ -37,14 +37,7 @@ char *getenv(char *name) return 0; /* unreachable */ } - - long exception_handler(PEXCEPTION_RECORD rec, void *frame, void *ctx, void *dispatch) { return 0; } - -void c_to_factor_toplevel(CELL quot) -{ - c_to_factor(quot); -} From e9b42fa635b13670dfb54e903c54e8aafa56d6d3 Mon Sep 17 00:00:00 2001 From: "U-SLAVA-FB3999113\\Slava" Date: Sun, 14 Oct 2007 20:38:23 -0400 Subject: [PATCH 04/20] Move more math stuff to extra/, get compiler to work without ratios/complex numbers --- core/alien/compiler/compiler.factor | 2 +- core/alien/structs/structs.factor | 2 +- core/arrays/arrays-tests.factor | 3 +- core/bootstrap/compiler/compiler.factor | 82 +++++++++---------- core/bootstrap/image/image.factor | 2 +- core/bootstrap/stage1.factor | 1 + core/bootstrap/stage2.factor | 12 ++- core/bootstrap/syntax.factor | 1 - core/compiler/test/intrinsics.factor | 5 +- core/cpu/arm/allot/allot.factor | 2 +- core/cpu/arm/architecture/architecture.factor | 2 +- core/cpu/arm/bootstrap.factor | 2 +- core/cpu/arm/intrinsics/intrinsics.factor | 2 +- core/cpu/ppc/allot/allot.factor | 2 +- core/cpu/ppc/architecture/architecture.factor | 2 +- core/cpu/ppc/assembler/assembler.factor | 2 +- core/cpu/ppc/bootstrap.factor | 2 +- core/cpu/ppc/intrinsics/intrinsics.factor | 10 +-- core/cpu/x86/32/32.factor | 2 +- core/cpu/x86/64/64.factor | 2 +- core/cpu/x86/allot/allot.factor | 4 +- core/cpu/x86/architecture/architecture.factor | 4 +- core/cpu/x86/intrinsics/intrinsics.factor | 2 +- core/inference/backend/backend.factor | 2 +- core/inference/class/class.factor | 3 +- core/io/utf16/utf16.factor | 2 +- core/math/floats/floats-tests.factor | 20 ----- core/math/floats/floats.factor | 11 +-- core/math/integers/integers-docs.factor | 3 +- core/math/integers/integers-tests.factor | 17 +--- core/math/integers/integers.factor | 3 - core/math/intervals/intervals-tests.factor | 15 ++-- core/math/math-docs.factor | 33 -------- core/math/math.factor | 42 +++------- core/math/parser/parser-tests.factor | 20 ----- core/optimizer/known-words/known-words.factor | 16 +--- core/optimizer/math/math.factor | 16 +--- core/prettyprint/backend/backend.factor | 1 - core/prettyprint/prettyprint-tests.factor | 1 - core/sequences/sequences-docs.factor | 18 ++++ core/sequences/sequences.factor | 6 ++ core/syntax/syntax.factor | 3 - core/threads/threads-tests.factor | 2 +- core/vectors/vectors-tests.factor | 2 +- core/vectors/vectors.factor | 0 {core => extra}/math/complex/authors.txt | 0 .../math/complex/complex-docs.factor | 0 .../math/complex/complex-tests.factor | 5 +- {core => extra}/math/complex/complex.factor | 11 ++- {core => extra}/math/complex/summary.txt | 0 {core => extra}/math/constants/authors.txt | 0 .../math/constants/constants-docs.factor | 0 .../math/constants/constants.factor | 2 - {core => extra}/math/constants/summary.txt | 0 {core => extra}/math/functions/authors.txt | 0 .../math/functions/functions-docs.factor | 34 ++++++++ .../math/functions/functions-tests.factor | 31 +++++++ .../math/functions/functions.factor | 49 ++++++++++- {core => extra}/math/functions/summary.txt | 0 {core => extra}/math/libm/authors.txt | 0 {core => extra}/math/libm/libm-docs.factor | 0 {core => extra}/math/libm/libm.factor | 0 {core => extra}/math/libm/summary.txt | 0 {core => extra}/math/libm/tags.txt | 0 {core => extra}/math/ratios/authors.txt | 0 .../math/ratios/ratios-docs.factor | 0 .../math/ratios/ratios-tests.factor | 26 +++++- {core => extra}/math/ratios/ratios.factor | 30 ++++--- {core => extra}/math/ratios/summary.txt | 0 {core => extra}/math/vectors/authors.txt | 0 {core => extra}/math/vectors/summary.txt | 0 .../math/vectors/vectors-docs.factor | 25 +----- .../math/vectors/vectors-tests.factor | 0 {core => extra}/math/vectors/vectors.factor | 23 ++++-- extra/random/random.factor | 2 +- vm/cpu-arm.S | 4 +- vm/cpu-arm.h | 5 +- vm/factor.c | 20 +++-- 78 files changed, 324 insertions(+), 329 deletions(-) mode change 100644 => 100755 core/alien/compiler/compiler.factor mode change 100644 => 100755 core/alien/structs/structs.factor mode change 100644 => 100755 core/arrays/arrays-tests.factor mode change 100644 => 100755 core/bootstrap/compiler/compiler.factor mode change 100644 => 100755 core/bootstrap/image/image.factor mode change 100644 => 100755 core/bootstrap/stage1.factor mode change 100644 => 100755 core/bootstrap/stage2.factor mode change 100644 => 100755 core/bootstrap/syntax.factor mode change 100644 => 100755 core/compiler/test/intrinsics.factor mode change 100644 => 100755 core/cpu/arm/allot/allot.factor mode change 100644 => 100755 core/cpu/arm/intrinsics/intrinsics.factor mode change 100644 => 100755 core/cpu/ppc/allot/allot.factor mode change 100644 => 100755 core/cpu/ppc/architecture/architecture.factor mode change 100644 => 100755 core/cpu/ppc/assembler/assembler.factor mode change 100644 => 100755 core/cpu/ppc/intrinsics/intrinsics.factor mode change 100644 => 100755 core/cpu/x86/32/32.factor mode change 100644 => 100755 core/cpu/x86/64/64.factor mode change 100644 => 100755 core/cpu/x86/allot/allot.factor mode change 100644 => 100755 core/cpu/x86/architecture/architecture.factor mode change 100644 => 100755 core/cpu/x86/intrinsics/intrinsics.factor mode change 100644 => 100755 core/inference/backend/backend.factor mode change 100644 => 100755 core/inference/class/class.factor mode change 100644 => 100755 core/io/utf16/utf16.factor mode change 100644 => 100755 core/math/floats/floats-tests.factor mode change 100644 => 100755 core/math/floats/floats.factor mode change 100644 => 100755 core/math/integers/integers-docs.factor mode change 100644 => 100755 core/math/integers/integers-tests.factor mode change 100644 => 100755 core/math/integers/integers.factor mode change 100644 => 100755 core/math/intervals/intervals-tests.factor mode change 100644 => 100755 core/math/math-docs.factor mode change 100644 => 100755 core/math/math.factor mode change 100644 => 100755 core/math/parser/parser-tests.factor mode change 100644 => 100755 core/optimizer/known-words/known-words.factor mode change 100644 => 100755 core/optimizer/math/math.factor mode change 100644 => 100755 core/prettyprint/backend/backend.factor mode change 100644 => 100755 core/prettyprint/prettyprint-tests.factor mode change 100644 => 100755 core/sequences/sequences-docs.factor mode change 100644 => 100755 core/sequences/sequences.factor mode change 100644 => 100755 core/syntax/syntax.factor mode change 100644 => 100755 core/threads/threads-tests.factor mode change 100644 => 100755 core/vectors/vectors-tests.factor mode change 100644 => 100755 core/vectors/vectors.factor rename {core => extra}/math/complex/authors.txt (100%) rename {core => extra}/math/complex/complex-docs.factor (100%) rename {core => extra}/math/complex/complex-tests.factor (94%) mode change 100644 => 100755 rename {core => extra}/math/complex/complex.factor (82%) mode change 100644 => 100755 rename {core => extra}/math/complex/summary.txt (100%) rename {core => extra}/math/constants/authors.txt (100%) rename {core => extra}/math/constants/constants-docs.factor (100%) rename {core => extra}/math/constants/constants.factor (80%) mode change 100644 => 100755 rename {core => extra}/math/constants/summary.txt (100%) rename {core => extra}/math/functions/authors.txt (100%) rename {core => extra}/math/functions/functions-docs.factor (84%) mode change 100644 => 100755 rename {core => extra}/math/functions/functions-tests.factor (73%) mode change 100644 => 100755 rename {core => extra}/math/functions/functions.factor (78%) mode change 100644 => 100755 rename {core => extra}/math/functions/summary.txt (100%) rename {core => extra}/math/libm/authors.txt (100%) rename {core => extra}/math/libm/libm-docs.factor (100%) rename {core => extra}/math/libm/libm.factor (100%) rename {core => extra}/math/libm/summary.txt (100%) rename {core => extra}/math/libm/tags.txt (100%) rename {core => extra}/math/ratios/authors.txt (100%) rename {core => extra}/math/ratios/ratios-docs.factor (100%) rename {core => extra}/math/ratios/ratios-tests.factor (84%) mode change 100644 => 100755 rename {core => extra}/math/ratios/ratios.factor (85%) mode change 100644 => 100755 rename {core => extra}/math/ratios/summary.txt (100%) rename {core => extra}/math/vectors/authors.txt (100%) rename {core => extra}/math/vectors/summary.txt (100%) rename {core => extra}/math/vectors/vectors-docs.factor (82%) mode change 100644 => 100755 rename {core => extra}/math/vectors/vectors-tests.factor (100%) rename {core => extra}/math/vectors/vectors.factor (50%) mode change 100644 => 100755 mode change 100644 => 100755 extra/random/random.factor diff --git a/core/alien/compiler/compiler.factor b/core/alien/compiler/compiler.factor old mode 100644 new mode 100755 index c4a7aa8dc3..f4f57f258d --- a/core/alien/compiler/compiler.factor +++ b/core/alien/compiler/compiler.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays generator generator.registers generator.fixup hashtables kernel math namespaces sequences words -inference.backend inference.dataflow system math.functions +inference.backend inference.dataflow system math.parser classes alien.arrays alien.c-types alien.structs alien.syntax cpu.architecture alien inspector quotations assocs kernel.private threads continuations.private libc combinators ; diff --git a/core/alien/structs/structs.factor b/core/alien/structs/structs.factor old mode 100644 new mode 100755 index 0afa9eafcb..aec09621cb --- a/core/alien/structs/structs.factor +++ b/core/alien/structs/structs.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays generic hashtables kernel kernel.private math namespaces parser sequences strings words libc slots -alien.c-types math.functions math.vectors cpu.architecture ; +alien.c-types cpu.architecture ; IN: alien.structs : align-offset ( offset type -- offset ) diff --git a/core/arrays/arrays-tests.factor b/core/arrays/arrays-tests.factor old mode 100644 new mode 100755 index 2c550fe724..3ff81fda72 --- a/core/arrays/arrays-tests.factor +++ b/core/arrays/arrays-tests.factor @@ -1,6 +1,5 @@ USING: arrays kernel sequences sequences.private growable -tools.test vectors layouts system math math.functions -vectors.private ; +tools.test vectors layouts system math vectors.private ; IN: temporary [ -2 { "a" "b" "c" } nth ] unit-test-fails diff --git a/core/bootstrap/compiler/compiler.factor b/core/bootstrap/compiler/compiler.factor old mode 100644 new mode 100755 index 39e85dcb21..eb65e7182b --- a/core/bootstrap/compiler/compiler.factor +++ b/core/bootstrap/compiler/compiler.factor @@ -5,48 +5,46 @@ hashtables.private sequences.private math tuples.private growable namespaces.private alien.remote-control assocs words generator command-line vocabs io prettyprint libc ; -"bootstrap.math" vocab [ - "cpu." cpu append require +"cpu." cpu append require - global [ { "compiler" } add-use ] bind +global [ { "compiler" } add-use ] bind - "-no-stack-traces" cli-args member? [ - f compiled-stack-traces set-global - ] when - - ! Compile a set of words ahead of our general - ! compile-all. This set of words was determined - ! semi-empirically using the profiler. It improves - ! bootstrap time significantly, because frequenly - ! called words which are also quick to compile - ! are replaced by compiled definitions as soon as - ! possible. - { - roll -roll declare not - - tuple-class-eq? array? hashtable? vector? - tuple? sbuf? node? tombstone? - - array-capacity array-nth set-array-nth - - wrap probe - - delegate - - underlying - - find-pair-next namestack* - - bitand bitor bitxor bitnot - - + 1+ 1- 2/ < <= > >= shift min - - new nth push pop peek hashcode* = get set - - . lines - - malloc free memcpy - } [ compile ] each - - [ recompile ] parse-hook set-global +"-no-stack-traces" cli-args member? [ + f compiled-stack-traces set-global ] when + +! Compile a set of words ahead of our general +! compile-all. This set of words was determined +! semi-empirically using the profiler. It improves +! bootstrap time significantly, because frequenly +! called words which are also quick to compile +! are replaced by compiled definitions as soon as +! possible. +{ + roll -roll declare not + + tuple-class-eq? array? hashtable? vector? + tuple? sbuf? node? tombstone? + + array-capacity array-nth set-array-nth + + wrap probe + + delegate + + underlying + + find-pair-next namestack* + + bitand bitor bitxor bitnot + + + 1+ 1- 2/ < <= > >= shift min + + new nth push pop peek hashcode* = get set + + . lines + + malloc free memcpy +} [ compile ] each + +[ recompile ] parse-hook set-global diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor old mode 100644 new mode 100755 index c749ec3dad..a842b240de --- a/core/bootstrap/image/image.factor +++ b/core/bootstrap/image/image.factor @@ -4,7 +4,7 @@ USING: alien arrays bit-arrays byte-arrays generic assocs hashtables assocs hashtables.private io kernel kernel.private math namespaces parser prettyprint sequences sequences.private strings sbufs vectors words quotations assocs system layouts -splitting growable math.functions classes tuples words.private +splitting growable classes tuples words.private io.binary io.files vocabs vocabs.loader source-files definitions debugger float-arrays quotations.private combinators.private combinators ; diff --git a/core/bootstrap/stage1.factor b/core/bootstrap/stage1.factor old mode 100644 new mode 100755 index bb8c9a57e8..df59afccb0 --- a/core/bootstrap/stage1.factor +++ b/core/bootstrap/stage1.factor @@ -23,6 +23,7 @@ vocabs.loader system ; \ boot , "math.integers" require + "math.floats" require "memory" require "io.streams.c" require "vocabs.loader" require diff --git a/core/bootstrap/stage2.factor b/core/bootstrap/stage2.factor old mode 100644 new mode 100755 index 728c4d44f6..121dd815e3 --- a/core/bootstrap/stage2.factor +++ b/core/bootstrap/stage2.factor @@ -19,11 +19,14 @@ IN: bootstrap.stage2 parse-command-line - "Cross-referencing..." print flush H{ } clone changed-words set-global - H{ } clone crossref set-global - xref-words - xref-sources + + "-no-crossref" cli-args member? [ + "Cross-referencing..." print flush + H{ } clone crossref set-global + xref-words + xref-sources + ] unless ! Set dll paths wince? [ "windows.ce" require ] when @@ -34,6 +37,7 @@ IN: bootstrap.stage2 ] [ "listener" require "none" require + "listener" use+ ] if [ diff --git a/core/bootstrap/syntax.factor b/core/bootstrap/syntax.factor old mode 100644 new mode 100755 index 136745f52b..28d1dae9b6 --- a/core/bootstrap/syntax.factor +++ b/core/bootstrap/syntax.factor @@ -20,7 +20,6 @@ f swap set-vocab-source-loaded? "B{" "C:" "CHAR:" - "C{" "DEFER:" "F{" "FORGET:" diff --git a/core/compiler/test/intrinsics.factor b/core/compiler/test/intrinsics.factor old mode 100644 new mode 100755 index d86018475c..0563c5a3b6 --- a/core/compiler/test/intrinsics.factor +++ b/core/compiler/test/intrinsics.factor @@ -2,10 +2,9 @@ IN: temporary USING: arrays compiler kernel kernel.private math math.private sequences strings tools.test words continuations sequences.private hashtables.private byte-arrays -strings.private system random math.vectors layouts +strings.private system random layouts vectors.private sbufs.private strings.private slots.private -alien alien.c-types alien.syntax namespaces libc math.constants -math.functions ; +alien alien.c-types alien.syntax namespaces libc ; ! Make sure that intrinsic ops compile to correct code. [ ] [ 1 [ drop ] compile-1 ] unit-test diff --git a/core/cpu/arm/allot/allot.factor b/core/cpu/arm/allot/allot.factor old mode 100644 new mode 100755 index ce07e1ea5a..2081a07f35 --- a/core/cpu/arm/allot/allot.factor +++ b/core/cpu/arm/allot/allot.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel cpu.architecture cpu.arm.assembler -cpu.arm.architecture namespaces math math.functions sequences +cpu.arm.architecture namespaces math sequences generator generator.registers generator.fixup system layouts alien ; IN: cpu.arm.allot diff --git a/core/cpu/arm/architecture/architecture.factor b/core/cpu/arm/architecture/architecture.factor index 411d8047c0..527daed7c4 100755 --- a/core/cpu/arm/architecture/architecture.factor +++ b/core/cpu/arm/architecture/architecture.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types arrays cpu.arm.assembler compiler -kernel kernel.private math math.functions namespaces words +kernel kernel.private math namespaces words words.private generator.registers generator.fixup generator cpu.architecture system layouts ; IN: cpu.arm.architecture diff --git a/core/cpu/arm/bootstrap.factor b/core/cpu/arm/bootstrap.factor index 4a4fe6a8d3..3054a0bb85 100755 --- a/core/cpu/arm/bootstrap.factor +++ b/core/cpu/arm/bootstrap.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: bootstrap.image.private kernel namespaces system -cpu.arm.assembler math math.functions layouts words vocabs ; +cpu.arm.assembler math layouts words vocabs ; IN: bootstrap.arm 4 \ cell set diff --git a/core/cpu/arm/intrinsics/intrinsics.factor b/core/cpu/arm/intrinsics/intrinsics.factor old mode 100644 new mode 100755 index 5af55cf8bd..218cdc9fb9 --- a/core/cpu/arm/intrinsics/intrinsics.factor +++ b/core/cpu/arm/intrinsics/intrinsics.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: alien arrays cpu.architecture cpu.arm.assembler cpu.arm.architecture cpu.arm.allot kernel kernel.private math -math.functions math.private namespaces sequences words +math.private namespaces sequences words quotations byte-arrays hashtables.private hashtables generator generator.registers generator.fixup sequences.private sbufs sbufs.private vectors vectors.private system tuples.private diff --git a/core/cpu/ppc/allot/allot.factor b/core/cpu/ppc/allot/allot.factor old mode 100644 new mode 100755 index 66b03c6018..a8c26d36bf --- a/core/cpu/ppc/allot/allot.factor +++ b/core/cpu/ppc/allot/allot.factor @@ -3,7 +3,7 @@ USING: kernel cpu.ppc.architecture cpu.ppc.assembler kernel.private namespaces math sequences generic arrays generator generator.registers generator.fixup system layouts -math.functions cpu.architecture alien ; +cpu.architecture alien ; IN: cpu.ppc.allot : load-zone-ptr ( reg -- ) diff --git a/core/cpu/ppc/architecture/architecture.factor b/core/cpu/ppc/architecture/architecture.factor old mode 100644 new mode 100755 index 6142b1e49f..508a46b4a7 --- a/core/cpu/ppc/architecture/architecture.factor +++ b/core/cpu/ppc/architecture/architecture.factor @@ -3,7 +3,7 @@ USING: alien.c-types cpu.ppc.assembler cpu.architecture generic kernel kernel.private math memory namespaces sequences words assocs generator generator.registers generator.fixup system -layouts math.functions classes words.private alien combinators ; +layouts classes words.private alien combinators ; IN: cpu.ppc.architecture TUPLE: ppc-backend ; diff --git a/core/cpu/ppc/assembler/assembler.factor b/core/cpu/ppc/assembler/assembler.factor old mode 100644 new mode 100755 index 2ea5595bc9..9bd9e615c5 --- a/core/cpu/ppc/assembler/assembler.factor +++ b/core/cpu/ppc/assembler/assembler.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. IN: cpu.ppc.assembler USING: generator.fixup generic kernel math memory namespaces -words math.bitfields math.functions io.binary ; +words math.bitfields io.binary ; ! See the Motorola or IBM documentation for details. The opcode ! names are standard, and the operand order is the same as in diff --git a/core/cpu/ppc/bootstrap.factor b/core/cpu/ppc/bootstrap.factor index c22d1f243c..dfca6f2849 100755 --- a/core/cpu/ppc/bootstrap.factor +++ b/core/cpu/ppc/bootstrap.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: bootstrap.image.private kernel namespaces system -cpu.ppc.assembler math math.functions layouts words vocabs ; +cpu.ppc.assembler math layouts words vocabs ; IN: bootstrap.ppc 4 \ cell set diff --git a/core/cpu/ppc/intrinsics/intrinsics.factor b/core/cpu/ppc/intrinsics/intrinsics.factor old mode 100644 new mode 100755 index ede213dc52..f78b7c06e2 --- a/core/cpu/ppc/intrinsics/intrinsics.factor +++ b/core/cpu/ppc/intrinsics/intrinsics.factor @@ -5,7 +5,7 @@ cpu.ppc.architecture cpu.ppc.allot cpu.architecture kernel kernel.private math math.private namespaces sequences words generic quotations byte-arrays hashtables hashtables.private generator generator.registers generator.fixup sequences.private -sbufs vectors system layouts math.functions math.floats.private +sbufs vectors system layouts math.floats.private classes tuples tuples.private sbufs.private vectors.private strings.private slots.private combinators bit-arrays float-arrays ; @@ -374,14 +374,6 @@ IN: cpu.ppc.intrinsics { +output+ { "out" } } } define-intrinsic -! \ fsqrt [ -! "y" operand "x" operand FSQRT -! ] H{ -! { +input+ { { float "x" } } } -! { +scratch+ { { float "y" } } } -! { +output+ { "y" } } -! } define-intrinsic - \ tag [ "out" operand "in" operand tag-mask get ANDI "out" operand dup %tag-fixnum diff --git a/core/cpu/x86/32/32.factor b/core/cpu/x86/32/32.factor old mode 100644 new mode 100755 index 4ef7777dd4..9cf9994a33 --- a/core/cpu/x86/32/32.factor +++ b/core/cpu/x86/32/32.factor @@ -4,7 +4,7 @@ USING: alien.c-types arrays cpu.x86.assembler cpu.x86.architecture cpu.x86.intrinsics cpu.x86.allot cpu.architecture kernel kernel.private math namespaces sequences generator.registers generator.fixup generator system -math.functions alien.compiler combinators command-line +alien.compiler combinators command-line compiler io vocabs.loader ; IN: cpu.x86.32 diff --git a/core/cpu/x86/64/64.factor b/core/cpu/x86/64/64.factor old mode 100644 new mode 100755 index 55513b0930..2216445e96 --- a/core/cpu/x86/64/64.factor +++ b/core/cpu/x86/64/64.factor @@ -4,7 +4,7 @@ USING: alien.c-types arrays cpu.x86.assembler cpu.x86.architecture cpu.x86.intrinsics cpu.x86.sse2 cpu.x86.allot cpu.architecture kernel kernel.private math namespaces sequences generator.registers generator.fixup system -alien alien.compiler alien.structs slots splitting math.functions ; +alien alien.compiler alien.structs slots splitting ; IN: cpu.x86.64 PREDICATE: x86-backend amd64-backend diff --git a/core/cpu/x86/allot/allot.factor b/core/cpu/x86/allot/allot.factor old mode 100644 new mode 100755 index 49ca17c36d..f32bda7d2c --- a/core/cpu/x86/allot/allot.factor +++ b/core/cpu/x86/allot/allot.factor @@ -2,8 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel cpu.architecture cpu.x86.assembler cpu.x86.architecture kernel.private namespaces math -math.functions sequences generic arrays generator -generator.fixup generator.registers system layouts alien ; +sequences generic arrays generator generator.fixup +generator.registers system layouts alien ; IN: cpu.x86.allot : allot-reg diff --git a/core/cpu/x86/architecture/architecture.factor b/core/cpu/x86/architecture/architecture.factor old mode 100644 new mode 100755 index 1ca4fe032a..07651c16e7 --- a/core/cpu/x86/architecture/architecture.factor +++ b/core/cpu/x86/architecture/architecture.factor @@ -2,8 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types alien.compiler arrays cpu.x86.assembler cpu.architecture kernel kernel.private math -math.functions memory namespaces sequences words generator -generator.registers generator.fixup system layouts combinators ; +memory namespaces sequences words generator generator.registers +generator.fixup system layouts combinators ; IN: cpu.x86.architecture TUPLE: x86-backend cell ; diff --git a/core/cpu/x86/intrinsics/intrinsics.factor b/core/cpu/x86/intrinsics/intrinsics.factor old mode 100644 new mode 100755 index 3b39afaa24..ff6975336d --- a/core/cpu/x86/intrinsics/intrinsics.factor +++ b/core/cpu/x86/intrinsics/intrinsics.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: alien arrays cpu.x86.assembler cpu.x86.allot cpu.x86.architecture cpu.architecture kernel kernel.private math -math.functions math.private namespaces quotations sequences +math.private namespaces quotations sequences words generic byte-arrays hashtables hashtables.private generator generator.registers generator.fixup sequences.private sbufs sbufs.private vectors vectors.private layouts system diff --git a/core/inference/backend/backend.factor b/core/inference/backend/backend.factor old mode 100644 new mode 100755 index a5f9e65160..f65d637b02 --- a/core/inference/backend/backend.factor +++ b/core/inference/backend/backend.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. IN: inference.backend USING: inference.dataflow arrays generic io io.streams.string -kernel math math.vectors namespaces parser prettyprint sequences +kernel math namespaces parser prettyprint sequences strings vectors words quotations effects classes continuations debugger assocs combinators ; diff --git a/core/inference/class/class.factor b/core/inference/class/class.factor old mode 100644 new mode 100755 index 016f7180e0..9049104cfc --- a/core/inference/class/class.factor +++ b/core/inference/class/class.factor @@ -2,8 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays generic assocs hashtables inference kernel math namespaces sequences words parser math.intervals -math.vectors effects classes inference.dataflow -inference.backend ; +effects classes inference.dataflow inference.backend ; IN: inference.class ! Class inference diff --git a/core/io/utf16/utf16.factor b/core/io/utf16/utf16.factor old mode 100644 new mode 100755 index ea6320174c..7ed27a626e --- a/core/io/utf16/utf16.factor +++ b/core/io/utf16/utf16.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006, 2007 Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: math kernel sequences sbufs vectors namespaces io.binary -io.encodings combinators splitting math.functions ; +io.encodings combinators splitting ; IN: io.utf16 SYMBOL: double diff --git a/core/math/floats/floats-tests.factor b/core/math/floats/floats-tests.factor old mode 100644 new mode 100755 index eed1046432..54a90ef233 --- a/core/math/floats/floats-tests.factor +++ b/core/math/floats/floats-tests.factor @@ -25,9 +25,6 @@ IN: temporary [ 2.1 ] [ -2.1 neg ] unit-test -[ 1 ] [ 0.5 1/2 + ] unit-test -[ 1 ] [ 1/2 0.5 + ] unit-test - [ 3 ] [ 3.1415 >fixnum ] unit-test [ 3 ] [ 3.1415 >bignum ] unit-test @@ -48,23 +45,6 @@ unit-test [ 2.0 ] [ 1.0 1+ ] unit-test [ 0.0 ] [ 1.0 1- ] unit-test -[ 4.0 ] [ 4.5 truncate ] unit-test -[ 4.0 ] [ 4.5 floor ] unit-test -[ 5.0 ] [ 4.5 ceiling ] unit-test - -[ -4.0 ] [ -4.5 truncate ] unit-test -[ -5.0 ] [ -4.5 floor ] unit-test -[ -4.0 ] [ -4.5 ceiling ] unit-test - -[ -4.0 ] [ -4.0 truncate ] unit-test -[ -4.0 ] [ -4.0 floor ] unit-test -[ -4.0 ] [ -4.0 ceiling ] unit-test - -[ -5.0 ] [ -4.5 round ] unit-test -[ -4.0 ] [ -4.4 round ] unit-test -[ 5.0 ] [ 4.5 round ] unit-test -[ 4.0 ] [ 4.4 round ] unit-test - ! [ t ] [ -0.0 -0.0 = ] unit-test ! [ f ] [ 0.0 -0.0 = ] unit-test diff --git a/core/math/floats/floats.factor b/core/math/floats/floats.factor old mode 100644 new mode 100755 index 62679afd75..30abd9cad6 --- a/core/math/floats/floats.factor +++ b/core/math/floats/floats.factor @@ -1,17 +1,11 @@ ! Copyright (C) 2004, 2006 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math math.functions math.private math.libm ; +USING: kernel math math.private ; IN: math.floats.private M: fixnum >float fixnum>float ; M: bignum >float bignum>float ; -M: real abs dup 0 < [ neg ] when ; -M: real absq sq ; - -M: real hashcode* nip >fixnum ; -M: real <=> - ; - M: float zero? dup 0.0 float= swap -0.0 float= or ; M: float >fixnum float>fixnum ; @@ -29,6 +23,3 @@ M: float - float- ; M: float * float* ; M: float / float/f ; M: float mod float-mod ; - -M: real sqrt - >float dup 0.0 < [ neg fsqrt 0.0 swap rect> ] [ fsqrt ] if ; diff --git a/core/math/integers/integers-docs.factor b/core/math/integers/integers-docs.factor old mode 100644 new mode 100755 index 3a5fd383e2..e21e9c7102 --- a/core/math/integers/integers-docs.factor +++ b/core/math/integers/integers-docs.factor @@ -1,5 +1,4 @@ -USING: help.markup help.syntax math math.private math.functions -math.ratios.private ; +USING: help.markup help.syntax math math.private ; IN: math.integers ARTICLE: "integers" "Integers" diff --git a/core/math/integers/integers-tests.factor b/core/math/integers/integers-tests.factor old mode 100644 new mode 100755 index 55b2c0a36c..5ad94d917c --- a/core/math/integers/integers-tests.factor +++ b/core/math/integers/integers-tests.factor @@ -1,4 +1,4 @@ -USING: kernel math namespaces prettyprint math.functions +USING: kernel math namespaces prettyprint math.private continuations tools.test sequences ; IN: temporary @@ -57,15 +57,6 @@ IN: temporary [ 134217728 dup + dup + dup + dup + dup + dup + unparse ] unit-test -[ t ] [ 0 0 ^ fp-nan? ] unit-test -[ 1 ] [ 10 0 ^ ] unit-test -[ 1/8 ] [ 1/2 3 ^ ] unit-test -[ 1/8 ] [ 2 -3 ^ ] unit-test -[ t ] [ 1 100 shift 2 100 ^ = ] unit-test - -[ t ] [ 256 power-of-2? ] unit-test -[ f ] [ 123 power-of-2? ] unit-test - [ 7 ] [ 255 log2 ] unit-test [ 8 ] [ 256 log2 ] unit-test [ 8 ] [ 257 log2 ] unit-test @@ -100,11 +91,6 @@ unit-test [ f ] [ BIN: -1101 >bignum 3 bit? ] unit-test [ t ] [ BIN: -1101 >bignum 4 bit? ] unit-test -[ 1 ] [ 7/8 ceiling ] unit-test -[ 2 ] [ 3/2 ceiling ] unit-test -[ 0 ] [ -7/8 ceiling ] unit-test -[ -1 ] [ -3/2 ceiling ] unit-test - [ 2 ] [ 0 next-power-of-2 ] unit-test [ 2 ] [ 1 next-power-of-2 ] unit-test [ 2 ] [ 2 next-power-of-2 ] unit-test @@ -115,7 +101,6 @@ unit-test [ 268435456 ] [ -268435456 >fixnum -1 / ] unit-test [ 268435456 ] [ -268435456 >fixnum -1 /i ] unit-test [ 268435456 0 ] [ -268435456 >fixnum -1 /mod ] unit-test -[ 1/268435456 ] [ -1 -268435456 >fixnum / ] unit-test [ 0 ] [ -1 -268435456 >fixnum /i ] unit-test [ 0 -1 ] [ -1 -268435456 >fixnum /mod ] unit-test [ 14355 ] [ 1591517158873146351817850880000000 32769 mod ] unit-test diff --git a/core/math/integers/integers.factor b/core/math/integers/integers.factor old mode 100644 new mode 100755 index 32bbcadae1..4f03201c02 --- a/core/math/integers/integers.factor +++ b/core/math/integers/integers.factor @@ -4,9 +4,6 @@ USING: kernel kernel.private sequences sequences.private math math.private combinators ; IN: math.integers.private -M: integer hashcode* nip >fixnum ; -M: integer <=> - ; - M: integer numerator ; M: integer denominator drop 1 ; diff --git a/core/math/intervals/intervals-tests.factor b/core/math/intervals/intervals-tests.factor old mode 100644 new mode 100755 index fe312259a6..cadf94b968 --- a/core/math/intervals/intervals-tests.factor +++ b/core/math/intervals/intervals-tests.factor @@ -39,11 +39,11 @@ IN: temporary ] unit-test [ t ] [ - 1 2 [a,b] -1/2 1/2 [a,b] interval* -1 1 [a,b] = + 1 2 [a,b] -0.5 0.5 [a,b] interval* -1 1 [a,b] = ] unit-test [ t ] [ - 1 2 [a,b] -1/2 1/2 (a,b] interval* -1 1 (a,b] = + 1 2 [a,b] -0.5 0.5 (a,b] interval* -1 1 (a,b] = ] unit-test [ t ] [ @@ -77,7 +77,7 @@ IN: temporary ] unit-test [ t ] [ - 1/2 0 1 (a,b) interval-contains? + 0.5 0 1 (a,b) interval-contains? ] unit-test [ f ] [ @@ -89,7 +89,7 @@ IN: temporary [ f ] [ -1 1 (a,b) 0 1 (a,b) interval/ ] unit-test [ t ] [ - -1 1 (a,b) 1/2 1 (a,b) interval/ -2 2 (a,b) = + -1 1 (a,b) 0.5 1 (a,b) interval/ -2 2 (a,b) = ] unit-test [ t ] [ 0 5 [a,b] 5 interval<= ] unit-test @@ -125,12 +125,15 @@ IN: temporary { + interval+ } { - interval- } { * interval* } - { / interval/ } { /i interval/i } { shift interval-shift } { min interval-min } { max interval-max } - } random ; + } + "math.ratios.private" vocab [ + { / interval/ } add + ] when + random ; : interval-test random-interval random-interval random-op diff --git a/core/math/math-docs.factor b/core/math/math-docs.factor old mode 100644 new mode 100755 index 7b7a1adc60..60e5310ce4 --- a/core/math/math-docs.factor +++ b/core/math/math-docs.factor @@ -243,26 +243,6 @@ HELP: 1- { $code "1-" "1 -" } } ; -HELP: truncate -{ $values { "x" real } { "y" "a whole real number" } } -{ $description "Outputs the number that results from subtracting the fractional component of " { $snippet "x" } "." } -{ $notes "The result is not necessarily an integer." } ; - -HELP: floor -{ $values { "x" real } { "y" "a whole real number" } } -{ $description "Outputs the greatest whole number smaller than or equal to " { $snippet "x" } "." } -{ $notes "The result is not necessarily an integer." } ; - -HELP: ceiling -{ $values { "x" real } { "y" "a whole real number" } } -{ $description "Outputs the least whole number greater than or equal to " { $snippet "x" } "." } -{ $notes "The result is not necessarily an integer." } ; - -HELP: round -{ $values { "x" real } { "y" "a whole real number" } } -{ $description "Outputs the whole number closest to " { $snippet "x" } "." } -{ $notes "The result is not necessarily an integer." } ; - HELP: sq { $values { "x" number } { "y" number } } { $description "Multiplies a number by itself." } ; @@ -351,22 +331,9 @@ HELP: imaginary ( z -- y ) { $values { "z" number } { "y" real } } { $description "Outputs the imaginary part of a complex number. This outputs zero for real numbers." } ; -HELP: (rect>) -{ $values { "x" real } { "y" real } { "z" number } } -{ $description "Creates a complex number from real and imaginary components." } -{ $warning "This word does not check that the arguments are real numbers, which can have undefined consequences. Use the " { $link rect> } " word instead." } ; - HELP: number { $class-description "The class of numbers." } ; -HELP: rect> -{ $values { "x" real } { "y" real } { "z" number } } -{ $description "Creates a complex number from real and imaginary components." } ; - -HELP: >rect -{ $values { "z" number } { "x" real } { "y" real } } -{ $description "Extracts the real and imaginary components of a complex number." } ; - HELP: next-power-of-2 { $values { "m" "a non-negative integer" } { "n" "an integer" } } { $description "Outputs the smallest power of 2 greater than " { $snippet "m" } ". The output value is always at least 1." } ; diff --git a/core/math/math.factor b/core/math/math.factor old mode 100644 new mode 100755 index 5331a954bf..02e2b433c4 --- a/core/math/math.factor +++ b/core/math/math.factor @@ -8,6 +8,7 @@ GENERIC: >bignum ( x -- y ) foldable GENERIC: >float ( x -- y ) foldable MATH: number= ( x y -- ? ) foldable + M: object number= 2drop f ; MATH: < ( x y -- ? ) foldable @@ -48,8 +49,6 @@ GENERIC: zero? ( x -- ? ) foldable M: object zero? drop f ; -GENERIC: sqrt ( x -- y ) foldable - : 1+ ( x -- y ) 1 + ; foldable : 1- ( x -- y ) 1 - ; foldable : 2/ ( x -- y ) -1 shift ; foldable @@ -66,15 +65,8 @@ GENERIC: sqrt ( x -- y ) foldable pick >= [ >= ] [ 2drop f ] if ; inline : rem ( x y -- z ) tuck mod over + swap mod ; foldable + : sgn ( x -- n ) dup 0 < -1 0 ? swap 0 > 1 0 ? bitor ; foldable -: truncate ( x -- y ) dup 1 mod - ; inline -: round ( x -- y ) dup sgn 2 / + truncate ; inline - -: floor ( x -- y ) - dup 1 mod dup zero? - [ drop ] [ dup 0 < [ - 1- ] [ - ] if ] if ; foldable - -: ceiling ( x -- y ) neg floor neg ; foldable : [-] ( x y -- z ) - 0 max ; inline @@ -84,9 +76,6 @@ GENERIC: sqrt ( x -- y ) foldable : odd? ( n -- ? ) 1 bitand 1 number= ; -: >fraction ( a/b -- a b ) - dup numerator swap denominator ; inline - UNION: integer fixnum bignum ; UNION: rational integer ratio ; @@ -95,6 +84,12 @@ UNION: real rational float ; UNION: number real complex ; +M: number equal? number= ; + +M: real hashcode* nip >fixnum ; + +M: real <=> - ; + GENERIC: fp-nan? ( x -- ? ) M: object fp-nan? @@ -104,25 +99,6 @@ M: float fp-nan? double>bits -51 shift BIN: 111111111111 [ bitand ] keep number= ; -) ( x y -- z ) - dup zero? [ drop ] [ ] if ; inline - -PRIVATE> - -: rect> ( x y -- z ) - over real? over real? and [ - (rect>) - ] [ - "Complex number must have real components" throw - ] if ; inline - -: >rect ( z -- x y ) dup real swap imaginary ; inline - -: >float-rect ( z -- x y ) - >rect swap >float swap >float ; inline - : (next-power-of-2) ( i n -- n ) 2dup >= [ drop @@ -132,6 +108,8 @@ PRIVATE> : next-power-of-2 ( m -- n ) 2 swap (next-power-of-2) ; foldable +: align ( m w -- n ) 1- [ + ] keep bitnot bitand ; inline + number number>string ] unit-test -[ 5 ] -[ "10/2" string>number ] -unit-test - -[ -5 ] -[ "-10/2" string>number ] -unit-test - -[ -5 ] -[ "10/-2" string>number ] -unit-test - -[ 5 ] -[ "-10/-2" string>number ] -unit-test - [ 5.0 ] [ "10.0/2" string>number ] unit-test @@ -105,10 +89,6 @@ unit-test [ "e/2" string>number ] unit-test -[ "33/100" ] -[ "66/200" string>number number>string ] -unit-test - [ f ] [ "12" bin> ] unit-test [ f ] [ "fdsf" bin> ] unit-test [ 3 ] [ "11" bin> ] unit-test diff --git a/core/optimizer/known-words/known-words.factor b/core/optimizer/known-words/known-words.factor old mode 100644 new mode 100755 index c072661025..88df5d8016 --- a/core/optimizer/known-words/known-words.factor +++ b/core/optimizer/known-words/known-words.factor @@ -6,7 +6,7 @@ inference.class kernel assocs math math.private kernel.private sequences words parser vectors strings sbufs io namespaces assocs quotations sequences.private io.binary io.crc32 io.buffers io.streams.string layouts splitting math.intervals -math.floats.private math.vectors tuples tuples.private classes +math.floats.private tuples tuples.private classes optimizer.def-use optimizer.backend optimizer.pattern-match float-arrays combinators.private ; @@ -102,20 +102,6 @@ float-arrays combinators.private ; { number number } "specializer" set-word-prop ] each -{ vneg norm-sq norm normalize } [ - { { float-array array } } "specializer" set-word-prop -] each - -\ n*v { * { float-array array } } "specializer" set-word-prop -\ v*n { { float-array array } * } "specializer" set-word-prop -\ n/v { * { float-array array } } "specializer" set-word-prop -\ v/n { { float-array array } * } "specializer" set-word-prop - -{ v+ v- v* v/ vmax vmin v. } [ - { { float-array array } { float-array array } } - "specializer" set-word-prop -] each - { first first2 first3 first4 } [ { array } "specializer" set-word-prop ] each diff --git a/core/optimizer/math/math.factor b/core/optimizer/math/math.factor old mode 100644 new mode 100755 index c3ab01b44b..0ea1f1316b --- a/core/optimizer/math/math.factor +++ b/core/optimizer/math/math.factor @@ -5,7 +5,7 @@ USING: alien arrays generic hashtables kernel assocs math math.private kernel.private sequences words parser inference.class inference.dataflow vectors strings sbufs io namespaces assocs quotations math.intervals sequences.private -math.libm combinators splitting layouts math.parser classes +combinators splitting layouts math.parser classes generic.math optimizer.pattern-match optimizer.backend optimizer.def-use generic.standard ; @@ -439,17 +439,3 @@ most-negative-fixnum most-positive-fixnum [a,b] [ splice-quot ] curry , ] { } make 1array define-optimizers ] assoc-each - -! This will go away when we have cross-word type inference -{ - facos fasin fatan - fcos fexp fcosh flog fpow - fsin fsinh fsqrt -} [ - [ drop { float } f ] - "output-classes" set-word-prop -] each - -\ fatan2 -[ drop { float float } f ] -"output-classes" set-word-prop diff --git a/core/prettyprint/backend/backend.factor b/core/prettyprint/backend/backend.factor old mode 100644 new mode 100755 index 1a376ef0e1..6250fbb43a --- a/core/prettyprint/backend/backend.factor +++ b/core/prettyprint/backend/backend.factor @@ -155,7 +155,6 @@ GENERIC: >pprint-sequence ( obj -- seq ) M: object >pprint-sequence ; -M: complex >pprint-sequence >rect 2array ; M: hashtable >pprint-sequence >alist ; M: tuple >pprint-sequence tuple>array ; M: wrapper >pprint-sequence wrapped 1array ; diff --git a/core/prettyprint/prettyprint-tests.factor b/core/prettyprint/prettyprint-tests.factor old mode 100644 new mode 100755 index ef21e9cf89..bb61251d28 --- a/core/prettyprint/prettyprint-tests.factor +++ b/core/prettyprint/prettyprint-tests.factor @@ -7,7 +7,6 @@ IN: temporary [ "4" ] [ 4 unparse ] unit-test [ "1.0" ] [ 1.0 unparse ] unit-test -[ "C{ 1/2 2/3 }" ] [ C{ 1/2 2/3 } unparse ] unit-test [ "1267650600228229401496703205376" ] [ 1 100 shift unparse ] unit-test [ "+" ] [ \ + unparse ] unit-test diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor old mode 100644 new mode 100755 index c553eac0df..7bf8d354b2 --- a/core/sequences/sequences-docs.factor +++ b/core/sequences/sequences-docs.factor @@ -943,3 +943,21 @@ HELP: unclip HELP: unclip-slice { $values { "seq" sequence } { "rest" slice } { "first" object } } { $description "Outputs a tail sequence and the first element of " { $snippet "seq" } "; the tail sequence consists of all elements of " { $snippet "seq" } " but the first. Unlike " { $link unclip } ", this word does not make a copy of the input sequence, and runs in constant time." } ; + +HELP: sum +{ $values { "seq" "a sequence of numbers" } { "n" "a number" } } +{ $description "Outputs the sum of all elements of " { $snippet "seq" } ". Outputs zero given an empty sequence." } ; + +HELP: product +{ $values { "seq" "a sequence of numbers" } { "n" "a number" } } +{ $description "Outputs the product of all elements of " { $snippet "seq" } ". Outputs one given an empty sequence." } ; + +HELP: infimum +{ $values { "seq" "a sequence of real numbers" } { "n" "a number" } } +{ $description "Outputs the least element of " { $snippet "seq" } "." } +{ $errors "Throws an error if the sequence is empty." } ; + +HELP: supremum +{ $values { "seq" "a sequence of real numbers" } { "n" "a number" } } +{ $description "Outputs the greatest element of " { $snippet "seq" } "." } +{ $errors "Throws an error if the sequence is empty." } ; diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor old mode 100644 new mode 100755 index a31c869f24..30ff7a7ff7 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -655,3 +655,9 @@ PRIVATE> : trim ( seq quot -- newseq ) [ ltrim ] keep rtrim ; inline + +: sum ( seq -- n ) 0 [ + ] reduce ; +: product ( seq -- n ) 1 [ * ] reduce ; + +: infimum ( seq -- n ) dup first [ min ] reduce ; +: supremum ( seq -- n ) dup first [ max ] reduce ; diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor old mode 100644 new mode 100755 index 0c6bbe1ec4..79840ac411 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -77,7 +77,6 @@ IN: bootstrap.syntax "?{" [ \ } [ >bit-array ] parse-literal ] define-syntax "F{" [ \ } [ >float-array ] parse-literal ] define-syntax "H{" [ \ } [ >hashtable ] parse-literal ] define-syntax -"C{" [ \ } [ first2 rect> ] parse-literal ] define-syntax "T{" [ \ } [ >tuple ] parse-literal ] define-syntax "W{" [ \ } [ first ] parse-literal ] define-syntax @@ -165,5 +164,3 @@ IN: bootstrap.syntax ] define-syntax "MAIN:" [ scan-word in get vocab set-vocab-main ] define-syntax - -"bootstrap.syntax" forget-vocab diff --git a/core/threads/threads-tests.factor b/core/threads/threads-tests.factor old mode 100644 new mode 100755 index 05fda2043d..6965828ff5 --- a/core/threads/threads-tests.factor +++ b/core/threads/threads-tests.factor @@ -8,6 +8,6 @@ IN: temporary [ ] [ [ "Errors, errors" throw ] in-thread ] unit-test yield -[ ] [ 1/2 sleep ] unit-test +[ ] [ 1 2 / sleep ] unit-test [ ] [ 0.3 sleep ] unit-test [ "hey" sleep ] unit-test-fails diff --git a/core/vectors/vectors-tests.factor b/core/vectors/vectors-tests.factor old mode 100644 new mode 100755 index 4215185793..4c57c238b4 --- a/core/vectors/vectors-tests.factor +++ b/core/vectors/vectors-tests.factor @@ -10,7 +10,7 @@ IN: temporary [ -3 V{ } nth ] unit-test-fails [ 3 V{ } nth ] unit-test-fails -[ 3 C{ 1 2 } nth ] unit-test-fails +[ 3 54.3 nth ] unit-test-fails [ "hey" [ 1 2 ] set-length ] unit-test-fails [ "hey" V{ 1 2 } set-length ] unit-test-fails diff --git a/core/vectors/vectors.factor b/core/vectors/vectors.factor old mode 100644 new mode 100755 diff --git a/core/math/complex/authors.txt b/extra/math/complex/authors.txt similarity index 100% rename from core/math/complex/authors.txt rename to extra/math/complex/authors.txt diff --git a/core/math/complex/complex-docs.factor b/extra/math/complex/complex-docs.factor similarity index 100% rename from core/math/complex/complex-docs.factor rename to extra/math/complex/complex-docs.factor diff --git a/core/math/complex/complex-tests.factor b/extra/math/complex/complex-tests.factor old mode 100644 new mode 100755 similarity index 94% rename from core/math/complex/complex-tests.factor rename to extra/math/complex/complex-tests.factor index 655dbd4985..336ed7d4f5 --- a/core/math/complex/complex-tests.factor +++ b/extra/math/complex/complex-tests.factor @@ -1,4 +1,5 @@ -USING: kernel math math.constants math.functions tools.test ; +USING: kernel math math.constants math.functions tools.test +prettyprint ; IN: temporary [ 1 C{ 0 1 } rect> ] unit-test-fails @@ -63,3 +64,5 @@ IN: temporary [ ] [ C{ 1 4 } tan drop ] unit-test [ ] [ C{ 1 4 } coth drop ] unit-test [ ] [ C{ 1 4 } cot drop ] unit-test + +[ "C{ 1/2 2/3 }" ] [ C{ 1/2 2/3 } unparse ] unit-test diff --git a/core/math/complex/complex.factor b/extra/math/complex/complex.factor old mode 100644 new mode 100755 similarity index 82% rename from core/math/complex/complex.factor rename to extra/math/complex/complex.factor index 8b218668ec..41ed7d2bd1 --- a/core/math/complex/complex.factor +++ b/extra/math/complex/complex.factor @@ -2,13 +2,12 @@ ! See http://factorcode.org/license.txt for BSD license. IN: math.complex.private USING: kernel kernel.private math math.private -math.libm math.functions ; +math.libm math.functions prettyprint.backend arrays +math.functions.private sequences parser ; M: real real ; M: real imaginary drop 0 ; -M: number equal? number= ; - M: complex absq >rect [ sq ] 2apply + ; : 2>rect ( x y -- xr yr xi yi ) @@ -34,3 +33,9 @@ M: complex abs absq >float fsqrt ; M: complex sqrt >polar swap fsqrt swap 2.0 / polar> ; M: complex hashcode* nip >rect >fixnum swap >fixnum bitxor ; + +M: complex >pprint-sequence >rect 2array ; + +IN: syntax + +: C{ \ } [ first2 rect> ] parse-literal ; parsing diff --git a/core/math/complex/summary.txt b/extra/math/complex/summary.txt similarity index 100% rename from core/math/complex/summary.txt rename to extra/math/complex/summary.txt diff --git a/core/math/constants/authors.txt b/extra/math/constants/authors.txt similarity index 100% rename from core/math/constants/authors.txt rename to extra/math/constants/authors.txt diff --git a/core/math/constants/constants-docs.factor b/extra/math/constants/constants-docs.factor similarity index 100% rename from core/math/constants/constants-docs.factor rename to extra/math/constants/constants-docs.factor diff --git a/core/math/constants/constants.factor b/extra/math/constants/constants.factor old mode 100644 new mode 100755 similarity index 80% rename from core/math/constants/constants.factor rename to extra/math/constants/constants.factor index 75c745e4c5..e2d7c4f433 --- a/core/math/constants/constants.factor +++ b/extra/math/constants/constants.factor @@ -2,8 +2,6 @@ ! See http://factorcode.org/license.txt for BSD license. IN: math.constants -: i ( -- i ) C{ 0 1 } ; inline -: -i ( -- -i ) C{ 0 -1 } ; inline : e ( -- e ) 2.7182818284590452354 ; inline : pi ( -- pi ) 3.14159265358979323846 ; inline : epsilon ( -- epsilon ) 2.2204460492503131e-16 ; inline diff --git a/core/math/constants/summary.txt b/extra/math/constants/summary.txt similarity index 100% rename from core/math/constants/summary.txt rename to extra/math/constants/summary.txt diff --git a/core/math/functions/authors.txt b/extra/math/functions/authors.txt similarity index 100% rename from core/math/functions/authors.txt rename to extra/math/functions/authors.txt diff --git a/core/math/functions/functions-docs.factor b/extra/math/functions/functions-docs.factor old mode 100644 new mode 100755 similarity index 84% rename from core/math/functions/functions-docs.factor rename to extra/math/functions/functions-docs.factor index 6889b6039d..3803e71fae --- a/core/math/functions/functions-docs.factor +++ b/extra/math/functions/functions-docs.factor @@ -94,6 +94,19 @@ ARTICLE: "math-functions" "Mathematical functions" ABOUT: "math-functions" +HELP: (rect>) +{ $values { "x" real } { "y" real } { "z" number } } +{ $description "Creates a complex number from real and imaginary components." } +{ $warning "This word does not check that the arguments are real numbers, which can have undefined consequences. Use the " { $link rect> } " word instead." } ; + +HELP: rect> +{ $values { "x" real } { "y" real } { "z" number } } +{ $description "Creates a complex number from real and imaginary components." } ; + +HELP: >rect +{ $values { "z" number } { "x" real } { "y" real } } +{ $description "Extracts the real and imaginary components of a complex number." } ; + HELP: power-of-2? { $values { "n" integer } { "?" "a boolean" } } { $description "Tests if " { $snippet "n" } " is a power of 2." } ; @@ -281,3 +294,24 @@ HELP: ~ { { $snippet "epsilon" } " is negative: relative distance test." } } } ; + + +HELP: truncate +{ $values { "x" real } { "y" "a whole real number" } } +{ $description "Outputs the number that results from subtracting the fractional component of " { $snippet "x" } "." } +{ $notes "The result is not necessarily an integer." } ; + +HELP: floor +{ $values { "x" real } { "y" "a whole real number" } } +{ $description "Outputs the greatest whole number smaller than or equal to " { $snippet "x" } "." } +{ $notes "The result is not necessarily an integer." } ; + +HELP: ceiling +{ $values { "x" real } { "y" "a whole real number" } } +{ $description "Outputs the least whole number greater than or equal to " { $snippet "x" } "." } +{ $notes "The result is not necessarily an integer." } ; + +HELP: round +{ $values { "x" real } { "y" "a whole real number" } } +{ $description "Outputs the whole number closest to " { $snippet "x" } "." } +{ $notes "The result is not necessarily an integer." } ; diff --git a/core/math/functions/functions-tests.factor b/extra/math/functions/functions-tests.factor old mode 100644 new mode 100755 similarity index 73% rename from core/math/functions/functions-tests.factor rename to extra/math/functions/functions-tests.factor index 16bd8c809e..fdfa450ede --- a/core/math/functions/functions-tests.factor +++ b/extra/math/functions/functions-tests.factor @@ -74,3 +74,34 @@ IN: temporary [ 78572682077 ] [ 234829342 342389423843 mod-inv ] unit-test [ 2 10 mod-inv ] unit-test-fails + +[ t ] [ 0 0 ^ fp-nan? ] unit-test +[ 1 ] [ 10 0 ^ ] unit-test +[ 1/8 ] [ 1/2 3 ^ ] unit-test +[ 1/8 ] [ 2 -3 ^ ] unit-test +[ t ] [ 1 100 shift 2 100 ^ = ] unit-test + +[ t ] [ 256 power-of-2? ] unit-test +[ f ] [ 123 power-of-2? ] unit-test + +[ 1 ] [ 7/8 ceiling ] unit-test +[ 2 ] [ 3/2 ceiling ] unit-test +[ 0 ] [ -7/8 ceiling ] unit-test +[ -1 ] [ -3/2 ceiling ] unit-test + +[ 4.0 ] [ 4.5 truncate ] unit-test +[ 4.0 ] [ 4.5 floor ] unit-test +[ 5.0 ] [ 4.5 ceiling ] unit-test + +[ -4.0 ] [ -4.5 truncate ] unit-test +[ -5.0 ] [ -4.5 floor ] unit-test +[ -4.0 ] [ -4.5 ceiling ] unit-test + +[ -4.0 ] [ -4.0 truncate ] unit-test +[ -4.0 ] [ -4.0 floor ] unit-test +[ -4.0 ] [ -4.0 ceiling ] unit-test + +[ -5.0 ] [ -4.5 round ] unit-test +[ -4.0 ] [ -4.4 round ] unit-test +[ 5.0 ] [ 4.5 round ] unit-test +[ 4.0 ] [ 4.4 round ] unit-test diff --git a/core/math/functions/functions.factor b/extra/math/functions/functions.factor old mode 100644 new mode 100755 similarity index 78% rename from core/math/functions/functions.factor rename to extra/math/functions/functions.factor index c0bcd35551..34a826f94f --- a/core/math/functions/functions.factor +++ b/extra/math/functions/functions.factor @@ -1,8 +1,28 @@ ! Copyright (C) 2004, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: math kernel math.constants math.libm combinators ; +USING: math kernel math.constants math.private +math.libm combinators ; IN: math.functions +) ( x y -- z ) + dup zero? [ drop ] [ ] if ; inline + +PRIVATE> + +: rect> ( x y -- z ) + over real? over real? and [ + (rect>) + ] [ + "Complex number must have real components" throw + ] if ; inline + +GENERIC: sqrt ( x -- y ) foldable + +M: real sqrt + >float dup 0.0 < [ neg fsqrt 0.0 swap rect> ] [ fsqrt ] if ; + : each-bit ( n quot -- ) over 0 number= pick -1 number= or [ 2drop @@ -62,8 +82,12 @@ M: integer (^) GENERIC: abs ( x -- y ) foldable +M: real abs dup 0 < [ neg ] when ; + GENERIC: absq ( x -- y ) foldable +M: real absq sq ; + : ~abs ( x y epsilon -- ? ) >r - abs r> < ; @@ -81,10 +105,13 @@ GENERIC: absq ( x -- y ) foldable : power-of-2? ( n -- ? ) dup 0 < [ drop f ] [ dup 1- bitand zero? ] if ; foldable -: align ( m w -- n ) 1- [ + ] keep bitnot bitand ; inline +: >rect ( z -- x y ) dup real swap imaginary ; inline : conjugate ( z -- z* ) >rect neg rect> ; inline +: >float-rect ( z -- x y ) + >rect swap >float swap >float ; inline + : arg ( z -- arg ) >float-rect swap fatan2 ; inline : >polar ( z -- abs arg ) @@ -160,18 +187,32 @@ M: number (^) : [-1,1]? ( x -- ? ) dup complex? [ drop f ] [ abs 1 <= ] if ; inline +: i* ( x -- y ) >rect neg swap rect> ; + +: -i* ( x -- y ) >rect swap neg rect> ; + : asin ( x -- y ) - dup [-1,1]? [ >float fasin ] [ i * asinh -i * ] if ; inline + dup [-1,1]? [ >float fasin ] [ i* asinh -i* ] if ; inline : acos ( x -- y ) dup [-1,1]? [ >float facos ] [ asin pi 2 / swap - ] if ; inline : atan ( x -- y ) - dup [-1,1]? [ >float fatan ] [ i * atanh i * ] if ; inline + dup [-1,1]? [ >float fatan ] [ i* atanh i* ] if ; inline : asec ( x -- y ) recip acos ; inline : acosec ( x -- y ) recip asin ; inline : acot ( x -- y ) recip atan ; inline + +: truncate ( x -- y ) dup 1 mod - ; inline + +: round ( x -- y ) dup sgn 2 / + truncate ; inline + +: floor ( x -- y ) + dup 1 mod dup zero? + [ drop ] [ dup 0 < [ - 1- ] [ - ] if ] if ; foldable + +: ceiling ( x -- y ) neg floor neg ; foldable diff --git a/core/math/functions/summary.txt b/extra/math/functions/summary.txt similarity index 100% rename from core/math/functions/summary.txt rename to extra/math/functions/summary.txt diff --git a/core/math/libm/authors.txt b/extra/math/libm/authors.txt similarity index 100% rename from core/math/libm/authors.txt rename to extra/math/libm/authors.txt diff --git a/core/math/libm/libm-docs.factor b/extra/math/libm/libm-docs.factor similarity index 100% rename from core/math/libm/libm-docs.factor rename to extra/math/libm/libm-docs.factor diff --git a/core/math/libm/libm.factor b/extra/math/libm/libm.factor similarity index 100% rename from core/math/libm/libm.factor rename to extra/math/libm/libm.factor diff --git a/core/math/libm/summary.txt b/extra/math/libm/summary.txt similarity index 100% rename from core/math/libm/summary.txt rename to extra/math/libm/summary.txt diff --git a/core/math/libm/tags.txt b/extra/math/libm/tags.txt similarity index 100% rename from core/math/libm/tags.txt rename to extra/math/libm/tags.txt diff --git a/core/math/ratios/authors.txt b/extra/math/ratios/authors.txt similarity index 100% rename from core/math/ratios/authors.txt rename to extra/math/ratios/authors.txt diff --git a/core/math/ratios/ratios-docs.factor b/extra/math/ratios/ratios-docs.factor similarity index 100% rename from core/math/ratios/ratios-docs.factor rename to extra/math/ratios/ratios-docs.factor diff --git a/core/math/ratios/ratios-tests.factor b/extra/math/ratios/ratios-tests.factor old mode 100644 new mode 100755 similarity index 84% rename from core/math/ratios/ratios-tests.factor rename to extra/math/ratios/ratios-tests.factor index 46e60f9b6f..a0e10b9c9c --- a/core/math/ratios/ratios-tests.factor +++ b/extra/math/ratios/ratios-tests.factor @@ -1,4 +1,4 @@ -USING: kernel math tools.test ; +USING: kernel math math.parser tools.test ; IN: temporary [ 1 2 ] [ 1/2 >fraction ] unit-test @@ -79,3 +79,27 @@ unit-test [ -1/2 ] [ 1/2 1- ] unit-test [ 3/2 ] [ 1/2 1+ ] unit-test + +[ 1 ] [ 0.5 1/2 + ] unit-test +[ 1 ] [ 1/2 0.5 + ] unit-test + +[ 1/268435456 ] [ -1 -268435456 >fixnum / ] unit-test + +[ 5 ] +[ "10/2" string>number ] +unit-test + +[ -5 ] +[ "-10/2" string>number ] +unit-test + +[ -5 ] +[ "10/-2" string>number ] +unit-test + +[ 5 ] +[ "-10/-2" string>number ] +unit-test +[ "33/100" ] +[ "66/200" string>number number>string ] +unit-test diff --git a/core/math/ratios/ratios.factor b/extra/math/ratios/ratios.factor old mode 100644 new mode 100755 similarity index 85% rename from core/math/ratios/ratios.factor rename to extra/math/ratios/ratios.factor index 4dfc084ed6..d92d33899a --- a/core/math/ratios/ratios.factor +++ b/extra/math/ratios/ratios.factor @@ -1,12 +1,27 @@ ! Copyright (C) 2004, 2006 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -IN: math.ratios.private -USING: kernel kernel.private math math.functions -math.private ; +IN: math.ratios +USING: kernel kernel.private math math.functions math.private ; + +: >fraction ( a/b -- a b ) + dup numerator swap denominator ; inline + +: 2>fraction ( a/b c/d -- a c b d ) + [ >fraction ] 2apply swapd ; inline + + ( a b -- a/b ) dup 1 number= [ drop ] [ ] if ; inline +: scale ( a/b c/d -- a*d b*c ) + 2>fraction >r * swap r> * swap ; inline + +: ratio+d ( a/b c/d -- b*d ) + denominator swap denominator * ; inline + +PRIVATE> + M: integer / dup zero? [ /i @@ -15,15 +30,6 @@ M: integer / 2dup gcd nip tuck /i >r /i r> fraction> ] if ; -: 2>fraction ( a/b c/d -- a c b d ) - [ >fraction ] 2apply swapd ; inline - -: scale ( a/b c/d -- a*d b*c ) - 2>fraction >r * swap r> * swap ; inline - -: ratio+d ( a/b c/d -- b*d ) - denominator swap denominator * ; inline - M: ratio number= 2>fraction number= [ number= ] [ 2drop f ] if ; diff --git a/core/math/ratios/summary.txt b/extra/math/ratios/summary.txt similarity index 100% rename from core/math/ratios/summary.txt rename to extra/math/ratios/summary.txt diff --git a/core/math/vectors/authors.txt b/extra/math/vectors/authors.txt similarity index 100% rename from core/math/vectors/authors.txt rename to extra/math/vectors/authors.txt diff --git a/core/math/vectors/summary.txt b/extra/math/vectors/summary.txt similarity index 100% rename from core/math/vectors/summary.txt rename to extra/math/vectors/summary.txt diff --git a/core/math/vectors/vectors-docs.factor b/extra/math/vectors/vectors-docs.factor old mode 100644 new mode 100755 similarity index 82% rename from core/math/vectors/vectors-docs.factor rename to extra/math/vectors/vectors-docs.factor index a97ab7c3a6..2005d99b44 --- a/core/math/vectors/vectors-docs.factor +++ b/extra/math/vectors/vectors-docs.factor @@ -21,12 +21,7 @@ $nl { $subsection v. } { $subsection norm } { $subsection norm-sq } -{ $subsection normalize } -"Combining all the values in a vector into a scalar with " { $link reduce } ":" -{ $subsection sum } -{ $subsection product } -{ $subsection supremum } -{ $subsection infimum } ; +{ $subsection normalize } ; ABOUT: "math-vectors" @@ -105,21 +100,3 @@ HELP: set-axis { $values { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } { "axis" "a sequence of 0/1" } { "w" "a sequence of numbers" } } { $description "Using " { $snippet "w" } " as a template, creates a new sequence containing corresponding elements from " { $snippet "u" } " in place of 0, and corresponding elements from " { $snippet "v" } " in place of 1." } { $examples { $example "USE: math.vectors" "{ 1 2 3 } { 4 5 6 } { 0 1 0 } set-axis ." "{ 1 5 3 }" } } ; - -HELP: sum -{ $values { "seq" "a sequence of numbers" } { "n" "a number" } } -{ $description "Outputs the sum of all elements of " { $snippet "seq" } ". Outputs zero given an empty sequence." } ; - -HELP: product -{ $values { "seq" "a sequence of numbers" } { "n" "a number" } } -{ $description "Outputs the product of all elements of " { $snippet "seq" } ". Outputs one given an empty sequence." } ; - -HELP: infimum -{ $values { "seq" "a sequence of real numbers" } { "n" "a number" } } -{ $description "Outputs the least element of " { $snippet "seq" } "." } -{ $errors "Throws an error if the sequence is empty." } ; - -HELP: supremum -{ $values { "seq" "a sequence of real numbers" } { "n" "a number" } } -{ $description "Outputs the greatest element of " { $snippet "seq" } "." } -{ $errors "Throws an error if the sequence is empty." } ; diff --git a/core/math/vectors/vectors-tests.factor b/extra/math/vectors/vectors-tests.factor similarity index 100% rename from core/math/vectors/vectors-tests.factor rename to extra/math/vectors/vectors-tests.factor diff --git a/core/math/vectors/vectors.factor b/extra/math/vectors/vectors.factor old mode 100644 new mode 100755 similarity index 50% rename from core/math/vectors/vectors.factor rename to extra/math/vectors/vectors.factor index ab7a1e861c..6cabe02279 --- a/core/math/vectors/vectors.factor +++ b/extra/math/vectors/vectors.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2005, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays kernel sequences math math.functions ; +USING: arrays kernel sequences math math.functions hints +float-arrays ; IN: math.vectors : vneg ( u -- v ) [ neg ] map ; @@ -26,8 +27,20 @@ IN: math.vectors : set-axis ( u v axis -- w ) dup length [ >r zero? pick pick ? r> swap nth ] 2map 2nip ; -: sum ( seq -- n ) 0 [ + ] reduce ; -: product ( seq -- n ) 1 [ * ] reduce ; +HINTS: vneg { float-array array } ; +HINTS: norm-sq { float-array array } ; +HINTS: norm { float-array array } ; +HINTS: normalize { float-array array } ; -: infimum ( seq -- n ) dup first [ min ] reduce ; -: supremum ( seq -- n ) dup first [ max ] reduce ; +HINTS: n*v * { float-array array } ; +HINTS: v*n { float-array array } * ; +HINTS: n/v * { float-array array } ; +HINTS: v/n { float-array array } * ; + +HINTS: v+ { float-array array } { float-array array } ; +HINTS: v- { float-array array } { float-array array } ; +HINTS: v* { float-array array } { float-array array } ; +HINTS: v/ { float-array array } { float-array array } ; +HINTS: vmax { float-array array } { float-array array } ; +HINTS: vmin { float-array array } { float-array array } ; +HINTS: v. { float-array array } { float-array array } ; diff --git a/extra/random/random.factor b/extra/random/random.factor old mode 100644 new mode 100755 index 93c25a66f6..45ce99bcea --- a/extra/random/random.factor +++ b/extra/random/random.factor @@ -4,7 +4,7 @@ ! mersenne twister based on ! http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/MT2002/CODES/mt19937ar.c -USING: arrays kernel math math.functions namespaces sequences +USING: arrays kernel math namespaces sequences system init alien.c-types ; IN: random diff --git a/vm/cpu-arm.S b/vm/cpu-arm.S index acc4dc6ad6..532908b772 100755 --- a/vm/cpu-arm.S +++ b/vm/cpu-arm.S @@ -48,7 +48,7 @@ DEF(void,c_to_factor,(CELL quot)): SAVE(r11,7) SAVE(r0,8) /* save quotation since we're about to mangle it */ - mov r0,sp /* pass call stack pointer as an argument */ + sub r0,sp,#4 /* pass call stack pointer as an argument */ bl MANGLE(save_callstack_bottom) RESTORE(r0,8) /* restore quotation */ @@ -78,7 +78,7 @@ DEFER: foo And calls to non-primitives do not have this one-instruction prologue, so we set the XT of undefined words to this symbol. */ DEF(void,undefined,(CELL word)): - mov r1,sp + sub r1,sp,#4 b MANGLE(undefined_error) DEF(void,dosym,(CELL word)): diff --git a/vm/cpu-arm.h b/vm/cpu-arm.h index 037bb26715..3e2e722edf 100755 --- a/vm/cpu-arm.h +++ b/vm/cpu-arm.h @@ -20,12 +20,9 @@ typedef struct /* Frame size in bytes */ CELL size; - - /* Return address */ - XT return_address; } F_STACK_FRAME; -#define FRAME_RETURN_ADDRESS(frame) (frame)->return_address +#define FRAME_RETURN_ADDRESS(frame) *(XT *)(frame_successor(frame) + 1) void c_to_factor(CELL quot); void dosym(CELL word); diff --git a/vm/factor.c b/vm/factor.c index 3541a4513c..d5e3ab23cf 100755 --- a/vm/factor.c +++ b/vm/factor.c @@ -3,21 +3,27 @@ void default_parameters(F_PARAMETERS *p) { p->image = NULL; - p->ds_size = 128; - p->rs_size = 128; /* We make a wild guess here that if we're running on ARM, we don't have a lot of memory. */ #ifdef FACTOR_ARM + p->ds_size = 8 * CELLS; + p->rs_size = 8 * CELLS; + p->gen_count = 2; - p->code_size = 2 * CELLS; + p->code_size = 4; + p->young_size = 1; + p->aging_size = 4; #else + p->ds_size = 32 * CELLS; + p->rs_size = 32 * CELLS; + p->gen_count = 3; p->code_size = 4 * CELLS; -#endif - p->young_size = 2 * CELLS; p->aging_size = 4 * CELLS; +#endif + p->secure_gc = false; p->fep = false; } @@ -134,9 +140,7 @@ void init_factor_from_args(F_CHAR *image, int argc, F_CHAR **argv, bool embedded if(p.fep) factorbug(); - printf("about to call boot\n"); - c_to_factor(userenv[BOOT_ENV]); - printf("return from call boot\n"); + c_to_factor_toplevel(userenv[BOOT_ENV]); unnest_stacks(); for(i = 0; i < argc; i++) From 047c8fe708399440c32a3a7e2897d13347e0173e Mon Sep 17 00:00:00 2001 From: "U-SLAVA-FB3999113\\Slava" Date: Sun, 14 Oct 2007 20:44:19 -0400 Subject: [PATCH 05/20] Bootstrap fixes --- core/bootstrap/image/image.factor | 2 +- core/optimizer/known-words/known-words.factor | 2 +- core/prettyprint/backend/backend.factor | 1 - extra/math/complex/complex.factor | 2 ++ 4 files changed, 4 insertions(+), 3 deletions(-) diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor index a842b240de..2308eef320 100755 --- a/core/bootstrap/image/image.factor +++ b/core/bootstrap/image/image.factor @@ -166,7 +166,7 @@ GENERIC: ' ( obj -- ptr ) [ (bignum>seq) ] { } make ; : emit-bignum ( n -- ) - [ 0 < 1 0 ? ] keep abs bignum>seq + dup 0 < [ 1 swap neg ] [ 0 swap ] if bignum>seq dup length 1+ emit-fixnum swap emit emit-seq ; diff --git a/core/optimizer/known-words/known-words.factor b/core/optimizer/known-words/known-words.factor index 88df5d8016..8ca92c05a3 100755 --- a/core/optimizer/known-words/known-words.factor +++ b/core/optimizer/known-words/known-words.factor @@ -92,7 +92,7 @@ float-arrays combinators.private ; ] each ! Specializers -{ 1+ 1- sq neg recip sgn truncate } [ +{ 1+ 1- sq neg recip sgn } [ { number } "specializer" set-word-prop ] each diff --git a/core/prettyprint/backend/backend.factor b/core/prettyprint/backend/backend.factor index 6250fbb43a..b67646e55a 100755 --- a/core/prettyprint/backend/backend.factor +++ b/core/prettyprint/backend/backend.factor @@ -138,7 +138,6 @@ M: pathname pprint* dup pathname-string "P\" " pprint-string ; GENERIC: pprint-delims ( obj -- start end ) -M: complex pprint-delims drop \ C{ \ } ; M: quotation pprint-delims drop \ [ \ ] ; M: curry pprint-delims drop \ [ \ ] ; M: array pprint-delims drop \ { \ } ; diff --git a/extra/math/complex/complex.factor b/extra/math/complex/complex.factor index 41ed7d2bd1..942c0c11d0 100755 --- a/extra/math/complex/complex.factor +++ b/extra/math/complex/complex.factor @@ -34,6 +34,8 @@ M: complex sqrt >polar swap fsqrt swap 2.0 / polar> ; M: complex hashcode* nip >rect >fixnum swap >fixnum bitxor ; +M: complex pprint-delims drop \ C{ \ } ; + M: complex >pprint-sequence >rect 2array ; IN: syntax From 8b54248c50cccb4de6dfc16946b549ea67b7b1ee Mon Sep 17 00:00:00 2001 From: "U-SLAVA-FB3999113\\Slava" Date: Sun, 14 Oct 2007 21:13:42 -0400 Subject: [PATCH 06/20] Get core unit tests to pass without number tower --- core/compiler/test/curry.factor | 4 +-- core/compiler/test/ifte.factor | 4 +-- core/compiler/test/intrinsics.factor | 22 +++++++----- core/compiler/test/optimizer.factor | 16 ++++----- core/compiler/test/stack-trace.factor | 4 +-- core/compiler/test/templates.factor | 39 ++++------------------ core/generic/generic-tests.factor | 4 +-- core/generic/generic.factor | 2 +- core/growable/growable-tests.factor | 2 +- core/hashtables/hashtables-tests.factor | 6 ++-- core/inference/inference-tests.factor | 4 +-- core/math/integers/integers-tests.factor | 1 - core/math/intervals/intervals-tests.factor | 10 +++--- core/parser/parser-docs.factor | 0 core/sequences/sequences-tests.factor | 10 +++--- core/threads/threads-tests.factor | 1 - extra/math/ratios/ratios-tests.factor | 1 + 17 files changed, 53 insertions(+), 77 deletions(-) mode change 100644 => 100755 core/compiler/test/curry.factor mode change 100644 => 100755 core/compiler/test/ifte.factor mode change 100644 => 100755 core/compiler/test/optimizer.factor mode change 100644 => 100755 core/compiler/test/stack-trace.factor mode change 100644 => 100755 core/compiler/test/templates.factor mode change 100644 => 100755 core/generic/generic-tests.factor mode change 100644 => 100755 core/generic/generic.factor mode change 100644 => 100755 core/growable/growable-tests.factor mode change 100644 => 100755 core/hashtables/hashtables-tests.factor mode change 100644 => 100755 core/inference/inference-tests.factor mode change 100644 => 100755 core/parser/parser-docs.factor mode change 100644 => 100755 core/sequences/sequences-tests.factor diff --git a/core/compiler/test/curry.factor b/core/compiler/test/curry.factor old mode 100644 new mode 100755 index e7401fbe9b..307c8adcdb --- a/core/compiler/test/curry.factor +++ b/core/compiler/test/curry.factor @@ -7,8 +7,8 @@ IN: temporary [ 3 ] [ [ 5 2 [ - ] 2curry call ] compile-1 ] unit-test [ 3 ] [ 5 [ 2 [ - ] 2curry call ] compile-1 ] unit-test [ 3 ] [ 5 2 [ [ - ] 2curry call ] compile-1 ] unit-test -[ 1/3 ] [ 5 2 [ [ - ] 2curry 1 swap call / ] compile-1 ] unit-test -[ 1/3 ] [ 5 2 [ [ - ] 2curry >r 1 r> call / ] compile-1 ] unit-test +[ 3 ] [ 5 2 [ [ - ] 2curry 9 swap call /i ] compile-1 ] unit-test +[ 3 ] [ 5 2 [ [ - ] 2curry >r 9 r> call /i ] compile-1 ] unit-test [ -10 -20 ] [ 10 20 -1 [ [ * ] curry 2apply ] compile-1 ] unit-test diff --git a/core/compiler/test/ifte.factor b/core/compiler/test/ifte.factor old mode 100644 new mode 100755 index c2ccc43cc5..aec971245c --- a/core/compiler/test/ifte.factor +++ b/core/compiler/test/ifte.factor @@ -33,12 +33,12 @@ math.private combinators ; : dead-code-rec t [ - C{ 3 2 } + 3.2 ] [ dead-code-rec ] if ; -[ C{ 3 2 } ] [ dead-code-rec ] unit-test +[ 3.2 ] [ dead-code-rec ] unit-test : one-rec [ f one-rec ] [ "hi" ] if ; diff --git a/core/compiler/test/intrinsics.factor b/core/compiler/test/intrinsics.factor index 0563c5a3b6..2d738b96dd 100755 --- a/core/compiler/test/intrinsics.factor +++ b/core/compiler/test/intrinsics.factor @@ -1,10 +1,10 @@ IN: temporary USING: arrays compiler kernel kernel.private math -math.private sequences strings tools.test words continuations -sequences.private hashtables.private byte-arrays -strings.private system random layouts -vectors.private sbufs.private strings.private slots.private -alien alien.c-types alien.syntax namespaces libc ; +math.constants math.private sequences strings tools.test words +continuations sequences.private hashtables.private byte-arrays +strings.private system random layouts vectors.private +sbufs.private strings.private slots.private alien alien.c-types +alien.syntax namespaces libc ; ! Make sure that intrinsic ops compile to correct code. [ ] [ 1 [ drop ] compile-1 ] unit-test @@ -326,9 +326,13 @@ cell 8 = [ [ 500 length ] compile-1 ] unit-test -[ C{ 1 2 } ] [ 1 2 [ ] compile-1 ] unit-test +[ 1 2 ] [ + 1 2 [ ] compile-1 dup real swap imaginary +] unit-test -[ 1/2 ] [ 1 2 [ ] compile-1 ] unit-test +[ 1 2 ] [ + 1 2 [ ] compile-1 dup numerator swap denominator +] unit-test [ \ + ] [ \ + [ ] compile-1 ] unit-test @@ -411,8 +415,8 @@ cell 8 = [ [ t ] [ pi [ { byte-array } declare *double ] compile-1 pi = ] unit-test ! Silly -[ t ] [ pi 4 [ [ { float byte-array } declare 0 set-alien-float ] compile-1 ] keep *float pi - abs 0.001 < ] unit-test -[ t ] [ pi [ { byte-array } declare *float ] compile-1 pi - abs 0.001 < ] unit-test +[ t ] [ pi 4 [ [ { float byte-array } declare 0 set-alien-float ] compile-1 ] keep *float pi - -0.001 0.001 between? ] unit-test +[ t ] [ pi [ { byte-array } declare *float ] compile-1 pi - -0.001 0.001 between? ] unit-test [ t ] [ pi 8 [ [ { float byte-array } declare 0 set-alien-double ] compile-1 ] keep *double pi = ] unit-test diff --git a/core/compiler/test/optimizer.factor b/core/compiler/test/optimizer.factor old mode 100644 new mode 100755 index e05164cfdd..7a9144b97e --- a/core/compiler/test/optimizer.factor +++ b/core/compiler/test/optimizer.factor @@ -208,10 +208,6 @@ M: slice foozul ; [ -5 ] [ 5 [ -1 * ] compile-1 ] unit-test [ -5 ] [ 5 [ -1 swap * ] compile-1 ] unit-test -[ 5 ] [ 5 [ 1 / ] compile-1 ] unit-test -[ 1/5 ] [ 5 [ 1 swap / ] compile-1 ] unit-test -[ -5 ] [ 5 [ -1 / ] compile-1 ] unit-test - [ 0 ] [ 5 [ 1 mod ] compile-1 ] unit-test [ 0 ] [ 5 [ 1 rem ] compile-1 ] unit-test @@ -246,8 +242,6 @@ M: slice foozul ; [ t ] [ 5 [ dup number= ] compile-1 ] unit-test [ t ] [ \ vector [ \ vector = ] compile-1 ] unit-test -[ 3 ] [ 10/3 [ { ratio } declare 1 /i ] compile-1 ] unit-test - GENERIC: detect-number ( obj -- obj ) M: number detect-number ; @@ -275,7 +269,11 @@ USE: sorting.private ] unit-test ! Regression -[ 1 2 { real imaginary } ] [ - C{ 1 2 } - [ { real imaginary } [ get-slots ] keep ] compile-1 +TUPLE: silly-tuple a b ; + +[ 1 2 { silly-tuple-a silly-tuple-b } ] [ + T{ silly-tuple f 1 2 } + [ + { silly-tuple-a silly-tuple-b } [ get-slots ] keep + ] compile-1 ] unit-test diff --git a/core/compiler/test/stack-trace.factor b/core/compiler/test/stack-trace.factor old mode 100644 new mode 100755 index 4c47ca8a12..73463ec99c --- a/core/compiler/test/stack-trace.factor +++ b/core/compiler/test/stack-trace.factor @@ -27,8 +27,8 @@ words splitting ; [ { 1 "hi" } bleh ] catch drop \ + stack-trace-contains? ] unit-test -[ f t ] [ - [ { C{ 1 2 } } bleh ] catch drop +[ t f ] [ + [ { "hi" } bleh ] catch drop \ + stack-trace-contains? \ > stack-trace-contains? ] unit-test diff --git a/core/compiler/test/templates.factor b/core/compiler/test/templates.factor old mode 100644 new mode 100755 index aa2690da7b..15d626a889 --- a/core/compiler/test/templates.factor +++ b/core/compiler/test/templates.factor @@ -1,9 +1,9 @@ ! 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 byte-arrays alien layouts ; +hashtables.private math.private namespaces sequences +sequences.private tools.test namespaces.private slots.private +combinators.private byte-arrays alien layouts ; IN: temporary ! Oops! @@ -37,41 +37,14 @@ unit-test : foo ; -[ 4 4 ] -[ 1/2 [ tag [ foo ] keep ] compile-1 ] +[ 5 5 ] +[ 1.2 [ tag [ foo ] keep ] compile-1 ] unit-test [ 1 2 2 ] -[ 1/2 [ dup 1 slot swap 2 slot [ foo ] keep ] compile-1 ] +[ { 1 2 } [ dup 2 slot swap 3 slot [ foo ] keep ] compile-1 ] unit-test -[ 41 5 4 ] [ - 5/4 4/5 [ - dup ratio? [ - over ratio? [ - 2dup 2>fraction >r * swap r> * swap - + -rot denominator swap denominator - ] [ - 2drop f f f - ] if - ] [ - 2drop f f f - ] if - ] compile-1 -] unit-test - -: jxyz - over bignum? [ - dup ratio? [ - [ >fraction ] 2apply swapd - >r 2array swap r> 2array swap - ] when - ] when ; - -\ jxyz compile - -[ { 1 2 } { 1 1 } ] [ 1 >bignum 1/2 jxyz ] unit-test - [ 3 ] [ global [ 3 \ foo set ] bind diff --git a/core/generic/generic-tests.factor b/core/generic/generic-tests.factor old mode 100644 new mode 100755 index 931f5b3872..e780655156 --- a/core/generic/generic-tests.factor +++ b/core/generic/generic-tests.factor @@ -34,7 +34,7 @@ M: f bool>str drop "false" ; [ f ] [ f bool>str str>bool ] unit-test ! Testing unions -UNION: funnies quotation ratio complex ; +UNION: funnies quotation float complex ; GENERIC: funny ( x -- y ) M: funnies funny drop 2 ; @@ -48,7 +48,7 @@ PREDICATE: funnies very-funny number? ; GENERIC: gooey ( x -- y ) M: very-funny gooey sq ; -[ 1/4 ] [ 1/2 gooey ] unit-test +[ 0.25 ] [ 0.5 gooey ] unit-test DEFER: complement-test FORGET: complement-test diff --git a/core/generic/generic.factor b/core/generic/generic.factor old mode 100644 new mode 100755 index a9216a2fd3..d5060827c2 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -21,7 +21,7 @@ M: object perform-combination #! method combination, and a method on the generic, and the #! method combination is forgotten first, then forgetting #! the method will throw an error. We don't want that. - nip [ "Invalid method combination" throw ] curry ; + nip [ "Invalid method combination" throw ] curry [ ] like ; : make-generic ( word -- ) dup diff --git a/core/growable/growable-tests.factor b/core/growable/growable-tests.factor old mode 100644 new mode 100755 index 3ef1f4e862..39d8721726 --- a/core/growable/growable-tests.factor +++ b/core/growable/growable-tests.factor @@ -22,5 +22,5 @@ unit-test-fails [ ] [ 10 V{ } [ set-length ] keep - 1/2 swap set-length + 0.5 swap set-length ] unit-test diff --git a/core/hashtables/hashtables-tests.factor b/core/hashtables/hashtables-tests.factor old mode 100644 new mode 100755 index 0c79efff77..7dc252fd3e --- a/core/hashtables/hashtables-tests.factor +++ b/core/hashtables/hashtables-tests.factor @@ -34,11 +34,11 @@ unit-test 16 "testhash" set -t C{ 2 3 } "testhash" get set-at +t { 2 3 } "testhash" get set-at f 100000000000000000000000000 "testhash" get set-at { } { [ { } ] } "testhash" get set-at -[ t ] [ C{ 2 3 } "testhash" get at ] unit-test +[ t ] [ { 2 3 } "testhash" get at ] unit-test [ f ] [ 100000000000000000000000000 "testhash" get at* drop ] unit-test [ { } ] [ { [ { } ] } clone "testhash" get at* drop ] unit-test @@ -122,7 +122,7 @@ H{ } "x" set 100 [ drop "x" get clear-assoc ] each ! Crash discovered by erg -[ t ] [ 3/4 dup clone = ] unit-test +[ t ] [ 0.75 dup clone = ] unit-test ! Another crash discovered by erg [ ] [ diff --git a/core/inference/inference-tests.factor b/core/inference/inference-tests.factor old mode 100644 new mode 100755 index cefad52cd7..1d3d6ebcf2 --- a/core/inference/inference-tests.factor +++ b/core/inference/inference-tests.factor @@ -230,8 +230,8 @@ DEFER: do-crap* ! Error reporting is wrong MATH: xyz M: fixnum xyz 2array ; -M: ratio xyz - [ >fraction ] 2apply swapd >r 2array swap r> 2array swap ; +M: float xyz + [ 3 ] 2apply swapd >r 2array swap r> 2array swap ; [ t ] [ [ [ xyz ] infer short-effect ] catch inference-error? ] unit-test diff --git a/core/math/integers/integers-tests.factor b/core/math/integers/integers-tests.factor index 5ad94d917c..680119a56e 100755 --- a/core/math/integers/integers-tests.factor +++ b/core/math/integers/integers-tests.factor @@ -98,7 +98,6 @@ unit-test [ 16 ] [ 13 next-power-of-2 ] unit-test [ 16 ] [ 16 next-power-of-2 ] unit-test -[ 268435456 ] [ -268435456 >fixnum -1 / ] unit-test [ 268435456 ] [ -268435456 >fixnum -1 /i ] unit-test [ 268435456 0 ] [ -268435456 >fixnum -1 /mod ] unit-test [ 0 ] [ -1 -268435456 >fixnum /i ] unit-test diff --git a/core/math/intervals/intervals-tests.factor b/core/math/intervals/intervals-tests.factor index cadf94b968..2c6ac2ecb0 100755 --- a/core/math/intervals/intervals-tests.factor +++ b/core/math/intervals/intervals-tests.factor @@ -1,5 +1,5 @@ USING: math.intervals kernel sequences words math arrays -prettyprint tools.test random ; +prettyprint tools.test random vocabs ; IN: temporary [ T{ interval f { 1 t } { 2 t } } ] [ 1 2 [a,b] ] unit-test @@ -88,9 +88,11 @@ IN: temporary [ f ] [ -1 1 (a,b) 0 1 (a,b) interval/ ] unit-test -[ t ] [ - -1 1 (a,b) 0.5 1 (a,b) interval/ -2 2 (a,b) = -] unit-test +"math.ratios.private" vocab [ + [ t ] [ + -1 1 (a,b) 0.5 1 (a,b) interval/ -2 2 (a,b) = + ] unit-test +] when [ t ] [ 0 5 [a,b] 5 interval<= ] unit-test diff --git a/core/parser/parser-docs.factor b/core/parser/parser-docs.factor old mode 100644 new mode 100755 diff --git a/core/sequences/sequences-tests.factor b/core/sequences/sequences-tests.factor old mode 100644 new mode 100755 index c8c1c0245b..58250f1ee5 --- a/core/sequences/sequences-tests.factor +++ b/core/sequences/sequences-tests.factor @@ -43,9 +43,9 @@ IN: temporary [ f ] [ CHAR: a 0 "tuvwxyz" >vector index* ] unit-test -[ f ] [ [ "Hello" { } 4/3 ] [ string? ] all? ] unit-test +[ f ] [ [ "Hello" { } 0.75 ] [ string? ] all? ] unit-test [ t ] [ [ ] [ ] all? ] unit-test -[ t ] [ [ "hi" t 1/2 ] [ ] all? ] unit-test +[ t ] [ [ "hi" t 0.5 ] [ ] all? ] unit-test [ [ 1 2 3 ] ] [ [ 1 4 2 5 3 6 ] [ 4 < ] subset ] unit-test [ { 4 2 6 } ] [ { 1 4 2 5 3 6 } [ 2 mod 0 = ] subset ] unit-test @@ -68,8 +68,8 @@ unit-test [ f ] [ [ { } { } "Hello" ] all-equal? ] unit-test [ f ] [ [ { 2 } { } { } ] all-equal? ] unit-test [ t ] [ [ ] all-equal? ] unit-test -[ t ] [ [ 1/2 ] all-equal? ] unit-test -[ t ] [ [ 1.0 10/10 1 ] all-equal? ] unit-test +[ t ] [ [ 1234 ] all-equal? ] unit-test +[ t ] [ [ 1.0 1 1 ] all-equal? ] unit-test [ t ] [ { 1 2 3 4 } [ < ] monotonic? ] unit-test [ f ] [ { 1 2 3 4 } [ > ] monotonic? ] unit-test [ [ 2 3 4 ] ] [ [ 1 2 3 ] 1 [ + ] curry map ] unit-test @@ -190,7 +190,7 @@ unit-test "cache-test" get ] unit-test -[ 1 ] [ 1/2 { 1 2 3 } nth ] unit-test +[ 1 ] [ 0.5 { 1 2 3 } nth ] unit-test ! Pathological case [ "ihbye" ] [ "hi" "bye" append ] unit-test diff --git a/core/threads/threads-tests.factor b/core/threads/threads-tests.factor index 6965828ff5..b1b2f86a47 100755 --- a/core/threads/threads-tests.factor +++ b/core/threads/threads-tests.factor @@ -8,6 +8,5 @@ IN: temporary [ ] [ [ "Errors, errors" throw ] in-thread ] unit-test yield -[ ] [ 1 2 / sleep ] unit-test [ ] [ 0.3 sleep ] unit-test [ "hey" sleep ] unit-test-fails diff --git a/extra/math/ratios/ratios-tests.factor b/extra/math/ratios/ratios-tests.factor index a0e10b9c9c..fbc8ee3256 100755 --- a/extra/math/ratios/ratios-tests.factor +++ b/extra/math/ratios/ratios-tests.factor @@ -84,6 +84,7 @@ unit-test [ 1 ] [ 1/2 0.5 + ] unit-test [ 1/268435456 ] [ -1 -268435456 >fixnum / ] unit-test +[ 268435456 ] [ -268435456 >fixnum -1 / ] unit-test [ 5 ] [ "10/2" string>number ] From 87944928aa3a3a0bc59984cf990aaa5d349e069b Mon Sep 17 00:00:00 2001 From: "U-SLAVA-FB3999113\\Slava" Date: Sun, 14 Oct 2007 21:30:30 -0400 Subject: [PATCH 07/20] complex/ratios unit test fixes --- extra/math/complex/complex-tests.factor | 46 ++++++++++----------- extra/math/complex/complex.factor | 8 ++-- extra/math/functions/functions-tests.factor | 4 +- extra/math/ratios/ratios-tests.factor | 3 +- 4 files changed, 31 insertions(+), 30 deletions(-) diff --git a/extra/math/complex/complex-tests.factor b/extra/math/complex/complex-tests.factor index 336ed7d4f5..be512e5052 100755 --- a/extra/math/complex/complex-tests.factor +++ b/extra/math/complex/complex-tests.factor @@ -11,36 +11,36 @@ IN: temporary [ C{ 2 5 } ] [ 2 5 rect> ] unit-test [ 2 5 ] [ C{ 2 5 } >rect ] unit-test -[ C{ 1/2 1 } ] [ 1/2 i + ] unit-test -[ C{ 1/2 1 } ] [ i 1/2 + ] unit-test +[ C{ 1/2 1 } ] [ 1/2 C{ 0 1 } + ] unit-test +[ C{ 1/2 1 } ] [ C{ 0 1 } 1/2 + ] unit-test [ t ] [ C{ 11 64 } C{ 11 64 } = ] unit-test -[ C{ 2 1 } ] [ 2 i + ] unit-test -[ C{ 2 1 } ] [ i 2 + ] unit-test +[ C{ 2 1 } ] [ 2 C{ 0 1 } + ] unit-test +[ C{ 2 1 } ] [ C{ 0 1 } 2 + ] unit-test [ C{ 5 4 } ] [ C{ 2 2 } C{ 3 2 } + ] unit-test [ 5 ] [ C{ 2 2 } C{ 3 -2 } + ] unit-test -[ C{ 1.0 1 } ] [ 1.0 i + ] unit-test +[ C{ 1.0 1 } ] [ 1.0 C{ 0 1 } + ] unit-test -[ C{ 1/2 -1 } ] [ 1/2 i - ] unit-test -[ C{ -1/2 1 } ] [ i 1/2 - ] unit-test -[ C{ 1/3 1/4 } ] [ 1 3 / 1 2 / i * + 1 4 / i * - ] unit-test -[ C{ -1/3 -1/4 } ] [ 1 4 / i * 1 3 / 1 2 / i * + - ] unit-test +[ C{ 1/2 -1 } ] [ 1/2 C{ 0 1 } - ] unit-test +[ C{ -1/2 1 } ] [ C{ 0 1 } 1/2 - ] unit-test +[ C{ 1/3 1/4 } ] [ 1 3 / 1 2 / i* + 1 4 / i* - ] unit-test +[ C{ -1/3 -1/4 } ] [ 1 4 / i* 1 3 / 1 2 / i* + - ] unit-test [ C{ 1/5 1/4 } ] [ C{ 3/5 1/2 } C{ 2/5 1/4 } - ] unit-test [ 4 ] [ C{ 5 10/3 } C{ 1 10/3 } - ] unit-test -[ C{ 1.0 -1 } ] [ 1.0 i - ] unit-test +[ C{ 1.0 -1 } ] [ 1.0 C{ 0 1 } - ] unit-test -[ C{ 0 1 } ] [ i 1 * ] unit-test -[ C{ 0 1 } ] [ 1 i * ] unit-test -[ C{ 0 1.0 } ] [ 1.0 i * ] unit-test -[ -1 ] [ i i * ] unit-test -[ C{ 0 1 } ] [ 1 i * ] unit-test -[ C{ 0 1 } ] [ i 1 * ] unit-test -[ C{ 0 1/2 } ] [ 1/2 i * ] unit-test -[ C{ 0 1/2 } ] [ i 1/2 * ] unit-test +[ C{ 0 1 } ] [ C{ 0 1 } 1 * ] unit-test +[ C{ 0 1 } ] [ 1 C{ 0 1 } * ] unit-test +[ C{ 0 1.0 } ] [ 1.0 C{ 0 1 } * ] unit-test +[ -1 ] [ C{ 0 1 } C{ 0 1 } * ] unit-test +[ C{ 0 1 } ] [ 1 C{ 0 1 } * ] unit-test +[ C{ 0 1 } ] [ C{ 0 1 } 1 * ] unit-test +[ C{ 0 1/2 } ] [ 1/2 C{ 0 1 } * ] unit-test +[ C{ 0 1/2 } ] [ C{ 0 1 } 1/2 * ] unit-test [ 2 ] [ C{ 1 1 } C{ 1 -1 } * ] unit-test -[ 1 ] [ i -i * ] unit-test +[ 1 ] [ C{ 0 1 } C{ 0 -1 } * ] unit-test -[ -1 ] [ i -i / ] unit-test -[ C{ 0 1 } ] [ 1 -i / ] unit-test +[ -1 ] [ C{ 0 1 } C{ 0 -1 } / ] unit-test +[ C{ 0 1 } ] [ 1 C{ 0 -1 } / ] unit-test [ t ] [ C{ 12 13 } C{ 13 14 } / C{ 13 14 } * C{ 12 13 } = ] unit-test [ C{ -3 4 } ] [ C{ 3 -4 } neg ] unit-test @@ -52,8 +52,8 @@ IN: temporary [ 0 ] [ 0 arg ] unit-test [ 0 ] [ 1 arg ] unit-test [ t ] [ -1 arg 3.14 3.15 between? ] unit-test -[ t ] [ i arg 1.57 1.58 between? ] unit-test -[ t ] [ -i arg -1.58 -1.57 between? ] unit-test +[ t ] [ C{ 0 1 } arg 1.57 1.58 between? ] unit-test +[ t ] [ C{ 0 -1 } arg -1.58 -1.57 between? ] unit-test [ 1 0 ] [ 1 >polar ] unit-test [ 1 ] [ -1 >polar drop ] unit-test diff --git a/extra/math/complex/complex.factor b/extra/math/complex/complex.factor index 942c0c11d0..ecd548fefb 100755 --- a/extra/math/complex/complex.factor +++ b/extra/math/complex/complex.factor @@ -34,10 +34,10 @@ M: complex sqrt >polar swap fsqrt swap 2.0 / polar> ; M: complex hashcode* nip >rect >fixnum swap >fixnum bitxor ; -M: complex pprint-delims drop \ C{ \ } ; - -M: complex >pprint-sequence >rect 2array ; - IN: syntax : C{ \ } [ first2 rect> ] parse-literal ; parsing + +M: complex pprint-delims drop \ C{ \ } ; + +M: complex >pprint-sequence >rect 2array ; diff --git a/extra/math/functions/functions-tests.factor b/extra/math/functions/functions-tests.factor index fdfa450ede..d957eebd2e 100755 --- a/extra/math/functions/functions-tests.factor +++ b/extra/math/functions/functions-tests.factor @@ -17,8 +17,8 @@ IN: temporary [ 4.0 ] [ 2 2 ^ ] unit-test [ 0.25 ] [ 2 -2 ^ ] unit-test [ t ] [ 2 0.5 ^ 2 ^ 2 2.00001 between? ] unit-test -[ t ] [ e pi i * ^ real -1.0 = ] unit-test -[ t ] [ e pi i * ^ imaginary -0.00001 0.00001 between? ] unit-test +[ t ] [ e pi i* ^ real -1.0 = ] unit-test +[ t ] [ e pi i* ^ imaginary -0.00001 0.00001 between? ] unit-test [ t ] [ 0 0 ^ fp-nan? ] unit-test [ 1.0/0.0 ] [ 0 -2 ^ ] unit-test diff --git a/extra/math/ratios/ratios-tests.factor b/extra/math/ratios/ratios-tests.factor index fbc8ee3256..79b0b21d28 100755 --- a/extra/math/ratios/ratios-tests.factor +++ b/extra/math/ratios/ratios-tests.factor @@ -1,4 +1,5 @@ -USING: kernel math math.parser tools.test ; +USING: kernel math math.parser math.ratios math.functions +tools.test ; IN: temporary [ 1 2 ] [ 1/2 >fraction ] unit-test From b4b4c599c6d0788ed81017ef7ac8e5459a6ad674 Mon Sep 17 00:00:00 2001 From: "U-SLAVA-FB3999113\\Slava" Date: Mon, 15 Oct 2007 19:59:03 -0400 Subject: [PATCH 08/20] Updating ARM optimizing compiler backend --- .../intrinsics.factor => arm/4/4.factor} | 2 +- core/cpu/{arm5 => arm/4}/authors.txt | 0 core/cpu/arm/4/summary.txt | 1 + core/cpu/arm/5/5.factor | 3 + core/cpu/arm/5/authors.txt | 1 + core/cpu/{arm5 => arm/5}/summary.txt | 0 core/cpu/arm/allot/allot.factor | 61 ++--- core/cpu/arm/architecture/architecture.factor | 91 ++++--- core/cpu/arm/arm.factor | 42 +-- core/cpu/arm/assembler/assembler.factor | 76 +++++- core/cpu/arm/bootstrap.factor | 6 +- core/cpu/arm/intrinsics/intrinsics.factor | 250 +++++++++++------- core/cpu/arm5/arm5.factor | 4 - core/cpu/arm5/assembler/assembler.factor | 74 ------ core/cpu/ppc/architecture/architecture.factor | 12 +- core/generator/generator.factor | 1 + 16 files changed, 338 insertions(+), 286 deletions(-) rename core/cpu/{arm5/intrinsics/intrinsics.factor => arm/4/4.factor} (98%) mode change 100644 => 100755 rename core/cpu/{arm5 => arm/4}/authors.txt (100%) create mode 100644 core/cpu/arm/4/summary.txt create mode 100755 core/cpu/arm/5/5.factor create mode 100644 core/cpu/arm/5/authors.txt rename core/cpu/{arm5 => arm/5}/summary.txt (100%) mode change 100644 => 100755 core/cpu/arm/arm.factor mode change 100644 => 100755 core/cpu/arm/assembler/assembler.factor delete mode 100644 core/cpu/arm5/arm5.factor delete mode 100644 core/cpu/arm5/assembler/assembler.factor mode change 100644 => 100755 core/generator/generator.factor diff --git a/core/cpu/arm5/intrinsics/intrinsics.factor b/core/cpu/arm/4/4.factor old mode 100644 new mode 100755 similarity index 98% rename from core/cpu/arm5/intrinsics/intrinsics.factor rename to core/cpu/arm/4/4.factor index d6f651b0e2..0d317fd553 --- a/core/cpu/arm5/intrinsics/intrinsics.factor +++ b/core/cpu/arm/4/4.factor @@ -6,7 +6,7 @@ math math.private namespaces sequences words quotations byte-arrays hashtables.private hashtables generator generator.registers generator.fixup sequences.private strings.private ; -IN: cpu.arm5.intrinsics +IN: cpu.arm4 : (%char-slot) "out" operand string-offset MOV diff --git a/core/cpu/arm5/authors.txt b/core/cpu/arm/4/authors.txt similarity index 100% rename from core/cpu/arm5/authors.txt rename to core/cpu/arm/4/authors.txt diff --git a/core/cpu/arm/4/summary.txt b/core/cpu/arm/4/summary.txt new file mode 100644 index 0000000000..7be5231690 --- /dev/null +++ b/core/cpu/arm/4/summary.txt @@ -0,0 +1 @@ +Additional compiler intrinsics for ARM4 diff --git a/core/cpu/arm/5/5.factor b/core/cpu/arm/5/5.factor new file mode 100755 index 0000000000..ae07345cd1 --- /dev/null +++ b/core/cpu/arm/5/5.factor @@ -0,0 +1,3 @@ +USING: cpu.arm.assembler cpu.arm4 namespaces ; + +t have-BLX? set-global diff --git a/core/cpu/arm/5/authors.txt b/core/cpu/arm/5/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/core/cpu/arm/5/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/core/cpu/arm5/summary.txt b/core/cpu/arm/5/summary.txt similarity index 100% rename from core/cpu/arm5/summary.txt rename to core/cpu/arm/5/summary.txt diff --git a/core/cpu/arm/allot/allot.factor b/core/cpu/arm/allot/allot.factor index 2081a07f35..c70c1090c2 100755 --- a/core/cpu/arm/allot/allot.factor +++ b/core/cpu/arm/allot/allot.factor @@ -8,31 +8,28 @@ IN: cpu.arm.allot : load-zone-ptr ( reg -- ) "nursery" f rot %alien-global ; -: object@ "allot-tmp" operand swap cells <+> ; - : %allot ( header size -- ) #! Store a pointer to 'size' bytes allocated from the - #! nursery in allot-tmp. + #! nursery in R11 8 align ! align the size R12 load-zone-ptr ! nusery -> r12 - "allot-tmp" operand R12 cell <+> LDR ! nursery.here -> allot-tmp - "allot-tmp" operand dup pick ADD ! increment allot-tmp - "allot-tmp" operand R12 cell <+> STR ! allot-tmp -> nursery.here - "allot-tmp" operand dup rot SUB ! old value + R11 R12 cell <+> LDR ! nursery.here -> r11 + R11 R11 pick ADD ! increment r11 + R11 R12 cell <+> STR ! r11 -> nursery.here + R11 R11 rot SUB ! old value R12 swap type-number tag-header MOV ! compute header - R12 0 object@ STR ! store header + R12 R11 0 <+> STR ! store header ; -: %tag-allot ( tag -- ) - "allot-tmp" operand dup rot tag-number ORR - "allot-tmp" get fresh-object ; +: %store-tagged ( reg tag -- ) + >r dup fresh-object v>operand R11 r> tag-number ORI ; : %allot-bignum ( #digits -- ) #! 1 cell header, 1 cell length, 1 cell sign, + digits #! length is the # of digits + sign bignum over 3 + cells %allot R12 swap 1+ v>operand MOV ! compute the length - R12 1 object@ STR ! store the length + R12 R11 cell <+> STR ! store the length ; : %allot-bignum-signed-1 ( reg -- ) @@ -43,7 +40,7 @@ IN: cpu.arm.allot "end" define-label ! is it zero? dup v>operand 0 CMP - 0 >bignum "allot-tmp" operand EQ load-indirect + 0 >bignum over EQ load-literal "end" get EQ B ! ! it is non-zero 1 %allot-bignum @@ -56,29 +53,27 @@ IN: cpu.arm.allot ! positive sign R12 0 GE MOV ! store sign - R12 2 object@ STR + R12 R11 2 cells <+> STR ! store the number - v>operand 3 object@ STR + dup v>operand R11 3 cells <+> STR ! tag the bignum, store it in reg bignum %tag-allot "end" resolve-label ] with-scope ; -: %allot-alien ( ptr -- ) - #! Tagged pointer to alien is in allot-tmp on exit. - [ - "temp" set - "end" define-label - "temp" operand 0 CMP - "allot-tmp" operand f v>operand EQ MOV - "end" get EQ B - alien 4 cells %allot - "temp" operand 2 object@ STR - "temp" operand f v>operand MOV - "temp" operand 1 object@ STR - "temp" operand 0 MOV - "temp" operand 3 object@ STR - ! Store tagged ptr in reg - object %tag-allot - "end" resolve-label - ] with-scope ; +M: arm-backend %box-alien ( dst src -- ) + "end" define-label + dup v>operand 0 CMP + over f v>operand EQ MOV + "end" get EQ B + alien 4 cells %allot + ! Store offset + v>operand R11 3 cells <+> STR + R12 f v>operand R12 + ! Store expired slot + R12 R11 1 cells <+> STR + ! Store underlying-alien slot + R12 R11 2 cells <+> STR + ! Store tagged ptr in reg + object %store-tagged + "end" resolve-label ; diff --git a/core/cpu/arm/architecture/architecture.factor b/core/cpu/arm/architecture/architecture.factor index 527daed7c4..7e077b4a22 100755 --- a/core/cpu/arm/architecture/architecture.factor +++ b/core/cpu/arm/architecture/architecture.factor @@ -9,8 +9,8 @@ IN: cpu.arm.architecture TUPLE: arm-backend ; ! ARM register assignments: -! R0, R1, R2, R3 integer vregs -! R12 temporary +! R0-R4, R7-R10 integer vregs +! R11, R12 temporary ! R5 data stack ! R6 retain stack ! R7 primitives @@ -22,7 +22,7 @@ M: temp-reg v>operand drop R12 ; M: int-regs return-reg drop R0 ; M: int-regs param-regs drop { R0 R1 R2 R3 } ; -M: int-regs vregs drop { R0 R1 R2 R3 R4 R7 R8 R9 R10 R11 } ; +M: int-regs vregs drop { R0 R1 R2 R3 R4 R7 R8 R9 R10 } ; ! No FPU support yet M: float-regs param-regs drop { } ; @@ -44,15 +44,27 @@ M: immediate load-literal v>operand load-indirect ] if ; -M: arm-backend stack-frame ( n -- i ) 4 + 8 align ; +: lr-save ( n -- i ) cell - ; +: next-save ( n -- i ) 2 cells - ; +: xt-save ( n -- i ) 3 cells - ; +: factor-area-size 5 cells ; + +M: arm-backend stack-frame ( n -- i ) + factor-area-size + 8 align ; + +M: ppc-backend %save-xt ( -- ) + R12 PC 8 SUB ; M: arm-backend %prologue ( n -- ) - LR SP 4 <-> STR - SP SP rot stack-frame SUB ; + SP SP pick SUB + R11 over LI + R11 SP pick next-save <+> STR + R12 SP rot xt-save <+> STR + LR SP pick lr-save <+> STR ; M: arm-backend %epilogue ( n -- ) - SP SP rot stack-frame ADD - LR SP 4 <-> LDR ; + LR SP lr-save <+> LDR + SP SP rot stack-frame ADD ; : compile-dlsym ( symbol dll reg -- ) [ @@ -83,26 +95,32 @@ M: arm-backend %profiler-prologue ( word -- ) R0 R12 profile-count-offset <+> STR "end" resolve-label ; -: primitive-addr ( word dst -- ) - #! Load a word address into dst. - R7 rot word-primitive cells <+> LDR ; +M: arm-backend %call-label ( label -- ) BL ; -M: arm-backend %call ( label -- ) - #! Far C call for primitives, near C call for compiled defs. - dup primitive? [ R0 primitive-addr R0 BLX ] [ BL ] if ; +M: arm-backend %jump-label ( label -- ) B ; -M: arm-backend %jump-label ( label -- ) - #! For tail calls. IP not saved on C stack. - #! WARNING: don't clobber LR here! - dup primitive? [ PC primitive-addr ] [ B ] if ; +: %load-xt ( word -- ) + 0 swap LOAD32 rc-absolute-ppc-2/2 rel-word ; + +: %prepare-primitive ( word -- ) + #! Save stack pointer to stack_chain->callstack_top, load XT + R1 SP MOV + T{ temp-reg } load-literal + R12 R12 word-xt-offset <+> LDR ; + +M: arm-backend %call-primitive ( word -- ) + %prepare-primitive R12 BLX ; + +M: arm-backend %jump-primitive ( word -- ) + %prepare-primitive R12 BX ; M: arm-backend %jump-t ( label -- ) - "flag" operand object tag-number CMP NE B ; + "flag" operand f v>operand CMP NE B ; : (%dispatch) ( word-table# reg -- ) #! Load jump table target address into reg. - "n" operand PC "n" operand 1 ADD - "n" operand 0 <+> LDR + "scratch" operand PC "n" operand 1 ADD + "scratch" operand 0 <+> LDR rc-indirect-arm rel-dispatch ; M: arm-backend %call-dispatch ( word-table# -- ) @@ -112,7 +130,6 @@ M: arm-backend %call-dispatch ( word-table# -- ) ] H{ { +input+ { { f "n" } } } { +scratch+ { { f "scratch" } } } - { +clobber+ { "n" } } } with-template ; M: arm-backend %jump-dispatch ( word-table# -- ) @@ -121,7 +138,7 @@ M: arm-backend %jump-dispatch ( word-table# -- ) PC (%dispatch) ] H{ { +input+ { { f "n" } } } - { +clobber+ { "n" } } + { +scratch+ { { f "scratch" } } } } with-template ; M: arm-backend %return ( -- ) %epilogue-later PC LR MOV ; @@ -134,9 +151,6 @@ M: arm-backend %unwind drop %return ; M: int-regs (%peek) \ LDR (%peek/replace) ; M: int-regs (%replace) \ STR (%peek/replace) ; -M: arm-backend %move-int>int ( dst src -- ) - [ v>operand ] 2apply MOV ; - : (%inc) ( n reg -- ) dup rot cells dup 0 < [ neg SUB ] [ ADD ] if ; @@ -215,11 +229,13 @@ M: arm-backend %box-small-struct ( size -- ) R2 swap MOV "box_small_struct" f %alien-invoke ; +: temp@ stack-frame* factor-area-size - swap - ; + : struct-return@ ( size n -- n ) [ stack-frame* + ] [ - stack-frame* swap - cell - + stack-frame* factor-area-size - swap - ] ?if ; M: arm-backend %prepare-box-struct ( size -- ) @@ -239,6 +255,15 @@ M: arm-backend %box-large-struct ( n size -- ) M: arm-backend struct-small-enough? ( size -- ? ) wince? [ drop f ] [ 4 <= ] if ; +M: ppc-backend %prepare-alien-invoke + #! Save Factor stack pointers in case the C code calls a + #! callback which does a GC, which must reliably trace + #! all roots. + "stack_chain" f R12 %alien-global + SP R12 0 <+> STR + ds-reg 11 8 <+> STR + rs-reg 11 12 <+> STR ; + M: arm-backend %alien-invoke ( symbol dll -- ) ! Load target address R12 PC 4 <+> LDR @@ -249,15 +274,13 @@ M: arm-backend %alien-invoke ( symbol dll -- ) ! The target address 0 , rc-absolute rel-dlsym ; -: temp@ SP stack-frame* 2 cells - <+> ; - M: arm-backend %prepare-alien-indirect ( -- ) "unbox_alien" f %alien-invoke - R0 temp@ STR ; + R0 SP cell temp@ <+> STR ; M: arm-backend %alien-indirect ( -- ) - IP temp@ LDR - IP BLX ; + R12 SP cell temp@ <+> LDR + R12 BLX ; M: arm-backend %alien-callback ( quot -- ) R0 load-indirect @@ -266,11 +289,11 @@ M: arm-backend %alien-callback ( quot -- ) M: arm-backend %callback-value ( ctype -- ) ! Save top of data stack %prepare-unbox - R0 temp@ STR + R0 SP cell temp@ <+> STR ! Restore data/call/retain stacks "unnest_stacks" f %alien-invoke ! Place former top of data stack in R0 - R0 temp@ LDR + R0 SP cell temp@ <+> LDR ! Unbox R0 unbox-return ; diff --git a/core/cpu/arm/arm.factor b/core/cpu/arm/arm.factor old mode 100644 new mode 100755 index 111044a552..afe6411d97 --- a/core/cpu/arm/arm.factor +++ b/core/cpu/arm/arm.factor @@ -24,27 +24,29 @@ vocabs.loader ; T{ arm-backend } compiler-backend set-global -: (detect-arm5) ; - -\ (detect-arm5) [ - ! The LDRH word is defined in the module we conditionally - ! load below... - ! R0 PC 0 <+> LDRH - HEX: e1df00b0 , -] H{ - { +scratch+ { { 0 "scratch" } } } -} define-intrinsic - -: detect-arm5 (detect-arm5) ; - -: arm5? ( -- ? ) [ detect-arm5 ] catch not ; +! We don't auto-detect since that would require us to support +! illegal instruction traps. This works on Linux but not on +! Windows CE. "arm-variant" get [ - \ detect-arm5 compile - "Detecting ARM architecture variant..." print - arm5? "arm5" "arm3" ? "arm-variant" set -] unless + "ARM variant: " write "arm-variant" get print +] [ + "==========" print + "You should specify the -arm-variant= switch." print + " can be one of arm3, arm4, arm4t, or arm5." print + "Assuming arm4t." print + "==========" print + "arm4t" "arm-variant" set +] if -"ARM architecture variant: " write "arm-variant" get print +"arm-variant" get { "arm4" "arm4t" "arm5" } member? [ + "cpu.arm.4" require +] when -"arm-variant" "arm5" = [ "cpu.arm5" require ] when +"arm-variant" get { "arm4t" "arm5" } member? [ + t have-BX? set-global +] when + +"arm-variant" get "arm5" = [ + t have-BLX? set-global +] when diff --git a/core/cpu/arm/assembler/assembler.factor b/core/cpu/arm/assembler/assembler.factor old mode 100644 new mode 100755 index 0152380547..e61e02ae8d --- a/core/cpu/arm/assembler/assembler.factor +++ b/core/cpu/arm/assembler/assembler.factor @@ -4,8 +4,6 @@ USING: arrays generator generator.fixup kernel sequences words namespaces math math.bitfields ; IN: cpu.arm.assembler -SYMBOL: arm-variant - : define-registers ( seq -- ) dup length [ "register" set-word-prop ] 2each ; @@ -253,15 +251,77 @@ M: object addressing-mode-2 shifter-op { { 1 25 } 0 } bitfield ; : STR 0 0 addr2 ; : STRB 1 0 addr2 ; -HOOK: BX arm-variant ( operand -- ) - -HOOK: BLX arm-variant ( operand -- ) - ! We might have to simulate these instructions since older ARM ! chips don't have them. -M: f BX PC swap MOV ; +SYMBOL: have-BX? +SYMBOL: have-BLX? -M: f BLX LR PC MOV BX ; +GENERIC# (BX) 1 ( Rm l -- ) + +M: register (BX) ( Rm l -- ) + { + { 1 24 } + { 1 21 } + { BIN: 1111 16 } + { BIN: 1111 12 } + { BIN: 1111 8 } + 5 + { 1 4 } + { register 0 } + } insn ; + +M: word (BX) 0 swap (BX) rc-relative-arm-3 rel-word ; + +M: label (BX) 0 swap (BX) rc-relative-arm-3 label-fixup ; + +: BX have-BX? get [ 0 (BX) ] [ PC swap MOV ] if ; + +: BLX have-BLX? get [ 1 (BLX) ] [ LR PC MOV BX ] if ; + +! More load and store instructions +GENERIC: addressing-mode-3 ( addressing-mode -- n ) + +: b>n/n ( b -- n n ) dup -4 shift swap HEX: f bitand ; + +M: addressing addressing-mode-3 + [ addressing-p ] keep + [ addressing-u ] keep + [ addressing-w ] keep + delegate addressing-mode-3 + { 0 21 23 24 } bitfield ; + +M: integer addressing-mode-3 + b>n/n { + ! { 1 24 } + { 1 22 } + { 1 7 } + { 1 4 } + 0 + 8 + } bitfield ; + +M: object addressing-mode-3 + shifter-op { + ! { 1 24 } + { 1 7 } + { 1 4 } + 0 + } bitfield ; + +: addr3 ( Rn Rd addressing-mode h l s -- ) + { + 6 + 20 + 5 + { addressing-mode-3 0 } + { register 16 } + { register 12 } + } insn ; + +: LDRH 1 1 0 addr3 ; +: LDRSB 0 1 1 addr3 ; +: LDRSH 1 1 1 addr3 ; +: STRH 1 0 0 addr3 ; ! Load and store multiple instructions diff --git a/core/cpu/arm/bootstrap.factor b/core/cpu/arm/bootstrap.factor index 3054a0bb85..4f67255305 100755 --- a/core/cpu/arm/bootstrap.factor +++ b/core/cpu/arm/bootstrap.factor @@ -1,9 +1,11 @@ ! Copyright (C) 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: bootstrap.image.private kernel namespaces system -cpu.arm.assembler math layouts words vocabs ; +cpu.arm.assembler cpu.arm5.assembler math layouts words vocabs ; IN: bootstrap.arm +T{ arm5-variant } arm-variant set-global + 4 \ cell set big-endian off @@ -17,7 +19,7 @@ big-endian off : temp-reg R3 ; : xt-reg R12 ; -: stack-frame 8 bootstrap-cells ; +: stack-frame 16 bootstrap-cells ; : next-save stack-frame 2 bootstrap-cells - ; : xt-save stack-frame 3 bootstrap-cells - ; diff --git a/core/cpu/arm/intrinsics/intrinsics.factor b/core/cpu/arm/intrinsics/intrinsics.factor index 218cdc9fb9..18cfb7d3de 100755 --- a/core/cpu/arm/intrinsics/intrinsics.factor +++ b/core/cpu/arm/intrinsics/intrinsics.factor @@ -9,27 +9,45 @@ sbufs.private vectors vectors.private system tuples.private layouts strings.private slots.private ; IN: cpu.arm.intrinsics +: %slot-literal-known-tag + "val" operand + "obj" operand + "n" get cells + "obj" get operand-tag - <+/-> ; + +: %slot-literal-any-tag + "obj" operand "scratch" operand %untag + "val" operand "scratch" operand "n" get cells <+> ; + +: %slot-any + "obj" operand "scratch" operand %untag + "n" operand dup 1 MOV + "scratch" operand "val" operand "n" operand <+> ; + \ slot { + ! Slot number is literal and the tag is known + { + [ %slot-literal-known-tag LDR ] H{ + { +input+ { { f "obj" known-tag } { [ small-slot? ] "n" } } } + { +scratch+ { { f "val" } } } + { +output+ { "val" } } + } + } ! Slot number is literal { - [ - "out" operand "obj" operand %untag - "out" operand dup "n" get cells <+> LDR - ] H{ + [ %slot-literal-any-tag LDR ] H{ { +input+ { { f "obj" } { [ small-slot? ] "n" } } } - { +scratch+ { { f "out" } } } - { +output+ { "out" } } + { +scratch+ { { f "scratch" } { f "val" } } } + { +output+ { "val" } } } } ! Slot number in a register { - [ - "out" operand "obj" operand %untag - "out" operand dup "n" operand 1 <+> LDR - ] H{ + [ %slot-any LDR ] H{ { +input+ { { f "obj" } { f "n" } } } - { +scratch+ { { f "out" } } } - { +output+ { "out" } } + { +scratch+ { { f "val" } { f "scratch" } } } + { +output+ { "val" } } + { +clobber+ { "n" } } } } } define-intrinsics @@ -44,13 +62,17 @@ IN: cpu.arm.intrinsics ] unless ; \ set-slot { + ! Slot number is literal and tag is known + { + [ %slot-literal-known-tag STR %write-barrier ] H{ + { +input+ { { f "val" } { f "obj" known-tag } { [ small-slot? ] "n" } } } + { +scratch+ { { f "scratch" } } } + { +clobber+ { "val" } } + } + } ! Slot number is literal { - [ - "scratch" operand "obj" operand %untag - "val" operand "scratch" operand "n" get cells <+> STR - generate-write-barrier - ] H{ + [ %slot-literal-any-tag STR %write-barrier ] H{ { +input+ { { f "val" } { f "obj" } { [ small-slot? ] "n" } } } { +scratch+ { { f "scratch" } } } { +clobber+ { "val" } } @@ -58,12 +80,7 @@ IN: cpu.arm.intrinsics } ! Slot number is in a register { - [ - "scratch" operand "obj" operand %untag - "n" operand "scratch" operand "n" operand 1 ADD - "val" operand "n" operand 0 STR - generate-write-barrier - ] H{ + [ %slot-any STR %write-barrier ] H{ { +input+ { { f "val" } { f "obj" } { f "n" } } } { +scratch+ { { f "scratch" } } } { +clobber+ { "val" "n" } } @@ -135,7 +152,7 @@ IN: cpu.arm.intrinsics : overflow-check ( insn -- ) [ "end" define-label - [ "allot-tmp" operand "x" operand "y" operand roll S execute ] keep + [ "out" operand "x" operand "y" operand roll S execute ] keep "end" get VC B { "x" "y" } %untag-fixnums "x" operand "x" operand "y" operand roll execute @@ -146,8 +163,8 @@ IN: cpu.arm.intrinsics : overflow-template ( word insn -- ) [ overflow-check ] curry H{ { +input+ { { f "x" } { f "y" } } } - { +scratch+ { { f "allot-tmp" } } } - { +output+ { "allot-tmp" } } + { +scratch+ { { f "out" } } } + { +output+ { "out" } } { +clobber+ { "x" "y" } } } define-intrinsic ; @@ -159,9 +176,9 @@ IN: cpu.arm.intrinsics "x" get %allot-bignum-signed-1 ] H{ { +input+ { { f "x" } } } - { +scratch+ { { f "allot-tmp" } } } + { +scratch+ { { f "out" } } } { +clobber+ { "x" } } - { +output+ { "allot-tmp" } } + { +output+ { "out" } } } define-intrinsic \ bignum>fixnum [ @@ -224,28 +241,39 @@ IN: cpu.arm.intrinsics } define-intrinsic \ type [ + ! Get the tag + "out" operand "obj" operand tag-mask get AND + ! Compare with object tag number (3). + "out" operand object tag-number CMP + ! Tag the tag if it is not equal to 3 + "out" operand dup NE %tag-fixnum + ! Load the object header if tag is equal to 3 + "out" operand "obj" operand object tag-number <-> EQ LDR +] H{ + { +input+ { { f "obj" } } } + { +scratch+ { { f "out" } } } + { +output+ { "out" } } +} define-intrinsic + +\ class-hash [ "end" define-label ! Get the tag - "y" operand "obj" operand tag-mask get AND + "out" operand "obj" operand tag-mask get AND + ! Compare with tuple tag number (2). + "out" operand tuple tag-number CMP + "out" operand "obj" operand tuple-class-offset <+/-> EQ LDR + "out" operand dup class-hash-offset <+/-> EQ LDR + "end" get EQ B ! Compare with object tag number (3). - "y" operand object tag-number CMP - ! Tag the tag if it is not equal to 3 - "x" operand "y" operand NE %tag-fixnum - ! Jump to end if it is not equal to 3 - "end" get NE B - ! Is the pointer itself equal to 3? Then its F_TYPE (9). - "obj" operand object tag-number CMP - ! Load F_TYPE (9) if it is equal - "x" operand f type v>operand EQ MOV - ! Load the object header if it is not equal - "x" operand "obj" operand object tag-number <-> NE LDR - ! Turn the header into a fixnum - "x" operand dup NE %untag + "out" operand object tag-number CMP + "out" operand "obj" operand object tag-number <-> EQ LDR + ! Tag the tag + "out" operand dup NE %tag-fixnum "end" resolve-label ] H{ { +input+ { { f "obj" } } } - { +scratch+ { { f "x" } { f "y" } } } - { +output+ { "x" } } + { +scratch+ { { f "out" } } } + { +output+ { "out" } } } define-intrinsic : userenv ( reg -- ) @@ -273,7 +301,7 @@ IN: cpu.arm.intrinsics { +clobber+ { "n" } } } define-intrinsic -: %set-slot "allot-tmp" operand swap cells <+> STR ; +: %set-slot R11 swap cells <+> STR ; : %store-length R12 "n" operand MOV @@ -289,11 +317,11 @@ IN: cpu.arm.intrinsics ! Zero out the rest of the tuple R12 f v>operand MOV "n" get 1- [ 1+ R12 %fill-array ] each - object %tag-allot + "out" get object %store-tagged ] H{ { +input+ { { f "class" } { [ inline-array? ] "n" } } } - { +scratch+ { { f "allot-tmp" } } } - { +output+ { "allot-tmp" } } + { +scratch+ { { f "out" } } } + { +output+ { "out" } } } define-intrinsic \ [ @@ -301,11 +329,11 @@ IN: cpu.arm.intrinsics %store-length ! Store initial element "n" get [ "initial" operand %fill-array ] each - object %tag-allot + "out" get object %store-tagged ] H{ { +input+ { { [ inline-array? ] "n" } { f "initial" } } } - { +scratch+ { { f "allot-tmp" } } } - { +output+ { "allot-tmp" } } + { +scratch+ { { f "out" } } } + { +output+ { "out" } } } define-intrinsic \ [ @@ -314,22 +342,22 @@ IN: cpu.arm.intrinsics ! Store initial element R12 0 MOV "n" get cell align cell /i [ R12 %fill-array ] each - object %tag-allot + "out" get object %store-tagged ] H{ { +input+ { { [ inline-array? ] "n" } } } - { +scratch+ { { f "allot-tmp" } } } - { +output+ { "allot-tmp" } } + { +scratch+ { { f "out" } } } + { +output+ { "out" } } } define-intrinsic \ [ ratio 3 cells %allot "numerator" operand 1 %set-slot "denominator" operand 2 %set-slot - ratio %tag-allot + "out" get ratio %store-tagged ] H{ { +input+ { { f "numerator" } { f "denominator" } } } - { +scratch+ { { f "allot-tmp" } } } - { +output+ { "allot-tmp" } } + { +scratch+ { { f "out" } } } + { +output+ { "out" } } } define-intrinsic \ [ @@ -337,22 +365,22 @@ IN: cpu.arm.intrinsics "real" operand 1 %set-slot "imaginary" operand 2 %set-slot ! Store tagged ptr in reg - complex %tag-allot + "out" get complex %store-tagged ] H{ { +input+ { { f "real" } { f "imaginary" } } } - { +scratch+ { { f "allot-tmp" } } } - { +output+ { "allot-tmp" } } + { +scratch+ { { f "out" } } } + { +output+ { "out" } } } define-intrinsic \ [ wrapper 2 cells %allot "obj" operand 1 %set-slot ! Store tagged ptr in reg - wrapper %tag-allot + "out" get object %store-tagged ] H{ { +input+ { { f "obj" } } } - { +scratch+ { { f "allot-tmp" } } } - { +output+ { "allot-tmp" } } + { +scratch+ { { f "out" } } } + { +output+ { "out" } } } define-intrinsic \ (hashtable) [ @@ -362,80 +390,82 @@ IN: cpu.arm.intrinsics R12 2 %set-slot R12 3 %set-slot ! Store tagged ptr in reg - object %tag-allot + "out" get object %store-tagged ] H{ - { +scratch+ { { f "allot-tmp" } } } - { +output+ { "allot-tmp" } } + { +scratch+ { { f "out" } } } + { +output+ { "out" } } } define-intrinsic \ string>sbuf [ sbuf 3 cells %allot "length" operand 1 %set-slot "string" operand 2 %set-slot - object %tag-allot + "out" get object %store-tagged ] H{ { +input+ { { f "string" } { f "length" } } } - { +scratch+ { { f "allot-tmp" } } } - { +output+ { "allot-tmp" } } + { +scratch+ { { f "out" } } } + { +output+ { "out" } } } define-intrinsic \ array>vector [ vector 3 cells %allot "length" operand 1 %set-slot "array" operand 2 %set-slot - object %tag-allot + "out" get object %store-tagged ] H{ { +input+ { { f "array" } { f "length" } } } - { +scratch+ { { f "allot-tmp" } } } - { +output+ { "allot-tmp" } } + { +scratch+ { { f "out" } } } + { +output+ { "out" } } } define-intrinsic \ curry [ \ curry 3 cells %allot "obj" operand 1 %set-slot "quot" operand 2 %set-slot - object %tag-allot + "out" get object %store-tagged ] H{ { +input+ { { f "obj" } { f "quot" } } } - { +scratch+ { { f "allot-tmp" } } } - { +output+ { "allot-tmp" } } + { +scratch+ { { f "out" } } } + { +output+ { "out" } } } define-intrinsic ! Alien intrinsics +: %alien-accessor ( 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" c-ptr } { f "offset" fixnum } } } - { +scratch+ { { f "output" } } } - { +output+ { "output" } } + { +scratch+ { { f "value" } } } + { +output+ { "value" } } { +clobber+ { "offset" } } } ; -: %alien-get ( quot -- ) - "output" get "address" set - "output" operand "alien" operand-class %alien-accessor ; - : %alien-integer-get ( quot -- ) - %alien-get - "output" operand dup %tag-fixnum ; inline - -: %alien-integer-set ( quot -- ) - "value" operand dup %untag-fixnum - "value" operand "alien" operand-class %alien-accessor ; inline + %alien-accessor + "value" operand dup %tag-fixnum ; inline : alien-integer-set-template H{ { +input+ { { f "value" fixnum } - { f "alien" simple-c-ptr } + { unboxed-c-ptr "alien" 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-accessor ; inline + : define-alien-integer-intrinsics ( word get-quot word set-quot -- ) [ %alien-integer-set ] curry alien-integer-set-template @@ -448,15 +478,31 @@ IN: cpu.arm.intrinsics \ set-alien-unsigned-1 [ STRB ] define-alien-integer-intrinsics -\ alien-cell [ - [ LDR ] %alien-get - "output" get %allot-alien -] H{ - { +input+ { - { f "alien" simple-c-ptr } - { f "offset" fixnum } - } } - { +scratch+ { { f "output" } { f "allot-tmp" } } } - { +output+ { "allot-tmp" } } - { +clobber+ { "offset" } } -} define-intrinsic +: alien-cell-template + H{ + { +input+ { + { unboxed-c-ptr "alien" c-ptr } + { f "offset" fixnum } + } } + { +scratch+ { { unboxed-alien "value" } } } + { +output+ { "value" } } + { +clobber+ { "offset" } } + } ; + +\ alien-cell +[ [ LDR ] %alien-accessor ] +alien-cell-template define-intrinsic + +: set-alien-cell-template + H{ + { +input+ { + { unboxed-c-ptr "value" pinned-c-ptr } + { unboxed-c-ptr "alien" c-ptr } + { f "offset" fixnum } + } } + { +clobber+ { "offset" } } + } ; + +\ set-alien-cell +[ [ STR ] %alien-accessor ] +set-alien-cell-template define-intrinsic diff --git a/core/cpu/arm5/arm5.factor b/core/cpu/arm5/arm5.factor deleted file mode 100644 index 11675f106a..0000000000 --- a/core/cpu/arm5/arm5.factor +++ /dev/null @@ -1,4 +0,0 @@ -USING: cpu.arm.assembler cpu.arm5.assembler cpu.arm5.intrinsics -namespaces ; - -T{ arm5-variant } arm-variant set-global diff --git a/core/cpu/arm5/assembler/assembler.factor b/core/cpu/arm5/assembler/assembler.factor deleted file mode 100644 index 237394af11..0000000000 --- a/core/cpu/arm5/assembler/assembler.factor +++ /dev/null @@ -1,74 +0,0 @@ -! Copyright (C) 2007 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: arrays generator generator.fixup kernel sequences words -namespaces math math.bitfields cpu.arm.assembler ; -IN: cpu.arm5.assembler - -TUPLE: arm5-variant ; - -GENERIC# (BX) 1 ( Rm l -- ) - -M: register (BX) ( Rm l -- ) - { - { 1 24 } - { 1 21 } - { BIN: 1111 16 } - { BIN: 1111 12 } - { BIN: 1111 8 } - 5 - { 1 4 } - { register 0 } - } insn ; - -M: word (BX) 0 swap (BX) rc-relative-arm-3 rel-word ; - -M: label (BX) 0 swap (BX) rc-relative-arm-3 label-fixup ; - -M: arm5-variant BX 0 (BX) ; - -M: arm5-variant BLX 1 (BX) ; - -! More load and store instructions -GENERIC: addressing-mode-3 ( addressing-mode -- n ) - -: b>n/n ( b -- n n ) dup -4 shift swap HEX: f bitand ; - -M: addressing addressing-mode-3 - [ addressing-p ] keep - [ addressing-u ] keep - [ addressing-w ] keep - delegate addressing-mode-3 - { 0 21 23 24 } bitfield ; - -M: integer addressing-mode-3 - b>n/n { - ! { 1 24 } - { 1 22 } - { 1 7 } - { 1 4 } - 0 - 8 - } bitfield ; - -M: object addressing-mode-3 - shifter-op { - ! { 1 24 } - { 1 7 } - { 1 4 } - 0 - } bitfield ; - -: addr3 ( Rn Rd addressing-mode h l s -- ) - { - 6 - 20 - 5 - { addressing-mode-3 0 } - { register 16 } - { register 12 } - } insn ; - -: LDRH 1 1 0 addr3 ; -: LDRSB 0 1 1 addr3 ; -: LDRSH 1 1 1 addr3 ; -: STRH 1 0 0 addr3 ; diff --git a/core/cpu/ppc/architecture/architecture.factor b/core/cpu/ppc/architecture/architecture.factor index 508a46b4a7..ba2f90c7ed 100755 --- a/core/cpu/ppc/architecture/architecture.factor +++ b/core/cpu/ppc/architecture/architecture.factor @@ -15,10 +15,8 @@ TUPLE: ppc-backend ; ! r14: data stack ! r15: retain stack -! For stack frame layout, see vm/cpu-ppc.h. - -: ds-reg 14 ; -: rs-reg 15 ; +: ds-reg 14 ; inline +: rs-reg 15 ; inline : reserved-area-size os { @@ -59,13 +57,11 @@ M: int-regs vregs } ; M: float-regs return-reg drop 1 ; - M: float-regs param-regs drop os H{ { "macosx" { 1 2 3 4 5 6 7 8 9 10 11 12 13 } } { "linux" { 1 2 3 4 5 6 7 8 } } } at ; - M: float-regs vregs drop { 0 1 2 3 4 5 6 7 8 9 10 11 12 13 } ; GENERIC: loc>operand ( loc -- reg n ) @@ -123,7 +119,7 @@ M: ppc-backend %call-label ( label -- ) BL ; M: ppc-backend %jump-label ( label -- ) B ; : %prepare-primitive ( word -- ) - ! Save stack pointer to stack_chain->callstack_top, load XT + #! Save stack pointer to stack_chain->callstack_top, load XT 4 1 MR 11 %load-xt ; : (%call) 11 MTLR BLRL ; @@ -137,7 +133,7 @@ M: ppc-backend %jump-primitive ( word -- ) %prepare-primitive (%jump) ; M: ppc-backend %jump-t ( label -- ) - 0 "flag" operand \ f tag-number CMPI BNE ; + 0 "flag" operand f v>operand CMPI BNE ; : dispatch-template ( word-table# quot -- ) [ diff --git a/core/generator/generator.factor b/core/generator/generator.factor old mode 100644 new mode 100755 index 30295b722e..380d6fd4a4 --- a/core/generator/generator.factor +++ b/core/generator/generator.factor @@ -312,3 +312,4 @@ M: #return generate-node drop end-basic-block %return f ; : underlying-alien-offset cell object tag-number - ; : tuple-class-offset 2 cells tuple tag-number - ; : class-hash-offset cell object tag-number - ; +: word-xt-offset 8 cells object tag-number - ; From bf82687051b7d916423917eb54a6f94f86033ee8 Mon Sep 17 00:00:00 2001 From: "U-SLAVA-FB3999113\\Slava" Date: Mon, 15 Oct 2007 19:59:35 -0400 Subject: [PATCH 09/20] More ARM changes --- core/cpu/arm/5/5.factor | 3 --- core/cpu/arm/5/authors.txt | 1 - core/cpu/arm/5/summary.txt | 1 - vm/cpu-arm.S | 2 +- vm/data_gc.c | 0 vm/factor.c | 2 +- vm/io.c | 2 ++ 7 files changed, 4 insertions(+), 7 deletions(-) delete mode 100755 core/cpu/arm/5/5.factor delete mode 100644 core/cpu/arm/5/authors.txt delete mode 100644 core/cpu/arm/5/summary.txt mode change 100644 => 100755 vm/data_gc.c mode change 100644 => 100755 vm/io.c diff --git a/core/cpu/arm/5/5.factor b/core/cpu/arm/5/5.factor deleted file mode 100755 index ae07345cd1..0000000000 --- a/core/cpu/arm/5/5.factor +++ /dev/null @@ -1,3 +0,0 @@ -USING: cpu.arm.assembler cpu.arm4 namespaces ; - -t have-BLX? set-global diff --git a/core/cpu/arm/5/authors.txt b/core/cpu/arm/5/authors.txt deleted file mode 100644 index 1901f27a24..0000000000 --- a/core/cpu/arm/5/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov diff --git a/core/cpu/arm/5/summary.txt b/core/cpu/arm/5/summary.txt deleted file mode 100644 index 5c697fe27e..0000000000 --- a/core/cpu/arm/5/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Additional compiler intrinsics for ARM5 diff --git a/vm/cpu-arm.S b/vm/cpu-arm.S index 532908b772..ba49eb8fdb 100755 --- a/vm/cpu-arm.S +++ b/vm/cpu-arm.S @@ -114,7 +114,7 @@ DEF(void,set_callstack,(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length)): ldr pc,LR_SAVE /* return */ DEF(void,throw_impl,(CELL quot, F_STACK_FRAME *rewind_to)): - mov sp,r1 /* compute new stack pointer */ + add sp,r1,#4 /* compute new stack pointer */ ldr lr,LR_SAVE /* we have rewound the stack; load return address */ JUMP_QUOT /* call the quotation */ diff --git a/vm/data_gc.c b/vm/data_gc.c old mode 100644 new mode 100755 diff --git a/vm/factor.c b/vm/factor.c index d5e3ab23cf..b611fb05ba 100755 --- a/vm/factor.c +++ b/vm/factor.c @@ -140,7 +140,7 @@ void init_factor_from_args(F_CHAR *image, int argc, F_CHAR **argv, bool embedded if(p.fep) factorbug(); - c_to_factor_toplevel(userenv[BOOT_ENV]); + c_to_factor(userenv[BOOT_ENV]); unnest_stacks(); for(i = 0; i < argc; i++) diff --git a/vm/io.c b/vm/io.c old mode 100644 new mode 100755 index f6cc62736c..bc7d057abf --- a/vm/io.c +++ b/vm/io.c @@ -19,8 +19,10 @@ void init_c_io(void) void io_error(void) { +#ifndef WINCE if(errno == EINTR) return; +#endif CELL error = tag_object(from_char_string(strerror(errno))); general_error(ERROR_IO,error,F,NULL); From b841dcc15947b8a3ad065556830c48630335a148 Mon Sep 17 00:00:00 2001 From: "U-SLAVA-FB3999113\\Slava" Date: Thu, 18 Oct 2007 02:37:52 -0400 Subject: [PATCH 10/20] Further progress on the ARM backend --- core/cpu/arm/allot/allot.factor | 10 +- core/cpu/arm/architecture/architecture.factor | 100 ++++++++++-------- core/cpu/arm/arm.factor | 12 ++- core/cpu/arm/assembler/assembler.factor | 2 +- core/cpu/arm/bootstrap.factor | 11 +- core/cpu/arm/intrinsics/intrinsics.factor | 12 +-- 6 files changed, 79 insertions(+), 68 deletions(-) diff --git a/core/cpu/arm/allot/allot.factor b/core/cpu/arm/allot/allot.factor index c70c1090c2..440aeca2a3 100755 --- a/core/cpu/arm/allot/allot.factor +++ b/core/cpu/arm/allot/allot.factor @@ -22,7 +22,7 @@ IN: cpu.arm.allot ; : %store-tagged ( reg tag -- ) - >r dup fresh-object v>operand R11 r> tag-number ORI ; + >r dup fresh-object v>operand R11 r> tag-number ORR ; : %allot-bignum ( #digits -- ) #! 1 cell header, 1 cell length, 1 cell sign, + digits @@ -32,10 +32,10 @@ IN: cpu.arm.allot R12 R11 cell <+> STR ! store the length ; -: %allot-bignum-signed-1 ( reg -- ) +: %allot-bignum-signed-1 ( dst src -- ) #! on entry, reg is a 30-bit quantity sign-extended to #! 32-bits. - #! exits with tagged ptr to bignum in allot-tmp. + #! exits with tagged ptr to bignum in reg. [ "end" define-label ! is it zero? @@ -55,9 +55,9 @@ IN: cpu.arm.allot ! store sign R12 R11 2 cells <+> STR ! store the number - dup v>operand R11 3 cells <+> STR + v>operand R11 3 cells <+> STR ! tag the bignum, store it in reg - bignum %tag-allot + bignum %store-tagged "end" resolve-label ] with-scope ; diff --git a/core/cpu/arm/architecture/architecture.factor b/core/cpu/arm/architecture/architecture.factor index 7e077b4a22..4545ad2e93 100755 --- a/core/cpu/arm/architecture/architecture.factor +++ b/core/cpu/arm/architecture/architecture.factor @@ -52,19 +52,19 @@ M: immediate load-literal M: arm-backend stack-frame ( n -- i ) factor-area-size + 8 align ; -M: ppc-backend %save-xt ( -- ) +M: arm-backend %save-xt ( -- ) R12 PC 8 SUB ; M: arm-backend %prologue ( n -- ) SP SP pick SUB - R11 over LI + R11 over MOV R11 SP pick next-save <+> STR - R12 SP rot xt-save <+> STR - LR SP pick lr-save <+> STR ; + R12 SP pick xt-save <+> STR + LR SP rot lr-save <+> STR ; M: arm-backend %epilogue ( n -- ) - LR SP lr-save <+> LDR - SP SP rot stack-frame ADD ; + LR SP pick lr-save <+> LDR + SP SP rot ADD ; : compile-dlsym ( symbol dll reg -- ) [ @@ -99,9 +99,6 @@ M: arm-backend %call-label ( label -- ) BL ; M: arm-backend %jump-label ( label -- ) B ; -: %load-xt ( word -- ) - 0 swap LOAD32 rc-absolute-ppc-2/2 rel-word ; - : %prepare-primitive ( word -- ) #! Save stack pointer to stack_chain->callstack_top, load XT R1 SP MOV @@ -145,11 +142,9 @@ M: arm-backend %return ( -- ) %epilogue-later PC LR MOV ; M: arm-backend %unwind drop %return ; -: (%peek/replace) - >r drop >r v>operand r> loc>operand r> execute ; +M: arm-backend %peek >r v>operand r> loc>operand LDR ; -M: int-regs (%peek) \ LDR (%peek/replace) ; -M: int-regs (%replace) \ STR (%peek/replace) ; +M: arm-backend %replace >r v>operand r> loc>operand STR ; : (%inc) ( n reg -- ) dup rot cells dup 0 < [ neg SUB ] [ ADD ] if ; @@ -255,14 +250,14 @@ M: arm-backend %box-large-struct ( n size -- ) M: arm-backend struct-small-enough? ( size -- ? ) wince? [ drop f ] [ 4 <= ] if ; -M: ppc-backend %prepare-alien-invoke +M: arm-backend %prepare-alien-invoke #! Save Factor stack pointers in case the C code calls a #! callback which does a GC, which must reliably trace #! all roots. "stack_chain" f R12 %alien-global SP R12 0 <+> STR - ds-reg 11 8 <+> STR - rs-reg 11 12 <+> STR ; + ds-reg R12 8 <+> STR + rs-reg R12 12 <+> STR ; M: arm-backend %alien-invoke ( symbol dll -- ) ! Load target address @@ -314,37 +309,50 @@ M: long-long-type c-type-stack-align? drop wince? not ; M: arm-backend fp-shadows-int? ( -- ? ) f ; ! Alien intrinsics -: add-alien-offset "offset" operand tag-bits get ADD ; +M: arm-backend %unbox-byte-array ( dst src -- ) + [ v>operand ] 2apply byte-array-offset ADD ; -: (%unbox-alien) <+> roll call ; inline +M: arm-backend %unbox-alien ( dst src -- ) + [ v>operand ] 2apply alien-offset <+> LDR ; -M: arm-backend %unbox-byte-array ( quot src -- ) - "address" operand "alien" operand add-alien-offset - "address" operand alien-offset (%unbox-alien) ; +M: arm-backend %unbox-f ( dst src -- ) + drop v>operand 0 MOV ; -M: arm-backend %unbox-alien ( quot src -- ) - "address" operand "alien" operand alien-offset <+> LDR - "address" operand dup add-alien-offset - "address" operand 0 (%unbox-alien) ; - -M: arm-backend %unbox-f ( quot src -- ) - "offset" operand dup %untag-fixnum - "offset" operand 0 (%unbox-alien) ; - -M: arm-backend %complex-alien-accessor ( quot src -- ) - "is-f" define-label - "is-alien" define-label +M: arm-backend %unbox-any-c-ptr ( dst src -- ) + #! We need three registers here. R11 and R12 are reserved + #! temporary registers. The third one is R14, which we have + #! to save/restore. "end" define-label - "alien" operand f v>operand CMP - "is-f" get EQ B - "address" operand "alien" operand header-offset neg <-> LDR - "address" operand alien type-number tag-header CMP - "is-alien" get EQ B - [ %unbox-byte-array ] 2keep - "end" get B - "is-alien" resolve-label - [ %unbox-alien ] 2keep - "end" get B - "is-f" resolve-label - %unbox-f - "end" resolve-label ; + "start" define-label + ! Save R14. + R14 SP 4 <-> STR + ! Address is computed in RR11 + R11 0 MOV + ! Load object into R12 + R12 swap v>operand MOV + ! We come back here with displaced aliens + "start" resolve-label + ! Is the object f? + R12 f v>operand CMP + ! If so, done + "end" get EQ B + ! Is the object an alien? + R14 R12 header-offset <+> LDR + R14 alien type-number tag-header CMP + ! Add byte array address to address being computed + R11 R11 R12 NE ADD + ! Add an offset to start of byte array's data area + R11 R11 byte-array-offset NE ADD + "end" get NE B + ! If alien, load the offset + R14 R12 alien-offset LDR + ! Add it to address being computed + R11 R11 R14 ADD + ! Now recurse on the underlying alien + R12 R12 underlying-alien-offset LDR + "start" get B + "end" resolve-label + ! Done, store address in destination register + v>operand R11 MOV + ! Restore R14. + R14 SP 4 <-> LDR ; diff --git a/core/cpu/arm/arm.factor b/core/cpu/arm/arm.factor index afe6411d97..e2814b772f 100755 --- a/core/cpu/arm/arm.factor +++ b/core/cpu/arm/arm.factor @@ -1,7 +1,9 @@ +! Copyright (C) 2007 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types kernel math namespaces -cpu.architecture cpu.arm.architecture cpu.arm.intrinsics -generator generator.registers continuations compiler io -vocabs.loader ; +cpu.architecture cpu.arm.architecture cpu.arm.assembler +cpu.arm.intrinsics generator generator.registers continuations +compiler io vocabs.loader sequences ; ! EABI passes floats in integer registers. [ alien-float ] @@ -34,9 +36,9 @@ T{ arm-backend } compiler-backend set-global "==========" print "You should specify the -arm-variant= switch." print " can be one of arm3, arm4, arm4t, or arm5." print - "Assuming arm4t." print + "Assuming arm3." print "==========" print - "arm4t" "arm-variant" set + "arm3" "arm-variant" set-global ] if "arm-variant" get { "arm4" "arm4t" "arm5" } member? [ diff --git a/core/cpu/arm/assembler/assembler.factor b/core/cpu/arm/assembler/assembler.factor index e61e02ae8d..d10b24de4e 100755 --- a/core/cpu/arm/assembler/assembler.factor +++ b/core/cpu/arm/assembler/assembler.factor @@ -276,7 +276,7 @@ M: label (BX) 0 swap (BX) rc-relative-arm-3 label-fixup ; : BX have-BX? get [ 0 (BX) ] [ PC swap MOV ] if ; -: BLX have-BLX? get [ 1 (BLX) ] [ LR PC MOV BX ] if ; +: BLX have-BLX? get [ 1 (BX) ] [ LR PC MOV BX ] if ; ! More load and store instructions GENERIC: addressing-mode-3 ( addressing-mode -- n ) diff --git a/core/cpu/arm/bootstrap.factor b/core/cpu/arm/bootstrap.factor index 4f67255305..8ab94cade4 100755 --- a/core/cpu/arm/bootstrap.factor +++ b/core/cpu/arm/bootstrap.factor @@ -1,10 +1,11 @@ ! Copyright (C) 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: bootstrap.image.private kernel namespaces system -cpu.arm.assembler cpu.arm5.assembler math layouts words vocabs ; +cpu.arm.assembler math layouts words vocabs ; IN: bootstrap.arm -T{ arm5-variant } arm-variant set-global +! We generate ARM3 code +f have-BX? set 4 \ cell set big-endian off @@ -66,12 +67,12 @@ big-endian off : jit-call scan-reg SP scan-save <+> STR ! save scan pointer LR PC MOV ! save return address - PC xt-reg MOV ! call + xt-reg BX ! call scan-reg SP scan-save <+> LDR ! restore scan pointer ; : jit-jump - PC xt-reg MOV ; + xt-reg BX ; [ load-word-xt jit-call ] { } make jit-word-call set @@ -113,6 +114,6 @@ big-endian off LR SP 4 <-> LDR ! load return address ] { } make jit-epilog set -[ PC LR MOV ] { } make jit-return set +[ LR BX ] { } make jit-return set "bootstrap.arm" forget-vocab diff --git a/core/cpu/arm/intrinsics/intrinsics.factor b/core/cpu/arm/intrinsics/intrinsics.factor index 18cfb7d3de..bc2e966906 100755 --- a/core/cpu/arm/intrinsics/intrinsics.factor +++ b/core/cpu/arm/intrinsics/intrinsics.factor @@ -16,11 +16,11 @@ IN: cpu.arm.intrinsics "obj" get operand-tag - <+/-> ; : %slot-literal-any-tag - "obj" operand "scratch" operand %untag + "scratch" operand "obj" operand %untag "val" operand "scratch" operand "n" get cells <+> ; : %slot-any - "obj" operand "scratch" operand %untag + "scratch" operand "obj" operand %untag "n" operand dup 1 MOV "scratch" operand "val" operand "n" operand <+> ; @@ -52,8 +52,8 @@ IN: cpu.arm.intrinsics } } define-intrinsics -: generate-write-barrier ( -- ) - "val" operand-immediate? "obj" get fresh-object? or [ +: %write-barrier ( -- ) + "val" get operand-immediate? "obj" get fresh-object? or [ "cards_offset" f R12 %alien-global "scratch" operand R12 "scratch" operand card-bits ADD "val" operand "scratch" operand 0 LDRB @@ -156,7 +156,7 @@ IN: cpu.arm.intrinsics "end" get VC B { "x" "y" } %untag-fixnums "x" operand "x" operand "y" operand roll execute - "x" get %allot-bignum-signed-1 + "out" get "x" get %allot-bignum-signed-1 "end" resolve-label ] with-scope ; inline @@ -173,7 +173,7 @@ IN: cpu.arm.intrinsics \ fixnum>bignum [ "x" operand dup %untag-fixnum - "x" get %allot-bignum-signed-1 + "out" get "x" get %allot-bignum-signed-1 ] H{ { +input+ { { f "x" } } } { +scratch+ { { f "out" } } } From f529d3d2d2b89bbe0bbcad95c338baeb547eebc0 Mon Sep 17 00:00:00 2001 From: "U-SLAVA-FB3999113\\Slava" Date: Thu, 18 Oct 2007 02:38:35 -0400 Subject: [PATCH 11/20] Load fixes for core/math --- core/math/integers/integers-docs.factor | 4 ---- core/math/math.factor | 3 +++ extra/math/constants/constants-docs.factor | 8 -------- extra/math/functions/functions-docs.factor | 2 +- extra/math/ratios/ratios-docs.factor | 4 ++++ extra/math/ratios/ratios.factor | 2 +- 6 files changed, 9 insertions(+), 14 deletions(-) mode change 100644 => 100755 extra/math/constants/constants-docs.factor mode change 100644 => 100755 extra/math/ratios/ratios-docs.factor diff --git a/core/math/integers/integers-docs.factor b/core/math/integers/integers-docs.factor index e21e9c7102..b319e028fb 100755 --- a/core/math/integers/integers-docs.factor +++ b/core/math/integers/integers-docs.factor @@ -44,10 +44,6 @@ HELP: odd? { $values { "n" integer } { "?" "a boolean" } } { $description "Tests if an integer is odd." } ; -HELP: fraction> -{ $values { "a" integer } { "b" "a positive integer" } { "a/b" rational } } -{ $description "Creates a new ratio, or outputs the numerator if the denominator is 1. This word does not reduce the fraction to lowest terms, and should not be called directly; use " { $link / } " instead." } ; - ! Unsafe primitives HELP: fixnum+ ( x y -- z ) { $values { "x" fixnum } { "y" fixnum } { "z" integer } } diff --git a/core/math/math.factor b/core/math/math.factor index 02e2b433c4..7f796e91b7 100755 --- a/core/math/math.factor +++ b/core/math/math.factor @@ -90,6 +90,9 @@ M: real hashcode* nip >fixnum ; M: real <=> - ; +! real and sequence overlap. we disambiguate: +M: integer <=> - ; + GENERIC: fp-nan? ( x -- ? ) M: object fp-nan? diff --git a/extra/math/constants/constants-docs.factor b/extra/math/constants/constants-docs.factor old mode 100644 new mode 100755 index 5945bb26c6..92c96985c3 --- a/extra/math/constants/constants-docs.factor +++ b/extra/math/constants/constants-docs.factor @@ -3,8 +3,6 @@ IN: math.constants ARTICLE: "math-constants" "Constants" "Standard mathematical constants:" -{ $subsection i } -{ $subsection -i } { $subsection e } { $subsection pi } "Various limits:" @@ -14,12 +12,6 @@ ARTICLE: "math-constants" "Constants" ABOUT: "math-constants" -HELP: i -{ $values { "i" "the imaginary unit" } } ; - -HELP: -i -{ $values { "-i" "the negated imaginary unit" } } ; - HELP: e { $values { "e" "base of natural logarithm" } } ; diff --git a/extra/math/functions/functions-docs.factor b/extra/math/functions/functions-docs.factor index 3803e71fae..08f3918197 100755 --- a/extra/math/functions/functions-docs.factor +++ b/extra/math/functions/functions-docs.factor @@ -1,5 +1,5 @@ USING: help.markup help.syntax kernel math -sequences quotations ; +sequences quotations math.functions.private ; IN: math.functions ARTICLE: "integer-functions" "Integer functions" diff --git a/extra/math/ratios/ratios-docs.factor b/extra/math/ratios/ratios-docs.factor old mode 100644 new mode 100755 index d661a68752..d996acaf1f --- a/extra/math/ratios/ratios-docs.factor +++ b/extra/math/ratios/ratios-docs.factor @@ -34,6 +34,10 @@ HELP: denominator ( a/b -- b ) { $values { "a/b" rational } { "b" "a positive integer" } } { $description "Outputs the denominator of a rational number. Always outputs 1 with integers." } ; +HELP: fraction> +{ $values { "a" integer } { "b" "a positive integer" } { "a/b" rational } } +{ $description "Creates a new ratio, or outputs the numerator if the denominator is 1. This word does not reduce the fraction to lowest terms, and should not be called directly; use " { $link / } " instead." } ; + HELP: >fraction { $values { "a/b" rational } { "a" integer } { "b" "a positive integer" } } { $description "Extracts the numerator and denominator of a rational number." } ; diff --git a/extra/math/ratios/ratios.factor b/extra/math/ratios/ratios.factor index d92d33899a..954fd8dd20 100755 --- a/extra/math/ratios/ratios.factor +++ b/extra/math/ratios/ratios.factor @@ -24,7 +24,7 @@ PRIVATE> M: integer / dup zero? [ - /i + "Division by zero" throw ] [ dup 0 < [ [ neg ] 2apply ] when 2dup gcd nip tuck /i >r /i r> fraction> From 7c88e58782999dfc15ec0d7acc4c79a6d83be19e Mon Sep 17 00:00:00 2001 From: "U-SLAVA-FB3999113\\Slava" Date: Thu, 18 Oct 2007 02:40:17 -0400 Subject: [PATCH 12/20] UI load fix --- extra/ui/gadgets/packs/packs.factor | 4 ++-- extra/ui/gadgets/sliders/sliders.factor | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) mode change 100644 => 100755 extra/ui/gadgets/packs/packs.factor mode change 100644 => 100755 extra/ui/gadgets/sliders/sliders.factor diff --git a/extra/ui/gadgets/packs/packs.factor b/extra/ui/gadgets/packs/packs.factor old mode 100644 new mode 100755 index dd10449034..8ac427d087 --- a/extra/ui/gadgets/packs/packs.factor +++ b/extra/ui/gadgets/packs/packs.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: sequences ui.gadgets kernel math math.vectors -namespaces ; +USING: sequences ui.gadgets kernel math math.functions +math.vectors namespaces ; IN: ui.gadgets.packs TUPLE: pack align fill gap ; diff --git a/extra/ui/gadgets/sliders/sliders.factor b/extra/ui/gadgets/sliders/sliders.factor old mode 100644 new mode 100755 index 5a245e7651..c38f8e9d11 --- a/extra/ui/gadgets/sliders/sliders.factor +++ b/extra/ui/gadgets/sliders/sliders.factor @@ -3,7 +3,7 @@ USING: arrays ui.gestures ui.gadgets ui.gadgets.buttons ui.gadgets.controls ui.gadgets.frames ui.gadgets.grids ui.gadgets.theme ui.render kernel math namespaces sequences -vectors models math.vectors quotations colors ; +vectors models math.vectors math.functions quotations colors ; IN: ui.gadgets.sliders TUPLE: elevator direction ; From 48572a3c7bca6e006ff57e031b444b428bb4dd2f Mon Sep 17 00:00:00 2001 From: "U-SLAVA-FB3999113\\Slava" Date: Thu, 18 Oct 2007 02:40:34 -0400 Subject: [PATCH 13/20] Update extra/tools for math re-organization --- extra/tools/profiler/profiler.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) mode change 100644 => 100755 extra/tools/profiler/profiler.factor diff --git a/extra/tools/profiler/profiler.factor b/extra/tools/profiler/profiler.factor old mode 100644 new mode 100755 index 382b17b363..ee34e6f9b0 --- a/extra/tools/profiler/profiler.factor +++ b/extra/tools/profiler/profiler.factor @@ -3,7 +3,7 @@ USING: words sequences math prettyprint kernel arrays io io.styles namespaces assocs kernel.private generator compiler strings combinators sorting math.parser -math.vectors vocabs definitions tools.profiler.private ; +vocabs definitions tools.profiler.private ; IN: tools.profiler : reset-counters ( -- ) From 0754b991e500b5c894bfa960852b9b586a93e819 Mon Sep 17 00:00:00 2001 From: "U-SLAVA-FB3999113\\Slava" Date: Thu, 18 Oct 2007 02:41:03 -0400 Subject: [PATCH 14/20] Fix overly-general method definitions in cpu.x86.64 --- core/cpu/x86/64/64.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/core/cpu/x86/64/64.factor b/core/cpu/x86/64/64.factor index 2216445e96..cb1fdc85b8 100755 --- a/core/cpu/x86/64/64.factor +++ b/core/cpu/x86/64/64.factor @@ -13,8 +13,8 @@ PREDICATE: x86-backend amd64-backend M: amd64-backend ds-reg R14 ; M: amd64-backend rs-reg R15 ; M: amd64-backend stack-reg RSP ; -M: x86-backend xt-reg RCX ; -M: x86-backend stack-save-reg RSI ; +M: amd64-backend xt-reg RCX ; +M: amd64-backend stack-save-reg RSI ; M: temp-reg v>operand drop RBX ; From 507d0ca1501c64d39e9c2e9c8cf5a3f29d5167db Mon Sep 17 00:00:00 2001 From: "U-SLAVA-FB3999113\\Slava" Date: Sun, 21 Oct 2007 15:18:31 -0400 Subject: [PATCH 15/20] More ARM fixes --- core/cpu/arm/allot/allot.factor | 6 +++--- core/cpu/arm/architecture/architecture.factor | 8 ++++---- core/cpu/arm/intrinsics/intrinsics.factor | 2 +- vm/cpu-arm.h | 1 - vm/factor.c | 2 +- vm/image.c | 10 ++++++---- vm/image.h | 2 +- vm/os-windows-ce.h | 3 +-- 8 files changed, 17 insertions(+), 17 deletions(-) mode change 100644 => 100755 vm/image.c mode change 100644 => 100755 vm/image.h diff --git a/core/cpu/arm/allot/allot.factor b/core/cpu/arm/allot/allot.factor index 440aeca2a3..41a5cab91e 100755 --- a/core/cpu/arm/allot/allot.factor +++ b/core/cpu/arm/allot/allot.factor @@ -40,7 +40,7 @@ IN: cpu.arm.allot "end" define-label ! is it zero? dup v>operand 0 CMP - 0 >bignum over EQ load-literal + 0 >bignum pick EQ load-literal "end" get EQ B ! ! it is non-zero 1 %allot-bignum @@ -64,12 +64,12 @@ IN: cpu.arm.allot M: arm-backend %box-alien ( dst src -- ) "end" define-label dup v>operand 0 CMP - over f v>operand EQ MOV + over v>operand f v>operand EQ MOV "end" get EQ B alien 4 cells %allot ! Store offset v>operand R11 3 cells <+> STR - R12 f v>operand R12 + R12 f v>operand MOV ! Store expired slot R12 R11 1 cells <+> STR ! Store underlying-alien slot diff --git a/core/cpu/arm/architecture/architecture.factor b/core/cpu/arm/architecture/architecture.factor index 4545ad2e93..d2b72da3a1 100755 --- a/core/cpu/arm/architecture/architecture.factor +++ b/core/cpu/arm/architecture/architecture.factor @@ -326,7 +326,7 @@ M: arm-backend %unbox-any-c-ptr ( dst src -- ) "start" define-label ! Save R14. R14 SP 4 <-> STR - ! Address is computed in RR11 + ! Address is computed in R11 R11 0 MOV ! Load object into R12 R12 swap v>operand MOV @@ -337,7 +337,7 @@ M: arm-backend %unbox-any-c-ptr ( dst src -- ) ! If so, done "end" get EQ B ! Is the object an alien? - R14 R12 header-offset <+> LDR + R14 R12 header-offset <+/-> LDR R14 alien type-number tag-header CMP ! Add byte array address to address being computed R11 R11 R12 NE ADD @@ -345,11 +345,11 @@ M: arm-backend %unbox-any-c-ptr ( dst src -- ) R11 R11 byte-array-offset NE ADD "end" get NE B ! If alien, load the offset - R14 R12 alien-offset LDR + R14 R12 alien-offset <+/-> LDR ! Add it to address being computed R11 R11 R14 ADD ! Now recurse on the underlying alien - R12 R12 underlying-alien-offset LDR + R12 R12 underlying-alien-offset <+/-> LDR "start" get B "end" resolve-label ! Done, store address in destination register diff --git a/core/cpu/arm/intrinsics/intrinsics.factor b/core/cpu/arm/intrinsics/intrinsics.factor index bc2e966906..4b0a0bf591 100755 --- a/core/cpu/arm/intrinsics/intrinsics.factor +++ b/core/cpu/arm/intrinsics/intrinsics.factor @@ -22,7 +22,7 @@ IN: cpu.arm.intrinsics : %slot-any "scratch" operand "obj" operand %untag "n" operand dup 1 MOV - "scratch" operand "val" operand "n" operand <+> ; + "val" operand "scratch" operand "n" operand <+> ; \ slot { ! Slot number is literal and the tag is known diff --git a/vm/cpu-arm.h b/vm/cpu-arm.h index 3e2e722edf..67dadb2906 100755 --- a/vm/cpu-arm.h +++ b/vm/cpu-arm.h @@ -32,4 +32,3 @@ void undefined(CELL word); void set_callstack(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, void *memcpy); void throw_impl(CELL quot, F_STACK_FRAME *rewind); void lazy_jit_compile(CELL quot); -void flush_icache(CELL start, CELL len); diff --git a/vm/factor.c b/vm/factor.c index b611fb05ba..d5e3ab23cf 100755 --- a/vm/factor.c +++ b/vm/factor.c @@ -140,7 +140,7 @@ void init_factor_from_args(F_CHAR *image, int argc, F_CHAR **argv, bool embedded if(p.fep) factorbug(); - c_to_factor(userenv[BOOT_ENV]); + c_to_factor_toplevel(userenv[BOOT_ENV]); unnest_stacks(); for(i = 0; i < argc; i++) diff --git a/vm/image.c b/vm/image.c old mode 100644 new mode 100755 index e5c4b45861..7b9e67f5cf --- a/vm/image.c +++ b/vm/image.c @@ -82,7 +82,7 @@ void load_image(F_PARAMETERS *p) } /* Save the current image to disk */ -bool save_image(const F_CHAR *filename) +void save_image(const F_CHAR *filename) { FILE* file; F_HEADER h; @@ -91,7 +91,11 @@ bool save_image(const F_CHAR *filename) file = OPEN_WRITE(filename); if(file == NULL) - fatal_error("Cannot open image for writing",errno); + { + FPRINTF(stderr,"Cannot open image file: %s\n",filename); + fprintf(stderr,"%s\n",strerror(errno)); + return; + } F_ZONE *tenured = &data_heap->generations[TENURED]; @@ -122,8 +126,6 @@ bool save_image(const F_CHAR *filename) fwrite(first_block(&code_heap),h.code_size,1,file); fclose(file); - - return true; } DEFINE_PRIMITIVE(save_image) diff --git a/vm/image.h b/vm/image.h old mode 100644 new mode 100755 index ba953677cf..0fc2f03a3d --- a/vm/image.h +++ b/vm/image.h @@ -36,7 +36,7 @@ typedef struct { void load_image(F_PARAMETERS *p); void init_objects(F_HEADER *h); -bool save_image(const F_CHAR *file); +void save_image(const F_CHAR *file); DECLARE_PRIMITIVE(save_image); DECLARE_PRIMITIVE(save_image_and_exit); diff --git a/vm/os-windows-ce.h b/vm/os-windows-ce.h index f73fb0a08c..959de89634 100755 --- a/vm/os-windows-ce.h +++ b/vm/os-windows-ce.h @@ -16,12 +16,11 @@ typedef wchar_t F_SYMBOL; int errno; char *strerror(int err); -void flush_icache(); +void flush_icache(CELL start, CELL end); char *getenv(char *name); #define snprintf _snprintf #define snwprintf _snwprintf -#define EINTR 0 s64 current_millis(void); void c_to_factor_toplevel(CELL quot); From de0808320e4d4f6a9ea6f650d0412a6611a2aa67 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 21 Oct 2007 17:37:50 -0400 Subject: [PATCH 16/20] Fix ltrim/rtrim, get extra/ to load after number tower changes --- core/bootstrap/stage2.factor | 5 +--- core/io/files/files.factor | 5 ++-- core/sequences/sequences-tests.factor | 10 ++++--- core/sequences/sequences.factor | 14 +++++----- extra/benchmark/raytracer/raytracer.factor | 2 +- .../spectral-norm/spectral-norm.factor | 4 +-- extra/boids/ui/ui.factor | 1 + extra/calendar/calendar.factor | 2 +- extra/color-picker/color-picker.factor | 7 +++-- extra/colors/hsv/hsv.factor | 3 +- extra/crypto/sha1/sha1.factor | 2 +- extra/factory/commands/commands.factor | 2 +- extra/io/windows/nt/backend/backend.factor | 2 +- extra/io/windows/windows.factor | 2 +- extra/irc/irc.factor | 2 +- extra/math/fft/fft.factor | 2 +- extra/math/polynomials/polynomials.factor | 2 +- extra/pack/pack.factor | 2 +- .../parser-combinators.factor | 6 ++-- extra/pos/pos.factor | 2 +- extra/tar/tar.factor | 2 +- extra/tetris/game/game.factor | 4 +-- misc/integration/deploy-size-test.factor | 28 +++++++++++++++++++ misc/integration/macosx-deploy.factor | 2 +- 24 files changed, 71 insertions(+), 42 deletions(-) create mode 100644 misc/integration/deploy-size-test.factor diff --git a/core/bootstrap/stage2.factor b/core/bootstrap/stage2.factor index 121dd815e3..1a52781307 100755 --- a/core/bootstrap/stage2.factor +++ b/core/bootstrap/stage2.factor @@ -19,7 +19,7 @@ IN: bootstrap.stage2 parse-command-line - H{ } clone changed-words set-global + all-words [ dup ] H{ } map>assoc changed-words set-global "-no-crossref" cli-args member? [ "Cross-referencing..." print flush @@ -41,9 +41,6 @@ IN: bootstrap.stage2 ] if [ - ! Compile everything if compiler is loaded - all-words [ changed-word ] each - "exclude" "include" [ get-global " " split [ empty? not ] subset ] 2apply seq-diff diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 84d83bd052..da1c078525 100644 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -29,9 +29,8 @@ M: object root-directory? ( path -- ? ) "/" = ; "/\\" member? ; : path+ ( str1 str2 -- str ) - >r [ path-separator? ] rtrim r> - [ path-separator? ] ltrim - >r "/" r> 3append ; + >r [ path-separator? ] right-trim "/" r> + [ path-separator? ] left-trim 3append ; : stat ( path -- directory? permissions length modified ) normalize-pathname (stat) ; diff --git a/core/sequences/sequences-tests.factor b/core/sequences/sequences-tests.factor index 58250f1ee5..1509fa8c05 100755 --- a/core/sequences/sequences-tests.factor +++ b/core/sequences/sequences-tests.factor @@ -236,9 +236,11 @@ unit-test [ -1./0. 0 delete-nth ] unit-test-fails [ "" ] [ "" [ blank? ] trim ] unit-test -[ "" ] [ "" [ blank? ] ltrim ] unit-test -[ "" ] [ "" [ blank? ] rtrim ] unit-test +[ "" ] [ "" [ blank? ] left-trim ] unit-test +[ "" ] [ "" [ blank? ] right-trim ] unit-test +[ "" ] [ " " [ blank? ] left-trim ] unit-test +[ "" ] [ " " [ blank? ] right-trim ] unit-test [ "asdf" ] [ " asdf " [ blank? ] trim ] unit-test -[ "asdf " ] [ " asdf " [ blank? ] ltrim ] unit-test -[ " asdf" ] [ " asdf " [ blank? ] rtrim ] unit-test +[ "asdf " ] [ " asdf " [ blank? ] left-trim ] unit-test +[ " asdf" ] [ " asdf " [ blank? ] right-trim ] unit-test diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 778f688c86..dedbbfc59d 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -652,16 +652,16 @@ PRIVATE> dup slice? [ { } like ] when 0 over length rot ; inline -: ltrim ( seq quot -- newseq ) - over >r [ not ] compose find drop - r> swap [ tail ] when* ; inline +: left-trim ( seq quot -- newseq ) + over >r [ not ] compose find drop r> swap + [ tail ] [ dup length tail ] if* ; inline -: rtrim ( seq quot -- newseq ) - over >r [ not ] compose find-last drop - r> swap [ 1+ head ] when* ; inline +: right-trim ( seq quot -- newseq ) + over >r [ not ] compose find-last drop r> swap + [ 1+ head ] [ 0 head ] if* ; inline : trim ( seq quot -- newseq ) - [ ltrim ] keep rtrim ; inline + [ left-trim ] keep right-trim ; inline : sum ( seq -- n ) 0 [ + ] reduce ; : product ( seq -- n ) 1 [ * ] reduce ; diff --git a/extra/benchmark/raytracer/raytracer.factor b/extra/benchmark/raytracer/raytracer.factor index 8f447bcb69..b277b08d79 100644 --- a/extra/benchmark/raytracer/raytracer.factor +++ b/extra/benchmark/raytracer/raytracer.factor @@ -2,7 +2,7 @@ ! http://www.ffconsultancy.com/free/ray_tracer/languages.html USING: float-arrays compiler generic io io.files kernel math -math.vectors math.parser namespaces sequences +math.functions math.vectors math.parser namespaces sequences sequences.private words ; IN: benchmark.raytracer diff --git a/extra/benchmark/spectral-norm/spectral-norm.factor b/extra/benchmark/spectral-norm/spectral-norm.factor index 196f06142e..e67359e70c 100644 --- a/extra/benchmark/spectral-norm/spectral-norm.factor +++ b/extra/benchmark/spectral-norm/spectral-norm.factor @@ -1,7 +1,7 @@ ! Factor port of ! http://shootout.alioth.debian.org/gp4/benchmark.php?test=spectralnorm&lang=all -USING: float-arrays kernel math math.vectors sequences -sequences.private prettyprint words tools.time hints ; +USING: float-arrays kernel math math.functions math.vectors +sequences sequences.private prettyprint words tools.time hints ; IN: benchmark.spectral-norm : fast-truncate >fixnum >float ; inline diff --git a/extra/boids/ui/ui.factor b/extra/boids/ui/ui.factor index 2bd86f49f6..15f33796fa 100644 --- a/extra/boids/ui/ui.factor +++ b/extra/boids/ui/ui.factor @@ -1,6 +1,7 @@ USING: kernel namespaces math + math.functions math.vectors math.parser hashtables sequences threads diff --git a/extra/calendar/calendar.factor b/extra/calendar/calendar.factor index 27857e0d9f..59414a1142 100644 --- a/extra/calendar/calendar.factor +++ b/extra/calendar/calendar.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays hashtables io io.streams.string kernel math -math.vectors math.parser +math.vectors math.functions math.parser namespaces sequences strings tuples system ; IN: calendar diff --git a/extra/color-picker/color-picker.factor b/extra/color-picker/color-picker.factor index 7082afc822..62ea2e29ba 100644 --- a/extra/color-picker/color-picker.factor +++ b/extra/color-picker/color-picker.factor @@ -1,8 +1,9 @@ ! Copyright (C) 2006, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math math.parser models sequences ui ui.gadgets -ui.gadgets.controls ui.gadgets.frames ui.gadgets.labels -ui.gadgets.packs ui.gadgets.sliders ui.render ; +USING: kernel math math.functions math.parser models sequences +ui ui.gadgets ui.gadgets.controls ui.gadgets.frames +ui.gadgets.labels ui.gadgets.packs ui.gadgets.sliders ui.render +; IN: color-picker ! Simple example demonstrating the use of models. diff --git a/extra/colors/hsv/hsv.factor b/extra/colors/hsv/hsv.factor index 102f45ce8a..79919d2d02 100644 --- a/extra/colors/hsv/hsv.factor +++ b/extra/colors/hsv/hsv.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2007 Eduardo Cavazos ! See http://factorcode.org/license.txt for BSD license. -USING: kernel combinators arrays sequences math combinators.lib ; +USING: kernel combinators arrays sequences math math.functions +combinators.lib ; IN: colors.hsv diff --git a/extra/crypto/sha1/sha1.factor b/extra/crypto/sha1/sha1.factor index 3497e33915..dfc5b10f7a 100644 --- a/extra/crypto/sha1/sha1.factor +++ b/extra/crypto/sha1/sha1.factor @@ -127,7 +127,7 @@ SYMBOL: K : file>sha1 ( file -- sha1 ) stream>sha1 ; : string>sha1-interleave ( string -- ) - [ zero? ] ltrim + [ zero? ] left-trim dup length odd? [ 1 tail ] when seq>2seq [ string>sha1 ] 2apply swap 2seq>seq ; diff --git a/extra/factory/commands/commands.factor b/extra/factory/commands/commands.factor index 35fab82ea8..282c738976 100644 --- a/extra/factory/commands/commands.factor +++ b/extra/factory/commands/commands.factor @@ -1,5 +1,5 @@ -USING: kernel combinators sequences math math.vectors mortar slot-accessors +USING: kernel combinators sequences math math.functions math.vectors mortar slot-accessors x x.widgets.wm.root x.widgets.wm.frame combinators.lib ; IN: factory.commands diff --git a/extra/io/windows/nt/backend/backend.factor b/extra/io/windows/nt/backend/backend.factor index a7f803fd7f..0cbdabfa1e 100755 --- a/extra/io/windows/nt/backend/backend.factor +++ b/extra/io/windows/nt/backend/backend.factor @@ -32,7 +32,7 @@ M: windows-nt-io normalize-pathname ( string -- string ) dup first CHAR: \\ = [ CHAR: \\ , ] unless % ] "" make ] } - } cond [ "/\\." member? ] rtrim ; + } cond [ "/\\." member? ] right-trim ; SYMBOL: io-hash diff --git a/extra/io/windows/windows.factor b/extra/io/windows/windows.factor index 423783526e..f46af26568 100644 --- a/extra/io/windows/windows.factor +++ b/extra/io/windows/windows.factor @@ -17,7 +17,7 @@ M: windows-io (socket-destructor) ( obj -- ) destructor-obj closesocket drop ; M: windows-io root-directory? ( path -- ? ) - [ path-separator? ] rtrim + [ path-separator? ] right-trim dup length 2 = [ dup first Letter? swap second CHAR: : = and diff --git a/extra/irc/irc.factor b/extra/irc/irc.factor index 0f2f2c371a..6f54768cab 100644 --- a/extra/irc/irc.factor +++ b/extra/irc/irc.factor @@ -72,7 +72,7 @@ TUPLE: part-command channel text ; SYMBOL: irc-client : irc-stream> ( -- stream ) irc-client get irc-client-stream ; -: trim-: ( seq -- seq ) [ CHAR: : = ] ltrim ; +: trim-: ( seq -- seq ) [ CHAR: : = ] left-trim ; : parse-name ( string -- string ) trim-: "!" split first ; : irc-split ( string -- seq ) diff --git a/extra/math/fft/fft.factor b/extra/math/fft/fft.factor index a21351fa74..6b5215350c 100644 --- a/extra/math/fft/fft.factor +++ b/extra/math/fft/fft.factor @@ -9,7 +9,7 @@ IN: math.fft : odd ( seq -- seq ) 2 group 1 ; DEFER: fft : two ( seq -- seq ) fft 2 v/n dup append ; -: omega ( n -- n ) recip -2 pi i * * * exp ; +: omega ( n -- n ) recip -2 pi i* * * exp ; : twiddle ( seq -- seq ) dup length dup omega swap n^v v* ; : (fft) ( seq -- seq ) dup odd two twiddle swap even two v+ ; : fft ( seq -- seq ) dup length 1 = [ (fft) ] unless ; diff --git a/extra/math/polynomials/polynomials.factor b/extra/math/polynomials/polynomials.factor index 5a4cc2bc66..f805df8249 100644 --- a/extra/math/polynomials/polynomials.factor +++ b/extra/math/polynomials/polynomials.factor @@ -22,7 +22,7 @@ PRIVATE> : p= ( p p -- ? ) pextend = ; : ptrim ( p -- p ) - dup length 1 = [ [ zero? ] rtrim ] unless ; + dup length 1 = [ [ zero? ] right-trim ] unless ; : 2ptrim ( p p -- p p ) [ ptrim ] 2apply ; : p+ ( p p -- p ) pextend v+ ; diff --git a/extra/pack/pack.factor b/extra/pack/pack.factor index 07b572f801..fd39f83a98 100644 --- a/extra/pack/pack.factor +++ b/extra/pack/pack.factor @@ -88,7 +88,7 @@ M: string b, ( n string -- ) heap-size b, ; "\0" read-until [ drop f ] unless ; : read-c-string* ( n -- str/f ) - read [ 0 = ] rtrim dup empty? [ drop f ] when ; + read [ 0 = ] right-trim dup empty? [ drop f ] when ; : (read-128-ber) ( n -- n ) 1 read first diff --git a/extra/parser-combinators/parser-combinators.factor b/extra/parser-combinators/parser-combinators.factor index 97acf8398b..fa0733f321 100644 --- a/extra/parser-combinators/parser-combinators.factor +++ b/extra/parser-combinators/parser-combinators.factor @@ -111,11 +111,11 @@ M: or-parser (parse) ( input parser1 -- list ) #! input. This implements the choice parsing operator. [ or-parser-p1 ] keep or-parser-p2 >r dupd parse swap r> parse lappend ; -: ltrim-slice ( string -- string ) +: left-trim-slice ( string -- string ) #! Return a new string without any leading whitespace #! from the original string. dup empty? [ - dup first blank? [ 1 tail-slice ltrim-slice ] when + dup first blank? [ 1 tail-slice left-trim-slice ] when ] unless ; TUPLE: sp-parser p1 ; @@ -127,7 +127,7 @@ C: sp sp-parser ( p1 -- parser ) M: sp-parser (parse) ( input parser -- list ) #! Skip all leading whitespace from the input then call #! the parser on the remaining input. - >r ltrim-slice r> sp-parser-p1 parse ; + >r left-trim-slice r> sp-parser-p1 parse ; TUPLE: just-parser p1 ; diff --git a/extra/pos/pos.factor b/extra/pos/pos.factor index 3071ebcf5f..24c5410e99 100644 --- a/extra/pos/pos.factor +++ b/extra/pos/pos.factor @@ -1,5 +1,5 @@ -USING: kernel math math.vectors sequences self ; +USING: kernel math math.functions math.vectors sequences self ; IN: pos diff --git a/extra/tar/tar.factor b/extra/tar/tar.factor index e41264680c..01a50566b4 100644 --- a/extra/tar/tar.factor +++ b/extra/tar/tar.factor @@ -164,7 +164,7 @@ TUPLE: unimplemented-typeflag header ; ! Long file name : typeflag-L ( header -- ) [ read-data-blocks ] keep - >string [ CHAR: \0 = ] rtrim filename set + >string [ CHAR: \0 = ] right-trim filename set global [ "long filename: " write filename get . flush ] bind filename get tar-path+ make-directories ; diff --git a/extra/tetris/game/game.factor b/extra/tetris/game/game.factor index 869a7c49c2..74c2f5f1cb 100644 --- a/extra/tetris/game/game.factor +++ b/extra/tetris/game/game.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006, 2007 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: kernel sequences math tetris.board tetris.piece -tetris.tetromino lazy-lists combinators system ; +USING: kernel sequences math math.functions tetris.board +tetris.piece tetris.tetromino lazy-lists combinators system ; IN: tetris.game TUPLE: tetris pieces last-update update-interval rows score game-state paused? running? ; diff --git a/misc/integration/deploy-size-test.factor b/misc/integration/deploy-size-test.factor new file mode 100644 index 0000000000..91cdaba293 --- /dev/null +++ b/misc/integration/deploy-size-test.factor @@ -0,0 +1,28 @@ +USING: tools.deploy sequences io.files io.launcher io +kernel concurrency prettyprint ; + +"." resource-path cd + +"deploy-log" make-directory + +{ + "automata.ui" + "boids.ui" + "bunny" + "color-picker" + "gesture-logger" + "golden-section" + "hello-world" + "hello-ui" + "lsys.ui" + "maze" + "nehe" + "tetris" + "catalyst-talk" +} [ + dup + "deploy-log/" over append + [ deploy ] with-stream + dup file-length 1024 /f + 2array +] parallel-map . diff --git a/misc/integration/macosx-deploy.factor b/misc/integration/macosx-deploy.factor index 29642a08eb..f1e6e7fe06 100644 --- a/misc/integration/macosx-deploy.factor +++ b/misc/integration/macosx-deploy.factor @@ -3,7 +3,7 @@ kernel concurrency ; "." resource-path cd -"mkdir deploy-log" run-process +"deploy-log" make-directory { "automata.ui" From f50e8de835bac3f5e797c635f6e39180b813e740 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 21 Oct 2007 18:10:27 -0400 Subject: [PATCH 17/20] Remove partial redraw optimization because there are too many broken GL implementations --- extra/ui/gadgets/worlds/worlds.factor | 8 ++--- extra/ui/ui.factor | 28 +++++---------- extra/ui/windows/windows.factor | 13 ++----- extra/ui/x11/x11.factor | 48 ++------------------------ extra/windows/opengl32/opengl32.factor | 7 ---- extra/x11/glx/glx.factor | 11 +----- 6 files changed, 20 insertions(+), 95 deletions(-) diff --git a/extra/ui/gadgets/worlds/worlds.factor b/extra/ui/gadgets/worlds/worlds.factor index 324dd7ddce..8000b90bd4 100644 --- a/extra/ui/gadgets/worlds/worlds.factor +++ b/extra/ui/gadgets/worlds/worlds.factor @@ -63,9 +63,9 @@ M: world focusable-child* gadget-child ; M: world children-on nip gadget-children ; -: (draw-world) ( rect world -- ) +: (draw-world) ( world -- ) dup world-handle [ - [ init-gl ] keep draw-gadget + [ dup init-gl ] keep draw-gadget ] with-gl-context ; : draw-world? ( world -- ? ) @@ -87,7 +87,7 @@ SYMBOL: ui-error-hook [ rethrow ] ui-error-hook set-global -: draw-world ( rect world -- ) +: draw-world ( world -- ) dup draw-world? [ dup world [ [ @@ -99,7 +99,7 @@ SYMBOL: ui-error-hook ] recover ] with-variable ] [ - 2drop + drop ] if ; world H{ diff --git a/extra/ui/ui.factor b/extra/ui/ui.factor index e93496c071..18886ef348 100644 --- a/extra/ui/ui.factor +++ b/extra/ui/ui.factor @@ -55,7 +55,7 @@ SYMBOL: windows : open-world-window ( world -- ) dup pref-dim over set-gadget-dim dup (open-world-window) - dup draw-world ; + draw-world ; : open-window ( gadget title -- ) >r [ 1 track, ] { 0 1 } make-track r> @@ -77,19 +77,12 @@ SYMBOL: windows dup hand-world get-global eq? [ hand-loc get-global swap move-hand ] [ drop ] if ; -: post-layout ( hash gadget -- ) - dup find-world dup [ - rot [ - >r screen-rect r> [ rect-union ] when* - ] change-at - ] [ - 3drop - ] if ; - -: layout-queued ( -- hash ) - H{ } clone invalid [ - dup layout dupd post-layout - ] queue-each ; +: layout-queued ( -- seq ) + [ + invalid [ + dup layout find-world [ , ] when* + ] queue-each + ] { } make ; SYMBOL: ui-hook @@ -105,11 +98,8 @@ SYMBOL: ui-hook init-ui ui-hook get call ] if ; -: redraw-worlds ( hash -- ) - [ - swap dup update-hand - dup world-handle [ draw-world ] [ 2drop ] if - ] assoc-each ; +: redraw-worlds ( seq -- ) + [ dup update-hand draw-world ] each ; : ui-step ( -- ) [ diff --git a/extra/ui/windows/windows.factor b/extra/ui/windows/windows.factor index a320c7ccd0..5f08c5afe1 100644 --- a/extra/ui/windows/windows.factor +++ b/extra/ui/windows/windows.factor @@ -65,7 +65,7 @@ M: pasteboard set-clipboard-contents drop copy ; selection set-global ; ! world-handle is a -TUPLE: win hWnd hDC hRC swap-hint? world title ; +TUPLE: win hWnd hDC hRC world title ; C: win SYMBOL: msg-obj @@ -413,11 +413,8 @@ SYMBOL: hWnd dup wglCreateContext dup win32-error=0/f [ wglMakeCurrent win32-error=0/f ] keep ; -: setup-gl ( hwnd -- hDC hRC swap-hint? ) - get-dc - dup setup-pixel-format - dup get-rc - swap-hint-supported? ; +: setup-gl ( hwnd -- hDC hRC ) + get-dc dup setup-pixel-format get-rc ; M: windows-ui-backend (open-world-window) ( world -- ) [ rect-dim first2 create-window dup setup-gl ] keep @@ -430,10 +427,6 @@ M: windows-ui-backend select-gl-context ( handle -- ) [ win-hDC ] keep win-hRC wglMakeCurrent win32-error=0/f ; M: windows-ui-backend flush-gl-context ( handle -- ) - dup win-swap-hint? [ - clip get flip-rect fix-coordinates - glAddSwapHintRectWIN - ] when win-hDC SwapBuffers win32-error=0/f ; ! Move window to front diff --git a/extra/ui/x11/x11.factor b/extra/ui/x11/x11.factor index c9b23e10e3..fe0f1fa9eb 100644 --- a/extra/ui/x11/x11.factor +++ b/extra/ui/x11/x11.factor @@ -12,7 +12,7 @@ TUPLE: x11-ui-backend ; : XA_NET_WM_NAME "_NET_WM_NAME" x-atom ; -TUPLE: x11-handle window glx xic copy-sub-buffer? ; +TUPLE: x11-handle window glx xic ; C: x11-handle @@ -173,8 +173,7 @@ M: world client-event : gadget-window ( world -- ) dup world-loc over rect-dim glx-window - over "Factor" create-xic - copy-sub-buffer-supported? + over "Factor" create-xic 2dup x11-handle-window register-window swap set-world-handle ; @@ -238,49 +237,8 @@ M: x11-ui-backend select-gl-context ( handle -- ) dup x11-handle-window swap x11-handle-glx glXMakeCurrent [ "Failed to set current GLX context" throw ] unless ; -: swap-buffers-mesa ( handle -- ) - dpy get swap x11-handle-window - clip get flip-rect fix-coordinates - glXCopySubBufferMESA ; - -: swap-buffers-full ( handle -- ) - dpy get swap x11-handle-window glXSwapBuffers ; - -: gl-raster-pos ( loc -- ) - first2 [ >fixnum ] 2apply glRasterPos2i ; - -: gl-copy-pixels ( loc dim buffer -- ) - >r fix-coordinates r> glCopyPixels ; - -: swap-buffers-slow ( -- ) - GL_BACK glReadBuffer - GL_FRONT glDrawBuffer - GL_SCISSOR_TEST glDisable - GL_ONE GL_ZERO glBlendFunc - clip get rect-bounds { 0 1 } v* v+ gl-raster-pos - clip get flip-rect GL_COLOR gl-copy-pixels - GL_BACK glDrawBuffer - glFlush ; - -: swap-buffer-strategy - "swap-buffer-strategy" get "slow" or ; - -: can-swap-full? ( -- ? ) - clip get world get delegates [ rect? ] find nip = ; - -: swap-buffers ( handle strategy -- ) - { - { "mesa" [ swap-buffers-mesa ] } - { "full" [ swap-buffers-full ] } - { "slow" [ - can-swap-full? - [ swap-buffers-full ] - [ drop swap-buffers-slow ] if - ] } - } case ; - M: x11-ui-backend flush-gl-context ( handle -- ) - swap-buffer-strategy swap-buffers ; + dpy get swap x11-handle-window glXSwapBuffers ; M: x11-ui-backend ui ( -- ) [ diff --git a/extra/windows/opengl32/opengl32.factor b/extra/windows/opengl32/opengl32.factor index 93473a4fd3..2d58d34083 100644 --- a/extra/windows/opengl32/opengl32.factor +++ b/extra/windows/opengl32/opengl32.factor @@ -101,10 +101,3 @@ FUNCTION: HGLRC wglCreateContext ( HDC hDC ) ; FUNCTION: BOOL wglDeleteContext ( HGLRC hRC ) ; FUNCTION: BOOL wglMakeCurrent ( HDC hDC, HGLRC hglrc ) ; FUNCTION: void* wglGetProcAddress ( char* name ) ; - -: glAddSwapHintRectWIN ( x y width height -- ) - "glAddSwapHintRectWIN" wglGetProcAddress check-ptr - "void" { "int" "int" "int" "int" } "stdcall" alien-indirect ; - -: swap-hint-supported? ( -- ? ) - "GL_WIN_swap_hint" GL_EXTENSIONS glGetString subseq? ; diff --git a/extra/x11/glx/glx.factor b/extra/x11/glx/glx.factor index 5402575c02..1a898c50a9 100644 --- a/extra/x11/glx/glx.factor +++ b/extra/x11/glx/glx.factor @@ -99,13 +99,4 @@ FUNCTION: void* glXGetProcAddress ( char* procname ) ; [ "Failed to create GLX context" throw ] unless* ; : destroy-glx ( GLXContext -- ) - dpy get swap glXDestroyContext ; - -: copy-sub-buffer-supported? ( -- ? ) - "GLX_MESA_copy_sub_buffer" - dpy get scr get glXQueryExtensionsString subseq? ; - -: glXCopySubBufferMESA ( dpy drawable x y width height -- ) - "glXCopySubBufferMESA" glXGetProcAddress - "void" { "Display*" "GLXDrawable" "int" "int" "int" "int" } - "cdecl" alien-indirect ; \ No newline at end of file + dpy get swap glXDestroyContext ; \ No newline at end of file From a271b84bba6c3c00c08ad2e6b03c52cf2f48ddfb Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 21 Oct 2007 18:47:46 -0400 Subject: [PATCH 18/20] Fix quaternions unit tests --- extra/math/quaternions/quaternions-tests.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/extra/math/quaternions/quaternions-tests.factor b/extra/math/quaternions/quaternions-tests.factor index 42cb72acb1..4f59798df0 100644 --- a/extra/math/quaternions/quaternions-tests.factor +++ b/extra/math/quaternions/quaternions-tests.factor @@ -14,8 +14,8 @@ math.constants ; [ t ] [ qj qj q* q1 v+ q0 = ] unit-test [ t ] [ qk qk q* q1 v+ q0 = ] unit-test [ t ] [ qi qj qk q* q* q1 v+ q0 = ] unit-test -[ t ] [ i qj n*v qk = ] unit-test -[ t ] [ qj i q*n qk v+ q0 = ] unit-test +[ t ] [ C{ 0 1 } qj n*v qk = ] unit-test +[ t ] [ qj C{ 0 1 } q*n qk v+ q0 = ] unit-test [ t ] [ qk qj q/ qi = ] unit-test [ t ] [ qi qk q/ qj = ] unit-test [ t ] [ qj qi q/ qk = ] unit-test @@ -23,4 +23,4 @@ math.constants ; [ t ] [ qj q>v v>q qj = ] unit-test [ t ] [ qk q>v v>q qk = ] unit-test [ t ] [ 1 c>q q1 = ] unit-test -[ t ] [ i c>q qi = ] unit-test +[ t ] [ C{ 0 1 } c>q qi = ] unit-test From 9d80b13932ac474de492b96fcffcf2a509d074af Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 22 Oct 2007 03:49:19 -0400 Subject: [PATCH 19/20] Add sanity check --- vm/code_heap.c | 5 +++++ vm/debug.c | 1 + 2 files changed, 6 insertions(+) diff --git a/vm/code_heap.c b/vm/code_heap.c index fd910ef9d4..9487c7a47a 100644 --- a/vm/code_heap.c +++ b/vm/code_heap.c @@ -70,6 +70,11 @@ INLINE void reloc_set_2_2(CELL cell, CELL value) /* Store a value into a bitfield of a PowerPC instruction */ INLINE void reloc_set_masked(CELL cell, F_FIXNUM value, CELL mask, F_FIXNUM shift) { + /* This is unaccurate but good enough */ + F_FIXNUM test = (F_FIXNUM)mask >> 1; + if(value <= -test || value >= test) + critical_error("Value does not fit inside relocation",0); + u32 original = *(u32*)cell; original &= ~mask; *(u32*)cell = (original | ((value >> shift) & mask)); diff --git a/vm/debug.c b/vm/debug.c index f0d74233d1..d8cfd1c599 100755 --- a/vm/debug.c +++ b/vm/debug.c @@ -111,6 +111,7 @@ void print_stack_frame(F_STACK_FRAME *frame) printf("\n"); print_obj(frame_scan(frame)); printf("\n"); + printf("%lx\n",(CELL)frame->xt); } void print_callstack(void) From 850c145a09ae6463fffb60b79de85eff312d77ca Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 24 Oct 2007 02:01:43 -0400 Subject: [PATCH 20/20] Fix bootstrap hang --- core/math/math.factor | 4 ++++ vm/debug.c | 1 + 2 files changed, 5 insertions(+) diff --git a/core/math/math.factor b/core/math/math.factor index 7f796e91b7..fea77855eb 100755 --- a/core/math/math.factor +++ b/core/math/math.factor @@ -91,6 +91,10 @@ M: real hashcode* nip >fixnum ; M: real <=> - ; ! real and sequence overlap. we disambiguate: +M: integer equal? number= ; + +M: integer hashcode* nip >fixnum ; + M: integer <=> - ; GENERIC: fp-nan? ( x -- ? ) diff --git a/vm/debug.c b/vm/debug.c index d8cfd1c599..b0761a4c5c 100755 --- a/vm/debug.c +++ b/vm/debug.c @@ -111,6 +111,7 @@ void print_stack_frame(F_STACK_FRAME *frame) printf("\n"); print_obj(frame_scan(frame)); printf("\n"); + printf("%lx\n",(CELL)frame_executing(frame)); printf("%lx\n",(CELL)frame->xt); }