images referencing libraries that could not be found no longer fail to load

cvs
Slava Pestov 2005-08-15 19:34:00 +00:00
parent 2495ef46f3
commit 979225805e
16 changed files with 122 additions and 54 deletions

View File

@ -118,6 +118,7 @@ parser prettyprint sequences io vectors words ;
] make-list ] make-list
"object" [ "generic" ] search "object" [ "generic" ] search
"tuple" [ "generic" ] search
"null" [ "generic" ] search "null" [ "generic" ] search
"typemap" [ "generic" ] search "typemap" [ "generic" ] search
"builtins" [ "generic" ] search "builtins" [ "generic" ] search
@ -128,6 +129,7 @@ reveal
reveal reveal
reveal reveal
reveal reveal
reveal
[ [
[ [
@ -137,10 +139,6 @@ reveal
[ hashtable? ] instances [ hashtable? ] instances
[ dup hash-size 1 max swap set-bucket-count ] each [ 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" "/library/bootstrap/init.factor"
} pull-in } pull-in
[
"Building generics..." print
all-words [ generic? ] subset [ make-generic ] each
] %
] make-list ] make-list
swap swap

View File

@ -114,6 +114,9 @@ compile? [
] pull-in ] pull-in
] when ] when
"Building cross-reference database..." print
recrossref
compile? [ compile? [
"Compiling system..." print "Compiling system..." print
compile-all compile-all

View File

@ -59,8 +59,6 @@ sequences vectors words ;
: peek-2 dup length 2 - swap nth ; : peek-2 dup length 2 - swap nth ;
: node-peek-2 ( node -- obj ) node-in-d peek-2 ; : node-peek-2 ( node -- obj ) node-in-d peek-2 ;
: value-types drop f ;
: typed? ( value -- ? ) value-types length 1 = ; : typed? ( value -- ? ) value-types length 1 = ;
: slot@ ( node -- n ) : slot@ ( node -- n )
@ -109,7 +107,15 @@ sequences vectors words ;
drop drop
in-1 in-1
0 %type , 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 out-1
] "intrinsic" set-word-prop ] "intrinsic" set-word-prop

View File

@ -86,7 +86,7 @@ M: %untag-fixnum generate-node ( vop -- )
: tag-fixnum ( dest src -- ) tag-bits SLWI ; : tag-fixnum ( dest src -- ) tag-bits SLWI ;
M: %tag-fixnum generate-node ( vop -- ) M: %retag-fixnum generate-node ( vop -- )
! todo: formalize scratch register usage ! todo: formalize scratch register usage
dest/src tag-fixnum ; dest/src tag-fixnum ;
@ -124,3 +124,6 @@ M: %type generate-node ( vop -- )
f type 18 LI f type 18 LI
"end" get save-xt "end" get save-xt
17 18 MR ; 17 18 MR ;
M: %tag generate-node ( vop -- )
dup vop-in-1 swap vop-out-1 tag-mask ANDI ;

View File

@ -71,7 +71,7 @@ M: %inc-d simplify-node ( linear vop -- linear ? )
[ over first operands= [ cdr cdr t ] [ f ] ifte ] [ over first operands= [ cdr cdr t ] [ f ] ifte ]
[ drop 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 ; drop \ %untag-fixnum cancel ;
: basic-block ( linear quot -- | quot: vop -- ? ) : basic-block ( linear quot -- | quot: vop -- ? )

View File

@ -302,10 +302,15 @@ C: %type make-vop ;
: %type ( vreg ) <vreg> dest-vop <%type> ; : %type ( vreg ) <vreg> dest-vop <%type> ;
M: %type basic-block? drop t ; M: %type basic-block? drop t ;
TUPLE: %tag-fixnum ; TUPLE: %tag ;
C: %tag-fixnum make-vop ; C: %tag make-vop ;
: %tag-fixnum <vreg> dest-vop <%tag-fixnum> ; : %tag ( vreg ) <vreg> dest-vop <%tag> ;
M: %tag-fixnum basic-block? drop t ; M: %tag basic-block? drop t ;
TUPLE: %retag-fixnum ;
C: %retag-fixnum make-vop ;
: %retag-fixnum <vreg> dest-vop <%retag-fixnum> ;
M: %retag-fixnum basic-block? drop t ;
TUPLE: %untag-fixnum ; TUPLE: %untag-fixnum ;
C: %untag-fixnum make-vop ; C: %untag-fixnum make-vop ;

View File

@ -43,7 +43,7 @@ M: %return generate-node ( vop -- )
M: %untag generate-node ( vop -- ) M: %untag generate-node ( vop -- )
vop-out-1 v>operand BIN: 111 bitnot AND ; 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 ; vop-out-1 v>operand 3 SHL ;
M: %untag-fixnum generate-node ( vop -- ) 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). ! The pointer is equal to 3. Load F_TYPE (9).
f type MOV f type MOV
"end" get save-xt ; "end" get save-xt ;
M: %tag generate-node ( vop -- )
dup dup vop-in-1 check-dest
vop-in-1 v>operand tag-mask AND ;

