diff --git a/library/bootstrap/boot-stage1.factor b/library/bootstrap/boot-stage1.factor index 44e33bfab6..8d8748f3f3 100644 --- a/library/bootstrap/boot-stage1.factor +++ b/library/bootstrap/boot-stage1.factor @@ -118,6 +118,7 @@ parser prettyprint sequences io vectors words ; ] make-list "object" [ "generic" ] search +"tuple" [ "generic" ] search "null" [ "generic" ] search "typemap" [ "generic" ] search "builtins" [ "generic" ] search @@ -128,6 +129,7 @@ reveal reveal reveal reveal +reveal [ [ @@ -137,10 +139,6 @@ reveal [ hashtable? ] instances [ dup hash-size 1 max swap set-bucket-count ] each - - "Building cross-reference database..." print - - recrossref ] % { @@ -158,12 +156,6 @@ reveal "/library/bootstrap/init.factor" } pull-in - - [ - "Building generics..." print - - all-words [ generic? ] subset [ make-generic ] each - ] % ] make-list swap diff --git a/library/bootstrap/boot-stage3.factor b/library/bootstrap/boot-stage3.factor index 66a7e39b3e..018e0cc238 100644 --- a/library/bootstrap/boot-stage3.factor +++ b/library/bootstrap/boot-stage3.factor @@ -114,6 +114,9 @@ compile? [ ] pull-in ] when +"Building cross-reference database..." print +recrossref + compile? [ "Compiling system..." print compile-all diff --git a/library/compiler/intrinsics.factor b/library/compiler/intrinsics.factor index d0f05e12e0..c7c6712713 100644 --- a/library/compiler/intrinsics.factor +++ b/library/compiler/intrinsics.factor @@ -59,8 +59,6 @@ sequences vectors words ; : peek-2 dup length 2 - swap nth ; : node-peek-2 ( node -- obj ) node-in-d peek-2 ; -: value-types drop f ; - : typed? ( value -- ? ) value-types length 1 = ; : slot@ ( node -- n ) @@ -109,7 +107,15 @@ sequences vectors words ; drop in-1 0 %type , - 0 %tag-fixnum , + 0 %retag-fixnum , + out-1 +] "intrinsic" set-word-prop + +\ tag [ + drop + in-1 + 0 %tag , + 0 %retag-fixnum , out-1 ] "intrinsic" set-word-prop diff --git a/library/compiler/ppc/generator.factor b/library/compiler/ppc/generator.factor index 22c5a08515..d295095b68 100644 --- a/library/compiler/ppc/generator.factor +++ b/library/compiler/ppc/generator.factor @@ -86,7 +86,7 @@ M: %untag-fixnum generate-node ( vop -- ) : tag-fixnum ( dest src -- ) tag-bits SLWI ; -M: %tag-fixnum generate-node ( vop -- ) +M: %retag-fixnum generate-node ( vop -- ) ! todo: formalize scratch register usage dest/src tag-fixnum ; @@ -124,3 +124,6 @@ M: %type generate-node ( vop -- ) f type 18 LI "end" get save-xt 17 18 MR ; + +M: %tag generate-node ( vop -- ) + dup vop-in-1 swap vop-out-1 tag-mask ANDI ; diff --git a/library/compiler/simplifier.factor b/library/compiler/simplifier.factor index 852d086020..37cc99569f 100644 --- a/library/compiler/simplifier.factor +++ b/library/compiler/simplifier.factor @@ -71,7 +71,7 @@ M: %inc-d simplify-node ( linear vop -- linear ? ) [ over first operands= [ cdr cdr t ] [ f ] ifte ] [ drop f ] ifte ; -M: %tag-fixnum simplify-node ( linear vop -- linear ? ) +M: %retag-fixnum simplify-node ( linear vop -- linear ? ) drop \ %untag-fixnum cancel ; : basic-block ( linear quot -- | quot: vop -- ? ) diff --git a/library/compiler/vops.factor b/library/compiler/vops.factor index e00a4fdb4f..273516eb7a 100644 --- a/library/compiler/vops.factor +++ b/library/compiler/vops.factor @@ -302,10 +302,15 @@ C: %type make-vop ; : %type ( vreg ) dest-vop <%type> ; M: %type basic-block? drop t ; -TUPLE: %tag-fixnum ; -C: %tag-fixnum make-vop ; -: %tag-fixnum dest-vop <%tag-fixnum> ; -M: %tag-fixnum basic-block? drop t ; +TUPLE: %tag ; +C: %tag make-vop ; +: %tag ( vreg ) dest-vop <%tag> ; +M: %tag basic-block? drop t ; + +TUPLE: %retag-fixnum ; +C: %retag-fixnum make-vop ; +: %retag-fixnum dest-vop <%retag-fixnum> ; +M: %retag-fixnum basic-block? drop t ; TUPLE: %untag-fixnum ; C: %untag-fixnum make-vop ; diff --git a/library/compiler/x86/generator.factor b/library/compiler/x86/generator.factor index b96753a5ca..b00f88b530 100644 --- a/library/compiler/x86/generator.factor +++ b/library/compiler/x86/generator.factor @@ -43,7 +43,7 @@ M: %return generate-node ( vop -- ) M: %untag generate-node ( vop -- ) vop-out-1 v>operand BIN: 111 bitnot AND ; -M: %tag-fixnum generate-node ( vop -- ) +M: %retag-fixnum generate-node ( vop -- ) vop-out-1 v>operand 3 SHL ; M: %untag-fixnum generate-node ( vop -- ) @@ -92,3 +92,7 @@ M: %type generate-node ( vop -- ) ! The pointer is equal to 3. Load F_TYPE (9). f type MOV "end" get save-xt ; + +M: %tag generate-node ( vop -- ) + dup dup vop-in-1 check-dest + vop-in-1 v>operand tag-mask AND ; diff --git a/library/generic/generic.factor b/library/generic/generic.factor index cd34a544dc..17d94d46d8 100644 --- a/library/generic/generic.factor +++ b/library/generic/generic.factor @@ -76,7 +76,7 @@ SYMBOL: null dup init-methods make-generic ; PREDICATE: compound generic ( word -- ? ) - "picker" word-prop ; + "combination" word-prop ; M: generic definer drop \ G: ; diff --git a/library/tools/debugger.factor b/library/tools/debugger.factor index fb7fdd0995..57446d8289 100644 --- a/library/tools/debugger.factor +++ b/library/tools/debugger.factor @@ -38,6 +38,10 @@ vectors words ; : heap-scan-error. ( obj -- ) "Cannot do next-object outside begin/end-scan" print drop ; +: undefined-symbol-error. ( obj -- ) + "The image refers to a library or symbol that was not found" + " at load time" append print drop ; + PREDICATE: cons kernel-error ( obj -- ? ) car kernel-error = ; @@ -54,6 +58,7 @@ M: kernel-error error. ( error -- ) c-string-error. ffi-error. heap-scan-error. + undefined-symbol-error. } nth execute ; M: no-method error. ( error -- ) diff --git a/library/words.factor b/library/words.factor index c9592a1f6f..309959dfcc 100644 --- a/library/words.factor +++ b/library/words.factor @@ -49,7 +49,11 @@ SYMBOL: crossref : add-crossref ( word -- ) #! Marks each word in the quotation as being a dependency #! of the word. - dup word-def [ (add-crossref) ] tree-each-with ; + crossref get [ + dup word-def [ (add-crossref) ] tree-each-with + ] [ + drop + ] ifte ; : (remove-crossref) dup word? [ @@ -61,16 +65,20 @@ SYMBOL: crossref : remove-crossref ( word -- ) #! Marks each word in the quotation as not being a #! dependency of the word. - dup word-def [ (remove-crossref) ] tree-each-with ; + crossref get [ + dup word-def [ (remove-crossref) ] tree-each-with + ] [ + drop + ] ifte ; : usages ( word -- deps ) #! List all usages of a word. This is a transitive closure, #! so indirect usages are reported. - crossref get closure word-sort ; + crossref get dup [ closure word-sort ] [ 2drop { } ] ifte ; : usage ( word -- list ) #! List all direct usages of a word. - crossref get hash dup [ hash-keys ] when word-sort ; + crossref get ?hash dup [ hash-keys ] when word-sort ; GENERIC: (uncrossref) ( word -- ) M: word (uncrossref) drop ; diff --git a/native/dll.c b/native/dll.c index e5a17c99fb..641cfe2088 100644 --- a/native/dll.c +++ b/native/dll.c @@ -10,7 +10,7 @@ void primitive_dlopen(void) path = untag_string(dpop()); dll = allot_object(DLL_TYPE,sizeof(DLL)); dll->path = tag_object(path); - ffi_dlopen(dll); + ffi_dlopen(dll,true); dpush(tag_object(dll)); } @@ -18,16 +18,25 @@ void primitive_dlopen(void) void primitive_dlsym(void) { CELL dll; - F_STRING* sym; + F_STRING *sym; + void *handle; maybe_gc(0); dll = dpop(); sym = untag_string(dpop()); + + if(dll == F) + handle = NULL; + else + { + DLL *d = untag_dll(dll); + if(d->dll == NULL) + general_error(ERROR_EXPIRED,dll); + handle = d->dll; + } - dpush(tag_cell((CELL)ffi_dlsym( - dll == F ? NULL : untag_dll(dll), - sym))); + dpush(tag_cell((CELL)ffi_dlsym(handle,sym,true))); } void primitive_dlclose(void) @@ -35,19 +44,10 @@ void primitive_dlclose(void) ffi_dlclose(untag_dll(dpop())); } -DLL* untag_dll(CELL tagged) -{ - DLL* dll = (DLL*)UNTAG(tagged); - type_check(DLL_TYPE,tagged); - if(dll->dll == NULL) - general_error(ERROR_EXPIRED,tagged); - return (DLL*)UNTAG(tagged); -} - void fixup_dll(DLL* dll) { data_fixup(&dll->path); - ffi_dlopen(dll); + ffi_dlopen(dll,false); } void collect_dll(DLL* dll) diff --git a/native/dll.h b/native/dll.h index 1aa18b641f..f592c7eb81 100644 --- a/native/dll.h +++ b/native/dll.h @@ -6,12 +6,16 @@ typedef struct { void* dll; } DLL; -DLL* untag_dll(CELL tagged); +INLINE DLL* untag_dll(CELL tagged) +{ + type_check(DLL_TYPE,tagged); + return (DLL*)UNTAG(tagged); +} void init_ffi(void); -void ffi_dlopen(DLL *dll); -void *ffi_dlsym(DLL *dll, F_STRING *symbol); +void ffi_dlopen(DLL *dll, bool error); +void *ffi_dlsym(DLL *dll, F_STRING *symbol, bool error); void ffi_dlclose(DLL *dll); void primitive_dlopen(void); diff --git a/native/error.h b/native/error.h index 427681b6ed..219f1beaef 100644 --- a/native/error.h +++ b/native/error.h @@ -8,6 +8,7 @@ #define ERROR_C_STRING (7<<3) #define ERROR_FFI (8<<3) #define ERROR_HEAP_SCAN (9<<3) +#define ERROR_UNDEFINED_SYMBOL (10<<3) /* When throw_error throws an error, it sets this global and longjmps back to the top-level. */ diff --git a/native/relocate.c b/native/relocate.c index 99aaee3f65..ac37b96025 100644 --- a/native/relocate.c +++ b/native/relocate.c @@ -85,12 +85,27 @@ void relocate_data() } } +void undefined_symbol(void) +{ + +} + CELL get_rel_symbol(F_REL* rel) { F_CONS* cons = untag_cons(get(rel->argument)); F_STRING* symbol = untag_string(cons->car); DLL* dll = (cons->cdr == F ? NULL : untag_dll(cons->cdr)); - return (CELL)ffi_dlsym(dll,symbol); + CELL sym; + + if(!dll) + return (CELL)undefined_symbol; + + sym = (CELL)ffi_dlsym(dll,symbol,false); + + if(!sym) + return (CELL)undefined_symbol; + + return sym; } INLINE CELL compute_code_rel(F_REL *rel, CELL original) diff --git a/native/unix/ffi.c b/native/unix/ffi.c index 5583a0e22e..c9a195e0a2 100644 --- a/native/unix/ffi.c +++ b/native/unix/ffi.c @@ -7,27 +7,39 @@ void init_ffi(void) null_dll = dlopen(NULL,RTLD_LAZY); } -void ffi_dlopen(DLL *dll) +void ffi_dlopen(DLL *dll, bool error) { void *dllptr = dlopen(to_c_string(untag_string(dll->path)), RTLD_LAZY); if(dllptr == NULL) { - general_error(ERROR_FFI,tag_object( - from_c_string(dlerror()))); + if(error) + { + general_error(ERROR_FFI,tag_object( + from_c_string(dlerror()))); + } + else + dll->dll = NULL; + + return; } dll->dll = dllptr; } -void *ffi_dlsym(DLL *dll, F_STRING *symbol) +void *ffi_dlsym(DLL *dll, F_STRING *symbol, bool error) { void *handle = (dll == NULL ? null_dll : dll->dll); void *sym = dlsym(handle,to_c_string(symbol)); if(sym == NULL) { - general_error(ERROR_FFI,tag_object( - from_c_string(dlerror()))); + if(error) + { + general_error(ERROR_FFI,tag_object( + from_c_string(dlerror()))); + } + + return NULL; } return sym; } diff --git a/native/win32/ffi.c b/native/win32/ffi.c index 848f7215f0..02e64b876b 100644 --- a/native/win32/ffi.c +++ b/native/win32/ffi.c @@ -4,7 +4,7 @@ void init_ffi (void) { } -void ffi_dlopen (DLL *dll) +void ffi_dlopen (DLL *dll, bool error) { HMODULE module; char *path = to_c_string(untag_string(dll->path)); @@ -12,18 +12,28 @@ void ffi_dlopen (DLL *dll) module = LoadLibrary(path); if (!module) - general_error(ERROR_FFI, tag_object(last_error())); + { + if(error) + general_error(ERROR_FFI, tag_object(last_error())); + else + return; + } dll->dll = module; } -void *ffi_dlsym (DLL *dll, F_STRING *symbol) +void *ffi_dlsym (DLL *dll, F_STRING *symbol, bool error) { void *sym = GetProcAddress(dll ? (HMODULE)dll->dll : GetModuleHandle(NULL), to_c_string(symbol)); if (!sym) - general_error(ERROR_FFI, tag_object(last_error())); + { + if(error) + general_error(ERROR_FFI, tag_object(last_error())); + else + return NULL; + } return sym; }