From 0b195896308f8556fef4e992de8c4f828843c802 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 16 Feb 2008 00:54:54 -0600 Subject: [PATCH] linkage errors don't thwart compilation anymore --- core/alien/alien.factor | 13 ++---- core/alien/compiler/compiler.factor | 43 +++++++++++-------- core/bootstrap/primitives.factor | 1 + core/compiler/compiler.factor | 2 +- core/cpu/architecture/architecture.factor | 2 +- core/generator/fixup/fixup.factor | 3 +- core/inference/known-words/known-words.factor | 2 + vm/alien.c | 16 ++++++- vm/alien.h | 1 + vm/code_heap.c | 31 +++++++++---- vm/image.c | 2 +- vm/os-unix.c | 20 +-------- vm/os-unix.h | 2 +- vm/os-windows.c | 15 +------ vm/os-windows.h | 2 +- vm/primitives.c | 1 + 16 files changed, 80 insertions(+), 76 deletions(-) diff --git a/core/alien/alien.factor b/core/alien/alien.factor index 317dac803e..0369d55fb3 100755 --- a/core/alien/alien.factor +++ b/core/alien/alien.factor @@ -53,18 +53,11 @@ TUPLE: library path abi dll ; : library ( name -- library ) libraries get at ; -: ( path abi -- library ) f \ library construct-boa ; +: ( path abi -- library ) + over dup [ dlopen ] when \ library construct-boa ; : load-library ( name -- dll ) - library dup [ - dup library-dll [ ] [ - dup library-path dup [ - dlopen dup rot set-library-dll - ] [ - 2drop f - ] if - ] ?if - ] when ; + library library-dll ; : add-library ( name path abi -- ) swap libraries get set-at ; diff --git a/core/alien/compiler/compiler.factor b/core/alien/compiler/compiler.factor index f68bdcf0a2..3a41b80c2a 100755 --- a/core/alien/compiler/compiler.factor +++ b/core/alien/compiler/compiler.factor @@ -213,30 +213,37 @@ TUPLE: no-such-library name ; M: no-such-library summary drop "Library not found" ; +M: no-such-library compiler-error-type + drop +linkage+ ; + : no-such-library ( name -- ) - \ no-such-library +linkage+ (inference-error) ; + \ no-such-library construct-boa + compiling-word get compiler-error ; -: (alien-invoke-dlsym) ( node -- symbol dll ) - dup alien-invoke-function - swap alien-invoke-library [ - load-library - ] [ - 2drop no-such-library - ] recover ; - -TUPLE: no-such-symbol ; +TUPLE: no-such-symbol name ; M: no-such-symbol summary drop "Symbol not found" ; -: no-such-symbol ( -- ) - \ no-such-symbol +linkage+ (inference-error) ; +M: no-such-symbol compiler-error-type + drop +linkage+ ; -: alien-invoke-dlsym ( node -- symbol dll ) - dup (alien-invoke-dlsym) 2dup dlsym [ - >r over stdcall-mangle r> 2dup dlsym - [ no-such-symbol ] unless - ] unless rot drop ; +: no-such-symbol ( name -- ) + \ no-such-symbol construct-boa + compiling-word get compiler-error ; + +: check-dlsym ( symbols dll -- ) + dup dll-valid? [ + dupd [ dlsym ] curry contains? + [ drop ] [ no-such-symbol ] if + ] [ + dll-path no-such-library drop + ] if ; + +: alien-invoke-dlsym ( node -- symbols dll ) + dup alien-invoke-function dup pick stdcall-mangle 2array + swap alien-invoke-library library dup [ library-dll ] when + 2dup check-dlsym ; \ alien-invoke [ ! Four literals @@ -247,8 +254,6 @@ M: no-such-symbol summary pop-literal nip over set-alien-invoke-function pop-literal nip over set-alien-invoke-library pop-literal nip over set-alien-invoke-return - ! If symbol doesn't resolve, no stack effect, no compile - dup alien-invoke-dlsym 2drop ! Quotation which coerces parameters to required types dup make-prep-quot recursive-state get infer-quot ! Add node to IR diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 66ede8b054..05850e10ee 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -646,6 +646,7 @@ builtins get num-tags get tail f union-class define-class { "resize-byte-array" "byte-arrays" } { "resize-bit-array" "bit-arrays" } { "resize-float-array" "float-arrays" } + { "dll-valid?" "alien" } } dup length [ >r first2 r> make-primitive ] 2each diff --git a/core/compiler/compiler.factor b/core/compiler/compiler.factor index f44e6c1387..b40c5afd33 100755 --- a/core/compiler/compiler.factor +++ b/core/compiler/compiler.factor @@ -24,7 +24,6 @@ IN: compiler : finish-compile ( word effect dependencies -- ) >r dupd save-effect r> - f pick compiler-error over compiled-unxref over crossref? [ compiled-xref ] [ 2drop ] if ; @@ -38,6 +37,7 @@ IN: compiler swap compiler-error ; : (compile) ( word -- ) + f over compiler-error [ dup compile-succeeded finish-compile ] [ dupd compile-failed f save-effect ] recover ; diff --git a/core/cpu/architecture/architecture.factor b/core/cpu/architecture/architecture.factor index 4bb10b23a2..cd6c8b61f7 100755 --- a/core/cpu/architecture/architecture.factor +++ b/core/cpu/architecture/architecture.factor @@ -128,7 +128,7 @@ HOOK: %prepare-var-args compiler-backend ( -- ) M: object %prepare-var-args ; -HOOK: %alien-invoke compiler-backend ( library function -- ) +HOOK: %alien-invoke compiler-backend ( function library -- ) HOOK: %cleanup compiler-backend ( alien-node -- ) diff --git a/core/generator/fixup/fixup.factor b/core/generator/fixup/fixup.factor index 25e2f8222b..3ee93ba4a5 100755 --- a/core/generator/fixup/fixup.factor +++ b/core/generator/fixup/fixup.factor @@ -111,7 +111,8 @@ SYMBOL: literal-table : add-literal ( obj -- n ) literal-table get push-new* ; : string>symbol ( str -- alien ) - wince? [ string>u16-alien ] [ string>char-alien ] if ; + [ wince? [ string>u16-alien ] [ string>char-alien ] if ] + over string? [ call ] [ map ] if ; : add-dlsym-literals ( symbol dll -- ) >r string>symbol r> 2array literal-table get push-all ; diff --git a/core/inference/known-words/known-words.factor b/core/inference/known-words/known-words.factor index 9d0f959b68..2173d5d4e1 100755 --- a/core/inference/known-words/known-words.factor +++ b/core/inference/known-words/known-words.factor @@ -596,3 +596,5 @@ set-primitive-effect \ (os-envs) { } { array } set-primitive-effect \ do-primitive [ \ do-primitive no-effect ] "infer" set-word-prop + +\ dll-valid? { object } { object } set-primitive-effect diff --git a/vm/alien.c b/vm/alien.c index 2e14ae9ba7..26d9464700 100755 --- a/vm/alien.c +++ b/vm/alien.c @@ -182,7 +182,7 @@ DEFINE_PRIMITIVE(dlopen) F_DLL* dll = allot_object(DLL_TYPE,sizeof(F_DLL)); UNREGISTER_ROOT(path); dll->path = path; - ffi_dlopen(dll,true); + ffi_dlopen(dll); dpush(tag_object(dll)); } @@ -202,7 +202,7 @@ DEFINE_PRIMITIVE(dlsym) { d = untag_dll(dll); if(d->dll == NULL) - general_error(ERROR_EXPIRED,dll,F,NULL); + dpush(F); } box_alien(ffi_dlsym(d,sym)); @@ -213,3 +213,15 @@ DEFINE_PRIMITIVE(dlclose) { ffi_dlclose(untag_dll(dpop())); } + +DEFINE_PRIMITIVE(dll_validp) +{ + CELL dll = dpop(); + if(dll == F) + dpush(T); + else + { + F_DLL *d = untag_dll(dll); + dpush(d->dll == NULL ? F : T); + } +} diff --git a/vm/alien.h b/vm/alien.h index 3357b0a3c0..babfbc358d 100755 --- a/vm/alien.h +++ b/vm/alien.h @@ -46,3 +46,4 @@ DEFINE_UNTAG(F_DLL,DLL_TYPE,dll) DECLARE_PRIMITIVE(dlopen); DECLARE_PRIMITIVE(dlsym); DECLARE_PRIMITIVE(dlclose); +DECLARE_PRIMITIVE(dll_validp); diff --git a/vm/code_heap.c b/vm/code_heap.c index f449445eb9..c2f8ba0f5e 100755 --- a/vm/code_heap.c +++ b/vm/code_heap.c @@ -18,22 +18,37 @@ INLINE CELL get_literal(CELL literals_start, CELL num) void *get_rel_symbol(F_REL *rel, CELL literals_start) { CELL arg = REL_ARGUMENT(rel); - F_SYMBOL *symbol = alien_offset(get_literal(literals_start,arg)); + CELL symbol = get_literal(literals_start,arg); CELL library = get_literal(literals_start,arg + 1); + F_DLL *dll = (library == F ? NULL : untag_dll(library)); if(dll != NULL && !dll->dll) return undefined_symbol; - if(!symbol) - return undefined_symbol; + if(type_of(symbol) == BYTE_ARRAY_TYPE) + { + F_CHAR *name = alien_offset(symbol); + void *sym = ffi_dlsym(dll,name); - void *sym = ffi_dlsym(dll,symbol); + if(sym) + return sym; + } + else if(type_of(symbol) == ARRAY_TYPE) + { + CELL i; + F_ARRAY *names = untag_object(symbol); + for(i = 0; i < array_capacity(names); i++) + { + F_CHAR *name = alien_offset(array_nth(names,i)); + void *sym = ffi_dlsym(dll,name); - if(sym) - return sym; - else - return undefined_symbol; + if(sym) + return sym; + } + } + + return undefined_symbol; } /* Compute an address to store at a relocation */ diff --git a/vm/image.c b/vm/image.c index 3d3c352093..70eceeafdc 100755 --- a/vm/image.c +++ b/vm/image.c @@ -224,7 +224,7 @@ void relocate_object(CELL relocating) fixup_quotation((F_QUOTATION *)relocating); break; case DLL_TYPE: - ffi_dlopen((F_DLL *)relocating,false); + ffi_dlopen((F_DLL *)relocating); break; case ALIEN_TYPE: fixup_alien((F_ALIEN *)relocating); diff --git a/vm/os-unix.c b/vm/os-unix.c index 92028dfc43..a84b29c2e2 100755 --- a/vm/os-unix.c +++ b/vm/os-unix.c @@ -20,25 +20,9 @@ void init_ffi(void) null_dll = dlopen(NULL_DLL,RTLD_LAZY); } -void ffi_dlopen(F_DLL *dll, bool error) +void ffi_dlopen(F_DLL *dll) { - void *dllptr = dlopen(alien_offset(dll->path), RTLD_LAZY); - - if(dllptr == NULL) - { - if(error) - { - general_error(ERROR_FFI,F, - tag_object(from_char_string(dlerror())), - NULL); - } - else - dll->dll = NULL; - - return; - } - - dll->dll = dllptr; + dll->dll = dlopen(alien_offset(dll->path), RTLD_LAZY); } void *ffi_dlsym(F_DLL *dll, F_SYMBOL *symbol) diff --git a/vm/os-unix.h b/vm/os-unix.h index 85f760b5aa..a23e8e545c 100755 --- a/vm/os-unix.h +++ b/vm/os-unix.h @@ -27,7 +27,7 @@ typedef char F_SYMBOL; #define FPRINTF(stream,format,arg) fprintf(stream,format,arg) void init_ffi(void); -void ffi_dlopen(F_DLL *dll, bool error); +void ffi_dlopen(F_DLL *dll); void *ffi_dlsym(F_DLL *dll, F_SYMBOL *symbol); void ffi_dlclose(F_DLL *dll); diff --git a/vm/os-windows.c b/vm/os-windows.c index 54baf56212..a60339c578 100755 --- a/vm/os-windows.c +++ b/vm/os-windows.c @@ -43,20 +43,9 @@ void init_ffi(void) fatal_error("GetModuleHandle(\"" FACTOR_DLL_NAME "\") failed", 0); } -void ffi_dlopen (F_DLL *dll, bool error) +void ffi_dlopen(F_DLL *dll) { - HMODULE module = LoadLibraryEx(alien_offset(dll->path), NULL, 0); - - if (!module) - { - dll->dll = NULL; - if(error) - general_error(ERROR_FFI,F,tag_object(get_error_message()),NULL); - else - return; - } - - dll->dll = module; + dll->dll = LoadLibraryEx(alien_offset(dll->path), NULL, 0); } void *ffi_dlsym(F_DLL *dll, F_SYMBOL *symbol) diff --git a/vm/os-windows.h b/vm/os-windows.h index a22252fde8..86492990b5 100755 --- a/vm/os-windows.h +++ b/vm/os-windows.h @@ -33,7 +33,7 @@ DLLEXPORT F_CHAR *error_message(DWORD id); void windows_error(void); void init_ffi(void); -void ffi_dlopen(F_DLL *dll, bool error); +void ffi_dlopen(F_DLL *dll); void *ffi_dlsym(F_DLL *dll, F_SYMBOL *symbol); void ffi_dlclose(F_DLL *dll); diff --git a/vm/primitives.c b/vm/primitives.c index 5699f90fda..a5cdb4f1ef 100755 --- a/vm/primitives.c +++ b/vm/primitives.c @@ -188,4 +188,5 @@ void *primitives[] = { primitive_resize_byte_array, primitive_resize_bit_array, primitive_resize_float_array, + primitive_dll_validp, };