View File

@ -76,7 +76,7 @@ SYMBOL: null
dup init-methods make-generic ; dup init-methods make-generic ;
PREDICATE: compound generic ( word -- ? ) PREDICATE: compound generic ( word -- ? )
"picker" word-prop ; "combination" word-prop ;
M: generic definer drop \ G: ; M: generic definer drop \ G: ;

View File

@ -38,6 +38,10 @@ vectors words ;
: heap-scan-error. ( obj -- ) : heap-scan-error. ( obj -- )
"Cannot do next-object outside begin/end-scan" print drop ; "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 -- ? ) PREDICATE: cons kernel-error ( obj -- ? )
car kernel-error = ; car kernel-error = ;
@ -54,6 +58,7 @@ M: kernel-error error. ( error -- )
c-string-error. c-string-error.
ffi-error. ffi-error.
heap-scan-error. heap-scan-error.
undefined-symbol-error.
} nth execute ; } nth execute ;
M: no-method error. ( error -- ) M: no-method error. ( error -- )

View File

@ -49,7 +49,11 @@ SYMBOL: crossref
: add-crossref ( word -- ) : add-crossref ( word -- )
#! Marks each word in the quotation as being a dependency #! Marks each word in the quotation as being a dependency
#! of the word. #! 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) : (remove-crossref)
dup word? [ dup word? [
@ -61,16 +65,20 @@ SYMBOL: crossref
: remove-crossref ( word -- ) : remove-crossref ( word -- )
#! Marks each word in the quotation as not being a #! Marks each word in the quotation as not being a
#! dependency of the word. #! 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 ) : usages ( word -- deps )
#! List all usages of a word. This is a transitive closure, #! List all usages of a word. This is a transitive closure,
#! so indirect usages are reported. #! so indirect usages are reported.
crossref get closure word-sort ; crossref get dup [ closure word-sort ] [ 2drop { } ] ifte ;
: usage ( word -- list ) : usage ( word -- list )
#! List all direct usages of a word. #! 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 -- ) GENERIC: (uncrossref) ( word -- )
M: word (uncrossref) drop ; M: word (uncrossref) drop ;

View File

@ -10,7 +10,7 @@ void primitive_dlopen(void)
path = untag_string(dpop()); path = untag_string(dpop());
dll = allot_object(DLL_TYPE,sizeof(DLL)); dll = allot_object(DLL_TYPE,sizeof(DLL));
dll->path = tag_object(path); dll->path = tag_object(path);
ffi_dlopen(dll); ffi_dlopen(dll,true);
dpush(tag_object(dll)); dpush(tag_object(dll));
} }
@ -19,15 +19,24 @@ void primitive_dlsym(void)
{ {
CELL dll; CELL dll;
F_STRING *sym; F_STRING *sym;
void *handle;
maybe_gc(0); maybe_gc(0);
dll = dpop(); dll = dpop();
sym = untag_string(dpop()); sym = untag_string(dpop());
dpush(tag_cell((CELL)ffi_dlsym( if(dll == F)
dll == F ? NULL : untag_dll(dll), handle = NULL;
sym))); else
{
DLL *d = untag_dll(dll);
if(d->dll == NULL)
general_error(ERROR_EXPIRED,dll);
handle = d->dll;
}
dpush(tag_cell((CELL)ffi_dlsym(handle,sym,true)));
} }
void primitive_dlclose(void) void primitive_dlclose(void)
@ -35,19 +44,10 @@ void primitive_dlclose(void)
ffi_dlclose(untag_dll(dpop())); 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) void fixup_dll(DLL* dll)
{ {
data_fixup(&dll->path); data_fixup(&dll->path);
ffi_dlopen(dll); ffi_dlopen(dll,false);
} }
void collect_dll(DLL* dll) void collect_dll(DLL* dll)

