images referencing libraries that could not be found no longer fail to load
parent
2495ef46f3
commit
979225805e
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
|
@ -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 -- ? )
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
|
@ -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: ;
|
||||||
|
|
||||||
|
|
|
@ -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 -- )
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
28
native/dll.c
28
native/dll.c
|
@ -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)
|
||||||
|
|
10
native/dll.h
10
native/dll.h
|
@ -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);
|
||||||
|
|
|
@ -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. */
|
||||||
|
|
|
@ -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)
|
||||||
|
|
|
@ -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;
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
|
@ -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;
|
||||||
}
|
}
|
||||||
|
|
Loading…
Reference in New Issue