Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

4881 lines (4181 sloc) 197.029 kB
;;;============================================================================
;;; File: "_t-c-2.scm"
;;; Copyright (c) 1994-2012 by Marc Feeley, All Rights Reserved.
(include "fixnum.scm")
(include-adt "_envadt.scm")
(include-adt "_gvmadt.scm")
(include-adt "_ptreeadt.scm")
(include-adt "_sourceadt.scm")
'(begin;**************brad
(##include "../gsc/_utilsadt.scm")
(##include "../gsc/_ptree1adt.scm")
(##include "../gsc/_gvmadt.scm")
(##include "../gsc/_hostadt.scm")
)
;;;----------------------------------------------------------------------------
;;
;; Back end for C language (part 2)
;; -----------------------
(define (targ-scan-procedure obj)
(let* ((proc (car obj))
(p (cdr obj)))
(if targ-info-port
(begin
(display " #<" targ-info-port)
(if (proc-obj-primitive? proc)
(display "primitive " targ-info-port)
(display "procedure " targ-info-port))
(write (string->canonical-symbol (proc-obj-name proc)) targ-info-port)
(display ">" targ-info-port)))
(set! targ-proc-name (proc-obj-name proc))
(set! targ-proc-code (make-stretchable-vector #f))
(set! targ-proc-code-length 0)
(set! targ-proc-rd-res (make-stretchable-vector #f))
(set! targ-proc-wr-res (make-stretchable-vector #f))
(set! targ-proc-lbl-tbl (queue-empty))
(set! targ-proc-lbl-tbl-ord (queue-empty))
(set! targ-debug-info? #f)
(set! targ-var-descr-queue (queue-empty))
(set! targ-first-class-label-queue (queue-empty))
;; (targ-repr-begin-proc!)
(let ((x (proc-obj-code proc)))
(if (bbs? x)
(targ-scan-scheme-procedure x)
(targ-scan-c-procedure x)))
;; (targ-repr-end-proc!)
(targ-cell-set! (caddr p) (+ targ-lbl-alloc 1))
; Assign label numbers sequentially, starting with "value" labels
; and then "goto" labels
(let ((ord-lbls (queue->list targ-proc-lbl-tbl-ord)))
(let loop2 ((l ord-lbls) (i 0) (val-lbls '()))
(if (pair? l)
(let ((x (car l)))
(if (targ-lbl-val? x)
(begin
(targ-cell-set! (targ-lbl-num x) i)
(loop2 (cdr l) (+ i 1) (cons x val-lbls)))
(loop2 (cdr l) i val-lbls)))
(let ((info (targ-debug-info)))
(targ-use-obj info)
(set! targ-lbl-alloc (+ targ-lbl-alloc (+ i 1)))
(set-car! p
(vector targ-proc-code
(reverse val-lbls)
targ-proc-rd-res
targ-proc-wr-res
info))
(let loop3 ((l ord-lbls) (i i))
(if (pair? l)
(let ((x (car l)))
(if (and (targ-lbl-goto? x)
(not (targ-lbl-val? x)))
(begin
(targ-cell-set! (targ-lbl-num x) i)
(loop3 (cdr l) (+ i 1)))
(loop3 (cdr l) i)))))))))
(if targ-info-port
(newline targ-info-port))
))
(define (targ-debug-info)
(define (number i lst)
(if (null? lst)
'()
(cons (list->vect (cons i (car lst)))
(number (+ i 1) (cdr lst)))))
(if targ-debug-info?
(vector (list->vect (number 0 (queue->list targ-first-class-label-queue)))
(list->vect (queue->list targ-var-descr-queue)))
#f))
(define (targ-scan-scheme-procedure bbs)
(set! targ-proc-entry-lbl (bbs-entry-lbl-num bbs))
(set! targ-proc-lbl-counter (make-counter (bbs-next-lbl-num bbs)))
(let loop ((prev-bb #f)
(prev-gvm-instr #f)
(l (bbs->code-list bbs)))
(if (not (null? l))
(let ((pres-bb (code-bb (car l)))
(pres-gvm-instr (code-gvm-instr (car l)))
(pres-slots-needed (code-slots-needed (car l)))
(next-gvm-instr (if (null? (cdr l))
#f
(code-gvm-instr (cadr l)))))
(targ-gen-gvm-instr prev-gvm-instr
pres-gvm-instr
next-gvm-instr
pres-slots-needed)
(loop pres-bb pres-gvm-instr (cdr l))))))
(define (targ-scan-c-procedure c-proc)
(define (ps-opnd opnd)
(cond ((reg? opnd)
(let ((n (reg-num opnd)))
(cons 'psr n)))
(else ; must be stack slot
(list "PSSTK" (- (stk-num opnd) targ-proc-fp)))))
(let* ((arity (c-proc-arity c-proc))
(pc (targ-label-info arity #f))
(pc-map (pcontext-map pc))
(pc-fs (pcontext-fs pc))
(ret (cdr (assq 'return pc-map)))
(fs (+ arity 1))
(lbl 2))
(set! targ-proc-entry-lbl 1)
(targ-start-bb pc-fs)
(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!
(targ-begin-fr) ; ************* not needed either
(targ-emit-label-entry targ-proc-entry-lbl arity #f)
(targ-ref-lbl-goto targ-proc-entry-lbl)
(targ-emit (list "IF_NARGS_EQ" arity '("NOTHING")))
(targ-emit (list "WRONG_NARGS"
(targ-ref-lbl-val targ-proc-entry-lbl)
arity 0 0))
(targ-emit (list 'append
(list "DEF_GLBL" (targ-make-glbl "" targ-proc-name))
#\newline))
;; (targ-repr-begin-block! 'entry targ-proc-entry-lbl)
; move arguments from registers to stack frame
(let loop1 ((i 1))
(if (and (<= i arity) (<= i targ-nb-arg-regs))
(begin
(targ-emit
(targ-loc (make-stk (+ pc-fs i)) (targ-opnd (make-reg i))))
(loop1 (+ i 1)))))
; store return address at top of stack frame
(targ-emit
(targ-loc (make-stk fs) (targ-opnd ret)))
;(targ-emit (targ-loc (make-stk (+ fs 1)) (targ-opnd (make-obj 1234567))));*********************
;(targ-emit (targ-loc (make-stk (+ fs 2)) (targ-opnd (make-obj 1234567))))
;(targ-emit (targ-loc (make-stk (+ fs 3)) (targ-opnd (make-obj 1234567))))
;(targ-emit (targ-loc (make-stk (+ fs 4)) (targ-opnd (make-obj 1234567))))
; setup new return address
(targ-emit
(targ-loc ret (targ-opnd (make-lbl lbl))))
(targ-emit
(targ-adjust-stack (targ-align-frame (+ fs targ-frame-reserve))))
(targ-emit
(list 'append (c-proc-body c-proc)))
(targ-emit
(list "JUMPPRM"
'("NOTHING")
(targ-opnd (make-reg 0))))
;; (targ-repr-exit-block! #f)
;; (targ-repr-end-block!)
(targ-emit-label-return lbl fs (- fs 1) (targ-build-gc-map-all-live fs) #f)
;; (targ-repr-begin-block! 'return lbl)
(targ-emit (targ-adjust-stack 0))
;; (targ-repr-exit-block! #f)
(targ-emit
(list "JUMPPRM"
'("NOTHING")
(targ-opnd (make-stk fs))))
;; (targ-repr-end-block!)
))
;;;----------------------------------------------------------------------------
;; Information attached to a procedure
(define targ-proc-name #f) ; procedure's name
(define targ-proc-code #f) ; code of the procedure
(define targ-proc-code-length #f) ; length of code of the procedure
(define targ-proc-entry-lbl #f) ; entry label
(define targ-proc-lbl-counter #f) ; label counter
(define targ-proc-rd-res #f) ; set of resources read from
(define targ-proc-wr-res #f) ; set of resources written to
(define targ-proc-lbl-tbl #f) ; table of all labels
(define targ-proc-lbl-tbl-ord #f) ; table of all labels ordered by def time
(define targ-proc-fp #f) ; frame pointer
(define targ-proc-hp #f) ; heap pointer
(define targ-debug-info? #f) ; generate debug information?
(define targ-var-descr-queue #f)
(define targ-first-class-label-queue #f)
(define targ-proc-instr-node #f)
(define targ-proc-entry-frame #f)
(define targ-proc-exit-frame #f)
;; Emit a piece of code
(define (targ-emit code)
(stretchable-vector-set! targ-proc-code targ-proc-code-length code)
(set! targ-proc-code-length (+ targ-proc-code-length 1)))
;; Emit a label
(define (targ-emit-label-simp lbl)
(targ-emit-label lbl #f #f))
(define (targ-emit-label-entry lbl nb-parms label-descr)
(targ-emit-label lbl 'proc (vector nb-parms 0)))
(define (targ-emit-label-subproc lbl nb-parms nb-closed label-descr)
(targ-emit-label lbl 'proc (vector nb-parms nb-closed)))
(define (targ-emit-label-return lbl fs link gc-map label-descr)
(targ-emit-label lbl 'return (vector 'normal fs link gc-map)))
(define (targ-emit-label-return-task lbl fs link gc-map label-descr)
(targ-emit-label lbl 'return (vector 'task fs link gc-map)))
(define (targ-emit-label-return-internal lbl fs link gc-map label-descr)
(targ-emit-label lbl 'return (vector 'internal fs link gc-map)))
;; Add a label to the code stream
(define (targ-emit-label lbl class info)
(let ((x (targ-get-lbl lbl)))
(targ-emit (cons 'label x))
(targ-add-label x class info)))
(define (targ-add-label lbl-struct class info)
(vector-set! lbl-struct 2 class)
(vector-set! lbl-struct 3 info)
(queue-put! targ-proc-lbl-tbl-ord lbl-struct))
;; Add label "n" to label table and return label object
(define (targ-get-lbl n)
(let ((x (assq n (queue->list targ-proc-lbl-tbl))))
(if x
(cdr x)
(let ((y (vector (targ-make-cell #f) ; eventual label number (set later)
#f ; used as a "goto" label?
#f ; class (not #f if "value" label)
#f))) ; extra info if "value" label
(queue-put! targ-proc-lbl-tbl (cons n y))
y))))
(define (targ-lbl-num lbl-struct)
(vector-ref lbl-struct 0))
;; Mark a label as referenced for "value" and return eventual label number
(define (targ-ref-lbl-val n)
(let ((x (targ-get-lbl n)))
(targ-lbl-num x)))
(define (targ-lbl-val? lbl-struct)
(vector-ref lbl-struct 2))
;; Mark a label as target for "goto" and return eventual label number
(define (targ-ref-lbl-goto n)
(let ((x (targ-get-lbl n)))
(vector-set! x 1 #t)
(targ-make-glbl (targ-lbl-num x) targ-proc-name)))
(define (targ-lbl-goto? lbl-struct)
(vector-ref lbl-struct 1))
(define (targ-make-glbl n name)
(list 'glbl n name))
;; To generate new, unique labels
(define (targ-new-lbl)
(targ-proc-lbl-counter))
(define (targ-heap-reserve space)
(set! targ-proc-hp (+ targ-proc-hp space)))
(define (targ-heap-reserve-and-check space sn)
(targ-heap-reserve space)
(if (> (+ targ-proc-hp
(* (targ-fp-cache-size) targ-flonum-space))
targ-msection-biggest)
(targ-update-fr-and-check-heap space sn)))
(define (targ-update-fr-and-check-heap space sn)
(targ-update-fr targ-proc-entry-frame)
(targ-check-heap space sn))
(define (targ-check-heap space sn)
(let ((lbl (targ-new-lbl)))
(targ-need-heap)
(targ-emit (targ-adjust-stack sn))
;; (targ-repr-exit-block! lbl)
(targ-emit
(list "CHECK_HEAP"
(targ-ref-lbl-val lbl)
(+ targ-msection-biggest space)))
;; (targ-repr-end-block!)
(targ-gen-label-return* lbl 'return-internal)
(set! targ-proc-hp 0)))
(define (targ-poll sn)
(let ((lbl (targ-new-lbl)))
(targ-rd-fp)
(targ-emit (targ-adjust-stack sn))
;; (targ-repr-exit-block! lbl)
(targ-emit
(list "POLL" (targ-ref-lbl-val lbl)))
;; (targ-repr-end-block!)
(targ-gen-label-return* lbl 'return-internal)))
(define (targ-start-bb fs)
(set! targ-proc-hp 0)
(set! targ-proc-fp fs))
(define (targ-begin-fr) ; start of a floating point region
(targ-fp-cache-init))
(define (targ-update-fr frame)
(let* ((live
(frame-live frame))
(any-closed-live?
(varset-intersects?
live
(list->varset (frame-closed frame)))))
(define (live? var)
(or (varset-member? var live)
(and (eq? var closure-env-var) any-closed-live?)))
(let loop1 ((i 1) (l (reverse (frame-slots frame))))
(if (pair? l)
(begin
(if (live? (car l))
(targ-fp-cache-write-if-dirty (make-stk i)))
(loop1 (+ i 1) (cdr l)))
(let loop2 ((i 0) (l (frame-regs frame)))
(if (pair? l)
(begin
(if (live? (car l))
(targ-fp-cache-write-if-dirty (make-reg i)))
(loop2 (+ i 1) (cdr l)))))))))
;; Management of resources
(define targ-nb-non-reg-res 2)
(define (targ-res-op i op)
(let ((x (if (< i targ-nb-non-reg-res)
(cons op (vector-ref '#("HEAP" "FP") i))
(let ((j (- i targ-nb-non-reg-res)))
(if (< j targ-nb-gvm-regs)
(cons op (string-append "R" (number->string j)))
(if (eq? op 'd-)
(let ((k (- j targ-nb-gvm-regs)))
(list "D_F64"
(targ-unboxed-index->code k)))
#f))))))
(and x (list 'append " " x))))
(define (targ-unboxed-loc->index loc)
(cond ((reg? loc)
(reg-num loc))
((stk? loc)
(+ (- (stk-num loc) 1) targ-nb-gvm-regs))
(else
(compiler-internal-error
"targ-unboxed-loc->index, invalid 'loc'" loc))))
(define targ-use-fresh-fp-vars? #f)
(set! targ-use-fresh-fp-vars? #t)
(define (targ-unboxed-index->code i)
(targ-need-unboxed i)
(cond (targ-use-fresh-fp-vars?
(list (string-append
"F64V"
(number->string i))))
((< i targ-nb-gvm-regs)
(list (string-append
"F64R"
(number->string i))))
(else
(list (string-append
"F64STK"
(number->string (+ (- i targ-nb-gvm-regs) 1)))))))
(define (targ-unboxed-loc->code loc stamp)
(targ-unboxed-index->code
(if targ-use-fresh-fp-vars?
stamp
(targ-unboxed-loc->index loc))))
(define (targ-rd-res i)
(stretchable-vector-set! targ-module-rd-res i #t)
(stretchable-vector-set! targ-proc-rd-res i #t))
(define (targ-wr-res i)
(targ-rd-res i)
(stretchable-vector-set! targ-module-wr-res i #t)
(stretchable-vector-set! targ-proc-wr-res i #t))
(define (targ-need-heap)
(targ-wr-res 0))
(define (targ-rd-fp)
(targ-rd-res 1))
(define (targ-wr-fp)
(targ-wr-res 1))
(define (targ-rd-reg n)
(targ-rd-res (+ n targ-nb-non-reg-res)))
(define (targ-wr-reg n)
(targ-wr-res (+ n targ-nb-non-reg-res)))
(define (targ-need-unboxed n)
(targ-wr-res
(+ n (+ targ-nb-non-reg-res targ-nb-gvm-regs))))
(define (targ-use-all-res)
(let loop ((i (- (+ targ-nb-non-reg-res targ-nb-gvm-regs) 1)))
(if (>= i 0)
(begin
(targ-wr-res i)
(loop (- i 1))))))
(define (targ-pop-pcontext pc)
(for-each
(lambda (x)
(let ((opnd (cdr x)))
(cond ((reg? opnd)
(let ((n (reg-num opnd)))
(targ-rd-reg n)))
((stk? opnd)
(targ-rd-fp)
(targ-wr-fp))
(else
(compiler-internal-error
"targ-pop-pcontext, unknown 'opnd'" opnd)))))
(pcontext-map pc)))
(define (targ-push-pcontext pc)
(for-each
(lambda (x)
(let ((opnd (cdr x)))
(cond ((reg? opnd)
(let ((n (reg-num opnd)))
(targ-wr-reg n)))
((stk? opnd)
(targ-rd-fp)
(targ-wr-fp))
(else
(compiler-internal-error
"targ-push-pcontext, unknown 'opnd'" opnd)))))
(pcontext-map pc)))
;;;----------------------------------------------------------------------------
(define (targ-add-var-descr! descr)
(define (index x l)
(let loop ((l l) (i 0))
(cond ((not (pair? l)) #f)
((equal? (car l) x) i)
(else (loop (cdr l) (+ i 1))))))
(let ((n (index descr (queue->list targ-var-descr-queue))))
(if n
n
(let ((m (length (queue->list targ-var-descr-queue))))
(queue-put! targ-var-descr-queue descr)
m))))
(define (targ-add-first-class-label! node slots frame)
(define (encode slot)
(let ((v (car slot))
(i (cdr slot)))
(+ (* i 32768)
(if (pair? v)
(* (targ-add-var-descr! (map encode v)) 2)
(+ (* (targ-add-var-descr! (var-name v)) 2)
(if (var-boxed? v) 1 0))))))
(define (closure-env-slot closure-vars stack-slots)
(let loop ((i 1) (lst1 closure-vars) (lst2 '()))
(if (null? lst1)
lst2
(let ((x (car lst1)))
(if (not (frame-live? x frame))
(loop (+ i 1)
(cdr lst1)
lst2)
(let ((y (assq (var-name x) stack-slots)))
(if (and y (not (eq? x (cadr y))))
(begin
(if (< (var-lexical-level (cadr y))
(var-lexical-level x))
(let ()
(##namespace ("" pp));****************
(pp (list
'closure-vars: (map var-name closure-vars)
'stack-slots: (map car stack-slots)
'source: (source->expression (node-source node))
))
(compiler-internal-error
"targ-add-first-class-label!, variable conflict")))
(loop (+ i 1)
(cdr lst1)
lst2))
(loop (+ i 1)
(cdr lst1)
(cons (cons x i) lst2)))))))))
(define (accessible-slots)
(let loop1 ((i 1)
(lst1 slots)
(lst2 '())
(closure-env #f)
(closure-env-index #f))
(if (pair? lst1)
(let* ((var (car lst1))
(x (frame-live? var frame)))
(cond ((pair? x) ; closure environment?
(if (or (not closure-env) (eq? var closure-env))
(loop1 (+ i 1)
(cdr lst1)
lst2
var
i)
(compiler-internal-error
"targ-add-first-class-label!, multiple closure environments")))
((or (not x) (temp-var? x)) ; not live or temporary var
(loop1 (+ i 1)
(cdr lst1)
lst2
closure-env
closure-env-index))
(else
(let* ((name (var-name x))
(y (assq name lst2)))
(if (and y (not (eq? x (cadr y))))
(let ((level-x (var-lexical-level x))
(level-y (var-lexical-level (cadr y))))
(cond ((< level-x level-y)
(loop1 (+ i 1)
(cdr lst1)
lst2
closure-env
closure-env-index))
((< level-y level-x)
(loop1 (+ i 1)
(cdr lst1)
(cons (cons name (cons x i)) (remq y lst2))
closure-env
closure-env-index))
(else
; Two different live variables have the same
; name and lexical level, both variables will
; be kept in the debugging information
; descriptor even though in the actual program
; only one of the two variables is in scope.
; "flatten" causes this condition to happen.
; TODO: take variable scopes into account.
(loop1 (+ i 1)
(cdr lst1)
(cons (cons name (cons x i)) lst2)
closure-env
closure-env-index))))
(loop1 (+ i 1)
(cdr lst1)
(cons (cons name (cons x i)) lst2)
closure-env
closure-env-index))))))
(let* ((x
(if closure-env
(closure-env-slot (frame-live? closure-env frame) lst2)
'()))
(accessible-stack-slots
(map cdr lst2)))
(if (null? x)
accessible-stack-slots
(cons (cons x closure-env-index)
accessible-stack-slots))))))
(let* ((env
(and node (node-env node)))
(label-descr
(cons (if (and env
(debug? env)
(or (debug-location? env)
(debug-source? env)))
(let ((src (node-source node)))
(set! targ-debug-info? #t)
(if (debug-location? env)
(if (debug-source? env)
src
(source-locat src))
(source->expression src)))
#f)
(if (and env
(or (and (debug? env)
(debug-environments? env))
(environment-map? env)))
(begin
(set! targ-debug-info? #t)
(map encode (accessible-slots)))
'()))))
(queue-put! targ-first-class-label-queue label-descr)
label-descr))
;;;----------------------------------------------------------------------------
(define (targ-gen-gvm-instr prev-gvm-instr gvm-instr next-gvm-instr sn)
(set! targ-proc-instr-node
(comment-get (gvm-instr-comment gvm-instr) 'node))
(set! targ-proc-exit-frame
(gvm-instr-frame gvm-instr))
(set! targ-proc-entry-frame
(and prev-gvm-instr (gvm-instr-frame prev-gvm-instr)))
;; (write-gvm-instr gvm-instr ##stdout)(newline);*************
(if targ-track-scheme-option?
(let* ((src (node-source targ-proc-instr-node))
(x (locat-filename-and-line (and src (source-locat src))))
(filename (car x))
(line (cdr x)))
(if (< 0 (string-length filename))
(targ-emit
(list 'line line filename)))))
(case (gvm-instr-type gvm-instr)
((label)
(set! targ-proc-entry-frame targ-proc-exit-frame)
(targ-start-bb (frame-size targ-proc-exit-frame))
(case (label-type gvm-instr)
((simple)
(targ-gen-label-simple (label-lbl-num gvm-instr)
sn))
((entry)
(targ-gen-label-entry (label-lbl-num gvm-instr)
(label-entry-nb-parms gvm-instr)
(label-entry-opts gvm-instr)
(label-entry-keys gvm-instr)
(label-entry-rest? gvm-instr)
(label-entry-closed? gvm-instr)
sn))
((return)
(targ-gen-label-return (label-lbl-num gvm-instr)
sn))
((task-entry)
(targ-gen-label-task-entry (label-lbl-num gvm-instr)
sn))
((task-return)
(targ-gen-label-task-return (label-lbl-num gvm-instr)
sn))
(else
(compiler-internal-error
"targ-gen-gvm-instr, unknown label type"))))
((apply)
(targ-gen-apply (apply-prim gvm-instr)
(apply-opnds gvm-instr)
(apply-loc gvm-instr)
sn))
((copy)
(targ-gen-copy (copy-opnd gvm-instr)
(copy-loc gvm-instr)
sn))
((close)
(targ-gen-close (close-parms gvm-instr)
sn))
((ifjump)
(targ-gen-ifjump (ifjump-test gvm-instr)
(ifjump-opnds gvm-instr)
(ifjump-true gvm-instr)
(ifjump-false gvm-instr)
(ifjump-poll? gvm-instr)
(if (and next-gvm-instr
(memq (label-type next-gvm-instr)
'(simple task-entry)))
(label-lbl-num next-gvm-instr)
#f)))
((switch)
(targ-gen-switch (switch-opnd gvm-instr)
(switch-cases gvm-instr)
(switch-default gvm-instr)
(switch-poll? gvm-instr)
(if (and next-gvm-instr
(memq (label-type next-gvm-instr)
'(simple task-entry)))
(label-lbl-num next-gvm-instr)
#f)))
((jump)
(targ-gen-jump (jump-opnd gvm-instr)
(jump-nb-args gvm-instr)
(jump-poll? gvm-instr)
(jump-safe? gvm-instr)
(if (and next-gvm-instr
(memq (label-type next-gvm-instr)
'(simple task-entry)))
(label-lbl-num next-gvm-instr)
#f)))
(else
(compiler-internal-error
"targ-gen-gvm-instr, unknown 'gvm-instr'" gvm-instr))))
;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
(define (targ-gen-label-simple lbl sn)
(targ-emit-label-simp lbl)
(targ-begin-fr)
;; (targ-repr-begin-block! 'simple lbl)
)
;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
(define (targ-gen-label-entry lbl nb-parms opts keys rest? closed? sn)
(let ((label-descr (targ-add-first-class-label!
targ-proc-instr-node
'()
targ-proc-exit-frame)))
(if (= lbl targ-proc-entry-lbl)
(begin
(targ-emit-label-entry lbl nb-parms label-descr)
(targ-ref-lbl-val lbl)
(targ-ref-lbl-goto lbl))
(let ((nb-closed (length (frame-closed targ-proc-exit-frame))));******
(targ-emit-label-subproc lbl nb-parms nb-closed label-descr))))
(let* ((nb-parms-except-rest
(- nb-parms (if rest? 1 0)))
(nb-keys
(if keys (length keys) 0))
(nb-req-and-opt
(- nb-parms-except-rest nb-keys))
(nb-opts
(length opts))
(nb-req
(- nb-req-and-opt nb-opts))
(lbl*
(targ-ref-lbl-val lbl))
(defaults
(append opts (map cdr (or keys '())))))
(define (make-key-descriptor)
(let loop ((lst1 keys) (lst2 '()))
(if (null? lst1)
(list->vect (reverse lst2))
(let ((key (car lst1)))
(loop (cdr lst1)
(cons (obj-val (cdr key)) (cons (car key) lst2)))))))
(define (dispatch-on-nb-args nb-args)
(if (> nb-args nb-req-and-opt)
(targ-emit
(if keys
(list (if rest?
(if (eq? rest? 'dsssl)
"GET_REST_KEY"
"GET_KEY_REST")
"GET_KEY")
lbl* nb-req nb-opts nb-keys
(targ-use-obj (make-key-descriptor)))
(list (if rest? "GET_REST" "WRONG_NARGS")
lbl* nb-req nb-opts nb-keys)))
(let ((nb-stacked (max 0 (- nb-args targ-nb-arg-regs)))
(nb-stacked* (max 0 (- nb-parms targ-nb-arg-regs))))
(define (setup-parameter i)
(if (<= i nb-parms)
(let* ((rest (setup-parameter (+ i 1)))
(src-reg (- i nb-stacked))
(src (cond ((<= i nb-args)
(cons 'r src-reg))
((and rest? (= i nb-parms))
'("NUL"))
(else
(targ-use-obj
(obj-val
(list-ref defaults (- i nb-req 1))))))))
(if (<= i nb-stacked*)
(begin
(if (<= i nb-args) (targ-rd-reg src-reg))
(targ-rd-fp)
(targ-wr-fp)
(cons (list "PUSH" src) rest))
(if (and (<= i nb-args) (= nb-stacked nb-stacked*))
rest
(let ((dst-reg (- i nb-stacked*)))
(if (<= i nb-args) (targ-rd-reg src-reg))
(targ-wr-reg dst-reg)
(cons (list 'set-r dst-reg src) rest)))))
'()))
(let ((x (setup-parameter (+ nb-stacked 1))))
(targ-emit (list "IF_NARGS_EQ"
nb-args
(if (null? x) '("NOTHING") (cons 'seq x)))))
(dispatch-on-nb-args (+ nb-args 1)))))
(dispatch-on-nb-args nb-req)
(if (= lbl targ-proc-entry-lbl)
(targ-emit (list 'append
(list "DEF_GLBL" (targ-make-glbl "" targ-proc-name))
#\newline)))
(targ-begin-fr)
;; (targ-repr-begin-block! 'entry lbl)
))
;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
(define (targ-gen-label-return lbl sn)
(targ-gen-label-return* lbl 'return))
(define (targ-gen-label-return* lbl kind)
(let ((frame targ-proc-entry-frame))
(define (extend-vars l n)
(cond ((= n 0) l)
((< n 0) (extend-vars (cdr l) (+ n 1)))
(else (extend-vars (cons empty-var l) (- n 1)))))
(define (generate fs vars gc-map)
(let ((label-descr
(targ-add-first-class-label!
targ-proc-instr-node
vars
frame))
(link
(pos-in-list ret-var vars)))
(if link
(begin
(case kind
((return)
(targ-emit-label-return lbl fs link gc-map label-descr)
;; (targ-repr-begin-block! 'return lbl)
)
((return-task)
(targ-emit-label-return-task lbl fs link gc-map label-descr)
;; (targ-repr-begin-block! 'task-return lbl)
)
((return-internal)
(targ-emit-label-return-internal lbl fs link gc-map label-descr)
;; (targ-repr-begin-block! 'return-internal lbl)
)
(else
(compiler-internal-error
"targ-gen-label-return*, unknown label kind")))
(targ-begin-fr))
(compiler-internal-error
"targ-gen-label-return*, no return address in frame"))))
(if (eq? kind 'return-internal)
(let* ((cfs
targ-proc-fp)
(cfs-after-alignment
(targ-align-frame cfs))
(regs
(frame-regs frame))
(return-var
(make-temp-var 'return))
(vars
(append (reverse (extend-vars (frame-slots frame)
(- cfs-after-alignment
(frame-size frame))))
(reverse (extend-vars (reverse regs)
(- targ-nb-gvm-regs
(length regs))))
(list return-var)
(extend-vars '()
(let ((n (+ targ-nb-gvm-regs 1)))
(- (targ-align-frame-without-reserve n)
n)))))
(gc-map
(targ-build-gc-map
vars
(lambda (i var)
(or (frame-live? var frame)
(let ((j (- i cfs-after-alignment)))
(and (>= j 0) ; all saved GVM regs are live
(<= j targ-nb-gvm-regs))))))))
(generate cfs vars gc-map))
(let* ((fs ; remove frame reserve from actual frame size
(- targ-proc-fp targ-frame-reserve))
(vars
(reverse (extend-vars (frame-slots frame)
(- fs (frame-size frame)))))
(gc-map
(targ-build-gc-map
vars
(lambda (i var)
(frame-live? var frame)))))
(generate fs vars gc-map)))))
;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
(define (targ-gen-label-task-entry lbl sn)
(targ-emit-label-simp lbl)
(targ-emit (list "TASK_PUSH" 0))
(targ-begin-fr)
;; (targ-repr-begin-block! 'task-entry lbl)
)
;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
(define (targ-gen-label-task-return lbl sn)
(let ((lbl2 (targ-new-lbl))
(fs (frame-size targ-proc-exit-frame)))
(targ-start-bb fs)
(targ-gen-label-return* lbl 'return-task)
(targ-emit (list "TASK_POP" (targ-ref-lbl-val lbl2)))
;; (targ-repr-exit-block! lbl2)
;; (targ-repr-end-block!)
(targ-gen-label-return* lbl2 'return)))
;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
(define (targ-gen-apply prim opnds loc sn)
(let ((proc (proc-obj-inline prim)))
(if proc
(begin
(proc opnds loc sn)
(targ-heap-reserve-and-check 0 sn))
(compiler-internal-error
"targ-gen-apply, unknown 'prim'" prim))))
;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
(define (targ-gen-copy opnd loc sn)
(if opnd
(targ-emit
(targ-loc loc (targ-opnd opnd)))
;; (targ-emit (targ-loc loc (targ-opnd (make-obj 1234567))));***********************
)
(targ-heap-reserve-and-check 0 sn))
'(;;
(if targ-repr-enabled?
(if (and (or (reg? opnd) (stk? opnd))
(or (reg? loc) (stk? loc)))
(let* ((loc-descrs
(targ-block-loc-descrs targ-repr-current-block))
(i
(targ-repr-loc->index opnd))
(descr
(stretchable-vector-ref loc-descrs i))
(have
(targ-repr-have-reprs descr)))
(if (targ-repr-empty? have)
(targ-emit
(targ-loc loc (targ-opnd opnd)))
(let ((j (targ-repr-loc->index loc)))
(let loop1 ((repr targ-repr-boxed))
(if (< repr targ-repr-nb-reprs)
(begin
(if (targ-repr-member? repr have)
(targ-emit
(if (= repr targ-repr-boxed)
(targ-repr-loc-boxed loc (targ-repr-opnd-boxed opnd))
(let ((type (vector-ref targ-repr-types (- repr 1))))
(list (string-append "SET_" type)
(targ-repr-unboxed-loc->code loc repr)
(targ-repr-unboxed-loc->code opnd repr))))))
(loop1 (+ repr 1)))))
(stretchable-vector-set! loc-descrs j
(targ-repr-have-reprs-set
(stretchable-vector-ref loc-descrs j)
have)))))
(targ-emit
(targ-loc loc (targ-opnd opnd))))
(targ-emit
(targ-loc loc (targ-opnd opnd)))))
;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
(define (targ-gen-close parms sn)
(define (close parms* sn*)
(if (pair? parms*)
(let* ((parm (car parms*))
(lbl (closure-parms-lbl parm))
(loc (closure-parms-loc parm))
(opnds (closure-parms-opnds parm))
(sn** (targ-sn-opnds opnds sn*)))
(close (cdr parms*) (targ-sn-loc loc sn**))
(let* ((x (targ-opnd loc))
(elements (map targ-opnd opnds))
(n (length elements)))
(targ-emit
(list "BEGIN_SETUP_CLO" n x (targ-ref-lbl-val lbl)))
(for-each-index (lambda (elem i)
(targ-emit
(list "ADD_CLO_ELEM" i elem)))
elements)
(targ-emit
(list "END_SETUP_CLO" n))))
(begin
(targ-heap-reserve-and-check
(apply +
(map (lambda (parm)
(targ-closure-space
(length (closure-parms-opnds parm))))
parms))
sn*)
(for-each (lambda (parm)
(let ((loc (closure-parms-loc parm))
(opnds (closure-parms-opnds parm)))
(targ-emit
(targ-loc loc (list "ALLOC_CLO" (length opnds))))))
parms))))
(close (reverse parms) sn)
(targ-heap-reserve-and-check 0 sn))
;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
(define (targ-gen-ifjump test opnds true-lbl false-lbl poll? next-lbl)
(let ((x (proc-obj-test test)))
(if x
(let ((args-flo? (vector-ref x 0))
(proc (vector-ref x 1)))
(define (gen-if not? branch-lbl fall-lbl)
(let ((fs (frame-size targ-proc-exit-frame)))
(if (or (not args-flo?)
(begin
(targ-update-fr targ-proc-exit-frame)
(targ-end-of-block-checks-needed? poll?)))
(let ((sn (targ-sn-opnds opnds fs)))
(targ-update-fr targ-proc-entry-frame)
(targ-end-of-block-checks poll? sn)))
(targ-emit
(targ-adjust-stack fs))
(targ-emit
(list "IF" (proc not? opnds fs)))
;; (targ-repr-exit-block! branch-lbl)
(targ-emit
(list "GOTO" (targ-ref-lbl-goto branch-lbl)))
(targ-emit
'("END_IF"))
;; (targ-repr-exit-block! fall-lbl)
(if (not (eqv? fall-lbl next-lbl))
(targ-emit
(list "GOTO" (targ-ref-lbl-goto fall-lbl))))
;; (targ-repr-end-block!)
))
(if (eqv? true-lbl next-lbl)
(gen-if #t false-lbl true-lbl)
(gen-if #f true-lbl false-lbl)))
(compiler-internal-error
"targ-gen-ifjump, unknown 'test'" test))))
(define (targ-end-of-block-checks-needed? poll?)
(or poll?
(> targ-proc-hp 0)))
(define (targ-end-of-block-checks poll? sn)
(if (> targ-proc-hp 0)
(targ-check-heap 0 sn))
(if poll?
(targ-poll sn)))
;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
(define (targ-gen-switch opnd cases default poll? next-lbl)
(targ-update-fr targ-proc-entry-frame)
(let* ((fs (frame-size targ-proc-exit-frame))
(sn (targ-sn-opnd opnd fs)))
(targ-end-of-block-checks poll? sn)
(targ-emit
(targ-adjust-stack fs))
(let loop ((lst cases)
(rev-cases-fixnum '())
(rev-cases-char '())
(rev-cases-symbol '())
(rev-cases-keyword '())
(rev-cases-other '()))
(if (pair? lst)
(let* ((c (car lst))
(obj (switch-case-obj c)))
(cond ((targ-fixnum32? obj)
(loop (cdr lst)
(cons c rev-cases-fixnum)
rev-cases-char
rev-cases-symbol
rev-cases-keyword
rev-cases-other))
((char? obj)
(loop (cdr lst)
rev-cases-fixnum
(cons c rev-cases-char)
rev-cases-symbol
rev-cases-keyword
rev-cases-other))
((symbol-object? obj)
(loop (cdr lst)
rev-cases-fixnum
rev-cases-char
(cons c rev-cases-symbol)
rev-cases-keyword
rev-cases-other))
((keyword-object? obj)
(loop (cdr lst)
rev-cases-fixnum
rev-cases-char
rev-cases-symbol
(cons c rev-cases-keyword)
rev-cases-other))
(else
(loop (cdr lst)
rev-cases-fixnum
rev-cases-char
rev-cases-symbol
rev-cases-keyword
(cons c rev-cases-other)))))
(let* ((cases-fixnum (reverse rev-cases-fixnum))
(cases-char (reverse rev-cases-char))
(cases-symbol (reverse rev-cases-symbol))
(cases-keyword (reverse rev-cases-keyword))
(cases-other (reverse rev-cases-other))
(cases-symkey (append cases-symbol cases-keyword)))
(define (gen cases begin-macro case-macro end-macro)
(if (not (null? cases))
(begin
(targ-emit (list begin-macro (targ-opnd opnd)))
(for-each
(lambda (c)
(targ-emit
(list case-macro
(targ-use-obj (switch-case-obj c))
(targ-ref-lbl-goto (switch-case-lbl c)))))
cases)
(targ-emit (list end-macro)))))
(if (<= (length cases-fixnum) 2)
(begin
(set! cases-other (append cases-fixnum cases-other))
(set! cases-fixnum '())))
(if (<= (length cases-char) 2)
(begin
(set! cases-other (append cases-char cases-other))
(set! cases-char '())))
(gen cases-other
"BEGIN_SWITCH"
"SWITCH_CASE_GOTO"
"END_SWITCH")
(gen cases-fixnum
"BEGIN_SWITCH_FIXNUM"
"SWITCH_FIXNUM_CASE_GOTO"
"END_SWITCH_FIXNUM")
(gen cases-char
"BEGIN_SWITCH_CHAR"
"SWITCH_CHAR_CASE_GOTO"
"END_SWITCH_CHAR")
(let ((n (length cases-symkey)))
(cond ((= n 0))
((<= n symkey-switch-as-if-cascade-limit)
(let loop ((cases cases-symkey))
(if (pair? cases)
(let ((c (car cases)))
(targ-emit
(list "IF_GOTO"
(list "EQP"
(targ-opnd opnd)
(targ-use-obj (switch-case-obj c)))
(targ-ref-lbl-goto (switch-case-lbl c))))
(loop (cdr cases))))))
(else
(let* ((mod (let loop ((i 1))
(if (> i n)
i
(loop (* i 2)))))
(buckets (make-vector mod '())))
(for-each
(lambda (c)
(let* ((obj (switch-case-obj c))
(hash (targ-hash
(if (symbol-object? obj)
(symbol->string obj)
(keyword-object->string obj))))
(i (modulo hash mod)))
(vector-set! buckets
i
(cons c (vector-ref buckets i)))))
cases-symkey)
(targ-emit
(list "BEGIN_SWITCH_SYMKEY"
(targ-opnd opnd)
mod
(list
(cond ((null? cases-keyword)
"SYMBOLP")
((null? cases-symbol)
"KEYWORDP")
(else
"SYMKEYP")))))
(let loop ((i 0))
(if (< i mod)
(begin
(targ-emit (list "SWITCH_SYMKEY_CASE" i))
(for-each
(lambda (c)
(targ-emit
(list "SWITCH_SYMKEY_CASE_GOTO"
(targ-use-obj (switch-case-obj c))
(targ-ref-lbl-goto (switch-case-lbl c)))))
(reverse (vector-ref buckets i)))
(targ-emit (list "GOTO" (targ-ref-lbl-goto default)))
(loop (+ i 1)))))
(targ-emit (list "END_SWITCH_SYMKEY")))))))))
(if (not (eqv? default next-lbl))
(targ-emit
(list "GOTO" (targ-ref-lbl-goto default))))))
(define symkey-switch-as-if-cascade-limit #f)
(set! symkey-switch-as-if-cascade-limit 20)
;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
(define (targ-gen-jump opnd nb-args poll? safe? next-lbl)
(targ-update-fr targ-proc-entry-frame)
(let ((inlined
(and (obj? opnd)
(proc-obj? (obj-val opnd))
nb-args
(let* ((proc (obj-val opnd))
(jump-inliner (proc-obj-jump-inline proc)))
(and jump-inliner
(jump-inliner nb-args poll? safe?))))))
(if (not inlined)
(let* ((fs (frame-size targ-proc-exit-frame))
(sn (targ-sn-opnd opnd fs))
(set-nargs (if nb-args (list "SET_NARGS" nb-args) #f)))
(targ-end-of-block-checks poll? sn)
(targ-emit
(targ-adjust-stack fs))
(cond ((lbl? opnd)
(let ((n (lbl-num opnd)))
;; (targ-repr-exit-block! (if nb-args #f n))
(if (and next-lbl (= next-lbl n)) ; fall through?
(targ-emit set-nargs)
(targ-emit
(list 'seq
set-nargs
(list "GOTO" (targ-ref-lbl-goto n)))))))
((and (obj? opnd)
(proc-obj? (obj-val opnd))
nb-args)
(let* ((proc (obj-val opnd))
(x (targ-use-prc proc #f)))
;; (targ-repr-exit-block! #f)
(if (eq? (car x) 'prm)
(targ-emit
(list "JUMPPRM"
set-nargs
x))
(let ((name (proc-obj-name proc)))
(if (targ-arg-check-avoidable? proc nb-args)
(targ-emit
(list "JUMPINT"
set-nargs
x
(targ-make-glbl "" name)))
(targ-emit
(list 'seq
set-nargs
(list "JUMPINT"
'("NOTHING")
x
(targ-make-glbl 0 name)))))))))
((glo? opnd)
;; (targ-repr-exit-block! #f)
(targ-emit
(cons (begin
(targ-wr-reg (+ targ-nb-arg-regs 1))
(if safe? "JUMPGLOSAFE" "JUMPGLONOTSAFE"))
(cons (if nb-args set-nargs '("NOTHING"))
(cdr (targ-opnd opnd))))))
(else
;; (targ-repr-exit-block! #f)
(targ-emit
(list (if nb-args
(begin
(targ-wr-reg (+ targ-nb-arg-regs 1))
(if safe? "JUMPGENSAFE" "JUMPGENNOTSAFE"))
"JUMPPRM")
(if nb-args set-nargs '("NOTHING"))
(targ-opnd opnd)))))
;; (targ-repr-end-block!)
))))
(define (targ-arg-check-avoidable? proc nb-args)
(let ((x (proc-obj-call-pat proc)))
(if (and (pair? x) (null? (cdr x))) ; proc accepts a fixed nb of args?
(let ((arg-count (car x)))
(= arg-count nb-args)) ; nb of arguments = nb of parameters?
#f)))
;;;----------------------------------------------------------------------------
'(;;
(define targ-repr-enabled? #f)
(set! targ-repr-enabled? #t)
(define targ-repr-graph #f)
(define targ-repr-current-block #f)
;; Location representation descriptors.
(define targ-repr-boxed 0) ; must be 0
(define targ-repr-f64 1)
(define targ-repr-nb-reprs 2) ; # of possible representations (including boxed)
(define targ-repr-universal 3) ; (- (expt 2 targ-repr-nb-repr) 1)
(define targ-repr-types ; type name of each unboxed representation
'#("F64"))
(define targ-repr-have-pos 0) ; bit position of "have" field (must be 0)
(define targ-repr-need-pos 2) ; bit position of "need" field
(define targ-repr-entry-pos 4) ; bit position of "entry" field
(define targ-repr-live1-mask 64) ; live at entry of block
(define targ-repr-live2-mask 128) ; live at exit of block
(define targ-repr-all-mask 255) ; (- (* 2 targ-repr-live2-mask) 1)
(define targ-repr-have-mask 252) ; (- targ-repr-all-mask targ-repr-universal)
(define targ-repr-entry-mask 207) ; (- targ-repr-all-mask
; (* (expt 2 targ-repr-entry-pos)
; targ-repr-universal))
(define (targ-repr-have-reprs descr)
(bits-and descr targ-repr-universal))
(define (targ-repr-have-reprs-union descr reprs)
(bits-or descr reprs))
(define (targ-repr-have-reprs-set descr reprs)
(bits-or (bits-and descr targ-repr-have-mask) reprs))
(define (targ-repr-need-reprs descr)
(bits-and (bits-shr descr targ-repr-need-pos) targ-repr-universal))
(define (targ-repr-need-reprs-union descr reprs)
(bits-or descr (bits-shl reprs targ-repr-need-pos)))
(define (targ-repr-entry-reprs descr)
(bits-and (bits-shr descr targ-repr-entry-pos) targ-repr-universal))
(define (targ-repr-entry-reprs-set descr reprs)
(bits-or (bits-and descr targ-repr-entry-mask)
(bits-shl reprs targ-repr-entry-pos)))
(define (targ-repr-live1-add descr)
(bits-or descr targ-repr-live1-mask))
(define (targ-repr-live1? descr)
(not (= (bits-and descr targ-repr-live1-mask) 0)))
(define (targ-repr-live2-add descr)
(bits-or descr targ-repr-live2-mask))
(define (targ-repr-live2? descr)
(not (= (bits-and descr targ-repr-live2-mask) 0)))
(define (targ-repr-equal-descr? descr1 descr2)
(= descr1 descr2))
(define (targ-repr-included-reprs? reprs1 reprs2)
(= (bits-and reprs1 reprs2) reprs1))
(define (targ-repr-empty)
0)
(define (targ-repr-empty? reprs)
(= reprs (targ-repr-empty)))
(define (targ-repr-member? repr reprs)
(not (= (bits-and reprs (bits-shl 1 repr)) 0)))
(define (targ-repr-singleton repr)
(bits-shl 1 repr))
(define (targ-repr-intersection reprs1 reprs2)
(bits-and reprs1 reprs2))
(define (targ-make-block kind lbl entry-cell)
(vector kind
lbl
entry-cell
'()
#f
#f
(make-stretchable-vector (targ-repr-empty))))
(define (targ-block-kind block) (vector-ref block 0))
(define (targ-block-lbl block) (vector-ref block 1))
(define (targ-block-entry-cell block) (vector-ref block 2))
(define (targ-block-exits block) (vector-ref block 3))
(define (targ-block-entry-fs block) (vector-ref block 4))
(define (targ-block-exit-fs block) (vector-ref block 5))
(define (targ-block-loc-descrs block) (vector-ref block 6))
(define (targ-block-add-exit! block lbl cell)
(vector-set! block 3
(cons (cons lbl cell) (vector-ref block 3))))
(define (targ-block-entry-fs-set! block fs)
(vector-set! block 4 fs))
(define (targ-block-exit-fs-set! block fs)
(vector-set! block 5 fs))
(define (targ-repr-begin-proc!)
(if targ-repr-enabled?
(set! targ-repr-graph (make-stretchable-vector #f))))
(define (targ-repr-end-proc!)
(define (compute-reprs-function src)
(let ((exits (targ-block-exits src)))
(if (not (null? (cdr exits)))
(compute-reprs-function-2-known-exits src (caar exits) (caadr exits))
(if (caar exits)
(compute-reprs-function-1-known-exit src (caar exits))
(compute-reprs-function-1-unknown-exit src)))))
(define (compute-reprs-function-1-unknown-exit src)
(lambda (src-descr i)
(targ-repr-singleton targ-repr-boxed)))
(define (compute-reprs-function-1-known-exit src dst)
(let* ((dst-loc-descrs (targ-block-loc-descrs dst))
(src-fs (targ-block-exit-fs src))
(dst-fs (targ-block-entry-fs dst))
(offs (- src-fs dst-fs)))
(lambda (src-descr i)
(let* ((src-have
(targ-repr-have-reprs src-descr))
(src-reprs
(if (targ-repr-empty? src-have)
(targ-repr-need-reprs src-descr)
src-have)))
(if (< i targ-nb-gvm-regs)
(let ((dst-descr
(stretchable-vector-ref dst-loc-descrs i)))
(stretchable-vector-set!
dst-loc-descrs
i
(targ-repr-entry-reprs-set
dst-descr
(targ-repr-intersection
(targ-repr-entry-reprs dst-descr)
src-reprs)))
(targ-repr-need-reprs dst-descr))
(let* ((j
(- i offs))
(dst-descr
(if (>= j targ-nb-gvm-regs)
(stretchable-vector-ref dst-loc-descrs j)
0)))
(if (>= j targ-nb-gvm-regs)
(stretchable-vector-set!
dst-loc-descrs
j
(targ-repr-entry-reprs-set
dst-descr
(targ-repr-intersection
(targ-repr-entry-reprs dst-descr)
src-reprs))))
(targ-repr-need-reprs dst-descr)))))))
(define (compute-reprs-function-2-known-exits src dst1 dst2)
(let* ((dst1-loc-descrs (targ-block-loc-descrs dst1))
(dst2-loc-descrs (targ-block-loc-descrs dst2))
(src-fs (targ-block-exit-fs src))
(dst1-fs (targ-block-entry-fs dst1))
(dst2-fs (targ-block-entry-fs dst2))
(offs1 (- src-fs dst1-fs))
(offs2 (- src-fs dst2-fs)))
(lambda (src-descr i)
(let* ((src-have
(targ-repr-have-reprs src-descr))
(src-reprs
(if (targ-repr-empty? src-have)
(targ-repr-need-reprs src-descr)
src-have)))
(if (< i targ-nb-gvm-regs)
(let ((dst1-descr
(stretchable-vector-ref dst1-loc-descrs i))
(dst2-descr
(stretchable-vector-ref dst2-loc-descrs i)))
(stretchable-vector-set!
dst1-loc-descrs
i
(targ-repr-entry-reprs-set
dst1-descr
(targ-repr-intersection
(targ-repr-entry-reprs dst1-descr)
src-reprs)))
(stretchable-vector-set!
dst2-loc-descrs
i
(targ-repr-entry-reprs-set
dst2-descr
(targ-repr-intersection
(targ-repr-entry-reprs dst2-descr)
src-reprs)))
(targ-repr-intersection
(targ-repr-need-reprs dst1-descr)
(targ-repr-need-reprs dst2-descr)))
(let* ((j1
(- i offs1))
(j2
(- i offs2))
(dst1-descr
(if (>= j1 targ-nb-gvm-regs)
(stretchable-vector-ref dst1-loc-descrs j1)
0))
(dst2-descr
(if (>= j2 targ-nb-gvm-regs)
(stretchable-vector-ref dst2-loc-descrs j2)
0)))
(if (>= j1 targ-nb-gvm-regs)
(stretchable-vector-set!
dst1-loc-descrs
j1
(targ-repr-entry-reprs-set
dst1-descr
(targ-repr-intersection
(targ-repr-entry-reprs dst1-descr)
src-reprs))))
(if (>= j2 targ-nb-gvm-regs)
(stretchable-vector-set!
dst2-loc-descrs
j2
(targ-repr-entry-reprs-set
dst2-descr
(targ-repr-intersection
(targ-repr-entry-reprs dst2-descr)
src-reprs))))
(targ-repr-intersection
(targ-repr-need-reprs dst1-descr)
(targ-repr-need-reprs dst2-descr))))))))
(define (insert-exit-conversions src dst cell)
(if dst
(insert-known-exit-conversions src dst cell)
(insert-unknown-exit-conversions src cell)))
(define (insert-unknown-exit-conversions src cell)
(let ((lst '())
(src-loc-descrs (targ-block-loc-descrs src))
(src-fs (targ-block-exit-fs src)))
(define (conversion i j need-j)
(let* ((descr-i
(stretchable-vector-ref src-loc-descrs i))
(have-i
(targ-repr-have-reprs descr-i))
(need-i
(targ-repr-need-reprs descr-i))
(reprs-i
(if (targ-repr-empty? have-i)
(if (targ-repr-empty? need-i)
(targ-repr-singleton targ-repr-boxed)
need-i)
have-i))
(reprs-j
(if (targ-repr-empty? need-j)
(targ-repr-singleton targ-repr-boxed)
need-j)))
(set! targ-proc-fp src-fs)
(let loop1 ((r (+ targ-repr-boxed 1)))
(if (< r targ-repr-nb-reprs)
(begin
(if (targ-repr-member? r reprs-j) ; needed in this repr?
(if (targ-repr-member? r reprs-i) ; already in this repr?
(if (not (= i j)) ; copying necessary?
(set! lst
(cons (targ-repr-unboxed-index-copy i j r)
lst)))
(set! lst
(cons (targ-repr-unboxed-copy
(targ-repr-from-boxed
(targ-repr-opnd-boxed (targ-repr-index->loc i))
r)
(targ-repr-unboxed-index->code j r)
r)
lst))))
(loop1 (+ r 1)))))
(if (not (or (targ-repr-included-reprs? reprs-j reprs-i)
(targ-repr-member? targ-repr-boxed reprs-i)))
(let loop2 ((r (+ targ-repr-boxed 1)))
(if (not (targ-repr-member? r reprs-i))
(loop2 (+ r 1))
(set! lst
(cons (targ-repr-to-boxed! (targ-repr-index->loc i) r)
lst)))))))
(let loop ((i (- (+ targ-nb-gvm-regs src-fs) 1)))
(if (>= i 0)
(let ((descr-i (stretchable-vector-ref src-loc-descrs i)))
(if (targ-repr-live2? descr-i)
(conversion i i (targ-repr-empty)))
(loop (- i 1)))))
(targ-cell-set!
cell
(list 'append
"/* exit representation: "
(targ-repr-to-string
src-loc-descrs
targ-repr-have-reprs
targ-repr-live2?)
" */"
#\newline
(cons 'seq lst)
#\newline))))
(define (insert-known-exit-conversions src dst cell)
(let* ((lst '())
(src-loc-descrs (targ-block-loc-descrs src))
(dst-loc-descrs (targ-block-loc-descrs dst))
(src-fs (targ-block-exit-fs src))
(dst-fs (targ-block-entry-fs dst))
(offs (- src-fs dst-fs)))
(define (conversion i j need-j)
(let* ((descr-i
(stretchable-vector-ref src-loc-descrs i))
(have-i
(targ-repr-have-reprs descr-i))
(need-i
(targ-repr-need-reprs descr-i))
(reprs-i
(if (targ-repr-empty? have-i)
(if (targ-repr-empty? need-i)
(targ-repr-singleton targ-repr-boxed)
need-i)
have-i))
(reprs-j
(if (targ-repr-empty? need-j)
(targ-repr-singleton targ-repr-boxed)
need-j)))
(set! targ-proc-fp src-fs)
(let loop1 ((r (+ targ-repr-boxed 1)))
(if (< r targ-repr-nb-reprs)
(begin
(if (targ-repr-member? r reprs-j) ; needed in this repr?
(if (targ-repr-member? r reprs-i) ; already in this repr?
(if (not (= i j)) ; copying necessary?
(set! lst
(cons (targ-repr-unboxed-index-copy i j r)
lst)))
(set! lst
(cons (targ-repr-unboxed-copy
(targ-repr-from-boxed
(targ-repr-opnd-boxed (targ-repr-index->loc i))
r)
(targ-repr-unboxed-index->code j r)
r)
lst))))
(loop1 (+ r 1)))))
(if (not (or (targ-repr-included-reprs? reprs-j reprs-i)
(targ-repr-member? targ-repr-boxed reprs-i)))
(let loop2 ((r (+ targ-repr-boxed 1)))
(if (not (targ-repr-member? r reprs-i))
(loop2 (+ r 1))
(set! lst
(cons (targ-repr-to-boxed! (targ-repr-index->loc i) r)
lst)))))))
(let loop ((i (- (+ targ-nb-gvm-regs src-fs) 1)))
(if (>= i 0)
(let ((j (if (< i targ-nb-gvm-regs) i (- i offs))))
(if (and (>= i targ-nb-gvm-regs)
(< j targ-nb-gvm-regs))
(conversion i i (targ-repr-empty))
(let ((descr-j (stretchable-vector-ref dst-loc-descrs j)))
(if (targ-repr-live1? descr-j)
(conversion i j (targ-repr-need-reprs descr-j)))))
(loop (- i 1)))))
(targ-cell-set!
cell
(list 'append
"/* exit representation: "
(targ-repr-to-string
src-loc-descrs
targ-repr-have-reprs
targ-repr-live2?)
" */"
#\newline
(cons 'seq lst)
#\newline))))
; preprocess graph to access it faster
(stretchable-vector-for-each
(lambda (block lbl)
(if block
(for-each ; collapse each label reference to a block
(lambda (x)
(if (car x) ; #f indicates an unknown exit block
(set-car! x
(stretchable-vector-ref
targ-repr-graph
(car x)))))
(targ-block-exits block))))
targ-repr-graph)
(let loop1 ()
(let ((changed? #f))
(define (intersect-reprs src)
(let ((loc-descrs (targ-block-loc-descrs src)))
(stretchable-vector-for-each
(lambda (descr i)
(if (targ-repr-live1? descr)
(let ((new
(targ-repr-need-reprs-union
descr
(targ-repr-entry-reprs descr))))
(stretchable-vector-set!
loc-descrs
i
(if (memq (targ-block-kind src)
'(entry return task-entry task-return))
new
(targ-repr-entry-reprs-set new targ-repr-universal))))))
loc-descrs)))
(define (propagate-repr src)
(let ((compute-reprs (compute-reprs-function src))
(loc-descrs (targ-block-loc-descrs src)))
(stretchable-vector-for-each
(lambda (descr i)
(if (targ-repr-live2? descr)
(let ((new
(targ-repr-need-reprs-union
descr
(compute-reprs descr i))))
(if (and (targ-repr-empty? (targ-repr-have-reprs descr))
(not (targ-repr-equal-descr? new descr)))
(begin
(set! changed? #t)
(stretchable-vector-set! loc-descrs i new))))))
loc-descrs)))
(let loop2 ((lbl (- (stretchable-vector-length targ-repr-graph) 1)))
(if (>= lbl 0)
(let ((block (stretchable-vector-ref targ-repr-graph lbl)))
(if block
(intersect-reprs block))
(loop2 (- lbl 1)))))
(let loop3 ((lbl (- (stretchable-vector-length targ-repr-graph) 1)))
(if (>= lbl 0)
(let ((block (stretchable-vector-ref targ-repr-graph lbl)))
(if block
(propagate-repr block))
(loop3 (- lbl 1)))))
(if changed?
(loop1))))
(let loop4 ((lbl (- (stretchable-vector-length targ-repr-graph) 1)))
(if (>= lbl 0)
(let ((block (stretchable-vector-ref targ-repr-graph lbl)))
(if block
(for-each
(lambda (x)
(insert-exit-conversions block (car x) (cdr x)))
(targ-block-exits block)))
(loop4 (- lbl 1)))))
(let loop5 ((lbl (- (stretchable-vector-length targ-repr-graph) 1)))
(if (>= lbl 0)
(let ((block (stretchable-vector-ref targ-repr-graph lbl)))
(if block
(let ((cell (targ-block-entry-cell block)))
(cond ((memq (targ-block-kind block)
'(entry return task-entry task-return))
(targ-cell-set!
cell
(list 'append
"/* entry representation: "
(targ-repr-to-string
(targ-block-loc-descrs block)
targ-repr-need-reprs
targ-repr-live1?)
" */"
#\newline
(begin
(set! targ-proc-fp (targ-block-entry-fs block))
(cons 'seq
(targ-repr-setup-need
(targ-block-loc-descrs block))))
#\newline)))
((memq (targ-block-kind block)
'(return-internal))
(targ-cell-set!
cell
(list 'append
"/* entry representation: "
(targ-repr-to-string
(targ-block-loc-descrs block)
targ-repr-need-reprs
targ-repr-live1?)
" */"
#\newline
;; (targ-repr-internal-need block)
#\newline)))
(else
(targ-cell-set!
cell
(list 'append
"/* entry representation: "
(targ-repr-to-string
(targ-block-loc-descrs block)
targ-repr-need-reprs
targ-repr-live1?)
" */"
#\newline))))))
(loop5 (- lbl 1)))))
;; (targ-emit (list 'append (with-output-to-string (lambda () (pp targ-repr-graph)))))
(if targ-repr-enabled?
(set! targ-repr-graph #f))
#f)
(define (targ-repr-unboxed-copy src dst repr)
(let ((type (vector-ref targ-repr-types (- repr 1))))
(list (string-append "SET_" type) dst src)))
(define (targ-repr-unboxed-index-copy src dst repr)
(targ-repr-unboxed-copy
(targ-repr-unboxed-index->code src repr)
(targ-repr-unboxed-index->code dst repr)
repr))
(define (targ-repr-setup-need loc-descrs)
(let ((lst '()))
(stretchable-vector-for-each
(lambda (descr i)
(if (targ-repr-live1? descr)
(let ((need (targ-repr-need-reprs descr)))
(let ((loc (targ-repr-index->loc i)))
(let loop ((r (+ targ-repr-boxed 1)))
(if (< r targ-repr-nb-reprs)
(begin
(if (targ-repr-member? r need)
(set! lst
(cons (targ-repr-from-boxed! loc r) lst)))
(loop (+ r 1)))))))))
loc-descrs)
lst))
(define (targ-repr-internal-need block)
(set! targ-proc-fp (targ-block-entry-fs block))
(let ((lst '())
(loc-descrs (targ-block-loc-descrs block)))
(set! lst (cons #\newline (cons "END" (cons #\newline lst))))
(stretchable-vector-for-each
(lambda (descr i)
(if (targ-repr-live1? descr)
(let ((need (targ-repr-need-reprs descr)))
(let ((loc (targ-repr-index->loc i)))
(let loop ((r (+ targ-repr-boxed 1)))
(if (< r targ-repr-nb-reprs)
(begin
(if (targ-repr-member? r need)
(set! lst
(cons (targ-repr-from-boxed! loc r) lst)))
(loop (+ r 1)))))))))
loc-descrs)
(set! lst (cons #\newline (cons "TRAP" (cons #\newline lst))))
(stretchable-vector-for-each
(lambda (descr i)
(if (targ-repr-live1? descr)
(let ((need (targ-repr-need-reprs descr)))
(if (not (targ-repr-member? targ-repr-boxed need))
(let loop2 ((r (+ targ-repr-boxed 1)))
(if (not (targ-repr-member? r need))
(loop2 (+ r 1))
(set! lst
(cons (targ-repr-to-boxed! (targ-repr-index->loc i) r)
lst))))))))
loc-descrs)
(set! lst (cons #\newline (cons "BEGIN" (cons #\newline lst))))
(cons 'seq lst)))
;************
(define (targ-repr-to-string loc-descrs reprs-extract live?)
(let ((str ""))
(stretchable-vector-for-each
(lambda (descr i)
(if (live? descr)
(let ((loc (targ-repr-index->loc i))
(reprs (reprs-extract descr)))
(set! str
(string-append
str
" "
(loc->str loc)
"="
(reprs->str reprs))))))
loc-descrs)
str))
(define (loc->str loc)
(if (reg? loc)
(string-append "R" (number->string (reg-num loc)))
(string-append "STK" (number->string (stk-num loc)))))
(define (reprs->str reprs)
(let ((str "{"))
(let loop ((r targ-repr-boxed) (sep ""))
(if (< r targ-repr-nb-reprs)
(if (targ-repr-member? r reprs)
(begin
(set! str
(string-append str
sep
(if (= r targ-repr-boxed)
"boxed"
(vector-ref targ-repr-types (- r 1)))))
(loop (+ r 1) ","))
(loop (+ r 1) sep))))
(string-append str "}")))
(define (targ-repr-for-each-live proc frame)
(let* ((live
(frame-live frame))
(any-closed-live?
(varset-intersects?
live
(list->varset (frame-closed frame)))))
(define (live? var)
(or (varset-member? var live)
(and (eq? var closure-env-var) any-closed-live?)))
(let ((slots (frame-slots frame)))
(let loop1 ((i (length slots)) (lst slots))
(if (pair? lst)
(begin
(if (live? (car lst))
(proc (targ-repr-loc->index (make-stk i))))
(loop1 (- i 1) (cdr lst)))
(let ((regs (frame-regs frame)))
(let loop2 ((i 0) (lst regs))
(if (pair? lst)
(begin
(if (live? (car lst))
(proc (targ-repr-loc->index (make-reg i))))
(loop2 (+ i 1) (cdr lst)))))))))))
(define (targ-repr-begin-block! kind lbl)
(targ-fp-cache-init);************
(if targ-repr-enabled?
(let ((cell (targ-make-cell #f))
(fs (frame-size targ-proc-exit-frame)))
(targ-emit cell)
(set! targ-repr-current-block
(targ-make-block kind lbl cell))
(stretchable-vector-set!
targ-repr-graph
lbl
targ-repr-current-block)
(targ-block-entry-fs-set!
targ-repr-current-block
fs)
(let ((loc-descrs (targ-block-loc-descrs targ-repr-current-block)))
(if (memq kind
'(entry return task-entry task-return))
(let loop ((i (- (+ targ-nb-gvm-regs fs) 1)))
(if (>= i 0)
(let ((descr (stretchable-vector-ref loc-descrs i)))
(stretchable-vector-set!
loc-descrs
i
(targ-repr-need-reprs-union
descr
(targ-repr-singleton targ-repr-boxed)))
(loop (- i 1))))))
(targ-repr-for-each-live
(lambda (i)
(stretchable-vector-set!
loc-descrs
i
(targ-repr-live1-add
(stretchable-vector-ref loc-descrs i))))
targ-proc-exit-frame)))))
(define (targ-repr-exit-block! lbl)
(if targ-repr-enabled?
(let ((cell (targ-make-cell #f)))
(targ-emit cell)
(targ-block-add-exit!
targ-repr-current-block
lbl
cell))))
(define (targ-repr-end-block!)
(if targ-repr-enabled?
(begin
(targ-block-exit-fs-set!
targ-repr-current-block
(frame-size targ-proc-exit-frame))
(let ((loc-descrs (targ-block-loc-descrs targ-repr-current-block)))
(targ-repr-for-each-live
(lambda (i)
(stretchable-vector-set!
loc-descrs
i
(targ-repr-live2-add
(stretchable-vector-ref loc-descrs i))))
targ-proc-exit-frame))
(set! targ-repr-current-block #f))))
(define (targ-repr-loc->index loc)
(cond ((reg? loc)
(reg-num loc))
((stk? loc)
(+ (- (stk-num loc) 1) targ-nb-gvm-regs))
(else
(compiler-internal-error
"targ-repr-loc->index, invalid 'loc'" loc))))
(define (targ-repr-index->loc i)
(if (< i targ-nb-gvm-regs)
(make-reg i)
(make-stk (+ (- i targ-nb-gvm-regs) 1))))
(define (targ-repr-unboxed-index->code i repr)
(let ((type (vector-ref targ-repr-types (- repr 1))))
(targ-need-unboxed i repr)
(if (< i targ-nb-gvm-regs)
(list (string-append
type
"R"
(number->string i)))
(list (string-append
type
"STK"
(number->string (+ (- i targ-nb-gvm-regs) 1)))))))
(define (targ-repr-index->code i repr)
(if (= repr targ-repr-boxed)
(if (< i targ-nb-gvm-regs)
(cons 'r i)
(list "STK" (- (+ (- i targ-nb-gvm-regs) 1) targ-proc-fp)))
(targ-repr-unboxed-index->code i repr)))
(define (targ-repr-unboxed-loc->code loc repr)
(targ-repr-unboxed-index->code
(targ-repr-loc->index loc)
repr))
(define (targ-repr-to-boxed! loc repr)
(targ-repr-loc-boxed
loc
(targ-repr-to-boxed
(targ-repr-unboxed-loc->code loc repr)
repr)))
(define (targ-repr-from-boxed! loc repr)
(let ((type (vector-ref targ-repr-types (- repr 1))))
(list (string-append "SET_" type)
(targ-repr-unboxed-loc->code loc repr)
(targ-repr-from-boxed
(targ-repr-opnd-boxed loc)
repr))))
(define (targ-repr-opnd opnd repr)
(if targ-repr-enabled?
(if (or (reg? opnd) (stk? opnd))
(let* ((loc-descrs
(targ-block-loc-descrs targ-repr-current-block))
(i
(targ-repr-loc->index opnd))
(descr
(stretchable-vector-ref loc-descrs i))
(have
(targ-repr-have-reprs descr)))
(cond ((targ-repr-empty? have)
(stretchable-vector-set! loc-descrs i
(targ-repr-need-reprs-union
descr
(targ-repr-singleton repr))))
((not (targ-repr-member? repr have))
(let loop ((r targ-repr-boxed))
(if (not (targ-repr-member? r have))
(loop (+ r 1))
(if (not (= r targ-repr-boxed))
(targ-emit (targ-repr-to-boxed! opnd r)))))
(if (not (= repr targ-repr-boxed))
(targ-emit (targ-repr-from-boxed! opnd repr)))
(stretchable-vector-set! loc-descrs i
(targ-repr-have-reprs-union
(targ-repr-have-reprs-union
descr
(targ-repr-singleton repr))
targ-repr-boxed))))
(targ-repr-index->code i repr))
(if (and (= repr targ-repr-f64)
(obj? opnd)
(eq? (targ-obj-type (obj-val opnd)) 'subtyped)
(eq? (targ-obj-subtype (obj-val opnd)) 'flonum)
targ-use-c-fp-constants?
(not (targ-unusual-float? (obj-val opnd))))
(obj-val opnd)
(targ-repr-from-boxed (targ-repr-opnd-boxed opnd) repr)))
(targ-repr-from-boxed (targ-repr-opnd-boxed opnd) repr)))
(define (targ-repr-from-boxed code repr)
(if (= repr targ-repr-boxed)
code
(list (string-append (vector-ref targ-repr-types (- repr 1)) "UNBOX")
code)))
(define (targ-repr-to-boxed code repr)
(if (= repr targ-repr-boxed)
code
(begin
(targ-need-heap)
(list (string-append (vector-ref targ-repr-types (- repr 1)) "BOX")
code))))
(define (targ-repr-opnd-boxed opnd)
(cond ((reg? opnd)
(let ((n (reg-num opnd)))
(targ-rd-reg n)
(cons 'r n)))
((stk? opnd)
(targ-rd-fp)
(list "STK" (- (stk-num opnd) targ-proc-fp)))
((glo? opnd)
(let ((name (glo-name opnd)))
(list "GLO"
(targ-use-glo name #f)
(targ-c-id-glo (symbol->string name)))))
((clo? opnd)
(list "CLO"
(targ-opnd (clo-base opnd))
(clo-index opnd)))
((lbl? opnd)
(let ((n (lbl-num opnd)))
(list "LBL" (targ-ref-lbl-val n))))
((obj? opnd)
(targ-use-obj (obj-val opnd)))
(else
(compiler-internal-error
"targ-repr-opnd-boxed, unknown 'opnd'" opnd))))
(define (targ-repr-loc loc val repr)
(if targ-repr-enabled?
(if (or (reg? loc) (stk? loc))
(let* ((loc-descrs
(targ-block-loc-descrs targ-repr-current-block))
(i
(targ-repr-loc->index loc))
(descr
(stretchable-vector-ref loc-descrs i))
(x
(if (= repr targ-repr-boxed)
(targ-repr-loc-boxed loc val)
(let ((type (vector-ref targ-repr-types (- repr 1))))
(list (string-append "SET_" type)
(targ-repr-unboxed-loc->code loc repr)
val)))))
(stretchable-vector-set! loc-descrs i
(targ-repr-have-reprs-set
descr
(targ-repr-singleton repr)))
x)
(targ-repr-loc-boxed loc (targ-repr-to-boxed val repr)))
(targ-repr-loc-boxed loc (targ-repr-to-boxed val repr))))
(define (targ-repr-loc-boxed loc val)
(cond ((reg? loc)
(let ((n (reg-num loc)))
(targ-wr-reg n)
(list 'set-r n val)))
((stk? loc)
(targ-rd-fp)
(list "SET_STK" (- (stk-num loc) targ-proc-fp) val))
((glo? loc)
(let ((name (glo-name loc)))
(list "SET_GLO"
(targ-use-glo name #t)
(targ-c-id-glo (symbol->string name))
val)))
((clo? loc)
(list "SET_CLO"
(targ-opnd (clo-base loc))
(clo-index loc)))
(else
(compiler-internal-error
"targ-repr-loc-boxed, unknown 'loc'" loc))))
(define (targ-opnd opnd) ; fetch a GVM operand in boxed form
(targ-repr-opnd opnd targ-repr-boxed))
(define (targ-opnd-flo opnd) ; fetch a GVM operand as an unboxed flonum
(targ-repr-opnd opnd targ-repr-f64))
(define (targ-loc loc val) ; store boxed value in GVM location
(targ-repr-loc loc val targ-repr-boxed))
(define (targ-loc-flo loc val) ; store unboxed flonum to GVM location
(targ-repr-loc loc val targ-repr-f64))
)
;;;----------------------------------------------------------------------------
(define (targ-opnd opnd) ; fetch GVM operand
(if (and targ-fp-cache-enabled? (or (reg? opnd) (stk? opnd)))
(targ-fp-cache-write-if-dirty opnd))
(cond ((reg? opnd)
(let ((n (reg-num opnd)))
(targ-rd-reg n)
(cons 'r n)))
((stk? opnd)
(targ-rd-fp)
(list "STK" (- (stk-num opnd) targ-proc-fp)))
((glo? opnd)
(let ((name (glo-name opnd)))
(list "GLO"
(targ-use-glo name #f)
(targ-c-id-glo (symbol->string name)))))
((clo? opnd)
(list "CLO"
(targ-opnd (clo-base opnd))
(clo-index opnd)))
((lbl? opnd)
(let ((n (lbl-num opnd)))
(list "LBL" (targ-ref-lbl-val n))))
((obj? opnd)
(targ-use-obj (obj-val opnd)))
(else
(compiler-internal-error
"targ-opnd, unknown 'opnd'" opnd))))
(define (targ-loc loc val) ; store GVM location
(let ((x (targ-loc-no-invalidate loc val)))
(if (and targ-fp-cache-enabled? (or (reg? loc) (stk? loc)))
(targ-fp-cache-invalidate loc))
x))
(define (targ-loc-no-invalidate loc val) ; store GVM location without
; invalidating flonum cache
(cond ((reg? loc)
(let ((n (reg-num loc)))
(targ-wr-reg n)
(list 'set-r n val)))
((stk? loc)
(targ-rd-fp)
(list "SET_STK" (- (stk-num loc) targ-proc-fp) val))
((glo? loc)
(let ((name (glo-name loc)))
(list "SET_GLO"
(targ-use-glo name #t)
(targ-c-id-glo (symbol->string name))
val)))
((clo? loc)
(list "SET_CLO"
(targ-opnd (clo-base loc))
(clo-index loc)))
(else
(compiler-internal-error
"targ-loc, unknown 'loc'" loc))))
(define (targ-opnd-flo opnd) ; fetch unboxed flonum GVM operand
(cond ((and targ-fp-cache-enabled? (or (reg? opnd) (stk? opnd)))
(let ((stamp1 (targ-fp-cache-probe opnd)))
(if stamp1
(targ-unboxed-loc->code opnd stamp1)
(let* ((stamp2 (targ-fp-cache-enter opnd #f))
(code (targ-unboxed-loc->code opnd stamp2)))
(targ-emit
(list "SET_F64" code (list "F64UNBOX" (targ-opnd opnd))))
code))))
((and (obj? opnd)
(eq? (targ-obj-type (obj-val opnd)) 'subtyped)
(eq? (targ-obj-subtype (obj-val opnd)) 'flonum)
targ-use-c-fp-constants?
(not (targ-unusual-float? (obj-val opnd))))
(obj-val opnd))
(else
(list "F64UNBOX" (targ-opnd opnd)))))
(define (targ-loc-flo loc val fs) ; store unboxed flonum to GVM location
(if (and targ-fp-cache-enabled? (or (reg? loc) (stk? loc)))
(begin
(targ-fp-cache-invalidate loc)
(let* ((stamp (targ-fp-cache-enter loc #t))
(code (targ-unboxed-loc->code loc stamp)))
(list "SET_F64" code val)))
(begin
(targ-heap-reserve-and-check targ-flonum-space fs)
(targ-loc loc (list "F64BOX" val)))))
;;;----------------------------------------------------------------------------
(define (targ-adjust-stack fs)
(if (= targ-proc-fp fs)
#f
(let ((fp targ-proc-fp))
(set! targ-proc-fp fs)
(targ-rd-fp)
(targ-wr-fp)
(list "ADJFP" (- fs fp)))))
(define (targ-sn-opnd opnd sn)
(cond ((stk? opnd)
(max (stk-num opnd) sn))
((clo? opnd)
(targ-sn-opnd (clo-base opnd) sn))
(else
sn)))
(define (targ-sn-opnds opnds sn)
(if (pair? opnds)
(targ-sn-opnd (car opnds) (targ-sn-opnds (cdr opnds) sn))
sn))
(define (targ-sn-loc loc sn)
(if loc
(targ-sn-opnd loc sn)
sn))
;;;----------------------------------------------------------------------------
;; Floating point number cache management.
(define targ-use-c-fp-constants? #f)
(set! targ-use-c-fp-constants? #t)
(define targ-fp-cache-enabled? #f)
(set! targ-fp-cache-enabled? #t)
(define (targ-fp-cache-init)
(set! targ-fp-cache (vector 0 '#() 0)))
(define (targ-fp-cache-size)
(vector-ref targ-fp-cache 0))
(define (targ-fp-cache-write loc stamp)
(targ-heap-reserve targ-flonum-space)
(targ-emit
(targ-loc-no-invalidate
loc
(list "F64BOX" (targ-unboxed-loc->code loc stamp)))))
(define (targ-fp-cache-write-if-dirty loc)
(let ((v (vector-ref targ-fp-cache 1)))
(let ((n (vector-length v)))
(let loop ((i 0))
(if (< i n)
(let ((x (vector-ref v i)))
(if (and x (vector-ref x 1) (eqv? (vector-ref x 0) loc))
(begin
(targ-fp-cache-write loc (vector-ref x 2))
(vector-set! x 1 #f))
(loop (+ i 1)))))))))
(define (targ-fp-cache-enter opnd dirty?) ; allocate new entry for opnd
(let* ((v1
(vector-ref targ-fp-cache 1))
(stamp
(let ((n (+ (vector-ref targ-fp-cache 2) 1)))
(vector-set! targ-fp-cache 2 n)
n))
(entry
(vector opnd dirty? stamp)))
(let ((n (vector-length v1)))
(let loop1 ((i 0))
(if (< i n)
(if (vector-ref v1 i)
(loop1 (+ i 1))
(vector-set! v1 i entry))
(let ((v2 (make-vector (+ (* n 2) 1) #f)))
(let loop2 ((i 0))
(if (< i n)
(begin
(vector-set! v2 i (vector-ref v1 i))
(loop2 (+ i 1)))))
(vector-set! v2 n entry)
(vector-set! targ-fp-cache 0 (+ n 1))
(vector-set! targ-fp-cache 1 v2)))))
stamp))
(define (targ-fp-cache-probe opnd) ; opnd must be a reg or stack slot
(let ((v (vector-ref targ-fp-cache 1)))
(let ((n (vector-length v)))
(let loop ((i 0))
(if (< i n)
(let ((x (vector-ref v i)))
(if (and x (eqv? (vector-ref x 0) opnd))
(vector-ref x 2)
(loop (+ i 1))))
#f)))))
(define (targ-fp-cache-invalidate opnd) ; opnd must be a reg or stack slot
(let ((v (vector-ref targ-fp-cache 1)))
(let ((n (vector-length v)))
(let loop ((i 0))
(if (< i n)
(let ((x (vector-ref v i)))
(if (and x (eqv? (vector-ref x 0) opnd))
(vector-set! v i #f))
(loop (+ i 1))))))))
;;;============================================================================
;; DATABASE OF PRIMITIVES
(for-each targ-prim-proc-add!
'(
("##c-code" 0 #t 0 0 (#f) extended)
))
;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;; Procedure specialization
(define (targ-spec name specializer-maker)
(let ((proc-name (string->canonical-symbol name)))
(let ((proc (targ-get-prim-info name)))
(proc-obj-specialize-set! proc (specializer-maker proc proc-name)))))
;; Safe specialization
(define (targ-s name)
(lambda (proc proc-name)
(let ((spec (targ-get-prim-info name)))
(lambda (env args) spec))))
;; Unsafe specialization
(define (targ-u name)
(lambda (proc proc-name)
(let ((spec (targ-get-prim-info name)))
(lambda (env args) (if (not (safe? env)) spec proc)))))
;; Arithmetic specialization
(define (targ-arith fix-name flo-name)
(lambda (proc proc-name)
(let ((fix-spec (if fix-name (targ-get-prim-info fix-name) proc))
(flo-spec (if flo-name (targ-get-prim-info flo-name) proc)))
(lambda (env args)
(let ((arith (arith-implementation proc-name env)))
(cond ((eq? arith fixnum-sym)
fix-spec)
((eq? arith flonum-sym)
flo-spec)
(else
proc)))))))
;; Safe specialization for eqv? and ##eqv?
(define (targ-s-eqv?)
(lambda (proc proc-name)
(let ((spec (targ-get-prim-info "##eq?")))
(lambda (env args)
(if (and (= (length args) 2)
(or (eq? (arith-implementation proc-name env) fixnum-sym)
(targ-eq-testable-object? (car args))
(targ-eq-testable-object? (cadr args))))
spec
proc)))))
;; Safe specialization for equal? and ##equal?
(define (targ-s-equal?)
(lambda (proc proc-name)
(let ((spec (targ-get-prim-info "##eq?")))
(lambda (env args)
(if (and (= (length args) 2)
(or (targ-eq-testable-object? (car args))
(targ-eq-testable-object? (cadr args))))
spec
proc)))))
(define (targ-eq-testable-object? obj)
(and (not (void-object? obj)) ; the void-object denotes a non-constant
(targ-testable-with-eq? obj)))
(define (targ-testable-with-eq? obj)
(or (symbol-object? obj)
(keyword-object? obj)
(memq (targ-obj-type obj)
'(boolean null absent unused deleted void eof optional
key rest
fixnum char))))
;;;----------------------------------------------------------------------------
(define (targ-op name descr)
(descr (targ-get-prim-info name)))
;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
(define (targ-apply-alloc compute-space proc-safe? side-effects? flo-result? f)
(targ-setup-inlinable-proc
proc-safe?
side-effects?
flo-result?
(lambda (opnds sn)
(targ-heap-reserve-and-check
(compute-space (length opnds))
(targ-sn-opnds opnds sn))
(f opnds sn))))
(define (targ-apply-cons)
(targ-apply-alloc
(lambda (n) targ-pair-space)
#t
#f
#f
(targ-apply-simp-generator #f "CONS")))
(define (targ-apply-list)
(targ-apply-alloc
(lambda (n) (* n targ-pair-space))
#t
#f
#f
(lambda (opnds sn)
(cond ((null? opnds)
'("NUL"))
((null? (cdr opnds))
(list "CONS" (targ-opnd (car opnds)) '("NUL")))
(else
(let* ((rev-elements (reverse (map targ-opnd opnds)))
(n (length rev-elements)))
(targ-emit
(list "BEGIN_ALLOC_LIST" n (car rev-elements)))
(for-each-index (lambda (elem i)
(targ-emit
(list "ADD_LIST_ELEM" (+ i 1) elem)))
(cdr rev-elements))
(targ-emit
(list "END_ALLOC_LIST" n))
(list "GET_LIST" n)))))))
(define (targ-apply-box)
(targ-apply-alloc
(lambda (n) targ-box-space)
#t
#f
#f
(targ-apply-simp-generator #f "BOX")))
(define (targ-apply-make-will)
(targ-apply-alloc
(lambda (n) targ-will-space)
#t
'expr ; this is an expression with side-effects
#f
(lambda (opnds sn)
(targ-apply-simp-gen opnds #f "MAKEWILL"))))
(define (targ-apply-make-promise)
(targ-apply-alloc
(lambda (n) targ-promise-space)
#t
#f
#f
(targ-apply-simp-generator #f "MAKEPROMISE")))
(define (targ-apply-vector-s kind)
(targ-apply-vector #t kind))
(define (targ-apply-vector-u kind)
(targ-apply-vector #f kind))
(define (targ-apply-vector proc-safe? kind)
(targ-setup-inlinable-proc
proc-safe?
#f
#f
(lambda (opnds sn)
(let ((n (length opnds)))
(if (and (eq? kind 'values) (= n 1))
(targ-opnd (car opnds))
(let ()
(define (compute-space n)
(case kind
((string) (targ-string-space n))
((s8vector) (targ-s8vector-space n))
((u8vector) (targ-s8vector-space n))
((s16vector) (targ-s8vector-space (* n 2)))
((u16vector) (targ-s8vector-space (* n 2)))
((s32vector) (targ-s8vector-space (* n 4)))
((u32vector) (targ-s8vector-space (* n 4)))
((s64vector) (targ-s8vector-space (* n 8)))
((u64vector) (targ-s8vector-space (* n 8)))
((f32vector) (targ-s8vector-space (* n 4)))
((f64vector) (targ-s8vector-space (* n 8)))
((values) (targ-vector-space n))
((structure) (targ-vector-space n))
(else (targ-vector-space n))))
(define begin-allocator-name
(case kind
((string) "BEGIN_ALLOC_STRING")
((s8vector) "BEGIN_ALLOC_S8VECTOR")
((u8vector) "BEGIN_ALLOC_U8VECTOR")
((s16vector) "BEGIN_ALLOC_S16VECTOR")
((u16vector) "BEGIN_ALLOC_U16VECTOR")
((s32vector) "BEGIN_ALLOC_S32VECTOR")
((u32vector) "BEGIN_ALLOC_U32VECTOR")
((s64vector) "BEGIN_ALLOC_S64VECTOR")
((u64vector) "BEGIN_ALLOC_U64VECTOR")
((f32vector) "BEGIN_ALLOC_F32VECTOR")
((f64vector) "BEGIN_ALLOC_F64VECTOR")
((values) "BEGIN_ALLOC_VALUES")
((structure) "BEGIN_ALLOC_STRUCTURE")
(else "BEGIN_ALLOC_VECTOR")))
(define end-allocator-name
(case kind
((string) "END_ALLOC_STRING")
((s8vector) "END_ALLOC_S8VECTOR")
((u8vector) "END_ALLOC_U8VECTOR")
((s16vector) "END_ALLOC_S16VECTOR")
((u16vector) "END_ALLOC_U16VECTOR")
((s32vector) "END_ALLOC_S32VECTOR")
((u32vector) "END_ALLOC_U32VECTOR")
((s64vector) "END_ALLOC_S64VECTOR")
((u64vector) "END_ALLOC_U64VECTOR")
((f32vector) "END_ALLOC_F32VECTOR")
((f64vector) "END_ALLOC_F64VECTOR")
((values) "END_ALLOC_VALUES")
((structure) "END_ALLOC_STRUCTURE")
(else "END_ALLOC_VECTOR")))
(define add-element
(case kind
((string) "ADD_STRING_ELEM")
((s8vector) "ADD_S8VECTOR_ELEM")
((u8vector) "ADD_U8VECTOR_ELEM")
((s16vector) "ADD_S16VECTOR_ELEM")
((u16vector) "ADD_U16VECTOR_ELEM")
((s32vector) "ADD_S32VECTOR_ELEM")
((u32vector) "ADD_U32VECTOR_ELEM")
((s64vector) "ADD_S64VECTOR_ELEM")
((u64vector) "ADD_U64VECTOR_ELEM")
((f32vector) "ADD_F32VECTOR_ELEM")
((f64vector) "ADD_F64VECTOR_ELEM")
((values) "ADD_VALUES_ELEM")
((structure) "ADD_STRUCTURE_ELEM")
(else "ADD_VECTOR_ELEM")))
(define getter-operation
(case kind
((string) "GET_STRING")
((s8vector) "GET_S8VECTOR")
((u8vector) "GET_U8VECTOR")
((s16vector) "GET_S16VECTOR")
((u16vector) "GET_U16VECTOR")
((s32vector) "GET_S32VECTOR")
((u32vector) "GET_U32VECTOR")
((s64vector) "GET_S64VECTOR")
((u64vector) "GET_U64VECTOR")
((f32vector) "GET_F32VECTOR")
((f64vector) "GET_F64VECTOR")
((values) "GET_VALUES")
((structure) "GET_STRUCTURE")
(else "GET_VECTOR")))
(targ-heap-reserve-and-check
(compute-space n)
(targ-sn-opnds opnds sn))
(let* ((flo? (or (eq? kind 'f32vector) (eq? kind 'f64vector)))
(elements (map (if flo? targ-opnd-flo targ-opnd) opnds)))
(targ-emit
(list begin-allocator-name n))
(for-each-index (lambda (elem i)
(targ-emit
(list add-element i elem)))
elements)
(targ-emit
(list end-allocator-name n))
(list getter-operation n))))))))
;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
(define (targ-apply-force)
(lambda (prim)
(proc-obj-inlinable?-set! prim (lambda (env) #t))
(proc-obj-inline-set!
prim
(lambda (opnds loc sn)
(let ((lbl (targ-new-lbl))
(opnd (car opnds))
(sn* (targ-sn-loc loc sn)))
(targ-update-fr targ-proc-entry-frame)
(targ-emit (targ-adjust-stack sn*))
(targ-emit (list "FORCE1"
(targ-ref-lbl-val lbl)
(targ-opnd opnd)))
;; (targ-repr-exit-block! lbl)
;; (targ-repr-end-block!)
(targ-gen-label-return* lbl 'return-internal)
(targ-emit (list "FORCE2"))
(if loc
(targ-emit (targ-loc loc (list "FORCE3")))))))))
;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
(define (targ-apply-first-argument)
(targ-setup-inlinable-proc*
#t
(lambda (opnds sn)
(targ-opnd (car opnds)))))
;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
(define (targ-apply-check-heap-limit)
(lambda (prim)
(proc-obj-inlinable?-set! prim (lambda (env) #t))
(proc-obj-inline-set!
prim
(lambda (opnds loc sn)
(if (> targ-proc-hp 0)
(targ-update-fr-and-check-heap 0 sn))
(if loc
(targ-emit
(targ-loc loc (targ-opnd (make-obj false-object)))))))))
;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
(define (targ-ifjump-simp-s flo? name)
(targ-ifjump-simp #t flo? name))
(define (targ-ifjump-simp-u flo? name)
(targ-ifjump-simp #f flo? name))
(define (targ-ifjump-simp proc-safe? flo? name)
(targ-setup-test-proc*
proc-safe?
flo?
(targ-ifjump-simp-generator flo? name)))
(define (targ-ifjump-fold-s flo? name)
(targ-ifjump-fold #t flo? name))
(define (targ-ifjump-fold-u flo? name)
(targ-ifjump-fold #f flo? name))
(define (targ-ifjump-fold proc-safe? flo? name)
(targ-setup-test-proc*
proc-safe?
flo?
(targ-ifjump-fold-generator flo? name)))
(define (targ-ifjump-apply-s name)
(targ-ifjump-apply #t name))
(define (targ-ifjump-apply-u name)
(targ-ifjump-apply #f name))
(define (targ-ifjump-apply proc-safe? name)
(targ-setup-inlinable-proc*
proc-safe?
(targ-apply-simp-generator #f name)))
(define (targ-apply-simp-s flo? side-effects? name)
(targ-apply-simp #t flo? side-effects? name))
(define (targ-apply-simp-u flo? side-effects? name)
(targ-apply-simp #f flo? side-effects? name))
(define (targ-apply-simp proc-safe? flo? side-effects? name); prim. with non-flonum result
(targ-setup-inlinable-proc
proc-safe?
side-effects?
#f
(targ-apply-simp-generator flo? name)))
(define (targ-apply-fold-s flo? name0 name1 name2)
(targ-apply-fold #t flo? name0 name1 name2))
(define (targ-apply-fold-u flo? name0 name1 name2)
(targ-apply-fold #f flo? name0 name1 name2))
(define (targ-apply-fold proc-safe? flo? name0 name1 name2)
(let ((generator (targ-apply-fold-generator flo? name0 name1 name2)))
(if flo?
(targ-apply-alloc
(lambda (n) 0) ; targ-apply-alloc accounts for space for flonum result
proc-safe?
#f
#t
generator)
(targ-setup-inlinable-proc
proc-safe?
#f
#f
generator))))
(define (targ-apply-simpflo-s flo? name)
(targ-apply-simpflo #t flo? name))
(define (targ-apply-simpflo-u flo? name)
(targ-apply-simpflo #f flo? name))
(define (targ-apply-simpflo proc-safe? flo? name) ; prim. with flonum result
(targ-apply-alloc
(lambda (n) 0) ; targ-apply-alloc accounts for space for flonum result
proc-safe?
#f
#t
(targ-apply-simp-generator flo? name)))
(define (targ-apply-simpflo2-s flo? name1 name2)
(targ-apply-simpflo2 #t flo? name1 name2))
(define (targ-apply-simpflo2-u flo? name1 name2)
(targ-apply-simpflo2 #f flo? name1 name2))
(define (targ-apply-simpflo2 proc-safe? flo? name1 name2) ; 1 or 2 arg prim. with flonum result
(targ-apply-alloc
(lambda (n) 0) ; targ-apply-alloc accounts for space for flonum result
proc-safe?
#f
#t
(lambda (opnds sn)
(if (= (length opnds) 1)
(targ-apply-simp-gen opnds flo? name1)
(targ-apply-simp-gen opnds flo? name2)))))
(define (targ-apply-simpflo3-s name)
(targ-apply-simpflo3 #t name))
(define (targ-apply-simpflo3-u name)
(targ-apply-simpflo3 #f name))
(define (targ-apply-simpflo3 proc-safe? name); 3 arg prim. whose last arg is a flonum
(targ-setup-inlinable-proc
proc-safe?
#t
#f
(lambda (opnds sn)
(let* ((arg1 (targ-opnd (car opnds)))
(arg2 (targ-opnd (cadr opnds)))
(arg3 (targ-opnd-flo (caddr opnds))))
(list name arg1 arg2 arg3)))))
(define (targ-apply-simpbig-s name)
(targ-apply-simpbig #t name))
(define (targ-apply-simpbig-u name)
(targ-apply-simpbig #f name))
(define (targ-apply-simpbig proc-safe? name) ; prim. with 32 or 64 bit bignum result
(targ-apply-alloc
(lambda (n) (targ-s8vector-space (* (quotient targ-max-adigit-width 8) 3))) ; space for 2^64-1 including 64 bit alignment ;;;;;;;;;;ugly code!
proc-safe?
#f
#f
(lambda (opnds sn)
(targ-apply-simp-gen opnds #f name))))
;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
(define (targ-setup-test-proc* proc-safe? args-flo? generator)
(lambda (prim)
((targ-setup-test-proc proc-safe? args-flo? generator)
prim)
((targ-setup-inlinable-proc
proc-safe?
#f
#f
(lambda (opnds sn)
(list "BOOLEAN" (generator opnds sn))))
prim)))
(define (targ-setup-test-proc proc-safe? args-flo? generator)
(lambda (prim)
(proc-obj-testable?-set!
prim
(lambda (env)
(or proc-safe?
(not (safe? env)))))
(proc-obj-test-set!
prim
(vector
args-flo?
(lambda (not? opnds fs)
(let ((test (generator opnds fs)))
(if not?
(list "NOT" test)
test)))))))
(define (targ-ifjump-simp-generator flo? name)
(lambda (opnds fs)
(targ-ifjump-simp-gen opnds flo? name)))
(define (targ-ifjump-simp-gen opnds flo? name)
(let loop ((l opnds) (args '()))
(if (pair? l)
(let ((opnd (car l)))
(loop (cdr l)
(cons (if flo? (targ-opnd-flo opnd) (targ-opnd opnd))
args)))
(cons name (reverse args)))))
(define (targ-ifjump-fold-generator flo? name)
(lambda (opnds fs)
(targ-ifjump-fold-gen opnds flo? name)))
(define (targ-ifjump-fold-gen opnds flo? name)
(define (multi-opnds opnds)
(let* ((opnd1 (car opnds))
(opnd2 (cadr opnds))
(opnd1* (if flo? (targ-opnd-flo opnd1) (targ-opnd opnd1)))
(opnd2* (if flo? (targ-opnd-flo opnd2) (targ-opnd opnd2)))
(r (list name opnd1* opnd2*)))
(if (pair? (cddr opnds))
(list "AND" r (multi-opnds (cdr opnds)))
r)))
(cond ((or (not (pair? opnds))
(not (pair? (cdr opnds))))
1)
(else
(multi-opnds opnds))))
;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
(define (targ-setup-inlinable-proc* proc-safe? generator)
(lambda (prim)
((targ-setup-test-proc
proc-safe?
#f ; safe to assume that arguments are not all flonums
(lambda (opnds fs)
(list "NOT" (list "FALSEP" (generator opnds fs)))))
prim)
((targ-setup-inlinable-proc proc-safe? #f #f generator)
prim)))
(define (targ-setup-inlinable-proc proc-safe? side-effects? flo-result? generator)
(lambda (prim)
(proc-obj-inlinable?-set!
prim
(lambda (env)
(or proc-safe?
(not (safe? env)))))
(proc-obj-inline-set!
prim
(lambda (opnds loc sn)
(if loc ; result is needed?
(if (eq? side-effects? #t) ; generator generates a statement?
(let ((x (generator opnds sn)))
(targ-emit
(if (eqv? (car opnds) loc)
x
(list 'seq x (targ-loc loc (targ-opnd (car opnds)))))))
(let ((sn* (targ-sn-loc loc sn)))
(let ((x (generator opnds sn*)))
(targ-emit
(if flo-result?
(targ-loc-flo loc x sn*)
(targ-loc loc x))))))
(if side-effects? ; only generate code for side-effect
(let ((x (generator opnds sn)))
(targ-emit
(if (eq? side-effects? 'expr) (list "EXPR" x) x)))))))))
(define (targ-apply-simp-generator flo? name)
(lambda (opnds sn)
(targ-apply-simp-gen opnds flo? name)))
(define (targ-apply-simp-gen opnds flo? name)
(let loop ((l opnds) (args '()))
(if (pair? l)
(let ((opnd (car l)))
(loop (cdr l)
(cons (if flo? (targ-opnd-flo opnd) (targ-opnd opnd))
args)))
(cons name (reverse args)))))
(define (targ-apply-fold-generator flo? name0 name1 name2)
(lambda (opnds sn)
(targ-apply-fold-gen opnds flo? name0 name1 name2)))
(define (targ-apply-fold-gen opnds flo? name0 name1 name2)
(if (not (pair? opnds))
(list name0)
(let* ((o (car opnds))
(r (if flo? (targ-opnd-flo o) (targ-opnd o))))
(if (not (pair? (cdr opnds)))
(list name1 r)
(let loop ((l (cdr opnds)) (r r))
(if (pair? l)
(let ((opnd (car l)))
(loop (cdr l)
(list name2
r
(if flo? (targ-opnd-flo opnd) (targ-opnd opnd)))))
r))))))
;;;----------------------------------------------------------------------------
(define (targ-jump-inline name jump-inliner)
(let ((prim (targ-get-prim-info name)))
(proc-obj-jump-inlinable?-set! prim (lambda (env) #t))
(proc-obj-jump-inline-set! prim jump-inliner)))
(define (targ-emit-jump-inline name safe? nb-args)
(let* ((pc (targ-jump-info nb-args))
(fs (pcontext-fs pc)))
(for-each (lambda (x)
(let ((opnd (cdr x)))
(targ-opnd
(if (stk? opnd)
(make-stk (+ targ-proc-fp (- (stk-num opnd) fs)))
opnd))))
(cdr (pcontext-map pc)))
(targ-emit
(list (string-append "JUMP_" name (number->string nb-args))
(list (if safe? "JUMPSAFE" "JUMPNOTSAFE"))))))
;;;----------------------------------------------------------------------------
;; Table of inlinable operations (for 'apply' and 'ifjump' GVM instructions)
(define (targ-setup-inlinable)
;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
(targ-op "##type" (targ-apply-simp-s #f #f "TYPE"))
(targ-op "##type-cast" (targ-apply-simp-u #f #f "TYPECAST"))
(targ-op "##subtype" (targ-apply-simp-u #f #f "SUBTYPE"))
(targ-op "##subtype-set!" (targ-apply-simp-u #f #t "SUBTYPESET"))
;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
(targ-op "##not" (targ-ifjump-simp-s #f "FALSEP"))
(targ-op "##boolean?" (targ-ifjump-simp-s #f "BOOLEANP"))
(targ-op "##null?" (targ-ifjump-simp-s #f "NULLP"))
(targ-op "##unbound?" (targ-ifjump-simp-s #f "UNBOUNDP"))
(targ-op "##eq?" (targ-ifjump-simp-s #f "EQP"))
(targ-op "##eof-object?" (targ-ifjump-simp-s #f "EOFP"))
;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
(targ-op "##fixnum?" (targ-ifjump-simp-s #f "FIXNUMP"))
(targ-op "##special?" (targ-ifjump-simp-s #f "SPECIALP"))
(targ-op "##pair?" (targ-ifjump-simp-s #f "PAIRP"))
(targ-op "##pair-mutable?" (targ-ifjump-simp-s #f "PAIRMUTABLEP"))
(targ-op "##subtyped?" (targ-ifjump-simp-s #f "SUBTYPEDP"))
(targ-op "##subtyped-mutable?"(targ-ifjump-simp-s #f "SUBTYPEDMUTABLEP"))
(targ-op "##subtyped.vector?" (targ-ifjump-simp-u #f "SUBTYPEDVECTORP"))
(targ-op "##subtyped.symbol?" (targ-ifjump-simp-u #f "SUBTYPEDSYMBOLP"))
(targ-op "##subtyped.flonum?" (targ-ifjump-simp-u #f "SUBTYPEDFLONUMP"))
(targ-op "##subtyped.bignum?" (targ-ifjump-simp-u #f "SUBTYPEDBIGNUMP"))
(targ-op "##vector?" (targ-ifjump-simp-s #f "VECTORP"))
(targ-op "##ratnum?" (targ-ifjump-simp-s #f "RATNUMP"))
(targ-op "##cpxnum?" (targ-ifjump-simp-s #f "CPXNUMP"))
(targ-op "##structure?" (targ-ifjump-simp-s #f "STRUCTUREP"))
(targ-op "##box?" (targ-ifjump-simp-s #f "BOXP"))
(targ-op "##values?" (targ-ifjump-simp-s #f "VALUESP"))
(targ-op "##meroon?" (targ-ifjump-simp-s #f "MEROONP"))
(targ-op "##jazz?" (targ-ifjump-simp-s #f "JAZZP"))
(targ-op "##symbol?" (targ-ifjump-simp-s #f "SYMBOLP"))
(targ-op "##keyword?" (targ-ifjump-simp-s #f "KEYWORDP"))
(targ-op "##frame?" (targ-ifjump-simp-s #f "FRAMEP"))
(targ-op "##continuation?" (targ-ifjump-simp-s #f "CONTINUATIONP"))
(targ-op "##promise?" (targ-ifjump-simp-s #f "PROMISEP"))
(targ-op "##will?" (targ-ifjump-simp-s #f "WILLP"))
(targ-op "##gc-hash-table?" (targ-ifjump-simp-s #f "GCHASHTABLEP"))
(targ-op "##mem-allocated?" (targ-ifjump-simp-s #f "MEMALLOCATEDP"))
(targ-op "##procedure?" (targ-ifjump-simp-s #f "PROCEDUREP"))
(targ-op "##return?" (targ-ifjump-simp-s #f "RETURNP"))
(targ-op "##foreign?" (targ-ifjump-simp-s #f "FOREIGNP"))
(targ-op "##string?" (targ-ifjump-simp-s #f "STRINGP"))
(targ-op "##s8vector?" (targ-ifjump-simp-s #f "S8VECTORP"))
(targ-op "##u8vector?" (targ-ifjump-simp-s #f "U8VECTORP"))
(targ-op "##s16vector?" (targ-ifjump-simp-s #f "S16VECTORP"))
(targ-op "##u16vector?" (targ-ifjump-simp-s #f "U16VECTORP"))
(targ-op "##s32vector?" (targ-ifjump-simp-s #f "S32VECTORP"))
(targ-op "##u32vector?" (targ-ifjump-simp-s #f "U32VECTORP"))
(targ-op "##s64vector?" (targ-ifjump-simp-s #f "S64VECTORP"))
(targ-op "##u64vector?" (targ-ifjump-simp-s #f "U64VECTORP"))
(targ-op "##f32vector?" (targ-ifjump-simp-s #f "F32VECTORP"))
(targ-op "##f64vector?" (targ-ifjump-simp-s #f "F64VECTORP"))
(targ-op "##flonum?" (targ-ifjump-simp-s #f "FLONUMP"))
(targ-op "##bignum?" (targ-ifjump-simp-s #f "BIGNUMP"))
(targ-op "##char?" (targ-ifjump-simp-s #f "CHARP"))
(targ-op "##number?" (targ-ifjump-simp-s #f "NUMBERP"))
(targ-op "##complex?" (targ-ifjump-simp-s #f "COMPLEXP"))
;;the following primitives can't be inlined because they have
;;non-trivial definitions which depend on some configuration
;;information provided by lib/_num.scm:
;;(targ-op "##real?" (targ-ifjump-simp-s #f "REALP"))
;;(targ-op "##rational?" (targ-ifjump-simp-s #f "RATIONALP"))
;;(targ-op "##integer?" (targ-ifjump-simp-s #f "INTEGERP"))
;;(targ-op "##exact?" (targ-ifjump-simp-s #f "EXACTP"))
;;(targ-op "##inexact?" (targ-ifjump-simp-s #f "INEXACTP"))
;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
(targ-op "##fixnum.max" (targ-apply-fold-u #f #f "FIXPOS" "FIXMAX"))
(targ-op "##fixnum.min" (targ-apply-fold-u #f #f "FIXPOS" "FIXMIN"))
(targ-op "##fixnum.wrap+" (targ-apply-fold-u #f "FIX_0" "FIXPOS" "FIXADD"))
(targ-op "##fixnum.+" (targ-apply-fold-u #f "FIX_0" "FIXPOS" "FIXADD"))
(targ-op "##fixnum.+?" (targ-apply-fold-u #f "FIX_0" #f "FIXADDP"))
(targ-op "##fixnum.wrap*" (targ-apply-fold-u #f "FIX_1" "FIXPOS" "FIXMUL"))
(targ-op "##fixnum.*" (targ-apply-fold-u #f "FIX_1" "FIXPOS" "FIXMUL"))
(targ-op "##fixnum.*?" (targ-apply-fold-u #f "FIX_1" #f "FIXMULP"))
(targ-op "##fixnum.wrap-" (targ-apply-fold-u #f #f "FIXNEG" "FIXSUB"))
(targ-op "##fixnum.-" (targ-apply-fold-u #f #f "FIXNEG" "FIXSUB"))
(targ-op "##fixnum.-?" (targ-apply-fold-u #f #f "FIXNEGP""FIXSUBP"))
(targ-op "##fixnum.wrapquotient"(targ-apply-fold-u #f #f #f "FIXQUO"))
(targ-op "##fixnum.quotient" (targ-apply-fold-u #f #f #f "FIXQUO"))
(targ-op "##fixnum.remainder" (targ-apply-fold-u #f #f #f "FIXREM"))
(targ-op "##fixnum.modulo" (targ-apply-fold-u #f #f #f "FIXMOD"))
(targ-op "##fixnum.bitwise-ior"(targ-apply-fold-u #f "FIX_0" "FIXPOS" "FIXIOR"))
(targ-op "##fixnum.bitwise-xor"(targ-apply-fold-u #f "FIX_0" "FIXPOS" "FIXXOR"))
(targ-op "##fixnum.bitwise-and"(targ-apply-fold-u #f "FIX_M1" "FIXPOS" "FIXAND"))
(targ-op "##fixnum.bitwise-not"(targ-apply-simp-u #f #f "FIXNOT"))
(targ-op "##fixnum.wraparithmetic-shift" (targ-apply-simp-u #f #f "FIXASH"))
(targ-op "##fixnum.arithmetic-shift" (targ-apply-simp-u #f #f "FIXASH"))
(targ-op "##fixnum.arithmetic-shift?" (targ-apply-simp-u #f #f "FIXASHP"))
(targ-op "##fixnum.wraparithmetic-shift-left"(targ-apply-simp-u #f #f "FIXASHL"))
(targ-op "##fixnum.arithmetic-shift-left" (targ-apply-simp-u #f #f "FIXASHL"))
(targ-op "##fixnum.arithmetic-shift-left?" (targ-apply-simp-u #f #f "FIXASHLP"))
(targ-op "##fixnum.arithmetic-shift-right" (targ-apply-simp-u #f #f "FIXASHR"))
(targ-op "##fixnum.arithmetic-shift-right?" (targ-apply-simp-u #f #f "FIXASHRP"))
(targ-op "##fixnum.wraplogical-shift-right" (targ-apply-simp-u #f #f "FIXLSHR"))
(targ-op "##fixnum.wraplogical-shift-right?" (targ-apply-simp-u #f #f "FIXLSHRP"))
(targ-op "##fixnum.wrapabs" (targ-apply-simp-u #f #f "FIXABS"))
(targ-op "##fixnum.abs" (targ-apply-simp-u #f #f "FIXABS"))
(targ-op "##fixnum.abs?" (targ-apply-simp-u #f #f "FIXABSP"))
(targ-op "##fixnum.zero?" (targ-ifjump-simp-u #f "FIXZEROP"))
(targ-op "##fixnum.positive?" (targ-ifjump-simp-u #f "FIXPOSITIVEP"))
(targ-op "##fixnum.negative?" (targ-ifjump-simp-u #f "FIXNEGATIVEP"))
(targ-op "##fixnum.odd?" (targ-ifjump-simp-u #f "FIXODDP"))
(targ-op "##fixnum.even?" (targ-ifjump-simp-u #f "FIXEVENP"))
(targ-op "##fixnum.=" (targ-ifjump-fold-u #f "FIXEQ"))
(targ-op "##fixnum.<" (targ-ifjump-fold-u #f "FIXLT"))
(targ-op "##fixnum.>" (targ-ifjump-fold-u #f "FIXGT"))
(targ-op "##fixnum.<=" (targ-ifjump-fold-u #f "FIXLE"))
(targ-op "##fixnum.>=" (targ-ifjump-fold-u #f "FIXGE"))
(targ-op "##fixnum.->char" (targ-apply-simp-u #f #f "FIXTOCHR"))
(targ-op "##fixnum.<-char" (targ-apply-simp-u #f #f "FIXFROMCHR"))
;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
(targ-op "##flonum.->fixnum" (targ-apply-simp-u #t #f "F64TOFIX"))
(targ-op "##flonum.<-fixnum" (targ-apply-simpflo-u #f "F64FROMFIX"))
(targ-op "##flonum.max" (targ-apply-fold-u #t #f "F64POS" "F64MAX"))
(targ-op "##flonum.min" (targ-apply-fold-u #t #f "F64POS" "F64MIN"))
(targ-op "##flonum.+" (targ-apply-fold-u #t "F64_0" "F64POS" "F64ADD"))
(targ-op "##flonum.*" (targ-apply-fold-u #t "F64_1" "F64POS" "F64MUL"))
(targ-op "##flonum.-" (targ-apply-fold-u #t #f "F64NEG" "F64SUB"))
(targ-op "##flonum./" (targ-apply-fold-u #t #f "F64INV" "F64DIV"))
(targ-op "##flonum.abs" (targ-apply-simpflo-u #t "F64ABS"))
(targ-op "##flonum.floor" (targ-apply-simpflo-u #t "F64FLOOR"))
(targ-op "##flonum.ceiling" (targ-apply-simpflo-u #t "F64CEILING"))
(targ-op "##flonum.truncate" (targ-apply-simpflo-u #t "F64TRUNCATE"))
(targ-op "##flonum.round" (targ-apply-simpflo-u #t "F64ROUND"))
(targ-op "##flonum.exp" (targ-apply-simpflo-u #t "F64EXP"))
(targ-op "##flonum.log" (targ-apply-simpflo-u #t "F64LOG"))
(targ-op "##flonum.sin" (targ-apply-simpflo-u #t "F64SIN"))
(targ-op "##flonum.cos" (targ-apply-simpflo-u #t "F64COS"))
(targ-op "##flonum.tan" (targ-apply-simpflo-u #t "F64TAN"))
(targ-op "##flonum.asin" (targ-apply-simpflo-u #t "F64ASIN"))
(targ-op "##flonum.acos" (targ-apply-simpflo-u #t "F64ACOS"))
(targ-op "##flonum.atan" (targ-apply-simpflo2-u #t "F64ATAN" "F64ATAN2"))
(targ-op "##flonum.expt" (targ-apply-simpflo-u #t "F64EXPT"))
(targ-op "##flonum.sqrt" (targ-apply-simpflo-u #t "F64SQRT"))
(targ-op "##flonum.copysign" (targ-apply-simpflo-u #t "F64COPYSIGN"))
(targ-op "##flonum.integer?" (targ-ifjump-simp-u #t "F64INTEGERP"))
(targ-op "##flonum.zero?" (targ-ifjump-simp-u #t "F64ZEROP"))
(targ-op "##flonum.positive?" (targ-ifjump-simp-u #t "F64POSITIVEP"))
(targ-op "##flonum.negative?" (targ-ifjump-simp-u #t "F64NEGATIVEP"))
(targ-op "##flonum.odd?" (targ-ifjump-simp-u #t "F64ODDP"))
(targ-op "##flonum.even?" (targ-ifjump-simp-u #t "F64EVENP"))
(targ-op "##flonum.finite?" (targ-ifjump-simp-u #t "F64FINITEP"))
(targ-op "##flonum.infinite?" (targ-ifjump-simp-u #t "F64INFINITEP"))
(targ-op "##flonum.nan?" (targ-ifjump-simp-u #t "F64NANP"))
(targ-op "##flonum.<-fixnum-exact?" (targ-ifjump-simp-u #f "F64FROMFIXEXACTP"))
(targ-op "##flonum.=" (targ-ifjump-fold-u #t "F64EQ"))
(targ-op "##flonum.<" (targ-ifjump-fold-u #t "F64LT"))
(targ-op "##flonum.>" (targ-ifjump-fold-u #t "F64GT"))
(targ-op "##flonum.<=" (targ-ifjump-fold-u #t "F64LE"))
(targ-op "##flonum.>=" (targ-ifjump-fold-u #t "F64GE"))
;; new fixnum primitives
(targ-op "##fxmax" (targ-apply-fold-u #f #f "FIXPOS" "FIXMAX"))
(targ-op "##fxmin" (targ-apply-fold-u #f #f "FIXPOS" "FIXMIN"))
(targ-op "##fxwrap+" (targ-apply-fold-u #f "FIX_0" "FIXPOS" "FIXADD"))
(targ-op "##fx+" (targ-apply-fold-u #f "FIX_0" "FIXPOS" "FIXADD"))
(targ-op "##fx+?" (targ-apply-fold-u #f "FIX_0" #f "FIXADDP"))
(targ-op "##fxwrap*" (targ-apply-fold-u #f "FIX_1" "FIXPOS" "FIXMUL"))
(targ-op "##fx*" (targ-apply-fold-u #f "FIX_1" "FIXPOS" "FIXMUL"))
(targ-op "##fx*?" (targ-apply-fold-u #f "FIX_1" #f "FIXMULP"))
(targ-op "##fxwrap-" (targ-apply-fold-u #f #f "FIXNEG" "FIXSUB"))
(targ-op "##fx-" (targ-apply-fold-u #f #f "FIXNEG" "FIXSUB"))
(targ-op "##fx-?" (targ-apply-fold-u #f #f "FIXNEGP""FIXSUBP"))
(targ-op "##fxwrapquotient" (targ-apply-fold-u #f #f #f "FIXQUO"))
(targ-op "##fxquotient" (targ-apply-fold-u #f #f #f "FIXQUO"))
(targ-op "##fxremainder" (targ-apply-fold-u #f #f #f "FIXREM"))
(targ-op "##fxmodulo" (targ-apply-fold-u #f #f #f "FIXMOD"))
(targ-op "##fxnot" (targ-apply-simp-u #f #f "FIXNOT"))
(targ-op "##fxand" (targ-apply-fold-u #f "FIX_M1" "FIXPOS" "FIXAND"))
(targ-op "##fxior" (targ-apply-fold-u #f "FIX_0" "FIXPOS" "FIXIOR"))
(targ-op "##fxxor" (targ-apply-fold-u #f "FIX_0" "FIXPOS" "FIXXOR"))
(targ-op "##fxif" (targ-apply-simp-u #f #f "FIXIF"))
(targ-op "##fxbit-count" (targ-apply-simp-u #f #f "FIXBITCOUNT"))
(targ-op "##fxlength" (targ-apply-simp-u #f #f "FIXLENGTH"))
(targ-op "##fxfirst-bit-set"(targ-apply-simp-u #f #f "FIXFIRSTBITSET"))
(targ-op "##fxbit-set?" (targ-ifjump-simp-u #f "FIXBITSETP"))
(targ-op "##fxwraparithmetic-shift" (targ-apply-simp-u #f #f "FIXASH"))
(targ-op "##fxarithmetic-shift" (targ-apply-simp-u #f #f "FIXASH"))
(targ-op "##fxarithmetic-shift?" (targ-apply-simp-u #f #f "FIXASHP"))
(targ-op "##fxwraparithmetic-shift-left"(targ-apply-simp-u #f #f "FIXASHL"))
(targ-op "##fxarithmetic-shift-left" (targ-apply-simp-u #f #f "FIXASHL"))
(targ-op "##fxarithmetic-shift-left?" (targ-apply-simp-u #f #f "FIXASHLP"))
(targ-op "##fxarithmetic-shift-right" (targ-apply-simp-u #f #f "FIXASHR"))
(targ-op "##fxarithmetic-shift-right?" (targ-apply-simp-u #f #f "FIXASHRP"))
(targ-op "##fxwraplogical-shift-right" (targ-apply-simp-u #f #f "FIXLSHR"))
(targ-op "##fxwraplogical-shift-right?" (targ-apply-simp-u #f #f "FIXLSHRP"))
(targ-op "##fxwrapabs" (targ-apply-simp-u #f #f "FIXABS"))
(targ-op "##fxabs" (targ-apply-simp-u #f #f "FIXABS"))
(targ-op "##fxabs?" (targ-apply-simp-u #f #f "FIXABSP"))
(targ-op "##fxzero?" (targ-ifjump-simp-u #f "FIXZEROP"))
(targ-op "##fxpositive?" (targ-ifjump-simp-u #f "FIXPOSITIVEP"))
(targ-op "##fxnegative?" (targ-ifjump-simp-u #f "FIXNEGATIVEP"))
(targ-op "##fxodd?" (targ-ifjump-simp-u #f "FIXODDP"))
(targ-op "##fxeven?" (targ-ifjump-simp-u #f "FIXEVENP"))
(targ-op "##fx=" (targ-ifjump-fold-u #f "FIXEQ"))
(targ-op "##fx<" (targ-ifjump-fold-u #f "FIXLT"))
(targ-op "##fx>" (targ-ifjump-fold-u #f "FIXGT"))
(targ-op "##fx<=" (targ-ifjump-fold-u #f "FIXLE"))
(targ-op "##fx>=" (targ-ifjump-fold-u #f "FIXGE"))
(targ-op "##fx->char" (targ-apply-simp-u #f #f "FIXTOCHR"))
(targ-op "##fx<-char" (targ-apply-simp-u #f #f "FIXFROMCHR"))
(targ-op "##fixnum->char" (targ-apply-simp-u #f #f "FIXTOCHR"))
(targ-op "##char->fixnum" (targ-apply-simp-u #f #f "FIXFROMCHR"))
(targ-op "##flonum->fixnum" (targ-apply-simp-u #t #f "F64TOFIX"))
(targ-op "##fixnum->flonum" (targ-apply-simpflo-u #f "F64FROMFIX"))
(targ-op "##fixnum->flonum-exact?" (targ-ifjump-simp-u #f "F64FROMFIXEXACTP"))
;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;; new flonum primitives
(targ-op "##fl->fx" (targ-apply-simp-u #t #f "F64TOFIX"))
(targ-op "##fl<-fx" (targ-apply-simpflo-u #f "F64FROMFIX"))
(targ-op "##flmax" (targ-apply-fold-u #t #f "F64POS" "F64MAX"))
(targ-op "##flmin" (targ-apply-fold-u #t #f "F64POS" "F64MIN"))
(targ-op "##fl+" (targ-apply-fold-u #t "F64_0" "F64POS" "F64ADD"))
(targ-op "##fl*" (targ-apply-fold-u #t "F64_1" "F64POS" "F64MUL"))
(targ-op "##fl-" (targ-apply-fold-u #t #f "F64NEG" "F64SUB"))
(targ-op "##fl/" (targ-apply-fold-u #t #f "F64INV" "F64DIV"))
(targ-op "##flabs" (targ-apply-simpflo-u #t "F64ABS"))
(targ-op "##flfloor" (targ-apply-simpflo-u #t "F64FLOOR"))
(targ-op "##flceiling" (targ-apply-simpflo-u #t "F64CEILING"))
(targ-op "##fltruncate" (targ-apply-simpflo-u #t "F64TRUNCATE"))
(targ-op "##flround" (targ-apply-simpflo-u #t "F64ROUND"))
(targ-op "##flexp" (targ-apply-simpflo-u #t "F64EXP"))
(targ-op "##fllog" (targ-apply-simpflo-u #t "F64LOG"))
(targ-op "##flsin" (targ-apply-simpflo-u #t "F64SIN"))
(targ-op "##flcos" (targ-apply-simpflo-u #t "F64COS"))
(targ-op "##fltan" (targ-apply-simpflo-u #t "F64TAN"))
(targ-op "##flasin" (targ-apply-simpflo-u #t "F64ASIN"))
(targ-op "##flacos" (targ-apply-simpflo-u #t "F64ACOS"))
(targ-op "##flatan" (targ-apply-simpflo2-u #t "F64ATAN" "F64ATAN2"))
(targ-op "##flexpt" (targ-apply-simpflo-u #t "F64EXPT"))
(targ-op "##flsqrt" (targ-apply-simpflo-u #t "F64SQRT"))
(targ-op "##flcopysign" (targ-apply-simpflo-u #t "F64COPYSIGN"))
(targ-op "##flinteger?" (targ-ifjump-simp-u #t "F64INTEGERP"))
(targ-op "##flzero?" (targ-ifjump-simp-u #t "F64ZEROP"))
(targ-op "##flpositive?" (targ-ifjump-simp-u #t "F64POSITIVEP"))
(targ-op "##flnegative?" (targ-ifjump-simp-u #t "F64NEGATIVEP"))
(targ-op "##flodd?" (targ-ifjump-simp-u #t "F64ODDP"))
(targ-op "##fleven?" (targ-ifjump-simp-u #t "F64EVENP"))
(targ-op "##flfinite?" (targ-ifjump-simp-u #t "F64FINITEP"))
(targ-op "##flinfinite?" (targ-ifjump-simp-u #t "F64INFINITEP"))
(targ-op "##flnan?" (targ-ifjump-simp-u #t "F64NANP"))
(targ-op "##fl<-fx-exact?" (targ-ifjump-simp-u #f "F64FROMFIXEXACTP"))
(targ-op "##fl=" (targ-ifjump-fold-u #t "F64EQ"))
(targ-op "##fl<" (targ-ifjump-fold-u #t "F64LT"))
(targ-op "##fl>" (targ-ifjump-fold-u #t "F64GT"))
(targ-op "##fl<=" (targ-ifjump-fold-u #t "F64LE"))
(targ-op "##fl>=" (targ-ifjump-fold-u #t "F64GE"))
;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
(targ-op "##char=?" (targ-ifjump-fold-u #f "CHAREQP"))
(targ-op "##char<?" (targ-ifjump-fold-u #f "CHARLTP"))
(targ-op "##char>?" (targ-ifjump-fold-u #f "CHARGTP"))
(targ-op "##char<=?" (targ-ifjump-fold-u #f "CHARLEP"))
(targ-op "##char>=?" (targ-ifjump-fold-u #f "CHARGEP"))
(targ-op "##char-alphabetic?" (targ-ifjump-simp-u #f "CHARALPHABETICP"))
(targ-op "##char-numeric?" (targ-ifjump-simp-u #f "CHARNUMERICP"))
(targ-op "##char-whitespace?" (targ-ifjump-simp-u #f "CHARWHITESPACEP"))
(targ-op "##char-upper-case?" (targ-ifjump-simp-u #f "CHARUPPERCASEP"))
(targ-op "##char-lower-case?" (targ-ifjump-simp-u #f "CHARLOWERCASEP"))
(targ-op "##char-upcase" (targ-apply-simp-u #f #f "CHARUPCASE"))
(targ-op "##char-downcase" (targ-apply-simp-u #f #f "CHARDOWNCASE"))
;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
(targ-op "##cons" (targ-apply-cons))
(targ-op "##set-car!" (targ-apply-simp-u #f #t "SETCAR"))
(targ-op "##set-cdr!" (targ-apply-simp-u #f #t "SETCDR"))
(targ-op "##car" (targ-ifjump-apply-u "CAR"))
(targ-op "##cdr" (targ-ifjump-apply-u "CDR"))
(targ-op "##caar" (targ-ifjump-apply-u "CAAR"))
(targ-op "##cadr" (targ-ifjump-apply-u "CADR"))
(targ-op "##cdar" (targ-ifjump-apply-u "CDAR"))
(targ-op "##cddr" (targ-ifjump-apply-u "CDDR"))
(targ-op "##caaar" (targ-ifjump-apply-u "CAAAR"))
(targ-op "##caadr" (targ-ifjump-apply-u "CAADR"))
(targ-op "##cadar" (targ-ifjump-apply-u "CADAR"))
(targ-op "##caddr" (targ-ifjump-apply-u "CADDR"))
(targ-op "##cdaar" (targ-ifjump-apply-u "CDAAR"))
(targ-op "##cdadr" (targ-ifjump-apply-u "CDADR"))
(targ-op "##cddar" (targ-ifjump-apply-u "CDDAR"))
(targ-op "##cdddr" (targ-ifjump-apply-u "CDDDR"))
(targ-op "##caaaar" (targ-ifjump-apply-u "CAAAAR"))
(targ-op "##caaadr" (targ-ifjump-apply-u "CAAADR"))
(targ-op "##caadar" (targ-ifjump-apply-u "CAADAR"))
(targ-op "##caaddr" (targ-ifjump-apply-u "CAADDR"))
(targ-op "##cadaar" (targ-ifjump-apply-u "CADAAR"))
(targ-op "##cadadr" (targ-ifjump-apply-u "CADADR"))
(targ-op "##caddar" (targ-ifjump-apply-u "CADDAR"))
(targ-op "##cadddr" (targ-ifjump-apply-u "CADDDR"))
(targ-op "##cdaaar" (targ-ifjump-apply-u "CDAAAR"))
(targ-op "##cdaadr" (targ-ifjump-apply-u "CDAADR"))
(targ-op "##cdadar" (targ-ifjump-apply-u "CDADAR"))
(targ-op "##cdaddr" (targ-ifjump-apply-u "CDADDR"))
(targ-op "##cddaar" (targ-ifjump-apply-u "CDDAAR"))
(targ-op "##cddadr" (targ-ifjump-apply-u "CDDADR"))
(targ-op "##cdddar" (targ-ifjump-apply-u "CDDDAR"))
(targ-op "##cddddr" (targ-ifjump-apply-u "CDDDDR"))
(targ-op "##list" (targ-apply-list))
;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
(targ-op "##quasi-list" (targ-apply-list))
(targ-op "##quasi-cons" (targ-apply-cons))
(targ-op "##quasi-vector" (targ-apply-vector-s 'vector))
;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
(targ-op "##box" (targ-apply-box))
(targ-op "##unbox" (targ-ifjump-apply-u "UNBOX"))
(targ-op "##set-box!" (targ-apply-simp-u #f #t "SETBOX"))
;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
(targ-op "##make-will" (targ-apply-make-will))
(targ-op "##will-testator" (targ-ifjump-apply-u "WILLTESTATOR"))
;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
(targ-op "##gc-hash-table-ref" (targ-apply-simp-u #f #f "GCHASHTABLEREF"))
(targ-op "##gc-hash-table-set!" (targ-apply-simp-u #f #f "GCHASHTABLESET"))
(targ-op "##gc-hash-table-rehash!" (targ-apply-simp-u #f #f "GCHASHTABLEREHASH"))
;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
(targ-op "##values" (targ-apply-vector-s 'values))
;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
(targ-op "##string" (targ-apply-vector-u 'string))
(targ-op "##string-length" (targ-apply-simp-u #f #f "STRINGLENGTH"))
(targ-op "##string-ref" (targ-apply-simp-u #f #f "STRINGREF"))
(targ-op "##string-set!" (targ-apply-simp-u #f #t "STRINGSET"))
(targ-op "##string-shrink!" (targ-apply-simp-u #f #t "STRINGSHRINK"))
;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
(targ-op "##vector" (targ-apply-vector-s 'vector))
(targ-op "##vector-length" (targ-apply-simp-u #f #f "VECTORLENGTH"))
(targ-op "##vector-ref" (targ-ifjump-apply-u "VECTORREF"))
(targ-op "##vector-set!" (targ-apply-simp-u #f #t "VECTORSET"))
(targ-op "##vector-shrink!" (targ-apply-simp-u #f #t "VECTORSHRINK"))
;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
(targ-op "##s8vector" (targ-apply-vector-u 's8vector))
(targ-op "##s8vector-length" (targ-apply-simp-u #f #f "S8VECTORLENGTH"))
(targ-op "##s8vector-ref" (targ-apply-simp-u #f #f "S8VECTORREF"))
(targ-op "##s8vector-set!" (targ-apply-simp-u #f #t "S8VECTORSET"))
(targ-op "##s8vector-shrink!" (targ-apply-simp-u #f #t "S8VECTORSHRINK"))
(targ-op "##u8vector" (targ-apply-vector-u 'u8vector))
(targ-op "##u8vector-length" (targ-apply-simp-u #f #f "U8VECTORLENGTH"))
(targ-op "##u8vector-ref" (targ-apply-simp-u #f #f "U8VECTORREF"))
(targ-op "##u8vector-set!" (targ-apply-simp-u #f #t "U8VECTORSET"))
(targ-op "##u8vector-shrink!" (targ-apply-simp-u #f #t "U8VECTORSHRINK"))
(targ-op "##s16vector" (targ-apply-vector-u 's16vector))
(targ-op "##s16vector-length" (targ-apply-simp-u #f #f "S16VECTORLENGTH"))
(targ-op "##s16vector-ref" (targ-apply-simp-u #f #f "S16VECTORREF"))
(targ-op "##s16vector-set!" (targ-apply-simp-u #f #t "S16VECTORSET"))
(targ-op "##s16vector-shrink!"(targ-apply-simp-u #f #t "S16VECTORSHRINK"))
(targ-op "##u16vector" (targ-apply-vector-u 'u16vector))
(targ-op "##u16vector-length" (targ-apply-simp-u #f #f "U16VECTORLENGTH"))
(targ-op "##u16vector-ref" (targ-apply-simp-u #f #f "U16VECTORREF"))
(targ-op "##u16vector-set!" (targ-apply-simp-u #f #t "U16VECTORSET"))
(targ-op "##u16vector-shrink!"(targ-apply-simp-u #f #t "U16VECTORSHRINK"))
(targ-op "##s32vector" (targ-apply-vector-u 's32vector))
(targ-op "##s32vector-length" (targ-apply-simp-u #f #f "S32VECTORLENGTH"))
(targ-op "##s32vector-ref" (targ-apply-simpbig-u "S32VECTORREF"))
(targ-op "##s32vector-set!" (targ-apply-simp-u #f #t "S32VECTORSET"))
(targ-op "##s32vector-shrink!"(targ-apply-simp-u #f #t "S32VECTORSHRINK"))
(targ-op "##u32vector" (targ-apply-vector-u 'u32vector))
(targ-op "##u32vector-length" (targ-apply-simp-u #f #f "U32VECTORLENGTH"))
(targ-op "##u32vector-ref" (targ-apply-simpbig-u "U32VECTORREF"))
(targ-op "##u32vector-set!" (targ-apply-simp-u #f #t "U32VECTORSET"))
(targ-op "##u32vector-shrink!"(targ-apply-simp-u #f #t "U32VECTORSHRINK"))
(targ-op "##s64vector" (targ-apply-vector-u 's64vector))
(targ-op "##s64vector-length" (targ-apply-simp-u #f #f "S64VECTORLENGTH"))
(targ-op "##s64vector-ref" (targ-apply-simpbig-u "S64VECTORREF"))
(targ-op "##s64vector-set!" (targ-apply-simp-u #f #t "S64VECTORSET"))
(targ-op "##s64vector-shrink!"(targ-apply-simp-u #f #t "S64VECTORSHRINK"))
(targ-op "##u64vector" (targ-apply-vector-u 'u64vector))
(targ-op "##u64vector-length" (targ-apply-simp-u #f #f "U64VECTORLENGTH"))
(targ-op "##u64vector-ref" (targ-apply-simpbig-u "U64VECTORREF"))
(targ-op "##u64vector-set!" (targ-apply-simp-u #f #t "U64VECTORSET"))
(targ-op "##u64vector-shrink!"(targ-apply-simp-u #f #t "U64VECTORSHRINK"))
(targ-op "##f32vector" (targ-apply-vector-u 'f32vector))
(targ-op "##f32vector-length" (targ-apply-simp-u #f #f "F32VECTORLENGTH"))
(targ-op "##f32vector-ref" (targ-apply-simpflo-u #f "F32VECTORREF"))
(targ-op "##f32vector-set!" (targ-apply-simpflo3-u "F32VECTORSET"))
(targ-op "##f32vector-shrink!"(targ-apply-simp-u #f #t "F32VECTORSHRINK"))
(targ-op "##f64vector" (targ-apply-vector-u 'f64vector))
(targ-op "##f64vector-length" (targ-apply-simp-u #f #f "F64VECTORLENGTH"))
(targ-op "##f64vector-ref" (targ-apply-simpflo-u #f "F64VECTORREF"))