Fix documentation typos, start working on compiled stack traces
slava
parent
74ddfad32c
commit
c0038a28f9
4
Makefile
4
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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 } "." } ;
|
||||
|
|
|
|||
|
|
@ -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." }
|
||||
{ $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: <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." } ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
: <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 ;
|
||||
|
|
|
|||
|
|
@ -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." } ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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. ;
|
||||
|
|
|
|||
19
vm/cpu-ppc.S
19
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
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
|
|
|||
12
vm/cpu-x86.h
12
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;
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
15
vm/os-unix.c
15
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));
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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));
|
||||
}
|
||||
|
|
|
|||
25
vm/run.c
25
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);
|
||||
|
|
|
|||
35
vm/run.h
35
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;
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
||||
|
|
|
|||
26
vm/types.h
26
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);
|
||||
|
|
|
|||
Loading…
Reference in New Issue