gsc/_t-c-2.scm

   1 ;;;============================================================================
   2
   3 ;;; File: "_t-c-2.scm", Time-stamp: <2009-06-08 06:36:56 feeley>
   4
   5 ;;; Copyright (c) 1994-2009 by Marc Feeley, All Rights Reserved.
   6
   7 (include "fixnum.scm")
   8
   9 (include-adt "_envadt.scm")
  10 (include-adt "_gvmadt.scm")
  11 (include-adt "_ptreeadt.scm")
  12 (include-adt "_sourceadt.scm")
  13
  14 '(begin;**************brad
  15 (##include "../gsc/_utilsadt.scm")
  16 (##include "../gsc/_ptree1adt.scm")
  17 (##include "../gsc/_gvmadt.scm")
  18 (##include "../gsc/_hostadt.scm")
  19 )
  20
  21 ;;;----------------------------------------------------------------------------
  22 ;;
  23 ;; Back end for C language (part 2)
  24 ;; -----------------------
  25
  26 (define (targ-scan-procedure obj)
  27   (let* ((proc (car obj))
  28          (p (cdr obj)))
  29
  30     (if targ-info-port
  31       (begin
  32         (display "  #<" targ-info-port)
  33         (if (proc-obj-primitive? proc)
  34           (display "primitive " targ-info-port)
  35           (display "procedure " targ-info-port))
  36         (write (string->canonical-symbol (proc-obj-name proc)) targ-info-port)
  37         (display ">" targ-info-port)))
  38
  39     (set! targ-proc-name               (proc-obj-name proc))
  40     (set! targ-proc-code               (make-stretchable-vector #f))
  41     (set! targ-proc-code-length        0)
  42     (set! targ-proc-rd-res             (make-stretchable-vector #f))
  43     (set! targ-proc-wr-res             (make-stretchable-vector #f))
  44     (set! targ-proc-lbl-tbl            (queue-empty))
  45     (set! targ-proc-lbl-tbl-ord        (queue-empty))
  46     (set! targ-debug-info?             #f)
  47     (set! targ-var-descr-queue         (queue-empty))
  48     (set! targ-first-class-label-queue (queue-empty))
  49
  50 ;;    (targ-repr-begin-proc!)
  51
  52     (let ((x (proc-obj-code proc)))
  53       (if (bbs? x)
  54         (targ-scan-scheme-procedure x)
  55         (targ-scan-c-procedure x)))
  56
  57 ;;    (targ-repr-end-proc!)
  58
  59     (targ-cell-set! (caddr p) (+ targ-lbl-alloc 1))
  60
  61     ; Assign label numbers sequentially, starting with "value" labels
  62     ; and then "goto" labels
  63
  64     (let ((ord-lbls (queue->list targ-proc-lbl-tbl-ord)))
  65       (let loop2 ((l ord-lbls) (i 0) (val-lbls '()))
  66         (if (pair? l)
  67           (let ((x (car l)))
  68             (if (targ-lbl-val? x)
  69               (begin
  70                 (targ-cell-set! (targ-lbl-num x) i)
  71                 (loop2 (cdr l) (+ i 1) (cons x val-lbls)))
  72               (loop2 (cdr l) i val-lbls)))
  73           (let ((info (targ-debug-info)))
  74             (targ-use-obj info)
  75             (set! targ-lbl-alloc (+ targ-lbl-alloc (+ i 1)))
  76             (set-car! p
  77               (vector targ-proc-code
  78                       (reverse val-lbls)
  79                       targ-proc-rd-res
  80                       targ-proc-wr-res
  81                       info))
  82             (let loop3 ((l ord-lbls) (i i))
  83               (if (pair? l)
  84                 (let ((x (car l)))
  85                   (if (and (targ-lbl-goto? x)
  86                            (not (targ-lbl-val? x)))
  87                     (begin
  88                       (targ-cell-set! (targ-lbl-num x) i)
  89                       (loop3 (cdr l) (+ i 1)))
  90                     (loop3 (cdr l) i)))))))))
  91
  92     (if targ-info-port
  93       (newline targ-info-port))
  94
  95     ))
  96
  97 (define (targ-debug-info)
  98
  99   (define (number i lst)
 100     (if (null? lst)
 101       '()
 102       (cons (list->vect (cons i (car lst)))
 103             (number (+ i 1) (cdr lst)))))
 104
 105   (if targ-debug-info?
 106     (vector (list->vect (number 0 (queue->list targ-first-class-label-queue)))
 107             (list->vect (queue->list targ-var-descr-queue)))
 108     #f))
 109
 110 (define (targ-scan-scheme-procedure bbs)
 111
 112   (set! targ-proc-entry-lbl   (bbs-entry-lbl-num bbs))
 113   (set! targ-proc-lbl-counter (make-counter (bbs-next-lbl-num bbs)))
 114
 115   (let loop ((prev-bb #f)
 116              (prev-gvm-instr #f)
 117              (l (bbs->code-list bbs)))
 118     (if (not (null? l))
 119       (let ((pres-bb (code-bb (car l)))
 120             (pres-gvm-instr (code-gvm-instr (car l)))
 121             (pres-slots-needed (code-slots-needed (car l)))
 122             (next-gvm-instr (if (null? (cdr l))
 123                               #f
 124                               (code-gvm-instr (cadr l)))))
 125
 126         (targ-gen-gvm-instr prev-gvm-instr
 127                             pres-gvm-instr
 128                             next-gvm-instr
 129                             pres-slots-needed)
 130
 131         (loop pres-bb pres-gvm-instr (cdr l))))))
 132
 133 (define (targ-scan-c-procedure c-proc)
 134
 135   (define (ps-opnd opnd)
 136     (cond ((reg? opnd)
 137            (let ((n (reg-num opnd)))
 138              (cons 'psr n)))
 139           (else ; must be stack slot
 140            (list "PSSTK" (- (stk-num opnd) targ-proc-fp)))))
 141
 142   (let* ((arity (c-proc-arity c-proc))
 143          (pc (targ-label-info arity #f))
 144          (pc-map (pcontext-map pc))
 145          (pc-fs (pcontext-fs pc))
 146          (ret (cdr (assq 'return pc-map)))
 147          (fs (+ arity 1))
 148          (lbl 2))
 149
 150     (set! targ-proc-entry-lbl 1)
 151
 152     (targ-start-bb pc-fs)
 153
 154     (set! targ-proc-entry-frame targ-proc-exit-frame);********** for targ-update-fr but probably not needed since it can't be called from here!
 155     (targ-begin-fr) ; ************* not needed either
 156
 157     (targ-emit-label-entry targ-proc-entry-lbl arity #f)
 158     (targ-ref-lbl-goto targ-proc-entry-lbl)
 159
 160     (targ-emit (list "IF_NARGS_EQ" arity '("NOTHING")))
 161     (targ-emit (list "WRONG_NARGS"
 162                      (targ-ref-lbl-val targ-proc-entry-lbl)
 163                      arity 0 0))
 164     (targ-emit (list 'append
 165                      (list "DEF_GLBL" (targ-make-glbl "" targ-proc-name))
 166                      #\newline))
 167
 168 ;;    (targ-repr-begin-block! 'entry targ-proc-entry-lbl)
 169
 170     ; move arguments from registers to stack frame
 171
 172     (let loop1 ((i 1))
 173       (if (and (<= i arity) (<= i targ-nb-arg-regs))
 174         (begin
 175           (targ-emit
 176             (targ-loc (make-stk (+ pc-fs i)) (targ-opnd (make-reg i))))
 177           (loop1 (+ i 1)))))
 178
 179     ; store return address at top of stack frame
 180
 181     (targ-emit
 182       (targ-loc (make-stk fs) (targ-opnd ret)))
 183
 184 ;(targ-emit (targ-loc (make-stk (+ fs 1)) (targ-opnd (make-obj 1234567))));*********************
 185 ;(targ-emit (targ-loc (make-stk (+ fs 2)) (targ-opnd (make-obj 1234567))))
 186 ;(targ-emit (targ-loc (make-stk (+ fs 3)) (targ-opnd (make-obj 1234567))))
 187 ;(targ-emit (targ-loc (make-stk (+ fs 4)) (targ-opnd (make-obj 1234567))))
 188
 189     ; setup new return address
 190
 191     (targ-emit
 192       (targ-loc ret (targ-opnd (make-lbl lbl))))
 193
 194     (targ-emit
 195       (targ-adjust-stack (targ-align-frame (+ fs targ-frame-reserve))))
 196
 197     (targ-emit
 198       (list 'append (c-proc-body c-proc)))
 199
 200     (targ-emit
 201       (list "JUMPPRM"
 202             '("NOTHING")
 203             (targ-opnd (make-reg 0))))
 204
 205 ;;    (targ-repr-exit-block! #f)
 206
 207 ;;    (targ-repr-end-block!)
 208
 209     (targ-emit-label-return lbl fs (- fs 1) (targ-build-gc-map-all-live fs) #f)
 210
 211 ;;    (targ-repr-begin-block! 'return lbl)
 212
 213     (targ-emit (targ-adjust-stack 0))
 214
 215 ;;    (targ-repr-exit-block! #f)
 216
 217     (targ-emit
 218       (list "JUMPPRM"
 219             '("NOTHING")
 220             (targ-opnd (make-stk fs))))
 221
 222 ;;    (targ-repr-end-block!)
 223 ))
 224
 225 ;;;----------------------------------------------------------------------------
 226
 227 ;; Information attached to a procedure
 228
 229 (define targ-proc-name            #f) ; procedure's name
 230 (define targ-proc-code            #f) ; code of the procedure
 231 (define targ-proc-code-length     #f) ; length of code of the procedure
 232 (define targ-proc-entry-lbl       #f) ; entry label
 233 (define targ-proc-lbl-counter     #f) ; label counter
 234 (define targ-proc-rd-res          #f) ; set of resources read from
 235 (define targ-proc-wr-res          #f) ; set of resources written to
 236 (define targ-proc-lbl-tbl         #f) ; table of all labels
 237 (define targ-proc-lbl-tbl-ord     #f) ; table of all labels ordered by def time
 238 (define targ-proc-fp              #f) ; frame pointer
 239 (define targ-proc-hp              #f) ; heap pointer
 240
 241 (define targ-debug-info?             #f) ; generate debug information?
 242 (define targ-var-descr-queue         #f)
 243 (define targ-first-class-label-queue #f)
 244
 245 (define targ-proc-instr-node      #f)
 246 (define targ-proc-entry-frame     #f)
 247 (define targ-proc-exit-frame      #f)
 248
 249 ;; Emit a piece of code
 250
 251 (define (targ-emit code)
 252   (stretchable-vector-set! targ-proc-code targ-proc-code-length code)
 253   (set! targ-proc-code-length (+ targ-proc-code-length 1)))
 254
 255 ;; Emit a label
 256
 257 (define (targ-emit-label-simp lbl)
 258   (targ-emit-label lbl #f #f))
 259
 260 (define (targ-emit-label-entry lbl nb-parms label-descr)
 261   (targ-emit-label lbl 'proc (vector nb-parms 0)))
 262
 263 (define (targ-emit-label-subproc lbl nb-parms nb-closed label-descr)
 264   (targ-emit-label lbl 'proc (vector nb-parms nb-closed)))
 265
 266 (define (targ-emit-label-return lbl fs link gc-map label-descr)
 267   (targ-emit-label lbl 'return (vector 'normal fs link gc-map)))
 268
 269 (define (targ-emit-label-return-task lbl fs link gc-map label-descr)
 270   (targ-emit-label lbl 'return (vector 'task fs link gc-map)))
 271
 272 (define (targ-emit-label-return-internal lbl fs link gc-map label-descr)
 273   (targ-emit-label lbl 'return (vector 'internal fs link gc-map)))
 274
 275 ;; Add a label to the code stream
 276
 277 (define (targ-emit-label lbl class info)
 278   (let ((x (targ-get-lbl lbl)))
 279     (targ-emit (cons 'label x))
 280     (targ-add-label x class info)))
 281
 282 (define (targ-add-label lbl-struct class info)
 283   (vector-set! lbl-struct 2 class)
 284   (vector-set! lbl-struct 3 info)
 285   (queue-put! targ-proc-lbl-tbl-ord lbl-struct))
 286
 287 ;; Add label "n" to label table and return label object
 288
 289 (define (targ-get-lbl n)
 290   (let ((x (assq n (queue->list targ-proc-lbl-tbl))))
 291     (if x
 292       (cdr x)
 293       (let ((y (vector (targ-make-cell #f) ; eventual label number (set later)
 294                        #f                  ; used as a "goto" label?
 295                        #f                  ; class (not #f if "value" label)
 296                        #f)))               ; extra info if "value" label
 297         (queue-put! targ-proc-lbl-tbl (cons n y))
 298         y))))
 299
 300 (define (targ-lbl-num lbl-struct)
 301   (vector-ref lbl-struct 0))
 302
 303 ;; Mark a label as referenced for "value" and return eventual label number
 304
 305 (define (targ-ref-lbl-val n)
 306   (let ((x (targ-get-lbl n)))
 307     (targ-lbl-num x)))
 308
 309 (define (targ-lbl-val? lbl-struct)
 310   (vector-ref lbl-struct 2))
 311
 312 ;; Mark a label as target for "goto" and return eventual label number
 313
 314 (define (targ-ref-lbl-goto n)
 315   (let ((x (targ-get-lbl n)))
 316     (vector-set! x 1 #t)
 317     (targ-make-glbl (targ-lbl-num x) targ-proc-name)))
 318
 319 (define (targ-lbl-goto? lbl-struct)
 320   (vector-ref lbl-struct 1))
 321
 322 (define (targ-make-glbl n name)
 323   (list 'glbl n name))
 324
 325 ;; To generate new, unique labels
 326
 327 (define (targ-new-lbl)
 328   (targ-proc-lbl-counter))
 329
 330 (define (targ-heap-reserve space)
 331   (set! targ-proc-hp (+ targ-proc-hp space)))
 332
 333 (define (targ-heap-reserve-and-check space sn)
 334   (targ-heap-reserve space)
 335   (if (> (+ targ-proc-hp
 336             (* (targ-fp-cache-size) targ-flonum-space))
 337          targ-msection-biggest)
 338     (targ-update-fr-and-check-heap space sn)))
 339
 340 (define (targ-update-fr-and-check-heap space sn)
 341   (targ-update-fr targ-proc-entry-frame)
 342   (targ-check-heap space sn))
 343
 344 (define (targ-check-heap space sn)
 345   (let ((lbl (targ-new-lbl)))
 346     (targ-need-heap)
 347     (targ-emit (targ-adjust-stack sn))
 348 ;;    (targ-repr-exit-block! lbl)
 349     (targ-emit
 350       (list "CHECK_HEAP"
 351             (targ-ref-lbl-val lbl)
 352             (+ targ-msection-biggest space)))
 353 ;;    (targ-repr-end-block!)
 354     (targ-gen-label-return* lbl 'return-internal)
 355     (set! targ-proc-hp 0)))
 356
 357 (define (targ-poll sn)
 358   (let ((lbl (targ-new-lbl)))
 359     (targ-rd-fp)
 360     (targ-emit (targ-adjust-stack sn))
 361 ;;    (targ-repr-exit-block! lbl)
 362     (targ-emit
 363       (list "POLL" (targ-ref-lbl-val lbl)))
 364 ;;    (targ-repr-end-block!)
 365     (targ-gen-label-return* lbl 'return-internal)))
 366
 367 (define (targ-start-bb fs)
 368   (set! targ-proc-hp 0)
 369   (set! targ-proc-fp fs))
 370
 371 (define (targ-begin-fr) ; start of a floating point region
 372   (targ-fp-cache-init))
 373
 374 (define (targ-update-fr frame)
 375   (let* ((live
 376           (frame-live frame))
 377          (any-closed-live?
 378           (varset-intersects?
 379             live
 380             (list->varset (frame-closed frame)))))
 381
 382     (define (live? var)
 383       (or (varset-member? var live)
 384           (and (eq? var closure-env-var) any-closed-live?)))
 385
 386     (let loop1 ((i 1) (l (reverse (frame-slots frame))))
 387       (if (pair? l)
 388         (begin
 389           (if (live? (car l))
 390             (targ-fp-cache-write-if-dirty (make-stk i)))
 391           (loop1 (+ i 1) (cdr l)))
 392         (let loop2 ((i 0) (l (frame-regs frame)))
 393           (if (pair? l)
 394             (begin
 395               (if (live? (car l))
 396                 (targ-fp-cache-write-if-dirty (make-reg i)))
 397               (loop2 (+ i 1) (cdr l)))))))))
 398
 399 ;; Management of resources
 400
 401 (define targ-nb-non-reg-res 2)
 402
 403 (define (targ-res-op i op)
 404   (let ((x (if (< i targ-nb-non-reg-res)
 405              (cons op (vector-ref '#("HEAP" "FP") i))
 406              (let ((j (- i targ-nb-non-reg-res)))
 407                (if (< j targ-nb-gvm-regs)
 408                  (cons op (string-append "R" (number->string j)))
 409                  (if (eq? op 'd-)
 410                    (let ((k (- j targ-nb-gvm-regs)))
 411                      (list "D_F64"
 412                            (targ-unboxed-index->code k)))
 413                    #f))))))
 414     (and x (list 'append " " x))))
 415
 416 (define (targ-unboxed-loc->index loc)
 417   (cond ((reg? loc)
 418          (reg-num loc))
 419         ((stk? loc)
 420          (+ (- (stk-num loc) 1) targ-nb-gvm-regs))
 421         (else
 422          (compiler-internal-error
 423            "targ-unboxed-loc->index, invalid 'loc'" loc))))
 424
 425 (define targ-use-fresh-fp-vars? #f)
 426 (set! targ-use-fresh-fp-vars? #t)
 427
 428 (define (targ-unboxed-index->code i)
 429   (targ-need-unboxed i)
 430   (cond (targ-use-fresh-fp-vars?
 431          (list (string-append
 432                 "F64V"
 433                 (number->string i))))
 434         ((< i targ-nb-gvm-regs)
 435          (list (string-append
 436                 "F64R"
 437                 (number->string i))))
 438         (else
 439          (list (string-append
 440                 "F64STK"
 441                 (number->string (+ (- i targ-nb-gvm-regs) 1)))))))
 442
 443 (define (targ-unboxed-loc->code loc stamp)
 444   (targ-unboxed-index->code
 445     (if targ-use-fresh-fp-vars?
 446       stamp
 447       (targ-unboxed-loc->index loc))))
 448
 449 (define (targ-rd-res i)
 450   (stretchable-vector-set! targ-module-rd-res i #t)
 451   (stretchable-vector-set! targ-proc-rd-res i #t))
 452
 453 (define (targ-wr-res i)
 454   (targ-rd-res i)
 455   (stretchable-vector-set! targ-module-wr-res i #t)
 456   (stretchable-vector-set! targ-proc-wr-res i #t))
 457
 458 (define (targ-need-heap)
 459   (targ-wr-res 0))
 460
 461 (define (targ-rd-fp)
 462   (targ-rd-res 1))
 463
 464 (define (targ-wr-fp)
 465   (targ-wr-res 1))
 466
 467 (define (targ-rd-reg n)
 468   (targ-rd-res (+ n targ-nb-non-reg-res)))
 469
 470 (define (targ-wr-reg n)
 471   (targ-wr-res (+ n targ-nb-non-reg-res)))
 472
 473 (define (targ-need-unboxed n)
 474   (targ-wr-res
 475     (+ n (+ targ-nb-non-reg-res targ-nb-gvm-regs))))
 476
 477 (define (targ-use-all-res)
 478   (let loop ((i (- (+ targ-nb-non-reg-res targ-nb-gvm-regs) 1)))
 479     (if (>= i 0)
 480       (begin
 481         (targ-wr-res i)
 482         (loop (- i 1))))))
 483
 484 (define (targ-pop-pcontext pc)
 485   (for-each
 486    (lambda (x)
 487      (let ((opnd (cdr x)))
 488        (cond ((reg? opnd)
 489               (let ((n (reg-num opnd)))
 490                 (targ-rd-reg n)))
 491              ((stk? opnd)
 492               (targ-rd-fp)
 493               (targ-wr-fp))
 494              (else
 495               (compiler-internal-error
 496                "targ-pop-pcontext, unknown 'opnd'" opnd)))))
 497    (pcontext-map pc)))
 498
 499 (define (targ-push-pcontext pc)
 500   (for-each
 501    (lambda (x)
 502      (let ((opnd (cdr x)))
 503        (cond ((reg? opnd)
 504               (let ((n (reg-num opnd)))
 505                 (targ-wr-reg n)))
 506              ((stk? opnd)
 507               (targ-rd-fp)
 508               (targ-wr-fp))
 509              (else
 510               (compiler-internal-error
 511                "targ-push-pcontext, unknown 'opnd'" opnd)))))
 512    (pcontext-map pc)))
 513
 514 ;;;----------------------------------------------------------------------------
 515
 516 (define (targ-add-var-descr! descr)
 517
 518   (define (index x l)
 519     (let loop ((l l) (i 0))
 520       (cond ((not (pair? l))    #f)
 521             ((equal? (car l) x) i)
 522             (else               (loop (cdr l) (+ i 1))))))
 523
 524   (let ((n (index descr (queue->list targ-var-descr-queue))))
 525     (if n
 526       n
 527       (let ((m (length (queue->list targ-var-descr-queue))))
 528         (queue-put! targ-var-descr-queue descr)
 529         m))))
 530
 531 (define (targ-add-first-class-label! node slots frame)
 532
 533   (define (encode slot)
 534     (let ((v (car slot))
 535           (i (cdr slot)))
 536       (+ (* i 32768)
 537          (if (pair? v)
 538            (* (targ-add-var-descr! (map encode v)) 2)
 539            (+ (* (targ-add-var-descr! (var-name v)) 2)
 540               (if (var-boxed? v) 1 0))))))
 541
 542   (define (closure-env-slot closure-vars stack-slots)
 543     (let loop ((i 1) (lst1 closure-vars) (lst2 '()))
 544       (if (null? lst1)
 545         lst2
 546         (let ((x (car lst1)))
 547           (if (not (frame-live? x frame))
 548             (loop (+ i 1)
 549                   (cdr lst1)
 550                   lst2)
 551             (let ((y (assq (var-name x) stack-slots)))
 552               (if (and y (not (eq? x (cadr y))))
 553                 (begin
 554                   (if (< (var-lexical-level (cadr y))
 555                          (var-lexical-level x))
 556                       (let ()
 557                         (##namespace ("" pp));****************
 558                         (pp (list
 559                              'closure-vars: (map var-name closure-vars)
 560                              'stack-slots: (map car stack-slots)
 561                              'source: (source->expression (node-source node))
 562                              ))
 563                         (compiler-internal-error
 564                          "targ-add-first-class-label!, variable conflict")))
 565                   (loop (+ i 1)
 566                         (cdr lst1)
 567                         lst2))
 568                 (loop (+ i 1)
 569                       (cdr lst1)
 570                       (cons (cons x i) lst2)))))))))
 571
 572   (define (accessible-slots)
 573     (let loop1 ((i 1)
 574                 (lst1 slots)
 575                 (lst2 '())
 576                 (closure-env #f)
 577                 (closure-env-index #f))
 578       (if (pair? lst1)
 579         (let* ((var (car lst1))
 580                (x (frame-live? var frame)))
 581           (cond ((pair? x) ; closure environment?
 582                  (if (or (not closure-env) (eq? var closure-env))
 583                    (loop1 (+ i 1)
 584                           (cdr lst1)
 585                           lst2
 586                           var
 587                           i)
 588                    (compiler-internal-error
 589                     "targ-add-first-class-label!, multiple closure environments")))
 590                 ((or (not x) (temp-var? x)) ; not live or temporary var
 591                  (loop1 (+ i 1)
 592                         (cdr lst1)
 593                         lst2
 594                         closure-env
 595                         closure-env-index))
 596                 (else
 597                  (let* ((name (var-name x))
 598                         (y (assq name lst2)))
 599                    (if (and y (not (eq? x (cadr y))))
 600                      (let ((level-x (var-lexical-level x))
 601                            (level-y (var-lexical-level (cadr y))))
 602                        (cond ((< level-x level-y)
 603                               (loop1 (+ i 1)
 604                                      (cdr lst1)
 605                                      lst2
 606                                      closure-env
 607                                      closure-env-index))
 608                              ((< level-y level-x)
 609                               (loop1 (+ i 1)
 610                                      (cdr lst1)
 611                                      (cons (cons name (cons x i)) (remq y lst2))
 612                                      closure-env
 613                                      closure-env-index))
 614                              (else
 615                               ; Two different live variables have the same
 616                               ; name and lexical level, both variables will
 617                               ; be kept in the debugging information
 618                               ; descriptor even though in the actual program
 619                               ; only one of the two variables is in scope.
 620                               ; "flatten" causes this condition to happen.
 621                               ; TODO: take variable scopes into account.
 622                               (loop1 (+ i 1)
 623                                      (cdr lst1)
 624                                      (cons (cons name (cons x i)) lst2)
 625                                      closure-env
 626                                      closure-env-index))))
 627                      (loop1 (+ i 1)
 628                             (cdr lst1)
 629                             (cons (cons name (cons x i)) lst2)
 630                             closure-env
 631                             closure-env-index))))))
 632         (let* ((x
 633                 (if closure-env
 634                   (closure-env-slot (frame-live? closure-env frame) lst2)
 635                   '()))
 636                (accessible-stack-slots
 637                 (map cdr lst2)))
 638           (if (null? x)
 639             accessible-stack-slots
 640             (cons (cons x closure-env-index)
 641                   accessible-stack-slots))))))
 642
 643   (let ((label-descr
 644          (cons (if (and node
 645                         (or targ-debug-location-option?
 646                             targ-debug-source-option?))
 647                    (let ((src (node-source node)))
 648                      (set! targ-debug-info? #t)
 649                      (if targ-debug-location-option?
 650                          (if targ-debug-source-option?
 651                              src
 652                              (source-locat src))
 653                          (source->expression src)))
 654                    #f)
 655                (if (and node
 656                         (or targ-debug-environments-option?
 657                             (environment-map? (node-env node))))
 658                  (begin
 659                    (set! targ-debug-info? #t)
 660                    (map encode (accessible-slots)))
 661                  '()))))
 662     (queue-put! targ-first-class-label-queue label-descr)
 663     label-descr))
 664
 665 ;;;----------------------------------------------------------------------------
 666
 667 (define (targ-gen-gvm-instr prev-gvm-instr gvm-instr next-gvm-instr sn)
 668
 669   (set! targ-proc-instr-node
 670     (comment-get (gvm-instr-comment gvm-instr) 'node))
 671   (set! targ-proc-exit-frame
 672     (gvm-instr-frame gvm-instr))
 673   (set! targ-proc-entry-frame
 674     (and prev-gvm-instr (gvm-instr-frame prev-gvm-instr)))
 675
 676 ;;  (write-gvm-instr gvm-instr ##stdout)(newline);*************
 677
 678   (if targ-track-scheme-option?
 679     (let* ((src (node-source targ-proc-instr-node))
 680            (x (locat-filename-and-line (and src (source-locat src))))
 681            (filename (car x))
 682            (line (cdr x)))
 683       (if (< 0 (string-length filename))
 684         (targ-emit
 685          (list 'line line filename)))))
 686
 687   (case (gvm-instr-type gvm-instr)
 688
 689     ((label)
 690      (set! targ-proc-entry-frame targ-proc-exit-frame)
 691      (targ-start-bb (frame-size targ-proc-exit-frame))
 692      (case (label-type gvm-instr)
 693        ((simple)
 694         (targ-gen-label-simple (label-lbl-num gvm-instr)
 695                                sn))
 696        ((entry)
 697         (targ-gen-label-entry (label-lbl-num gvm-instr)
 698                               (label-entry-nb-parms gvm-instr)
 699                               (label-entry-opts gvm-instr)
 700                               (label-entry-keys gvm-instr)
 701                               (label-entry-rest? gvm-instr)
 702                               (label-entry-closed? gvm-instr)
 703                               sn))
 704        ((return)
 705         (targ-gen-label-return (label-lbl-num gvm-instr)
 706                                sn))
 707        ((task-entry)
 708         (targ-gen-label-task-entry (label-lbl-num gvm-instr)
 709                                    sn))
 710        ((task-return)
 711         (targ-gen-label-task-return (label-lbl-num gvm-instr)
 712                                     sn))
 713        (else
 714         (compiler-internal-error
 715           "targ-gen-gvm-instr, unknown label type"))))
 716
 717     ((apply)
 718      (targ-gen-apply (apply-prim gvm-instr)
 719                      (apply-opnds gvm-instr)
 720                      (apply-loc gvm-instr)
 721                      sn))
 722
 723     ((copy)
 724      (targ-gen-copy (copy-opnd gvm-instr)
 725                     (copy-loc gvm-instr)
 726                     sn))
 727
 728     ((close)
 729      (targ-gen-close (close-parms gvm-instr)
 730                      sn))
 731
 732     ((ifjump)
 733      (targ-gen-ifjump (ifjump-test gvm-instr)
 734                       (ifjump-opnds gvm-instr)
 735                       (ifjump-true gvm-instr)
 736                       (ifjump-false gvm-instr)
 737                       (ifjump-poll? gvm-instr)
 738                       (if (and next-gvm-instr
 739                                (memq (label-type next-gvm-instr)
 740                                      '(simple task-entry)))
 741                         (label-lbl-num next-gvm-instr)
 742                         #f)))
 743
 744     ((switch)
 745      (targ-gen-switch (switch-opnd gvm-instr)
 746                       (switch-cases gvm-instr)
 747                       (switch-default gvm-instr)
 748                       (switch-poll? gvm-instr)
 749                       (if (and next-gvm-instr
 750                                (memq (label-type next-gvm-instr)
 751                                      '(simple task-entry)))
 752                         (label-lbl-num next-gvm-instr)
 753                         #f)))
 754
 755     ((jump)
 756      (targ-gen-jump (jump-opnd gvm-instr)
 757                     (jump-nb-args gvm-instr)
 758                     (jump-poll? gvm-instr)
 759                     (jump-safe? gvm-instr)
 760                     (if (and next-gvm-instr
 761                              (memq (label-type next-gvm-instr)
 762                                    '(simple task-entry)))
 763                       (label-lbl-num next-gvm-instr)
 764                       #f)))
 765
 766     (else
 767      (compiler-internal-error
 768        "targ-gen-gvm-instr, unknown 'gvm-instr'" gvm-instr))))
 769
 770 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 771
 772 (define (targ-gen-label-simple lbl sn)
 773   (targ-emit-label-simp lbl)
 774   (targ-begin-fr)
 775 ;;  (targ-repr-begin-block! 'simple lbl)
 776 )
 777
 778 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 779
 780 (define (targ-gen-label-entry lbl nb-parms opts keys rest? closed? sn)
 781
 782   (let ((label-descr (targ-add-first-class-label!
 783                        targ-proc-instr-node
 784                        '()
 785                        targ-proc-exit-frame)))
 786     (if (= lbl targ-proc-entry-lbl)
 787       (begin
 788         (targ-emit-label-entry lbl nb-parms label-descr)
 789         (targ-ref-lbl-val lbl)
 790         (targ-ref-lbl-goto lbl))
 791       (let ((nb-closed (length (frame-closed targ-proc-exit-frame))));******
 792         (targ-emit-label-subproc lbl nb-parms nb-closed label-descr))))
 793
 794   (let* ((nb-parms-except-rest
 795           (- nb-parms (if rest? 1 0)))
 796          (nb-keys
 797           (if keys (length keys) 0))
 798          (nb-req-and-opt
 799           (- nb-parms-except-rest nb-keys))
 800          (nb-opts
 801           (length opts))
 802          (nb-req
 803           (- nb-req-and-opt nb-opts))
 804          (lbl*
 805           (targ-ref-lbl-val lbl))
 806          (defaults
 807           (append opts (map cdr (or keys '())))))
 808
 809     (define (make-key-descriptor)
 810       (let loop ((lst1 keys) (lst2 '()))
 811         (if (null? lst1)
 812           (list->vect (reverse lst2))
 813           (let ((key (car lst1)))
 814             (loop (cdr lst1)
 815                   (cons (obj-val (cdr key)) (cons (car key) lst2)))))))
 816
 817     (define (dispatch-on-nb-args nb-args)
 818       (if (> nb-args nb-req-and-opt)
 819
 820         (targ-emit
 821          (if keys
 822            (list (if rest?
 823                    (if (eq? rest? 'dsssl)
 824                        "GET_REST_KEY"
 825                        "GET_KEY_REST")
 826                    "GET_KEY")
 827                  lbl* nb-req nb-opts nb-keys
 828                  (targ-use-obj (make-key-descriptor)))
 829            (list (if rest? "GET_REST" "WRONG_NARGS")
 830                  lbl* nb-req nb-opts nb-keys)))
 831
 832         (let ((nb-stacked (max 0 (- nb-args targ-nb-arg-regs)))
 833               (nb-stacked* (max 0 (- nb-parms targ-nb-arg-regs))))
 834
 835           (define (setup-parameter i)
 836             (if (<= i nb-parms)
 837               (let* ((rest (setup-parameter (+ i 1)))
 838                      (src-reg (- i nb-stacked))
 839                      (src (cond ((<= i nb-args)
 840                                  (cons 'r src-reg))
 841                                 ((and rest? (= i nb-parms))
 842                                  '("NUL"))
 843                                 (else
 844                                  (targ-use-obj
 845                                   (obj-val
 846                                    (list-ref defaults (- i nb-req 1))))))))
 847                 (if (<= i nb-stacked*)
 848                   (begin
 849                     (if (<= i nb-args) (targ-rd-reg src-reg))
 850                     (targ-rd-fp)
 851                     (targ-wr-fp)
 852                     (cons (list "PUSH" src) rest))
 853                   (if (and (<= i nb-args) (= nb-stacked nb-stacked*))
 854                     rest
 855                     (let ((dst-reg (- i nb-stacked*)))
 856                       (if (<= i nb-args) (targ-rd-reg src-reg))
 857                       (targ-wr-reg dst-reg)
 858                       (cons (list 'set-r dst-reg src) rest)))))
 859               '()))
 860
 861           (let ((x (setup-parameter (+ nb-stacked 1))))
 862             (targ-emit (list "IF_NARGS_EQ"
 863                              nb-args
 864                              (if (null? x) '("NOTHING") (cons 'seq x)))))
 865
 866           (dispatch-on-nb-args (+ nb-args 1)))))
 867
 868     (dispatch-on-nb-args nb-req)
 869
 870     (if (= lbl targ-proc-entry-lbl)
 871       (targ-emit (list 'append
 872                        (list "DEF_GLBL" (targ-make-glbl "" targ-proc-name))
 873                        #\newline)))
 874
 875     (targ-begin-fr)
 876 ;;    (targ-repr-begin-block! 'entry lbl)
 877 ))
 878
 879 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 880
 881 (define (targ-gen-label-return lbl sn)
 882   (targ-gen-label-return* lbl 'return))
 883
 884 (define (targ-gen-label-return* lbl kind)
 885   (let ((frame targ-proc-entry-frame))
 886
 887     (define (extend-vars l n)
 888       (cond ((= n 0) l)
 889             ((< n 0) (extend-vars (cdr l) (+ n 1)))
 890             (else    (extend-vars (cons empty-var l) (- n 1)))))
 891
 892     (define (generate fs vars gc-map)
 893       (let ((label-descr
 894              (targ-add-first-class-label!
 895               targ-proc-instr-node
 896               vars
 897               frame))
 898             (link
 899              (pos-in-list ret-var vars)))
 900         (if link
 901           (begin
 902             (case kind
 903               ((return)
 904                (targ-emit-label-return lbl fs link gc-map label-descr)
 905 ;;               (targ-repr-begin-block! 'return lbl)
 906 )
 907               ((return-task)
 908                (targ-emit-label-return-task lbl fs link gc-map label-descr)
 909 ;;               (targ-repr-begin-block! 'task-return lbl)
 910 )
 911               ((return-internal)
 912                (targ-emit-label-return-internal lbl fs link gc-map label-descr)
 913 ;;               (targ-repr-begin-block! 'return-internal lbl)
 914 )
 915               (else
 916                (compiler-internal-error
 917                  "targ-gen-label-return*, unknown label kind")))
 918             (targ-begin-fr))
 919           (compiler-internal-error
 920             "targ-gen-label-return*, no return address in frame"))))
 921
 922     (if (eq? kind 'return-internal)
 923       (let* ((cfs
 924               targ-proc-fp)
 925              (cfs-after-alignment
 926               (targ-align-frame cfs))
 927              (regs
 928               (frame-regs frame))
 929              (return-var
 930               (make-temp-var 'return))
 931              (vars
 932               (append (reverse (extend-vars (frame-slots frame)
 933                                             (- cfs-after-alignment
 934                                                (frame-size frame))))
 935                       (reverse (extend-vars (reverse regs)
 936                                             (- targ-nb-gvm-regs
 937                                                (length regs))))
 938                       (list return-var)
 939                       (extend-vars '()
 940                                    (- (- (targ-align-frame
 941                                           (+ (+ targ-nb-gvm-regs 1)
 942                                              targ-frame-reserve))
 943                                          targ-frame-reserve)
 944                                       (+ targ-nb-gvm-regs 1)))))
 945              (gc-map
 946               (targ-build-gc-map
 947                vars
 948                (lambda (i var)
 949                  (or (frame-live? var frame)
 950                      (let ((j (- i cfs-after-alignment)))
 951                        (and (>= j 0) ; all saved GVM regs are live
 952                             (<= j targ-nb-gvm-regs))))))))
 953         (generate cfs vars gc-map))
 954       (let* ((fs ; remove frame reserve from actual frame size
 955               (- targ-proc-fp targ-frame-reserve))
 956              (vars
 957               (reverse (extend-vars (frame-slots frame)
 958                                     (- fs (frame-size frame)))))
 959              (gc-map
 960               (targ-build-gc-map
 961                vars
 962                (lambda (i var)
 963                  (frame-live? var frame)))))
 964         (generate fs vars gc-map)))))
 965
 966 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 967
 968 (define (targ-gen-label-task-entry lbl sn)
 969
 970   (targ-emit-label-simp lbl)
 971
 972   (targ-emit (list "TASK_PUSH" 0))
 973
 974   (targ-begin-fr)
 975 ;;  (targ-repr-begin-block! 'task-entry lbl)
 976 )
 977
 978 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 979
 980 (define (targ-gen-label-task-return lbl sn)
 981   (let ((lbl2 (targ-new-lbl))
 982         (fs (frame-size targ-proc-exit-frame)))
 983
 984     (targ-start-bb fs)
 985
 986     (targ-gen-label-return* lbl 'return-task)
 987     (targ-emit (list "TASK_POP" (targ-ref-lbl-val lbl2)))
 988 ;;    (targ-repr-exit-block! lbl2)
 989 ;;    (targ-repr-end-block!)
 990     (targ-gen-label-return* lbl2 'return)))
 991
 992 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 993
 994 (define (targ-gen-apply prim opnds loc sn)
 995   (let ((proc (proc-obj-inline prim)))
 996     (if proc
 997       (begin
 998         (proc opnds loc sn)
 999         (targ-heap-reserve-and-check 0 sn))
1000       (compiler-internal-error
1001         "targ-gen-apply, unknown 'prim'" prim))))
1002
1003 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1004
1005 (define (targ-gen-copy opnd loc sn)
1006   (if opnd
1007     (targ-emit
1008      (targ-loc loc (targ-opnd opnd)))
1009 ;;    (targ-emit (targ-loc loc (targ-opnd (make-obj 1234567))));***********************
1010 )
1011   (targ-heap-reserve-and-check 0 sn))
1012
1013 '(;;
1014   (if targ-repr-enabled?
1015
1016     (if (and (or (reg? opnd) (stk? opnd))
1017              (or (reg? loc) (stk? loc)))
1018       (let* ((loc-descrs
1019               (targ-block-loc-descrs targ-repr-current-block))
1020              (i
1021               (targ-repr-loc->index opnd))
1022              (descr
1023               (stretchable-vector-ref loc-descrs i))
1024              (have
1025               (targ-repr-have-reprs descr)))
1026         (if (targ-repr-empty? have)
1027
1028           (targ-emit
1029             (targ-loc loc (targ-opnd opnd)))
1030
1031           (let ((j (targ-repr-loc->index loc)))
1032             (let loop1 ((repr targ-repr-boxed))
1033               (if (< repr targ-repr-nb-reprs)
1034                 (begin
1035                   (if (targ-repr-member? repr have)
1036                     (targ-emit
1037                       (if (= repr targ-repr-boxed)
1038                         (targ-repr-loc-boxed loc (targ-repr-opnd-boxed opnd))
1039                         (let ((type (vector-ref targ-repr-types (- repr 1))))
1040                           (list (string-append "SET_" type)
1041                                 (targ-repr-unboxed-loc->code loc repr)
1042                                 (targ-repr-unboxed-loc->code opnd repr))))))
1043                   (loop1 (+ repr 1)))))
1044             (stretchable-vector-set! loc-descrs j
1045               (targ-repr-have-reprs-set
1046                 (stretchable-vector-ref loc-descrs j)
1047                 have)))))
1048
1049       (targ-emit
1050         (targ-loc loc (targ-opnd opnd))))
1051
1052     (targ-emit
1053       (targ-loc loc (targ-opnd opnd)))))
1054
1055 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1056
1057 (define (targ-gen-close parms sn)
1058
1059   (define (close parms* sn*)
1060     (if (pair? parms*)
1061
1062       (let* ((parm (car parms*))
1063              (lbl (closure-parms-lbl parm))
1064              (loc (closure-parms-loc parm))
1065              (opnds (closure-parms-opnds parm))
1066              (sn** (targ-sn-opnds opnds sn*)))
1067         (close (cdr parms*) (targ-sn-loc loc sn**))
1068         (let* ((x (targ-opnd loc))
1069                (elements (map targ-opnd opnds))
1070                (n (length elements)))
1071           (targ-emit
1072             (list "BEGIN_SETUP_CLO" n x (targ-ref-lbl-val lbl)))
1073           (for-each-index (lambda (elem i)
1074                             (targ-emit
1075                               (list "ADD_CLO_ELEM" i elem)))
1076                           elements)
1077           (targ-emit
1078             (list "END_SETUP_CLO" n))))
1079
1080       (begin
1081
1082         (targ-heap-reserve-and-check
1083           (apply +
1084                  (map (lambda (parm)
1085                         (targ-closure-space
1086                           (length (closure-parms-opnds parm))))
1087                       parms))
1088           sn*)
1089
1090         (for-each (lambda (parm)
1091                     (let ((loc (closure-parms-loc parm))
1092                           (opnds (closure-parms-opnds parm)))
1093                       (targ-emit
1094                         (targ-loc loc (list "ALLOC_CLO" (length opnds))))))
1095                   parms))))
1096
1097   (close (reverse parms) sn)
1098
1099   (targ-heap-reserve-and-check 0 sn))
1100
1101 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1102
1103 (define (targ-gen-ifjump test opnds true-lbl false-lbl poll? next-lbl)
1104   (let ((x (proc-obj-test test)))
1105     (if x
1106
1107       (let ((args-flo? (vector-ref x 0))
1108             (proc (vector-ref x 1)))
1109
1110         (define (gen-if not? branch-lbl fall-lbl)
1111           (let ((fs (frame-size targ-proc-exit-frame)))
1112             (if (or (not args-flo?)
1113                     (begin
1114                       (targ-update-fr targ-proc-exit-frame)
1115                       (targ-end-of-block-checks-needed? poll?)))
1116               (let ((sn (targ-sn-opnds opnds fs)))
1117                 (targ-update-fr targ-proc-entry-frame)
1118                 (targ-end-of-block-checks poll? sn)))
1119             (targ-emit
1120               (targ-adjust-stack fs))
1121             (targ-emit
1122               (list "IF" (proc not? opnds fs)))
1123 ;;            (targ-repr-exit-block! branch-lbl)
1124             (targ-emit
1125               (list "GOTO" (targ-ref-lbl-goto branch-lbl)))
1126             (targ-emit
1127               '("END_IF"))
1128 ;;            (targ-repr-exit-block! fall-lbl)
1129             (if (not (eqv? fall-lbl next-lbl))
1130               (targ-emit
1131                 (list "GOTO" (targ-ref-lbl-goto fall-lbl))))
1132 ;;            (targ-repr-end-block!)
1133 ))
1134
1135         (if (eqv? true-lbl next-lbl)
1136           (gen-if #t false-lbl true-lbl)
1137           (gen-if #f true-lbl false-lbl)))
1138
1139       (compiler-internal-error
1140         "targ-gen-ifjump, unknown 'test'" test))))
1141
1142 (define (targ-end-of-block-checks-needed? poll?)
1143   (or poll?
1144       (> targ-proc-hp 0)))
1145
1146 (define (targ-end-of-block-checks poll? sn)
1147   (if (> targ-proc-hp 0)
1148     (targ-check-heap 0 sn))
1149   (if poll?
1150     (targ-poll sn)))
1151
1152 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1153
1154 (define (targ-gen-switch opnd cases default poll? next-lbl)
1155
1156   (targ-update-fr targ-proc-entry-frame)
1157
1158   (let* ((fs (frame-size targ-proc-exit-frame))
1159          (sn (targ-sn-opnd opnd fs)))
1160
1161     (targ-end-of-block-checks poll? sn)
1162
1163     (targ-emit
1164      (targ-adjust-stack fs))
1165
1166     (let loop ((lst cases)
1167                (rev-cases-fixnum32 '())
1168                (rev-cases-char '())
1169                (rev-cases-symbol '())
1170                (rev-cases-keyword '())
1171                (rev-cases-other '()))
1172       (if (pair? lst)
1173
1174         (let* ((c (car lst))
1175                (obj (switch-case-obj c)))
1176           (cond ((targ-fixnum32? obj)
1177                  (loop (cdr lst)
1178                        (cons c rev-cases-fixnum32)
1179                        rev-cases-char
1180                        rev-cases-symbol
1181                        rev-cases-keyword
1182                        rev-cases-other))
1183                 ((char? obj)
1184                  (loop (cdr lst)
1185                        rev-cases-fixnum32
1186                        (cons c rev-cases-char)
1187                        rev-cases-symbol
1188                        rev-cases-keyword
1189                        rev-cases-other))
1190                 ((symbol-object? obj)
1191                  (loop (cdr lst)
1192                        rev-cases-fixnum32
1193                        rev-cases-char
1194                        (cons c rev-cases-symbol)
1195                        rev-cases-keyword
1196                        rev-cases-other))
1197                 ((keyword-object? obj)
1198                  (loop (cdr lst)
1199                        rev-cases-fixnum32
1200                        rev-cases-char
1201                        rev-cases-symbol
1202                        (cons c rev-cases-keyword)
1203                        rev-cases-other))
1204                 (else
1205                  (loop (cdr lst)
1206                        rev-cases-fixnum32
1207                        rev-cases-char
1208                        rev-cases-symbol
1209                        rev-cases-keyword
1210                        (cons c rev-cases-other)))))
1211
1212         (let* ((cases-fixnum32 (reverse rev-cases-fixnum32))
1213                (cases-char (reverse rev-cases-char))
1214                (cases-symbol (reverse rev-cases-symbol))
1215                (cases-keyword (reverse rev-cases-keyword))
1216                (cases-other (reverse rev-cases-other))
1217                (cases-symkey (append cases-symbol cases-keyword)))
1218
1219           (define (gen cases begin-macro case-macro end-macro)
1220             (if (not (null? cases))
1221               (begin
1222                 (targ-emit (list begin-macro (targ-opnd opnd)))
1223                 (for-each
1224                  (lambda (c)
1225                    (targ-emit
1226                     (list case-macro
1227                           (targ-use-obj (switch-case-obj c))
1228                           (targ-ref-lbl-goto (switch-case-lbl c)))))
1229                  cases)
1230                 (targ-emit (list end-macro)))))
1231
1232           (if (<= (length cases-fixnum32) 2)
1233             (begin
1234               (set! cases-other (append cases-fixnum32 cases-other))
1235               (set! cases-fixnum32 '())))
1236
1237           (if (<= (length cases-char) 2)
1238             (begin
1239               (set! cases-other (append cases-char cases-other))
1240               (set! cases-char '())))
1241
1242           (gen cases-other
1243                "BEGIN_SWITCH"
1244                "SWITCH_CASE_GOTO"
1245                "END_SWITCH")
1246
1247           (gen cases-fixnum32
1248                "BEGIN_SWITCH_FIXNUM"
1249                "SWITCH_FIXNUM_CASE_GOTO"
1250                "END_SWITCH_FIXNUM")
1251
1252           (gen cases-char
1253                "BEGIN_SWITCH_CHAR"
1254                "SWITCH_CHAR_CASE_GOTO"
1255                "END_SWITCH_CHAR")
1256
1257           (let ((n (length cases-symkey)))
1258             (cond ((= n 0))
1259                   ((<= n symkey-switch-as-if-cascade-limit)
1260                    (let loop ((cases cases-symkey))
1261                      (if (pair? cases)
1262                        (let ((c (car cases)))
1263                          (targ-emit
1264                           (list "IF_GOTO"
1265                                 (list "EQP"
1266                                       (targ-opnd opnd)
1267                                       (targ-use-obj (switch-case-obj c)))
1268                                 (targ-ref-lbl-goto (switch-case-lbl c))))
1269                          (loop (cdr cases))))))
1270                   (else
1271                    (let* ((mod (let loop ((i 1))
1272                                  (if (> i n)
1273                                    i
1274                                    (loop (* i 2)))))
1275                           (buckets (make-vector mod '())))
1276
1277                      (for-each
1278                       (lambda (c)
1279                         (let* ((obj (switch-case-obj c))
1280                                (hash (targ-hash
1281                                       (if (symbol-object? obj)
1282                                         (symbol->string obj)
1283                                         (keyword-object->string obj))))
1284                                (i (modulo hash mod)))
1285                           (vector-set! buckets
1286                                        i
1287                                        (cons c (vector-ref buckets i)))))
1288                       cases-symkey)
1289
1290                      (targ-emit
1291                       (list "BEGIN_SWITCH_SYMKEY"
1292                             (targ-opnd opnd)
1293                             mod
1294                             (list
1295                              (cond ((null? cases-keyword)
1296                                     "SYMBOLP")
1297                                    ((null? cases-symbol)
1298                                     "KEYWORDP")
1299                                    (else
1300                                     "SYMKEYP")))))
1301
1302                      (let loop ((i 0))
1303                        (if (< i mod)
1304                          (begin
1305                            (targ-emit (list "SWITCH_SYMKEY_CASE" i))
1306                            (for-each
1307                             (lambda (c)
1308                               (targ-emit
1309                                (list "SWITCH_SYMKEY_CASE_GOTO"
1310                                      (targ-use-obj (switch-case-obj c))
1311                                      (targ-ref-lbl-goto (switch-case-lbl c)))))
1312                             (reverse (vector-ref buckets i)))
1313                            (targ-emit (list "GOTO" (targ-ref-lbl-goto default)))
1314                            (loop (+ i 1)))))
1315
1316                      (targ-emit (list "END_SWITCH_SYMKEY")))))))))
1317
1318     (if (not (eqv? default next-lbl))
1319       (targ-emit
1320        (list "GOTO" (targ-ref-lbl-goto default))))))
1321
1322 (define symkey-switch-as-if-cascade-limit #f)
1323 (set! symkey-switch-as-if-cascade-limit 20)
1324
1325 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1326
1327 (define (targ-gen-jump opnd nb-args poll? safe? next-lbl)
1328
1329   (targ-update-fr targ-proc-entry-frame)
1330
1331   (let ((inlined
1332          (and (obj? opnd)
1333               (proc-obj? (obj-val opnd))
1334               nb-args
1335               (let* ((proc (obj-val opnd))
1336                      (jump-inliner (proc-obj-jump-inline proc)))
1337                 (and jump-inliner
1338                      (jump-inliner nb-args poll? safe?))))))
1339     (if (not inlined)
1340       (let* ((fs (frame-size targ-proc-exit-frame))
1341              (sn (targ-sn-opnd opnd fs))
1342              (set-nargs (if nb-args (list "SET_NARGS" nb-args) #f)))
1343
1344         (targ-end-of-block-checks poll? sn)
1345
1346         (targ-emit
1347          (targ-adjust-stack fs))
1348
1349         (cond ((lbl? opnd)
1350                (let ((n (lbl-num opnd)))
1351 ;;                 (targ-repr-exit-block! (if nb-args #f n))
1352                  (if (and next-lbl (= next-lbl n)) ; fall through?
1353                    (targ-emit set-nargs)
1354                    (targ-emit
1355                      (list 'seq
1356                            set-nargs
1357                            (list "GOTO" (targ-ref-lbl-goto n)))))))
1358               ((and (obj? opnd)
1359                     (proc-obj? (obj-val opnd))
1360                     nb-args)
1361                (let* ((proc (obj-val opnd))
1362                       (x (targ-use-prc proc #f)))
1363 ;;                 (targ-repr-exit-block! #f)
1364                  (if (eq? (car x) 'prm)
1365                    (targ-emit
1366                      (list "JUMPPRM"
1367                            set-nargs
1368                            x))
1369                    (let ((name (proc-obj-name proc)))
1370                      (if (targ-arg-check-avoidable? proc nb-args)
1371                        (targ-emit
1372                          (list "JUMPINT"
1373                                set-nargs
1374                                x
1375                                (targ-make-glbl "" name)))
1376                        (targ-emit
1377                          (list 'seq
1378                                set-nargs
1379                                (list "JUMPINT"
1380                                      '("NOTHING")
1381                                      x
1382                                      (targ-make-glbl 0 name)))))))))
1383               ((glo? opnd)
1384 ;;               (targ-repr-exit-block! #f)
1385                (targ-emit
1386                  (cons (begin
1387                          (targ-wr-reg (+ targ-nb-arg-regs 1))
1388                          (if safe? "JUMPGLOSAFE" "JUMPGLONOTSAFE"))
1389                        (cons (if nb-args set-nargs '("NOTHING"))
1390                              (cdr (targ-opnd opnd))))))
1391               (else
1392 ;;               (targ-repr-exit-block! #f)
1393                (targ-emit
1394                  (list (if nb-args
1395                          (begin
1396                            (targ-wr-reg (+ targ-nb-arg-regs 1))
1397                            (if safe? "JUMPGENSAFE" "JUMPGENNOTSAFE"))
1398                          "JUMPPRM")
1399                        (if nb-args set-nargs '("NOTHING"))
1400                        (targ-opnd opnd)))))
1401
1402 ;;        (targ-repr-end-block!)
1403 ))))
1404
1405 (define (targ-arg-check-avoidable? proc nb-args)
1406   (let ((x (proc-obj-call-pat proc)))
1407     (if (and (pair? x) (null? (cdr x))) ; proc accepts a fixed nb of args?
1408       (let ((arg-count (car x)))
1409         (= arg-count nb-args))          ; nb of arguments = nb of parameters?
1410       #f)))
1411
1412 ;;;----------------------------------------------------------------------------
1413
1414 '(;;
1415
1416 (define targ-repr-enabled? #f)
1417 (set! targ-repr-enabled? #t)
1418
1419 (define targ-repr-graph #f)
1420 (define targ-repr-current-block #f)
1421
1422 ;; Location representation descriptors.
1423
1424 (define targ-repr-boxed 0) ; must be 0
1425 (define targ-repr-f64   1)
1426
1427 (define targ-repr-nb-reprs 2) ; # of possible representations (including boxed)
1428 (define targ-repr-universal 3) ; (- (expt 2 targ-repr-nb-repr) 1)
1429
1430 (define targ-repr-types ; type name of each unboxed representation
1431   '#("F64"))
1432
1433 (define targ-repr-have-pos  0) ; bit position of "have" field (must be 0)
1434 (define targ-repr-need-pos  2) ; bit position of "need" field
1435 (define targ-repr-entry-pos 4) ; bit position of "entry" field
1436
1437 (define targ-repr-live1-mask  64) ; live at entry of block
1438 (define targ-repr-live2-mask 128) ; live at exit of block
1439 (define targ-repr-all-mask   255) ; (- (* 2 targ-repr-live2-mask) 1)
1440 (define targ-repr-have-mask  252) ; (- targ-repr-all-mask targ-repr-universal)
1441 (define targ-repr-entry-mask 207) ; (- targ-repr-all-mask
1442                                   ;    (* (expt 2 targ-repr-entry-pos)
1443                                   ;       targ-repr-universal))
1444
1445 (define (targ-repr-have-reprs descr)
1446   (bits-and descr targ-repr-universal))
1447
1448 (define (targ-repr-have-reprs-union descr reprs)
1449   (bits-or descr reprs))
1450
1451 (define (targ-repr-have-reprs-set descr reprs)
1452   (bits-or (bits-and descr targ-repr-have-mask) reprs))
1453
1454 (define (targ-repr-need-reprs descr)
1455   (bits-and (bits-shr descr targ-repr-need-pos) targ-repr-universal))
1456
1457 (define (targ-repr-need-reprs-union descr reprs)
1458   (bits-or descr (bits-shl reprs targ-repr-need-pos)))
1459
1460 (define (targ-repr-entry-reprs descr)
1461   (bits-and (bits-shr descr targ-repr-entry-pos) targ-repr-universal))
1462
1463 (define (targ-repr-entry-reprs-set descr reprs)
1464   (bits-or (bits-and descr targ-repr-entry-mask)
1465            (bits-shl reprs targ-repr-entry-pos)))
1466
1467 (define (targ-repr-live1-add descr)
1468   (bits-or descr targ-repr-live1-mask))
1469
1470 (define (targ-repr-live1? descr)
1471   (not (= (bits-and descr targ-repr-live1-mask) 0)))
1472
1473 (define (targ-repr-live2-add descr)
1474   (bits-or descr targ-repr-live2-mask))
1475
1476 (define (targ-repr-live2? descr)
1477   (not (= (bits-and descr targ-repr-live2-mask) 0)))
1478
1479 (define (targ-repr-equal-descr? descr1 descr2)
1480   (= descr1 descr2))
1481
1482 (define (targ-repr-included-reprs? reprs1 reprs2)
1483   (= (bits-and reprs1 reprs2) reprs1))
1484
1485 (define (targ-repr-empty)
1486   0)
1487
1488 (define (targ-repr-empty? reprs)
1489   (= reprs (targ-repr-empty)))
1490
1491 (define (targ-repr-member? repr reprs)
1492   (not (= (bits-and reprs (bits-shl 1 repr)) 0)))
1493
1494 (define (targ-repr-singleton repr)
1495   (bits-shl 1 repr))
1496
1497 (define (targ-repr-intersection reprs1 reprs2)
1498   (bits-and reprs1 reprs2))
1499
1500 (define (targ-make-block kind lbl entry-cell)
1501   (vector kind
1502           lbl
1503           entry-cell
1504           '()
1505           #f
1506           #f
1507           (make-stretchable-vector (targ-repr-empty))))
1508
1509 (define (targ-block-kind block)        (vector-ref block 0))
1510 (define (targ-block-lbl block)         (vector-ref block 1))
1511 (define (targ-block-entry-cell block)  (vector-ref block 2))
1512 (define (targ-block-exits block)       (vector-ref block 3))
1513 (define (targ-block-entry-fs block)    (vector-ref block 4))
1514 (define (targ-block-exit-fs block)     (vector-ref block 5))
1515 (define (targ-block-loc-descrs block)  (vector-ref block 6))
1516
1517 (define (targ-block-add-exit! block lbl cell)
1518   (vector-set! block 3
1519     (cons (cons lbl cell) (vector-ref block 3))))
1520
1521 (define (targ-block-entry-fs-set! block fs)
1522   (vector-set! block 4 fs))
1523
1524 (define (targ-block-exit-fs-set! block fs)
1525   (vector-set! block 5 fs))
1526
1527 (define (targ-repr-begin-proc!)
1528   (if targ-repr-enabled?
1529     (set! targ-repr-graph (make-stretchable-vector #f))))
1530
1531 (define (targ-repr-end-proc!)
1532
1533   (define (compute-reprs-function src)
1534     (let ((exits (targ-block-exits src)))
1535       (if (not (null? (cdr exits)))
1536         (compute-reprs-function-2-known-exits src (caar exits) (caadr exits))
1537         (if (caar exits)
1538           (compute-reprs-function-1-known-exit src (caar exits))
1539           (compute-reprs-function-1-unknown-exit src)))))
1540
1541   (define (compute-reprs-function-1-unknown-exit src)
1542     (lambda (src-descr i)
1543       (targ-repr-singleton targ-repr-boxed)))
1544
1545   (define (compute-reprs-function-1-known-exit src dst)
1546     (let* ((dst-loc-descrs (targ-block-loc-descrs dst))
1547            (src-fs (targ-block-exit-fs src))
1548            (dst-fs (targ-block-entry-fs dst))
1549            (offs (- src-fs dst-fs)))
1550       (lambda (src-descr i)
1551         (let* ((src-have
1552                 (targ-repr-have-reprs src-descr))
1553                (src-reprs
1554                 (if (targ-repr-empty? src-have)
1555                   (targ-repr-need-reprs src-descr)
1556                   src-have)))
1557           (if (< i targ-nb-gvm-regs)
1558             (let ((dst-descr
1559                     (stretchable-vector-ref dst-loc-descrs i)))
1560               (stretchable-vector-set!
1561                 dst-loc-descrs
1562                 i
1563                 (targ-repr-entry-reprs-set
1564                   dst-descr
1565                   (targ-repr-intersection
1566                     (targ-repr-entry-reprs dst-descr)
1567                     src-reprs)))
1568               (targ-repr-need-reprs dst-descr))
1569             (let* ((j
1570                     (- i offs))
1571                    (dst-descr
1572                      (if (>= j targ-nb-gvm-regs)
1573                        (stretchable-vector-ref dst-loc-descrs j)
1574                        0)))
1575               (if (>= j targ-nb-gvm-regs)
1576                 (stretchable-vector-set!
1577                   dst-loc-descrs
1578                   j
1579                   (targ-repr-entry-reprs-set
1580                     dst-descr
1581                     (targ-repr-intersection
1582                       (targ-repr-entry-reprs dst-descr)
1583                       src-reprs))))
1584               (targ-repr-need-reprs dst-descr)))))))
1585
1586   (define (compute-reprs-function-2-known-exits src dst1 dst2)
1587     (let* ((dst1-loc-descrs (targ-block-loc-descrs dst1))
1588            (dst2-loc-descrs (targ-block-loc-descrs dst2))
1589            (src-fs (targ-block-exit-fs src))
1590            (dst1-fs (targ-block-entry-fs dst1))
1591            (dst2-fs (targ-block-entry-fs dst2))
1592            (offs1 (- src-fs dst1-fs))
1593            (offs2 (- src-fs dst2-fs)))
1594       (lambda (src-descr i)
1595         (let* ((src-have
1596                 (targ-repr-have-reprs src-descr))
1597                (src-reprs
1598                 (if (targ-repr-empty? src-have)
1599                   (targ-repr-need-reprs src-descr)
1600                   src-have)))
1601           (if (< i targ-nb-gvm-regs)
1602             (let ((dst1-descr
1603                     (stretchable-vector-ref dst1-loc-descrs i))
1604                   (dst2-descr
1605                     (stretchable-vector-ref dst2-loc-descrs i)))
1606               (stretchable-vector-set!
1607                 dst1-loc-descrs
1608                 i
1609                 (targ-repr-entry-reprs-set
1610                   dst1-descr
1611                   (targ-repr-intersection
1612                     (targ-repr-entry-reprs dst1-descr)
1613                     src-reprs)))
1614               (stretchable-vector-set!
1615                 dst2-loc-descrs
1616                 i
1617                 (targ-repr-entry-reprs-set
1618                   dst2-descr
1619                   (targ-repr-intersection
1620                     (targ-repr-entry-reprs dst2-descr)
1621                     src-reprs)))
1622               (targ-repr-intersection
1623                 (targ-repr-need-reprs dst1-descr)
1624                 (targ-repr-need-reprs dst2-descr)))
1625             (let* ((j1
1626                     (- i offs1))
1627                    (j2
1628                     (- i offs2))
1629                    (dst1-descr
1630                      (if (>= j1 targ-nb-gvm-regs)
1631                        (stretchable-vector-ref dst1-loc-descrs j1)
1632                        0))
1633                    (dst2-descr
1634                      (if (>= j2 targ-nb-gvm-regs)
1635                        (stretchable-vector-ref dst2-loc-descrs j2)
1636                        0)))
1637               (if (>= j1 targ-nb-gvm-regs)
1638                 (stretchable-vector-set!
1639                   dst1-loc-descrs
1640                   j1
1641                   (targ-repr-entry-reprs-set
1642                     dst1-descr
1643                     (targ-repr-intersection
1644                       (targ-repr-entry-reprs dst1-descr)
1645                       src-reprs))))
1646               (if (>= j2 targ-nb-gvm-regs)
1647                 (stretchable-vector-set!
1648                   dst2-loc-descrs
1649                   j2
1650                   (targ-repr-entry-reprs-set
1651                     dst2-descr
1652                     (targ-repr-intersection
1653                       (targ-repr-entry-reprs dst2-descr)
1654                       src-reprs))))
1655               (targ-repr-intersection
1656                 (targ-repr-need-reprs dst1-descr)
1657                 (targ-repr-need-reprs dst2-descr))))))))
1658
1659   (define (insert-exit-conversions src dst cell)
1660     (if dst
1661       (insert-known-exit-conversions src dst cell)
1662       (insert-unknown-exit-conversions src cell)))
1663
1664   (define (insert-unknown-exit-conversions src cell)
1665     (let ((lst '())
1666           (src-loc-descrs (targ-block-loc-descrs src))
1667           (src-fs (targ-block-exit-fs src)))
1668
1669       (define (conversion i j need-j)
1670         (let* ((descr-i
1671                 (stretchable-vector-ref src-loc-descrs i))
1672                (have-i
1673                 (targ-repr-have-reprs descr-i))
1674                (need-i
1675                 (targ-repr-need-reprs descr-i))
1676                (reprs-i
1677                 (if (targ-repr-empty? have-i)
1678                   (if (targ-repr-empty? need-i)
1679                     (targ-repr-singleton targ-repr-boxed)
1680                     need-i)
1681                   have-i))
1682                (reprs-j
1683                 (if (targ-repr-empty? need-j)
1684                   (targ-repr-singleton targ-repr-boxed)
1685                   need-j)))
1686
1687           (set! targ-proc-fp src-fs)
1688
1689           (let loop1 ((r (+ targ-repr-boxed 1)))
1690             (if (< r targ-repr-nb-reprs)
1691               (begin
1692                 (if (targ-repr-member? r reprs-j) ; needed in this repr?
1693                   (if (targ-repr-member? r reprs-i) ; already in this repr?
1694                     (if (not (= i j)) ; copying necessary?
1695                       (set! lst
1696                         (cons (targ-repr-unboxed-index-copy i j r)
1697                               lst)))
1698                     (set! lst
1699                       (cons (targ-repr-unboxed-copy
1700                               (targ-repr-from-boxed
1701                                 (targ-repr-opnd-boxed (targ-repr-index->loc i))
1702                                 r)
1703                               (targ-repr-unboxed-index->code j r)
1704                               r)
1705                             lst))))
1706                 (loop1 (+ r 1)))))
1707
1708           (if (not (or (targ-repr-included-reprs? reprs-j reprs-i)
1709                        (targ-repr-member? targ-repr-boxed reprs-i)))
1710             (let loop2 ((r (+ targ-repr-boxed 1)))
1711               (if (not (targ-repr-member? r reprs-i))
1712                 (loop2 (+ r 1))
1713                 (set! lst
1714                   (cons (targ-repr-to-boxed! (targ-repr-index->loc i) r)
1715                         lst)))))))
1716
1717       (let loop ((i (- (+ targ-nb-gvm-regs src-fs) 1)))
1718         (if (>= i 0)
1719           (let ((descr-i (stretchable-vector-ref src-loc-descrs i)))
1720             (if (targ-repr-live2? descr-i)
1721               (conversion i i (targ-repr-empty)))
1722             (loop (- i 1)))))
1723       (targ-cell-set!
1724         cell
1725         (list 'append
1726               "/* exit representation: "
1727               (targ-repr-to-string
1728                src-loc-descrs
1729                targ-repr-have-reprs
1730                targ-repr-live2?)
1731               " */"
1732               #\newline
1733               (cons 'seq lst)
1734               #\newline))))
1735
1736   (define (insert-known-exit-conversions src dst cell)
1737     (let* ((lst '())
1738            (src-loc-descrs (targ-block-loc-descrs src))
1739            (dst-loc-descrs (targ-block-loc-descrs dst))
1740            (src-fs (targ-block-exit-fs src))
1741            (dst-fs (targ-block-entry-fs dst))
1742            (offs (- src-fs dst-fs)))
1743
1744       (define (conversion i j need-j)
1745         (let* ((descr-i
1746                 (stretchable-vector-ref src-loc-descrs i))
1747                (have-i
1748                 (targ-repr-have-reprs descr-i))
1749                (need-i
1750                 (targ-repr-need-reprs descr-i))
1751                (reprs-i
1752                 (if (targ-repr-empty? have-i)
1753                   (if (targ-repr-empty? need-i)
1754                     (targ-repr-singleton targ-repr-boxed)
1755                     need-i)
1756                   have-i))
1757                (reprs-j
1758                 (if (targ-repr-empty? need-j)
1759                   (targ-repr-singleton targ-repr-boxed)
1760                   need-j)))
1761
1762           (set! targ-proc-fp src-fs)
1763
1764           (let loop1 ((r (+ targ-repr-boxed 1)))
1765             (if (< r targ-repr-nb-reprs)
1766               (begin
1767                 (if (targ-repr-member? r reprs-j) ; needed in this repr?
1768                   (if (targ-repr-member? r reprs-i) ; already in this repr?
1769                     (if (not (= i j)) ; copying necessary?
1770                       (set! lst
1771                         (cons (targ-repr-unboxed-index-copy i j r)
1772                               lst)))
1773                     (set! lst
1774                       (cons (targ-repr-unboxed-copy
1775                               (targ-repr-from-boxed
1776                                 (targ-repr-opnd-boxed (targ-repr-index->loc i))
1777                                 r)
1778                               (targ-repr-unboxed-index->code j r)
1779                               r)
1780                             lst))))
1781                 (loop1 (+ r 1)))))
1782
1783           (if (not (or (targ-repr-included-reprs? reprs-j reprs-i)
1784                        (targ-repr-member? targ-repr-boxed reprs-i)))
1785             (let loop2 ((r (+ targ-repr-boxed 1)))
1786               (if (not (targ-repr-member? r reprs-i))
1787                 (loop2 (+ r 1))
1788                 (set! lst
1789                   (cons (targ-repr-to-boxed! (targ-repr-index->loc i) r)
1790                         lst)))))))
1791
1792       (let loop ((i (- (+ targ-nb-gvm-regs src-fs) 1)))
1793         (if (>= i 0)
1794           (let ((j (if (< i targ-nb-gvm-regs) i (- i offs))))
1795             (if (and (>= i targ-nb-gvm-regs)
1796                      (< j targ-nb-gvm-regs))
1797               (conversion i i (targ-repr-empty))
1798               (let ((descr-j (stretchable-vector-ref dst-loc-descrs j)))
1799                 (if (targ-repr-live1? descr-j)
1800                   (conversion i j (targ-repr-need-reprs descr-j)))))
1801             (loop (- i 1)))))
1802       (targ-cell-set!
1803         cell
1804         (list 'append
1805               "/* exit representation: "
1806               (targ-repr-to-string
1807                src-loc-descrs
1808                targ-repr-have-reprs
1809                targ-repr-live2?)
1810               " */"
1811               #\newline
1812               (cons 'seq lst)
1813               #\newline))))
1814
1815   ; preprocess graph to access it faster
1816
1817   (stretchable-vector-for-each
1818     (lambda (block lbl)
1819       (if block
1820         (for-each ; collapse each label reference to a block
1821           (lambda (x)
1822             (if (car x) ; #f indicates an unknown exit block
1823               (set-car! x
1824                         (stretchable-vector-ref
1825                           targ-repr-graph
1826                           (car x)))))
1827           (targ-block-exits block))))
1828     targ-repr-graph)
1829
1830   (let loop1 ()
1831     (let ((changed? #f))
1832
1833       (define (intersect-reprs src)
1834         (let ((loc-descrs (targ-block-loc-descrs src)))
1835           (stretchable-vector-for-each
1836             (lambda (descr i)
1837               (if (targ-repr-live1? descr)
1838                 (let ((new
1839                        (targ-repr-need-reprs-union
1840                          descr
1841                          (targ-repr-entry-reprs descr))))
1842                   (stretchable-vector-set!
1843                     loc-descrs
1844                     i
1845                     (if (memq (targ-block-kind src)
1846                               '(entry return task-entry task-return))
1847                       new
1848                       (targ-repr-entry-reprs-set new targ-repr-universal))))))
1849             loc-descrs)))
1850
1851       (define (propagate-repr src)
1852         (let ((compute-reprs (compute-reprs-function src))
1853               (loc-descrs (targ-block-loc-descrs src)))
1854           (stretchable-vector-for-each
1855             (lambda (descr i)
1856               (if (targ-repr-live2? descr)
1857                 (let ((new
1858                        (targ-repr-need-reprs-union
1859                          descr
1860                          (compute-reprs descr i))))
1861                   (if (and (targ-repr-empty? (targ-repr-have-reprs descr))
1862                            (not (targ-repr-equal-descr? new descr)))
1863                     (begin
1864                       (set! changed? #t)
1865                       (stretchable-vector-set! loc-descrs i new))))))
1866             loc-descrs)))
1867
1868       (let loop2 ((lbl (- (stretchable-vector-length targ-repr-graph) 1)))
1869         (if (>= lbl 0)
1870           (let ((block (stretchable-vector-ref targ-repr-graph lbl)))
1871             (if block
1872               (intersect-reprs block))
1873             (loop2 (- lbl 1)))))
1874
1875       (let loop3 ((lbl (- (stretchable-vector-length targ-repr-graph) 1)))
1876         (if (>= lbl 0)
1877           (let ((block (stretchable-vector-ref targ-repr-graph lbl)))
1878             (if block
1879               (propagate-repr block))
1880             (loop3 (- lbl 1)))))
1881
1882       (if changed?
1883         (loop1))))
1884
1885   (let loop4 ((lbl (- (stretchable-vector-length targ-repr-graph) 1)))
1886     (if (>= lbl 0)
1887       (let ((block (stretchable-vector-ref targ-repr-graph lbl)))
1888         (if block
1889           (for-each
1890             (lambda (x)
1891               (insert-exit-conversions block (car x) (cdr x)))
1892             (targ-block-exits block)))
1893         (loop4 (- lbl 1)))))
1894
1895   (let loop5 ((lbl (- (stretchable-vector-length targ-repr-graph) 1)))
1896     (if (>= lbl 0)
1897       (let ((block (stretchable-vector-ref targ-repr-graph lbl)))
1898         (if block
1899           (let ((cell (targ-block-entry-cell block)))
1900             (cond ((memq (targ-block-kind block)
1901                          '(entry return task-entry task-return))
1902                    (targ-cell-set!
1903                      cell
1904                      (list 'append
1905                            "/* entry representation: "
1906                            (targ-repr-to-string
1907                              (targ-block-loc-descrs block)
1908                              targ-repr-need-reprs
1909                              targ-repr-live1?)
1910                            " */"
1911                            #\newline
1912                            (begin
1913                              (set! targ-proc-fp (targ-block-entry-fs block))
1914                              (cons 'seq
1915                                    (targ-repr-setup-need
1916                                     (targ-block-loc-descrs block))))
1917                            #\newline)))
1918                   ((memq (targ-block-kind block)
1919                          '(return-internal))
1920                    (targ-cell-set!
1921                      cell
1922                      (list 'append
1923                            "/* entry representation: "
1924                            (targ-repr-to-string
1925                              (targ-block-loc-descrs block)
1926                              targ-repr-need-reprs
1927                              targ-repr-live1?)
1928                            " */"
1929                            #\newline
1930 ;;                           (targ-repr-internal-need block)
1931                            #\newline)))
1932                   (else
1933                    (targ-cell-set!
1934                      cell
1935                      (list 'append
1936                            "/* entry representation: "
1937                            (targ-repr-to-string
1938                              (targ-block-loc-descrs block)
1939                              targ-repr-need-reprs
1940                              targ-repr-live1?)
1941                            " */"
1942                            #\newline))))))
1943         (loop5 (- lbl 1)))))
1944
1945 ;;  (targ-emit (list 'append (with-output-to-string (lambda () (pp targ-repr-graph)))))
1946
1947   (if targ-repr-enabled?
1948     (set! targ-repr-graph #f))
1949
1950   #f)
1951
1952
1953 (define (targ-repr-unboxed-copy src dst repr)
1954   (let ((type (vector-ref targ-repr-types (- repr 1))))
1955     (list (string-append "SET_" type) dst src)))
1956
1957 (define (targ-repr-unboxed-index-copy src dst repr)
1958   (targ-repr-unboxed-copy
1959     (targ-repr-unboxed-index->code src repr)
1960     (targ-repr-unboxed-index->code dst repr)
1961     repr))
1962
1963 (define (targ-repr-setup-need loc-descrs)
1964   (let ((lst '()))
1965     (stretchable-vector-for-each
1966       (lambda (descr i)
1967         (if (targ-repr-live1? descr)
1968           (let ((need (targ-repr-need-reprs descr)))
1969             (let ((loc (targ-repr-index->loc i)))
1970               (let loop ((r (+ targ-repr-boxed 1)))
1971                 (if (< r targ-repr-nb-reprs)
1972                   (begin
1973                     (if (targ-repr-member? r need)
1974                       (set! lst
1975                         (cons (targ-repr-from-boxed! loc r) lst)))
1976                     (loop (+ r 1)))))))))
1977       loc-descrs)
1978     lst))
1979
1980 (define (targ-repr-internal-need block)
1981   (set! targ-proc-fp (targ-block-entry-fs block))
1982   (let ((lst '())
1983         (loc-descrs (targ-block-loc-descrs block)))
1984     (set! lst (cons #\newline (cons "END" (cons #\newline lst))))
1985     (stretchable-vector-for-each
1986       (lambda (descr i)
1987         (if (targ-repr-live1? descr)
1988           (let ((need (targ-repr-need-reprs descr)))
1989             (let ((loc (targ-repr-index->loc i)))
1990               (let loop ((r (+ targ-repr-boxed 1)))
1991                 (if (< r targ-repr-nb-reprs)
1992                   (begin
1993                     (if (targ-repr-member? r need)
1994                       (set! lst
1995                         (cons (targ-repr-from-boxed! loc r) lst)))
1996                     (loop (+ r 1)))))))))
1997       loc-descrs)
1998     (set! lst (cons #\newline (cons "TRAP" (cons #\newline lst))))
1999     (stretchable-vector-for-each
2000       (lambda (descr i)
2001         (if (targ-repr-live1? descr)
2002           (let ((need (targ-repr-need-reprs descr)))
2003             (if (not (targ-repr-member? targ-repr-boxed need))
2004               (let loop2 ((r (+ targ-repr-boxed 1)))
2005                 (if (not (targ-repr-member? r need))
2006                   (loop2 (+ r 1))
2007                   (set! lst
2008                     (cons (targ-repr-to-boxed! (targ-repr-index->loc i) r)
2009                           lst))))))))
2010       loc-descrs)
2011     (set! lst (cons #\newline (cons "BEGIN" (cons #\newline lst))))
2012     (cons 'seq lst)))
2013
2014 ;************
2015 (define (targ-repr-to-string loc-descrs reprs-extract live?)
2016   (let ((str ""))
2017     (stretchable-vector-for-each
2018       (lambda (descr i)
2019         (if (live? descr)
2020           (let ((loc (targ-repr-index->loc i))
2021                 (reprs (reprs-extract descr)))
2022             (set! str
2023               (string-append
2024                 str
2025                 "  "
2026                 (loc->str loc)
2027                 "="
2028                 (reprs->str reprs))))))
2029       loc-descrs)
2030     str))
2031
2032 (define (loc->str loc)
2033   (if (reg? loc)
2034     (string-append "R" (number->string (reg-num loc)))
2035     (string-append "STK" (number->string (stk-num loc)))))
2036
2037 (define (reprs->str reprs)
2038   (let ((str "{"))
2039     (let loop ((r targ-repr-boxed) (sep ""))
2040       (if (< r targ-repr-nb-reprs)
2041         (if (targ-repr-member? r reprs)
2042           (begin
2043             (set! str
2044               (string-append str
2045                              sep
2046                              (if (= r targ-repr-boxed)
2047                                "boxed"
2048                                (vector-ref targ-repr-types (- r 1)))))
2049             (loop (+ r 1) ","))
2050           (loop (+ r 1) sep))))
2051     (string-append str "}")))
2052
2053
2054
2055
2056 (define (targ-repr-for-each-live proc frame)
2057   (let* ((live
2058           (frame-live frame))
2059          (any-closed-live?
2060           (varset-intersects?
2061             live
2062             (list->varset (frame-closed frame)))))
2063
2064     (define (live? var)
2065       (or (varset-member? var live)
2066           (and (eq? var closure-env-var) any-closed-live?)))
2067
2068     (let ((slots (frame-slots frame)))
2069       (let loop1 ((i (length slots)) (lst slots))
2070         (if (pair? lst)
2071           (begin
2072             (if (live? (car lst))
2073               (proc (targ-repr-loc->index (make-stk i))))
2074             (loop1 (- i 1) (cdr lst)))
2075           (let ((regs (frame-regs frame)))
2076             (let loop2 ((i 0) (lst regs))
2077               (if (pair? lst)
2078                 (begin
2079                   (if (live? (car lst))
2080                     (proc (targ-repr-loc->index (make-reg i))))
2081                   (loop2 (+ i 1) (cdr lst)))))))))))
2082
2083 (define (targ-repr-begin-block! kind lbl)
2084 (targ-fp-cache-init);************
2085   (if targ-repr-enabled?
2086     (let ((cell (targ-make-cell #f))
2087           (fs (frame-size targ-proc-exit-frame)))
2088       (targ-emit cell)
2089       (set! targ-repr-current-block
2090         (targ-make-block kind lbl cell))
2091       (stretchable-vector-set!
2092         targ-repr-graph
2093         lbl
2094         targ-repr-current-block)
2095       (targ-block-entry-fs-set!
2096         targ-repr-current-block
2097         fs)
2098       (let ((loc-descrs (targ-block-loc-descrs targ-repr-current-block)))
2099         (if (memq kind
2100                   '(entry return task-entry task-return))
2101           (let loop ((i (- (+ targ-nb-gvm-regs fs) 1)))
2102             (if (>= i 0)
2103               (let ((descr (stretchable-vector-ref loc-descrs i)))
2104                 (stretchable-vector-set!
2105                   loc-descrs
2106                   i
2107                   (targ-repr-need-reprs-union
2108                     descr
2109                     (targ-repr-singleton targ-repr-boxed)))
2110                 (loop (- i 1))))))
2111         (targ-repr-for-each-live
2112           (lambda (i)
2113             (stretchable-vector-set!
2114               loc-descrs
2115               i
2116               (targ-repr-live1-add
2117                 (stretchable-vector-ref loc-descrs i))))
2118           targ-proc-exit-frame)))))
2119
2120 (define (targ-repr-exit-block! lbl)
2121   (if targ-repr-enabled?
2122     (let ((cell (targ-make-cell #f)))
2123       (targ-emit cell)
2124       (targ-block-add-exit!
2125         targ-repr-current-block
2126         lbl
2127         cell))))
2128
2129 (define (targ-repr-end-block!)
2130   (if targ-repr-enabled?
2131     (begin
2132       (targ-block-exit-fs-set!
2133         targ-repr-current-block
2134         (frame-size targ-proc-exit-frame))
2135       (let ((loc-descrs (targ-block-loc-descrs targ-repr-current-block)))
2136         (targ-repr-for-each-live
2137           (lambda (i)
2138             (stretchable-vector-set!
2139               loc-descrs
2140               i
2141               (targ-repr-live2-add
2142                 (stretchable-vector-ref loc-descrs i))))
2143           targ-proc-exit-frame))
2144       (set! targ-repr-current-block #f))))
2145
2146 (define (targ-repr-loc->index loc)
2147   (cond ((reg? loc)
2148          (reg-num loc))
2149         ((stk? loc)
2150          (+ (- (stk-num loc) 1) targ-nb-gvm-regs))
2151         (else
2152          (compiler-internal-error
2153            "targ-repr-loc->index, invalid 'loc'" loc))))
2154
2155 (define (targ-repr-index->loc i)
2156   (if (< i targ-nb-gvm-regs)
2157     (make-reg i)
2158     (make-stk (+ (- i targ-nb-gvm-regs) 1))))
2159
2160 (define (targ-repr-unboxed-index->code i repr)
2161   (let ((type (vector-ref targ-repr-types (- repr 1))))
2162     (targ-need-unboxed i repr)
2163     (if (< i targ-nb-gvm-regs)
2164       (list (string-append
2165               type
2166               "R"
2167               (number->string i)))
2168       (list (string-append
2169               type
2170               "STK"
2171               (number->string (+ (- i targ-nb-gvm-regs) 1)))))))
2172
2173 (define (targ-repr-index->code i repr)
2174   (if (= repr targ-repr-boxed)
2175     (if (< i targ-nb-gvm-regs)
2176       (cons 'r i)
2177       (list "STK" (- (+ (- i targ-nb-gvm-regs) 1) targ-proc-fp)))
2178     (targ-repr-unboxed-index->code i repr)))
2179
2180 (define (targ-repr-unboxed-loc->code loc repr)
2181   (targ-repr-unboxed-index->code
2182     (targ-repr-loc->index loc)
2183     repr))
2184
2185 (define (targ-repr-to-boxed! loc repr)
2186   (targ-repr-loc-boxed
2187     loc
2188     (targ-repr-to-boxed
2189       (targ-repr-unboxed-loc->code loc repr)
2190       repr)))
2191
2192 (define (targ-repr-from-boxed! loc repr)
2193   (let ((type (vector-ref targ-repr-types (- repr 1))))
2194     (list (string-append "SET_" type)
2195           (targ-repr-unboxed-loc->code loc repr)
2196           (targ-repr-from-boxed
2197             (targ-repr-opnd-boxed loc)
2198             repr))))
2199
2200 (define (targ-repr-opnd opnd repr)
2201   (if targ-repr-enabled?
2202
2203     (if (or (reg? opnd) (stk? opnd))
2204       (let* ((loc-descrs
2205               (targ-block-loc-descrs targ-repr-current-block))
2206              (i
2207               (targ-repr-loc->index opnd))
2208              (descr
2209               (stretchable-vector-ref loc-descrs i))
2210              (have
2211               (targ-repr-have-reprs descr)))
2212         (cond ((targ-repr-empty? have)
2213                (stretchable-vector-set! loc-descrs i
2214                  (targ-repr-need-reprs-union
2215                    descr
2216                    (targ-repr-singleton repr))))
2217               ((not (targ-repr-member? repr have))
2218                (let loop ((r targ-repr-boxed))
2219                  (if (not (targ-repr-member? r have))
2220                    (loop (+ r 1))
2221                    (if (not (= r targ-repr-boxed))
2222                      (targ-emit (targ-repr-to-boxed! opnd r)))))
2223                (if (not (= repr targ-repr-boxed))
2224                  (targ-emit (targ-repr-from-boxed! opnd repr)))
2225                (stretchable-vector-set! loc-descrs i
2226                  (targ-repr-have-reprs-union
2227                    (targ-repr-have-reprs-union
2228                      descr
2229                      (targ-repr-singleton repr))
2230                    targ-repr-boxed))))
2231         (targ-repr-index->code i repr))
2232       (if (and (= repr targ-repr-f64)
2233                (obj? opnd)
2234                (eq? (targ-obj-type (obj-val opnd)) 'subtyped)
2235                (eq? (targ-obj-subtype (obj-val opnd)) 'flonum)
2236                targ-use-c-fp-constants?
2237                (not (targ-unusual-float? (obj-val opnd))))
2238         (obj-val opnd)
2239         (targ-repr-from-boxed (targ-repr-opnd-boxed opnd) repr)))
2240
2241     (targ-repr-from-boxed (targ-repr-opnd-boxed opnd) repr)))
2242
2243 (define (targ-repr-from-boxed code repr)
2244   (if (= repr targ-repr-boxed)
2245     code
2246     (list (string-append (vector-ref targ-repr-types (- repr 1)) "UNBOX")
2247           code)))
2248
2249 (define (targ-repr-to-boxed code repr)
2250   (if (= repr targ-repr-boxed)
2251     code
2252     (begin
2253       (targ-need-heap)
2254       (list (string-append (vector-ref targ-repr-types (- repr 1)) "BOX")
2255             code))))
2256
2257 (define (targ-repr-opnd-boxed opnd)
2258
2259   (cond ((reg? opnd)
2260          (let ((n (reg-num opnd)))
2261            (targ-rd-reg n)
2262            (cons 'r n)))
2263
2264         ((stk? opnd)
2265          (targ-rd-fp)
2266          (list "STK" (- (stk-num opnd) targ-proc-fp)))
2267
2268         ((glo? opnd)
2269          (let ((name (glo-name opnd)))
2270            (list "GLO"
2271                  (targ-use-glo name #f)
2272                  (targ-c-id-glo (symbol->string name)))))
2273
2274         ((clo? opnd)
2275          (list "CLO"
2276                (targ-opnd (clo-base opnd))
2277                (clo-index opnd)))
2278
2279         ((lbl? opnd)
2280          (let ((n (lbl-num opnd)))
2281            (list "LBL" (targ-ref-lbl-val n))))
2282
2283         ((obj? opnd)
2284          (targ-use-obj (obj-val opnd)))
2285
2286         (else
2287          (compiler-internal-error
2288            "targ-repr-opnd-boxed, unknown 'opnd'" opnd))))
2289
2290 (define (targ-repr-loc loc val repr)
2291   (if targ-repr-enabled?
2292
2293     (if (or (reg? loc) (stk? loc))
2294       (let* ((loc-descrs
2295               (targ-block-loc-descrs targ-repr-current-block))
2296              (i
2297               (targ-repr-loc->index loc))
2298              (descr
2299               (stretchable-vector-ref loc-descrs i))
2300              (x
2301               (if (= repr targ-repr-boxed)
2302                 (targ-repr-loc-boxed loc val)
2303                 (let ((type (vector-ref targ-repr-types (- repr 1))))
2304                   (list (string-append "SET_" type)
2305                         (targ-repr-unboxed-loc->code loc repr)
2306                         val)))))
2307         (stretchable-vector-set! loc-descrs i
2308           (targ-repr-have-reprs-set
2309             descr
2310             (targ-repr-singleton repr)))
2311         x)
2312       (targ-repr-loc-boxed loc (targ-repr-to-boxed val repr)))
2313
2314     (targ-repr-loc-boxed loc (targ-repr-to-boxed val repr))))
2315
2316 (define (targ-repr-loc-boxed loc val)
2317
2318   (cond ((reg? loc)
2319          (let ((n (reg-num loc)))
2320            (targ-wr-reg n)
2321            (list 'set-r n val)))
2322
2323         ((stk? loc)
2324          (targ-rd-fp)
2325          (list "SET_STK" (- (stk-num loc) targ-proc-fp) val))
2326
2327         ((glo? loc)
2328          (let ((name (glo-name loc)))
2329            (list "SET_GLO"
2330                  (targ-use-glo name #t)
2331                  (targ-c-id-glo (symbol->string name))
2332                  val)))
2333
2334         ((clo? loc)
2335          (list "SET_CLO"
2336                (targ-opnd (clo-base loc))
2337                (clo-index loc)))
2338
2339         (else
2340          (compiler-internal-error
2341            "targ-repr-loc-boxed, unknown 'loc'" loc))))
2342
2343 (define (targ-opnd opnd) ; fetch a GVM operand in boxed form
2344   (targ-repr-opnd opnd targ-repr-boxed))
2345
2346 (define (targ-opnd-flo opnd) ; fetch a GVM operand as an unboxed flonum
2347   (targ-repr-opnd opnd targ-repr-f64))
2348
2349 (define (targ-loc loc val) ; store boxed value in GVM location
2350   (targ-repr-loc loc val targ-repr-boxed))
2351
2352 (define (targ-loc-flo loc val) ; store unboxed flonum to GVM location
2353   (targ-repr-loc loc val targ-repr-f64))
2354 )
2355
2356 ;;;----------------------------------------------------------------------------
2357
2358 (define (targ-opnd opnd) ; fetch GVM operand
2359
2360   (if (and targ-fp-cache-enabled? (or (reg? opnd) (stk? opnd)))
2361     (targ-fp-cache-write-if-dirty opnd))
2362
2363   (cond ((reg? opnd)
2364          (let ((n (reg-num opnd)))
2365            (targ-rd-reg n)
2366            (cons 'r n)))
2367
2368         ((stk? opnd)
2369          (targ-rd-fp)
2370          (list "STK" (- (stk-num opnd) targ-proc-fp)))
2371
2372         ((glo? opnd)
2373          (let ((name (glo-name opnd)))
2374            (list "GLO"
2375                  (targ-use-glo name #f)
2376                  (targ-c-id-glo (symbol->string name)))))
2377
2378         ((clo? opnd)
2379          (list "CLO"
2380                (targ-opnd (clo-base opnd))
2381                (clo-index opnd)))
2382
2383         ((lbl? opnd)
2384          (let ((n (lbl-num opnd)))
2385            (list "LBL" (targ-ref-lbl-val n))))
2386
2387         ((obj? opnd)
2388          (targ-use-obj (obj-val opnd)))
2389
2390         (else
2391          (compiler-internal-error
2392            "targ-opnd, unknown 'opnd'" opnd))))
2393
2394 (define (targ-loc loc val) ; store GVM location
2395   (let ((x (targ-loc-no-invalidate loc val)))
2396
2397     (if (and targ-fp-cache-enabled? (or (reg? loc) (stk? loc)))
2398       (targ-fp-cache-invalidate loc))
2399
2400     x))
2401
2402 (define (targ-loc-no-invalidate loc val) ; store GVM location without
2403                                          ; invalidating flonum cache
2404   (cond ((reg? loc)
2405          (let ((n (reg-num loc)))
2406            (targ-wr-reg n)
2407            (list 'set-r n val)))
2408
2409         ((stk? loc)
2410          (targ-rd-fp)
2411          (list "SET_STK" (- (stk-num loc) targ-proc-fp) val))
2412
2413         ((glo? loc)
2414          (let ((name (glo-name loc)))
2415            (list "SET_GLO"
2416                  (targ-use-glo name #t)
2417                  (targ-c-id-glo (symbol->string name))
2418                  val)))
2419
2420         ((clo? loc)
2421          (list "SET_CLO"
2422                (targ-opnd (clo-base loc))
2423                (clo-index loc)))
2424
2425         (else
2426          (compiler-internal-error
2427            "targ-loc, unknown 'loc'" loc))))
2428
2429 (define (targ-opnd-flo opnd) ; fetch unboxed flonum GVM operand
2430   (cond ((and targ-fp-cache-enabled? (or (reg? opnd) (stk? opnd)))
2431          (let ((stamp1 (targ-fp-cache-probe opnd)))
2432            (if stamp1
2433              (targ-unboxed-loc->code opnd stamp1)
2434              (let* ((stamp2 (targ-fp-cache-enter opnd #f))
2435                     (code (targ-unboxed-loc->code opnd stamp2)))
2436                (targ-emit
2437                  (list "SET_F64" code (list "F64UNBOX" (targ-opnd opnd))))
2438                code))))
2439         ((and (obj? opnd)
2440               (eq? (targ-obj-type (obj-val opnd)) 'subtyped)
2441               (eq? (targ-obj-subtype (obj-val opnd)) 'flonum)
2442               targ-use-c-fp-constants?
2443               (not (targ-unusual-float? (obj-val opnd))))
2444          (obj-val opnd))
2445         (else
2446          (list "F64UNBOX" (targ-opnd opnd)))))
2447
2448 (define (targ-loc-flo loc val fs) ; store unboxed flonum to GVM location
2449   (if (and targ-fp-cache-enabled? (or (reg? loc) (stk? loc)))
2450     (begin
2451       (targ-fp-cache-invalidate loc)
2452       (let* ((stamp (targ-fp-cache-enter loc #t))
2453              (code (targ-unboxed-loc->code loc stamp)))
2454         (list "SET_F64" code val)))
2455     (begin
2456       (targ-heap-reserve-and-check targ-flonum-space fs)
2457       (targ-loc loc (list "F64BOX" val)))))
2458
2459 ;;;----------------------------------------------------------------------------
2460
2461 (define (targ-adjust-stack fs)
2462   (if (= targ-proc-fp fs)
2463     #f
2464     (let ((fp targ-proc-fp))
2465       (set! targ-proc-fp fs)
2466       (targ-rd-fp)
2467       (targ-wr-fp)
2468       (list "ADJFP" (- fs fp)))))
2469
2470 (define (targ-sn-opnd opnd sn)
2471   (cond ((stk? opnd)
2472          (max (stk-num opnd) sn))
2473         ((clo? opnd)
2474          (targ-sn-opnd (clo-base opnd) sn))
2475         (else
2476          sn)))
2477
2478 (define (targ-sn-opnds opnds sn)
2479   (if (pair? opnds)
2480     (targ-sn-opnd (car opnds) (targ-sn-opnds (cdr opnds) sn))
2481     sn))
2482
2483 (define (targ-sn-loc loc sn)
2484   (if loc
2485     (targ-sn-opnd loc sn)
2486     sn))
2487
2488 ;;;----------------------------------------------------------------------------
2489
2490 ;; Floating point number cache management.
2491
2492 (define targ-use-c-fp-constants? #f)
2493 (set! targ-use-c-fp-constants? #t)
2494
2495 (define targ-fp-cache-enabled? #f)
2496 (set! targ-fp-cache-enabled? #t)
2497
2498 (define (targ-fp-cache-init)
2499   (set! targ-fp-cache (vector 0 '#() 0)))
2500
2501 (define (targ-fp-cache-size)
2502   (vector-ref targ-fp-cache 0))
2503
2504 (define (targ-fp-cache-write loc stamp)
2505   (targ-heap-reserve targ-flonum-space)
2506   (targ-emit
2507     (targ-loc-no-invalidate
2508       loc
2509       (list "F64BOX" (targ-unboxed-loc->code loc stamp)))))
2510
2511 (define (targ-fp-cache-write-if-dirty loc)
2512   (let ((v (vector-ref targ-fp-cache 1)))
2513     (let ((n (vector-length v)))
2514       (let loop ((i 0))
2515         (if (< i n)
2516           (let ((x (vector-ref v i)))
2517             (if (and x (vector-ref x 1) (eqv? (vector-ref x 0) loc))
2518               (begin
2519                 (targ-fp-cache-write loc (vector-ref x 2))
2520                 (vector-set! x 1 #f))
2521               (loop (+ i 1)))))))))
2522
2523 (define (targ-fp-cache-enter opnd dirty?) ; allocate new entry for opnd
2524   (let* ((v1
2525           (vector-ref targ-fp-cache 1))
2526          (stamp
2527           (let ((n (+ (vector-ref targ-fp-cache 2) 1)))
2528             (vector-set! targ-fp-cache 2 n)
2529             n))
2530          (entry
2531           (vector opnd dirty? stamp)))
2532     (let ((n (vector-length v1)))
2533       (let loop1 ((i 0))
2534         (if (< i n)
2535           (if (vector-ref v1 i)
2536             (loop1 (+ i 1))
2537             (vector-set! v1 i entry))
2538           (let ((v2 (make-vector (+ (* n 2) 1) #f)))
2539             (let loop2 ((i 0))
2540               (if (< i n)
2541                 (begin
2542                   (vector-set! v2 i (vector-ref v1 i))
2543                   (loop2 (+ i 1)))))
2544             (vector-set! v2 n entry)
2545             (vector-set! targ-fp-cache 0 (+ n 1))
2546             (vector-set! targ-fp-cache 1 v2)))))
2547     stamp))
2548
2549 (define (targ-fp-cache-probe opnd) ; opnd must be a reg or stack slot
2550   (let ((v (vector-ref targ-fp-cache 1)))
2551     (let ((n (vector-length v)))
2552       (let loop ((i 0))
2553         (if (< i n)
2554           (let ((x (vector-ref v i)))
2555             (if (and x (eqv? (vector-ref x 0) opnd))
2556               (vector-ref x 2)
2557               (loop (+ i 1))))
2558           #f)))))
2559
2560 (define (targ-fp-cache-invalidate opnd) ; opnd must be a reg or stack slot
2561   (let ((v (vector-ref targ-fp-cache 1)))
2562     (let ((n (vector-length v)))
2563       (let loop ((i 0))
2564         (if (< i n)
2565           (let ((x (vector-ref v i)))
2566             (if (and x (eqv? (vector-ref x 0) opnd))
2567               (vector-set! v i #f))
2568             (loop (+ i 1))))))))
2569
2570 ;;;============================================================================
2571
2572 ;; DATABASE OF PRIMITIVES
2573
2574 (for-each targ-prim-proc-add!
2575           '(
2576             ("##c-code"  0            #t 0        0 (#f)   extended)
2577            ))
2578
2579 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2580
2581 ;; Procedure specialization
2582
2583 (define (targ-spec name specializer-maker)
2584   (let ((proc-name (string->canonical-symbol name)))
2585     (let ((proc (targ-get-prim-info name)))
2586       (proc-obj-specialize-set! proc (specializer-maker proc proc-name)))))
2587
2588 ;; Safe specialization
2589
2590 (define (targ-s name)
2591   (lambda (proc proc-name)
2592     (let ((spec (targ-get-prim-info name)))
2593       (lambda (env args) spec))))
2594
2595 ;; Unsafe specialization
2596
2597 (define (targ-u name)
2598   (lambda (proc proc-name)
2599     (let ((spec (targ-get-prim-info name)))
2600       (lambda (env args) (if (not (safe? env)) spec proc)))))
2601
2602 ;; Arithmetic specialization
2603
2604 (define (targ-arith fix-name flo-name)
2605   (lambda (proc proc-name)
2606     (let ((fix-spec (if fix-name (targ-get-prim-info fix-name) proc))
2607           (flo-spec (if flo-name (targ-get-prim-info flo-name) proc)))
2608       (lambda (env args)
2609         (let ((arith (arith-implementation proc-name env)))
2610           (cond ((eq? arith fixnum-sym)
2611                  fix-spec)
2612                 ((eq? arith flonum-sym)
2613                  flo-spec)
2614                 (else
2615                  proc)))))))
2616
2617 ;; Safe specialization for eqv? and ##eqv?
2618
2619 (define (targ-s-eqv?)
2620   (lambda (proc proc-name)
2621     (let ((spec (targ-get-prim-info "##eq?")))
2622       (lambda (env args)
2623         (if (and (= (length args) 2)
2624                  (or (eq? (arith-implementation proc-name env) fixnum-sym)
2625                      (targ-eq-testable-object? (car args))
2626                      (targ-eq-testable-object? (cadr args))))
2627           spec
2628           proc)))))
2629
2630 ;; Safe specialization for equal? and ##equal?
2631
2632 (define (targ-s-equal?)
2633   (lambda (proc proc-name)
2634     (let ((spec (targ-get-prim-info "##eq?")))
2635       (lambda (env args)
2636         (if (and (= (length args) 2)
2637                  (or (targ-eq-testable-object? (car args))
2638                      (targ-eq-testable-object? (cadr args))))
2639           spec
2640           proc)))))
2641
2642 (define (targ-eq-testable-object? obj)
2643   (and (not (void-object? obj)) ; the void-object denotes a non-constant
2644        (targ-testable-with-eq? obj)))
2645
2646 (define (targ-testable-with-eq? obj)
2647   (or (symbol-object? obj)
2648       (keyword-object? obj)
2649       (memq (targ-obj-type obj)
2650             '(boolean null absent unused deleted void eof optional
2651               key rest
2652               fixnum32 char))))
2653
2654 ;;;----------------------------------------------------------------------------
2655
2656 (define (targ-op name descr)
2657   (descr (targ-get-prim-info name)))
2658
2659 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2660
2661 (define (targ-apply-alloc compute-space proc-safe? side-effects? flo-result? f)
2662   (targ-setup-inlinable-proc
2663     proc-safe?
2664     side-effects?
2665     flo-result?
2666     (lambda (opnds sn)
2667       (targ-heap-reserve-and-check
2668         (compute-space (length opnds))
2669         (targ-sn-opnds opnds sn))
2670       (f opnds sn))))
2671
2672 (define (targ-apply-cons)
2673   (targ-apply-alloc
2674     (lambda (n) targ-pair-space)
2675     #t
2676     #f
2677     #f
2678     (targ-apply-simp-generator #f "CONS")))
2679
2680 (define (targ-apply-list)
2681   (targ-apply-alloc
2682     (lambda (n) (* n targ-pair-space))
2683     #t
2684     #f
2685     #f
2686     (lambda (opnds sn)
2687       (cond ((null? opnds)
2688              '("NUL"))
2689             ((null? (cdr opnds))
2690              (list "CONS" (targ-opnd (car opnds)) '("NUL")))
2691             (else
2692              (let* ((rev-elements (reverse (map targ-opnd opnds)))
2693                     (n (length rev-elements)))
2694                (targ-emit
2695                  (list "BEGIN_ALLOC_LIST" n (car rev-elements)))
2696                (for-each-index (lambda (elem i)
2697                                  (targ-emit
2698                                    (list "ADD_LIST_ELEM" (+ i 1) elem)))
2699                                (cdr rev-elements))
2700                (targ-emit
2701                  (list "END_ALLOC_LIST" n))
2702                (list "GET_LIST" n)))))))
2703
2704 (define (targ-apply-box)
2705   (targ-apply-alloc
2706     (lambda (n) targ-box-space)
2707     #t
2708     #f
2709     #f
2710     (targ-apply-simp-generator #f "BOX")))
2711
2712 (define (targ-apply-make-will)
2713   (targ-apply-alloc
2714     (lambda (n) targ-will-space)
2715     #t
2716     'expr ; this is an expression with side-effects
2717     #f
2718     (lambda (opnds sn)
2719       (targ-apply-simp-gen opnds #f "MAKEWILL"))))
2720
2721 (define (targ-apply-make-promise)
2722   (targ-apply-alloc
2723     (lambda (n) targ-promise-space)
2724     #t
2725     #f
2726     #f
2727     (targ-apply-simp-generator #f "MAKEPROMISE")))
2728
2729 (define (targ-apply-vector-s kind)
2730   (targ-apply-vector #t kind))
2731
2732 (define (targ-apply-vector-u kind)
2733   (targ-apply-vector #f kind))
2734
2735 (define (targ-apply-vector proc-safe? kind)
2736   (targ-setup-inlinable-proc
2737     proc-safe?
2738     #f
2739     #f
2740     (lambda (opnds sn)
2741       (let ((n (length opnds)))
2742         (if (and (eq? kind 'values) (= n 1))
2743
2744           (targ-opnd (car opnds))
2745
2746           (let ()
2747
2748             (define (compute-space n)
2749               (case kind
2750                 ((string)    (targ-string-space n))
2751                 ((s8vector)  (targ-s8vector-space n))
2752                 ((u8vector)  (targ-s8vector-space n))
2753                 ((s16vector) (targ-s8vector-space (* n 2)))
2754                 ((u16vector) (targ-s8vector-space (* n 2)))
2755                 ((s32vector) (targ-s8vector-space (* n 4)))
2756                 ((u32vector) (targ-s8vector-space (* n 4)))
2757                 ((s64vector) (targ-s8vector-space (* n 8)))
2758                 ((u64vector) (targ-s8vector-space (* n 8)))
2759                 ((f32vector) (targ-s8vector-space (* n 4)))
2760                 ((f64vector) (targ-s8vector-space (* n 8)))
2761                 ((values)    (targ-vector-space n))
2762                 ((structure) (targ-vector-space n))
2763                 (else        (targ-vector-space n))))
2764
2765             (define begin-allocator-name
2766               (case kind
2767                 ((string)    "BEGIN_ALLOC_STRING")
2768                 ((s8vector)  "BEGIN_ALLOC_S8VECTOR")
2769                 ((u8vector)  "BEGIN_ALLOC_U8VECTOR")
2770                 ((s16vector) "BEGIN_ALLOC_S16VECTOR")
2771                 ((u16vector) "BEGIN_ALLOC_U16VECTOR")
2772                 ((s32vector) "BEGIN_ALLOC_S32VECTOR")
2773                 ((u32vector) "BEGIN_ALLOC_U32VECTOR")
2774                 ((s64vector) "BEGIN_ALLOC_S64VECTOR")
2775                 ((u64vector) "BEGIN_ALLOC_U64VECTOR")
2776                 ((f32vector) "BEGIN_ALLOC_F32VECTOR")
2777                 ((f64vector) "BEGIN_ALLOC_F64VECTOR")
2778                 ((values)    "BEGIN_ALLOC_VALUES")
2779                 ((structure) "BEGIN_ALLOC_STRUCTURE")
2780                 (else        "BEGIN_ALLOC_VECTOR")))
2781
2782             (define end-allocator-name
2783               (case kind
2784                 ((string)    "END_ALLOC_STRING")
2785                 ((s8vector)  "END_ALLOC_S8VECTOR")
2786                 ((u8vector)  "END_ALLOC_U8VECTOR")
2787                 ((s16vector) "END_ALLOC_S16VECTOR")
2788                 ((u16vector) "END_ALLOC_U16VECTOR")
2789                 ((s32vector) "END_ALLOC_S32VECTOR")
2790                 ((u32vector) "END_ALLOC_U32VECTOR")
2791                 ((s64vector) "END_ALLOC_S64VECTOR")
2792                 ((u64vector) "END_ALLOC_U64VECTOR")
2793                 ((f32vector) "END_ALLOC_F32VECTOR")
2794                 ((f64vector) "END_ALLOC_F64VECTOR")
2795                 ((values)    "END_ALLOC_VALUES")
2796                 ((structure) "END_ALLOC_STRUCTURE")
2797                 (else        "END_ALLOC_VECTOR")))
2798
2799             (define add-element
2800               (case kind
2801                 ((string)    "ADD_STRING_ELEM")
2802                 ((s8vector)  "ADD_S8VECTOR_ELEM")
2803                 ((u8vector)  "ADD_U8VECTOR_ELEM")
2804                 ((s16vector) "ADD_S16VECTOR_ELEM")
2805                 ((u16vector) "ADD_U16VECTOR_ELEM")
2806                 ((s32vector) "ADD_S32VECTOR_ELEM")
2807                 ((u32vector) "ADD_U32VECTOR_ELEM")
2808                 ((s64vector) "ADD_S64VECTOR_ELEM")
2809                 ((u64vector) "ADD_U64VECTOR_ELEM")
2810                 ((f32vector) "ADD_F32VECTOR_ELEM")
2811                 ((f64vector) "ADD_F64VECTOR_ELEM")
2812                 ((values)    "ADD_VALUES_ELEM")
2813                 ((structure) "ADD_STRUCTURE_ELEM")
2814                 (else        "ADD_VECTOR_ELEM")))
2815
2816             (define getter-operation
2817               (case kind
2818                 ((string)    "GET_STRING")
2819                 ((s8vector)  "GET_S8VECTOR")
2820                 ((u8vector)  "GET_U8VECTOR")
2821                 ((s16vector) "GET_S16VECTOR")
2822                 ((u16vector) "GET_U16VECTOR")
2823                 ((s32vector) "GET_S32VECTOR")
2824                 ((u32vector) "GET_U32VECTOR")
2825                 ((s64vector) "GET_S64VECTOR")
2826                 ((u64vector) "GET_U64VECTOR")
2827                 ((f32vector) "GET_F32VECTOR")
2828                 ((f64vector) "GET_F64VECTOR")
2829                 ((values)    "GET_VALUES")
2830                 ((structure) "GET_STRUCTURE")
2831                 (else        "GET_VECTOR")))
2832
2833             (targ-heap-reserve-and-check
2834               (compute-space n)
2835               (targ-sn-opnds opnds sn))
2836
2837             (let* ((flo? (or (eq? kind 'f32vector) (eq? kind 'f64vector)))
2838                    (elements (map (if flo? targ-opnd-flo targ-opnd) opnds)))
2839               (targ-emit
2840                 (list begin-allocator-name n))
2841               (for-each-index (lambda (elem i)
2842                                 (targ-emit
2843                                   (list add-element i elem)))
2844                               elements)
2845               (targ-emit
2846                 (list end-allocator-name n))
2847               (list getter-operation n))))))))
2848
2849 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2850
2851 (define (targ-apply-force)
2852   (lambda (prim)
2853     (proc-obj-inlinable?-set! prim (lambda (env) #t))
2854     (proc-obj-inline-set!
2855       prim
2856       (lambda (opnds loc sn)
2857         (let ((lbl (targ-new-lbl))
2858               (opnd (car opnds))
2859               (sn* (targ-sn-loc loc sn)))
2860
2861           (targ-update-fr targ-proc-entry-frame)
2862           (targ-emit (targ-adjust-stack sn*))
2863           (targ-emit (list "FORCE1"
2864                            (targ-ref-lbl-val lbl)
2865                            (targ-opnd opnd)))
2866 ;;          (targ-repr-exit-block! lbl)
2867 ;;          (targ-repr-end-block!)
2868           (targ-gen-label-return* lbl 'return-internal)
2869           (targ-emit (list "FORCE2"))
2870           (if loc
2871             (targ-emit (targ-loc loc (list "FORCE3")))))))))
2872
2873 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2874
2875 (define (targ-apply-first-argument)
2876   (targ-setup-inlinable-proc*
2877     #t
2878     (lambda (opnds sn)
2879       (targ-opnd (car opnds)))))
2880
2881 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2882
2883 (define (targ-apply-check-heap-limit)
2884   (lambda (prim)
2885     (proc-obj-inlinable?-set! prim (lambda (env) #t))
2886     (proc-obj-inline-set!
2887       prim
2888       (lambda (opnds loc sn)
2889         (if (> targ-proc-hp 0)
2890           (targ-update-fr-and-check-heap 0 sn))
2891         (if loc
2892           (targ-emit
2893             (targ-loc loc (targ-opnd (make-obj false-object)))))))))
2894
2895 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2896
2897 (define (targ-ifjump-simp-s flo? name)
2898   (targ-ifjump-simp #t flo? name))
2899
2900 (define (targ-ifjump-simp-u flo? name)
2901   (targ-ifjump-simp #f flo? name))
2902
2903 (define (targ-ifjump-simp proc-safe? flo? name)
2904   (targ-setup-test-proc*
2905     proc-safe?
2906     flo?
2907     (targ-ifjump-simp-generator flo? name)))
2908
2909 (define (targ-ifjump-fold-s flo? name)
2910   (targ-ifjump-fold #t flo? name))
2911
2912 (define (targ-ifjump-fold-u flo? name)
2913   (targ-ifjump-fold #f flo? name))
2914
2915 (define (targ-ifjump-fold proc-safe? flo? name)
2916   (targ-setup-test-proc*
2917     proc-safe?
2918     flo?
2919     (targ-ifjump-fold-generator flo? name)))
2920
2921 (define (targ-ifjump-apply-s name)
2922   (targ-ifjump-apply #t name))
2923
2924 (define (targ-ifjump-apply-u name)
2925   (targ-ifjump-apply #f name))
2926
2927 (define (targ-ifjump-apply proc-safe? name)
2928   (targ-setup-inlinable-proc*
2929     proc-safe?
2930     (targ-apply-simp-generator #f name)))
2931
2932 (define (targ-apply-simp-s flo? side-effects? name)
2933   (targ-apply-simp #t flo? side-effects? name))
2934
2935 (define (targ-apply-simp-u flo? side-effects? name)
2936   (targ-apply-simp #f flo? side-effects? name))
2937
2938 (define (targ-apply-simp proc-safe? flo? side-effects? name); prim. with non-flonum result
2939   (targ-setup-inlinable-proc
2940     proc-safe?
2941     side-effects?
2942     #f
2943     (targ-apply-simp-generator flo? name)))
2944
2945 (define (targ-apply-fold-s flo? name0 name1 name2)
2946   (targ-apply-fold #t flo? name0 name1 name2))
2947
2948 (define (targ-apply-fold-u flo? name0 name1 name2)
2949   (targ-apply-fold #f flo? name0 name1 name2))
2950
2951 (define (targ-apply-fold proc-safe? flo? name0 name1 name2)
2952   (let ((generator (targ-apply-fold-generator flo? name0 name1 name2)))
2953     (if flo?
2954       (targ-apply-alloc
2955         (lambda (n) 0) ; targ-apply-alloc accounts for space for flonum result
2956         proc-safe?
2957         #f
2958         #t
2959         generator)
2960       (targ-setup-inlinable-proc
2961         proc-safe?
2962         #f
2963         #f
2964         generator))))
2965
2966 (define (targ-apply-simpflo-s flo? name)
2967   (targ-apply-simpflo #t flo? name))
2968
2969 (define (targ-apply-simpflo-u flo? name)
2970   (targ-apply-simpflo #f flo? name))
2971
2972 (define (targ-apply-simpflo proc-safe? flo? name) ; prim. with flonum result
2973   (targ-apply-alloc
2974     (lambda (n) 0) ; targ-apply-alloc accounts for space for flonum result
2975     proc-safe?
2976     #f
2977     #t
2978     (targ-apply-simp-generator flo? name)))
2979
2980 (define (targ-apply-simpflo2-s flo? name1 name2)
2981   (targ-apply-simpflo2 #t flo? name1 name2))
2982
2983 (define (targ-apply-simpflo2-u flo? name1 name2)
2984   (targ-apply-simpflo2 #f flo? name1 name2))
2985
2986 (define (targ-apply-simpflo2 proc-safe? flo? name1 name2) ; 1 or 2 arg prim. with flonum result
2987   (targ-apply-alloc
2988     (lambda (n) 0) ; targ-apply-alloc accounts for space for flonum result
2989     proc-safe?
2990     #f
2991     #t
2992     (lambda (opnds sn)
2993       (if (= (length opnds) 1)
2994         (targ-apply-simp-gen opnds flo? name1)
2995         (targ-apply-simp-gen opnds flo? name2)))))
2996
2997 (define (targ-apply-simpflo3-s name)
2998   (targ-apply-simpflo3 #t name))
2999
3000 (define (targ-apply-simpflo3-u name)
3001   (targ-apply-simpflo3 #f name))
3002
3003 (define (targ-apply-simpflo3 proc-safe? name); 3 arg prim. whose last arg is a flonum
3004   (targ-setup-inlinable-proc
3005     proc-safe?
3006     #t
3007     #f
3008     (lambda (opnds sn)
3009       (let* ((arg1 (targ-opnd (car opnds)))
3010              (arg2 (targ-opnd (cadr opnds)))
3011              (arg3 (targ-opnd-flo (caddr opnds))))
3012         (list name arg1 arg2 arg3)))))
3013
3014 (define (targ-apply-simpbig-s name)
3015   (targ-apply-simpbig #t name))
3016
3017 (define (targ-apply-simpbig-u name)
3018   (targ-apply-simpbig #f name))
3019
3020 (define (targ-apply-simpbig proc-safe? name) ; prim. with 32 or 64 bit bignum result
3021   (targ-apply-alloc
3022     (lambda (n) (targ-s8vector-space (* (quotient targ-max-adigit-width 8) 3))) ; space for 2^64-1 including 64 bit alignment  ;;;;;;;;;;ugly code!
3023     proc-safe?
3024     #f
3025     #f
3026     (lambda (opnds sn)
3027       (targ-apply-simp-gen opnds #f name))))
3028
3029 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3030
3031 (define (targ-setup-test-proc* proc-safe? args-flo? generator)
3032   (lambda (prim)
3033     ((targ-setup-test-proc proc-safe? args-flo? generator)
3034      prim)
3035     ((targ-setup-inlinable-proc
3036        proc-safe?
3037        #f
3038        #f
3039        (lambda (opnds sn)
3040          (list "BOOLEAN" (generator opnds sn))))
3041      prim)))
3042
3043 (define (targ-setup-test-proc proc-safe? args-flo? generator)
3044   (lambda (prim)
3045     (proc-obj-testable?-set!
3046       prim
3047       (lambda (env)
3048         (or proc-safe?
3049             (not (safe? env)))))
3050     (proc-obj-test-set!
3051       prim
3052       (vector
3053         args-flo?
3054         (lambda (not? opnds fs)
3055           (let ((test (generator opnds fs)))
3056             (if not?
3057               (list "NOT" test)
3058               test)))))))
3059
3060 (define (targ-ifjump-simp-generator flo? name)
3061   (lambda (opnds fs)
3062     (targ-ifjump-simp-gen opnds flo? name)))
3063
3064 (define (targ-ifjump-simp-gen opnds flo? name)
3065   (let loop ((l opnds) (args '()))
3066     (if (pair? l)
3067       (let ((opnd (car l)))
3068         (loop (cdr l)
3069               (cons (if flo? (targ-opnd-flo opnd) (targ-opnd opnd))
3070                     args)))
3071       (cons name (reverse args)))))
3072
3073 (define (targ-ifjump-fold-generator flo? name)
3074   (lambda (opnds fs)
3075     (targ-ifjump-fold-gen opnds flo? name)))
3076
3077 (define (targ-ifjump-fold-gen opnds flo? name)
3078
3079   (define (multi-opnds opnds)
3080     (let* ((opnd1 (car opnds))
3081            (opnd2 (cadr opnds))
3082            (opnd1* (if flo? (targ-opnd-flo opnd1) (targ-opnd opnd1)))
3083            (opnd2* (if flo? (targ-opnd-flo opnd2) (targ-opnd opnd2)))
3084            (r (list name opnd1* opnd2*)))
3085       (if (pair? (cddr opnds))
3086         (list "AND" r (multi-opnds (cdr opnds)))
3087         r)))
3088
3089   (cond ((or (not (pair? opnds))
3090              (not (pair? (cdr opnds))))
3091          1)
3092         (else
3093          (multi-opnds opnds))))
3094
3095 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3096
3097 (define (targ-setup-inlinable-proc* proc-safe? generator)
3098   (lambda (prim)
3099     ((targ-setup-test-proc
3100        proc-safe?
3101        #f ; safe to assume that arguments are not all flonums
3102        (lambda (opnds fs)
3103          (list "NOT" (list "FALSEP" (generator opnds fs)))))
3104      prim)
3105     ((targ-setup-inlinable-proc proc-safe? #f #f generator)
3106      prim)))
3107
3108 (define (targ-setup-inlinable-proc proc-safe? side-effects? flo-result? generator)
3109   (lambda (prim)
3110     (proc-obj-inlinable?-set!
3111       prim
3112       (lambda (env)
3113         (or proc-safe?
3114             (not (safe? env)))))
3115     (proc-obj-inline-set!
3116       prim
3117       (lambda (opnds loc sn)
3118         (if loc ; result is needed?
3119           (if (eq? side-effects? #t) ; generator generates a statement?
3120             (let ((x (generator opnds sn)))
3121               (targ-emit
3122                 (if (eqv? (car opnds) loc)
3123                   x
3124                   (list 'seq x (targ-loc loc (targ-opnd (car opnds)))))))
3125             (let ((sn* (targ-sn-loc loc sn)))
3126               (let ((x (generator opnds sn*)))
3127                 (targ-emit
3128                   (if flo-result?
3129                     (targ-loc-flo loc x sn*)
3130                     (targ-loc loc x))))))
3131           (if side-effects? ; only generate code for side-effect
3132             (let ((x (generator opnds sn)))
3133               (targ-emit
3134                 (if (eq? side-effects? 'expr) (list "EXPR" x) x)))))))))
3135
3136 (define (targ-apply-simp-generator flo? name)
3137   (lambda (opnds sn)
3138     (targ-apply-simp-gen opnds flo? name)))
3139
3140 (define (targ-apply-simp-gen opnds flo? name)
3141   (let loop ((l opnds) (args '()))
3142     (if (pair? l)
3143       (let ((opnd (car l)))
3144         (loop (cdr l)
3145               (cons (if flo? (targ-opnd-flo opnd) (targ-opnd opnd))
3146                     args)))
3147       (cons name (reverse args)))))
3148
3149 (define (targ-apply-fold-generator flo? name0 name1 name2)
3150   (lambda (opnds sn)
3151     (targ-apply-fold-gen opnds flo? name0 name1 name2)))
3152
3153 (define (targ-apply-fold-gen opnds flo? name0 name1 name2)
3154   (if (not (pair? opnds))
3155     (list name0)
3156     (let* ((o (car opnds))
3157            (r (if flo? (targ-opnd-flo o) (targ-opnd o))))
3158       (if (not (pair? (cdr opnds)))
3159         (list name1 r)
3160         (let loop ((l (cdr opnds)) (r r))
3161           (if (pair? l)
3162             (let ((opnd (car l)))
3163               (loop (cdr l)
3164                     (list name2
3165                           r
3166                           (if flo? (targ-opnd-flo opnd) (targ-opnd opnd)))))
3167             r))))))
3168
3169 ;;;----------------------------------------------------------------------------
3170
3171 (define (targ-jump-inline name jump-inliner)
3172   (let ((prim (targ-get-prim-info name)))
3173     (proc-obj-jump-inlinable?-set! prim (lambda (env) #t))
3174     (proc-obj-jump-inline-set! prim jump-inliner)))
3175
3176 (define (targ-emit-jump-inline name safe? nb-args)
3177   (let* ((pc (targ-jump-info nb-args))
3178          (fs (pcontext-fs pc)))
3179     (for-each (lambda (x)
3180                 (let ((opnd (cdr x)))
3181                   (targ-opnd
3182                    (if (stk? opnd)
3183                      (make-stk (+ targ-proc-fp (- (stk-num opnd) fs)))
3184                      opnd))))
3185               (cdr (pcontext-map pc)))
3186     (targ-emit
3187      (list (string-append "JUMP_" name (number->string nb-args))
3188            (list (if safe? "JUMPSAFE" "JUMPNOTSAFE"))))))
3189
3190 ;;;----------------------------------------------------------------------------
3191
3192 ;; Table of inlinable operations (for 'apply' and 'ifjump' GVM instructions)
3193
3194 (define (targ-setup-inlinable)
3195
3196 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3197
3198 (targ-op "##type"             (targ-apply-simp-s #f #f "TYPE"))
3199 (targ-op "##type-cast"        (targ-apply-simp-u #f #f "TYPECAST"))
3200 (targ-op "##subtype"          (targ-apply-simp-u #f #f "SUBTYPE"))
3201 (targ-op "##subtype-set!"     (targ-apply-simp-u #f #t "SUBTYPESET"))
3202
3203 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3204
3205 (targ-op "##not"              (targ-ifjump-simp-s #f "FALSEP"))
3206 (targ-op "##boolean?"         (targ-ifjump-simp-s #f "BOOLEANP"))
3207 (targ-op "##null?"            (targ-ifjump-simp-s #f "NULLP"))
3208 (targ-op "##unbound?"         (targ-ifjump-simp-s #f "UNBOUNDP"))
3209 (targ-op "##eq?"              (targ-ifjump-simp-s #f "EQP"))
3210 (targ-op "##eof-object?"      (targ-ifjump-simp-s #f "EOFP"))
3211
3212 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3213
3214 (targ-op "##fixnum?"          (targ-ifjump-simp-s #f "FIXNUMP"))
3215 (targ-op "##special?"         (targ-ifjump-simp-s #f "SPECIALP"))
3216 (targ-op "##pair?"            (targ-ifjump-simp-s #f "PAIRP"))
3217 (targ-op "##pair-mutable?"    (targ-ifjump-simp-s #f "PAIRMUTABLEP"))
3218 (targ-op "##subtyped?"        (targ-ifjump-simp-s #f "SUBTYPEDP"))
3219 (targ-op "##subtyped-mutable?"(targ-ifjump-simp-s #f "SUBTYPEDMUTABLEP"))
3220 (targ-op "##subtyped.vector?" (targ-ifjump-simp-u #f "SUBTYPEDVECTORP"))
3221 (targ-op "##subtyped.symbol?" (targ-ifjump-simp-u #f "SUBTYPEDSYMBOLP"))
3222 (targ-op "##subtyped.flonum?" (targ-ifjump-simp-u #f "SUBTYPEDFLONUMP"))
3223 (targ-op "##subtyped.bignum?" (targ-ifjump-simp-u #f "SUBTYPEDBIGNUMP"))
3224 (targ-op "##vector?"          (targ-ifjump-simp-s #f "VECTORP"))
3225 (targ-op "##ratnum?"          (targ-ifjump-simp-s #f "RATNUMP"))
3226 (targ-op "##cpxnum?"          (targ-ifjump-simp-s #f "CPXNUMP"))
3227 (targ-op "##structure?"       (targ-ifjump-simp-s #f "STRUCTUREP"))
3228 (targ-op "##box?"             (targ-ifjump-simp-s #f "BOXP"))
3229 (targ-op "##values?"          (targ-ifjump-simp-s #f "VALUESP"))
3230 (targ-op "##meroon?"          (targ-ifjump-simp-s #f "MEROONP"))
3231 (targ-op "##jazz?"            (targ-ifjump-simp-s #f "JAZZP"))
3232 (targ-op "##symbol?"          (targ-ifjump-simp-s #f "SYMBOLP"))
3233 (targ-op "##keyword?"         (targ-ifjump-simp-s #f "KEYWORDP"))
3234 (targ-op "##frame?"           (targ-ifjump-simp-s #f "FRAMEP"))
3235 (targ-op "##continuation?"    (targ-ifjump-simp-s #f "CONTINUATIONP"))
3236 (targ-op "##promise?"         (targ-ifjump-simp-s #f "PROMISEP"))
3237 (targ-op "##will?"            (targ-ifjump-simp-s #f "WILLP"))
3238 (targ-op "##gc-hash-table?"   (targ-ifjump-simp-s #f "GCHASHTABLEP"))
3239 (targ-op "##mem-allocated?"   (targ-ifjump-simp-s #f "MEMALLOCATEDP"))
3240 (targ-op "##procedure?"       (targ-ifjump-simp-s #f "PROCEDUREP"))
3241 (targ-op "##return?"          (targ-ifjump-simp-s #f "RETURNP"))
3242 (targ-op "##foreign?"         (targ-ifjump-simp-s #f "FOREIGNP"))
3243 (targ-op "##string?"          (targ-ifjump-simp-s #f "STRINGP"))
3244 (targ-op "##s8vector?"        (targ-ifjump-simp-s #f "S8VECTORP"))
3245 (targ-op "##u8vector?"        (targ-ifjump-simp-s #f "U8VECTORP"))
3246 (targ-op "##s16vector?"       (targ-ifjump-simp-s #f "S16VECTORP"))
3247 (targ-op "##u16vector?"       (targ-ifjump-simp-s #f "U16VECTORP"))
3248 (targ-op "##s32vector?"       (targ-ifjump-simp-s #f "S32VECTORP"))
3249 (targ-op "##u32vector?"       (targ-ifjump-simp-s #f "U32VECTORP"))
3250 (targ-op "##s64vector?"       (targ-ifjump-simp-s #f "S64VECTORP"))
3251 (targ-op "##u64vector?"       (targ-ifjump-simp-s #f "U64VECTORP"))
3252 (targ-op "##f32vector?"       (targ-ifjump-simp-s #f "F32VECTORP"))
3253 (targ-op "##f64vector?"       (targ-ifjump-simp-s #f "F64VECTORP"))
3254 (targ-op "##flonum?"          (targ-ifjump-simp-s #f "FLONUMP"))
3255 (targ-op "##bignum?"          (targ-ifjump-simp-s #f "BIGNUMP"))
3256 (targ-op "##char?"            (targ-ifjump-simp-s #f "CHARP"))
3257 (targ-op "##number?"          (targ-ifjump-simp-s #f "NUMBERP"))
3258 (targ-op "##complex?"         (targ-ifjump-simp-s #f "COMPLEXP"))
3259
3260 ;;the following primitives can't be inlined because they have
3261 ;;non-trivial definitions which depend on some configuration
3262 ;;information provided by lib/_num.scm:
3263 ;;(targ-op "##real?"            (targ-ifjump-simp-s #f "REALP"))
3264 ;;(targ-op "##rational?"        (targ-ifjump-simp-s #f "RATIONALP"))
3265 ;;(targ-op "##integer?"         (targ-ifjump-simp-s #f "INTEGERP"))
3266 ;;(targ-op "##exact?"           (targ-ifjump-simp-s #f "EXACTP"))
3267 ;;(targ-op "##inexact?"         (targ-ifjump-simp-s #f "INEXACTP"))
3268
3269 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3270
3271 (targ-op "##fixnum.max"       (targ-apply-fold-u #f #f       "FIXPOS" "FIXMAX"))
3272 (targ-op "##fixnum.min"       (targ-apply-fold-u #f #f       "FIXPOS" "FIXMIN"))
3273
3274 (targ-op "##fixnum.wrap+"     (targ-apply-fold-u #f "FIX_0"  "FIXPOS" "FIXADD"))
3275 (targ-op "##fixnum.+"         (targ-apply-fold-u #f "FIX_0"  "FIXPOS" "FIXADD"))
3276 (targ-op "##fixnum.+?"        (targ-apply-fold-u #f "FIX_0"  #f       "FIXADDP"))
3277 (targ-op "##fixnum.wrap*"     (targ-apply-fold-u #f "FIX_1"  "FIXPOS" "FIXMUL"))
3278 (targ-op "##fixnum.*"         (targ-apply-fold-u #f "FIX_1"  "FIXPOS" "FIXMUL"))
3279 (targ-op "##fixnum.*?"        (targ-apply-fold-u #f "FIX_1"  #f       "FIXMULP"))
3280 (targ-op "##fixnum.wrap-"     (targ-apply-fold-u #f #f       "FIXNEG" "FIXSUB"))
3281 (targ-op "##fixnum.-"         (targ-apply-fold-u #f #f       "FIXNEG" "FIXSUB"))
3282 (targ-op "##fixnum.-?"        (targ-apply-fold-u #f #f       "FIXNEGP""FIXSUBP"))
3283 (targ-op "##fixnum.wrapquotient"(targ-apply-fold-u #f #f       #f       "FIXQUO"))
3284 (targ-op "##fixnum.quotient"  (targ-apply-fold-u #f #f       #f       "FIXQUO"))
3285 (targ-op "##fixnum.remainder" (targ-apply-fold-u #f #f       #f       "FIXREM"))
3286 (targ-op "##fixnum.modulo"    (targ-apply-fold-u #f #f       #f       "FIXMOD"))
3287 (targ-op "##fixnum.bitwise-ior"(targ-apply-fold-u #f "FIX_0"  "FIXPOS" "FIXIOR"))
3288 (targ-op "##fixnum.bitwise-xor"(targ-apply-fold-u #f "FIX_0"  "FIXPOS" "FIXXOR"))
3289 (targ-op "##fixnum.bitwise-and"(targ-apply-fold-u #f "FIX_M1" "FIXPOS" "FIXAND"))
3290 (targ-op "##fixnum.bitwise-not"(targ-apply-simp-u #f #f "FIXNOT"))
3291 (targ-op "##fixnum.wraparithmetic-shift"     (targ-apply-simp-u #f #f "FIXASH"))
3292 (targ-op "##fixnum.arithmetic-shift"         (targ-apply-simp-u #f #f "FIXASH"))
3293 (targ-op "##fixnum.arithmetic-shift?"        (targ-apply-simp-u #f #f "FIXASHP"))
3294 (targ-op "##fixnum.wraparithmetic-shift-left"(targ-apply-simp-u #f #f "FIXASHL"))
3295 (targ-op "##fixnum.arithmetic-shift-left"    (targ-apply-simp-u #f #f "FIXASHL"))
3296 (targ-op "##fixnum.arithmetic-shift-left?"   (targ-apply-simp-u #f #f "FIXASHLP"))
3297 (targ-op "##fixnum.arithmetic-shift-right"   (targ-apply-simp-u #f #f "FIXASHR"))
3298 (targ-op "##fixnum.arithmetic-shift-right?"  (targ-apply-simp-u #f #f "FIXASHRP"))
3299 (targ-op "##fixnum.wraplogical-shift-right"  (targ-apply-simp-u #f #f "FIXLSHR"))
3300 (targ-op "##fixnum.wraplogical-shift-right?" (targ-apply-simp-u #f #f "FIXLSHRP"))
3301 (targ-op "##fixnum.wrapabs"    (targ-apply-simp-u #f #f "FIXABS"))
3302 (targ-op "##fixnum.abs"        (targ-apply-simp-u #f #f "FIXABS"))
3303 (targ-op "##fixnum.abs?"       (targ-apply-simp-u #f #f "FIXABSP"))
3304
3305 (targ-op "##fixnum.zero?"     (targ-ifjump-simp-u #f "FIXZEROP"))
3306 (targ-op "##fixnum.positive?" (targ-ifjump-simp-u #f "FIXPOSITIVEP"))
3307 (targ-op "##fixnum.negative?" (targ-ifjump-simp-u #f "FIXNEGATIVEP"))
3308 (targ-op "##fixnum.odd?"      (targ-ifjump-simp-u #f "FIXODDP"))
3309 (targ-op "##fixnum.even?"     (targ-ifjump-simp-u #f "FIXEVENP"))
3310 (targ-op "##fixnum.="         (targ-ifjump-fold-u #f "FIXEQ"))
3311 (targ-op "##fixnum.<"         (targ-ifjump-fold-u #f "FIXLT"))
3312 (targ-op "##fixnum.>"         (targ-ifjump-fold-u #f "FIXGT"))
3313 (targ-op "##fixnum.<="        (targ-ifjump-fold-u #f "FIXLE"))
3314 (targ-op "##fixnum.>="        (targ-ifjump-fold-u #f "FIXGE"))
3315
3316 (targ-op "##fixnum.->char"    (targ-apply-simp-u #f #f "FIXTOCHR"))
3317 (targ-op "##fixnum.<-char"    (targ-apply-simp-u #f #f "FIXFROMCHR"))
3318
3319 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3320
3321 (targ-op "##flonum.->fixnum"  (targ-apply-simp-u #t #f "F64TOFIX"))
3322 (targ-op "##flonum.<-fixnum"  (targ-apply-simpflo-u #f "F64FROMFIX"))
3323
3324 (targ-op "##flonum.max"       (targ-apply-fold-u #t #f      "F64POS" "F64MAX"))
3325 (targ-op "##flonum.min"       (targ-apply-fold-u #t #f      "F64POS" "F64MIN"))
3326
3327 (targ-op "##flonum.+"         (targ-apply-fold-u #t "F64_0" "F64POS" "F64ADD"))
3328 (targ-op "##flonum.*"         (targ-apply-fold-u #t "F64_1" "F64POS" "F64MUL"))
3329 (targ-op "##flonum.-"         (targ-apply-fold-u #t #f      "F64NEG" "F64SUB"))
3330 (targ-op "##flonum./"         (targ-apply-fold-u #t #f      "F64INV" "F64DIV"))
3331 (targ-op "##flonum.abs"       (targ-apply-simpflo-u #t "F64ABS"))
3332 (targ-op "##flonum.floor"     (targ-apply-simpflo-u #t "F64FLOOR"))
3333 (targ-op "##flonum.ceiling"   (targ-apply-simpflo-u #t "F64CEILING"))
3334 (targ-op "##flonum.truncate"  (targ-apply-simpflo-u #t "F64TRUNCATE"))
3335 (targ-op "##flonum.round"     (targ-apply-simpflo-u #t "F64ROUND"))
3336 (targ-op "##flonum.exp"       (targ-apply-simpflo-u #t "F64EXP"))
3337 (targ-op "##flonum.log"       (targ-apply-simpflo-u #t "F64LOG"))
3338 (targ-op "##flonum.sin"       (targ-apply-simpflo-u #t "F64SIN"))
3339 (targ-op "##flonum.cos"       (targ-apply-simpflo-u #t "F64COS"))
3340 (targ-op "##flonum.tan"       (targ-apply-simpflo-u #t "F64TAN"))
3341 (targ-op "##flonum.asin"      (targ-apply-simpflo-u #t "F64ASIN"))
3342 (targ-op "##flonum.acos"      (targ-apply-simpflo-u #t "F64ACOS"))
3343 (targ-op "##flonum.atan"      (targ-apply-simpflo2-u #t "F64ATAN" "F64ATAN2"))
3344 (targ-op "##flonum.expt"      (targ-apply-simpflo-u #t "F64EXPT"))
3345 (targ-op "##flonum.sqrt"      (targ-apply-simpflo-u #t "F64SQRT"))
3346 (targ-op "##flonum.copysign"  (targ-apply-simpflo-u #t "F64COPYSIGN"))
3347
3348 (targ-op "##flonum.integer?"  (targ-ifjump-simp-u #t "F64INTEGERP"))
3349 (targ-op "##flonum.zero?"     (targ-ifjump-simp-u #t "F64ZEROP"))
3350 (targ-op "##flonum.positive?" (targ-ifjump-simp-u #t "F64POSITIVEP"))
3351 (targ-op "##flonum.negative?" (targ-ifjump-simp-u #t "F64NEGATIVEP"))
3352 (targ-op "##flonum.odd?"      (targ-ifjump-simp-u #t "F64ODDP"))
3353 (targ-op "##flonum.even?"     (targ-ifjump-simp-u #t "F64EVENP"))
3354 (targ-op "##flonum.finite?"   (targ-ifjump-simp-u #t "F64FINITEP"))
3355 (targ-op "##flonum.infinite?" (targ-ifjump-simp-u #t "F64INFINITEP"))
3356 (targ-op "##flonum.nan?"      (targ-ifjump-simp-u #t "F64NANP"))
3357 (targ-op "##flonum.<-fixnum-exact?" (targ-ifjump-simp-u #f "F64FROMFIXEXACTP"))
3358 (targ-op "##flonum.="         (targ-ifjump-fold-u #t "F64EQ"))
3359 (targ-op "##flonum.<"         (targ-ifjump-fold-u #t "F64LT"))
3360 (targ-op "##flonum.>"         (targ-ifjump-fold-u #t "F64GT"))
3361 (targ-op "##flonum.<="        (targ-ifjump-fold-u #t "F64LE"))
3362 (targ-op "##flonum.>="        (targ-ifjump-fold-u #t "F64GE"))
3363
3364 ;; new fixnum primitives
3365
3366 (targ-op "##fxmax"          (targ-apply-fold-u #f #f       "FIXPOS" "FIXMAX"))
3367 (targ-op "##fxmin"          (targ-apply-fold-u #f #f       "FIXPOS" "FIXMIN"))
3368
3369 (targ-op "##fxwrap+"        (targ-apply-fold-u #f "FIX_0"  "FIXPOS" "FIXADD"))
3370 (targ-op "##fx+"            (targ-apply-fold-u #f "FIX_0"  "FIXPOS" "FIXADD"))
3371 (targ-op "##fx+?"           (targ-apply-fold-u #f "FIX_0"  #f       "FIXADDP"))
3372 (targ-op "##fxwrap*"        (targ-apply-fold-u #f "FIX_1"  "FIXPOS" "FIXMUL"))
3373 (targ-op "##fx*"            (targ-apply-fold-u #f "FIX_1"  "FIXPOS" "FIXMUL"))
3374 (targ-op "##fx*?"           (targ-apply-fold-u #f "FIX_1"  #f       "FIXMULP"))
3375 (targ-op "##fxwrap-"        (targ-apply-fold-u #f #f       "FIXNEG" "FIXSUB"))
3376 (targ-op "##fx-"            (targ-apply-fold-u #f #f       "FIXNEG" "FIXSUB"))
3377 (targ-op "##fx-?"           (targ-apply-fold-u #f #f       "FIXNEGP""FIXSUBP"))
3378 (targ-op "##fxwrapquotient" (targ-apply-fold-u #f #f       #f       "FIXQUO"))
3379 (targ-op "##fxquotient"     (targ-apply-fold-u #f #f       #f       "FIXQUO"))
3380 (targ-op "##fxremainder"    (targ-apply-fold-u #f #f       #f       "FIXREM"))
3381 (targ-op "##fxmodulo"       (targ-apply-fold-u #f #f       #f       "FIXMOD"))
3382 (targ-op "##fxnot"          (targ-apply-simp-u #f #f "FIXNOT"))
3383 (targ-op "##fxand"          (targ-apply-fold-u #f "FIX_M1" "FIXPOS" "FIXAND"))
3384 (targ-op "##fxior"          (targ-apply-fold-u #f "FIX_0"  "FIXPOS" "FIXIOR"))
3385 (targ-op "##fxxor"          (targ-apply-fold-u #f "FIX_0"  "FIXPOS" "FIXXOR"))
3386 (targ-op "##fxif"           (targ-apply-simp-u #f #f "FIXIF"))
3387 (targ-op "##fxbit-count"    (targ-apply-simp-u #f #f "FIXBITCOUNT"))
3388 (targ-op "##fxlength"       (targ-apply-simp-u #f #f "FIXLENGTH"))
3389 (targ-op "##fxfirst-bit-set"(targ-apply-simp-u #f #f "FIXFIRSTBITSET"))
3390 (targ-op "##fxbit-set?"     (targ-ifjump-simp-u #f "FIXBITSETP"))
3391 (targ-op "##fxwraparithmetic-shift"     (targ-apply-simp-u #f #f "FIXASH"))
3392 (targ-op "##fxarithmetic-shift"         (targ-apply-simp-u #f #f "FIXASH"))
3393 (targ-op "##fxarithmetic-shift?"        (targ-apply-simp-u #f #f "FIXASHP"))
3394 (targ-op "##fxwraparithmetic-shift-left"(targ-apply-simp-u #f #f "FIXASHL"))
3395 (targ-op "##fxarithmetic-shift-left"    (targ-apply-simp-u #f #f "FIXASHL"))
3396 (targ-op "##fxarithmetic-shift-left?"   (targ-apply-simp-u #f #f "FIXASHLP"))
3397 (targ-op "##fxarithmetic-shift-right"   (targ-apply-simp-u #f #f "FIXASHR"))
3398 (targ-op "##fxarithmetic-shift-right?"  (targ-apply-simp-u #f #f "FIXASHRP"))
3399 (targ-op "##fxwraplogical-shift-right"  (targ-apply-simp-u #f #f "FIXLSHR"))
3400 (targ-op "##fxwraplogical-shift-right?" (targ-apply-simp-u #f #f "FIXLSHRP"))
3401 (targ-op "##fxwrapabs"      (targ-apply-simp-u #f #f "FIXABS"))
3402 (targ-op "##fxabs"          (targ-apply-simp-u #f #f "FIXABS"))
3403 (targ-op "##fxabs?"         (targ-apply-simp-u #f #f "FIXABSP"))
3404
3405 (targ-op "##fxzero?"     (targ-ifjump-simp-u #f "FIXZEROP"))
3406 (targ-op "##fxpositive?" (targ-ifjump-simp-u #f "FIXPOSITIVEP"))
3407 (targ-op "##fxnegative?" (targ-ifjump-simp-u #f "FIXNEGATIVEP"))
3408 (targ-op "##fxodd?"      (targ-ifjump-simp-u #f "FIXODDP"))
3409 (targ-op "##fxeven?"     (targ-ifjump-simp-u #f "FIXEVENP"))
3410 (targ-op "##fx="         (targ-ifjump-fold-u #f "FIXEQ"))
3411 (targ-op "##fx<"         (targ-ifjump-fold-u #f "FIXLT"))
3412 (targ-op "##fx>"         (targ-ifjump-fold-u #f "FIXGT"))
3413 (targ-op "##fx<="        (targ-ifjump-fold-u #f "FIXLE"))
3414 (targ-op "##fx>="        (targ-ifjump-fold-u #f "FIXGE"))
3415
3416 (targ-op "##fx->char"    (targ-apply-simp-u #f #f "FIXTOCHR"))
3417 (targ-op "##fx<-char"    (targ-apply-simp-u #f #f "FIXFROMCHR"))
3418
3419 (targ-op "##fixnum->char"   (targ-apply-simp-u #f #f "FIXTOCHR"))
3420 (targ-op "##char->fixnum"   (targ-apply-simp-u #f #f "FIXFROMCHR"))
3421 (targ-op "##flonum->fixnum" (targ-apply-simp-u #t #f "F64TOFIX"))
3422 (targ-op "##fixnum->flonum" (targ-apply-simpflo-u #f "F64FROMFIX"))
3423 (targ-op "##fixnum->flonum-exact?" (targ-ifjump-simp-u #f "F64FROMFIXEXACTP"))
3424
3425 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3426
3427 ;; new flonum primitives
3428
3429 (targ-op "##fl->fx"  (targ-apply-simp-u #t #f "F64TOFIX"))
3430 (targ-op "##fl<-fx"  (targ-apply-simpflo-u #f "F64FROMFIX"))
3431
3432 (targ-op "##flmax"       (targ-apply-fold-u #t #f      "F64POS" "F64MAX"))
3433 (targ-op "##flmin"       (targ-apply-fold-u #t #f      "F64POS" "F64MIN"))
3434
3435 (targ-op "##fl+"         (targ-apply-fold-u #t "F64_0" "F64POS" "F64ADD"))
3436 (targ-op "##fl*"         (targ-apply-fold-u #t "F64_1" "F64POS" "F64MUL"))
3437 (targ-op "##fl-"         (targ-apply-fold-u #t #f      "F64NEG" "F64SUB"))
3438 (targ-op "##fl/"         (targ-apply-fold-u #t #f      "F64INV" "F64DIV"))
3439 (targ-op "##flabs"       (targ-apply-simpflo-u #t "F64ABS"))
3440 (targ-op "##flfloor"     (targ-apply-simpflo-u #t "F64FLOOR"))
3441 (targ-op "##flceiling"   (targ-apply-simpflo-u #t "F64CEILING"))
3442 (targ-op "##fltruncate"  (targ-apply-simpflo-u #t "F64TRUNCATE"))
3443 (targ-op "##flround"     (targ-apply-simpflo-u #t "F64ROUND"))
3444 (targ-op "##flexp"       (targ-apply-simpflo-u #t "F64EXP"))
3445 (targ-op "##fllog"       (targ-apply-simpflo-u #t "F64LOG"))
3446 (targ-op "##flsin"       (targ-apply-simpflo-u #t "F64SIN"))
3447 (targ-op "##flcos"       (targ-apply-simpflo-u #t "F64COS"))
3448 (targ-op "##fltan"       (targ-apply-simpflo-u #t "F64TAN"))
3449 (targ-op "##flasin"      (targ-apply-simpflo-u #t "F64ASIN"))
3450 (targ-op "##flacos"      (targ-apply-simpflo-u #t "F64ACOS"))
3451 (targ-op "##flatan"      (targ-apply-simpflo2-u #t "F64ATAN" "F64ATAN2"))
3452 (targ-op "##flexpt"      (targ-apply-simpflo-u #t "F64EXPT"))
3453 (targ-op "##flsqrt"      (targ-apply-simpflo-u #t "F64SQRT"))
3454 (targ-op "##flcopysign"  (targ-apply-simpflo-u #t "F64COPYSIGN"))
3455
3456 (targ-op "##flinteger?"  (targ-ifjump-simp-u #t "F64INTEGERP"))
3457 (targ-op "##flzero?"     (targ-ifjump-simp-u #t "F64ZEROP"))
3458 (targ-op "##flpositive?" (targ-ifjump-simp-u #t "F64POSITIVEP"))
3459 (targ-op "##flnegative?" (targ-ifjump-simp-u #t "F64NEGATIVEP"))
3460 (targ-op "##flodd?"      (targ-ifjump-simp-u #t "F64ODDP"))
3461 (targ-op "##fleven?"     (targ-ifjump-simp-u #t "F64EVENP"))
3462 (targ-op "##flfinite?"   (targ-ifjump-simp-u #t "F64FINITEP"))
3463 (targ-op "##flinfinite?" (targ-ifjump-simp-u #t "F64INFINITEP"))
3464 (targ-op "##flnan?"      (targ-ifjump-simp-u #t "F64NANP"))
3465 (targ-op "##fl<-fx-exact?" (targ-ifjump-simp-u #f "F64FROMFIXEXACTP"))
3466 (targ-op "##fl="         (targ-ifjump-fold-u #t "F64EQ"))
3467 (targ-op "##fl<"         (targ-ifjump-fold-u #t "F64LT"))
3468 (targ-op "##fl>"         (targ-ifjump-fold-u #t "F64GT"))
3469 (targ-op "##fl<="        (targ-ifjump-fold-u #t "F64LE"))
3470 (targ-op "##fl>="        (targ-ifjump-fold-u #t "F64GE"))
3471
3472 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3473
3474 (targ-op "##char=?"           (targ-ifjump-fold-u #f "CHAREQP"))
3475 (targ-op "##char<?"           (targ-ifjump-fold-u #f "CHARLTP"))
3476 (targ-op "##char>?"           (targ-ifjump-fold-u #f "CHARGTP"))
3477 (targ-op "##char<=?"          (targ-ifjump-fold-u #f "CHARLEP"))
3478 (targ-op "##char>=?"          (targ-ifjump-fold-u #f "CHARGEP"))
3479
3480 (targ-op "##char-alphabetic?" (targ-ifjump-simp-u #f "CHARALPHABETICP"))
3481 (targ-op "##char-numeric?"    (targ-ifjump-simp-u #f "CHARNUMERICP"))
3482 (targ-op "##char-whitespace?" (targ-ifjump-simp-u #f "CHARWHITESPACEP"))
3483 (targ-op "##char-upper-case?" (targ-ifjump-simp-u #f "CHARUPPERCASEP"))
3484 (targ-op "##char-lower-case?" (targ-ifjump-simp-u #f "CHARLOWERCASEP"))
3485 (targ-op "##char-upcase"      (targ-apply-simp-u #f #f "CHARUPCASE"))
3486 (targ-op "##char-downcase"    (targ-apply-simp-u #f #f "CHARDOWNCASE"))
3487
3488 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3489
3490 (targ-op "##cons"             (targ-apply-cons))
3491 (targ-op "##set-car!"         (targ-apply-simp-u #f #t "SETCAR"))
3492 (targ-op "##set-cdr!"         (targ-apply-simp-u #f #t "SETCDR"))
3493 (targ-op "##car"              (targ-ifjump-apply-u "CAR"))
3494 (targ-op "##cdr"              (targ-ifjump-apply-u "CDR"))
3495 (targ-op "##caar"             (targ-ifjump-apply-u "CAAR"))
3496 (targ-op "##cadr"             (targ-ifjump-apply-u "CADR"))
3497 (targ-op "##cdar"             (targ-ifjump-apply-u "CDAR"))
3498 (targ-op "##cddr"             (targ-ifjump-apply-u "CDDR"))
3499 (targ-op "##caaar"            (targ-ifjump-apply-u "CAAAR"))
3500 (targ-op "##caadr"            (targ-ifjump-apply-u "CAADR"))
3501 (targ-op "##cadar"            (targ-ifjump-apply-u "CADAR"))
3502 (targ-op "##caddr"            (targ-ifjump-apply-u "CADDR"))
3503 (targ-op "##cdaar"            (targ-ifjump-apply-u "CDAAR"))
3504 (targ-op "##cdadr"            (targ-ifjump-apply-u "CDADR"))
3505 (targ-op "##cddar"            (targ-ifjump-apply-u "CDDAR"))
3506 (targ-op "##cdddr"            (targ-ifjump-apply-u "CDDDR"))
3507 (targ-op "##caaaar"           (targ-ifjump-apply-u "CAAAAR"))
3508 (targ-op "##caaadr"           (targ-ifjump-apply-u "CAAADR"))
3509 (targ-op "##caadar"           (targ-ifjump-apply-u "CAADAR"))
3510 (targ-op "##caaddr"           (targ-ifjump-apply-u "CAADDR"))
3511 (targ-op "##cadaar"           (targ-ifjump-apply-u "CADAAR"))
3512 (targ-op "##cadadr"           (targ-ifjump-apply-u "CADADR"))
3513 (targ-op "##caddar"           (targ-ifjump-apply-u "CADDAR"))
3514 (targ-op "##cadddr"           (targ-ifjump-apply-u "CADDDR"))
3515 (targ-op "##cdaaar"           (targ-ifjump-apply-u "CDAAAR"))
3516 (targ-op "##cdaadr"           (targ-ifjump-apply-u "CDAADR"))
3517 (targ-op "##cdadar"           (targ-ifjump-apply-u "CDADAR"))
3518 (targ-op "##cdaddr"           (targ-ifjump-apply-u "CDADDR"))
3519 (targ-op "##cddaar"           (targ-ifjump-apply-u "CDDAAR"))
3520 (targ-op "##cddadr"           (targ-ifjump-apply-u "CDDADR"))
3521 (targ-op "##cdddar"           (targ-ifjump-apply-u "CDDDAR"))
3522 (targ-op "##cddddr"           (targ-ifjump-apply-u "CDDDDR"))
3523
3524 (targ-op "##list"             (targ-apply-list))
3525
3526 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3527
3528 (targ-op "##quasi-list"       (targ-apply-list))
3529 (targ-op "##quasi-cons"       (targ-apply-cons))
3530 (targ-op "##quasi-vector"     (targ-apply-vector-s 'vector))
3531
3532 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3533
3534 (targ-op "##box"              (targ-apply-box))
3535 (targ-op "##unbox"            (targ-ifjump-apply-u "UNBOX"))
3536 (targ-op "##set-box!"         (targ-apply-simp-u #f #t "SETBOX"))
3537
3538 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3539
3540 (targ-op "##make-will"        (targ-apply-make-will))
3541 (targ-op "##will-testator"    (targ-ifjump-apply-u "WILLTESTATOR"))
3542
3543 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3544
3545 (targ-op "##gc-hash-table-ref"     (targ-apply-simp-u #f #f "GCHASHTABLEREF"))
3546 (targ-op "##gc-hash-table-set!"    (targ-apply-simp-u #f #f "GCHASHTABLESET"))
3547 (targ-op "##gc-hash-table-rehash!" (targ-apply-simp-u #f #f "GCHASHTABLEREHASH"))
3548
3549 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3550
3551 (targ-op "##values"           (targ-apply-vector-s 'values))
3552
3553 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3554
3555 (targ-op "##string"           (targ-apply-vector-u 'string))
3556 (targ-op "##string-length"    (targ-apply-simp-u #f #f "STRINGLENGTH"))
3557 (targ-op "##string-ref"       (targ-apply-simp-u #f #f "STRINGREF"))
3558 (targ-op "##string-set!"      (targ-apply-simp-u #f #t "STRINGSET"))
3559 (targ-op "##string-shrink!"   (targ-apply-simp-u #f #t "STRINGSHRINK"))
3560
3561 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3562
3563 (targ-op "##vector"           (targ-apply-vector-s 'vector))
3564 (targ-op "##vector-length"    (targ-apply-simp-u #f #f "VECTORLENGTH"))
3565 (targ-op "##vector-ref"       (targ-ifjump-apply-u "VECTORREF"))
3566 (targ-op "##vector-set!"      (targ-apply-simp-u #f #t "VECTORSET"))
3567 (targ-op "##vector-shrink!"   (targ-apply-simp-u #f #t "VECTORSHRINK"))
3568
3569 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3570
3571 (targ-op "##s8vector"         (targ-apply-vector-u 's8vector))
3572 (targ-op "##s8vector-length"  (targ-apply-simp-u #f #f "S8VECTORLENGTH"))
3573 (targ-op "##s8vector-ref"     (targ-apply-simp-u #f #f "S8VECTORREF"))
3574 (targ-op "##s8vector-set!"    (targ-apply-simp-u #f #t "S8VECTORSET"))
3575 (targ-op "##s8vector-shrink!" (targ-apply-simp-u #f #t "S8VECTORSHRINK"))
3576
3577 (targ-op "##u8vector"         (targ-apply-vector-u 'u8vector))
3578 (targ-op "##u8vector-length"  (targ-apply-simp-u #f #f "U8VECTORLENGTH"))
3579 (targ-op "##u8vector-ref"     (targ-apply-simp-u #f #f "U8VECTORREF"))
3580 (targ-op "##u8vector-set!"    (targ-apply-simp-u #f #t "U8VECTORSET"))
3581 (targ-op "##u8vector-shrink!" (targ-apply-simp-u #f #t "U8VECTORSHRINK"))
3582
3583 (targ-op "##s16vector"        (targ-apply-vector-u 's16vector))
3584 (targ-op "##s16vector-length" (targ-apply-simp-u #f #f "S16VECTORLENGTH"))
3585 (targ-op "##s16vector-ref"    (targ-apply-simp-u #f #f "S16VECTORREF"))
3586 (targ-op "##s16vector-set!"   (targ-apply-simp-u #f #t "S16VECTORSET"))
3587 (targ-op "##s16vector-shrink!"(targ-apply-simp-u #f #t "S16VECTORSHRINK"))
3588
3589 (targ-op "##u16vector"        (targ-apply-vector-u 'u16vector))
3590 (targ-op "##u16vector-length" (targ-apply-simp-u #f #f "U16VECTORLENGTH"))
3591 (targ-op "##u16vector-ref"    (targ-apply-simp-u #f #f "U16VECTORREF"))
3592 (targ-op "##u16vector-set!"   (targ-apply-simp-u #f #t "U16VECTORSET"))
3593 (targ-op "##u16vector-shrink!"(targ-apply-simp-u #f #t "U16VECTORSHRINK"))
3594
3595 (targ-op "##s32vector"        (targ-apply-vector-u 's32vector))
3596 (targ-op "##s32vector-length" (targ-apply-simp-u #f #f "S32VECTORLENGTH"))
3597 (targ-op "##s32vector-ref"    (targ-apply-simpbig-u "S32VECTORREF"))
3598 (targ-op "##s32vector-set!"   (targ-apply-simp-u #f #t "S32VECTORSET"))
3599 (targ-op "##s32vector-shrink!"(targ-apply-simp-u #f #t "S32VECTORSHRINK"))
3600
3601 (targ-op "##u32vector"        (targ-apply-vector-u 'u32vector))
3602 (targ-op "##u32vector-length" (targ-apply-simp-u #f #f "U32VECTORLENGTH"))
3603 (targ-op "##u32vector-ref"    (targ-apply-simpbig-u "U32VECTORREF"))
3604 (targ-op "##u32vector-set!"   (targ-apply-simp-u #f #t "U32VECTORSET"))
3605 (targ-op "##u32vector-shrink!"(targ-apply-simp-u #f #t "U32VECTORSHRINK"))
3606
3607 (targ-op "##s64vector"        (targ-apply-vector-u 's64vector))
3608 (targ-op "##s64vector-length" (targ-apply-simp-u #f #f "S64VECTORLENGTH"))
3609 (targ-op "##s64vector-ref"    (targ-apply-simpbig-u "S64VECTORREF"))
3610 (targ-op "##s64vector-set!"   (targ-apply-simp-u #f #t "S64VECTORSET"))
3611 (targ-op "##s64vector-shrink!"(targ-apply-simp-u #f #t "S64VECTORSHRINK"))
3612
3613 (targ-op "##u64vector"        (targ-apply-vector-u 'u64vector))
3614 (targ-op "##u64vector-length" (targ-apply-simp-u #f #f "U64VECTORLENGTH"))
3615 (targ-op "##u64vector-ref"    (targ-apply-simpbig-u "U64VECTORREF"))
3616 (targ-op "##u64vector-set!"   (targ-apply-simp-u #f #t "U64VECTORSET"))
3617 (targ-op "##u64vector-shrink!"(targ-apply-simp-u #f #t "U64VECTORSHRINK"))
3618
3619 (targ-op "##f32vector"        (targ-apply-vector-u 'f32vector))
3620 (targ-op "##f32vector-length" (targ-apply-simp-u #f #f "F32VECTORLENGTH"))
3621 (targ-op "##f32vector-ref"    (targ-apply-simpflo-u #f "F32VECTORREF"))
3622 (targ-op "##f32vector-set!"   (targ-apply-simpflo3-u "F32VECTORSET"))
3623 (targ-op "##f32vector-shrink!"(targ-apply-simp-u #f #t "F32VECTORSHRINK"))
3624
3625 (targ-op "##f64vector"        (targ-apply-vector-u 'f64vector))
3626 (targ-op "##f64vector-length" (targ-apply-simp-u #f #f "F64VECTORLENGTH"))
3627 (targ-op "##f64vector-ref"    (targ-apply-simpflo-u #f "F64VECTORREF"))
3628 (targ-op "##f64vector-set!"   (targ-apply-simpflo3-u "F64VECTORSET"))
3629 (targ-op "##f64vector-shrink!"(targ-apply-simp-u #f #t "F64VECTORSHRINK"))
3630
3631 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3632
3633 (targ-op "##bignum.negative?"        (targ-ifjump-simp-u #f "BIGNEGATIVEP"))
3634 (targ-op "##bignum.adigit-length"    (targ-apply-simp-u #f #f "BIGALENGTH"))
3635 (targ-op "##bignum.adigit-inc!"      (targ-apply-simp-u #f 'expr "BIGAINC"))
3636 (targ-op "##bignum.adigit-dec!"      (targ-apply-simp-u #f 'expr "BIGADEC"))
3637 (targ-op "##bignum.adigit-add!"      (targ-apply-simp-u #f 'expr "BIGAADD"))
3638 (targ-op "##bignum.adigit-sub!"      (targ-apply-simp-u #f 'expr "BIGASUB"))
3639 (targ-op "##bignum.mdigit-length"    (targ-apply-simp-u #f #f "BIGMLENGTH"))
3640 (targ-op "##bignum.mdigit-ref"       (targ-apply-simp-u #f #f "BIGMREF"))
3641 (targ-op "##bignum.mdigit-set!"      (targ-apply-simp-u #f #t "BIGMSET"))
3642 (targ-op "##bignum.mdigit-mul!"      (targ-apply-simp-u #f 'expr "BIGMMUL"))
3643 (targ-op "##bignum.mdigit-div!"      (targ-apply-simp-u #f 'expr "BIGMDIV"))
3644 (targ-op "##bignum.mdigit-quotient"  (targ-apply-simp-u #f #f "BIGMQUO"))
3645 (targ-op "##bignum.mdigit-remainder" (targ-apply-simp-u #f #f "BIGMREM"))
3646 (targ-op "##bignum.mdigit-test?"     (targ-ifjump-simp-u #f "BIGMTESTP"))
3647
3648 (targ-op "##bignum.adigit-ones?"     (targ-ifjump-simp-u #f "BIGAONESP"))
3649 (targ-op "##bignum.adigit-="         (targ-ifjump-simp-u #f "BIGAEQP"))
3650 (targ-op "##bignum.adigit-<"         (targ-ifjump-simp-u #f "BIGALESSP"))
3651 (targ-op "##bignum.adigit-zero?"     (targ-ifjump-simp-u #f "BIGAZEROP"))
3652 (targ-op "##bignum.adigit-negative?" (targ-ifjump-simp-u #f "BIGANEGATIVEP"))
3653 (targ-op "##bignum.->fixnum"         (targ-apply-simp-u #f #f "BIGTOFIX"))
3654 (targ-op "##bignum.<-fixnum"         (targ-apply-simpbig-u "BIGFROMFIX"))
3655 (targ-op "##bignum.adigit-shrink!"   (targ-apply-simp-u #f #t "BIGASHRINK"))
3656 (targ-op "##bignum.adigit-copy!"     (targ-apply-simp-u #f #t "BIGACOPY"))
3657 (targ-op "##bignum.adigit-cat!"      (targ-apply-simp-u #f #t "BIGACAT"))
3658 (targ-op "##bignum.adigit-bitwise-and!"(targ-apply-simp-u #f #t "BIGAAND"))
3659 (targ-op "##bignum.adigit-bitwise-ior!"(targ-apply-simp-u #f #t "BIGAIOR"))
3660 (targ-op "##bignum.adigit-bitwise-xor!"(targ-apply-simp-u #f #t "BIGAXOR"))
3661 (targ-op "##bignum.adigit-bitwise-not!"(targ-apply-simp-u #f #t "BIGANOT"))
3662
3663 (targ-op "##bignum.fdigit-length"    (targ-apply-simp-u #f #f "BIGFLENGTH"))
3664 (targ-op "##bignum.fdigit-ref"       (targ-apply-simp-u #f #f "BIGFREF"))
3665 (targ-op "##bignum.fdigit-set!"      (targ-apply-simp-u #f #t "BIGFSET"))
3666
3667 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3668
3669 (targ-op "##structure-direct-instance-of?"
3670          (targ-ifjump-simp-s #f "STRUCTUREDIOP"))
3671 (targ-op "##structure-type"
3672          (targ-ifjump-apply-u "STRUCTURETYPE"))
3673 (targ-op "##structure-type-set!"
3674          (targ-apply-simp-u #f #t "STRUCTURETYPESET"))
3675 (targ-op "##structure"
3676          (targ-apply-vector-u 'structure))
3677 (targ-op "##unchecked-structure-ref"
3678          (targ-ifjump-apply-u "UNCHECKEDSTRUCTUREREF"))
3679 (targ-op "##unchecked-structure-set!"
3680          (targ-apply-simp-u #f #t "UNCHECKEDSTRUCTURESET"))
3681
3682 (targ-op "##type-id"          (targ-apply-simp-u #f #f "TYPEID"))
3683 (targ-op "##type-name"        (targ-apply-simp-u #f #f "TYPENAME"))
3684 (targ-op "##type-flags"       (targ-apply-simp-u #f #f "TYPEFLAGS"))
3685 (targ-op "##type-super"       (targ-apply-simp-u #f #f "TYPESUPER"))
3686 (targ-op "##type-fields"      (targ-apply-simp-u #f #f "TYPEFIELDS"))
3687
3688 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3689
3690 (targ-op "##closure-length"   (targ-apply-simp-u #f #f "CLOSURELENGTH"))
3691 (targ-op "##closure-code"     (targ-apply-simp-u #f #f "CLOSURECODE"))
3692 (targ-op "##closure-ref"      (targ-apply-simp-u #f #f "CLOSUREREF"))
3693 (targ-op "##closure-set!"     (targ-apply-simp-u #f #t "CLOSURESET"))
3694
3695 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3696
3697 (targ-op "##global-var-ref"
3698          (targ-apply-simp-u #f #f "GLOBALVARREF"))
3699 (targ-op "##global-var-primitive-ref"
3700          (targ-apply-simp-u #f #f "GLOBALVARPRIMREF"))
3701 (targ-op "##global-var-set!"
3702          (targ-apply-simp-u #f #t "GLOBALVARSET"))
3703 (targ-op "##global-var-primitive-set!"
3704          (targ-apply-simp-u #f #t "GLOBALVARPRIMSET"))
3705
3706 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3707
3708 (targ-op "##make-promise"     (targ-apply-make-promise))
3709 (targ-op "##force"            (targ-apply-force))
3710 (targ-op "##void"             (targ-apply-simp-s #f #f "VOID"))
3711
3712 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3713
3714 (targ-op "##first-argument"   (targ-apply-first-argument))
3715 (targ-op "##check-heap-limit" (targ-apply-check-heap-limit))
3716
3717 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3718
3719 (targ-op "##current-thread"   (targ-apply-simp-s #f #f "CURRENTTHREAD"))
3720 (targ-op "##run-queue"        (targ-apply-simp-s #f #f "RUNQUEUE"))
3721
3722 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3723
3724 (targ-op
3725   "##c-code"
3726   (lambda (prim)
3727     (proc-obj-inlinable?-set! prim (lambda (env) #t))
3728     (proc-obj-inline-set!
3729       prim
3730       (lambda (opnds loc sn)
3731         (targ-use-all-res)
3732         (let ((n (length opnds)))
3733           (if (= n 0)
3734             (compiler-error
3735               "\"##c-code\" needs at least one argument")
3736             (let ((code (car opnds))
3737                   (args (map (lambda (opnd) (targ-opnd opnd))
3738                              (cdr opnds))))
3739               (if (and (obj? code)
3740                        (string? (obj-val code)))
3741                 (let loop ((i (- n 1))
3742                            (rev-args (reverse args))
3743                            (lst1 (list "{ " c-id-prefix "SCMOBJ "
3744                                        c-id-prefix "RESULT;"
3745                                        #\newline
3746                                        (obj-val code)
3747                                        #\newline))
3748                            (lst2 (list #\newline
3749                                        "}")))
3750                   (if (null? rev-args)
3751                     (begin
3752                       (targ-emit (cons 'append lst1))
3753                       (if loc
3754                         (targ-emit (targ-loc loc '("RESULT"))))
3755                       (targ-emit (cons 'append (reverse lst2))))
3756                     (let ((arg (car rev-args)))
3757                       (loop (- i 1)
3758                             (cdr rev-args)
3759                             (append
3760                               (list "#define " c-id-prefix "ARG" i " " arg
3761                                     #\newline)
3762                               lst1)
3763                             (append
3764                               (list #\newline
3765                                     i "ARG" c-id-prefix "#undef ")
3766                               lst2)))))
3767                 (compiler-error
3768                   "Argument 1 of \"##c-code\" must be a string constant")))))))))
3769
3770 )
3771
3772 (targ-setup-inlinable)
3773
3774 ;;;----------------------------------------------------------------------------
3775
3776 ;; Table of jump-inlinable operations (for 'jump' GVM instructions)
3777
3778 (define (targ-setup-jump-inlinable)
3779
3780 (targ-jump-inline "##thread-save!"
3781   (lambda (nb-args poll? safe?)
3782     (and (< 0 nb-args)
3783          (< nb-args 5)
3784          (let ((fs (frame-size targ-proc-exit-frame)))
3785            (targ-end-of-block-checks #t fs) ; force a poll
3786            (targ-emit (targ-adjust-stack fs))
3787            (targ-emit-jump-inline "THREAD_SAVE" safe? nb-args)
3788            (targ-rd-fp)
3789            (targ-wr-fp)
3790            (targ-rd-reg 0)
3791            (targ-wr-reg 0)
3792            (targ-wr-reg (+ targ-nb-arg-regs 1))
3793            #t))))
3794
3795 (targ-jump-inline "##thread-restore!"
3796   (lambda (nb-args poll? safe?)
3797     (and (< 1 nb-args)
3798          (< nb-args 6)
3799          (let ((fs (frame-size targ-proc-exit-frame)))
3800            (targ-end-of-block-checks poll? fs)
3801            (targ-emit (targ-adjust-stack fs))
3802            (targ-emit-jump-inline "THREAD_RESTORE" safe? nb-args)
3803            (targ-rd-fp)
3804            (targ-wr-fp)
3805            (targ-wr-reg 0)
3806            (targ-wr-reg (+ targ-nb-arg-regs 1))
3807            #t))))
3808
3809 (targ-jump-inline "##continuation-capture"
3810   (lambda (nb-args poll? safe?)
3811     (and (< 0 nb-args)
3812          (< nb-args 5)
3813          (let ((fs (frame-size targ-proc-exit-frame)))
3814            (targ-end-of-block-checks poll? fs)
3815            (targ-emit (targ-adjust-stack fs))
3816            (targ-emit-jump-inline "CONTINUATION_CAPTURE" safe? nb-args)
3817            (targ-rd-fp)
3818            (targ-wr-fp)
3819            (targ-pop-pcontext (targ-jump-info nb-args))
3820            (targ-push-pcontext (targ-label-info nb-args #t))
3821            #t))))
3822
3823 (targ-jump-inline "##continuation-graft-no-winding"
3824   (lambda (nb-args poll? safe?)
3825     (and (< 1 nb-args)
3826          (< nb-args 6)
3827          (let ((fs (frame-size targ-proc-exit-frame)))
3828            (targ-end-of-block-checks poll? fs)
3829            (targ-emit (targ-adjust-stack fs))
3830            (targ-emit-jump-inline "CONTINUATION_GRAFT_NO_WINDING" safe? nb-args)
3831            (targ-rd-fp)
3832            (targ-wr-fp)
3833            (targ-pop-pcontext (targ-jump-info nb-args))
3834            (targ-push-pcontext (targ-label-info (- nb-args 2) #t))
3835            #t))))
3836
3837 (targ-jump-inline "##continuation-return-no-winding"
3838   (lambda (nb-args poll? safe?)
3839     (and (= nb-args 2)
3840          (let ((fs (frame-size targ-proc-exit-frame)))
3841            (targ-end-of-block-checks poll? fs)
3842            (targ-emit (targ-adjust-stack fs))
3843            (targ-emit-jump-inline "CONTINUATION_RETURN_NO_WINDING" safe? nb-args)
3844            (targ-rd-fp)
3845            (targ-wr-fp)
3846            (targ-pop-pcontext (targ-jump-info nb-args))
3847            (targ-wr-reg 0)
3848            (targ-wr-reg 1)
3849            #t))))
3850
3851 )
3852
3853 (targ-setup-jump-inlinable)
3854
3855 ;;;----------------------------------------------------------------------------
3856
3857 ;; Table of procedure specializations
3858
3859 (define (targ-setup-specializations)
3860
3861 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3862
3863 (targ-spec "not"         (targ-s "##not"))
3864 (targ-spec "boolean?"    (targ-s "##boolean?"))
3865 (targ-spec "null?"       (targ-s "##null?"))
3866 (targ-spec "eq?"         (targ-s "##eq?"))
3867 (targ-spec "eof-object?" (targ-s "##eof-object?"))
3868
3869 (targ-spec "pair?"       (targ-s "##pair?"))
3870 (targ-spec "procedure?"  (targ-s "##procedure?"))
3871 (targ-spec "vector?"     (targ-s "##vector?"))
3872 (targ-spec "symbol?"     (targ-s "##symbol?"))
3873 (targ-spec "keyword?"    (targ-s "##keyword?"))
3874 (targ-spec "string?"     (targ-s "##string?"))
3875 (targ-spec "char?"       (targ-s "##char?"))
3876
3877 (targ-spec "fixnum?"     (targ-s "##fixnum?"))
3878 (targ-spec "flonum?"     (targ-s "##flonum?"))
3879
3880 (targ-spec "number?"     (targ-s "##number?"))
3881 (targ-spec "complex?"    (targ-s "##complex?"))
3882 (targ-spec "real?"       (targ-s "##real?"))
3883 (targ-spec "rational?"   (targ-s "##rational?"))
3884 (targ-spec "integer?"    (targ-s "##integer?"))
3885
3886 ;;the following primitives must check that their parameter is a number:
3887 ;;(targ-spec "exact?"      (targ-s "##exact?"))
3888 ;;(targ-spec "inexact?"    (targ-s "##inexact?"))
3889
3890 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3891
3892 (targ-spec "fx=" (targ-u "##fx="))
3893 (targ-spec "fl=" (targ-u "##fl="))
3894 (targ-spec "="   (targ-arith "fx=" "fl="))
3895
3896 (targ-spec "fx<" (targ-u "##fx<"))
3897 (targ-spec "fl<" (targ-u "##fl<"))
3898 (targ-spec "<"   (targ-arith "fx<" "fl<"))
3899
3900 (targ-spec "fx>" (targ-u "##fx>"))
3901 (targ-spec "fl>" (targ-u "##fl>"))
3902 (targ-spec ">"   (targ-arith "fx>" "fl>"))
3903
3904 (targ-spec "fx<=" (targ-u "##fx<="))
3905 (targ-spec "fl<=" (targ-u "##fl<="))
3906 (targ-spec "<="   (targ-arith "fx<=" "fl<="))
3907
3908 (targ-spec "fx>=" (targ-u "##fx>="))
3909 (targ-spec "fl>=" (targ-u "##fl>="))
3910 (targ-spec ">="   (targ-arith "fx>=" "fl>="))
3911
3912 (targ-spec "flinteger?" (targ-u "##flinteger?"))
3913
3914 (targ-spec "fxzero?" (targ-u "##fxzero?"))
3915 (targ-spec "flzero?" (targ-u "##flzero?"))
3916 (targ-spec "zero?"   (targ-arith "fxzero?" "flzero?"))
3917
3918 (targ-spec "fxpositive?" (targ-u "##fxpositive?"))
3919 (targ-spec "flpositive?" (targ-u "##flpositive?"))
3920 (targ-spec "positive?"   (targ-arith "fxpositive?" "flpositive?"))
3921
3922 (targ-spec "fxnegative?" (targ-u "##fxnegative?"))
3923 (targ-spec "flnegative?" (targ-u "##flnegative?"))
3924 (targ-spec "negative?"   (targ-arith "fxnegative?" "flnegative?"))
3925
3926 (targ-spec "fxodd?" (targ-u "##fxodd?"))
3927 (targ-spec "flodd?" (targ-u "##flodd?"))
3928 (targ-spec "odd?"   (targ-arith "fxodd?" "flodd?"))
3929
3930 (targ-spec "fxeven?" (targ-u "##fxeven?"))
3931 (targ-spec "fleven?" (targ-u "##fleven?"))
3932 (targ-spec "even?"   (targ-arith "fxeven?" "fleven?"))
3933
3934 (targ-spec "flfinite?" (targ-u "##flfinite?"))
3935 (targ-spec "finite?"   (targ-arith #f "flfinite?"))
3936
3937 (targ-spec "flinfinite?" (targ-u "##flinfinite?"))
3938 (targ-spec "infinite?"   (targ-arith #f "flinfinite?"))
3939
3940 (targ-spec "flnan?" (targ-u "##flnan?"))
3941 (targ-spec "nan?"   (targ-arith #f "flnan?"))
3942
3943 (targ-spec "fxmax" (targ-u "##fxmax"))
3944 (targ-spec "flmax" (targ-u "##flmax"))
3945 (targ-spec "max"   (targ-arith "fxmax" "flmax"))
3946
3947 (targ-spec "fxmin" (targ-u "##fxmin"))
3948 (targ-spec "flmin" (targ-u "##flmin"))
3949 (targ-spec "min"   (targ-arith "fxmin" "flmin"))
3950
3951 (targ-spec "fxwrap+" (targ-u "##fxwrap+"))
3952 (targ-spec "fx+"     (targ-u "##fx+"))
3953 (targ-spec "fl+"     (targ-u "##fl+"))
3954 (targ-spec "+"       (targ-arith "fx+" "fl+"))
3955
3956 (targ-spec "fxwrap*" (targ-u "##fxwrap*"))
3957 (targ-spec "fx*"     (targ-u "##fx*"))
3958 (targ-spec "fl*"     (targ-u "##fl*"))
3959 (targ-spec "*"       (targ-arith "fx*" "fl*"))
3960
3961 (targ-spec "fxwrap-" (targ-u "##fxwrap-"))
3962 (targ-spec "fx-"     (targ-u "##fx-"))
3963 (targ-spec "fl-"     (targ-u "##fl-"))
3964 (targ-spec "-"       (targ-arith "fx-" "fl-"))
3965
3966 (targ-spec "fl/"     (targ-u "##fl/"))
3967 (targ-spec "/"       (targ-arith #f "fl/"))
3968
3969 (targ-spec "fxwrapquotient" (targ-u "##fxwrapquotient"))
3970 (targ-spec "fxquotient"     (targ-u "##fxquotient"))
3971 (targ-spec "quotient"       (targ-arith "fxquotient" #f))
3972
3973 (targ-spec "fxremainder" (targ-u "##fxremainder"))
3974 (targ-spec "remainder"   (targ-arith "fxremainder" #f))
3975
3976 (targ-spec "fxmodulo" (targ-u "##fxmodulo"))
3977 (targ-spec "modulo"   (targ-arith "fxmodulo" #f))
3978
3979 (targ-spec "fxnot" (targ-u "##fxnot"))
3980
3981 (targ-spec "fxand" (targ-u "##fxand"))
3982
3983 (targ-spec "fxior" (targ-u "##fxior"))
3984
3985 (targ-spec "fxxor" (targ-u "##fxxor"))
3986
3987 (targ-spec "fxif" (targ-u "##fxif"))
3988
3989 (targ-spec "fxbit-count" (targ-u "##fxbit-count"))
3990
3991 (targ-spec "fxlength" (targ-u "##fxlength"))
3992
3993 (targ-spec "fxfirst-bit-set" (targ-u "##fxfirst-bit-set"))
3994
3995 (targ-spec "fxbit-set?" (targ-u "##fxbit-set?"))
3996
3997 (targ-spec "fxwraparithmetic-shift" (targ-u "##fxwraparithmetic-shift"))
3998 (targ-spec "fxarithmetic-shift"     (targ-u "##fxarithmetic-shift"))
3999 (targ-spec "arithmetic-shift"       (targ-arith "fxarithmetic-shift" #f))
4000
4001 (targ-spec "fxwraparithmetic-shift-left" (targ-u "##fxwraparithmetic-shift-left"))
4002 (targ-spec "fxarithmetic-shift-left"   (targ-u "##fxarithmetic-shift-left"))
4003 (targ-spec "fxarithmetic-shift-right"  (targ-u "##fxarithmetic-shift-right"))
4004 (targ-spec "fxwraplogical-shift-right" (targ-u "##fxwraplogical-shift-right"))
4005
4006 (targ-spec "fxwrapabs" (targ-u "##fxwrapabs"))
4007 (targ-spec "fxabs"     (targ-u "##fxabs"))
4008 (targ-spec "flabs"     (targ-u "##flabs"))
4009 (targ-spec "abs"       (targ-arith "fxabs" "flabs"))
4010
4011 (targ-spec "flfloor" (targ-u "##flfloor"))
4012 (targ-spec "floor"   (targ-arith #f "flfloor"))
4013
4014 (targ-spec "flceiling" (targ-u "##flceiling"))
4015 (targ-spec "ceiling"   (targ-arith #f "flceiling"))
4016
4017 (targ-spec "fltruncate" (targ-u "##fltruncate"))
4018 (targ-spec "truncate"   (targ-arith #f "fltruncate"))
4019
4020 (targ-spec "flround" (targ-u "##flround"))
4021 (targ-spec "round"   (targ-arith #f "flround"))
4022
4023 (targ-spec "flexp" (targ-u "##flexp"))
4024 (targ-spec "exp"   (targ-arith #f "flexp"))
4025
4026 (targ-spec "fllog" (targ-u "##fllog"))
4027 (targ-spec "log"   (targ-arith #f "fllog"))
4028
4029 (targ-spec "flsin" (targ-u "##flsin"))
4030 (targ-spec "sin"   (targ-arith #f "flsin"))
4031
4032 (targ-spec "flcos" (targ-u "##flcos"))
4033 (targ-spec "cos"   (targ-arith #f "flcos"))
4034
4035 (targ-spec "fltan" (targ-u "##fltan"))
4036 (targ-spec "tan"   (targ-arith #f "fltan"))
4037
4038 (targ-spec "flasin" (targ-u "##flasin"))
4039 (targ-spec "asin"   (targ-arith #f "flasin"))
4040
4041 (targ-spec "flacos" (targ-u "##flacos"))
4042 (targ-spec "acos"   (targ-arith #f "flacos"))
4043
4044 (targ-spec "flatan" (targ-u "##flatan"))
4045 (targ-spec "atan"   (targ-arith #f "flatan"))
4046
4047 (targ-spec "flexpt" (targ-u "##flexpt"))
4048 (targ-spec "expt"   (targ-arith #f "flexpt"))
4049
4050 (targ-spec "flsqrt" (targ-u "##flsqrt"))
4051 (targ-spec "sqrt"   (targ-arith #f "flsqrt"))
4052
4053 (targ-spec "fixnum->flonum" (targ-u "##fixnum->flonum"))
4054
4055 ;(targ-spec "exact->inexact" (targ-arith "##fixnum->flonum" #f))
4056 ;(targ-spec "inexact->exact" (targ-arith "##flonum->fixnum" #f))
4057
4058 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4059
4060 (targ-spec "char=?"     (targ-u "##char=?"))
4061 (targ-spec "char<?"     (targ-u "##char<?"))
4062 (targ-spec "char>?"     (targ-u "##char>?"))
4063 (targ-spec "char<=?"    (targ-u "##char<=?"))
4064 (targ-spec "char>=?"    (targ-u "##char>=?"))
4065
4066 (targ-spec "char-alphabetic?" (targ-u "##char-alphabetic?"))
4067 (targ-spec "char-numeric?"    (targ-u "##char-numeric?"))
4068 (targ-spec "char-whitespace?" (targ-u "##char-whitespace?"))
4069 (targ-spec "char-upper-case?" (targ-u "##char-upper-case?"))
4070 (targ-spec "char-lower-case?" (targ-u "##char-lower-case?"))
4071 (targ-spec "char->integer"    (targ-u "##char->fixnum"))
4072 (targ-spec "integer->char"    (targ-u "##fixnum->char"))
4073 (targ-spec "char-upcase"      (targ-u "##char-upcase"))
4074 (targ-spec "char-downcase"    (targ-u "##char-downcase"))
4075
4076 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4077
4078 (targ-spec "cons"       (targ-s "##cons"))
4079 (targ-spec "set-car!"   (targ-u "##set-car!"))
4080 (targ-spec "set-cdr!"   (targ-u "##set-cdr!"))
4081 (targ-spec "car"        (targ-u "##car"))
4082 (targ-spec "cdr"        (targ-u "##cdr"))
4083 (targ-spec "caar"       (targ-u "##caar"))
4084 (targ-spec "cadr"       (targ-u "##cadr"))
4085 (targ-spec "cdar"       (targ-u "##cdar"))
4086 (targ-spec "cddr"       (targ-u "##cddr"))
4087 (targ-spec "caaar"      (targ-u "##caaar"))
4088 (targ-spec "caadr"      (targ-u "##caadr"))
4089 (targ-spec "cadar"      (targ-u "##cadar"))
4090 (targ-spec "caddr"      (targ-u "##caddr"))
4091 (targ-spec "cdaar"      (targ-u "##cdaar"))
4092 (targ-spec "cdadr"      (targ-u "##cdadr"))
4093 (targ-spec "cddar"      (targ-u "##cddar"))
4094 (targ-spec "cdddr"      (targ-u "##cdddr"))
4095 (targ-spec "caaaar"     (targ-u "##caaaar"))
4096 (targ-spec "caaadr"     (targ-u "##caaadr"))
4097 (targ-spec "caadar"     (targ-u "##caadar"))
4098 (targ-spec "caaddr"     (targ-u "##caaddr"))
4099 (targ-spec "cadaar"     (targ-u "##cadaar"))
4100 (targ-spec "cadadr"     (targ-u "##cadadr"))
4101 (targ-spec "caddar"     (targ-u "##caddar"))
4102 (targ-spec "cadddr"     (targ-u "##cadddr"))
4103 (targ-spec "cdaaar"     (targ-u "##cdaaar"))
4104 (targ-spec "cdaadr"     (targ-u "##cdaadr"))
4105 (targ-spec "cdadar"     (targ-u "##cdadar"))
4106 (targ-spec "cdaddr"     (targ-u "##cdaddr"))
4107 (targ-spec "cddaar"     (targ-u "##cddaar"))
4108 (targ-spec "cddadr"     (targ-u "##cddadr"))
4109 (targ-spec "cdddar"     (targ-u "##cdddar"))
4110 (targ-spec "cddddr"     (targ-u "##cddddr"))
4111
4112 (targ-spec "list"       (targ-s "##list"))
4113
4114 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4115
4116 (targ-spec "will?"          (targ-s "##will?"))
4117 (targ-spec "make-will"      (targ-s "##make-will"))
4118 (targ-spec "will-testator"  (targ-u "##will-testator"))
4119
4120 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4121
4122 (targ-spec "box?"           (targ-s "##box?"))
4123 (targ-spec "box"            (targ-s "##box"))
4124 (targ-spec "unbox"          (targ-u "##unbox"))
4125 (targ-spec "set-box!"       (targ-u "##set-box!"))
4126
4127 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4128
4129 (targ-spec "values"         (targ-s "##values"))
4130
4131 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4132
4133 (targ-spec "string"         (targ-u "##string"))
4134 (targ-spec "string-length"  (targ-u "##string-length"))
4135 (targ-spec "string-ref"     (targ-u "##string-ref"))
4136 (targ-spec "string-set!"    (targ-u "##string-set!"))
4137
4138 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4139
4140 (targ-spec "vector"         (targ-s "##vector"))
4141 (targ-spec "vector-length"  (targ-u "##vector-length"))
4142 (targ-spec "vector-ref"     (targ-u "##vector-ref"))
4143 (targ-spec "vector-set!"    (targ-u "##vector-set!"))
4144
4145 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4146
4147 (targ-spec "s8vector?"        (targ-s "##s8vector?"))
4148 (targ-spec "s8vector"         (targ-u "##s8vector"))
4149 (targ-spec "s8vector-length"  (targ-u "##s8vector-length"))
4150 (targ-spec "s8vector-ref"     (targ-u "##s8vector-ref"))
4151 (targ-spec "s8vector-set!"    (targ-u "##s8vector-set!"))
4152
4153 (targ-spec "u8vector?"        (targ-s "##u8vector?"))
4154 (targ-spec "u8vector"         (targ-u "##u8vector"))
4155 (targ-spec "u8vector-length"  (targ-u "##u8vector-length"))
4156 (targ-spec "u8vector-ref"     (targ-u "##u8vector-ref"))
4157 (targ-spec "u8vector-set!"    (targ-u "##u8vector-set!"))
4158
4159 (targ-spec "s16vector?"       (targ-s "##s16vector?"))
4160 (targ-spec "s16vector"        (targ-u "##s16vector"))
4161 (targ-spec "s16vector-length" (targ-u "##s16vector-length"))
4162 (targ-spec "s16vector-ref"    (targ-u "##s16vector-ref"))
4163 (targ-spec "s16vector-set!"   (targ-u "##s16vector-set!"))
4164
4165 (targ-spec "u16vector?"       (targ-s "##u16vector?"))
4166 (targ-spec "u16vector"        (targ-u "##u16vector"))
4167 (targ-spec "u16vector-length" (targ-u "##u16vector-length"))
4168 (targ-spec "u16vector-ref"    (targ-u "##u16vector-ref"))
4169 (targ-spec "u16vector-set!"   (targ-u "##u16vector-set!"))
4170
4171 (targ-spec "s32vector?"       (targ-s "##s32vector?"))
4172 (targ-spec "s32vector"        (targ-u "##s32vector"))
4173 (targ-spec "s32vector-length" (targ-u "##s32vector-length"))
4174 (targ-spec "s32vector-ref"    (targ-u "##s32vector-ref"))
4175 (targ-spec "s32vector-set!"   (targ-u "##s32vector-set!"))
4176
4177 (targ-spec "u32vector?"       (targ-s "##u32vector?"))
4178 (targ-spec "u32vector"        (targ-u "##u32vector"))
4179 (targ-spec "u32vector-length" (targ-u "##u32vector-length"))
4180 (targ-spec "u32vector-ref"    (targ-u "##u32vector-ref"))
4181 (targ-spec "u32vector-set!"   (targ-u "##u32vector-set!"))
4182
4183 (targ-spec "s64vector?"       (targ-s "##s64vector?"))
4184 (targ-spec "s64vector"        (targ-u "##s64vector"))
4185 (targ-spec "s64vector-length" (targ-u "##s64vector-length"))
4186 (targ-spec "s64vector-ref"    (targ-u "##s64vector-ref"))
4187 (targ-spec "s64vector-set!"   (targ-u "##s64vector-set!"))
4188
4189 (targ-spec "u64vector?"       (targ-s "##u64vector?"))
4190 (targ-spec "u64vector"        (targ-u "##u64vector"))
4191 (targ-spec "u64vector-length" (targ-u "##u64vector-length"))
4192 (targ-spec "u64vector-ref"    (targ-u "##u64vector-ref"))
4193 (targ-spec "u64vector-set!"   (targ-u "##u64vector-set!"))
4194
4195 (targ-spec "f32vector?"       (targ-s "##f32vector?"))
4196 (targ-spec "f32vector"        (targ-u "##f32vector"))
4197 (targ-spec "f32vector-length" (targ-u "##f32vector-length"))
4198 (targ-spec "f32vector-ref"    (targ-u "##f32vector-ref"))
4199 (targ-spec "f32vector-set!"   (targ-u "##f32vector-set!"))
4200
4201 (targ-spec "f64vector?"       (targ-s "##f64vector?"))
4202 (targ-spec "f64vector"        (targ-u "##f64vector"))
4203 (targ-spec "f64vector-length" (targ-u "##f64vector-length"))
4204 (targ-spec "f64vector-ref"    (targ-u "##f64vector-ref"))
4205 (targ-spec "f64vector-set!"   (targ-u "##f64vector-set!"))
4206
4207 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4208
4209 (targ-spec "##structure-ref"  (targ-u "##unchecked-structure-ref"))
4210 (targ-spec "##structure-set!" (targ-u "##unchecked-structure-set!"))
4211
4212 (targ-spec "##direct-structure-ref"  (targ-u "##unchecked-structure-ref"))
4213 (targ-spec "##direct-structure-set!" (targ-u "##unchecked-structure-set!"))
4214
4215 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4216
4217 (targ-spec "touch"            (targ-s "##force"))
4218 (targ-spec "force"            (targ-s "##force"))
4219 (targ-spec "void"             (targ-s "##void"))
4220
4221 (targ-spec "eqv?"             (targ-s-eqv?))
4222 (targ-spec "##eqv?"           (targ-s-eqv?))
4223 (targ-spec "equal?"           (targ-s-equal?))
4224 (targ-spec "##equal?"         (targ-s-equal?))
4225
4226 (targ-spec "call/cc"          (targ-s "##call-with-current-continuation"))
4227 (targ-spec "call-with-current-continuation"
4228                               (targ-s "##call-with-current-continuation"))
4229
4230 (targ-spec "continuation?"        (targ-s "##continuation?"))
4231 (targ-spec "continuation-capture" (targ-s "##continuation-capture"))
4232 (targ-spec "continuation-graft"   (targ-s "##continuation-graft"))
4233 (targ-spec "continuation-return"  (targ-s "##continuation-return"))
4234
4235 (targ-spec "current-thread"   (targ-s "##current-thread"))
4236 )
4237
4238 (targ-setup-specializations)
4239
4240 ;;;----------------------------------------------------------------------------
4241
4242 ;; Table of procedure call simplifiers
4243
4244 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4245
4246 ;; Procedure call simplification
4247
4248 (define (targ-simp name . folders)
4249   (let ((proc (targ-get-prim-info name)))
4250     (proc-obj-simplify-set!
4251      proc
4252      (lambda (ptree args)
4253        (let loop ((lst folders))
4254          (if (pair? lst)
4255            (let ((folder (car lst)))
4256              (or (folder ptree args)
4257                  (loop (cdr lst))))
4258            #f))))))
4259
4260 (define (targ-constant-folder op . type-patterns)
4261   (targ-constant-folder-with-ptree-maker
4262    (lambda (ptree arg-vals)
4263      (let ((result (apply op arg-vals)))
4264        (new-cst (node-source ptree) (node-env ptree)
4265          result)))
4266    type-patterns))
4267
4268 (define targ-constant-folder-gen targ-constant-folder)
4269
4270 (define (targ-constant-folder-fix op . type-patterns)
4271   (targ-constant-folder-with-ptree-maker
4272    (lambda (ptree arg-vals)
4273      (let ((result (apply op arg-vals)))
4274        (and (or (not (number? result))
4275                 (targ-fixnum32? result))
4276             (new-cst (node-source ptree) (node-env ptree)
4277               result))))
4278    type-patterns))
4279
4280 (define (targ-constant-folder-flo op . type-patterns)
4281   (targ-constant-folder-with-ptree-maker
4282    (lambda (ptree arg-vals)
4283      (let ((result (apply op arg-vals)))
4284        (and (or (not (number? result))
4285                 (targ-flonum? result))
4286             (new-cst (node-source ptree) (node-env ptree)
4287               result))))
4288    type-patterns))
4289
4290 (define (targ-constant-folder-with-ptree-maker ptree-maker type-patterns)
4291   (let ((type-patterns
4292          (if (null? type-patterns)
4293            (list (lambda (obj) #t))
4294            type-patterns)))
4295     (lambda (ptree args)
4296
4297       (define (match? args type-pattern)
4298         (if (pair? args)
4299           (cond ((pair? type-pattern)
4300                  (and ((car type-pattern) (car args))
4301                       (match? (cdr args) (cdr type-pattern))))
4302                 ((null? type-pattern)
4303                  #f)
4304                 (else
4305                  (and (type-pattern (car args))
4306                       (match? (cdr args) type-pattern))))
4307           (not (pair? type-pattern))))
4308
4309       (and (every? cst? args) ; are all arguments constants?
4310            (let ((arg-vals (map cst-val args)))
4311              (let loop ((type-pats type-patterns))
4312                (if (pair? type-pats)
4313                  (if (match? arg-vals (car type-pats))
4314                    (ptree-maker ptree arg-vals)
4315                    (loop (cdr type-pats)))
4316                  #f)))))))
4317
4318 (define (targ-constant-folder-ref op get-length type?)
4319   (lambda (ptree args)
4320     (and (every? cst? args) ; are all arguments constants?
4321          (let* ((arg-vals (map cst-val args))
4322                 (vect (car arg-vals))
4323                 (index (cadr arg-vals)))
4324            (and (type? vect)
4325                 (integer? index)
4326                 (exact? index)
4327                 (not (< index 0))
4328                 (< index (get-length vect))
4329                 (let ((result (op vect index)))
4330                   (new-cst (node-source ptree) (node-env ptree)
4331                     result)))))))
4332
4333 (define (targ-setup-simplifiers)
4334
4335 (define (num? obj) (targ-number? obj))
4336 (define (nz-num? obj) (targ-nonzero-number? obj))
4337
4338 (define (int? obj) (targ-integer? obj))
4339 (define (nz-int? obj) (targ-nonzero-integer? obj))
4340
4341 (define (flo? obj) (targ-flonum? obj))
4342 (define (nz-flo? obj) (targ-nonzero-flonum? obj))
4343
4344 (define (fix32? obj) (targ-fixnum32? obj))
4345 (define (nz-fix32? obj) (targ-nonzero-fixnum32? obj))
4346
4347 (define (not-bigfix? obj)
4348   (not (and (targ-fixnum64? obj) (not (targ-fixnum32? obj)))))
4349
4350 (define (mem-alloc? obj)
4351   (let ((type (targ-obj-type obj)))
4352     (or (eq? type 'pair)
4353         (and (eq? type 'subtyped)
4354              (not-bigfix? obj)))))
4355
4356 (define (any obj) #t)
4357
4358 (define (alist? obj) (and (list? obj) (every? pair? obj)))
4359
4360 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4361
4362 (targ-simp "##not"            (targ-constant-folder false-object?  ))
4363 (targ-simp "boolean?"         (targ-constant-folder (lambda (obj)
4364                                                       (or (false-object? obj)
4365                                                           (eq? obj #t)))))
4366 (targ-simp "##eqv?"           (targ-constant-folder eqv?           ))
4367 (targ-simp "##eq?"            (targ-constant-folder eq?            ))
4368 (targ-simp "equal?"           (targ-constant-folder equal?         ))
4369 (targ-simp "##mem-allocated?" (targ-constant-folder (lambda (obj)
4370                                                       (case (targ-obj-type obj)
4371                                                         ((subtyped pair) #t)
4372                                                         (else            #f)))
4373                                                     not-bigfix?))
4374 (targ-simp "##subtyped?"      (targ-constant-folder (lambda (obj)
4375                                                       (case (targ-obj-type obj)
4376                                                         ((subtyped) #t)
4377                                                         (else       #f)))
4378                                                     not-bigfix?))
4379 (targ-simp "##subtype"        (targ-constant-folder targ-obj-subtype-integer
4380                                                     mem-alloc?))
4381 (targ-simp "##pair?"          (targ-constant-folder pair?          ))
4382 ;(targ-simp "##cons"           (targ-constant-folder cons           ))
4383 (targ-simp "car"              (targ-constant-folder car            pair?))
4384 (targ-simp "##car"            (targ-constant-folder car            pair?))
4385 (targ-simp "cdr"              (targ-constant-folder cdr            pair?))
4386 (targ-simp "##cdr"            (targ-constant-folder cdr            pair?))
4387 ;(targ-simp "caar"             (targ-constant-folder caar           ))
4388 ;(targ-simp "cadr"             (targ-constant-folder cadr           ))
4389 ;(targ-simp "cdar"             (targ-constant-folder cdar           ))
4390 ;(targ-simp "cddr"             (targ-constant-folder cddr           ))
4391 ;(targ-simp "caaar"            (targ-constant-folder caaar          ))
4392 ;(targ-simp "caadr"            (targ-constant-folder caadr          ))
4393 ;(targ-simp "cadar"            (targ-constant-folder cadar          ))
4394 ;(targ-simp "caddr"            (targ-constant-folder caddr          ))
4395 ;(targ-simp "cdaar"            (targ-constant-folder cdaar          ))
4396 ;(targ-simp "cdadr"            (targ-constant-folder cdadr          ))
4397 ;(targ-simp "cddar"            (targ-constant-folder cddar          ))
4398 ;(targ-simp "cdddr"            (targ-constant-folder cdddr          ))
4399 ;(targ-simp "caaaar"           (targ-constant-folder caaaar         ))
4400 ;(targ-simp "caaadr"           (targ-constant-folder caaadr         ))
4401 ;(targ-simp "caadar"           (targ-constant-folder caadar         ))
4402 ;(targ-simp "caaddr"           (targ-constant-folder caaddr         ))
4403 ;(targ-simp "cadaar"           (targ-constant-folder cadaar         ))
4404 ;(targ-simp "cadadr"           (targ-constant-folder cadadr         ))
4405 ;(targ-simp "caddar"           (targ-constant-folder caddar         ))
4406 ;(targ-simp "cadddr"           (targ-constant-folder cadddr         ))
4407 ;(targ-simp "cdaaar"           (targ-constant-folder cdaaar         ))
4408 ;(targ-simp "cdaadr"           (targ-constant-folder cdaadr         ))
4409 ;(targ-simp "cdadar"           (targ-constant-folder cdadar         ))
4410 ;(targ-simp "cdaddr"           (targ-constant-folder cdaddr         ))
4411 ;(targ-simp "cddaar"           (targ-constant-folder cddaar         ))
4412 ;(targ-simp "cddadr"           (targ-constant-folder cddadr         ))
4413 ;(targ-simp "cdddar"           (targ-constant-folder cdddar         ))
4414 ;(targ-simp "cddddr"           (targ-constant-folder cddddr         ))
4415 (targ-simp "##null?"          (targ-constant-folder null?          ))
4416 (targ-simp "list?"            (targ-constant-folder list?          ))
4417 ;(targ-simp "list"             (targ-constant-folder list           ))
4418 (targ-simp "length"           (targ-constant-folder length         list?))
4419 ;(targ-simp "append"           (targ-constant-folder append         list?))
4420 ;(targ-simp "reverse"          (targ-constant-folder reverse        list?))
4421 (targ-simp "list-ref"         (targ-constant-folder-ref
4422                                list-ref
4423                                length
4424                                list?))
4425 (targ-simp "memq"             (targ-constant-folder memq
4426                                                     (list any list?)))
4427 (targ-simp "memv"             (targ-constant-folder memv
4428                                                     (list any list?)))
4429 (targ-simp "member"           (targ-constant-folder member
4430                                                     (list any list?)))
4431 (targ-simp "assq"             (targ-constant-folder assq
4432                                                     (list any alist?)))
4433 (targ-simp "assv"             (targ-constant-folder assv
4434                                                     (list any alist?)))
4435 (targ-simp "assoc"            (targ-constant-folder assoc
4436                                                     (list any alist?)))
4437 (targ-simp "##symbol?"        (targ-constant-folder symbol-object? ))
4438 ;(targ-simp "symbol->string"   (targ-constant-folder symbol->string
4439 ;;                                                    symbol-object?))
4440 (targ-simp "string->symbol"   (targ-constant-folder string->symbol ))
4441 (targ-simp "number?"          (targ-constant-folder number?        ))
4442 (targ-simp "complex?"         (targ-constant-folder complex?       ))
4443 (targ-simp "real?"            (targ-constant-folder real?          ))
4444 (targ-simp "rational?"        (targ-constant-folder rational?      ))
4445 (targ-simp "integer?"         (targ-constant-folder integer?       ))
4446 (targ-simp "exact?"           (targ-constant-folder exact?         num?))
4447 (targ-simp "inexact?"         (targ-constant-folder inexact?       num?))
4448 (targ-simp "="                (targ-constant-folder =              num?))
4449 (targ-simp "##fx="       (targ-constant-folder =              fix32?))
4450 (targ-simp "##fixnum.="       (targ-constant-folder =              fix32?))
4451 (targ-simp "##fl="       (targ-constant-folder =              flo?))
4452 (targ-simp "##flonum.="       (targ-constant-folder =              flo?))
4453 (targ-simp "<"                (targ-constant-folder <              real?))
4454 (targ-simp "##fx<"       (targ-constant-folder <              fix32?))
4455 (targ-simp "##fixnum.<"       (targ-constant-folder <              fix32?))
4456 (targ-simp "##fl<"       (targ-constant-folder <              flo?))
4457 (targ-simp "##flonum.<"       (targ-constant-folder <              flo?))
4458 (targ-simp ">"                (targ-constant-folder >              real?))
4459 (targ-simp "##fx>"       (targ-constant-folder >              fix32?))
4460 (targ-simp "##fixnum.>"       (targ-constant-folder >              fix32?))
4461 (targ-simp "##fl>"       (targ-constant-folder >              flo?))
4462 (targ-simp "##flonum.>"       (targ-constant-folder >              flo?))
4463 (targ-simp "<="               (targ-constant-folder <=             real?))
4464 (targ-simp "##fx<="      (targ-constant-folder <=             fix32?))
4465 (targ-simp "##fixnum.<="      (targ-constant-folder <=             fix32?))
4466 (targ-simp "##fl<="      (targ-constant-folder <=             flo?))
4467 (targ-simp "##flonum.<="      (targ-constant-folder <=             flo?))
4468 (targ-simp ">="               (targ-constant-folder >=             real?))
4469 (targ-simp "##fx>="      (targ-constant-folder >=             fix32?))
4470 (targ-simp "##fixnum.>="      (targ-constant-folder >=             fix32?))
4471 (targ-simp "##fl>="      (targ-constant-folder >=             flo?))
4472 (targ-simp "##flonum.>="      (targ-constant-folder >=             flo?))
4473 (targ-simp "zero?"            (targ-constant-folder zero?          num?))
4474 (targ-simp "##fxzero?"   (targ-constant-folder zero?          fix32?))
4475 (targ-simp "##fixnum.zero?"   (targ-constant-folder zero?          fix32?))
4476 (targ-simp "##flzero?"   (targ-constant-folder zero?          flo?))
4477 (targ-simp "##flonum.zero?"   (targ-constant-folder zero?          flo?))
4478 (targ-simp "positive?"         (targ-constant-folder positive?     real?))
4479 (targ-simp "##fxpositive?"(targ-constant-folder positive?     fix32?))
4480 (targ-simp "##fixnum.positive?"(targ-constant-folder positive?     fix32?))
4481 (targ-simp "##flpositive?"(targ-constant-folder positive?     flo?))
4482 (targ-simp "##flonum.positive?"(targ-constant-folder positive?     flo?))
4483 (targ-simp "negative?"         (targ-constant-folder negative?     real?))
4484 (targ-simp "##fxnegative?"(targ-constant-folder negative?     fix32?))
4485 (targ-simp "##fixnum.negative?"(targ-constant-folder negative?     fix32?))
4486 (targ-simp "##flnegative?"(targ-constant-folder negative?     flo?))
4487 (targ-simp "##flonum.negative?"(targ-constant-folder negative?     flo?))
4488 (targ-simp "odd?"             (targ-constant-folder odd?           int?))
4489 (targ-simp "##fxodd?"    (targ-constant-folder odd?           fix32?))
4490 (targ-simp "##fixnum.odd?"    (targ-constant-folder odd?           fix32?))
4491 (targ-simp "##flodd?"    (targ-constant-folder odd?           flo?))
4492 (targ-simp "##flonum.odd?"    (targ-constant-folder odd?           flo?))
4493 (targ-simp "even?"            (targ-constant-folder even?          int?))
4494 (targ-simp "##fxeven?"   (targ-constant-folder even?          fix32?))
4495 (targ-simp "##fixnum.even?"   (targ-constant-folder even?          fix32?))
4496 (targ-simp "##fleven?"   (targ-constant-folder even?          flo?))
4497 (targ-simp "##flonum.even?"   (targ-constant-folder even?          flo?))
4498 (targ-simp "max"              (targ-constant-folder-gen max        real?))
4499 (targ-simp "##fxmax"     (targ-constant-folder-fix max        fix32?))
4500 (targ-simp "##fixnum.max"     (targ-constant-folder-fix max        fix32?))
4501 (targ-simp "##flmax"     (targ-constant-folder-flo max        flo?))
4502 (targ-simp "##flonum.max"     (targ-constant-folder-flo max        flo?))
4503 (targ-simp "min"              (targ-constant-folder-gen min        real?))
4504 (targ-simp "##fxmin"     (targ-constant-folder-fix min        fix32?))
4505 (targ-simp "##fixnum.min"     (targ-constant-folder-fix min        fix32?))
4506 (targ-simp "##flmin"     (targ-constant-folder-flo min        flo?))
4507 (targ-simp "##flonum.min"     (targ-constant-folder-flo min        flo?))
4508 (targ-simp "+"                (targ-constant-folder-gen +          num?))
4509 (targ-simp "##fxwrap+"   (targ-constant-folder-fix +          fix32?))
4510 (targ-simp "##fixnum.wrap+"   (targ-constant-folder-fix +          fix32?))
4511 (targ-simp "##fx+"       (targ-constant-folder-fix +          fix32?))
4512 (targ-simp "##fixnum.+"       (targ-constant-folder-fix +          fix32?))
4513 (targ-simp "##fx+?"      (targ-constant-folder-fix +          fix32?))
4514 (targ-simp "##fixnum.+?"      (targ-constant-folder-fix +          fix32?))
4515 (targ-simp "##fl+"       (targ-constant-folder-flo +          flo?));;;;;;;;;;must return 0.0 when 0 args
4516 (targ-simp "##flonum.+"       (targ-constant-folder-flo +          flo?));;;;;;;;;;must return 0.0 when 0 args
4517 (targ-simp "*"                (targ-constant-folder-gen *          num?))
4518 (targ-simp "##fxwrap*"   (targ-constant-folder-fix *          fix32?))
4519 (targ-simp "##fixnum.wrap*"   (targ-constant-folder-fix *          fix32?))
4520 (targ-simp "##fx*"       (targ-constant-folder-fix *          fix32?))
4521 (targ-simp "##fixnum.*"       (targ-constant-folder-fix *          fix32?))
4522 (targ-simp "##fx*?"      (targ-constant-folder-fix *          fix32?))
4523 (targ-simp "##fixnum.*?"      (targ-constant-folder-fix *          fix32?))
4524 (targ-simp "##fl*"       (targ-constant-folder-flo *          flo?));;;;;;;;;;must return 1.0 when 0 args
4525 (targ-simp "##flonum.*"       (targ-constant-folder-flo *          flo?));;;;;;;;;;must return 1.0 when 0 args
4526 (targ-simp "-"                (targ-constant-folder-gen -          num?))
4527 (targ-simp "##fxwrap-"   (targ-constant-folder-fix -          fix32?))
4528 (targ-simp "##fixnum.wrap-"   (targ-constant-folder-fix -          fix32?))
4529 (targ-simp "##fx-"       (targ-constant-folder-fix -          fix32?))
4530 (targ-simp "##fixnum.-"       (targ-constant-folder-fix -          fix32?))
4531 (targ-simp "##fx-?"      (targ-constant-folder-fix -          fix32?))
4532 (targ-simp "##fixnum.-?"      (targ-constant-folder-fix -          fix32?))
4533 (targ-simp "##fl-"       (targ-constant-folder-flo -          flo?))
4534 (targ-simp "##flonum.-"       (targ-constant-folder-flo -          flo?))
4535 (targ-simp "/"                (targ-constant-folder-gen /
4536                                                         (list nz-num?)
4537                                                         (cons num?
4538                                                               (cons nz-num?
4539                                                                     nz-num?))))
4540 (targ-simp "##fl/"       (targ-constant-folder-flo /
4541                                                         (list nz-flo?)
4542                                                         (cons flo?
4543                                                               (cons nz-flo?
4544                                                                     nz-flo?))))
4545 (targ-simp "##flonum./"       (targ-constant-folder-flo /
4546                                                         (list nz-flo?)
4547                                                         (cons flo?
4548                                                               (cons nz-flo?
4549                                                                     nz-flo?))))
4550 (targ-simp "abs"              (targ-constant-folder-gen abs        real?))
4551 (targ-simp "##flabs"     (targ-constant-folder-flo abs        flo?))
4552 (targ-simp "##flonum.abs"     (targ-constant-folder-flo abs        flo?))
4553 (targ-simp "quotient"         (targ-constant-folder-gen quotient
4554                                                         (list int? nz-int?)))
4555 (targ-simp "##fxwrapquotient"(targ-constant-folder-fix quotient
4556                                                             (list fix32? nz-fix32?)))
4557 (targ-simp "##fixnum.wrapquotient"(targ-constant-folder-fix quotient
4558                                                             (list fix32? nz-fix32?)))
4559 (targ-simp "##fxquotient"(targ-constant-folder-fix quotient
4560                                                         (list fix32? nz-fix32?)))
4561 (targ-simp "##fixnum.quotient"(targ-constant-folder-fix quotient
4562                                                         (list fix32? nz-fix32?)))
4563 (targ-simp "remainder"        (targ-constant-folder-gen remainder
4564                                                         (list int? nz-int?)))
4565 (targ-simp "##fxremainder"(targ-constant-folder-fix remainder
4566                                                         (list fix32? nz-fix32?)))
4567 (targ-simp "##fixnum.remainder"(targ-constant-folder-fix remainder
4568                                                         (list fix32? nz-fix32?)))
4569 (targ-simp "modulo"           (targ-constant-folder-gen modulo
4570                                                         (list int? nz-int?)))
4571 (targ-simp "##fxmodulo"  (targ-constant-folder-fix modulo
4572                                                         (list fix32? nz-fix32?)))
4573 (targ-simp "##fixnum.modulo"  (targ-constant-folder-fix modulo
4574                                                         (list fix32? nz-fix32?)))
4575 (targ-simp "gcd"              (targ-constant-folder-gen gcd        int?))
4576 (targ-simp "lcm"              (targ-constant-folder-gen lcm        int?))
4577 (targ-simp "numerator"        (targ-constant-folder-gen numerator  rational?))
4578 (targ-simp "denominator"      (targ-constant-folder-gen denominator rational?))
4579 (targ-simp "floor"            (targ-constant-folder-gen floor      real?))
4580 (targ-simp "##flfloor"   (targ-constant-folder-flo floor      flo?))
4581 (targ-simp "##flonum.floor"   (targ-constant-folder-flo floor      flo?))
4582 (targ-simp "ceiling"          (targ-constant-folder-gen ceiling    real?))
4583 (targ-simp "##flceiling" (targ-constant-folder-flo ceiling    flo?))
4584 (targ-simp "##flonum.ceiling" (targ-constant-folder-flo ceiling    flo?))
4585 (targ-simp "truncate"         (targ-constant-folder-gen truncate   real?))
4586 (targ-simp "##fltruncate"(targ-constant-folder-flo truncate   flo?))
4587 (targ-simp "##flonum.truncate"(targ-constant-folder-flo truncate   flo?))
4588 (targ-simp "round"            (targ-constant-folder-gen round      real?))
4589 (targ-simp "##flround"   (targ-constant-folder-flo round      flo?))
4590 (targ-simp "##flonum.round"   (targ-constant-folder-flo round      flo?))
4591 (targ-simp "rationalize"      (targ-constant-folder-gen rationalize real?))
4592 (targ-simp "exp"              (targ-constant-folder-gen exp        num?))
4593 (targ-simp "##flexp"     (targ-constant-folder-flo exp        flo?))
4594 (targ-simp "##flonum.exp"     (targ-constant-folder-flo exp        flo?))
4595 (targ-simp "log"              (targ-constant-folder-gen log        nz-num?))
4596 (targ-simp "##fllog"     (targ-constant-folder-flo log        nz-flo?))
4597 (targ-simp "##flonum.log"     (targ-constant-folder-flo log        nz-flo?))
4598 (targ-simp "sin"              (targ-constant-folder-gen sin        num?))
4599 (targ-simp "##flsin"     (targ-constant-folder-flo sin        flo?))
4600 (targ-simp "##flonum.sin"     (targ-constant-folder-flo sin        flo?))
4601 (targ-simp "cos"              (targ-constant-folder-gen cos        num?))
4602 (targ-simp "##flcos"     (targ-constant-folder-flo cos        flo?))
4603 (targ-simp "##flonum.cos"     (targ-constant-folder-flo cos        flo?))
4604 (targ-simp "tan"              (targ-constant-folder-gen tan        num?))
4605 (targ-simp "##fltan"     (targ-constant-folder-flo tan        flo?))
4606 (targ-simp "##flonum.tan"     (targ-constant-folder-flo tan        flo?))
4607 (targ-simp "asin"             (targ-constant-folder-gen asin       num?))
4608 (targ-simp "##flasin"    (targ-constant-folder-flo asin       flo?))
4609 (targ-simp "##flonum.asin"    (targ-constant-folder-flo asin       flo?))
4610 (targ-simp "acos"             (targ-constant-folder-gen acos       num?))
4611 (targ-simp "##flacos"    (targ-constant-folder-flo acos       flo?))
4612 (targ-simp "##flonum.acos"    (targ-constant-folder-flo acos       flo?))
4613 (targ-simp "atan"             (targ-constant-folder-gen atan       num?))
4614 (targ-simp "##flatan"    (targ-constant-folder-flo atan       flo?))
4615 (targ-simp "##flonum.atan"    (targ-constant-folder-flo atan       flo?))
4616 (targ-simp "expt"             (targ-constant-folder-gen expt       num?))
4617 (targ-simp "##flexpt"    (targ-constant-folder-flo expt       flo?))
4618 (targ-simp "##flonum.expt"    (targ-constant-folder-flo expt       flo?))
4619 (targ-simp "sqrt"             (targ-constant-folder-gen sqrt       num?))
4620 (targ-simp "##flsqrt"    (targ-constant-folder-flo sqrt       flo?))
4621 (targ-simp "##flonum.sqrt"    (targ-constant-folder-flo sqrt       flo?))
4622 (targ-simp "expt"             (targ-constant-folder-gen expt       num?))
4623 (targ-simp "##flonum->fixnum"(targ-constant-folder-flo exact->inexact fix32?))
4624 (targ-simp "##flonum.<-fixnum"(targ-constant-folder-flo exact->inexact fix32?))
4625
4626 (targ-simp "make-rectangular" (targ-constant-folder-gen make-rectangular real?))
4627 (targ-simp "make-polar"       (targ-constant-folder-gen make-polar     real?))
4628 (targ-simp "real-part"        (targ-constant-folder-gen real-part      num?))
4629 (targ-simp "imag-part"        (targ-constant-folder-gen imag-part      num?))
4630 (targ-simp "magnitude"        (targ-constant-folder-gen magnitude      num?))
4631 (targ-simp "angle"            (targ-constant-folder-gen angle          num?))
4632 (targ-simp "exact->inexact"   (targ-constant-folder-gen exact->inexact num?))
4633 (targ-simp "inexact->exact"   (targ-constant-folder-gen inexact->exact num?))
4634 ;(targ-simp "number->string"   (targ-constant-folder number->string num?))
4635 (targ-simp "string->number"   (targ-constant-folder string->number string?))
4636
4637 (targ-simp "##char?"          (targ-constant-folder char?          ))
4638 (targ-simp "char=?"           (targ-constant-folder char=?         char?))
4639 (targ-simp "char<?"           (targ-constant-folder char<?         char?))
4640 (targ-simp "char>?"           (targ-constant-folder char>?         char?))
4641 (targ-simp "char<=?"          (targ-constant-folder char<=?        char?))
4642 (targ-simp "char>=?"          (targ-constant-folder char>=?        char?))
4643 (targ-simp "char-ci=?"        (targ-constant-folder char-ci=?      char?))
4644 (targ-simp "char-ci<?"        (targ-constant-folder char-ci<?      char?))
4645 (targ-simp "char-ci>?"        (targ-constant-folder char-ci>?      char?))
4646 (targ-simp "char-ci<=?"       (targ-constant-folder char-ci<=?     char?))
4647 (targ-simp "char-ci>=?"       (targ-constant-folder char-ci>=?     char?))
4648 (targ-simp "char-alphabetic?" (targ-constant-folder char-alphabetic? char?))
4649 (targ-simp "char-numeric?"    (targ-constant-folder char-numeric?  char?))
4650 (targ-simp "char-whitespace?" (targ-constant-folder char-whitespace? char?))
4651 (targ-simp "char-upper-case?" (targ-constant-folder char-upper-case? char?))
4652 (targ-simp "char-lower-case?" (targ-constant-folder char-lower-case? char?))
4653 (targ-simp "char->integer"    (targ-constant-folder char->integer  char?))
4654 ;(targ-simp "integer->char"    (targ-constant-folder integer->char  ))
4655 (targ-simp "char-upcase"      (targ-constant-folder char-upcase    char?))
4656 (targ-simp "char-downcase"    (targ-constant-folder char-downcase  char?))
4657
4658 (targ-simp "##string?"        (targ-constant-folder string?        ))
4659 ;(targ-simp "make-string"      (targ-constant-folder make-string    ))
4660 ;(targ-simp "string"           (targ-constant-folder string         char?))
4661 (targ-simp "string-length"    (targ-constant-folder string-length  string?))
4662 (targ-simp "string-ref"       (targ-constant-folder-ref
4663                                string-ref
4664                                string-length
4665                                string?))
4666 (targ-simp "string=?"         (targ-constant-folder string=?       string?))
4667 (targ-simp "string<?"         (targ-constant-folder string<?       string?))
4668 (targ-simp "string>?"         (targ-constant-folder string>?       string?))
4669 (targ-simp "string<=?"        (targ-constant-folder string<=?      string?))
4670 (targ-simp "string>=?"        (targ-constant-folder string>=?      string?))
4671 (targ-simp "string-ci=?"      (targ-constant-folder string-ci=?    string?))
4672 (targ-simp "string-ci<?"      (targ-constant-folder string-ci<?    string?))
4673 (targ-simp "string-ci>?"      (targ-constant-folder string-ci>?    string?))
4674 (targ-simp "string-ci<=?"     (targ-constant-folder string-ci<=?   string?))
4675 (targ-simp "string-ci>=?"     (targ-constant-folder string-ci>=?   string?))
4676 ;(targ-simp "substring"        (targ-constant-folder substring      ))
4677 ;(targ-simp "string-append"    (targ-constant-folder string-append  string?))
4678
4679 (targ-simp "##vector?"          (targ-constant-folder vector-object? ))
4680 (targ-simp "##vector-length"    (targ-constant-folder vector-length
4681                                                     vector-object?))
4682 (targ-simp "##vector-ref"       (targ-constant-folder-ref
4683                                  vector-ref
4684                                  vector-length
4685                                  vector-object?))
4686 ;(targ-simp "make-vector"        (targ-constant-folder make-vector    ))
4687 ;(targ-simp "vector"             (targ-constant-folder vector         ))
4688 (targ-simp "vector-length"      (targ-constant-folder vector-length
4689                                                       vector-object?))
4690 (targ-simp "vector-ref"         (targ-constant-folder-ref
4691                                  vector-ref
4692                                  vector-length
4693                                  vector-object?))
4694
4695 (targ-simp "##s8vector?"        (targ-constant-folder s8vect? ))
4696 (targ-simp "##s8vector-length"  (targ-constant-folder s8vect-length
4697                                                     s8vect?))
4698 (targ-simp "##s8vector-ref"     (targ-constant-folder-ref
4699                                  s8vect-ref
4700                                  s8vect-length
4701                                  s8vect?))
4702 ;(targ-simp "make-s8vector"      (targ-constant-folder make-s8vect    ))
4703 ;(targ-simp "s8vector"           (targ-constant-folder s8vect         ))
4704 (targ-simp "s8vector-length"    (targ-constant-folder s8vect-length
4705                                                       s8vect?))
4706 (targ-simp "s8vector-ref"       (targ-constant-folder-ref
4707                                  s8vect-ref
4708                                  s8vect-length
4709                                  s8vect?))
4710
4711 (targ-simp "##u8vector?"        (targ-constant-folder u8vect? ))
4712 (targ-simp "##u8vector-length"  (targ-constant-folder u8vect-length
4713                                                       u8vect?))
4714 (targ-simp "##u8vector-ref"     (targ-constant-folder-ref
4715                                  u8vect-ref
4716                                  u8vect-length
4717                                  u8vect?))
4718 ;(targ-simp "make-u8vector"      (targ-constant-folder make-u8vect    ))
4719 ;(targ-simp "u8vector"           (targ-constant-folder u8vect         ))
4720 (targ-simp "u8vector-length"    (targ-constant-folder u8vect-length
4721                                                       u8vect?))
4722 (targ-simp "u8vector-ref"       (targ-constant-folder-ref
4723                                  u8vect-ref
4724                                  u8vect-length
4725                                  u8vect?))
4726
4727 (targ-simp "##s16vector?"       (targ-constant-folder s16vect? ))
4728 (targ-simp "##s16vector-length" (targ-constant-folder s16vect-length
4729                                                       s16vect?))
4730 (targ-simp "##s16vector-ref"    (targ-constant-folder-ref
4731                                  s16vect-ref
4732                                  s16vect-length
4733                                  s16vect?))
4734 ;(targ-simp "make-s16vector"     (targ-constant-folder make-s16vect    ))
4735 ;(targ-simp "s16vector"          (targ-constant-folder s16vect         ))
4736 (targ-simp "s16vector-length"   (targ-constant-folder s16vect-length
4737                                                       s16vect?))
4738 (targ-simp "s16vector-ref"      (targ-constant-folder-ref
4739                                  s16vect-ref
4740                                  s16vect-length
4741                                  s16vect?))
4742
4743 (targ-simp "##u16vector?"       (targ-constant-folder u16vect? ))
4744 (targ-simp "##u16vector-length" (targ-constant-folder u16vect-length
4745                                                       u16vect?))
4746 (targ-simp "##u16vector-ref"    (targ-constant-folder-ref
4747                                  u16vect-ref
4748                                  u16vect-length
4749                                  u16vect?))
4750 ;(targ-simp "make-u16vector"     (targ-constant-folder make-u16vect    ))
4751 ;(targ-simp "u16vector"          (targ-constant-folder u16vect         ))
4752 (targ-simp "u16vector-length"   (targ-constant-folder u16vect-length
4753                                                       u16vect?))
4754 (targ-simp "u16vector-ref"      (targ-constant-folder-ref
4755                                  u16vect-ref
4756                                  u16vect-length
4757                                  u16vect?))
4758
4759 (targ-simp "##s32vector?"       (targ-constant-folder s32vect? ))
4760 (targ-simp "##s32vector-length" (targ-constant-folder s32vect-length
4761                                                       s32vect?))
4762 (targ-simp "##s32vector-ref"    (targ-constant-folder-ref
4763                                  s32vect-ref
4764                                  s32vect-length
4765                                  s32vect?))
4766 ;(targ-simp "make-s32vector"     (targ-constant-folder make-s32vect    ))
4767 ;(targ-simp "s32vector"          (targ-constant-folder s32vect         ))
4768 (targ-simp "s32vector-length"   (targ-constant-folder s32vect-length
4769                                                       s32vect?))
4770 (targ-simp "s32vector-ref"      (targ-constant-folder-ref
4771                                  s32vect-ref
4772                                  s32vect-length
4773                                  s32vect?))
4774
4775 (targ-simp "##u32vector?"       (targ-constant-folder u32vect? ))
4776 (targ-simp "##u32vector-length" (targ-constant-folder u32vect-length
4777                                                       u32vect?))
4778 (targ-simp "##u32vector-ref"    (targ-constant-folder-ref
4779                                  u32vect-ref
4780                                  u32vect-length
4781                                  u32vect?))
4782 ;(targ-simp "make-u32vector"     (targ-constant-folder make-u32vect    ))
4783 ;(targ-simp "u32vector"          (targ-constant-folder u32vect         ))
4784 (targ-simp "u32vector-length"   (targ-constant-folder u32vect-length
4785                                                       u32vect?))
4786 (targ-simp "u32vector-ref"      (targ-constant-folder-ref
4787                                  u32vect-ref
4788                                  u32vect-length
4789                                  u32vect?))
4790
4791 (targ-simp "##s64vector?"       (targ-constant-folder s64vect? ))
4792 (targ-simp "##s64vector-length" (targ-constant-folder s64vect-length
4793                                                       s64vect?))
4794 (targ-simp "##s64vector-ref"    (targ-constant-folder-ref
4795                                  s64vect-ref
4796                                  s64vect-length
4797                                  s64vect?))
4798 ;(targ-simp "make-s64vector"     (targ-constant-folder make-s64vect    ))
4799 ;(targ-simp "s64vector"          (targ-constant-folder s64vect         ))
4800 (targ-simp "s64vector-length"   (targ-constant-folder s64vect-length
4801                                                       s64vect?))
4802 (targ-simp "s64vector-ref"      (targ-constant-folder-ref
4803                                  s64vect-ref
4804                                  s64vect-length
4805                                  s64vect?))
4806
4807 (targ-simp "##u64vector?"       (targ-constant-folder u64vect? ))
4808 (targ-simp "##u64vector-length" (targ-constant-folder u64vect-length
4809                                                       u64vect?))
4810 (targ-simp "##u64vector-ref"    (targ-constant-folder-ref
4811                                  u64vect-ref
4812                                  u64vect-length
4813                                  u64vect?))
4814 ;(targ-simp "make-u64vector"     (targ-constant-folder make-u64vect    ))
4815 ;(targ-simp "u64vector"          (targ-constant-folder u64vect         ))
4816 (targ-simp "u64vector-length"   (targ-constant-folder u64vect-length
4817                                                       u64vect?))
4818 (targ-simp "u64vector-ref"      (targ-constant-folder-ref
4819                                  u64vect-ref
4820                                  u64vect-length
4821                                  u64vect?))
4822
4823 (targ-simp "##f32vector?"       (targ-constant-folder f32vect? ))
4824 (targ-simp "##f32vector-length" (targ-constant-folder f32vect-length
4825                                                       f32vect?))
4826 (targ-simp "##f32vector-ref"    (targ-constant-folder-ref
4827                                  f32vect-ref
4828                                  f32vect-length
4829                                  f32vect?))
4830 ;(targ-simp "make-f32vector"     (targ-constant-folder make-f32vect    ))
4831 ;(targ-simp "f32vector"          (targ-constant-folder f32vect         ))
4832 (targ-simp "f32vector-length"   (targ-constant-folder f32vect-length
4833                                                       f32vect?))
4834 (targ-simp "f32vector-ref"      (targ-constant-folder-ref
4835                                  f32vect-ref
4836                                  f32vect-length
4837                                  f32vect?))
4838
4839 (targ-simp "##f64vector?"       (targ-constant-folder f64vect? ))
4840 (targ-simp "##f64vector-length" (targ-constant-folder f64vect-length
4841                                                       f64vect?))
4842 (targ-simp "##f64vector-ref"    (targ-constant-folder-ref
4843                                  f64vect-ref
4844                                  f64vect-length
4845                                  f64vect?))
4846 ;(targ-simp "make-f64vector"     (targ-constant-folder make-f64vect    ))
4847 ;(targ-simp "f64vector"          (targ-constant-folder f64vect         ))
4848 (targ-simp "f64vector-length"   (targ-constant-folder f64vect-length
4849                                                       f64vect?))
4850 (targ-simp "f64vector-ref"      (targ-constant-folder-ref
4851                                  f64vect-ref
4852                                  f64vect-length
4853                                  f64vect?))
4854
4855 (targ-simp "##procedure?"     (targ-constant-folder proc-obj?      ))
4856 ;(targ-simp "apply"            (targ-constant-folder apply          ))
4857 (targ-simp "input-port?"      (targ-constant-folder input-port?    ))
4858 (targ-simp "output-port?"     (targ-constant-folder output-port?   ))
4859 (targ-simp "##eof-object?"    (targ-constant-folder end-of-file-object?))
4860 ;(targ-simp "list-tail"        (targ-constant-folder list-tail      ))
4861 ;(targ-simp "string->list"     (targ-constant-folder string->list   string?))
4862 ;(targ-simp "list->string"     (targ-constant-folder list->string   ))
4863 ;(targ-simp "string-copy"      (targ-constant-folder string-copy    string?))
4864 ;(targ-simp "vector->list"     (targ-constant-folder vector->list
4865 ;;                                                    vector-object?))
4866 ;(targ-simp "list->vector"     (targ-constant-folder list->vector   list?))
4867 (targ-simp "##keyword?"       (targ-constant-folder keyword-object?))
4868 ;(targ-simp "keyword->string"  (targ-constant-folder keyword-object->string))
4869 (targ-simp "string->keyword"  (targ-constant-folder string->keyword-object))
4870 (targ-simp "##void"           (targ-constant-folder (lambda () void-object)))
4871
4872 (targ-simp "##fixnum?"        (targ-constant-folder fix32?         not-bigfix?))
4873 (targ-simp "##flonum?"        (targ-constant-folder flo?           ))
4874 )
4875
4876 (targ-setup-simplifiers)
4877
4878 (define (targ-setup-expanders)
4879
4880 (define (targ-exp name expander)
4881   (let ((proc (targ-get-prim-info name)))
4882     (proc-obj-expandable?-set! proc (lambda (env) #t))
4883     (proc-obj-expand-set! proc expander)))
4884
4885 (define (gen-check-run-time-binding
4886          check-run-time-binding
4887          source
4888          env
4889          succeed
4890          fail)
4891   (if check-run-time-binding
4892       (new-tst source env
4893         (check-run-time-binding)
4894         (succeed)
4895         (fail))
4896       (succeed)))
4897
4898 (define (gen-type-checks
4899          source
4900          env
4901          vars
4902          check-run-time-binding
4903          check-prim
4904          tail
4905          succeed
4906          fail)
4907   (let ((type-checks
4908          (gen-uniform-type-checks source env
4909            vars
4910            (lambda (var)
4911              (gen-call-prim-vars source env check-prim (list var)))
4912            tail)))
4913     (if (or type-checks
4914             check-run-time-binding)
4915       (new-tst source env
4916         (if type-checks
4917           (if check-run-time-binding
4918             (new-conj source env
4919               (check-run-time-binding)
4920               type-checks)
4921             type-checks)
4922           (check-run-time-binding))
4923         (succeed)
4924         (fail))
4925       (succeed))))
4926
4927 (define (gen-simple-case check-prim prim)
4928   (lambda (source
4929            env
4930            vars
4931            check-run-time-binding
4932            invalid
4933            fail)
4934     (gen-type-checks
4935      source
4936      env
4937      vars
4938      check-run-time-binding
4939      check-prim
4940      #f
4941      (lambda ()
4942        (gen-call-prim-vars source env prim vars))
4943      fail)))
4944
4945 (define (gen-validating-case check-prim gen)
4946   (lambda (source
4947            env
4948            vars
4949            check-run-time-binding
4950            invalid
4951            fail)
4952     (gen-type-checks
4953      source
4954      env
4955      vars
4956      check-run-time-binding
4957      check-prim
4958      #f
4959      (lambda ()
4960        (gen source env vars invalid))
4961      fail)))
4962
4963 (define (setup-list-primitives)
4964
4965   (define **null?-sym (string->canonical-symbol "##null?"))
4966   (define **pair?-sym (string->canonical-symbol "##pair?"))
4967   (define **pair-mutable?-sym (string->canonical-symbol "##pair-mutable?"))
4968   (define **cons-sym (string->canonical-symbol "##cons"))
4969   (define **car-sym (string->canonical-symbol "##car"))
4970   (define **cdr-sym (string->canonical-symbol "##cdr"))
4971   (define **set-car!-sym (string->canonical-symbol "##set-car!"))
4972   (define **set-cdr!-sym (string->canonical-symbol "##set-cdr!"))
4973   (define **procedure?-sym (string->canonical-symbol "##procedure?"))
4974
4975   (define (setup-c...r-primitive pattern)
4976
4977     (define (gen-name pattern)
4978
4979       (define (ads pattern)
4980         (if (= pattern 1)
4981           ""
4982           (string-append (if (odd? pattern) "d" "a")
4983                          (ads (quotient pattern 2)))))
4984
4985       (string-append "c" (ads pattern) "r"))
4986
4987     (define (c...r pattern x)
4988       (if (= pattern 1)
4989           x
4990           (let ((y (c...r (quotient pattern 2) x)))
4991             (if (pair? y)
4992               (if (odd? pattern) (cdr y) (car y))
4993               #f))))
4994
4995     (define (expander ptree oper args generate-call check-run-time-binding)
4996       (let ((source (node-source ptree))
4997             (env (node-env ptree)))
4998
4999         (define (op-prim pattern)
5000           (if (odd? pattern) **cdr-sym **car-sym))
5001
5002         (define (gen-tst-pair pattern var body check)
5003           (new-tst source env
5004             (let ((x (and check (check)))
5005                   (y (gen-call-prim-vars source env **pair?-sym (list var))))
5006               (if x
5007                 (new-conj source env x y)
5008                 y))
5009             (gen-call-prim-vars source env (op-prim pattern) (list var))
5010             body))
5011
5012         (define (gen-c...r pattern var)
5013           (if (< pattern 4)
5014             (gen-tst-pair
5015              pattern
5016              var
5017              (new-cst source env
5018                #f)
5019              check-run-time-binding)
5020             (let ((vars (gen-temp-vars source '(#f))))
5021               (new-call source env
5022                 (gen-prc source env
5023                   vars
5024                   (gen-tst-pair
5025                    pattern
5026                    (car vars)
5027                    (new-cst source env
5028                      #f)
5029                    #f))
5030                 (list (gen-c...r (quotient pattern 2) var))))))
5031
5032         (let* ((vars1
5033                 (gen-temp-vars source '(#f)))
5034                (call
5035                 (generate-call vars1)))
5036           (gen-prc source env
5037             vars1
5038             (if (< pattern 4)
5039               (gen-tst-pair pattern (car vars1) call check-run-time-binding)
5040               (new-call source env
5041                 (let ((vars2 (gen-temp-vars source '(#f))))
5042                   (gen-prc source env
5043                     vars2
5044                     (gen-tst-pair pattern (car vars2) call #f)))
5045                 (list (gen-c...r (quotient pattern 2) (car vars1)))))))))
5046
5047     (let ((name (gen-name pattern)))
5048       (targ-exp name expander)))
5049
5050   (define (setup-c...r-primitives)
5051     (let loop ((pattern 2))
5052       (if (< pattern 32)
5053           (begin
5054             (setup-c...r-primitive pattern)
5055             (loop (+ pattern 1))))))
5056
5057   (define (setup-set-c...r!-primitive pattern)
5058
5059     (define (gen-name pattern)
5060       (if (= pattern 0) "set-car!" "set-cdr!"))
5061
5062     (define (expander ptree oper args generate-call check-run-time-binding)
5063       (let ((source (node-source ptree))
5064             (env (node-env ptree)))
5065
5066         (define (op-prim pattern)
5067           (if (odd? pattern) **set-cdr!-sym **set-car!-sym))
5068
5069         (let ((vars
5070                (gen-temp-vars source args)))
5071           (gen-prc source env
5072             vars
5073             (let ((type-check
5074                    (gen-call-prim-vars source env
5075                      **pair?-sym
5076                      (list (car vars)))))
5077               (new-tst source env
5078                 (new-conj source env
5079                   (if check-run-time-binding
5080                     (new-conj source env
5081                       (check-run-time-binding)
5082                       type-check)
5083                     type-check)
5084                   (gen-call-prim-vars source env
5085                     **pair-mutable?-sym
5086                     (list (car vars))))
5087                 (gen-call-prim-vars source env
5088                   (op-prim pattern)
5089                   vars)
5090                 (generate-call vars)))))))
5091
5092     (let ((name (gen-name pattern)))
5093       (targ-exp name expander)))
5094
5095   (define (setup-set-c...r!-primitives)
5096     (setup-set-c...r!-primitive 0)  ; set-car!
5097     (setup-set-c...r!-primitive 1)) ; set-cdr!
5098
5099   (define (make-assq-memq-expander prim)
5100     (lambda (ptree oper args generate-call check-run-time-binding)
5101       (let* ((source
5102               (node-source ptree))
5103              (env
5104               (node-env ptree))
5105              (vars
5106               (gen-temp-vars source args))
5107              (obj-var
5108               (car vars))
5109              (lst-var
5110               (cadr vars))
5111              (loop-var
5112               (new-temp-variable source 'loop))
5113              (lst1-var
5114               (new-temp-variable source 'lst1))
5115              (x-var
5116               (new-temp-variable source 'x)))
5117
5118         (define (gen-main-loop)
5119           (new-call source env
5120             (new-prc source env
5121               #f
5122               #f
5123               (list loop-var)
5124               '()
5125               #f
5126               #f
5127               (new-call source env
5128                 (new-ref source env
5129                   loop-var)
5130                 (list (new-ref source env
5131                         lst-var))))
5132             (list (new-prc source env
5133                     #f
5134                     #f
5135                     (list lst1-var)
5136                     '()
5137                     #f
5138                     #f
5139                     (new-tst source env
5140                       (gen-call-prim-vars source env **pair?-sym (list lst1-var))
5141                       (new-call source env
5142                         (new-prc source env
5143                           #f
5144                           #f
5145                           (list x-var)
5146                           '()
5147                           #f
5148                           #f
5149                           (if (memq prim '(assq assv))
5150                             (let ()
5151
5152                               (define (gen-test)
5153                                 (new-tst source env
5154                                   (gen-call-prim source env
5155                                     (if (eq? prim 'assq)
5156                                         **eq?-sym
5157                                         **eqv?-sym)
5158                                     (list (new-ref source env
5159                                             obj-var)
5160                                           (gen-call-prim-vars source env
5161                                             **car-sym
5162                                             (list x-var))))
5163                                   (new-ref source env
5164                                     x-var)
5165                                   (new-call source env
5166                                     (new-ref source env
5167                                       loop-var)
5168                                     (list (gen-call-prim-vars source env
5169                                             **cdr-sym
5170                                             (list lst1-var))))))
5171
5172                               (if (safe? env)
5173                                 (new-tst source env
5174                                   (gen-call-prim-vars source env
5175                                     **pair?-sym
5176                                     (list x-var))
5177                                   (gen-test)
5178                                   (generate-call vars))
5179                                 (gen-test)))
5180                             (new-tst source env
5181                               (gen-call-prim source env
5182                                 (if (eq? prim 'memq)
5183                                     **eq?-sym
5184                                     **eqv?-sym)
5185                                 (list (new-ref source env
5186                                         obj-var)
5187                                       (new-ref source env
5188                                         x-var)))
5189                               (new-ref source env
5190                                 lst1-var)
5191                               (new-call source env
5192                                 (new-ref source env
5193                                   loop-var)
5194                                 (list (gen-call-prim-vars source env
5195                                         **cdr-sym
5196                                         (list lst1-var)))))))
5197                         (list (gen-call-prim-vars source env
5198                                 **car-sym
5199                                 (list lst1-var))))
5200                       (if (safe? env)
5201                         (new-tst source env
5202                           (gen-call-prim-vars source env **null?-sym (list lst1-var))
5203                           (new-cst source env
5204                             false-object)
5205                           (generate-call vars))
5206                         (new-cst source env
5207                           false-object)))))))
5208
5209         (gen-prc source env
5210           vars
5211           (if check-run-time-binding
5212             (new-tst source env
5213               (check-run-time-binding)
5214               (gen-main-loop)
5215               (generate-call vars))
5216             (gen-main-loop))))))
5217
5218   (define (make-map-for-each-expander prim)
5219     (lambda (ptree oper args generate-call check-run-time-binding)
5220       (let* ((source
5221               (node-source ptree))
5222              (env
5223               (node-env ptree))
5224              (vars
5225               (gen-temp-vars source args))
5226              (f-var
5227               (car vars))
5228              (lst-vars
5229               (cdr vars)))
5230
5231         (define (gen-conj-call-prim-vars source env prim vars)
5232           (if (pair? vars)
5233               (let ((code
5234                      (gen-call-prim-vars source env
5235                        prim
5236                        (list (car vars)))))
5237                 (if (null? (cdr vars))
5238                     code
5239                     (new-conj source env
5240                       code
5241                       (gen-conj-call-prim-vars source env prim (cdr vars)))))
5242               (new-cst source env
5243                 #t)))
5244
5245         (define (gen-main-loop)
5246           (let* ((loop2-var
5247                   (new-temp-variable source 'loop2))
5248                  (lst2-vars
5249                   (gen-temp-vars source lst-vars))
5250                  (x-var
5251                   (new-temp-variable source 'x)))
5252             (new-call source env
5253               (new-prc source env
5254                 #f
5255                 #f
5256                 (list loop2-var)
5257                 '()
5258                 #f
5259                 #f
5260                 (new-call source env
5261                   (new-ref source env
5262                     loop2-var)
5263                   (map (lambda (var)
5264                          (new-ref source env
5265                            var))
5266                        lst-vars)))
5267               (list (new-prc source env
5268                       #f
5269                       #f
5270                       lst2-vars
5271                       '()
5272                       #f
5273                       #f
5274                       (new-tst source env
5275                         (gen-conj-call-prim-vars source env
5276                           **pair?-sym
5277                           (if (safe? env) ;; in case lists are truncated by other threads
5278                               lst2-vars
5279                               (list (car lst2-vars))))
5280                         (new-call source env
5281                           (new-prc source env
5282                             #f
5283                             #f
5284                             (list x-var)
5285                             '()
5286                             #f
5287                             #f
5288                             (let ((rec-call
5289                                    (new-call source env
5290                                      (new-ref source env
5291                                        loop2-var)
5292                                      (map (lambda (var)
5293                                             (gen-call-prim-vars source env
5294                                               **cdr-sym
5295                                               (list var)))
5296                                           lst2-vars))))
5297                               (if (eq? prim 'map)
5298                                 (gen-call-prim source env
5299                                   **cons-sym
5300                                   (list (new-ref source env
5301                                           x-var)
5302                                         rec-call))
5303                                 rec-call)))
5304                           (list (new-call source env
5305                                   (new-ref source env
5306                                     f-var)
5307                                   (map (lambda (var)
5308                                             (gen-call-prim-vars source env
5309                                               **car-sym
5310                                               (list var)))
5311                                           lst2-vars))))
5312                         (new-cst source env
5313                           (if (eq? prim 'map)
5314                             '()
5315                             void-object))))))))
5316
5317         (define (gen-check)
5318           (let* ((loop1-var
5319                   (new-temp-variable source 'loop1))
5320                  (lst1-vars
5321                   (gen-temp-vars source lst-vars)))
5322             (new-call source env
5323               (new-prc source env
5324                 #f
5325                 #f
5326                 (list loop1-var)
5327                 '()
5328                 #f
5329                 #f
5330                 (new-call source env
5331                   (new-ref source env
5332                     loop1-var)
5333                   (map (lambda (var)
5334                          (new-ref source env
5335                            var))
5336                        lst-vars)))
5337               (list (new-prc source env
5338                       #f
5339                       #f
5340                       lst1-vars
5341                       '()
5342                       #f
5343                       #f
5344                       (new-tst source env
5345                         (gen-conj-call-prim-vars source env
5346                           **pair?-sym
5347                           lst1-vars)
5348                         (new-call source env
5349                           (new-ref source env
5350                             loop1-var)
5351                           (map (lambda (var)
5352                                  (gen-call-prim-vars source env
5353                                    **cdr-sym
5354                                    (list var)))
5355                                lst1-vars))
5356                         (new-tst source env
5357                           (gen-conj-call-prim-vars source env
5358                             **null?-sym
5359                             lst1-vars)
5360                           (gen-main-loop)
5361                           (generate-call vars))))))))
5362
5363         (gen-prc source env
5364           vars
5365           (let ((check-proc
5366                  (and (safe? env)
5367                       (let ((f-arg (car args)))
5368                         (and (not (or (prc? f-arg)
5369                                       (and (cst? f-arg)
5370                                            (proc-obj? (cst-val f-arg)))))
5371                              (gen-call-prim-vars source env
5372                                **procedure?-sym
5373                                (list f-var)))))))
5374             (if (or check-run-time-binding
5375                     check-proc)
5376               (new-tst source env
5377                 (cond ((and check-run-time-binding
5378                             check-proc)
5379                        (new-conj source env
5380                          (check-run-time-binding)
5381                          check-proc))
5382                       (check-run-time-binding
5383                        (check-run-time-binding))
5384                       (else
5385                        check-proc))
5386                 (if (safe? env)
5387                   (gen-check)
5388                   (gen-main-loop))
5389                 (generate-call vars))
5390               (gen-main-loop)))))))
5391
5392   (setup-c...r-primitives)
5393   (setup-set-c...r!-primitives)
5394
5395   (targ-exp "assq" (make-assq-memq-expander 'assq))
5396   (targ-exp "assv" (make-assq-memq-expander 'assv))
5397   (targ-exp "memq" (make-assq-memq-expander 'memq))
5398   (targ-exp "memv" (make-assq-memq-expander 'memv))
5399   (targ-exp "map" (make-map-for-each-expander 'map))
5400   (targ-exp "for-each" (make-map-for-each-expander 'for-each)))
5401
5402 (define (setup-numeric-primitives)
5403
5404   (define **real?-sym     (string->canonical-symbol "##real?"))
5405   (define **rational?-sym (string->canonical-symbol "##rational?"))
5406   (define **integer?-sym  (string->canonical-symbol "##integer?"))
5407   (define **exact?-sym    (string->canonical-symbol "##exact?"))
5408   (define **inexact?-sym  (string->canonical-symbol "##inexact?"))
5409   (define exact?-sym      (string->canonical-symbol "exact?"))
5410   (define inexact?-sym    (string->canonical-symbol "inexact?"))
5411
5412   (define **fixnum?-sym (string->canonical-symbol "##fixnum?"))
5413
5414   (define **fx=-sym (string->canonical-symbol "##fx="))
5415   (define **fx<-sym (string->canonical-symbol "##fx<"))
5416   (define **fx>-sym (string->canonical-symbol "##fx>"))
5417   (define **fx<=-sym (string->canonical-symbol "##fx<="))
5418   (define **fx>=-sym (string->canonical-symbol "##fx>="))
5419
5420   (define **fxzero?-sym (string->canonical-symbol "##fxzero?"))
5421   (define **fxpositive?-sym (string->canonical-symbol "##fxpositive?"))
5422   (define **fxnegative?-sym (string->canonical-symbol "##fxnegative?"))
5423
5424   (define **fxodd?-sym (string->canonical-symbol "##fxodd?"))
5425   (define **fxeven?-sym (string->canonical-symbol "##fxeven?"))
5426
5427   (define **fxmax-sym (string->canonical-symbol "##fxmax"))
5428   (define **fxmin-sym (string->canonical-symbol "##fxmin"))
5429
5430   (define **fxwrap+-sym (string->canonical-symbol "##fxwrap+"))
5431   (define **fx+-sym (string->canonical-symbol "##fx+"))
5432   (define **fx+?-sym (string->canonical-symbol "##fx+?"))
5433   (define **fxwrap*-sym (string->canonical-symbol "##fxwrap*"))
5434   (define **fx*-sym (string->canonical-symbol "##fx*"))
5435   (define **fx*?-sym (string->canonical-symbol "##fx*?"))
5436   (define **fxwrap--sym (string->canonical-symbol "##fxwrap-"))
5437   (define **fx--sym (string->canonical-symbol "##fx-"))
5438   (define **fx-?-sym (string->canonical-symbol "##fx-?"))
5439   (define **fxwrapquotient-sym (string->canonical-symbol "##fxwrapquotient"))
5440   (define **fxquotient-sym (string->canonical-symbol "##fxquotient"))
5441   (define **fxremainder-sym (string->canonical-symbol "##fxremainder"))
5442   (define **fxmodulo-sym (string->canonical-symbol "##fxmodulo"))
5443
5444   (define **fxwrapabs-sym (string->canonical-symbol "##fxwrapabs"))
5445   (define **fxabs-sym (string->canonical-symbol "##fxabs"))
5446   (define **fxabs?-sym (string->canonical-symbol "##fxabs?"))
5447
5448   (define **fxnot-sym (string->canonical-symbol "##fxnot"))
5449   (define **fxand-sym (string->canonical-symbol "##fxand"))
5450   (define **fxior-sym (string->canonical-symbol "##fxior"))
5451   (define **fxxor-sym (string->canonical-symbol "##fxxor"))
5452
5453   (define **flonum?-sym (string->canonical-symbol "##flonum?"))
5454
5455   (define **fl=-sym (string->canonical-symbol "##fl="))
5456   (define **fl<-sym (string->canonical-symbol "##fl<"))
5457   (define **fl>-sym (string->canonical-symbol "##fl>"))
5458   (define **fl<=-sym (string->canonical-symbol "##fl<="))
5459   (define **fl>=-sym (string->canonical-symbol "##fl>="))
5460
5461   (define **flinteger?-sym (string->canonical-symbol "##flinteger?"))
5462   (define **flzero?-sym (string->canonical-symbol "##flzero?"))
5463   (define **flpositive?-sym (string->canonical-symbol "##flpositive?"))
5464   (define **flnegative?-sym (string->canonical-symbol "##flnegative?"))
5465   (define **flodd?-sym (string->canonical-symbol "##flodd?"))
5466   (define **fleven?-sym (string->canonical-symbol "##fleven?"))
5467   (define **flfinite?-sym (string->canonical-symbol "##flfinite?"))
5468   (define **flinfinite?-sym (string->canonical-symbol "##flinfinite?"))
5469   (define **flnan?-sym (string->canonical-symbol "##flnan?"))
5470
5471   (define **flmax-sym (string->canonical-symbol "##flmax"))
5472   (define **flmin-sym (string->canonical-symbol "##flmin"))
5473
5474   (define **fl+-sym (string->canonical-symbol "##fl+"))
5475   (define **fl*-sym (string->canonical-symbol "##fl*"))
5476   (define **fl--sym (string->canonical-symbol "##fl-"))
5477   (define **fl/-sym (string->canonical-symbol "##fl/"))
5478
5479   (define **flabs-sym (string->canonical-symbol "##flabs"))
5480   (define **flfloor-sym (string->canonical-symbol "##flfloor"))
5481   (define **flceiling-sym (string->canonical-symbol "##flceiling"))
5482   (define **fltruncate-sym (string->canonical-symbol "##fltruncate"))
5483   (define **flround-sym (string->canonical-symbol "##flround"))
5484   (define **flexp-sym (string->canonical-symbol "##flexp"))
5485   (define **fllog-sym (string->canonical-symbol "##fllog"))
5486   (define **flsin-sym (string->canonical-symbol "##flsin"))
5487   (define **flcos-sym (string->canonical-symbol "##flcos"))
5488   (define **fltan-sym (string->canonical-symbol "##fltan"))
5489   (define **flasin-sym (string->canonical-symbol "##flasin"))
5490   (define **flacos-sym (string->canonical-symbol "##flacos"))
5491   (define **flatan-sym (string->canonical-symbol "##flatan"))
5492   (define **flexpt-sym (string->canonical-symbol "##flexpt"))
5493   (define **flsqrt-sym (string->canonical-symbol "##flsqrt"))
5494   (define **flcopysign-sym (string->canonical-symbol "##flcopysign"))
5495
5496   (define **fl<-fx-sym (string->canonical-symbol "##fl<-fx"))
5497
5498   (define **char?-sym (string->canonical-symbol "##char?"))
5499
5500   (define **char=?-sym (string->canonical-symbol "##char=?"))
5501   (define **char<?-sym (string->canonical-symbol "##char<?"))
5502   (define **char>?-sym (string->canonical-symbol "##char>?"))
5503   (define **char<=?-sym (string->canonical-symbol "##char<=?"))
5504   (define **char>=?-sym (string->canonical-symbol "##char>=?"))
5505
5506   (define **char-ci=?-sym (string->canonical-symbol "##char-ci=?"))
5507   (define **char-ci<?-sym (string->canonical-symbol "##char-ci<?"))
5508   (define **char-ci>?-sym (string->canonical-symbol "##char-ci>?"))
5509   (define **char-ci<=?-sym (string->canonical-symbol "##char-ci<=?"))
5510   (define **char-ci>=?-sym (string->canonical-symbol "##char-ci>=?"))
5511
5512   (define **mem-allocated?-sym (string->canonical-symbol "##mem-allocated?"))
5513   (define **subtyped?-sym (string->canonical-symbol "##subtyped?"))
5514   (define **subtype-sym (string->canonical-symbol "##subtype"))
5515
5516   (define (gen-fixnum-case gen)
5517     (lambda (source
5518              env
5519              vars
5520              check-run-time-binding
5521              invalid
5522              fail)
5523       (gen-type-checks
5524        source
5525        env
5526        vars
5527        check-run-time-binding
5528        **fixnum?-sym
5529        #f
5530        (lambda ()
5531          (gen source env vars invalid))
5532        fail)))
5533
5534   (define (gen-fixnum-division-case gen)
5535     (lambda (source
5536              env
5537              vars
5538              check-run-time-binding
5539              invalid
5540              fail)
5541       (gen-type-checks
5542        source
5543        env
5544        vars
5545        check-run-time-binding
5546        **fixnum?-sym
5547        (gen-call-prim source env
5548          **not-sym
5549          (list (gen-call-prim source env
5550                  **eqv?-sym
5551                  (list (new-ref source env
5552                          (cadr vars))
5553                        (new-cst source env
5554                          0)))))
5555        (lambda ()
5556          (gen source env vars invalid))
5557        fail)))
5558
5559   (define (gen-flonum-case gen)
5560     (lambda (source
5561              env
5562              vars
5563              check-run-time-binding
5564              invalid
5565              fail)
5566       (gen-type-checks
5567        source
5568        env
5569        vars
5570        check-run-time-binding
5571        **flonum?-sym
5572        #f
5573        (lambda ()
5574          (gen source env vars invalid))
5575        fail)))
5576
5577   (define (gen-log-flonum-case gen)
5578     (lambda (source
5579              env
5580              vars
5581              check-run-time-binding
5582              invalid
5583              fail)
5584       (gen-type-checks
5585        source
5586        env
5587        vars
5588        check-run-time-binding
5589        **flonum?-sym
5590        (new-disj source env
5591          (gen-call-prim-vars source env
5592            **flnan?-sym
5593            vars)
5594          (gen-call-prim source env
5595            **not-sym
5596            (list (gen-call-prim source env
5597                    **flnegative?-sym
5598                    (list (gen-call-prim source env
5599                            **flcopysign-sym
5600                            (list (new-cst source env
5601                                    (macro-inexact-+1))
5602                                  (new-ref source env
5603                                    (car vars)))))))))
5604        (lambda ()
5605          (gen source env vars invalid))
5606        fail)))
5607
5608   (define (gen-expt-flonum-case gen)
5609     (lambda (source
5610              env
5611              vars
5612              check-run-time-binding
5613              invalid
5614              fail)
5615       (gen-type-checks
5616        source
5617        env
5618        vars
5619        check-run-time-binding
5620        **flonum?-sym
5621        (new-disj source env
5622          (gen-call-prim source env
5623            **not-sym
5624            (list (gen-call-prim-vars source env
5625                    **flnegative?-sym
5626                    (list (car vars)))))
5627          (gen-call-prim-vars source env
5628            **flinteger?-sym
5629            (list (cadr vars))))
5630        (lambda ()
5631          (gen source env vars invalid))
5632        fail)))
5633
5634   (define (gen-sqrt-flonum-case gen)
5635     (lambda (source
5636              env
5637              vars
5638              check-run-time-binding
5639              invalid
5640              fail)
5641       (gen-type-checks
5642        source
5643        env
5644        vars
5645        check-run-time-binding
5646        **flonum?-sym
5647        (gen-call-prim source env
5648          **not-sym
5649          (list (gen-call-prim-vars source env
5650                  **flnegative?-sym
5651                  vars)))
5652        (lambda ()
5653          (gen source env vars invalid))
5654        fail)))
5655
5656   (define (gen-finite-flonum-case gen)
5657     (lambda (source
5658              env
5659              vars
5660              check-run-time-binding
5661              invalid
5662              fail)
5663       (gen-type-checks
5664        source
5665        env
5666        vars
5667        check-run-time-binding
5668        **flonum?-sym
5669        (gen-call-prim-vars source env
5670          **flfinite?-sym
5671          vars)
5672        (lambda ()
5673          (gen source env vars invalid))
5674        fail)))
5675
5676   (define (gen-asin-acos-atan-flonum-case gen)
5677     (lambda (source
5678              env
5679              vars
5680              check-run-time-binding
5681              invalid
5682              fail)
5683       (gen-type-checks
5684        source
5685        env
5686        vars
5687        check-run-time-binding
5688        **flonum?-sym
5689        (and (= (length vars) 1)
5690             (new-conj source env
5691               (gen-call-prim source env
5692                 **not-sym
5693                 (list (gen-call-prim source env
5694                         **fl<-sym
5695                         (list (new-cst source env
5696                                 (macro-inexact-+1))
5697                               (new-ref source env
5698                                 (car vars))))))
5699               (gen-call-prim source env
5700                 **not-sym
5701                 (list (gen-call-prim source env
5702                         **fl<-sym
5703                         (list (new-ref source env
5704                                 (car vars))
5705                               (new-cst source env
5706                                 (macro-inexact--1))))))))
5707        (lambda ()
5708          (gen source env vars invalid))
5709        fail)))
5710
5711   (define (no-case source
5712                    env
5713                    vars
5714                    check-run-time-binding
5715                    invalid
5716                    fail)
5717     (fail))
5718
5719   (define (make-fixflo-expander fixnum-case flonum-case)
5720     (lambda (ptree oper args generate-call check-run-time-binding)
5721       (let* ((source
5722               (node-source ptree))
5723              (env
5724               (node-env ptree))
5725              (mostly-arith
5726               (mostly-arith-implementation (var-name (ref-var oper)) env))
5727              (cases
5728               (cond ((eq? mostly-arith mostly-fixnum-sym)
5729                      (cons fixnum-case no-case))
5730                     ((eq? mostly-arith mostly-flonum-sym)
5731                      (cons flonum-case no-case))
5732                     ((eq? mostly-arith mostly-fixnum-flonum-sym)
5733                      (cons fixnum-case flonum-case))
5734                     ((eq? mostly-arith mostly-flonum-fixnum-sym)
5735                      (cons flonum-case fixnum-case))
5736                     (else
5737                      (cons no-case no-case)))))
5738         (if (and (eq? (car cases) no-case)
5739                  (eq? (cdr cases) no-case))
5740           #f
5741           (let ((vars (gen-temp-vars source args)))
5742             (gen-prc source env
5743               vars
5744               (let* ((generic-call
5745                       (lambda ()
5746                         (generate-call vars)))
5747                      (cases-expansion
5748                       ((car cases) source env
5749                        vars
5750                        (and (eq? (cdr cases) no-case)
5751                             check-run-time-binding)
5752                        generic-call
5753                        (lambda ()
5754                          ((cdr cases) source env
5755                           vars
5756                           (and (eq? (car cases) no-case)
5757                                check-run-time-binding)
5758                           generic-call
5759                           generic-call)))))
5760                 (if (and check-run-time-binding
5761                          (not (eq? (car cases) no-case))
5762                          (not (eq? (cdr cases) no-case)))
5763                   (new-tst source env
5764                     (check-run-time-binding)
5765                     cases-expansion
5766                     (generic-call))
5767                   cases-expansion))))))))
5768
5769   (define (make-simple-expander gen-case)
5770     (lambda (ptree oper args generate-call check-run-time-binding)
5771       (let* ((source
5772               (node-source ptree))
5773              (env
5774               (node-env ptree))
5775              (vars
5776               (gen-temp-vars source args)))
5777         (gen-prc source env
5778           vars
5779           (let ((generic-call
5780                  (lambda ()
5781                    (generate-call vars))))
5782             (gen-case source env
5783               vars
5784               check-run-time-binding
5785               generic-call
5786               generic-call))))))
5787
5788   (define (make-fixnum-division-expander gen-case)
5789     (lambda (ptree oper args generate-call check-run-time-binding)
5790       (let* ((source
5791               (node-source ptree))
5792              (env
5793               (node-env ptree))
5794              (mostly-arith
5795               (mostly-arith-implementation (var-name (ref-var oper)) env)))
5796         (and (or (eq? mostly-arith mostly-fixnum-sym)
5797                  (eq? mostly-arith mostly-fixnum-flonum-sym)
5798                  (eq? mostly-arith mostly-flonum-fixnum-sym))
5799              (let ((vars
5800                     (gen-temp-vars source args)))
5801                (gen-prc source env
5802                  vars
5803                  (let ((generic-call
5804                         (lambda ()
5805                           (generate-call vars))))
5806                    (gen-case source env
5807                      vars
5808                      check-run-time-binding
5809                      generic-call
5810                      generic-call))))))))
5811
5812   (define (make-prim-generator prim)
5813     (lambda (source env vars invalid)
5814       (gen-call-prim-vars source env prim vars)))
5815
5816   (define gen-fixnum-0
5817     (lambda (source env vars invalid)
5818       (new-cst source env
5819         0)))
5820
5821   (define gen-fixnum-1
5822     (lambda (source env vars invalid)
5823       (new-cst source env
5824         1)))
5825
5826   (define gen-flonum-0
5827     (lambda (source env vars invalid)
5828       (new-cst source env
5829         targ-inexact-+0)))
5830
5831   (define gen-flonum-1
5832     (lambda (source env vars invalid)
5833       (new-cst source env
5834         targ-inexact-+1)))
5835
5836   (define gen-first-arg
5837     (lambda (source env vars invalid)
5838       (new-ref source env
5839         (car vars))))
5840
5841   (define (make-nary-generator zero one two-or-more)
5842     (lambda (source env vars invalid)
5843       (cond ((null? vars)
5844              (zero source env vars invalid))
5845             ((null? (cdr vars))
5846              (one source env vars invalid))
5847             (else
5848              (two-or-more source env vars invalid)))))
5849
5850   (define (gen-fold source env vars invalid op-sym)
5851
5852     (define (fold result vars)
5853       (if (null? vars)
5854         result
5855         (fold (gen-call-prim source env
5856                 op-sym
5857                 (list result
5858                       (new-ref source env
5859                         (car vars))))
5860               (cdr vars))))
5861
5862     (fold (new-ref source env
5863             (car vars))
5864           (cdr vars)))
5865
5866   (define (make-fold-generator op-sym)
5867     (lambda (source env vars invalid)
5868       (gen-fold source env
5869         vars
5870         invalid
5871         op-sym)))
5872
5873   (define (gen-conditional-fold source env vars invalid gen-op)
5874
5875     (define (conditional-fold result-var vars intermediate-result-vars)
5876       (if (null? vars)
5877         (new-ref source env
5878           result-var)
5879         (let ((var (car intermediate-result-vars)))
5880           (new-call source env
5881             (gen-prc source env
5882               (list var)
5883               (new-tst source env
5884                 (new-ref source env
5885                   var)
5886                 (conditional-fold var
5887                                   (cdr vars)
5888                                   (cdr intermediate-result-vars))
5889                 (invalid)))
5890             (list (gen-op source env result-var (car vars)))))))
5891
5892     (conditional-fold (car vars)
5893                       (cdr vars)
5894                       (gen-temp-vars source (cdr vars))))
5895
5896   (define (make-conditional-fold-generator conditional-op-sym)
5897     (lambda (source env vars invalid)
5898       (gen-conditional-fold source env
5899         vars
5900         invalid
5901         (lambda (source env var1 var2)
5902           (gen-call-prim-vars source env
5903             conditional-op-sym
5904             (list var1 var2))))))
5905
5906   (define case-fx=
5907     (gen-simple-case **fixnum?-sym **fx=-sym))
5908
5909   (define case-fx<
5910     (gen-simple-case **fixnum?-sym **fx<-sym))
5911
5912   (define case-fx>
5913     (gen-simple-case **fixnum?-sym **fx>-sym))
5914
5915   (define case-fx<=
5916     (gen-simple-case **fixnum?-sym **fx<=-sym))
5917
5918   (define case-fx>=
5919     (gen-simple-case **fixnum?-sym **fx>=-sym))
5920
5921   (define case-fxzero?
5922     (gen-simple-case **fixnum?-sym **fxzero?-sym))
5923
5924   (define case-fxpositive?
5925     (gen-simple-case **fixnum?-sym **fxpositive?-sym))
5926
5927   (define case-fxnegative?
5928     (gen-simple-case **fixnum?-sym **fxnegative?-sym))
5929
5930   (define case-fxodd?
5931     (gen-simple-case **fixnum?-sym **fxodd?-sym))
5932
5933   (define case-fxeven?
5934     (gen-simple-case **fixnum?-sym **fxeven?-sym))
5935
5936   (let ()
5937
5938     (define case-fxmax
5939       (gen-validating-case
5940        **fixnum?-sym
5941        (make-nary-generator
5942         gen-fixnum-0 ; ignored
5943         gen-first-arg
5944         (make-fold-generator **fxmax-sym))))
5945
5946     (define case-fxmin
5947       (gen-validating-case
5948        **fixnum?-sym
5949        (make-nary-generator
5950         gen-fixnum-0 ; ignored
5951         gen-first-arg
5952         (make-fold-generator **fxmin-sym))))
5953
5954     (define case-fxwrap+
5955       (gen-validating-case
5956        **fixnum?-sym
5957        (make-nary-generator
5958         gen-fixnum-0
5959         gen-first-arg
5960         (make-fold-generator **fxwrap+-sym))))
5961
5962     (define case-fx+
5963       (gen-validating-case
5964        **fixnum?-sym
5965        (make-nary-generator
5966         gen-fixnum-0
5967         gen-first-arg
5968         (make-conditional-fold-generator **fx+?-sym))))
5969
5970     (define case-fxwrap*
5971       (gen-validating-case
5972        **fixnum?-sym
5973        (make-nary-generator
5974         gen-fixnum-1
5975         gen-first-arg
5976         (make-fold-generator **fxwrap*-sym))))
5977
5978     (define case-fx*
5979       (gen-validating-case
5980        **fixnum?-sym
5981        (make-nary-generator
5982         gen-fixnum-1
5983         gen-first-arg
5984         (lambda (source env vars invalid)
5985           (new-tst source env
5986             (gen-disj-multi source env
5987               (map (lambda (var)
5988                      (gen-call-prim source env
5989                        **eqv?-sym
5990                        (list (new-ref source env
5991                                var)
5992                              (new-cst source env
5993                                0))))
5994                    (reverse (cdr vars))))
5995             (new-cst source env
5996               0)
5997             (gen-conditional-fold source env
5998               vars
5999               invalid
6000               (lambda (source env var1 var2)
6001                 (new-tst source env
6002                   (gen-call-prim source env
6003                     **eqv?-sym
6004                     (list (new-ref source env
6005                             var2)
6006                           (new-cst source env
6007                             -1)))
6008                   (gen-call-prim-vars source env
6009                     **fx-?-sym
6010                     (list var1))
6011                   (gen-call-prim-vars source env
6012                     **fx*?-sym
6013                     (list var1 var2))))))))))
6014
6015     (define case-fxwrap-
6016       (gen-validating-case
6017        **fixnum?-sym
6018        (make-nary-generator
6019         gen-fixnum-0 ; ignored
6020         (make-prim-generator **fxwrap--sym)
6021         (make-fold-generator **fxwrap--sym))))
6022
6023     (define case-fx-
6024       (gen-validating-case
6025        **fixnum?-sym
6026        (make-nary-generator
6027         gen-fixnum-0 ; ignored
6028         (lambda (source env vars invalid)
6029           (let ((var (car (gen-temp-vars source '(#f)))))
6030             (new-call source env
6031               (gen-prc source env
6032                 (list var)
6033                 (new-tst source env
6034                   (new-ref source env
6035                     var)
6036                   (new-ref source env
6037                     var)
6038                   (invalid)))
6039               (list (gen-call-prim-vars source env
6040                       **fx-?-sym
6041                       vars)))))
6042         (lambda (source env vars invalid)
6043           (gen-conditional-fold source env
6044             vars
6045             invalid
6046             (lambda (source env var1 var2)
6047               (gen-call-prim-vars source env
6048                 **fx-?-sym
6049                 (list var1 var2))))))))
6050
6051     (define case-fxwrapquotient
6052       (gen-simple-case **fixnum?-sym **fxwrapquotient-sym))
6053
6054     (define case-fxquotient
6055       (gen-fixnum-division-case
6056        (lambda (source env vars invalid)
6057          (new-tst source env
6058            (gen-call-prim source env
6059              **eqv?-sym
6060              (list (new-ref source env
6061                      (cadr vars))
6062                    (new-cst source env
6063                      -1)))
6064            (new-disj source env
6065              (gen-call-prim-vars source env
6066                **fx-?-sym
6067                (list (car vars)))
6068              (invalid))
6069            (gen-call-prim-vars source env
6070              **fxquotient-sym
6071              vars)))))
6072
6073     (define case-fxremainder
6074       (gen-fixnum-division-case
6075        (make-prim-generator **fxremainder-sym)))
6076
6077     (define case-fxmodulo
6078       (gen-fixnum-division-case
6079        (make-prim-generator **fxmodulo-sym)))
6080
6081     (define case-fxwrapabs
6082       (gen-simple-case **fixnum?-sym **fxwrapabs-sym))
6083
6084     (define case-fxabs
6085       (gen-fixnum-case
6086        (lambda (source env vars invalid)
6087          (let ((var (car (gen-temp-vars source '(#f)))))
6088            (new-call source env
6089              (gen-prc source env
6090                (list var)
6091                (new-tst source env
6092                  (new-ref source env
6093                    var)
6094                  (new-ref source env
6095                    var)
6096                  (invalid)))
6097              (list (gen-call-prim-vars source env
6098                     **fxabs?-sym
6099                     vars)))))))
6100
6101     (define case-fxnot
6102       (gen-simple-case **fixnum?-sym **fxnot-sym))
6103
6104     (define case-fxand
6105       (gen-simple-case **fixnum?-sym **fxand-sym))
6106
6107     (define case-fxior
6108       (gen-simple-case **fixnum?-sym **fxior-sym))
6109
6110     (define case-fxxor
6111       (gen-simple-case **fixnum?-sym **fxxor-sym))
6112
6113     ; fxwraparithmetic-shift
6114     ; fxarithmetic-shift
6115     ; fxwraparithmetic-shift-left
6116     ; fxarithmetic-shift-left
6117     ; fxarithmetic-shift-right
6118     ; fxwraplogical-shift-right
6119
6120     (define case-fixnum->flonum
6121       (gen-fixnum-case
6122        (make-prim-generator **fl<-fx-sym)))
6123
6124     (define case-fixnum-exact->inexact
6125       (gen-fixnum-case
6126        (make-prim-generator **fl<-fx-sym)))
6127
6128     (define case-fixnum-inexact->exact
6129       (gen-fixnum-case
6130        gen-first-arg))
6131
6132     (define case-fl=
6133       (gen-simple-case **flonum?-sym **fl=-sym))
6134
6135     (define case-fl<
6136       (gen-simple-case **flonum?-sym **fl<-sym))
6137
6138     (define case-fl>
6139       (gen-simple-case **flonum?-sym **fl>-sym))
6140
6141     (define case-fl<=
6142       (gen-simple-case **flonum?-sym **fl<=-sym))
6143
6144     (define case-fl>=
6145       (gen-simple-case **flonum?-sym **fl>=-sym))
6146
6147     (define case-flinteger?
6148       (gen-simple-case **flonum?-sym **flinteger?-sym))
6149
6150     (define case-flzero?
6151       (gen-simple-case **flonum?-sym **flzero?-sym))
6152
6153     (define case-flpositive?
6154       (gen-simple-case **flonum?-sym **flpositive?-sym))
6155
6156     (define case-flnegative?
6157       (gen-simple-case **flonum?-sym **flnegative?-sym))
6158
6159     (define case-flodd?
6160       (gen-simple-case **flonum?-sym **flodd?-sym))
6161
6162     (define case-fleven?
6163       (gen-simple-case **flonum?-sym **fleven?-sym))
6164
6165     (define case-flfinite?
6166       (gen-simple-case **flonum?-sym **flfinite?-sym))
6167
6168     (define case-flinfinite?
6169       (gen-simple-case **flonum?-sym **flinfinite?-sym))
6170
6171     (define case-flnan?
6172       (gen-simple-case **flonum?-sym **flnan?-sym))
6173
6174     (define case-flmax
6175       (gen-validating-case
6176        **flonum?-sym
6177        (make-nary-generator
6178         gen-flonum-0 ; ignored
6179         gen-first-arg
6180         (make-fold-generator **flmax-sym))))
6181
6182     (define case-flmin
6183       (gen-validating-case
6184        **flonum?-sym
6185        (make-nary-generator
6186         gen-flonum-0 ; ignored
6187         gen-first-arg
6188         (make-fold-generator **flmin-sym))))
6189
6190     (define case-fl+
6191       (gen-validating-case
6192        **flonum?-sym
6193        (make-nary-generator
6194         gen-flonum-0
6195         gen-first-arg
6196         (make-fold-generator **fl+-sym))))
6197
6198     (define case-fl*
6199       (gen-validating-case
6200        **flonum?-sym
6201        (make-nary-generator
6202         gen-flonum-1
6203         gen-first-arg
6204         (make-fold-generator **fl*-sym))))
6205
6206     (define case-fl-
6207       (gen-validating-case
6208        **flonum?-sym
6209        (make-nary-generator
6210         gen-flonum-0 ; ignored
6211         (make-prim-generator **fl--sym)
6212         (make-fold-generator **fl--sym))))
6213
6214     (define case-fl/
6215       (gen-validating-case
6216        **flonum?-sym
6217        (make-nary-generator
6218         gen-flonum-0 ; ignored
6219         (make-prim-generator **fl/-sym)
6220         (make-fold-generator **fl/-sym))))
6221
6222     (define case-flabs
6223       (gen-simple-case **flonum?-sym **flabs-sym))
6224
6225     (define case-flfloor
6226       (gen-finite-flonum-case
6227        (make-prim-generator **flfloor-sym)))
6228
6229     (define case-flceiling
6230       (gen-finite-flonum-case
6231        (make-prim-generator **flceiling-sym)))
6232
6233     (define case-fltruncate
6234       (gen-finite-flonum-case
6235        (make-prim-generator **fltruncate-sym)))
6236
6237     (define case-flround
6238       (gen-finite-flonum-case
6239        (make-prim-generator **flround-sym)))
6240
6241     (define case-flexp
6242       (gen-simple-case **flonum?-sym **flexp-sym))
6243
6244     (define case-fllog
6245       (gen-log-flonum-case
6246        (make-prim-generator **fllog-sym)))
6247
6248     (define case-flsin
6249       (gen-simple-case **flonum?-sym **flsin-sym))
6250
6251     (define case-flcos
6252       (gen-simple-case **flonum?-sym **flcos-sym))
6253
6254     (define case-fltan
6255       (gen-simple-case **flonum?-sym **fltan-sym))
6256
6257     (define case-flasin
6258       (gen-asin-acos-atan-flonum-case
6259        (make-prim-generator **flasin-sym)))
6260
6261     (define case-flacos
6262       (gen-asin-acos-atan-flonum-case
6263        (make-prim-generator **flacos-sym)))
6264
6265     (define case-flatan
6266       (gen-asin-acos-atan-flonum-case
6267        (make-prim-generator **flatan-sym)))
6268
6269     (define case-flexpt
6270       (gen-expt-flonum-case
6271        (make-prim-generator **flexpt-sym)))
6272
6273     (define case-flsqrt
6274       (gen-sqrt-flonum-case
6275        (make-prim-generator **flsqrt-sym)))
6276
6277     (define case-flonum-exact->inexact
6278       (gen-flonum-case
6279        gen-first-arg))
6280
6281     (define case-flonum-inexact->exact
6282       no-case)
6283
6284     (define case-char=?
6285       (gen-simple-case **char?-sym **char=?-sym))
6286
6287     (define case-char<?
6288       (gen-simple-case **char?-sym **char<?-sym))
6289
6290     (define case-char>?
6291       (gen-simple-case **char?-sym **char>?-sym))
6292
6293     (define case-char<=?
6294       (gen-simple-case **char?-sym **char<=?-sym))
6295
6296     (define case-char>=?
6297       (gen-simple-case **char?-sym **char>=?-sym))
6298
6299     (define (case-eqv?-or-equal? prim)
6300       (lambda (source
6301                env
6302                vars
6303                check-run-time-binding
6304                invalid
6305                fail)
6306         (gen-check-run-time-binding
6307          check-run-time-binding
6308          source
6309          env
6310          (lambda ()
6311            (let ((var1 (car vars))
6312                  (var2 (cadr vars)))
6313              (new-disj source env
6314                (gen-call-prim source env
6315                  **eq?-sym
6316                  (list (new-ref source env
6317                          var1)
6318                        (new-ref source env
6319                          var2)))
6320                (new-conj source env
6321                  (gen-call-prim source env
6322                    prim
6323                    (list (new-ref source env
6324                            var1)))
6325                  (new-conj source env
6326                    (gen-call-prim source env
6327                      prim
6328                      (list (new-ref source env
6329                              var2)))
6330                    (new-conj source env
6331                      (gen-call-prim source env
6332                        **fx=-sym
6333                        (list (gen-call-prim source env
6334                                **subtype-sym
6335                                (list (new-ref source env
6336                                        var1)))
6337                              (gen-call-prim source env
6338                                **subtype-sym
6339                                (list (new-ref source env
6340                                        var2)))))
6341                      (invalid)))))))
6342          fail)))
6343
6344     (define case-real?
6345       (lambda (source
6346                env
6347                vars
6348                check-run-time-binding
6349                invalid
6350                fail)
6351         (gen-check-run-time-binding
6352          check-run-time-binding
6353          source
6354          env
6355          (lambda ()
6356            (new-disj source env
6357              (gen-call-prim-vars source env **fixnum?-sym vars)
6358              (new-disj source env
6359                (gen-call-prim-vars source env **flonum?-sym vars)
6360                (gen-call-prim-vars source (add-not-inline-primitive? env)
6361                  **real?-sym
6362                  vars))))
6363          fail)))
6364
6365     (define case-rational?
6366       (lambda (source
6367                env
6368                vars
6369                check-run-time-binding
6370                invalid
6371                fail)
6372         (gen-check-run-time-binding
6373          check-run-time-binding
6374          source
6375          env
6376          (lambda ()
6377            (new-disj source env
6378              (gen-call-prim-vars source env **fixnum?-sym vars)
6379              (new-tst source env
6380                (gen-call-prim-vars source env **flonum?-sym vars)
6381                (gen-call-prim-vars source env **flfinite?-sym vars)
6382                (gen-call-prim-vars source (add-not-inline-primitive? env)
6383                  **rational?-sym
6384                  vars))))
6385          fail)))
6386
6387     (define case-integer?
6388       (lambda (source
6389                env
6390                vars
6391                check-run-time-binding
6392                invalid
6393                fail)
6394         (gen-check-run-time-binding
6395          check-run-time-binding
6396          source
6397          env
6398          (lambda ()
6399            (new-disj source env
6400              (gen-call-prim-vars source env **fixnum?-sym vars)
6401              (gen-call-prim-vars source (add-not-inline-primitive? env)
6402                **integer?-sym
6403                vars)))
6404          fail)))
6405
6406     (define (case-exact? fallback)
6407       (lambda (source
6408                env
6409                vars
6410                check-run-time-binding
6411                invalid
6412                fail)
6413         (gen-check-run-time-binding
6414          check-run-time-binding
6415          source
6416          env
6417          (lambda ()
6418            (new-disj source env
6419              (gen-call-prim-vars source env **fixnum?-sym vars)
6420              (new-conj source env
6421                (gen-call-prim source env
6422                  **not-sym
6423                  (list (gen-call-prim-vars source env **flonum?-sym vars)))
6424                (gen-call-prim-vars source (add-not-inline-primitive? env)
6425                  fallback
6426                  vars))))
6427          fail)))
6428
6429     (define (case-inexact? fallback)
6430       (lambda (source
6431                env
6432                vars
6433                check-run-time-binding
6434                invalid
6435                fail)
6436         (gen-check-run-time-binding
6437          check-run-time-binding
6438          source
6439          env
6440          (lambda ()
6441            (new-conj source env
6442              (gen-call-prim source env
6443                **not-sym
6444                (list (gen-call-prim-vars source env **fixnum?-sym vars)))
6445              (new-disj source env
6446                (gen-call-prim-vars source env **flonum?-sym vars)
6447                (gen-call-prim-vars source (add-not-inline-primitive? env)
6448                  fallback
6449                  vars))))
6450          fail)))
6451
6452     (targ-exp "##real?"     (make-simple-expander case-real?))
6453     (targ-exp "##rational?" (make-simple-expander case-rational?))
6454     (targ-exp "##integer?"  (make-simple-expander case-integer?))
6455     (targ-exp "##exact?"    (make-simple-expander (case-exact? **exact?-sym)))
6456     (targ-exp "##inexact?"  (make-simple-expander (case-inexact? **inexact?-sym)))
6457
6458     (targ-exp "exact?"      (make-simple-expander (case-exact? exact?-sym)))
6459     (targ-exp "inexact?"    (make-simple-expander (case-inexact? inexact?-sym)))
6460
6461     (targ-exp "fx=" (make-simple-expander case-fx=))
6462     (targ-exp "fl=" (make-simple-expander case-fl=))
6463     (targ-exp "="   (make-fixflo-expander case-fx= case-fl=))
6464
6465     (targ-exp "fx<" (make-simple-expander case-fx<))
6466     (targ-exp "fl<" (make-simple-expander case-fl<))
6467     (targ-exp "<"   (make-fixflo-expander case-fx< case-fl<))
6468
6469     (targ-exp "fx>" (make-simple-expander case-fx>))
6470     (targ-exp "fl>" (make-simple-expander case-fl>))
6471     (targ-exp ">"   (make-fixflo-expander case-fx> case-fl>))
6472
6473     (targ-exp "fx<=" (make-simple-expander case-fx<=))
6474     (targ-exp "fl<=" (make-simple-expander case-fl<=))
6475     (targ-exp "<="   (make-fixflo-expander case-fx<= case-fl<=))
6476
6477     (targ-exp "fx>=" (make-simple-expander case-fx>=))
6478     (targ-exp "fl>=" (make-simple-expander case-fl>=))
6479     (targ-exp ">="   (make-fixflo-expander case-fx>= case-fl>=))
6480
6481     (targ-exp "flinteger?" (make-simple-expander case-flinteger?))
6482
6483     (targ-exp "fxzero?" (make-simple-expander case-fxzero?))
6484     (targ-exp "flzero?" (make-simple-expander case-flzero?))
6485     (targ-exp "zero?"   (make-fixflo-expander case-fxzero? case-flzero?))
6486
6487     (targ-exp "fxpositive?" (make-simple-expander case-fxpositive?))
6488     (targ-exp "flpositive?" (make-simple-expander case-flpositive?))
6489     (targ-exp "positive?"   (make-fixflo-expander case-fxpositive? case-flpositive?))
6490
6491     (targ-exp "fxnegative?" (make-simple-expander case-fxnegative?))
6492     (targ-exp "flnegative?" (make-simple-expander case-flnegative?))
6493     (targ-exp "negative?"   (make-fixflo-expander case-fxnegative? case-flnegative?))
6494
6495     (targ-exp "fxodd?" (make-simple-expander case-fxodd?))
6496     (targ-exp "flodd?" (make-simple-expander case-flodd?))
6497     (targ-exp "odd?"   (make-fixflo-expander case-fxodd? case-flodd?))
6498
6499     (targ-exp "fxeven?" (make-simple-expander case-fxeven?))
6500     (targ-exp "fleven?" (make-simple-expander case-fleven?))
6501     (targ-exp "even?"   (make-fixflo-expander case-fxeven? case-fleven?))
6502
6503     (targ-exp "flfinite?" (make-simple-expander case-flfinite?))
6504     (targ-exp "finite?"   (make-fixflo-expander no-case case-flfinite?))
6505
6506     (targ-exp "flinfinite?" (make-simple-expander case-flinfinite?))
6507     (targ-exp "infinite?"   (make-fixflo-expander no-case case-flinfinite?))
6508
6509     (targ-exp "flnan?" (make-simple-expander case-flnan?))
6510     (targ-exp "nan?"   (make-fixflo-expander no-case case-flnan?))
6511
6512     (targ-exp "fxmax" (make-simple-expander case-fxmax))
6513     (targ-exp "flmax" (make-simple-expander case-flmax))
6514     (targ-exp "max"   (make-fixflo-expander case-fxmax case-flmax))
6515
6516     (targ-exp "fxmin" (make-simple-expander case-fxmin))
6517     (targ-exp "flmin" (make-simple-expander case-flmin))
6518     (targ-exp "min"   (make-fixflo-expander case-fxmin case-flmin))
6519
6520     (targ-exp "fxwrap+" (make-simple-expander case-fxwrap+))
6521     (targ-exp "fx+"     (make-simple-expander case-fx+))
6522     (targ-exp "fl+"     (make-simple-expander case-fl+))
6523     (targ-exp "+"       (make-fixflo-expander
6524                          case-fx+
6525                          (gen-validating-case
6526                           **flonum?-sym
6527                           (make-nary-generator
6528                            gen-fixnum-0
6529                            gen-first-arg
6530                            (make-fold-generator **fl+-sym)))))
6531
6532     (targ-exp "fxwrap*" (make-simple-expander case-fxwrap*))
6533     (targ-exp "fx*"     (make-simple-expander case-fx*))
6534     (targ-exp "fl*"     (make-simple-expander case-fl*))
6535     (targ-exp "*"       (make-fixflo-expander
6536                          case-fx*
6537                          (gen-validating-case
6538                           **flonum?-sym
6539                           (make-nary-generator
6540                            gen-fixnum-1
6541                            gen-first-arg
6542                            (make-fold-generator **fl*-sym)))))
6543
6544     (targ-exp "fxwrap-" (make-simple-expander case-fxwrap-))
6545     (targ-exp "fx-"     (make-simple-expander case-fx-))
6546     (targ-exp "fl-"     (make-simple-expander case-fl-))
6547     (targ-exp "-"       (make-fixflo-expander case-fx- case-fl-))
6548
6549     (targ-exp "fl/"     (make-simple-expander case-fl/))
6550     (targ-exp "/"       (make-fixflo-expander no-case case-fl/))
6551
6552     (targ-exp "fxwrapquotient" (make-simple-expander case-fxwrapquotient))
6553     (targ-exp "fxquotient"     (make-simple-expander case-fxquotient))
6554     (targ-exp "quotient"       (make-fixnum-division-expander case-fxquotient))
6555
6556     (targ-exp "fxremainder" (make-simple-expander case-fxremainder))
6557     (targ-exp "remainder"   (make-fixnum-division-expander case-fxremainder))
6558
6559     (targ-exp "fxmodulo" (make-simple-expander case-fxmodulo))
6560     (targ-exp "modulo"   (make-fixnum-division-expander case-fxmodulo))
6561
6562     (targ-exp "fxnot" (make-simple-expander case-fxnot))
6563
6564     (targ-exp "fxand" (make-simple-expander case-fxand))
6565
6566     (targ-exp "fxior" (make-simple-expander case-fxior))
6567
6568     (targ-exp "fxxor" (make-simple-expander case-fxxor))
6569
6570 ;;  (targ-exp "fxwraparithmetic-shift" (make-simple-expander case-fxwraparithmetic-shift))
6571 ;;  (targ-exp "fxarithmetic-shift" (make-simple-expander case-fxarithmetic-shift))
6572
6573 ;;  (targ-exp "fxwraparithmetic-shift-left" (make-simple-expander case-fxwraparithmetic-shift-left))
6574 ;;  (targ-exp "fxarithmetic-shift-left" (make-simple-expander case-fxarithmetic-shift-left))
6575
6576 ;;  (targ-exp "fxarithmetic-shift-right" (make-simple-expander case-fxarithmetic-shift-right))
6577 ;;  (targ-exp "fxwraplogical-shift-right" (make-simple-expander case-fxwraplogical-shift-right))
6578
6579     (targ-exp "fxwrapabs" (make-simple-expander case-fxwrapabs))
6580     (targ-exp "fxabs" (make-simple-expander case-fxabs))
6581     (targ-exp "flabs" (make-simple-expander case-flabs))
6582     (targ-exp "abs"   (make-fixflo-expander case-fxabs case-flabs))
6583
6584     (targ-exp "flfloor" (make-simple-expander case-flfloor))
6585     (targ-exp "floor"   (make-fixflo-expander no-case case-flfloor))
6586
6587     (targ-exp "flceiling" (make-simple-expander case-flceiling))
6588     (targ-exp "ceiling"   (make-fixflo-expander no-case case-flceiling))
6589
6590     (targ-exp "fltruncate" (make-simple-expander case-fltruncate))
6591     (targ-exp "truncate"   (make-fixflo-expander no-case case-fltruncate))
6592
6593     (targ-exp "flround" (make-simple-expander case-flround))
6594     (targ-exp "round"   (make-fixflo-expander no-case case-flround))
6595
6596     (targ-exp "flexp" (make-simple-expander case-flexp))
6597     (targ-exp "exp"   (make-fixflo-expander no-case case-flexp))
6598
6599     (targ-exp "fllog" (make-simple-expander case-fllog))
6600     (targ-exp "log"   (make-fixflo-expander no-case case-fllog))
6601
6602     (targ-exp "flsin" (make-simple-expander case-flsin))
6603     (targ-exp "sin"   (make-fixflo-expander no-case case-flsin))
6604
6605     (targ-exp "flcos" (make-simple-expander case-flcos))
6606     (targ-exp "cos"   (make-fixflo-expander no-case case-flcos))
6607
6608     (targ-exp "fltan" (make-simple-expander case-fltan))
6609     (targ-exp "tan"   (make-fixflo-expander no-case case-fltan))
6610
6611     (targ-exp "flasin" (make-simple-expander case-flasin))
6612     (targ-exp "asin"   (make-fixflo-expander no-case case-flasin))
6613
6614     (targ-exp "flacos" (make-simple-expander case-flacos))
6615     (targ-exp "acos"   (make-fixflo-expander no-case case-flacos))
6616
6617     (targ-exp "flatan" (make-simple-expander case-flatan))
6618     (targ-exp "atan"   (make-fixflo-expander no-case case-flatan))
6619
6620     (targ-exp "flexpt" (make-simple-expander case-flexpt))
6621     (targ-exp "expt"   (make-fixflo-expander no-case case-flexpt))
6622
6623     (targ-exp "flsqrt" (make-simple-expander case-flsqrt))
6624     (targ-exp "sqrt"   (make-fixflo-expander no-case case-flsqrt))
6625
6626     (targ-exp "fixnum->flonum" (make-simple-expander case-fixnum->flonum))
6627
6628     (targ-exp
6629      "exact->inexact"
6630      (make-fixflo-expander
6631       case-fixnum-exact->inexact
6632       case-flonum-exact->inexact))
6633
6634     (targ-exp
6635      "inexact->exact"
6636      (make-fixflo-expander
6637       case-fixnum-inexact->exact
6638       case-flonum-inexact->exact))
6639
6640     (targ-exp "char=?" (make-simple-expander case-char=?))
6641     (targ-exp "char<?" (make-simple-expander case-char<?))
6642     (targ-exp "char>?" (make-simple-expander case-char>?))
6643     (targ-exp "char<=?" (make-simple-expander case-char<=?))
6644     (targ-exp "char>=?" (make-simple-expander case-char>=?))
6645
6646     (targ-exp
6647      "eqv?"
6648      (make-simple-expander (case-eqv?-or-equal? **subtyped?-sym)))
6649
6650     (targ-exp
6651      "##eqv?"
6652      (make-simple-expander (case-eqv?-or-equal? **subtyped?-sym)))
6653
6654     (targ-exp
6655      "equal?"
6656      (make-simple-expander (case-eqv?-or-equal? **mem-allocated?-sym)))
6657 ))
6658
6659 (define (setup-vector-primitives)
6660
6661   (define **fixnum?-sym (string->canonical-symbol "##fixnum?"))
6662   (define **flonum?-sym (string->canonical-symbol "##flonum?"))
6663   (define **char?-sym   (string->canonical-symbol "##char?"))
6664   (define **fx<-sym     (string->canonical-symbol "##fx<"))
6665   (define **fx<=-sym    (string->canonical-symbol "##fx<="))
6666   (define **subtyped-mutable?-sym (string->canonical-symbol "##subtyped-mutable?"))
6667
6668   (define **string?-sym          (string->canonical-symbol "##string?"))
6669   (define **string-length-sym    (string->canonical-symbol "##string-length"))
6670   (define **string-ref-sym       (string->canonical-symbol "##string-ref"))
6671   (define **string-set!-sym      (string->canonical-symbol "##string-set!"))
6672
6673   (define **vector?-sym          (string->canonical-symbol "##vector?"))
6674   (define **vector-length-sym    (string->canonical-symbol "##vector-length"))
6675   (define **vector-ref-sym       (string->canonical-symbol "##vector-ref"))
6676   (define **vector-set!-sym      (string->canonical-symbol "##vector-set!"))
6677
6678   (define **s8vector?-sym        (string->canonical-symbol "##s8vector?"))
6679   (define **s8vector-length-sym  (string->canonical-symbol "##s8vector-length"))
6680   (define **s8vector-ref-sym     (string->canonical-symbol "##s8vector-ref"))
6681   (define **s8vector-set!-sym    (string->canonical-symbol "##s8vector-set!"))
6682
6683   (define **u8vector?-sym        (string->canonical-symbol "##u8vector?"))
6684   (define **u8vector-length-sym  (string->canonical-symbol "##u8vector-length"))
6685   (define **u8vector-ref-sym     (string->canonical-symbol "##u8vector-ref"))
6686   (define **u8vector-set!-sym    (string->canonical-symbol "##u8vector-set!"))
6687
6688   (define **s16vector?-sym       (string->canonical-symbol "##s16vector?"))
6689   (define **s16vector-length-sym (string->canonical-symbol "##s16vector-length"))
6690   (define **s16vector-ref-sym    (string->canonical-symbol "##s16vector-ref"))
6691   (define **s16vector-set!-sym   (string->canonical-symbol "##s16vector-set!"))
6692
6693   (define **u16vector?-sym       (string->canonical-symbol "##u16vector?"))
6694   (define **u16vector-length-sym (string->canonical-symbol "##u16vector-length"))
6695   (define **u16vector-ref-sym    (string->canonical-symbol "##u16vector-ref"))
6696   (define **u16vector-set!-sym   (string->canonical-symbol "##u16vector-set!"))
6697
6698   (define **s32vector?-sym       (string->canonical-symbol "##s32vector?"))
6699   (define **s32vector-length-sym (string->canonical-symbol "##s32vector-length"))
6700   (define **s32vector-ref-sym    (string->canonical-symbol "##s32vector-ref"))
6701   (define **s32vector-set!-sym   (string->canonical-symbol "##s32vector-set!"))
6702
6703   (define **u32vector?-sym       (string->canonical-symbol "##u32vector?"))
6704   (define **u32vector-length-sym (string->canonical-symbol "##u32vector-length"))
6705   (define **u32vector-ref-sym    (string->canonical-symbol "##u32vector-ref"))
6706   (define **u32vector-set!-sym   (string->canonical-symbol "##u32vector-set!"))
6707
6708   (define **s64vector?-sym       (string->canonical-symbol "##s64vector?"))
6709   (define **s64vector-length-sym (string->canonical-symbol "##s64vector-length"))
6710   (define **s64vector-ref-sym    (string->canonical-symbol "##s64vector-ref"))
6711   (define **s64vector-set!-sym   (string->canonical-symbol "##s64vector-set!"))
6712
6713   (define **u64vector?-sym       (string->canonical-symbol "##u64vector?"))
6714   (define **u64vector-length-sym (string->canonical-symbol "##u64vector-length"))
6715   (define **u64vector-ref-sym    (string->canonical-symbol "##u64vector-ref"))
6716   (define **u64vector-set!-sym   (string->canonical-symbol "##u64vector-set!"))
6717
6718   (define **f32vector?-sym       (string->canonical-symbol "##f32vector?"))
6719   (define **f32vector-length-sym (string->canonical-symbol "##f32vector-length"))
6720   (define **f32vector-ref-sym    (string->canonical-symbol "##f32vector-ref"))
6721   (define **f32vector-set!-sym   (string->canonical-symbol "##f32vector-set!"))
6722
6723   (define **f64vector?-sym       (string->canonical-symbol "##f64vector?"))
6724   (define **f64vector-length-sym (string->canonical-symbol "##f64vector-length"))
6725   (define **f64vector-ref-sym    (string->canonical-symbol "##f64vector-ref"))
6726   (define **f64vector-set!-sym   (string->canonical-symbol "##f64vector-set!"))
6727
6728   (define (make-fixnum-interval-checker lo hi)
6729     ; assumes (integer-length hi) >= (integer-length lo)
6730     (lambda (source env var)
6731       (if (targ-fixnum64? hi)
6732         (let ((interval-check
6733                (gen-fixnum-interval-check source env
6734                  var
6735                  (new-cst source env
6736                    lo)
6737                  (new-cst source env
6738                    hi)
6739                  #t)))
6740           (if (targ-fixnum32? hi)
6741             interval-check
6742             (new-conj source env
6743               (gen-call-prim source env
6744                 **fixnum?-sym
6745                 (list (new-cst source env
6746                         hi)))
6747               interval-check)))
6748         (gen-call-prim-vars source env
6749           **fixnum?-sym
6750           (list var)))))
6751
6752   (define (make-flonum-checker)
6753     (lambda (source env var)
6754       (gen-call-prim-vars source env
6755         **flonum?-sym
6756         (list var))))
6757
6758   (define (gen-fixnum-interval-check source env var lo hi incl?)
6759     (let* ((fixnum-check
6760             (gen-call-prim-vars source env
6761               **fixnum?-sym
6762               (list var)))
6763            (interval-check
6764             (new-conj source env
6765               fixnum-check
6766               (new-conj source env
6767                 (gen-call-prim source env
6768                   **fx<=-sym
6769                   (list lo
6770                         (new-ref source env
6771                           var)))
6772                 (gen-call-prim source env
6773                   (if incl? **fx<=-sym **fx<-sym)
6774                   (list (new-ref source env
6775                           var)
6776                         hi))))))
6777       interval-check))
6778
6779   (define (make-vector-expanders
6780            vect?-str
6781            vect-length-str
6782            vect-ref-str
6783            vect-set!-str
6784            **vect?-str
6785            **vect-length-str
6786            **vect-ref-str
6787            **vect-set!-str
6788            value-checker)
6789     (let ((vect?-sym (string->canonical-symbol vect?-str))
6790           (vect-length-sym (string->canonical-symbol vect-length-str))
6791           (vect-ref-sym (string->canonical-symbol vect-ref-str))
6792           (vect-set!-sym (string->canonical-symbol vect-set!-str))
6793           (**vect?-sym (string->canonical-symbol **vect?-str))
6794           (**vect-length-sym (string->canonical-symbol **vect-length-str))
6795           (**vect-ref-sym (string->canonical-symbol **vect-ref-str))
6796           (**vect-set!-sym (string->canonical-symbol **vect-set!-str)))
6797
6798       (define (gen-type-check source env vect-arg)
6799         (gen-call-prim-vars source env
6800           **vect?-sym
6801           (list vect-arg)))
6802
6803       (define (gen-mutability-check source env vect-arg)
6804         (gen-call-prim-vars source env
6805           **subtyped-mutable?-sym
6806           (list vect-arg)))
6807
6808       (define (gen-index-check source env vect-arg index-arg)
6809         (gen-fixnum-interval-check source env
6810           index-arg
6811           (new-cst source env
6812             0)
6813           (gen-call-prim-vars source env
6814             **vect-length-sym
6815             (list vect-arg))
6816           #f))
6817
6818       (define (make-length-expander type-check?)
6819         (lambda (ptree oper args generate-call check-run-time-binding)
6820           (let* ((source
6821                   (node-source ptree))
6822                  (env
6823                   (node-env ptree))
6824                  (vars
6825                   (gen-temp-vars source args))
6826                  (arg1
6827                   (car vars))
6828                  (type-check
6829                   (and type-check?
6830                        (gen-type-check source env arg1)))
6831                  (checks
6832                   (if check-run-time-binding
6833                     (let ((rtb-check (check-run-time-binding)))
6834                       (if type-check
6835                         (new-conj source env
6836                           rtb-check
6837                           type-check)
6838                         rtb-check))
6839                     type-check))
6840                  (call-prim
6841                   (gen-call-prim-vars source env
6842                     **vect-length-sym
6843                     vars)))
6844             (gen-prc source env
6845               vars
6846               (if checks
6847                 (new-tst source env
6848                   checks
6849                   call-prim
6850                   (generate-call vars))
6851                 call-prim)))))
6852
6853       (define (make-ref-set!-expander type-check? set!?)
6854         (lambda (ptree oper args generate-call check-run-time-binding)
6855           (let* ((source
6856                   (node-source ptree))
6857                  (env
6858                   (node-env ptree))
6859                  (vars
6860                   (gen-temp-vars source args))
6861                  (arg1
6862                   (car vars))
6863                  (arg2
6864                   (cadr vars))
6865                  (type-check
6866                   (and type-check?
6867                        (let ((check
6868                               (gen-type-check source env arg1)))
6869                          (if set!?
6870                            (new-conj source env
6871                              check
6872                              (gen-mutability-check source env arg1))
6873                            check))))
6874                  (index-check
6875                   (gen-index-check source env arg1 arg2))
6876                  (index-value-check
6877                   (if (and value-checker set!?)
6878                     (let ((val-check (value-checker source env (caddr vars))))
6879                       (new-conj source env
6880                         index-check
6881                         val-check))
6882                     index-check))
6883                  (type-index-value-check
6884                   (if type-check
6885                     (new-conj source env
6886                       type-check
6887                       index-value-check)
6888                     index-value-check))
6889                  (checks
6890                   (if check-run-time-binding
6891                     (let ((rtb-check (check-run-time-binding)))
6892                       (if type-index-value-check
6893                         (new-conj source env
6894                           rtb-check
6895                           type-index-value-check)
6896                         rtb-check))
6897                     type-index-value-check))
6898                  (call-prim
6899                   (gen-call-prim-vars source env
6900                     (if set!? **vect-set!-sym **vect-ref-sym)
6901                     vars)))
6902             (gen-prc source env
6903               vars
6904               (if checks
6905                 (new-tst source env
6906                   checks
6907                   call-prim
6908                   (generate-call vars))
6909                 call-prim)))))
6910
6911       (targ-exp
6912        vect-length-str
6913        (make-length-expander #t))
6914
6915       (targ-exp
6916        vect-ref-str
6917        (make-ref-set!-expander #t #f))
6918
6919       (targ-exp
6920        vect-set!-str
6921        (make-ref-set!-expander #t #t))))
6922
6923   (make-vector-expanders
6924    "vector?"
6925    "vector-length"
6926    "vector-ref"
6927    "vector-set!"
6928    "##vector?"
6929    "##vector-length"
6930    "##vector-ref"
6931    "##vector-set!"
6932    #f)
6933
6934   (make-vector-expanders
6935    "string?"
6936    "string-length"
6937    "string-ref"
6938    "string-set!"
6939    "##string?"
6940    "##string-length"
6941    "##string-ref"
6942    "##string-set!"
6943    (lambda (source env var)
6944      (gen-call-prim-vars source env
6945        **char?-sym
6946        (list var))))
6947
6948   (make-vector-expanders
6949    "s8vector?"
6950    "s8vector-length"
6951    "s8vector-ref"
6952    "s8vector-set!"
6953    "##s8vector?"
6954    "##s8vector-length"
6955    "##s8vector-ref"
6956    "##s8vector-set!"
6957    (make-fixnum-interval-checker -128 127))
6958
6959   (make-vector-expanders
6960    "u8vector?"
6961    "u8vector-length"
6962    "u8vector-ref"
6963    "u8vector-set!"
6964    "##u8vector?"
6965    "##u8vector-length"
6966    "##u8vector-ref"
6967    "##u8vector-set!"
6968    (make-fixnum-interval-checker 0 255))
6969
6970   (make-vector-expanders
6971    "s16vector?"
6972    "s16vector-length"
6973    "s16vector-ref"
6974    "s16vector-set!"
6975    "##s16vector?"
6976    "##s16vector-length"
6977    "##s16vector-ref"
6978    "##s16vector-set!"
6979    (make-fixnum-interval-checker -32768 32767))
6980
6981   (make-vector-expanders
6982    "u16vector?"
6983    "u16vector-length"
6984    "u16vector-ref"
6985    "u16vector-set!"
6986    "##u16vector?"
6987    "##u16vector-length"
6988    "##u16vector-ref"
6989    "##u16vector-set!"
6990    (make-fixnum-interval-checker 0 65535))
6991
6992 #;
6993   (make-vector-expanders
6994    "s32vector?"
6995    "s32vector-length"
6996    "s32vector-ref"
6997    "s32vector-set!"
6998    "##s32vector?"
6999    "##s32vector-length"
7000    "##s32vector-ref"
7001    "##s32vector-set!"
7002    (make-fixnum-interval-checker -2147483648 2147483647))
7003
7004 #;
7005   (make-vector-expanders
7006    "u32vector?"
7007    "u32vector-length"
7008    "u32vector-ref"
7009    "u32vector-set!"
7010    "##u32vector?"
7011    "##u32vector-length"
7012    "##u32vector-ref"
7013    "##u32vector-set!"
7014    (make-fixnum-interval-checker 0 4294967295))
7015
7016 #;
7017   (make-vector-expanders
7018    "s64vector?"
7019    "s64vector-length"
7020    "s64vector-ref"
7021    "s64vector-set!"
7022    "##s64vector?"
7023    "##s64vector-length"
7024    "##s64vector-ref"
7025    "##s64vector-set!"
7026    (make-fixnum-interval-checker -9223372036854775808 9223372036854775807))
7027
7028 #;
7029   (make-vector-expanders
7030    "u64vector?"
7031    "u64vector-length"
7032    "u64vector-ref"
7033    "u64vector-set!"
7034    "##u64vector?"
7035    "##u64vector-length"
7036    "##u64vector-ref"
7037    "##u64vector-set!"
7038    (make-fixnum-interval-checker 0 18446744073709551615))
7039
7040   (make-vector-expanders
7041    "f32vector?"
7042    "f32vector-length"
7043    "f32vector-ref"
7044    "f32vector-set!"
7045    "##f32vector?"
7046    "##f32vector-length"
7047    "##f32vector-ref"
7048    "##f32vector-set!"
7049    (make-flonum-checker))
7050
7051   (make-vector-expanders
7052    "f64vector?"
7053    "f64vector-length"
7054    "f64vector-ref"
7055    "f64vector-set!"
7056    "##f64vector?"
7057    "##f64vector-length"
7058    "##f64vector-ref"
7059    "##f64vector-set!"
7060    (make-flonum-checker))
7061 )
7062
7063 (define (setup-structure-primitives)
7064
7065   (define **structure-direct-instance-of?-sym
7066     (string->canonical-symbol "##structure-direct-instance-of?"))
7067
7068   (define **type-id-sym
7069     (string->canonical-symbol "##type-id"))
7070
7071   (define **unchecked-structure-ref-sym
7072     (string->canonical-symbol "##unchecked-structure-ref"))
7073
7074   (define **unchecked-structure-set!-sym
7075     (string->canonical-symbol "##unchecked-structure-set!"))
7076
7077   (define (gen-type-check source env obj-arg type-arg)
7078     (gen-call-prim source env
7079       **structure-direct-instance-of?-sym
7080       (list (new-ref source env
7081               obj-arg)
7082             (gen-call-prim-vars source env
7083               **type-id-sym
7084               (list type-arg)))))
7085
7086   (define (make-ref-set!-expander set!?)
7087     (lambda (ptree oper args generate-call check-run-time-binding)
7088       (let* ((source
7089               (node-source ptree))
7090              (env
7091               (node-env ptree))
7092              (vars
7093               (gen-temp-vars source args))
7094              (obj-var
7095               (list-ref vars 0))
7096              (type-var
7097               (list-ref vars (if set!? 3 2)))
7098              (type-check
7099               (gen-type-check source env obj-var type-var))
7100              (call-prim
7101               (gen-call-prim-vars source env
7102                 (if set!?
7103                   **unchecked-structure-set!-sym
7104                   **unchecked-structure-ref-sym)
7105                 vars)))
7106         (gen-prc source env
7107           vars
7108           (new-tst source env
7109             type-check
7110             call-prim
7111             (generate-call vars))))))
7112
7113   (targ-exp
7114    "##direct-structure-ref"
7115    (make-ref-set!-expander #f))
7116
7117   (targ-exp
7118    "##direct-structure-set!"
7119    (make-ref-set!-expander #t))
7120 )
7121
7122 (setup-list-primitives)
7123 (setup-numeric-primitives)
7124 (setup-vector-primitives)
7125 (setup-structure-primitives)
7126
7127 )
7128
7129 (targ-setup-expanders)
7130
7131 ;;;----------------------------------------------------------------------------