Fix documentation typos, start working on compiled stack traces

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)

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
 

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

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 )
 

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

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 } "." } ;

library/io/c-streams.facts

@@ -17,8 +17,8 @@ HELP: <file-writer>
 
 HELP: <client>
 { $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." }
+{ $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 there is a connection cannot be established." } ;
+{ $errors "Throws an error if domain name lookup fails, or if the connection cannot be established." } ;
 
 HELP: <server>
 { $values  { "port" "an integer between 0 and 65535" } { "server" "a handle" } }
@@ -32,10 +32,10 @@ HELP: <server>
 { $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 <server> } ", 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." } ;
 

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

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
+kernel math namespaces parser prettyprint sequences
-sequences sequences-internals strings styles vectors words ;
+sequences-internals strings styles vectors words errors ;
-IN: errors
+IN: kernel-internals
 
-PREDICATE: array kernel-error ( obj -- ? )
+: save-error ( error trace continuation -- )
-    dup first \ kernel-error eq? swap second 0 18 between? and ;
+    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 ;
+
+: <xt-map> ( -- 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 )
+    <xt-map> 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 <reversed> [
+        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 ;

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." } ;
 

library/tools/describe.factor

@@ -44,7 +44,7 @@ M: hashtable sheet hash>alist ;
 
 : describe ( object -- ) dup summary print sheet sheet. ;
 
-: stack. ( seq -- ) <reversed> >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 <reversed> [ first2 1- callframe. ] each ;
+    3 group [ first2 1- callframe. ] each ;
 
 : .c ( -- ) callstack callstack. ;

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

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);

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;

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)

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

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;
+	GROWABLE_ARRAY(result);
-	F_ARRAY *result = allot_array(ARRAY_TYPE,100,F);
 
 	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);
-
+			GROWABLE_ADD(result,name);
-			set_array_nth(result,result_count,name);
-			result_count++;
 		}
 
 		closedir(dir);
 	}
 
-	result = reallot_array(result,result_count,F);
+	GROWABLE_TRIM(result);
 
 	dpush(tag_object(result));
 }

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);
-
+			GROWABLE_ADD(result,name);
-			set_array_nth(result,result_count,name);
-			result_count++;
 		}
 		while (FindNextFile(dir, &find_data));
 		CloseHandle(dir);
 	}
 
-	result = reallot_array(result,result_count,F);
+	GROWABLE_TRIM(result);
 
 	dpush(tag_object(result));
 }

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);

vm/run.h

@@ -28,6 +28,8 @@ CELL callframe_end;
 #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;

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;
 

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);