1;; vfasl conversion uses the 2 3 4(let () 5 6(include "strip-types.ss") 7 8;; cooperates better with auto-indent than `fasl-case`: 9(define-syntax (fasl-case* stx) 10 (syntax-case stx (else) 11 [(_ target [(op fld ...) body ...] ... [else e-body ...]) 12 #'(fasl-case target [op (fld ...) body ...] ... [else e-body ...])] 13 [(_ target [(op fld ...) body ...] ...) 14 #'(fasl-case target [op (fld ...) body ...] ...)])) 15 16;; reverse quoting convention compared to `constant-case`: 17(define-syntax (constant-case* stx) 18 (syntax-case stx (else) 19 [(_ target [(const ...) body ...] ... [else e-body ...]) 20 (with-syntax ([((val ...) ...) 21 (map (lambda (consts) 22 (map (lambda (const) 23 (lookup-constant const)) 24 consts)) 25 (datum ((const ...) ...)))]) 26 #'(case target [(val ...) body ...] ... [else e-body ...]))] 27 [(_ target [(const ...) body ...] ...) 28 #'(constant-case* target [(const ...) body ...] ... [else ($oops 'constant-case* "no matching case ~s" 'target)])])) 29 30;; ************************************************************ 31;; Encode-time data structures */ 32 33;; During encoding, we use a bytevector per vspace on first pass, 34;; single shared bytevector on the second pass 35(define-record-type vfasl-chunk 36 (fields (mutable bv) 37 (mutable offset) ; offset into bv 38 (mutable alloc) ; allocation pointer; implies size 39 limit) ; #f or a sanity-check limit 40 (nongenerative)) 41 42(define-record-type vfasl-info 43 (fields (mutable bv) 44 45 (mutable base-addr) ; index within bv to make pointers and relocations relative to 46 47 (mutable sym-count) 48 49 (mutable symref-count) 50 (mutable symrefs) ; offset into bv 51 52 (mutable rtdref-count) 53 (mutable rtdrefs) ; offset into bv 54 55 (mutable singletonref-count) 56 (mutable singletonrefs) ; offset into bv 57 58 spaces ; vector of vfasl-chunk 59 60 (mutable ptr-bitmap) ; #f or offset into bv 61 62 (mutable graph) 63 (mutable base-rtd) ; write base-rtd only once 64 65 (mutable symbols) ; intern symbols (because multiple fasl blocks may be combined) 66 (mutable rtds) ; intern rtds (same reason) 67 (mutable strings) ; intern certain strings (for code names) 68 69 (mutable installs-library-entry?)) ; to determine whether vfasls can be combined 70 (nongenerative)) 71 72(define (new-vfasl-info) 73 (make-vfasl-info #f 74 75 0 76 0 ; sym-count 77 78 0 ;symref-count 79 #f 80 81 0 ; rtdref-count 82 #f 83 84 0 ; singletonref-count 85 #f 86 87 (list->vector 88 (let loop ([i 0]) 89 (if (fx= i (constant vspaces-count)) 90 '() 91 (cons (make-vfasl-chunk '#vu8() 0 0 #f) 92 (loop (fx+ i 1)))))) 93 #f ; ptr-bitmap 94 95 (make-eq-hashtable) 96 #f 97 (make-eq-hashtable) 98 (make-eq-hashtable) 99 (make-hashtable string-hash string=?) 100 101 #f)) ; installs-library-entry? 102 103;; Creates a vfasl image for the fasl content `v` (as read by "strip.ss") 104(define (to-vfasl v) 105 (let ([v (ensure-reference v)] 106 [vfi (new-vfasl-info)]) 107 ;; First pass: determine sizes 108 (copy v vfi) 109 110 ;; Setup for second pass: allocate to contiguous bytes 111 (let* ([data-size (let loop ([i 0]) 112 (if (fx= i (constant vspaces-count)) 113 0 114 (fx+ (vfasl-chunk-alloc 115 (vector-ref (vfasl-info-spaces vfi) i)) 116 (loop (fx+ i 1)))))] 117 [table-size (fx+ (fx* (vfasl-info-symref-count vfi) (constant ptr-bytes)) 118 (fx* (vfasl-info-rtdref-count vfi) (constant ptr-bytes)) 119 (fx* (vfasl-info-singletonref-count vfi) (constant ptr-bytes)))] 120 [bitmap-size (fxsra (fx+ data-size (fx- (constant byte-bits) 1)) (constant log2-byte-bits))] 121 [size (fx+ (constant size-vfasl-header) 122 data-size 123 table-size 124 bitmap-size)] 125 [bv (make-bytevector size 0)]) 126 (vfasl-info-bv-set! vfi bv) 127 128 ;; write header, except for result offset and table size: 129 (set-uptr! bv (constant vfasl-header-data-size-disp) data-size) 130 (let loop ([i 1] [offset (vfasl-chunk-alloc 131 (vector-ref (vfasl-info-spaces vfi) 0))]) 132 (unless (fx= i (constant vspaces-count)) 133 (set-uptr! bv 134 (fx+ (constant vfasl-header-vspace-rel-offsets-disp) 135 (fx* (fx- i 1) (constant ptr-bytes))) 136 offset) 137 (loop (fx+ i 1) (fx+ offset (vfasl-chunk-alloc 138 (vector-ref (vfasl-info-spaces vfi) i)))))) 139 (set-uptr! bv (constant vfasl-header-symref-count-disp) (vfasl-info-symref-count vfi)) 140 (set-uptr! bv (constant vfasl-header-rtdref-count-disp) (vfasl-info-rtdref-count vfi)) 141 (set-uptr! bv (constant vfasl-header-singletonref-count-disp) (vfasl-info-singletonref-count vfi)) 142 143 (let ([base-addr (constant size-vfasl-header)]) 144 (vfasl-info-base-addr-set! vfi base-addr) 145 146 (let* ([p 147 ;; Set pointers to vspaces based on sizes from first pass 148 (let loop ([i 0] [p base-addr]) 149 (if (fx= i (constant vspaces-count)) 150 p 151 (let ([len (vfasl-chunk-alloc 152 (vector-ref (vfasl-info-spaces vfi) i))]) 153 (vector-set! (vfasl-info-spaces vfi) i (make-vfasl-chunk bv p 0 len)) 154 (loop (fx+ i 1) (fx+ p len)))))] 155 [p (begin 156 (vfasl-info-symrefs-set! vfi p) 157 (fx+ p (fx* (vfasl-info-symref-count vfi) (constant ptr-bytes))))] 158 [p (begin 159 (vfasl-info-rtdrefs-set! vfi p) 160 (fx+ p (fx* (vfasl-info-rtdref-count vfi) (constant ptr-bytes))))] 161 [p (begin 162 (vfasl-info-singletonrefs-set! vfi p) 163 (fx+ p (fx* (vfasl-info-singletonref-count vfi) (constant ptr-bytes))))] 164 [bm p]) 165 (vfasl-info-ptr-bitmap-set! vfi bm) 166 167 (vfasl-info-sym-count-set! vfi 0) 168 (vfasl-info-symref-count-set! vfi 0) 169 (vfasl-info-rtdref-count-set! vfi 0) 170 (vfasl-info-singletonref-count-set! vfi 0) 171 (vfasl-info-graph-set! vfi (make-eq-hashtable)) 172 (vfasl-info-base-rtd-set! vfi #f) 173 174 ;; Write data 175 (let ([v (copy v vfi)]) 176 (let-values ([(bv offset) (vptr->bytevector+offset v vfi)]) 177 (set-iptr! bv (constant vfasl-header-result-offset-disp) (- offset base-addr))) 178 179 ;; We can ignore trailing zeros in the bitmap: 180 (let* ([zeros (let loop ([bmp (fx+ bm bitmap-size)] [zeros 0]) 181 (cond 182 [(fx= bmp bm) zeros] 183 [(fx= 0 (bytevector-u8-ref bv (fx- bmp 1))) 184 (loop (fx- bmp 1) (fx+ zeros 1))] 185 [else zeros]))] 186 [table-size (fx+ table-size (fx- bitmap-size zeros))]) 187 (set-uptr! bv (constant vfasl-header-table-size-disp) table-size) 188 ;; Truncate bytevector to match end of bitmaps 189 (bytevector-truncate! bv (fx- size zeros))) 190 191 (sort-offsets! bv (vfasl-info-symrefs vfi) (vfasl-info-symref-count vfi)) 192 (sort-offsets! bv (vfasl-info-rtdrefs vfi) (vfasl-info-rtdref-count vfi)) 193 (sort-offsets! bv (vfasl-info-singletonrefs vfi) (vfasl-info-singletonref-count vfi)) 194 195 bv)))))) 196 197;; If compiled code uses `$install-library-entry`, then it can't be 198;; combined into a single vfasled object, because the installation 199;; needs to be evaluated for laster vfasls. Recognize a non-combinable 200;; value as anything that references the C entry or even mentions the 201;; symbol `$install-library-entry` (as defined in "library.ss"). If 202;; non-boot code mentions the symbol `$install-library-entry`, it just 203;; isn't as optimal. 204;; 205;; This is an expensive test, since we perform half of a vfasl 206;; encoding to look for `$install-library-entry`. */ 207(define (fasl-can-combine? v) 208 (let ([vfi (new-vfasl-info)]) 209 ;; Run a "first pass" 210 (copy v vfi) 211 (not (vfasl-info-installs-library-entry? vfi)))) 212 213;; Box certain kinds of values (including singletons) where the vfasl 214;; process needs a pointer into data 215(define (ensure-reference v) 216 (define (enbox v) 217 (fasl-tuple (constant fasl-type-box) (vector v))) 218 (define (enbox-fixnum n) 219 (if (<= (constant most-negative-fixnum) n (constant most-positive-fixnum)) 220 (enbox v) 221 v)) 222 (fasl-case* v 223 [(atom ty uptr) 224 (constant-case* ty 225 [(fasl-type-immediate fasl-type-base-rtd) (enbox v)] 226 [else v])] 227 [(small-integer iptr) (enbox-fixnum iptr)] 228 [(large-integer sign vuptr) (enbox-fixnum (build-exact-integer sign vuptr))] 229 [(tuple ty vec) 230 (constant-case* ty 231 [(fasl-type-box) (enbox v)] 232 [else v])] 233 [(string ty string) 234 (constant-case* ty 235 [(fasl-type-symbol) (enbox v)] 236 [else 237 (if (fx= 0 (string-length string)) 238 (enbox v) 239 v)])] 240 [(vector ty vec) 241 (if (fx= 0 (vector-length vec)) 242 (enbox v) 243 v)] 244 [(fxvector vec) 245 (if (fx= 0 (vector-length vec)) 246 (enbox v) 247 v)] 248 [(bytevector ty bv) 249 (if (fx= 0 (bytevector-length bv)) 250 (enbox v) 251 v)] 252 [(record maybe-uid size nflds rtd pad-ty* fld*) 253 (enbox v)] 254 [else v])) 255 256;; quicksort on uptrs within a bytevector 257(define (sort-offsets! bv offset len) 258 (define (uref i) 259 (ref-uptr bv (fx+ offset (fx* i (constant ptr-bytes))))) 260 (define (uset! i v) 261 (set-uptr! bv (fx+ offset (fx* i (constant ptr-bytes))) v)) 262 (when (fx> len 1) 263 (let* ([mid (fxsra len 1)] 264 [tmp (uref mid)]) 265 (uset! mid (uref 0)) 266 (uset! 0 tmp)) 267 (let ([p-val (uref 0)]) 268 (let loop ([i 1] [pivot 0]) 269 (cond 270 [(fx= i len) 271 (uset! pivot p-val) 272 (sort-offsets! bv offset pivot) 273 (sort-offsets! bv (fx+ offset (fx* (fx+ pivot 1) (constant ptr-bytes))) (fx- len pivot 1))] 274 [(< (uref i) p-val) 275 (uset! pivot (uref i)) 276 (let ([pivot (fx+ pivot 1)]) 277 (uset! i (uref pivot)) 278 (loop (fx+ i 1) pivot))] 279 [else 280 (loop (fx+ i 1) pivot)]))))) 281 282;; ---------------------------------------- 283 284;; A vptr represents a pointer to an object allocated in a vfasl image. 285;; A vsingleton represents a pointer to a single (not in the image). 286;; A number a pointer represents a literal pointer, such as a fixnum or immediate. 287 288(define (make-vptr v vspace) (cons v vspace)) 289(define (make-vsingleton n) (cons n 'singleton)) 290 291(define (vptr? v) (and (pair? v) (not (eq? (cdr v) 'singleton)))) 292(define (vptr-v v) (car v)) 293(define (vptr-vspace v) (cdr v)) 294(define (vptr+ v offset) (make-vptr (fx+ (vptr-v v) offset) (vptr-vspace v))) 295 296(define (vsingleton? v) (and (pair? v) (eq? (cdr v) 'singleton))) 297(define (vsingleton-index v) (car v)) 298 299(define (segment-start? sz) 300 (fxzero? (fxand sz (fx- (constant bytes-per-segment) 1)))) 301(define (segment-truncate sz) 302 (fxand sz (fxnot (fx- (constant bytes-per-segment) 1)))) 303 304;; Allocate into the given vspace in a vfasl image. The result 305;; is just the `v` part of a vptr (because it's easier to do arithmetic 306;; with that to initialize the item). 307(define (find-room who vfi vspc n type) 308 (let ([n (c-alloc-align n)] 309 [vc (vector-ref (vfasl-info-spaces vfi) vspc)]) 310 (constant-case* vspc 311 [(vspace-symbol vspace-impure-record) 312 ;; For these spaces, in case they will be loaded into the static 313 ;; generation, objects must satisfy an extra constraint: an object 314 ;; must not span segments unless it's at the start of a 315 ;; segment 316 (let ([sz (vfasl-chunk-alloc vc)]) 317 (unless (segment-start? sz) 318 ;; Since we're not at the start of a segment, don't let an 319 ;; object span a segment 320 (when (and (not (fx= (segment-truncate sz) (segment-truncate (fx+ sz n)))) 321 (not (segment-start? (fx+ sz n)))) 322 ;; Skip to next segment 323 (vfasl-chunk-alloc-set! vc (segment-truncate (fx+ sz n))))))] 324 [else (void)]) 325 (let* ([sz (vfasl-chunk-alloc vc)] 326 [new-sz (fx+ sz n)] 327 [limit (vfasl-chunk-limit vc)]) 328 (when (and limit 329 (fx> new-sz limit)) 330 ($oops 'vfasl "allocation overrun")) 331 (when (fx< (bytevector-length (vfasl-chunk-bv vc)) new-sz) 332 (let ([bv (make-bytevector (fx+ (if (fxzero? sz) 333 (constant bytes-per-segment) 334 (fx* 2 (bytevector-length (vfasl-chunk-bv vc)))) 335 (segment-truncate n)))]) 336 (bytevector-copy! (vfasl-chunk-bv vc) 0 bv 0 sz) 337 (vfasl-chunk-bv-set! vc bv))) 338 (vfasl-chunk-alloc-set! vc new-sz) 339 (make-vptr (fx- sz (fx- (constant typemod) type)) 340 vspc)))) 341 342(define vptr->bytevector+offset 343 (case-lambda 344 [(p vfi) (vptr->bytevector+offset p 0 vfi)] 345 [(p delta vfi) 346 (let ([vc (vector-ref (vfasl-info-spaces vfi) (vptr-vspace p))]) 347 (values (vfasl-chunk-bv vc) (fx+ (vfasl-chunk-offset vc) (vptr-v p) delta)))])) 348 349;; Overloaded to either set in a bytevector or set in a vfasl image: 350(define set-uptr! 351 (case-lambda 352 [(bv i uptr) 353 (constant-case ptr-bytes 354 [(4) (bytevector-u32-set! bv i uptr (constant native-endianness))] 355 [(8) (bytevector-u64-set! bv i uptr (constant native-endianness))])] 356 [(p delta uptr vfi) 357 (let-values ([(bv offset) (vptr->bytevector+offset p delta vfi)]) 358 (set-uptr! bv offset uptr))])) 359 360;; Overloaded in the same way as `set-uptr!` 361(define ref-uptr 362 (case-lambda 363 [(bv i) 364 (constant-case ptr-bytes 365 [(4) (bytevector-u32-ref bv i (constant native-endianness))] 366 [(8) (bytevector-u64-ref bv i (constant native-endianness))])] 367 [(p delta vfi) 368 (let-values ([(bv offset) (vptr->bytevector+offset p delta vfi)]) 369 (ref-uptr bv offset))])) 370 371;; Overloaded in the same way as `set-uptr!` 372(define set-iptr! 373 (case-lambda 374 [(bv i uptr) 375 (constant-case ptr-bytes 376 [(4) (bytevector-s32-set! bv i uptr (constant native-endianness))] 377 [(8) (bytevector-s64-set! bv i uptr (constant native-endianness))])] 378 [(p delta uptr vfi) 379 (let-values ([(bv offset) (vptr->bytevector+offset p delta vfi)]) 380 (set-iptr! bv offset uptr))])) 381 382;; Overloaded in the same way as `set-uptr!` 383(define set-double! 384 (case-lambda 385 [(bv i dbl) 386 (bytevector-ieee-double-set! bv i dbl (constant native-endianness))] 387 [(p delta dbl vfi) 388 (let-values ([(bv offset) (vptr->bytevector+offset p delta vfi)]) 389 (set-double! bv offset dbl))])) 390 391;; Overloaded in the same way as `set-uptr!` 392(define set-char! 393 (case-lambda 394 [(bv i char) 395 (let ([n (bitwise-ior (bitwise-arithmetic-shift-left (char->integer char) (constant char-data-offset)) 396 (constant type-char))]) 397 (constant-case string-char-bytes 398 [(4) (bytevector-u32-set! bv i n (constant native-endianness))]))] 399 [(p delta char vfi) 400 (let-values ([(bv offset) (vptr->bytevector+offset p delta vfi)]) 401 (set-char! bv offset char))])) 402 403(define set-u8! 404 (case-lambda 405 [(p delta u8 vfi) 406 (let-values ([(bv offset) (vptr->bytevector+offset p delta vfi)]) 407 (bytevector-u8-set! bv offset u8))])) 408 409(define (copy-u8s! p delta bv bv-off len vfi) 410 (let-values ([(dest-bv offset) (vptr->bytevector+offset p delta vfi)]) 411 (bytevector-copy! bv bv-off dest-bv offset len))) 412 413;; Overloaded in the same way as `set-uptr!` 414(define set-bigit! 415 (case-lambda 416 [(bv i bigit) 417 (constant-case bigit-bytes 418 [(4) (bytevector-u32-set! bv i bigit (constant native-endianness))])] 419 [(p delta bigit vfi) 420 (let-values ([(bv offset) (vptr->bytevector+offset p delta vfi)]) 421 (set-bigit! bv offset bigit))])) 422 423;; Sets a pointer in a vfasl image, and optionally records the reference. 424;; The pointer is written as a relative offset, and then it will get 425;; adjusted when the vfasl image is loaded. 426(define (do-set-ptr! at-p delta p vfi record?) 427 (let* ([vc (vector-ref (vfasl-info-spaces vfi) (vptr-vspace at-p))] 428 [rel-v (fx- (fx+ (vptr-v at-p) delta (vfasl-chunk-offset vc)) 429 (vfasl-info-base-addr vfi))]) 430 (define (register! vfasl-info-ref-count 431 vfasl-info-ref-count-set! 432 vfasl-info-refs) 433 (unless record? ($oops 'vfasl "expected to record ptr")) 434 (let ([c (vfasl-info-ref-count vfi)] 435 [refs (vfasl-info-refs vfi)]) 436 (vfasl-info-ref-count-set! vfi (fx+ c 1)) 437 (when refs 438 (set-uptr! (vfasl-info-bv vfi) (fx+ refs (fx* c (constant ptr-bytes))) rel-v)))) 439 (let ([val (cond 440 [(vptr? p) 441 (let* ([p-vspc (vptr-vspace p)] 442 [p-vc (vector-ref (vfasl-info-spaces vfi) p-vspc)]) 443 (constant-case* p-vspc 444 [(vspace-symbol) 445 (when record? 446 (register! vfasl-info-symref-count 447 vfasl-info-symref-count-set! 448 vfasl-info-symrefs)) 449 ;; symbol reference are not registered in the bitmap, 450 ;; and the reference is as an index instead of address offset 451 (fix (symbol-vptr->index p vfi))] 452 [else 453 (when record? 454 (when (eqv? p-vspc (constant vspace-rtd)) 455 (register! vfasl-info-rtdref-count 456 vfasl-info-rtdref-count-set! 457 vfasl-info-rtdrefs)) 458 (let ([bm (vfasl-info-ptr-bitmap vfi)]) 459 (when bm 460 (safe-assert (fxzero? (fxand rel-v (fx- (constant ptr-bytes) 1)))) 461 (let* ([w-rel-b (fxsra rel-v (constant log2-ptr-bytes))] 462 [i (fx+ bm (fxsra w-rel-b (constant log2-byte-bits)))] 463 [bit (fxsll 1 (fxand w-rel-b (fx- (constant byte-bits) 1)))] 464 [bv (vfasl-info-bv vfi)]) 465 (bytevector-u8-set! bv i (fxior (bytevector-u8-ref bv i) bit)))))) 466 (fx- (fx+ (vptr-v p) (vfasl-chunk-offset p-vc)) 467 (vfasl-info-base-addr vfi))]))] 468 [(vsingleton? p) 469 (register! vfasl-info-singletonref-count 470 vfasl-info-singletonref-count-set! 471 vfasl-info-singletonrefs) 472 (fix (vsingleton-index p))] 473 [else p])]) 474 (set-iptr! at-p delta val vfi)))) 475 476(define (set-ptr! at-p delta p vfi) (do-set-ptr! at-p delta p vfi #t)) 477(define (set-ptr!/no-record at-p delta p vfi) (do-set-ptr! at-p delta p vfi #f)) 478 479(define (symbol-vptr->index p vfi) 480 ;; There may be leftover space at the end of each segment containing symbols, 481 ;; we we have to compensate for that 482 (let* ([vc (vector-ref (vfasl-info-spaces vfi) (constant vspace-symbol))] 483 [offset (fx+ (vptr-v p) (fx- (constant typemod) (constant type-symbol)))] 484 [seg (quotient offset (constant bytes-per-segment))]) 485 (fx+ (fx* seg (quotient (constant bytes-per-segment) (constant size-symbol))) 486 (fxquotient (fx- offset (fx* seg (constant bytes-per-segment))) (constant size-symbol))))) 487 488(define (build-exact-integer sign vuptr) 489 (let loop ([v 0] [i 0]) 490 (cond 491 [(fx= i (vector-length vuptr)) 492 (if (eqv? sign 1) (- v) v)] 493 [else (loop (bitwise-ior (bitwise-arithmetic-shift v (constant bigit-bits)) 494 (vector-ref vuptr i)) 495 (fx+ i 1))]))) 496 497(define (build-flonum high low) 498 (let ([bv (make-bytevector 8)]) 499 (bytevector-u64-native-set! bv 0 (bitwise-ior low (bitwise-arithmetic-shift high 32))) 500 (bytevector-ieee-double-native-ref bv 0))) 501 502(define (unpack-flonum v) 503 (fasl-case* v 504 [(flonum high low) (build-flonum high low)] 505 [else ($oops 'vfasl "expected a flonum")])) 506 507(define (unpack-symbol v) 508 (or (fasl-case* v 509 [(string ty string) 510 (if (eq? ty (constant fasl-type-symbol)) 511 (string->symbol string) 512 #f)] 513 [(gensym pname uname) (gensym pname uname)] 514 [else #f]) 515 (error 'vfasl "expected a symbol: ~s" v))) 516 517;; ---------------------------------------- 518 519(define rtd-flds (csv7:record-field-accessor #!base-rtd 'flds)) 520 521(define (fix v) 522 (bitwise-arithmetic-shift-left v (constant fixnum-offset))) 523(define (fixed? v) 524 (fxzero? (bitwise-and v (sub1 (fxsll 1 (constant fixnum-offset)))))) 525 526(define (graph! v new-p vfi) 527 (eq-hashtable-set! (vfasl-info-graph vfi) v new-p)) 528 529(define (copy v vfi) 530 (or (eq-hashtable-ref (vfasl-info-graph vfi) v #f) 531 (do-copy v vfi))) 532 533(define (do-copy v vfi) 534 (fasl-case* v 535 [(atom ty uptr) 536 (constant-case* ty 537 [(fasl-type-immediate) uptr] 538 [(fasl-type-entry fasl-type-library fasl-type-library-code) 539 ($oops 'vfasl "expected only in a relocation: ~s" v)] 540 [else ($oops 'vfasl "unknown atom: ~s" v)])] 541 [(small-integer iptr) (exact-integer-copy v iptr vfi)] 542 [(large-integer sign vuptr) 543 (exact-integer-copy v (build-exact-integer sign vuptr) vfi)] 544 [(flonum high low) 545 (let ([new-p (find-room 'flonum vfi 546 (constant vspace-data) 547 (constant size-flonum) 548 (constant type-flonum))]) 549 (graph! v new-p vfi) 550 (set-double! new-p (constant flonum-data-disp) (build-flonum high low) vfi) 551 new-p)] 552 [(pair vec) 553 (let ([len (vector-length vec)] 554 [vspc (constant vspace-impure)]) 555 (cond 556 [(fx= len 1) (copy (vector-ref vec 0) vfi)] 557 [else 558 ;; can't just use `pair-copy` for initial pair, because we need 559 ;; to set up the graph: 560 (let ([new-p (find-room 'pair vfi 561 (constant vspace-impure) 562 (constant size-pair) 563 (constant type-pair))]) 564 (graph! v new-p vfi) 565 (set-ptr! new-p (constant pair-car-disp) (copy (vector-ref vec 0) vfi) vfi) 566 (let ([d (let loop ([i 1]) 567 (let ([e (copy (vector-ref vec i) vfi)] 568 [i (fx+ i 1)]) 569 (if (fx= i len) 570 e 571 (pair-copy e (loop i) vfi))))]) 572 (set-ptr! new-p (constant pair-cdr-disp) d vfi) 573 new-p))]))] 574 [(tuple ty vec) 575 (constant-case* ty 576 [(fasl-type-base-rtd) (base-rtd-copy v vfi)] 577 [(fasl-type-box fasl-type-immutable-box) 578 (let ([new-p (find-room 'box vfi 579 (constant vspace-impure) 580 (constant size-box) 581 (constant type-typed-object))]) 582 (graph! v new-p vfi) 583 (set-uptr! new-p (constant box-type-disp) 584 (if (eqv? ty (constant fasl-type-immutable-box)) 585 (constant type-immutable-box) 586 (constant type-box)) 587 vfi) 588 (set-ptr! new-p (constant box-ref-disp) (copy (vector-ref vec 0) vfi) vfi) 589 new-p)] 590 [(fasl-type-ratnum) 591 (let ([new-p (find-room 'ratnum vfi 592 (constant vspace-impure) 593 (constant size-ratnum) 594 (constant type-typed-object))]) 595 (graph! v new-p vfi) 596 (set-uptr! new-p (constant ratnum-type-disp) (constant type-ratnum) vfi) 597 (set-ptr! new-p (constant ratnum-numerator-disp) (copy (vector-ref vec 0) vfi) vfi) 598 (set-ptr! new-p (constant ratnum-denominator-disp) (copy (vector-ref vec 1) vfi) vfi) 599 new-p)] 600 [(fasl-type-exactnum) 601 (let ([new-p (find-room 'exactnum vfi 602 (constant vspace-impure) 603 (constant size-exactnum) 604 (constant type-typed-object))]) 605 (graph! v new-p vfi) 606 (set-uptr! new-p (constant exactnum-type-disp) (constant type-exactnum) vfi) 607 (set-ptr! new-p (constant exactnum-real-disp) (copy (vector-ref vec 0) vfi) vfi) 608 (set-ptr! new-p (constant exactnum-imag-disp) (copy (vector-ref vec 1) vfi) vfi) 609 new-p)] 610 [(fasl-type-inexactnum) 611 (let ([new-p (find-room 'inexactnum vfi 612 (constant vspace-data) 613 (constant size-inexactnum) 614 (constant type-typed-object))]) 615 (graph! v new-p vfi) 616 (set-uptr! new-p (constant inexactnum-type-disp) (constant type-inexactnum) vfi) 617 (set-double! new-p (constant inexactnum-real-disp) (unpack-flonum (vector-ref vec 0)) vfi) 618 (set-double! new-p (constant inexactnum-imag-disp) (unpack-flonum (vector-ref vec 1)) vfi) 619 new-p)] 620 [(fasl-type-weak-pair) 621 ($oops 'vfasl "weak pair not supported")] 622 [(fasl-type-ephemeron) 623 ($oops 'vfasl "ephemeron pair not supported")] 624 [else 625 ($oops 'vfasl "unrecognized tuple type")])] 626 [(string ty string) 627 (constant-case* ty 628 [(fasl-type-symbol) 629 (when (string=? string "$install-library-entry") 630 (vfasl-info-installs-library-entry?-set! vfi #t)) 631 (symbol-copy v 632 (string-copy string vfi) 633 (string->symbol string) 634 vfi)] 635 [else 636 (let ([immutable? (eqv? ty (constant fasl-type-immutable-string))]) 637 (cond 638 [(fx= 0 (string-length string)) 639 (make-vsingleton (if immutable? 640 (constant singleton-null-immutable-string) 641 (constant singleton-null-string)))] 642 [else 643 (vector-copy v string vfi 644 string-length 645 vspace-data 646 header-size-string string-data-disp 647 string-char-bytes 648 (bitwise-ior (bitwise-arithmetic-shift-left (string-length string) (constant string-length-offset)) 649 (if immutable? 650 (constant string-immutable-flag) 651 0) 652 (constant type-string)) 653 string-type-disp 654 set-char! 655 string-ref)]))])] 656 [(gensym pname uname) 657 (symbol-copy v (pair-copy (string-copy uname vfi) (string-copy pname vfi) vfi) (gensym pname uname) vfi)] 658 [(vector ty vec) 659 (cond 660 [(fx= 0 (vector-length vec)) 661 (make-vsingleton (constant-case* ty 662 [(fasl-type-vector) 663 (constant singleton-null-vector)] 664 [(fasl-type-immutable-vector) 665 (constant singleton-null-immutable-vector)] 666 [(fasl-type-flvector) 667 (constant singleton-null-flvector)]))] 668 [else 669 (constant-case* ty 670 [(fasl-type-vector fasl-type-immutable-vector) 671 (vector-copy v vec vfi 672 vector-length 673 vspace-impure 674 header-size-vector vector-data-disp 675 ptr-bytes 676 (bitwise-ior (bitwise-arithmetic-shift-left (vector-length vec) (constant vector-length-offset)) 677 (if (eqv? ty (constant fasl-type-immutable-vector)) 678 (constant vector-immutable-flag) 679 0) 680 (constant type-vector)) 681 vector-type-disp 682 set-ptr! 683 (lambda (vec i) (copy (vector-ref vec i) vfi)))] 684 [(fasl-type-flvector) 685 (vector-copy v vec vfi 686 vector-length 687 vspace-data 688 header-size-flvector flvector-data-disp 689 double-bytes 690 (bitwise-ior (bitwise-arithmetic-shift-left (vector-length vec) (constant flvector-length-offset)) 691 (constant type-flvector)) 692 flvector-type-disp 693 set-double! 694 (lambda (v i) (unpack-flonum (vector-ref v i))))])])] 695 [(fxvector vec) 696 (cond 697 [(fx= 0 (vector-length vec)) 698 (make-vsingleton (constant singleton-null-fxvector))] 699 [else 700 (vector-copy v vec vfi 701 vector-length 702 vspace-data 703 header-size-fxvector fxvector-data-disp 704 ptr-bytes 705 (bitwise-ior (bitwise-arithmetic-shift-left (vector-length v) (constant fxvector-length-offset)) 706 (constant type-fxvector)) 707 fxvector-type-disp 708 set-iptr! 709 (lambda (v i) (fix (vector-ref v i))))])] 710 [(bytevector ty bv) 711 (cond 712 [(fx= 0 (bytevector-length bv)) 713 (make-vsingleton (if (eqv? ty (constant fasl-type-immutable-bytevector)) 714 (constant singleton-null-immutable-bytevector) 715 (constant singleton-null-bytevector)))] 716 [else 717 (vector-copy v bv vfi 718 bytevector-length 719 vspace-data 720 header-size-bytevector bytevector-data-disp 721 byte-bytes 722 (bitwise-ior (bitwise-arithmetic-shift-left (bytevector-length bv) (constant bytevector-length-offset)) 723 (if (eqv? ty (constant fasl-type-immutable-bytevector)) 724 (constant bytevector-immutable-flag) 725 0) 726 (constant type-bytevector)) 727 bytevector-type-disp 728 set-u8! 729 bytevector-u8-ref)])] 730 [(stencil-vector mask vec) 731 (vector-copy v vec vfi 732 vector-length 733 vspace-impure 734 header-size-stencil-vector stencil-vector-data-disp 735 ptr-bytes 736 (bitwise-ior (bitwise-arithmetic-shift-left mask (constant stencil-vector-mask-offset)) 737 (constant type-stencil-vector)) 738 stencil-vector-type-disp 739 set-ptr! 740 (lambda (v i) (copy (vector-ref v i) vfi)))] 741 [(record maybe-uid size nflds rtd pad-ty* fld*) 742 (cond 743 [(refers-back-to-self? v rtd) 744 (base-rtd-copy v vfi)] 745 [(and maybe-uid 746 (let ([v2 (eq-hashtable-ref (vfasl-info-rtds vfi) (unpack-symbol maybe-uid) v)]) 747 (and (not (eq? v2 v)) 748 v2))) 749 => (lambda (v2) 750 (copy v2 vfi))] 751 [else 752 (let ([rtd-p (copy rtd vfi)]) 753 (when maybe-uid 754 (eq-hashtable-set! (vfasl-info-rtds vfi) (unpack-symbol maybe-uid) v) 755 ;; make sure parent type is earlier 756 (safe-assert (pair? fld*)) 757 (let ([ancestry (car fld*)]) 758 (field-case ancestry 759 [ptr (elem) 760 (fasl-case* elem 761 [(vector ty vec) 762 (let ([parent (vector-ref vec (fx- (vector-length vec) 763 (constant ancestry-parent-offset)))]) 764 (copy parent vfi))] 765 [else (safe-assert (not 'vector)) (void)])] 766 [else (safe-assert (not 'ptr)) (void)]))) 767 (let* ([vspc (cond 768 [maybe-uid 769 (constant vspace-rtd)] 770 [(eqv? 0 (let-values ([(bv offset) (vptr->bytevector+offset rtd-p vfi)]) 771 (ref-uptr bv (fx+ offset (constant record-type-mpm-disp))))) 772 (constant vspace-pure-typed)] 773 [else 774 (constant vspace-impure-record)])] 775 [new-p (find-room 'record vfi vspc size (constant type-typed-object))]) 776 (graph! v new-p vfi) 777 (set-ptr! new-p (constant record-type-disp) rtd-p vfi) 778 (let loop ([addr (constant record-data-disp)] 779 [pad-ty* pad-ty*] 780 [fld* fld*]) 781 (unless (null? pad-ty*) 782 (let* ([pad-ty (car pad-ty*)] 783 [addr (fx+ addr (fxsrl pad-ty 4))] 784 [addr (field-case (car fld*) 785 [ptr (elem) 786 (safe-assert (eqv? (fxand pad-ty #xF) (constant fasl-fld-ptr))) 787 (set-ptr! new-p addr (copy elem vfi) vfi) 788 (fx+ addr (constant ptr-bytes))] 789 [iptr (elem) 790 (set-iptr! new-p addr elem vfi) 791 (fx+ addr (constant ptr-bytes))] 792 [double (high low) 793 (safe-assert (eqv? (fxand pad-ty #xF) (constant fasl-fld-double))) 794 (set-double! new-p addr 795 (build-flonum high low) 796 vfi) 797 (fx+ addr (constant double-bytes))] 798 [else 799 (error 'vfasl "unsupported field: ~s" (car fld*))])]) 800 (loop addr (cdr pad-ty*) (cdr fld*))))) 801 new-p))])] 802 [(closure offset c) 803 (let* ([c-v (copy c vfi)] 804 [new-p (find-room 'closure vfi 805 (constant vspace-closure) 806 (constant header-size-closure) 807 (constant type-closure))]) 808 (graph! v new-p vfi) 809 (set-ptr!/no-record new-p (constant closure-code-disp) (vptr+ c-v offset) vfi) 810 new-p)] 811 [(code flags free name arity-mask info pinfo* bytes m vreloc) 812 (let* ([len (bytevector-length bytes)] 813 [new-p (find-room 'code vfi 814 (constant vspace-code) 815 (fx+ (constant header-size-code) len) 816 (constant type-typed-object))]) 817 (graph! v new-p vfi) 818 (set-uptr! new-p (constant code-type-disp) 819 (bitwise-ior (bitwise-arithmetic-shift-left flags (constant code-flags-offset)) 820 (constant type-code)) 821 vfi) 822 (set-uptr! new-p (constant code-length-disp) len vfi) 823 (set-ptr! new-p (constant code-name-disp) 824 (fasl-case* name 825 [(string ty string) 826 ;; imitate string interning that fasl read performs: 827 (if (or (eqv? ty (constant fasl-type-string)) 828 (eqv? ty (constant fasl-type-immutable-string))) 829 (string-copy string vfi) 830 (copy name vfi))] 831 [else (copy name vfi)]) 832 vfi) 833 (set-ptr! new-p (constant code-arity-mask-disp) (copy arity-mask vfi) vfi) 834 (set-uptr! new-p (constant code-closure-length-disp) free vfi) 835 (set-ptr! new-p (constant code-info-disp) (copy info vfi) vfi) 836 (set-ptr! new-p (constant code-pinfo*-disp) (copy pinfo* vfi) vfi) 837 (copy-u8s! new-p (constant code-data-disp) bytes 0 len vfi) 838 ;; must be after code is copied into place: 839 (set-ptr!/no-record new-p (constant code-reloc-disp) (copy-reloc m vreloc new-p vfi) vfi) 840 new-p)] 841 [(symbol-hashtable mutable? minlen subtype veclen vpfasl) 842 (let* ([flds (rtd-flds $symbol-ht-rtd)] 843 [len (fx* (length flds) (constant ptr-bytes))] 844 [new-p (find-room 'symbol-ht vfi 845 (constant vspace-impure) 846 (fx+ (constant header-size-record) len) 847 (constant type-typed-object))] 848 [vec-p (find-room 'symbol-ht-vector vfi 849 (constant vspace-impure) 850 (fx+ (constant header-size-vector) (fx* veclen (constant ptr-bytes))) 851 (constant type-typed-object))] 852 [equiv (case subtype 853 [(0) (make-vsingleton (constant singleton-eq))] 854 [(1) (make-vsingleton (constant singleton-eqv))] 855 [(2) (make-vsingleton (constant singleton-equal))] 856 [(3) (make-vsingleton (constant singleton-symbol=?))] 857 [else ($oops 'vfasl "unrecognized symbol table subtype ~s" subtype)])]) 858 (define (field-offset name) 859 (let loop ([flds flds] [addr (constant record-data-disp)]) 860 (cond 861 [(null? flds) ($oops 'vfasl "could not find symbol hash table field ~s" name)] 862 [(eq? (fld-name (car flds)) name) addr] 863 [else (loop (cdr flds) (fx+ addr (constant ptr-bytes)))]))) 864 (graph! v new-p vfi) 865 (set-ptr! new-p (constant record-type-disp) (make-vsingleton (constant singleton-symbol-ht-rtd)) vfi) 866 (set-ptr! new-p (field-offset 'type) (make-vsingleton (constant singleton-symbol-symbol)) vfi) 867 (set-ptr! new-p (field-offset 'mutable?) (if mutable? (constant strue) (constant sfalse)) vfi) 868 (set-ptr! new-p (field-offset 'vec) vec-p vfi) 869 (set-ptr! new-p (field-offset 'minlen) (fix minlen) vfi) 870 (set-ptr! new-p (field-offset 'size) (fix (vector-length vpfasl)) vfi) 871 (set-ptr! new-p (field-offset 'equiv?) equiv vfi) 872 (set-uptr! vec-p (constant vector-type-disp) 873 (bitwise-ior (bitwise-arithmetic-shift-left veclen (constant vector-length-offset)) 874 (constant type-vector)) 875 vfi) 876 (let ([to-vec (make-vector veclen (constant snil))]) 877 ;; first, determine what goes in each vector slot, building up 878 ;; pair copies for the vector slots: 879 (vector-for-each (lambda (p) 880 (let* ([a (copy (car p) vfi)] 881 [b (copy (cdr p) vfi)] 882 [hc (or (fasl-case* (car p) 883 [(string ty string) 884 (and (eqv? ty (constant fasl-type-symbol)) 885 (target-symbol-hash (string->symbol string)))] 886 [(gensym pname uname) 887 (target-symbol-hash (gensym pname uname))] 888 [else #f]) 889 ($oops 'vfasl "symbol table key not a symbol ~s" (car p)))] 890 [i (fxand hc (fx- veclen 1))]) 891 (vector-set! to-vec i (pair-copy (pair-copy a b vfi) (vector-ref to-vec i) vfi)))) 892 vpfasl) 893 ;; install the vector slots: 894 (let loop ([i 0]) 895 (unless (fx= i veclen) 896 (set-ptr! vec-p (fx+ (constant vector-data-disp) (fx* i (constant ptr-bytes))) 897 (vector-ref to-vec i) 898 vfi) 899 (loop (fx+ i 1))))) 900 new-p)] 901 [(indirect g i) (copy (vector-ref g i) vfi)] 902 [else 903 ($oops 'vfasl "unsupported ~s" v)])) 904 905(define-syntax (vector-copy stx) 906 (syntax-case stx () 907 [(_ v vec vfi 908 vec-length 909 vspace 910 header-size-vec data-disp 911 elem-bytes 912 tag 913 vec-type-disp 914 set-elem! 915 vec-ref) 916 #'(let* ([len (vec-length vec)] 917 [new-p (find-room 'vec-type-disp vfi 918 (constant vspace) 919 (fx+ (constant header-size-vec) (fx* len (constant elem-bytes))) 920 (constant type-typed-object))]) 921 (graph! v new-p vfi) 922 (set-uptr! new-p (constant vec-type-disp) tag vfi) 923 (let loop ([i 0]) 924 (unless (fx= i len) 925 (set-elem! new-p (fx+ (constant data-disp) (fx* i (constant elem-bytes))) 926 (vec-ref vec i) 927 vfi) 928 (loop (fx+ i 1)))) 929 new-p)])) 930 931(define (symbol-copy v name sym vfi) 932 (let ([v2 (eq-hashtable-ref (vfasl-info-symbols vfi) sym v)]) 933 (cond 934 [(not (eq? v v2)) 935 (copy v2 vfi)] 936 [else 937 (eq-hashtable-set! (vfasl-info-symbols vfi) sym v) 938 (let ([new-p (find-room 'symbol vfi 939 (constant vspace-symbol) 940 (constant size-symbol) 941 (constant type-symbol))]) 942 (graph! v new-p vfi) 943 (set-uptr! new-p (constant symbol-value-disp) 944 ;; use value slot to store symbol index 945 (fix (symbol-vptr->index new-p vfi)) 946 vfi) 947 (set-uptr! new-p (constant symbol-pvalue-disp) (constant snil) vfi) 948 (set-uptr! new-p (constant symbol-plist-disp) (constant snil) vfi) 949 (set-ptr! new-p (constant symbol-name-disp) name vfi) 950 (set-uptr! new-p (constant symbol-splist-disp) (constant snil) vfi) 951 (set-iptr! new-p (constant symbol-hash-disp) (fix (target-symbol-hash sym)) vfi) 952 new-p)]))) 953 954(define target-symbol-hash 955 (let ([symbol-hashX (constant-case ptr-bits 956 [(32) (foreign-procedure "(cs)symbol_hash32" (ptr) integer-32)] 957 [(64) (foreign-procedure "(cs)symbol_hash64" (ptr) integer-64)])]) 958 (lambda (s) 959 (bitwise-and (symbol-hashX (if (gensym? s) 960 (gensym->unique-string s) 961 (symbol->string s))) 962 (constant most-positive-fixnum))))) 963 964(define (string-copy name vfi) 965 ;; interns `name` so that symbols and code share 966 (let ([s (or (hashtable-ref (vfasl-info-strings vfi) name #f) 967 (let ([s (fasl-string (constant fasl-type-immutable-string) name)]) 968 (hashtable-set! (vfasl-info-strings vfi) name s) 969 s))]) 970 (copy s vfi))) 971 972(define (pair-copy a d vfi) 973 (let* ([new-p (find-room 'pair vfi 974 (constant vspace-impure) 975 (constant size-pair) 976 (constant type-pair))]) 977 (set-ptr! new-p (constant pair-car-disp) a vfi) 978 (set-ptr! new-p (constant pair-cdr-disp) d vfi) 979 new-p)) 980 981(define (exact-integer-copy v n vfi) 982 (if (<= (constant most-negative-fixnum) n (constant most-positive-fixnum)) 983 (fix n) 984 (let ([len (fxquotient (fx+ (integer-length n) (fx- (constant bigit-bits) 1)) (constant bigit-bits))]) 985 (vector-copy v n vfi 986 (lambda (n) len) 987 vspace-data 988 header-size-bignum bignum-data-disp 989 bigit-bytes 990 (bitwise-ior (bitwise-arithmetic-shift-left len (constant bignum-length-offset)) 991 (if (negative? n) 992 (constant type-negative-bignum) 993 (constant type-positive-bignum))) 994 bignum-type-disp 995 set-bigit! 996 (lambda (n i) 997 (let ([i (- len i 1)]) 998 (let ([i (fx* i (constant bigit-bits))]) 999 (bitwise-bit-field n i (fx+ i (constant bigit-bits)))))))))) 1000 1001(define (base-rtd-copy v vfi) 1002 (let ([new-p (or (vfasl-info-base-rtd vfi) 1003 (find-room 'base-rtd vfi 1004 (constant vspace-rtd) 1005 (constant size-record-type) 1006 (constant type-typed-object)))]) 1007 ;; this is a placeholder, and there's no need to write any content 1008 (graph! v new-p vfi) 1009 (vfasl-info-base-rtd-set! vfi new-p) 1010 new-p)) 1011 1012(define (refers-back-to-self? v rtd) 1013 (or (eq? v rtd) 1014 (fasl-case* rtd 1015 [(indirect g i) (refers-back-to-self? v (vector-ref g i))] 1016 [else #f]))) 1017 1018(define (reloc-addr n) 1019 (fx+ (constant reloc-table-data-disp) (fx* n (constant ptr-bytes)))) 1020 1021(define (make-short-reloc type code-offset item-offset) 1022 (bitwise-ior (bitwise-arithmetic-shift-left type (constant reloc-type-offset)) 1023 (bitwise-arithmetic-shift-left code-offset (constant reloc-code-offset-offset)) 1024 (bitwise-arithmetic-shift-left item-offset (constant reloc-item-offset-offset)))) 1025 1026(define (build-vfasl-reloc tag pos) 1027 (fix (bitwise-ior tag (bitwise-arithmetic-shift-left pos (constant vfasl-reloc-tag-bits))))) 1028 1029(define (copy-reloc m vreloc code-p vfi) 1030 (let* ([new-p (find-room 'reloc vfi 1031 (constant vspace-reloc) 1032 (fx+ (constant header-size-reloc-table) (fx* m (constant ptr-bytes))) 1033 (constant type-untyped))]) 1034 (set-uptr! new-p (constant reloc-table-size-disp) m vfi) 1035 (set-ptr!/no-record new-p (constant reloc-table-code-disp) code-p vfi) 1036 (let loop ([n 0] [a 0] [i 0]) 1037 (unless (fx= n m) 1038 (fasl-case* (vector-ref vreloc i) 1039 [(reloc type-etc code-offset item-offset elem) 1040 (let* ([type (fxsra type-etc 2)] 1041 [n (cond 1042 [(fxlogtest type-etc 1) 1043 (set-uptr! new-p (reloc-addr n) 1044 (bitwise-ior (fxsll type (constant reloc-type-offset)) 1045 (constant reloc-extended-format)) 1046 vfi) 1047 (set-uptr! new-p (reloc-addr (fx+ n 1)) item-offset vfi) 1048 (set-uptr! new-p (reloc-addr (fx+ n 2)) code-offset vfi) 1049 (fx+ n 3)] 1050 [else 1051 (set-uptr! new-p (reloc-addr n) 1052 (make-short-reloc type code-offset item-offset) 1053 vfi) 1054 (fx+ n 1)])] 1055 [a (fx+ a code-offset)] 1056 [new-elem (or (fasl-case* elem 1057 [(atom ty uptr) 1058 (constant-case* ty 1059 [(fasl-type-entry) 1060 (when (eqv? uptr (lookup-c-entry install-library-entry)) 1061 (vfasl-info-installs-library-entry?-set! vfi #t)) 1062 (build-vfasl-reloc (constant vfasl-reloc-c-entry-tag) uptr)] 1063 [(fasl-type-library) 1064 (build-vfasl-reloc (constant vfasl-reloc-library-entry-tag) uptr)] 1065 [(fasl-type-library-code) 1066 (build-vfasl-reloc (constant vfasl-reloc-library-entry-code-tag) uptr)] 1067 [else #f])] 1068 [else #f]) 1069 (let ([elem-addr (copy elem vfi)]) 1070 (cond 1071 [(vsingleton? elem-addr) 1072 (build-vfasl-reloc (constant vfasl-reloc-singleton-tag) 1073 (vsingleton-index elem-addr))] 1074 [(vptr? elem-addr) 1075 (cond 1076 [(eqv? (vptr-vspace elem-addr) (constant vspace-symbol)) 1077 (build-vfasl-reloc (constant vfasl-reloc-symbol-tag) 1078 (symbol-vptr->index elem-addr vfi))] 1079 [else 1080 (let-values ([(bv offset) (vptr->bytevector+offset elem-addr vfi)]) 1081 (safe-assert (not (fixed? offset))) 1082 (fx- offset (vfasl-info-base-addr vfi)))])] 1083 [else 1084 ;; an immediate value; for fixnums, we can only allow 0 1085 (unless (or (eqv? elem-addr 0) 1086 (not (fixed? elem-addr))) 1087 ($oops 'vfasl "unexpected fixnum in relocation ~s" elem-addr)) 1088 elem-addr])))]) 1089 ;; overwrites constant-loading instructions in the code, so the 1090 ;; linking protocol needs to be able to deal with that, possibly using 1091 ;; later instructions to infer the right repair: 1092 (set-iptr! code-p a new-elem vfi) 1093 (loop n a (fx+ i 1)))] 1094 [else ($oops 'vfasl "expected a relocation")]))) 1095 new-p)) 1096 1097(set! $fasl-to-vfasl to-vfasl) 1098(set! $fasl-can-combine? fasl-can-combine?)) 1099