diff --git a/Makefile b/Makefile index 8f0343d860..df4e31bd19 100644 --- a/Makefile +++ b/Makefile @@ -3,13 +3,13 @@ CC = gcc BINARY = f IMAGE = factor.image BUNDLE = Factor.app -VERSION = 0.86 +VERSION = 0.87 DISK_IMAGE_DIR = Factor-$(VERSION) DISK_IMAGE = Factor-$(VERSION).dmg LIBPATH = -L/usr/X11R6/lib ifdef DEBUG - CFLAGS = -pg -O1 + CFLAGS = -g STRIP = touch else CFLAGS = -Wall -O3 -ffast-math -fomit-frame-pointer $(SITE_CFLAGS) diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index e615f2cfec..2f34a4e02e 100644 --- a/TODO.FACTOR.txt +++ b/TODO.FACTOR.txt @@ -1,5 +1,9 @@ + 0.87: +- amd64 structs-by-value bug +- intrinsic fixnum>float float>fixnum +- compiled call traces + - fix search unit test - these things are "Too Slow": - all-words @@ -18,10 +22,7 @@ - graphical crossref tool - ui browser: show currently selected vocab & words - auto-update browser and help when sources reload -- amd64 structs-by-value bug -- intrinsic fixnum>float float>fixnum - mac intel: struct returns from objc methods -- compiled call traces - new windows don't always have focus, eg focus follows mouse - listener commands from a menu should not include 'hide-glass' etc - bogus compile errors? @@ -32,7 +33,6 @@ - ui docs - some kind of declarative wiring framework for ui - overhaul models, set-model* is crap -- allow rebinding styles - fix windows gcc issue - robustify stepper -- see if step back past a throw works diff --git a/library/compiler/alien/alien-callback.factor b/library/compiler/alien/alien-callback.factor index c7ab5d4be6..5135049aa9 100644 --- a/library/compiler/alien/alien-callback.factor +++ b/library/compiler/alien/alien-callback.factor @@ -2,7 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. IN: alien USING: compiler errors generic hashtables inference -kernel namespaces sequences strings words parser prettyprint ; +kernel namespaces sequences strings words parser prettyprint +kernel-internals ; ! Callbacks are registered in a global hashtable. If you clear ! this hashtable, they will all be blown away by code GC, beware diff --git a/library/compiler/ppc/architecture.factor b/library/compiler/ppc/architecture.factor index d6a309e8c1..6035c21c23 100644 --- a/library/compiler/ppc/architecture.factor +++ b/library/compiler/ppc/architecture.factor @@ -13,6 +13,16 @@ memory namespaces sequences words ; ! r14 data stack ! r15 call stack +! Stack layout: + +! Mach-O -vs- Linux/PPC +: stack@ macosx? 24 8 ? + ; +: lr@ macosx? 8 4 ? + ; + +! Frames are 16-byte aligned, minimum size is 32 bytes +! Grows down +! - lr@: return address + M: int-regs return-reg drop 3 ; M: int-regs fastcall-regs drop { 3 4 5 6 7 8 9 10 } ; M: int-regs vregs drop { 3 4 5 6 7 8 9 10 } ; @@ -21,9 +31,6 @@ M: float-regs return-reg drop 1 ; M: float-regs fastcall-regs drop { 1 2 3 4 5 6 7 8 } ; M: float-regs vregs drop { 0 1 2 3 4 5 6 7 8 9 10 11 12 13 } ; -! Mach-O -vs- Linux/PPC -: stack@ macosx? 24 8 ? + ; -: lr@ macosx? 8 4 ? + ; GENERIC: loc>operand ( loc -- reg n ) diff --git a/library/errors.factor b/library/errors.factor index 07e76674ac..6062f749a1 100644 --- a/library/errors.factor +++ b/library/errors.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2004, 2006 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. IN: kernel-internals -USING: arrays generic namespaces sequences ; +USING: arrays generic namespaces sequences math ; : >c ( continuation -- ) catchstack* push ; : c> ( -- continuation ) catchstack* pop ; @@ -11,6 +11,8 @@ USING: kernel ; SYMBOL: error SYMBOL: error-continuation +SYMBOL: error-stack-trace +SYMBOL: restarts : catch ( try -- error/f ) [ >c call f c> drop f ] callcc1 nip ; inline @@ -49,4 +51,7 @@ M: condition compute-restarts [ condition-cc ] keep condition-restarts [ swap add ] map-with append ; +PREDICATE: array kernel-error ( obj -- ? ) + dup first \ kernel-error eq? swap second 0 18 between? and ; + DEFER: try diff --git a/library/errors.facts b/library/errors.facts index d0ff2a57f5..12f1e3b66b 100644 --- a/library/errors.facts +++ b/library/errors.facts @@ -9,6 +9,10 @@ HELP: error-continuation { $description "Global variable holding current continuation of most recently thrown error." } { $notes "Only updated by " { $link throw } ", not " { $link rethrow } "." } ; +HELP: restarts +{ $var-description "Global variable holding the set of possible restarts for the most recently thrown error." } +{ $notes "Only updated by " { $link throw } ", not " { $link rethrow } "." } ; + HELP: >c { $values { "continuation" "a continuation" } } { $description "Pushes an exception handler continuation on the catch stack. The continuation must have been reified by " { $link callcc1 } "." } ; diff --git a/library/io/c-streams.facts b/library/io/c-streams.facts index 25b43dbdab..468037b63c 100644 --- a/library/io/c-streams.facts +++ b/library/io/c-streams.facts @@ -17,8 +17,8 @@ HELP: HELP: { $values { "host" "a string" } { "port" "an integer between 0 and 65535" } { "stream" "a bidirectional stream" } } -{ $description "Connects to TCP/IP port number " { $code "port" } " on the host named by " { $code "host" } ", and outputs a bidirectional stream." } -{ $errors "Throws an error if domain name lookup fails, or if there is a connection cannot be established." } ; +{ $description "Connects to TCP/IP port number " { $snippet "port" } " on the host named by " { $snippet "host" } ", and outputs a bidirectional stream." } +{ $errors "Throws an error if domain name lookup fails, or if the connection cannot be established." } ; HELP: { $values { "port" "an integer between 0 and 65535" } { "server" "a handle" } } @@ -32,10 +32,10 @@ HELP: { $errors "Throws an error if the port is already in use, or if the OS forbits access." } ; HELP: accept -{ $values { "server" "a handle" } { "stream" "a bidirectional stream" } } +{ $values { "server" "a handle" } { "client" "a bidirectional stream" } } { $description "Waits for a connection to a server socket created by " { $link } ", and outputs a bidirectional stream when the connection has been established." $terpri -"The client socket supports two accessor words to get the host name and port number of the incoming connection:" +"The new stream supports two accessor words to get the host name and port number of the incoming connection:" { $list { $link client-stream-host } { $link client-stream-port } } } { $errors "Throws an error if the server socket is closed or otherwise is unavailable." } ; diff --git a/library/io/styles.facts b/library/io/styles.facts index b5619e1269..8a0714d921 100644 --- a/library/io/styles.facts +++ b/library/io/styles.facts @@ -38,7 +38,7 @@ HELP: font { $description "Character style. Font family named by a string." } { $examples "This example outputs some different font sizes:" - { $code "{ \"Monospaced\" \"Serif\" \"Sans Serif\" }\n[ dup font associate format terpri ] each" } + { $code "{ \"monospace\" \"serif\" \"sans-serif\" }\n[ dup font associate format terpri ] each" } } ; HELP: font-size @@ -90,7 +90,7 @@ HELP: outline { $see-also write-outliner } ; HELP: table-gap -{ $description "Table style. Pixels between table cells." } +{ $description "Table style. Horizontal and vertical gap between table cells, denoted by a pair of integers." } { $see-also with-stream-table tabular-output } ; HELP: table-border diff --git a/library/tools/debugger.factor b/library/tools/debugger.factor index dcca8a251f..7660b13584 100644 --- a/library/tools/debugger.factor +++ b/library/tools/debugger.factor @@ -1,12 +1,43 @@ ! Copyright (C) 2004, 2006 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays definitions generic hashtables help tools io -kernel kernel-internals math namespaces parser prettyprint -sequences sequences-internals strings styles vectors words ; -IN: errors +kernel math namespaces parser prettyprint sequences +sequences-internals strings styles vectors words errors ; +IN: kernel-internals -PREDICATE: array kernel-error ( obj -- ? ) - dup first \ kernel-error eq? swap second 0 18 between? and ; +: save-error ( error trace continuation -- ) + error-continuation set-global + error-stack-trace set-global + dup error set-global + compute-restarts restarts set-global ; + +: error-handler ( error trace -- ) + dupd continuation save-error rethrow ; + +: init-error-handler ( -- ) + V{ } clone set-catchstack + ! kernel calls on error + [ error-handler ] 5 setenv + \ kernel-error 12 setenv ; + +: code-heap-start 17 getenv ; +: code-heap-end 18 getenv ; + +: ( -- xtmap ) + [ + f code-heap-start 2array , + all-words [ compiled? ] subset + [ dup word-xt 2array , ] each + f code-heap-end 2array , + ] { } make [ [ second ] 2apply - ] sort ; + +: find-xt ( xt xtmap -- word ) + [ second - ] binsearch* first ; + +: symbolic-stack-trace ( seq -- seq ) + swap [ dup pick find-xt 2array ] map nip ; + +IN: errors GENERIC: error. ( error -- ) GENERIC: error-help ( error -- topic ) @@ -19,16 +50,29 @@ M: tuple error-help class ; M: string error. print ; -SYMBOL: restarts - : :s ( -- ) error-continuation get continuation-data stack. ; : :r ( -- ) error-continuation get continuation-retain stack. ; +: xt. ( xt -- ) + >hex cell 2 * CHAR: 0 pad-left write ; + +: word-xt. ( xt word -- ) + "Compiled: " write dup pprint bl + "(offset " write word-xt - >hex write ")" write ; + +: bare-xt. ( xt -- ) + "C code: " write xt. ; + +: :trace + error-stack-trace get symbolic-stack-trace [ + first2 [ word-xt. ] [ bare-xt. ] if* terpri + ] each ; + : :c ( -- ) - error-continuation get continuation-call callstack. ; + error-continuation get continuation-call callstack. :trace ; : :get ( variable -- value ) error-continuation get continuation-name hash-stack ; @@ -99,17 +143,3 @@ SYMBOL: restarts ] recover drop ; : try ( quot -- ) [ print-error ] recover ; - -: save-error ( error continuation -- ) - error-continuation set-global - dup error set-global - compute-restarts restarts set-global ; - -: error-handler ( error -- ) - dup continuation save-error rethrow ; - -: init-error-handler ( -- ) - V{ } clone set-catchstack - ! kernel calls on error - [ error-handler ] 5 setenv - \ kernel-error 12 setenv ; diff --git a/library/tools/debugger.facts b/library/tools/debugger.facts index e7bffe13a9..ad2811f65c 100644 --- a/library/tools/debugger.facts +++ b/library/tools/debugger.facts @@ -2,10 +2,6 @@ IN: errors USING: alien arrays generic help kernel math memory strings vectors ; -HELP: restarts -{ $var-description "Global variable holding the set of possible restarts for the most recently thrown error." } -{ $notes "Only updated by " { $link throw } ", not " { $link rethrow } "." } ; - HELP: :s { $description "Prints the data stack at the time of the most recent error. Used for interactive debugging." } ; diff --git a/library/tools/describe.factor b/library/tools/describe.factor index 64a34fa983..2c37f43e06 100644 --- a/library/tools/describe.factor +++ b/library/tools/describe.factor @@ -44,7 +44,7 @@ M: hashtable sheet hash>alist ; : describe ( object -- ) dup summary print sheet sheet. ; -: stack. ( seq -- ) >array sheet sheet. ; +: stack. ( seq -- ) >array sheet sheet. ; : .s ( -- ) datastack stack. ; : .r ( -- ) retainstack stack. ; @@ -58,6 +58,6 @@ M: hashtable sheet hash>alist ; ] with-scope ; : callstack. ( seq -- ) - 3 group [ first2 1- callframe. ] each ; + 3 group [ first2 1- callframe. ] each ; : .c ( -- ) callstack callstack. ; diff --git a/vm/cpu-ppc.S b/vm/cpu-ppc.S index e6b1858098..69347d1df3 100644 --- a/vm/cpu-ppc.S +++ b/vm/cpu-ppc.S @@ -1,3 +1,9 @@ +#ifdef __APPLE__ + #define MANGLE(sym) _##sym +#else + #define MANGLE(sym) sym +#endif + /* Thanks to Joshua Grams for this code. On PowerPC processors, we must flush the instruction cache manually @@ -6,12 +12,6 @@ after writing to the code heap. Callable from C as void flush_icache(void *start, int len) */ -#ifdef __APPLE__ - #define MANGLE(sym) _##sym -#else - #define MANGLE(sym) sym -#endif - .globl MANGLE(flush_icache) MANGLE(flush_icache): /* compute number of cache lines to flush */ @@ -30,3 +30,10 @@ MANGLE(flush_icache): sync /* finish up */ isync blr + +/* Callable from C as +void *native_stack_pointer(void) */ + .globl MANGLE(native_stack_pointer) +MANGLE(native_stack_pointer): + mr r3,r1 /* native stack pointer is in r1 */ + blr diff --git a/vm/cpu-ppc.h b/vm/cpu-ppc.h index ff3c7b67eb..8d8f2bace3 100644 --- a/vm/cpu-ppc.h +++ b/vm/cpu-ppc.h @@ -5,3 +5,5 @@ register CELL rs asm("r15"); register CELL cards_offset asm("r16"); void flush_icache(CELL start, CELL len); + +void *native_stack_pointer(void); diff --git a/vm/cpu-x86.h b/vm/cpu-x86.h index 0f880a56d1..335398eb98 100644 --- a/vm/cpu-x86.h +++ b/vm/cpu-x86.h @@ -5,3 +5,15 @@ register CELL rs asm("edi"); CELL cards_offset; INLINE void flush_icache(CELL start, CELL len) {} + +INLINE void *native_stack_pointer(void) +{ + void *ptr; + asm("mov %%ebp, %0" : "=r" (ptr)); + return ptr; +} + +typedef struct _F_STACK_FRAME { + struct _F_STACK_FRAME *previous; + CELL *return_address; +} F_STACK_FRAME; diff --git a/vm/factor.c b/vm/factor.c index 6a7474dc8f..a66cad0875 100644 --- a/vm/factor.c +++ b/vm/factor.c @@ -25,6 +25,8 @@ void init_factor(const char* image, userenv[GEN_ENV] = tag_fixnum(gen_count); userenv[IMAGE_ENV] = tag_object(from_char_string(image)); userenv[CELL_SIZE_ENV] = tag_fixnum(sizeof(CELL)); + userenv[CODE_HEAP_START_ENV] = allot_cell(compiling.base); + userenv[CODE_HEAP_END_ENV] = allot_cell(compiling.limit); } INLINE bool factor_arg(const char* str, const char* arg, CELL* value) diff --git a/vm/os-macosx-ppc.h b/vm/os-macosx-ppc.h index 1ec8a2f1f0..fc6b2dc7c4 100644 --- a/vm/os-macosx-ppc.h +++ b/vm/os-macosx-ppc.h @@ -1,3 +1,9 @@ +typedef struct _F_STACK_FRAME { + struct _F_STACK_FRAME *previous; + CELL padding; + CELL *return_address; +} F_STACK_FRAME; + #define SIGSEGV_EXC_STATE_TYPE ppc_exception_state_t #define SIGSEGV_EXC_STATE_FLAVOR PPC_EXCEPTION_STATE #define SIGSEGV_EXC_STATE_COUNT PPC_EXCEPTION_STATE_COUNT diff --git a/vm/os-unix.c b/vm/os-unix.c index 9eafceff63..def72f3c16 100644 --- a/vm/os-unix.c +++ b/vm/os-unix.c @@ -85,8 +85,7 @@ void primitive_stat(void) void primitive_read_dir(void) { DIR* dir = opendir(unbox_char_string()); - CELL result_count = 0; - F_ARRAY *result = allot_array(ARRAY_TYPE,100,F); + GROWABLE_ARRAY(result); if(dir != NULL) { @@ -94,24 +93,16 @@ void primitive_read_dir(void) while((file = readdir(dir)) != NULL) { - if(result_count == array_capacity(result)) - { - result = reallot_array(result, - result_count * 2,F); - } - REGISTER_ARRAY(result); CELL name = tag_object(from_char_string(file->d_name)); UNREGISTER_ARRAY(result); - - set_array_nth(result,result_count,name); - result_count++; + GROWABLE_ADD(result,name); } closedir(dir); } - result = reallot_array(result,result_count,F); + GROWABLE_TRIM(result); dpush(tag_object(result)); } diff --git a/vm/os-windows.c b/vm/os-windows.c index b91de62197..cf30e3638e 100644 --- a/vm/os-windows.c +++ b/vm/os-windows.c @@ -115,31 +115,23 @@ void primitive_read_dir(void) sprintf(path, "%s\\*", unbox_char_string()); - F_ARRAY *result = allot_array(ARRAY_TYPE,100,F); + GROWABLE_ARRAY(result); if(INVALID_HANDLE_VALUE != (dir = FindFirstFile(path, &find_data))) { do { - if(result_count == array_capacity(result)) - { - result = reallot_array(result, - result_count * 2,F); - } - REGISTER_ARRAY(result); CELL name = tag_object(from_char_string( find_data.cFileName)); UNREGISTER_ARRAY(result); - - set_array_nth(result,result_count,name); - result_count++; + GROWABLE_ADD(result,name); } while (FindNextFile(dir, &find_data)); CloseHandle(dir); } - result = reallot_array(result,result_count,F); + GROWABLE_TRIM(result); dpush(tag_object(result)); } diff --git a/vm/run.c b/vm/run.c index bc1b8e0fae..97d66506a1 100644 --- a/vm/run.c +++ b/vm/run.c @@ -53,6 +53,7 @@ void handle_error(void) fix_stacks(); dpush(thrown_error); + dpush(thrown_native_stack_trace); /* Notify any 'catch' blocks */ push_callframe(); set_callframe(userenv[BREAK_ENV]); @@ -103,6 +104,7 @@ void interpreter_loop(void) void interpreter(void) { + stack_chain->native_stack_pointer = native_stack_pointer(); SETJMP(stack_chain->toplevel); handle_error(); interpreter_loop(); @@ -254,6 +256,28 @@ void early_error(CELL error) } } +CELL native_stack_trace(void) +{ + F_STACK_FRAME *frame = native_stack_pointer(); + GROWABLE_ARRAY(array); + + while((CELL)frame < (CELL)stack_chain->native_stack_pointer) + { + fflush(stdout); + REGISTER_ARRAY(array); + CELL cell = allot_cell((CELL)frame->return_address); + UNREGISTER_ARRAY(array); + GROWABLE_ADD(array,cell); + if((CELL)frame->previous <= (CELL)frame) + critical_error("C stack is busted",(CELL)frame); + frame = frame->previous; + } + + GROWABLE_TRIM(array); + + return tag_object(array); +} + void throw_error(CELL error, bool keep_stacks) { early_error(error); @@ -263,6 +287,7 @@ void throw_error(CELL error, bool keep_stacks) thrown_keep_stacks = keep_stacks; thrown_ds = ds; thrown_rs = rs; + thrown_native_stack_trace = native_stack_trace(); /* Return to interpreter() function */ LONGJMP(stack_chain->toplevel,1); diff --git a/vm/run.h b/vm/run.h index 8a56a4fd5d..7c443073fa 100644 --- a/vm/run.h +++ b/vm/run.h @@ -12,22 +12,24 @@ CELL callframe_end; #define USER_ENV 32 -#define CELL_SIZE_ENV 1 /* sizeof(CELL) */ -#define NLX_VECTOR_ENV 2 /* non-local exit hook, used by library only */ -#define NAMESTACK_ENV 3 /* used by library only */ -#define GLOBAL_ENV 4 -#define BREAK_ENV 5 -#define CATCHSTACK_ENV 6 /* used by library only */ -#define CPU_ENV 7 -#define BOOT_ENV 8 -#define CALLCC_1_ENV 9 /* used by library only */ -#define ARGS_ENV 10 -#define OS_ENV 11 -#define ERROR_ENV 12 /* a marker consed onto kernel errors */ -#define IN_ENV 13 -#define OUT_ENV 14 -#define GEN_ENV 15 /* set to gen_count */ -#define IMAGE_ENV 16 /* image name */ +#define CELL_SIZE_ENV 1 /* sizeof(CELL) */ +#define NLX_VECTOR_ENV 2 /* non-local exit hook, used by library only */ +#define NAMESTACK_ENV 3 /* used by library only */ +#define GLOBAL_ENV 4 +#define BREAK_ENV 5 +#define CATCHSTACK_ENV 6 /* used by library only */ +#define CPU_ENV 7 +#define BOOT_ENV 8 +#define CALLCC_1_ENV 9 /* used by library only */ +#define ARGS_ENV 10 +#define OS_ENV 11 +#define ERROR_ENV 12 /* a marker consed onto kernel errors */ +#define IN_ENV 13 +#define OUT_ENV 14 +#define GEN_ENV 15 /* set to gen_count */ +#define IMAGE_ENV 16 /* image name */ +#define CODE_HEAP_START_ENV 17 /* start of code heap, used by :trace */ +#define CODE_HEAP_END_ENV 18 /* end of code heap, used by :trace */ /* TAGGED user environment data; see getenv/setenv prims */ DLLEXPORT CELL userenv[USER_ENV]; @@ -176,6 +178,7 @@ volatile bool throwing; /* When throw_error throws an error, it sets this global and longjmps back to the top-level. */ CELL thrown_error; +CELL thrown_native_stack_trace; CELL thrown_keep_stacks; /* Since longjmp restores registers, we must save all these values. */ CELL thrown_ds; diff --git a/vm/stack.h b/vm/stack.h index d913e5ed00..037a57016f 100644 --- a/vm/stack.h +++ b/vm/stack.h @@ -34,6 +34,9 @@ typedef struct _F_STACKS { /* saved extra_roots pointer on entry to callback */ CELL extra_roots; + /* C stack pointer on entry */ + void *native_stack_pointer; + /* error handler longjmp buffer */ JMP_BUF toplevel; diff --git a/vm/types.h b/vm/types.h index 65ef0b9b23..223c665cc8 100644 --- a/vm/types.h +++ b/vm/types.h @@ -50,6 +50,32 @@ INLINE CELL array_capacity(F_ARRAY* array) return array->capacity >> TAG_BITS; } +#define GROWABLE_ARRAY(result) \ + CELL result##_count = 0; \ + F_ARRAY *result = allot_array(ARRAY_TYPE,100,F) + +INLINE F_ARRAY *growable_add(F_ARRAY *result, CELL elt, CELL *result_count) +{ + REGISTER_ROOT(elt); + + if(*result_count == array_capacity(result)) + { + result = reallot_array(result, + *result_count * 2,F); + } + + UNREGISTER_ROOT(elt); + set_array_nth(result,*result_count,elt); + *result_count = *result_count + 1; + + return result; +} + +#define GROWABLE_ADD(result,elt) \ + result = growable_add(result,elt,&result##_count) + +#define GROWABLE_TRIM(result) result = reallot_array(result,result##_count,F) + INLINE F_VECTOR* untag_vector(CELL tagged) { type_check(VECTOR_TYPE,tagged);