diff --git a/c/externs.h b/c/externs.h index 6dc1a4c20f..e02a6d2a2f 100644 --- a/c/externs.h +++ b/c/externs.h @@ -94,7 +94,7 @@ extern ptr S_relocation_table PROTO((iptr n)); /* fasl.c */ extern void S_fasl_init PROTO((void)); ptr S_fasl_read PROTO((ptr file, IBOOL gzflag, ptr path)); -ptr S_bv_fasl_read PROTO((ptr bv, ptr path)); +ptr S_bv_fasl_read PROTO((ptr bv, int ty, ptr path)); /* S_boot_read's f argument is really gzFile, but zlib.h is not included everywhere */ ptr S_boot_read PROTO((gzFile file, const char *path)); char *S_format_scheme_version PROTO((uptr n)); diff --git a/c/fasl.c b/c/fasl.c index 15a4d246a2..00858432b7 100644 --- a/c/fasl.c +++ b/c/fasl.c @@ -211,7 +211,7 @@ static INT uf_read PROTO((unbufFaslFile uf, octet *s, iptr n)); static octet uf_bytein PROTO((unbufFaslFile uf)); static uptr uf_uptrin PROTO((unbufFaslFile uf)); static ptr fasl_entry PROTO((ptr tc, unbufFaslFile uf)); -static ptr bv_fasl_entry PROTO((ptr tc, ptr bv, unbufFaslFile uf)); +static ptr bv_fasl_entry PROTO((ptr tc, ptr bv, IFASLCODE ty, unbufFaslFile uf)); static void fillFaslFile PROTO((faslFile f)); static void bytesin PROTO((octet *s, iptr n, faslFile f)); static void toolarge PROTO((ptr path)); @@ -304,7 +304,7 @@ ptr S_fasl_read(ptr file, IBOOL gzflag, ptr path) { return x; } -ptr S_bv_fasl_read(ptr bv, ptr path) { +ptr S_bv_fasl_read(ptr bv, int ty, ptr path) { ptr tc = get_thread_context(); ptr x; struct unbufFaslFileObj uffo; @@ -312,7 +312,7 @@ ptr S_bv_fasl_read(ptr bv, ptr path) { tc_mutex_acquire() uffo.path = path; uffo.type = UFFO_TYPE_BV; - x = bv_fasl_entry(tc, bv, &uffo); + x = bv_fasl_entry(tc, bv, ty, &uffo); tc_mutex_release() return x; } @@ -476,16 +476,21 @@ static ptr fasl_entry(ptr tc, unbufFaslFile uf) { return x; } -static ptr bv_fasl_entry(ptr tc, ptr bv, unbufFaslFile uf) { +static ptr bv_fasl_entry(ptr tc, ptr bv, int ty, unbufFaslFile uf) { ptr x; ptr strbuf = S_G.null_string; struct faslFileObj ffo; ffo.size = Sbytevector_length(bv); - ffo.next = ffo.buf = &BVIT(bv, 0); - ffo.end = &BVIT(bv, ffo.size); - ffo.uf = uf; - faslin(tc, &x, S_G.null_vector, &strbuf, &ffo); + if (ty == fasl_type_vfasl_size) { + x = S_vfasl(bv, (ptr)0, ffo.size); + } else { + ffo.next = ffo.buf = &BVIT(bv, 0); + ffo.end = &BVIT(bv, ffo.size); + ffo.uf = uf; + + faslin(tc, &x, S_G.null_vector, &strbuf, &ffo); + } S_flush_instruction_cache(tc); return x; diff --git a/c/vfasl.c b/c/vfasl.c index e36f1d3428..145c225d9d 100644 --- a/c/vfasl.c +++ b/c/vfasl.c @@ -242,6 +242,18 @@ ptr S_vfasl(ptr bv, void *stream, iptr input_len) } } + /* Replace references to singletons like "" and #vu8(). + This needs to be before interning symbols, in case "" + is a symbol name. */ + { + vfoff i; + for (i = 0; i < header.singletonref_count; i++) { + ptr *ref; + ref = ptr_add(data, singletonrefs[i]); + *ref = lookup_singleton(UNFIX(*ref)); + } + } + /* Intern symbols */ { ptr sym = TYPE(data, type_symbol); @@ -338,16 +350,6 @@ ptr S_vfasl(ptr bv, void *stream, iptr input_len) } } - /* Replace references to singletons like "" and #vu8() */ - { - vfoff i; - for (i = 0; i < header.singletonref_count; i++) { - ptr *ref; - ref = ptr_add(data, singletonrefs[i]); - *ref = lookup_singleton(UNFIX(*ref)); - } - } - /* Fix code pointers on closures */ { ptr cl = TYPE(ptr_add(data, header.closure_offset), type_closure); @@ -1248,6 +1250,14 @@ static int detect_singleton(ptr p) { return 3; else if (p == S_G.null_bytevector) return 4; + else if (p == S_G.eqp) + return 5; + else if (p == S_G.eqvp) + return 6; + else if (p == S_G.equalp) + return 7; + else if (p == S_G.symboleqp) + return 8; else return 0; } @@ -1262,11 +1272,19 @@ static ptr lookup_singleton(int which) { return S_G.null_fxvector; case 4: return S_G.null_bytevector; + case 5: + return S_G.eqp; + case 6: + return S_G.eqvp; + case 7: + return S_G.equalp; + case 8: + return S_G.symboleqp; default: S_error("vfasl", "bad singleton index"); return (ptr)0; } -} +} /*************************************************************/ diff --git a/s/7.ss b/s/7.ss index c012aed2a6..0155c8bbdd 100644 --- a/s/7.ss +++ b/s/7.ss @@ -121,7 +121,7 @@ (set! fasl-read (let () (define $fasl-read (foreign-procedure "(cs)fasl_read" (ptr boolean ptr) ptr)) - (define $bv-fasl-read (foreign-procedure "(cs)bv_fasl_read" (ptr ptr) ptr)) + (define $bv-fasl-read (foreign-procedure "(cs)bv_fasl_read" (ptr int ptr) ptr)) (define (get-uptr p) (let ([k (get-u8 p)]) (let f ([k k] [n (fxsrl k 1)]) @@ -168,8 +168,9 @@ [(eqv? ty (constant fasl-type-header)) (check-header p) (fasl-entry)] - [(eqv? ty (constant fasl-type-fasl-size)) - ($bv-fasl-read (get-bytevector-n p (get-uptr p)) (port-name p))] + [(or (eqv? ty (constant fasl-type-fasl-size)) + (eqv? ty (constant fasl-type-vfasl-size))) + ($bv-fasl-read (get-bytevector-n p (get-uptr p)) ty (port-name p))] [else (malformed p)]))))))) (define ($compiled-file-header? ip) diff --git a/s/compile.ss b/s/compile.ss index cff5d41734..878dae4ae6 100644 --- a/s/compile.ss +++ b/s/compile.ss @@ -455,9 +455,9 @@ [(group) elt* (apply vector (map c-vfaslobj elt*))] [(visit-stuff) elt - (cons (constant visit-tag) (c-vfaslobj x))] + (cons (constant visit-tag) (c-vfaslobj elt))] [(revisit-stuff) elt - (cons (constant revisit-tag) (c-vfaslobj x))] + (cons (constant revisit-tag) (c-vfaslobj elt))] [else (c-mkcode x)]))) (define c-print-vfasl diff --git a/s/patch.ss b/s/patch.ss index 5bf1f9a39b..24b7e5bad0 100644 --- a/s/patch.ss +++ b/s/patch.ss @@ -13,6 +13,8 @@ ;;; See the License for the specific language governing permissions and ;;; limitations under the License. +(define (generate-vfasl) #f) + (printf "loading ~s cross compiler~%" (constant machine-type-name)) ; (current-expand (lambda args (apply sc-expand args)))