View File

@ -6,12 +6,16 @@ typedef struct {
void* dll; void* dll;
} 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 init_ffi(void);
void ffi_dlopen(DLL *dll); void ffi_dlopen(DLL *dll, bool error);
void *ffi_dlsym(DLL *dll, F_STRING *symbol); void *ffi_dlsym(DLL *dll, F_STRING *symbol, bool error);
void ffi_dlclose(DLL *dll); void ffi_dlclose(DLL *dll);
void primitive_dlopen(void); void primitive_dlopen(void);

View File

@ -8,6 +8,7 @@
#define ERROR_C_STRING (7<<3) #define ERROR_C_STRING (7<<3)
#define ERROR_FFI (8<<3) #define ERROR_FFI (8<<3)
#define ERROR_HEAP_SCAN (9<<3) #define ERROR_HEAP_SCAN (9<<3)
#define ERROR_UNDEFINED_SYMBOL (10<<3)
/* When throw_error throws an error, it sets this global and /* When throw_error throws an error, it sets this global and
longjmps back to the top-level. */ longjmps back to the top-level. */

View File

@ -85,12 +85,27 @@ void relocate_data()
} }
} }
void undefined_symbol(void)
{
}
CELL get_rel_symbol(F_REL* rel) CELL get_rel_symbol(F_REL* rel)
{ {
F_CONS* cons = untag_cons(get(rel->argument)); F_CONS* cons = untag_cons(get(rel->argument));
F_STRING* symbol = untag_string(cons->car); F_STRING* symbol = untag_string(cons->car);
DLL* dll = (cons->cdr == F ? NULL : untag_dll(cons->cdr)); 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) INLINE CELL compute_code_rel(F_REL *rel, CELL original)

View File

@ -7,28 +7,40 @@ void init_ffi(void)
null_dll = dlopen(NULL,RTLD_LAZY); 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); void *dllptr = dlopen(to_c_string(untag_string(dll->path)), RTLD_LAZY);
if(dllptr == NULL) if(dllptr == NULL)
{
if(error)
{ {
general_error(ERROR_FFI,tag_object( general_error(ERROR_FFI,tag_object(
from_c_string(dlerror()))); from_c_string(dlerror())));
} }
else
dll->dll = NULL;
return;
}
dll->dll = dllptr; 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 *handle = (dll == NULL ? null_dll : dll->dll);
void *sym = dlsym(handle,to_c_string(symbol)); void *sym = dlsym(handle,to_c_string(symbol));
if(sym == NULL) if(sym == NULL)
{
if(error)
{ {
general_error(ERROR_FFI,tag_object( general_error(ERROR_FFI,tag_object(
from_c_string(dlerror()))); from_c_string(dlerror())));
} }
return NULL;
}
return sym; return sym;
} }

View File

@ -4,7 +4,7 @@ void init_ffi (void)
{ {
} }
void ffi_dlopen (DLL *dll) void ffi_dlopen (DLL *dll, bool error)
{ {
HMODULE module; HMODULE module;
char *path = to_c_string(untag_string(dll->path)); char *path = to_c_string(untag_string(dll->path));
@ -12,18 +12,28 @@ void ffi_dlopen (DLL *dll)
module = LoadLibrary(path); module = LoadLibrary(path);
if (!module) if (!module)
{
if(error)
general_error(ERROR_FFI, tag_object(last_error())); general_error(ERROR_FFI, tag_object(last_error()));
else
return;
}
dll->dll = module; 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), void *sym = GetProcAddress(dll ? (HMODULE)dll->dll : GetModuleHandle(NULL),
to_c_string(symbol)); to_c_string(symbol));
if (!sym) if (!sym)
{
if(error)
general_error(ERROR_FFI, tag_object(last_error())); general_error(ERROR_FFI, tag_object(last_error()));
else
return NULL;
}
return sym; return sym;
} }