reduce copied code among back ends
All back ends had essentially the same `define-instruction`, just with slightly more functionality, checking, or abstraction each case. The newly shared version better sorts out some inherent run-time checks versus safe-mode assertions related to fp and non-fp arguments. original commit: c70836fa04eb33442fd3ca273ce9ca08ce877fec
This commit is contained in:
Matthew Flatt
parent
7e3417aa8c
commit
e9d01f1e4d
261
s/arm32.ss
261
s/arm32.ss
|
|
@ -109,39 +109,13 @@
|
|||
))
|
||||
|
||||
;;; SECTION 2: instructions
|
||||
(module (md-handle-jump) ; also sets primitive handlers
|
||||
(module (md-handle-jump ; also sets primitive handlers
|
||||
mem->mem
|
||||
fpmem->fpmem
|
||||
coercible?
|
||||
coerce-opnd)
|
||||
(import asm-module)
|
||||
|
||||
(define-syntax seq
|
||||
(lambda (x)
|
||||
(syntax-case x ()
|
||||
[(_ e ... ex)
|
||||
(with-syntax ([(t ...) (generate-temporaries #'(e ...))])
|
||||
#'(let ([t e] ...)
|
||||
(with-values ex
|
||||
(case-lambda
|
||||
[(x*) (cons* t ... x*)]
|
||||
[(x* p) (values (cons* t ... x*) p)]))))])))
|
||||
|
||||
; don't bother with literal@? check since lvalues can't be literals
|
||||
(define lmem? mref?)
|
||||
|
||||
(define mem?
|
||||
(lambda (x)
|
||||
(or (lmem? x) (literal@? x))))
|
||||
|
||||
(define fpmem?
|
||||
(lambda (x)
|
||||
(nanopass-case (L15c Triv) x
|
||||
[(mref ,lvalue0 ,lvalue1 ,imm ,type) (eq? type 'fp)]
|
||||
[else #f])))
|
||||
|
||||
(define-syntax mem-of-type?
|
||||
(lambda (stx)
|
||||
(syntax-case stx (mem fpmem)
|
||||
[(_ mem e) #'(lmem? e)]
|
||||
[(_ fpmem e) #'(fpmem? e)])))
|
||||
|
||||
(define imm-funky12?
|
||||
(lambda (x)
|
||||
(nanopass-case (L15c Triv) x
|
||||
|
|
@ -206,15 +180,6 @@
|
|||
[(immediate ,imm) `(immediate ,(lognot imm))]
|
||||
[else (sorry! who "~s is not an immediate" ir)]))
|
||||
|
||||
(define lvalue->ur
|
||||
(lambda (x k)
|
||||
(if (mref? x)
|
||||
(let ([u (make-tmp 'u)])
|
||||
(seq
|
||||
(set-ur=mref u x)
|
||||
(k u)))
|
||||
(k x))))
|
||||
|
||||
(define mref->mref
|
||||
(lambda (a k)
|
||||
(define return
|
||||
|
|
@ -294,17 +259,13 @@
|
|||
[else
|
||||
(return x0 %zero imm)])))))])))
|
||||
|
||||
(define mem->fpmem
|
||||
(lambda (a k)
|
||||
(fpmem->fpmem a k)))
|
||||
|
||||
;; `define-instruction` code takes care of `ur` and `fpur`, to which
|
||||
;; all type-compatible values must convert
|
||||
(define-syntax coercible?
|
||||
(syntax-rules ()
|
||||
[(_ ?a ?aty*)
|
||||
(let ([a ?a] [aty* ?aty*])
|
||||
(or (and (memq 'ur aty*) (not (or (fpmem? a) (fpur? a))))
|
||||
(and (memq 'fpur aty*) (or (fpmem? a) (fpur? a)))
|
||||
(and (memq 'funky12 aty*) (imm-funky12? a))
|
||||
(or (and (memq 'funky12 aty*) (imm-funky12? a))
|
||||
(and (memq 'negate-funky12 aty*) (imm-negate-funky12? a))
|
||||
(and (memq 'lognot-funky12 aty*) (imm-lognot-funky12? a))
|
||||
(and (memq 'shift-count aty*) (imm-shift-count? a))
|
||||
|
|
@ -315,6 +276,7 @@
|
|||
(and (memq 'mem aty*) (mem? a))
|
||||
(and (memq 'fpmem aty*) (fpmem? a))))]))
|
||||
|
||||
;; `define-instruction` doesn't try to cover `ur` and `fpur`
|
||||
(define-syntax coerce-opnd ; passes k something compatible with aty*
|
||||
(syntax-rules ()
|
||||
[(_ ?a ?aty* ?k)
|
||||
|
|
@ -360,12 +322,6 @@
|
|||
(sorry! 'coerce-opnd "unexpected operand ~s" a)])]
|
||||
[else (sorry! 'coerce-opnd "cannot coerce ~s to ~s" a aty*)]))]))
|
||||
|
||||
(define set-ur=mref
|
||||
(lambda (ur mref)
|
||||
(mref->mref mref
|
||||
(lambda (mref)
|
||||
(build-set! ,ur ,mref)))))
|
||||
|
||||
(define md-handle-jump
|
||||
(lambda (t)
|
||||
(with-output-language (L15d Tail)
|
||||
|
|
@ -390,157 +346,6 @@
|
|||
(values '() `(jump (label-ref ,l ,offset)))]
|
||||
[else (long-form t)]))))
|
||||
|
||||
(define-syntax define-instruction
|
||||
(lambda (x)
|
||||
(define make-value-clause
|
||||
(lambda (fmt)
|
||||
(syntax-case fmt (mem fpmem ur fpur)
|
||||
[(op (c mem) (a ur))
|
||||
#`(lambda (c a)
|
||||
(if (lmem? c)
|
||||
(coerce-opnd a '(ur)
|
||||
(lambda (a)
|
||||
(mem->mem c
|
||||
(lambda (c)
|
||||
(rhs c a)))))
|
||||
(next c a)))]
|
||||
[(op (c fpmem) (a aty ...) ...)
|
||||
#`(lambda (c a ...)
|
||||
(if (and (fpmem? c) (coercible? a '(aty ...)) ...)
|
||||
#,(let f ([a* #'(a ...)] [aty** #'((aty ...) ...)])
|
||||
(cond
|
||||
[(null? a*)
|
||||
#'(fpmem->fpmem c
|
||||
(lambda (c)
|
||||
(rhs c a ...)))]
|
||||
[else
|
||||
#`(coerce-opnd #,(car a*) '#,(car aty**)
|
||||
(lambda (#,(car a*))
|
||||
#,(f (cdr a*) (cdr aty**))))]))
|
||||
(next c a ...)))]
|
||||
[(op (c ur) (a aty ...) ...)
|
||||
#`(lambda (c a ...)
|
||||
(if (and (coercible? a '(aty ...)) ...)
|
||||
#,(let f ([a* #'(a ...)] [aty** #'((aty ...) ...)])
|
||||
(if (null? a*)
|
||||
#'(if (ur? c)
|
||||
(rhs c a ...)
|
||||
(let ([u (make-tmp 'u)])
|
||||
(seq
|
||||
(rhs u a ...)
|
||||
(mref->mref c
|
||||
(lambda (c)
|
||||
(build-set! ,c ,u))))))
|
||||
#`(coerce-opnd #,(car a*) '#,(car aty**)
|
||||
(lambda (#,(car a*)) #,(f (cdr a*) (cdr aty**))))))
|
||||
(next c a ...)))]
|
||||
[(op (c fpur) (a aty ...) ...)
|
||||
#`(lambda (c a ...)
|
||||
(if (and (coercible? a '(aty ...)) ...)
|
||||
#,(let f ([a* #'(a ...)] [aty** #'((aty ...) ...)])
|
||||
(if (null? a*)
|
||||
#'(if (fpur? c)
|
||||
(rhs c a ...)
|
||||
(let ([u (make-tmp 'u 'fp)])
|
||||
(seq
|
||||
(rhs u a ...)
|
||||
(fpmem->fpmem c
|
||||
(lambda (c)
|
||||
(build-set! ,c ,u))))))
|
||||
#`(coerce-opnd #,(car a*) '#,(car aty**)
|
||||
(lambda (#,(car a*)) #,(f (cdr a*) (cdr aty**))))))
|
||||
(next c a ...)))])))
|
||||
|
||||
(define-who make-pred-clause
|
||||
(lambda (fmt)
|
||||
(syntax-case fmt ()
|
||||
[(op (a aty ...) ...)
|
||||
#`(lambda (a ...)
|
||||
(if (and (coercible? a '(aty ...)) ...)
|
||||
#,(let f ([a* #'(a ...)] [aty** #'((aty ...) ...)])
|
||||
(if (null? a*)
|
||||
#'(rhs a ...)
|
||||
#`(coerce-opnd #,(car a*) '#,(car aty**)
|
||||
(lambda (#,(car a*)) #,(f (cdr a*) (cdr aty**))))))
|
||||
(next a ...)))])))
|
||||
|
||||
(define-who make-effect-clause
|
||||
(lambda (fmt)
|
||||
(syntax-case fmt ()
|
||||
[(op (a aty ...) ...)
|
||||
#`(lambda (a ...)
|
||||
(if (and (coercible? a '(aty ...)) ...)
|
||||
#,(let f ([a* #'(a ...)] [aty** #'((aty ...) ...)])
|
||||
(if (null? a*)
|
||||
#'(rhs a ...)
|
||||
#`(coerce-opnd #,(car a*) '#,(car aty**)
|
||||
(lambda (#,(car a*)) #,(f (cdr a*) (cdr aty**))))))
|
||||
(next a ...)))])))
|
||||
|
||||
(syntax-case x (definitions)
|
||||
[(k context (sym ...) (definitions defn ...) [(op (a aty ...) ...) ?rhs0 ?rhs1 ...] ...)
|
||||
; potentially unnecessary level of checking, but the big thing is to make sure
|
||||
; the number of operands expected is the same on every clause of define-intruction
|
||||
(and (not (null? #'(op ...)))
|
||||
(andmap identifier? #'(sym ...))
|
||||
(andmap identifier? #'(op ...))
|
||||
(andmap identifier? #'(a ... ...))
|
||||
(andmap identifier? #'(aty ... ... ...)))
|
||||
(with-implicit (k info return with-output-language)
|
||||
(with-syntax ([((opnd* ...) . ignore) #'((a ...) ...)])
|
||||
(define make-proc
|
||||
(lambda (make-clause)
|
||||
(let f ([op* #'(op ...)]
|
||||
[fmt* #'((op (a aty ...) ...) ...)]
|
||||
[arg* #'((a ...) ...)]
|
||||
[rhs* #'((?rhs0 ?rhs1 ...) ...)])
|
||||
(if (null? op*)
|
||||
#'(lambda (opnd* ...)
|
||||
(sorry! name "no match found for ~s" (list opnd* ...)))
|
||||
#`(let ([next #,(f (cdr op*) (cdr fmt*) (cdr arg*) (cdr rhs*))]
|
||||
[rhs (lambda #,(car arg*)
|
||||
(let ([#,(car op*) name])
|
||||
#,@(car rhs*)))])
|
||||
#,(make-clause (car fmt*)))))))
|
||||
(unless (let ([a** #'((a ...) ...)])
|
||||
(let* ([a* (car a**)] [len (length a*)])
|
||||
(andmap (lambda (a*) (fx= (length a*) len)) (cdr a**))))
|
||||
(syntax-error x "mismatched instruction arities"))
|
||||
(cond
|
||||
[(free-identifier=? #'context #'value)
|
||||
#`(let ([fvalue (lambda (name)
|
||||
(lambda (info opnd* ...)
|
||||
defn ...
|
||||
(with-output-language (L15d Effect)
|
||||
(#,(make-proc make-value-clause) opnd* ...))))])
|
||||
(begin
|
||||
(safe-assert (eq? (primitive-type (%primitive sym)) 'value))
|
||||
(primitive-handler-set! (%primitive sym) (fvalue 'sym)))
|
||||
...)]
|
||||
[(free-identifier=? #'context #'pred)
|
||||
#`(let ([fpred (lambda (name)
|
||||
(lambda (info opnd* ...)
|
||||
defn ...
|
||||
(with-output-language (L15d Pred)
|
||||
(#,(make-proc make-pred-clause) opnd* ...))))])
|
||||
(begin
|
||||
(safe-assert (eq? (primitive-type (%primitive sym)) 'pred))
|
||||
(primitive-handler-set! (%primitive sym) (fpred 'sym)))
|
||||
...)]
|
||||
[(free-identifier=? #'context #'effect)
|
||||
#`(let ([feffect (lambda (name)
|
||||
(lambda (info opnd* ...)
|
||||
defn ...
|
||||
(with-output-language (L15d Effect)
|
||||
(#,(make-proc make-effect-clause) opnd* ...))))])
|
||||
(begin
|
||||
(safe-assert (eq? (primitive-type (%primitive sym)) 'effect))
|
||||
(primitive-handler-set! (%primitive sym) (feffect 'sym)))
|
||||
...)]
|
||||
[else (syntax-error #'context "unrecognized context")])))]
|
||||
[(k context (sym ...) cl ...) #'(k context (sym ...) (definitions) cl ...)]
|
||||
[(k context sym cl ...) (identifier? #'sym) #'(k context (sym) (definitions) cl ...)])))
|
||||
|
||||
(define info-cc-eq (make-info-condition-code 'eq? #f #t))
|
||||
(define asm-eq (asm-relop info-cc-eq))
|
||||
|
||||
|
|
@ -1037,8 +842,7 @@
|
|||
asm-pop-multiple asm-shiftop asm-logand asm-lognot
|
||||
asm-logtest asm-fp-relop asm-relop asm-push-multiple asm-vpush-multiple asm-vpop-multiple
|
||||
asm-indirect-jump asm-literal-jump
|
||||
asm-direct-jump asm-return-address asm-jump asm-conditional-jump asm-data-label
|
||||
asm-rp-header asm-rp-compact-header
|
||||
asm-direct-jump asm-return-address asm-jump asm-conditional-jump
|
||||
asm-indirect-call asm-condition-code
|
||||
asm-fpmove-single asm-fl-cvt asm-fpt asm-fpmove asm-fpcastto asm-fpcastfrom asm-fptrunc
|
||||
asm-lock asm-lock+/- asm-cas asm-fence
|
||||
|
|
@ -2473,11 +2277,6 @@
|
|||
[(fp<=) (i? (r? blt bhi) (r? bge bls))]
|
||||
[(fp=) (i? bne beq)]))))))
|
||||
|
||||
(define asm-data-label
|
||||
(lambda (code* l offset func code-size)
|
||||
(let ([rel (make-funcrel 'abs l offset)])
|
||||
(cons* rel (aop-cons* `(asm "mrv point:" ,rel) code*)))))
|
||||
|
||||
(define asm-helper-jump
|
||||
(lambda (code* reloc)
|
||||
; NB: kills %ts, unbeknownst to the instruction scheduler
|
||||
|
|
@ -2518,46 +2317,6 @@
|
|||
(lambda (code* reloc)
|
||||
(cons* reloc (aop-cons* `(asm "relocation:" ,reloc) code*))))
|
||||
|
||||
(define asm-rp-header
|
||||
(let ([mrv-error `(abs ,(constant code-data-disp)
|
||||
(library-code ,(lookup-libspec values-error)))])
|
||||
(lambda (code* mrvl fs lpm func code-size)
|
||||
(let* ([code* (cons* `(long . ,fs)
|
||||
(aop-cons* `(asm "frame size:" ,fs)
|
||||
code*))]
|
||||
[code* (cons* (if (target-fixnum? lpm)
|
||||
`(long . ,(fix lpm))
|
||||
`(abs 0 (object ,lpm)))
|
||||
(aop-cons* `(asm livemask: ,(format "~b" lpm))
|
||||
code*))]
|
||||
[code* (if mrvl
|
||||
(asm-data-label code* mrvl 0 func code-size)
|
||||
(cons*
|
||||
mrv-error
|
||||
(aop-cons* `(asm "mrv point:" ,mrv-error)
|
||||
code*)))]
|
||||
[code* (cons*
|
||||
'(code-top-link)
|
||||
(aop-cons* `(asm code-top-link)
|
||||
code*))])
|
||||
code*))))
|
||||
|
||||
(define asm-rp-compact-header
|
||||
(lambda (code* err? fs lpm func code-size)
|
||||
(let* ([code* (cons* `(long . ,(fxior (constant compact-header-mask)
|
||||
(if err?
|
||||
(constant compact-header-values-error-mask)
|
||||
0)
|
||||
(fxsll fs (constant compact-frame-words-offset))
|
||||
(fxsll lpm (constant compact-frame-mask-offset))))
|
||||
(aop-cons* `(asm "mrv pt:" (,lpm ,fs ,(if err? 'error 'continue)))
|
||||
code*))]
|
||||
[code* (cons*
|
||||
'(code-top-link)
|
||||
(aop-cons* `(asm code-top-link)
|
||||
code*))])
|
||||
code*)))
|
||||
|
||||
; NB: reads from %lr...should be okay if declare-intrinsics sets up return-live* properly
|
||||
(define asm-return (lambda () (emit bx (cons 'reg %lr) '())))
|
||||
|
||||
|
|
|
|||
268
s/arm64.ss
268
s/arm64.ss
|
|
@ -57,33 +57,13 @@
|
|||
))
|
||||
|
||||
;;; SECTION 2: instructions
|
||||
(module (md-handle-jump) ; also sets primitive handlers
|
||||
(module (md-handle-jump ; also sets primitive handlers
|
||||
mem->mem
|
||||
fpmem->fpmem
|
||||
coercible?
|
||||
coerce-opnd)
|
||||
(import asm-module)
|
||||
|
||||
(define-syntax seq
|
||||
(lambda (x)
|
||||
(syntax-case x ()
|
||||
[(_ e ... ex)
|
||||
(with-syntax ([(t ...) (generate-temporaries #'(e ...))])
|
||||
#'(let ([t e] ...)
|
||||
(with-values ex
|
||||
(case-lambda
|
||||
[(x*) (cons* t ... x*)]
|
||||
[(x* p) (values (cons* t ... x*) p)]))))])))
|
||||
|
||||
; don't bother with literal@? check since lvalues can't be literals
|
||||
(define lmem? mref?)
|
||||
|
||||
(define mem?
|
||||
(lambda (x)
|
||||
(or (lmem? x) (literal@? x))))
|
||||
|
||||
(define fpmem?
|
||||
(lambda (x)
|
||||
(nanopass-case (L15c Triv) x
|
||||
[(mref ,lvalue0 ,lvalue1 ,imm ,type) (eq? type 'fp)]
|
||||
[else #f])))
|
||||
|
||||
(define imm-funkymask?
|
||||
(lambda (x)
|
||||
(nanopass-case (L15c Triv) x
|
||||
|
|
@ -113,21 +93,6 @@
|
|||
[(immediate ,imm) `(immediate ,(- imm))]
|
||||
[else (sorry! who "~s is not an immediate" ir)]))
|
||||
|
||||
(define-syntax mem-of-type?
|
||||
(lambda (stx)
|
||||
(syntax-case stx (mem fpmem)
|
||||
[(_ mem e) #'(lmem? e)]
|
||||
[(_ fpmem e) #'(fpmem? e)])))
|
||||
|
||||
(define lvalue->ur
|
||||
(lambda (x k)
|
||||
(if (mref? x)
|
||||
(let ([u (make-tmp 'u)])
|
||||
(seq
|
||||
(set-ur=mref u x)
|
||||
(k u)))
|
||||
(k x))))
|
||||
|
||||
(define mref->mref
|
||||
(lambda (a k)
|
||||
(define return
|
||||
|
|
@ -177,19 +142,20 @@
|
|||
|
||||
(define fpmem->fpmem mem->mem)
|
||||
|
||||
;; `define-instruction` code takes care of `ur` and `fpur`, to which
|
||||
;; all type-compatible values must convert
|
||||
(define-syntax coercible?
|
||||
(syntax-rules ()
|
||||
[(_ ?a ?aty*)
|
||||
(let ([a ?a] [aty* ?aty*])
|
||||
(or (and (memq 'ur aty*) (not (or (fpmem? a) (fpur? a))))
|
||||
(and (memq 'fpur aty*) (or (fpmem? a) (fpur? a)))
|
||||
(and (memq 'unsigned12 aty*) (imm-unsigned12? a))
|
||||
(or (and (memq 'unsigned12 aty*) (imm-unsigned12? a))
|
||||
(and (memq 'neg-unsigned12 aty*) (imm-neg-unsigned12? a))
|
||||
(and (memq 'funkymask aty*) (imm-funkymask? a))
|
||||
(and (memq 'imm-constant aty*) (imm-constant? a))
|
||||
(and (memq 'mem aty*) (mem? a))
|
||||
(and (memq 'fpmem aty*) (fpmem? a))))]))
|
||||
|
||||
;; `define-instruction` doesn't try to cover `ur` and `fpur`
|
||||
(define-syntax coerce-opnd ; passes k something compatible with aty*
|
||||
(syntax-rules ()
|
||||
[(_ ?a ?aty* ?k)
|
||||
|
|
@ -231,12 +197,6 @@
|
|||
(sorry! 'coerce-opnd "unexpected operand ~s" a)])]
|
||||
[else (sorry! 'coerce-opnd "cannot coerce ~s to ~s" a aty*)]))]))
|
||||
|
||||
(define set-ur=mref
|
||||
(lambda (ur mref)
|
||||
(mref->mref mref
|
||||
(lambda (mref)
|
||||
(build-set! ,ur ,mref)))))
|
||||
|
||||
(define md-handle-jump
|
||||
(lambda (t)
|
||||
(with-output-language (L15d Tail)
|
||||
|
|
@ -259,162 +219,6 @@
|
|||
(values '() `(jump (label-ref ,l ,offset)))]
|
||||
[else (long-form t)]))))
|
||||
|
||||
(define-syntax define-instruction
|
||||
(lambda (x)
|
||||
(define make-value-clause
|
||||
(lambda (fmt)
|
||||
(syntax-case fmt (mem fpmem ur fpur)
|
||||
[(op (c mem) (a aty ...) ...)
|
||||
#`(lambda (c a ...)
|
||||
(if (and (lmem? c) (coercible? a '(aty ...)) ...)
|
||||
#,(let f ([a* #'(a ...)] [aty** #'((aty ...) ...)])
|
||||
(cond
|
||||
[(null? a*)
|
||||
#'(mem->mem c
|
||||
(lambda (c)
|
||||
(rhs c a ...)))]
|
||||
[else
|
||||
#`(coerce-opnd #,(car a*) '#,(car aty**)
|
||||
(lambda (#,(car a*))
|
||||
#,(f (cdr a*) (cdr aty**))))]))
|
||||
(next c a ...)))]
|
||||
[(op (c fpmem) (a aty ...) ...)
|
||||
#`(lambda (c a ...)
|
||||
(if (and (fpmem? c) (coercible? a '(aty ...)) ...)
|
||||
#,(let f ([a* #'(a ...)] [aty** #'((aty ...) ...)])
|
||||
(cond
|
||||
[(null? a*)
|
||||
#'(fpmem->fpmem c
|
||||
(lambda (c)
|
||||
(rhs c a ...)))]
|
||||
[else
|
||||
#`(coerce-opnd #,(car a*) '#,(car aty**)
|
||||
(lambda (#,(car a*))
|
||||
#,(f (cdr a*) (cdr aty**))))]))
|
||||
(next c a ...)))]
|
||||
[(op (c ur) (a aty ...) ...)
|
||||
#`(lambda (c a ...)
|
||||
(if (and (coercible? a '(aty ...)) ...)
|
||||
#,(let f ([a* #'(a ...)] [aty** #'((aty ...) ...)])
|
||||
(if (null? a*)
|
||||
#'(if (ur? c)
|
||||
(rhs c a ...)
|
||||
(let ([u (make-tmp 'u)])
|
||||
(seq
|
||||
(rhs u a ...)
|
||||
(mref->mref c
|
||||
(lambda (c)
|
||||
(build-set! ,c ,u))))))
|
||||
#`(coerce-opnd #,(car a*) '#,(car aty**)
|
||||
(lambda (#,(car a*)) #,(f (cdr a*) (cdr aty**))))))
|
||||
(next c a ...)))]
|
||||
[(op (c fpur) (a aty ...) ...)
|
||||
#`(lambda (c a ...)
|
||||
(if (and (coercible? a '(aty ...)) ...)
|
||||
#,(let f ([a* #'(a ...)] [aty** #'((aty ...) ...)])
|
||||
(if (null? a*)
|
||||
#'(if (fpur? c)
|
||||
(rhs c a ...)
|
||||
(let ([u (make-tmp 'u 'fp)])
|
||||
(seq
|
||||
(rhs u a ...)
|
||||
(fpmem->fpmem c
|
||||
(lambda (c)
|
||||
(build-set! ,c ,u))))))
|
||||
#`(coerce-opnd #,(car a*) '#,(car aty**)
|
||||
(lambda (#,(car a*)) #,(f (cdr a*) (cdr aty**))))))
|
||||
(next c a ...)))])))
|
||||
|
||||
(define-who make-pred-clause
|
||||
(lambda (fmt)
|
||||
(syntax-case fmt ()
|
||||
[(op (a aty ...) ...)
|
||||
#`(lambda (a ...)
|
||||
(if (and (coercible? a '(aty ...)) ...)
|
||||
#,(let f ([a* #'(a ...)] [aty** #'((aty ...) ...)])
|
||||
(if (null? a*)
|
||||
#'(rhs a ...)
|
||||
#`(coerce-opnd #,(car a*) '#,(car aty**)
|
||||
(lambda (#,(car a*)) #,(f (cdr a*) (cdr aty**))))))
|
||||
(next a ...)))])))
|
||||
|
||||
(define-who make-effect-clause
|
||||
(lambda (fmt)
|
||||
(syntax-case fmt ()
|
||||
[(op (a aty ...) ...)
|
||||
#`(lambda (a ...)
|
||||
(if (and (coercible? a '(aty ...)) ...)
|
||||
#,(let f ([a* #'(a ...)] [aty** #'((aty ...) ...)])
|
||||
(if (null? a*)
|
||||
#'(rhs a ...)
|
||||
#`(coerce-opnd #,(car a*) '#,(car aty**)
|
||||
(lambda (#,(car a*)) #,(f (cdr a*) (cdr aty**))))))
|
||||
(next a ...)))])))
|
||||
|
||||
(syntax-case x (definitions)
|
||||
[(k context (sym ...) (definitions defn ...) [(op (a aty ...) ...) ?rhs0 ?rhs1 ...] ...)
|
||||
; potentially unnecessary level of checking, but the big thing is to make sure
|
||||
; the number of operands expected is the same on every clause of define-intruction
|
||||
(and (not (null? #'(op ...)))
|
||||
(andmap identifier? #'(sym ...))
|
||||
(andmap identifier? #'(op ...))
|
||||
(andmap identifier? #'(a ... ...))
|
||||
(andmap identifier? #'(aty ... ... ...)))
|
||||
(with-implicit (k info return with-output-language)
|
||||
(with-syntax ([((opnd* ...) . ignore) #'((a ...) ...)])
|
||||
(define make-proc
|
||||
(lambda (make-clause)
|
||||
(let f ([op* #'(op ...)]
|
||||
[fmt* #'((op (a aty ...) ...) ...)]
|
||||
[arg* #'((a ...) ...)]
|
||||
[rhs* #'((?rhs0 ?rhs1 ...) ...)])
|
||||
(if (null? op*)
|
||||
#'(lambda (opnd* ...)
|
||||
(sorry! name "no match found for ~s" (list opnd* ...)))
|
||||
#`(let ([next #,(f (cdr op*) (cdr fmt*) (cdr arg*) (cdr rhs*))]
|
||||
[rhs (lambda #,(car arg*)
|
||||
(let ([#,(car op*) name])
|
||||
#,@(car rhs*)))])
|
||||
#,(make-clause (car fmt*)))))))
|
||||
(unless (let ([a** #'((a ...) ...)])
|
||||
(let* ([a* (car a**)] [len (length a*)])
|
||||
(andmap (lambda (a*) (fx= (length a*) len)) (cdr a**))))
|
||||
(syntax-error x "mismatched instruction arities"))
|
||||
(cond
|
||||
[(free-identifier=? #'context #'value)
|
||||
#`(let ([fvalue (lambda (name)
|
||||
(lambda (info opnd* ...)
|
||||
defn ...
|
||||
(with-output-language (L15d Effect)
|
||||
(#,(make-proc make-value-clause) opnd* ...))))])
|
||||
(begin
|
||||
(safe-assert (eq? (primitive-type (%primitive sym)) 'value))
|
||||
(primitive-handler-set! (%primitive sym) (fvalue 'sym)))
|
||||
...)]
|
||||
[(free-identifier=? #'context #'pred)
|
||||
#`(let ([fpred (lambda (name)
|
||||
(lambda (info opnd* ...)
|
||||
defn ...
|
||||
(with-output-language (L15d Pred)
|
||||
(#,(make-proc make-pred-clause) opnd* ...))))])
|
||||
(begin
|
||||
(safe-assert (eq? (primitive-type (%primitive sym)) 'pred))
|
||||
(primitive-handler-set! (%primitive sym) (fpred 'sym)))
|
||||
...)]
|
||||
[(free-identifier=? #'context #'effect)
|
||||
#`(let ([feffect (lambda (name)
|
||||
(lambda (info opnd* ...)
|
||||
defn ...
|
||||
(with-output-language (L15d Effect)
|
||||
(#,(make-proc make-effect-clause) opnd* ...))))])
|
||||
(begin
|
||||
(safe-assert (eq? (primitive-type (%primitive sym)) 'effect))
|
||||
(primitive-handler-set! (%primitive sym) (feffect 'sym)))
|
||||
...)]
|
||||
[else (syntax-error #'context "unrecognized context")])))]
|
||||
[(k context (sym ...) cl ...) #'(k context (sym ...) (definitions) cl ...)]
|
||||
[(k context sym cl ...) (identifier? #'sym) #'(k context (sym) (definitions) cl ...)])))
|
||||
|
||||
(define info-cc-eq (make-info-condition-code 'eq? #f #t))
|
||||
(define asm-eq (asm-relop info-cc-eq #f))
|
||||
|
||||
|
|
@ -874,8 +678,7 @@
|
|||
asm-pop-multiple asm-shiftop asm-logand asm-lognot asm-cmp/asr63
|
||||
asm-logtest asm-fp-relop asm-relop asm-push-multiple asm-push-fpmultiple asm-pop-fpmultiple
|
||||
asm-indirect-jump asm-literal-jump
|
||||
asm-direct-jump asm-return-address asm-jump asm-conditional-jump asm-data-label
|
||||
asm-rp-header asm-rp-compact-header
|
||||
asm-direct-jump asm-return-address asm-jump asm-conditional-jump
|
||||
asm-indirect-call asm-condition-code
|
||||
asm-fpmove-single asm-fl-cvt asm-fpt asm-fpmove asm-fpcastto asm-fpcastfrom asm-fptrunc
|
||||
asm-lock asm-lock+/- asm-cas asm-fence
|
||||
|
|
@ -902,12 +705,6 @@
|
|||
[(reg) r (reg-mdinfo r)]
|
||||
[else (sorry! who "ea=~s" ea)])))
|
||||
|
||||
(define ax-register-list
|
||||
(lambda (r*)
|
||||
(fold-left
|
||||
(lambda (a r) (fx+ a (fxsll 1 (reg-mdinfo r))))
|
||||
0 r*)))
|
||||
|
||||
(define ax-reg?
|
||||
(lambda (ea)
|
||||
(record-case ea
|
||||
|
|
@ -2420,11 +2217,6 @@
|
|||
[(fp<=) (i? (r? blt bhi) (r? bge bls))]
|
||||
[(fp=) (i? bne beq)]))))))
|
||||
|
||||
(define asm-data-label
|
||||
(lambda (code* l offset func code-size)
|
||||
(let ([rel (make-funcrel 'abs l offset)])
|
||||
(cons* rel (aop-cons* `(asm "mrv point:" ,rel) code*)))))
|
||||
|
||||
(define asm-helper-jump
|
||||
(lambda (code* reloc)
|
||||
(let ([jmp-tmp (cons 'reg %jmptmp)])
|
||||
|
|
@ -2462,46 +2254,6 @@
|
|||
(lambda (code* reloc)
|
||||
(cons* reloc (aop-cons* `(asm "relocation:" ,reloc) code*))))
|
||||
|
||||
(define asm-rp-header
|
||||
(let ([mrv-error `(abs ,(constant code-data-disp)
|
||||
(library-code ,(lookup-libspec values-error)))])
|
||||
(lambda (code* mrvl fs lpm func code-size)
|
||||
(let* ([code* (cons* `(quad . ,fs)
|
||||
(aop-cons* `(asm "frame size:" ,fs)
|
||||
code*))]
|
||||
[code* (cons* (if (target-fixnum? lpm)
|
||||
`(quad . ,(fix lpm))
|
||||
`(abs 0 (object ,lpm)))
|
||||
(aop-cons* `(asm livemask: ,(format "~b" lpm))
|
||||
code*))]
|
||||
[code* (if mrvl
|
||||
(asm-data-label code* mrvl 0 func code-size)
|
||||
(cons*
|
||||
mrv-error
|
||||
(aop-cons* `(asm "mrv point:" ,mrv-error)
|
||||
code*)))]
|
||||
[code* (cons*
|
||||
'(code-top-link)
|
||||
(aop-cons* `(asm code-top-link)
|
||||
code*))])
|
||||
code*))))
|
||||
|
||||
(define asm-rp-compact-header
|
||||
(lambda (code* err? fs lpm func code-size)
|
||||
(let* ([code* (cons* `(quad . ,(fxior (constant compact-header-mask)
|
||||
(if err?
|
||||
(constant compact-header-values-error-mask)
|
||||
0)
|
||||
(fxsll fs (constant compact-frame-words-offset))
|
||||
(fxsll lpm (constant compact-frame-mask-offset))))
|
||||
(aop-cons* `(asm "mrv pt:" (,lpm ,fs ,(if err? 'error 'continue)))
|
||||
code*))]
|
||||
[code* (cons*
|
||||
'(code-top-link)
|
||||
(aop-cons* `(asm code-top-link)
|
||||
code*))])
|
||||
code*)))
|
||||
|
||||
; NB: reads from %lr...should be okay if declare-intrinsics sets up return-live* properly
|
||||
(define asm-return (lambda () (emit ret (cons 'reg %lr) '())))
|
||||
|
||||
|
|
|
|||
292
s/cpnanopass.ss
292
s/cpnanopass.ss
|
|
@ -11727,6 +11727,12 @@
|
|||
|
||||
(define-pass np-impose-calling-conventions : L12.5 (ir) -> L13 ()
|
||||
(definitions
|
||||
;; define-op sets up assembly op macros--
|
||||
;; suffixes are a sub-list of (b w l 1)--
|
||||
;; the opcode, the size (byte word, long, quad), and all other expressions
|
||||
;; are passed to the specified handler--
|
||||
;; for prefix 'p' and each suffix 's' a macro of the form 'ps' is set up--
|
||||
;; if no suffix is specified the prefix is defined as a macro
|
||||
(import (only asm-module asm-foreign-call asm-foreign-callable asm-enter))
|
||||
(define newframe-info-for-mventry-point)
|
||||
(define Lcall-error (make-Lcall-error))
|
||||
|
|
@ -13377,6 +13383,7 @@
|
|||
(define-pass np-expand-hand-coded : L13 (ir) -> L13.5 ()
|
||||
(definitions
|
||||
(import (only asm-module asm-enter))
|
||||
;; ----------------------------------------
|
||||
(define Ldoargerr (make-Ldoargerr))
|
||||
(define-$type-check (L13.5 Pred))
|
||||
(define make-info
|
||||
|
|
@ -16153,6 +16160,53 @@
|
|||
(fx- offset (fx- (constant size-rp-header)
|
||||
(constant size-rp-compact-header)))
|
||||
offset)))
|
||||
|
||||
(define asm-data-label
|
||||
(lambda (code* l offset func code-size)
|
||||
(let ([rel (make-funcrel 'abs l offset)])
|
||||
(cons* rel (aop-cons* `(asm "mrv point:" ,rel) code*)))))
|
||||
|
||||
(define asm-rp-header
|
||||
(let ([mrv-error `(abs ,(constant code-data-disp)
|
||||
(library-code ,(lookup-libspec values-error)))])
|
||||
(lambda (code* mrvl fs lpm func code-size)
|
||||
(let ([size (constant-case ptr-bits [(32) 'long] [(64) 'quad])])
|
||||
(let* ([code* (cons* `(,size . ,fs)
|
||||
(aop-cons* `(asm "frame size:" ,fs)
|
||||
code*))]
|
||||
[code* (cons* (if (target-fixnum? lpm)
|
||||
`(,size . ,(fix lpm))
|
||||
`(abs 0 (object ,lpm)))
|
||||
(aop-cons* `(asm livemask: ,(format "~b" lpm))
|
||||
code*))]
|
||||
[code* (if mrvl
|
||||
(asm-data-label code* mrvl 0 func code-size)
|
||||
(cons*
|
||||
mrv-error
|
||||
(aop-cons* `(asm "mrv point:" ,mrv-error)
|
||||
code*)))]
|
||||
[code* (cons*
|
||||
'(code-top-link)
|
||||
(aop-cons* `(asm code-top-link)
|
||||
code*))])
|
||||
code*)))))
|
||||
|
||||
(define asm-rp-compact-header
|
||||
(lambda (code* err? fs lpm func code-size)
|
||||
(let ([size (constant-case ptr-bits [(32) 'long] [(64) 'quad])])
|
||||
(let* ([code* (cons* `(,size . ,(fxior (constant compact-header-mask)
|
||||
(if err?
|
||||
(constant compact-header-values-error-mask)
|
||||
0)
|
||||
(fxsll fs (constant compact-frame-words-offset))
|
||||
(fxsll lpm (constant compact-frame-mask-offset))))
|
||||
(aop-cons* `(asm "mrv pt:" (,lpm ,fs ,(if err? 'error 'continue)))
|
||||
code*))]
|
||||
[code* (cons*
|
||||
'(code-top-link)
|
||||
(aop-cons* `(asm code-top-link)
|
||||
code*))])
|
||||
code*))))
|
||||
|
||||
(architecture assembler)
|
||||
|
||||
|
|
@ -17162,11 +17216,30 @@
|
|||
(nanopass-case (L15c Triv) x
|
||||
[(literal ,info) (info-literal-indirect? info)]
|
||||
[else #f])))
|
||||
(define mref?
|
||||
(define lmem?
|
||||
(lambda (x)
|
||||
(nanopass-case (L15c Triv) x
|
||||
[(mref ,lvalue1 ,lvalue2 ,imm ,type) #t]
|
||||
[(mref ,lvalue1 ,lvalue2 ,imm ,type) (not (eq? type 'fp))]
|
||||
[else #f])))
|
||||
(define mem?
|
||||
(lambda (x)
|
||||
(or (lmem? x) (literal@? x))))
|
||||
(define fpmem?
|
||||
(lambda (x)
|
||||
(nanopass-case (L15c Triv) x
|
||||
[(mref ,lvalue1 ,lvalue2 ,imm ,type) (eq? type 'fp)]
|
||||
[else #f])))
|
||||
(define lvalue->ur
|
||||
(lambda (x k)
|
||||
(safe-assert (not (fpmem? x)))
|
||||
(if (mem? x)
|
||||
(let ([u (make-tmp 'u)])
|
||||
(seq
|
||||
(mem->mem x
|
||||
(lambda (x)
|
||||
(build-set! ,u ,x)))
|
||||
(k u)))
|
||||
(k x))))
|
||||
(define same?
|
||||
(lambda (a b)
|
||||
(or (eq? a b)
|
||||
|
|
@ -17194,6 +17267,221 @@
|
|||
(info-literal-addr info) (info-literal-offset info)))]
|
||||
[else (sorry! who "unexpected literal ~s" ir)]))
|
||||
|
||||
(define-syntax seq
|
||||
(lambda (x)
|
||||
(syntax-case x ()
|
||||
[(_ e ... ex)
|
||||
(with-syntax ([(t ...) (generate-temporaries #'(e ...))])
|
||||
#'(let ([t e] ...)
|
||||
(with-values ex
|
||||
(case-lambda
|
||||
[(x*) (cons* t ... x*)]
|
||||
[(x* p) (values (cons* t ... x*) p)]))))])))
|
||||
|
||||
(define-syntax coercible?*
|
||||
(lambda (stx)
|
||||
(syntax-case stx (quote)
|
||||
[(_ x '(ty ...))
|
||||
(memq 'ur (datum (ty ...)))
|
||||
#`(let () (safe-assert (not (or (fpur? x) (fpmem? x)))) #t)]
|
||||
[(_ x '(ty ...))
|
||||
(memq 'fpur (datum (ty ...)))
|
||||
#`(let () (safe-assert (or (fpur? x) (fpmem? x))) #t)]
|
||||
[(_ x '(ty ...))
|
||||
#`(coercible? x '(ty ...))])))
|
||||
|
||||
;; If any value clause includes a constant that a register matches the target register.
|
||||
;; then `acsame-mem` and/or `acsame-ur` must be defined
|
||||
(define-syntax define-instruction
|
||||
(lambda (x)
|
||||
(define (type->lpred t)
|
||||
(case t
|
||||
[(mem) #'lmem?]
|
||||
[(fpmem) #'fpmem?]
|
||||
[(ur) #'(lambda (x) (safe-assert (not (or (fpur? x) (fpmem? x)))) #t)]
|
||||
[(fpur) #'(lambda (x) (safe-assert (or (fpur? x) (fpmem? x))) #t)]
|
||||
[else ($oops 'type->red "unrecognized ~s" t)]))
|
||||
|
||||
(define make-value-clause
|
||||
(lambda (fmt)
|
||||
(syntax-case fmt (mem ur fpmem fpur)
|
||||
[(op (c cty) (a ?c) (b bty* ...) ...)
|
||||
(and (bound-identifier=? #'?c #'c)
|
||||
(memq (datum cty) '(mem fpmem ur xur)))
|
||||
#`(lambda (c a b ...)
|
||||
(if (and (#,(type->lpred (datum cty)) c)
|
||||
(same? a c)
|
||||
(coercible?* b '(bty* ...)) ...)
|
||||
#,(let f ([b* #'(b ...)] [bty** #'((bty* ...) ...)])
|
||||
(if (null? b*)
|
||||
#`(#,(if (memq (datum cty) '(ur fpur)) #'acsame-ur #'acsame-mem)
|
||||
#,fmt
|
||||
c cty (b bty* ...) ...
|
||||
(lambda (c b ...) (rhs c c b ...)))
|
||||
#`(coerce-opnd #,(car b*) '#,(car bty**)
|
||||
(lambda (#,(car b*)) #,(f (cdr b*) (cdr bty**))))))
|
||||
(next c a b ...)))]
|
||||
[(op (c cty) (a aty* ...) ... (b ?c))
|
||||
(and (bound-identifier=? #'?c #'c)
|
||||
(memq (datum cty) '(mem fpmem ur xur)))
|
||||
#`(lambda (c a ... b)
|
||||
(if (and (#,(type->lpred (datum cty)) c)
|
||||
(same? b c)
|
||||
(coercible?* a '(aty* ...)) ...)
|
||||
#,(let f ([a* #'(a ...)] [aty** #'((aty* ...) ...)])
|
||||
(if (null? a*)
|
||||
#`(#,(if (memq (datum cty) '(ur fpur)) #'acsame-ur #'acsame-mem)
|
||||
#,fmt
|
||||
c cty (a aty* ...) ...
|
||||
(lambda (c a ...) (rhs c a ... c)))
|
||||
#`(coerce-opnd #,(car a*) '#,(car aty**)
|
||||
(lambda (#,(car a*)) #,(f (cdr a*) (cdr aty**))))))
|
||||
(next c a ... b)))]
|
||||
[(op (c xur) (a aty ...) ...)
|
||||
(memq (datum xur) '(ur fpur))
|
||||
#`(lambda (c a ...)
|
||||
(if (and (#,(type->lpred (datum xur)) c)
|
||||
(coercible?* a '(aty ...)) ...)
|
||||
#,(let f ([a* #'(a ...)] [aty** #'((aty ...) ...)])
|
||||
(if (null? a*)
|
||||
#`(if (ur? c)
|
||||
(rhs c a ...)
|
||||
(let ([u (make-tmp 'u '#,(if (eq? (datum xur) 'ur) #'uptr #'fp))])
|
||||
(seq
|
||||
(rhs u a ...)
|
||||
(#,(if (eq? (datum xur) 'ur) #'mem->mem #'fpmem->fpmem)
|
||||
c
|
||||
(lambda (c)
|
||||
(build-set! ,c ,u))))))
|
||||
#`(coerce-opnd #,(car a*) '#,(car aty**)
|
||||
(lambda (#,(car a*)) #,(f (cdr a*) (cdr aty**))))))
|
||||
(next c a ...)))]
|
||||
[(op (c xmem) (a aty ...) ...)
|
||||
(memq (datum xmem) '(mem fpmem))
|
||||
#`(lambda (c a ...)
|
||||
(if (and (#,(type->lpred (datum xmem)) c)
|
||||
(coercible?* a '(aty ...)) ...)
|
||||
#,(let f ([a* #'(a ...)] [aty** #'((aty ...) ...)])
|
||||
(if (null? a*)
|
||||
#`(#,(if (eq? (datum xmem) 'mem) #'mem->mem #'fpmem->fpmem)
|
||||
c
|
||||
(lambda (c)
|
||||
(rhs c a ...)))
|
||||
#`(coerce-opnd #,(car a*) '#,(car aty**)
|
||||
(lambda (#,(car a*)) #,(f (cdr a*) (cdr aty**))))))
|
||||
(next c a ...)))])))
|
||||
|
||||
(define-who make-pred-clause
|
||||
(lambda (fmt)
|
||||
(syntax-case fmt ()
|
||||
[(op (a aty ...) ...)
|
||||
#`(lambda (a ...)
|
||||
(if (and (coercible?* a '(aty ...)) ...)
|
||||
#,(let f ([a* #'(a ...)] [aty** #'((aty ...) ...)])
|
||||
(if (null? a*)
|
||||
#'(rhs a ...)
|
||||
#`(coerce-opnd #,(car a*) '#,(car aty**)
|
||||
(lambda (#,(car a*)) #,(f (cdr a*) (cdr aty**))))))
|
||||
(next a ...)))])))
|
||||
|
||||
(define-who make-effect-clause
|
||||
(lambda (fmt)
|
||||
(syntax-case fmt ()
|
||||
[(op (a aty ...) ...)
|
||||
#`(lambda (a ...)
|
||||
(if (and (coercible?* a '(aty ...)) ...)
|
||||
#,(let f ([a* #'(a ...)] [aty** #'((aty ...) ...)])
|
||||
(if (null? a*)
|
||||
#'(rhs a ...)
|
||||
#`(coerce-opnd #,(car a*) '#,(car aty**)
|
||||
(lambda (#,(car a*)) #,(f (cdr a*) (cdr aty**))))))
|
||||
(next a ...)))])))
|
||||
|
||||
(syntax-case x (definitions)
|
||||
[(k context (sym ...) (definitions defn ...) [(op (a aty ...) ...) ?rhs0 ?rhs1 ...] ...)
|
||||
(and (not (null? #'(op ...)))
|
||||
(andmap identifier? #'(sym ...))
|
||||
(andmap identifier? #'(op ...))
|
||||
(andmap identifier? #'(a ... ...))
|
||||
(andmap identifier? #'(aty ... ... ...)))
|
||||
(with-implicit (k info return with-output-language)
|
||||
(with-syntax ([((opnd* ...) . ignore) #'((a ...) ...)])
|
||||
(define make-proc
|
||||
(lambda (make-clause)
|
||||
(let f ([op* #'(op ...)]
|
||||
[fmt* #'((op (a aty ...) ...) ...)]
|
||||
[arg* #'((a ...) ...)]
|
||||
[rhs* #'((?rhs0 ?rhs1 ...) ...)])
|
||||
(if (null? op*)
|
||||
#'(lambda (opnd* ...)
|
||||
(sorry! name "no match found for ~s" (list opnd* ...)))
|
||||
#`(let ([next #,(f (cdr op*) (cdr fmt*) (cdr arg*) (cdr rhs*))]
|
||||
[rhs (lambda #,(car arg*)
|
||||
(let ([#,(car op*) name])
|
||||
#,@(car rhs*)))])
|
||||
#,(make-clause (car fmt*)))))))
|
||||
(unless (let ([a** #'((a ...) ...)])
|
||||
(let* ([a* (car a**)] [len (length a*)])
|
||||
(andmap (lambda (a*) (fx= (length a*) len)) (cdr a**))))
|
||||
(syntax-error x "mismatched instruction arities"))
|
||||
;; Sanity check on consistent fp and non-fp types
|
||||
(let ([aty*** (datum (((aty ...) ...) ...))])
|
||||
(let loop ([aty*** aty***]
|
||||
[int* (map (lambda (aty**) #f) (car aty***))]
|
||||
[fp* (map (lambda (aty**) #f) (car aty***))])
|
||||
(unless (null? aty***)
|
||||
(let ([aty** (car aty***)])
|
||||
(let ([next-int* (map (lambda (aty*)
|
||||
(or (memq 'ur aty*)
|
||||
(memq 'mem aty*)))
|
||||
aty**)]
|
||||
[next-fp* (map (lambda (aty*)
|
||||
(or (memq 'fpur aty*)
|
||||
(memq 'fpmem aty*)))
|
||||
aty**)])
|
||||
(when (ormap (lambda (int fp next-int next-fp)
|
||||
(or (and int next-fp)
|
||||
(and fp next-int)
|
||||
(and next-int next-fp)))
|
||||
int* fp* next-int* next-fp*)
|
||||
(syntax-error x "mismatched instruction argument types"))
|
||||
(loop (cdr aty***) next-int* next-fp*))))))
|
||||
(with-syntax ([((opnd* ...) . ignore) #'((a ...) ...)])
|
||||
(cond
|
||||
[(free-identifier=? #'context #'value)
|
||||
#`(let ([fvalue (lambda (name)
|
||||
(lambda (info opnd* ...)
|
||||
defn ...
|
||||
(with-output-language (L15d Effect)
|
||||
(#,(make-proc make-value-clause) opnd* ...))))])
|
||||
(begin
|
||||
(safe-assert (eq? (primitive-type (%primitive sym)) 'value))
|
||||
(primitive-handler-set! (%primitive sym) (fvalue 'sym)))
|
||||
...)]
|
||||
[(free-identifier=? #'context #'pred)
|
||||
#`(let ([fpred (lambda (name)
|
||||
(lambda (info opnd* ...)
|
||||
defn ...
|
||||
(with-output-language (L15d Pred)
|
||||
(#,(make-proc make-pred-clause) opnd* ...))))])
|
||||
(begin
|
||||
(safe-assert (eq? (primitive-type (%primitive sym)) 'pred))
|
||||
(primitive-handler-set! (%primitive sym) (fpred 'sym)))
|
||||
...)]
|
||||
[(free-identifier=? #'context #'effect)
|
||||
#`(let ([feffect (lambda (name)
|
||||
(lambda (info opnd* ...)
|
||||
defn ...
|
||||
(with-output-language (L15d Effect)
|
||||
(#,(make-proc make-effect-clause) opnd* ...))))])
|
||||
(begin
|
||||
(safe-assert (eq? (primitive-type (%primitive sym)) 'effect))
|
||||
(primitive-handler-set! (%primitive sym) (feffect 'sym)))
|
||||
...)]
|
||||
[else (syntax-error #'context "unrecognized context")]))))]
|
||||
[(k context (sym ...) cl ...) #'(k context (sym ...) (definitions) cl ...)]
|
||||
[(k context sym cl ...) (identifier? #'sym) #'(k context (sym) (definitions) cl ...)])))
|
||||
|
||||
(define-pass select-instructions! : (L15c Dummy) (ir block* live-size force-overflow?) -> (L15d Dummy) ()
|
||||
(definitions
|
||||
(module (handle-jump handle-effect-inline handle-pred-inline handle-value-inline)
|
||||
|
|
|
|||
228
s/ppc32.ss
228
s/ppc32.ss
|
|
@ -115,33 +115,13 @@
|
|||
))
|
||||
|
||||
;;; SECTION 2: instructions
|
||||
(module (md-handle-jump) ; also sets primitive handlers
|
||||
(module (md-handle-jump ; also sets primitive handlers
|
||||
mem->mem
|
||||
fpmem->fpmem
|
||||
coercible?
|
||||
coerce-opnd)
|
||||
(import asm-module)
|
||||
|
||||
(define-syntax seq
|
||||
(lambda (x)
|
||||
(syntax-case x ()
|
||||
[(_ e ... ex)
|
||||
(with-syntax ([(t ...) (generate-temporaries #'(e ...))])
|
||||
#'(let ([t e] ...)
|
||||
(with-values ex
|
||||
(case-lambda
|
||||
[(x*) (cons* t ... x*)]
|
||||
[(x* p) (values (cons* t ... x*) p)]))))])))
|
||||
|
||||
; don't bother with literal@? check since lvalues can't be literals
|
||||
(define lmem? mref?)
|
||||
|
||||
(define mem?
|
||||
(lambda (x)
|
||||
(or (lmem? x) (literal@? x))))
|
||||
|
||||
(define fpmem?
|
||||
(lambda (x)
|
||||
(nanopass-case (L15c Triv) x
|
||||
[(mref ,lvalue0 ,lvalue1 ,imm ,type) (eq? type 'fp)]
|
||||
[else #f])))
|
||||
|
||||
(define-syntax define-imm-pred
|
||||
(lambda (x)
|
||||
(syntax-case x ()
|
||||
|
|
@ -167,15 +147,6 @@
|
|||
[(immediate ,imm) #t]
|
||||
[else #f])))
|
||||
|
||||
(define lvalue->ur
|
||||
(lambda (x k)
|
||||
(if (mref? x)
|
||||
(let ([u (make-tmp 'u)])
|
||||
(seq
|
||||
(set-ur=mref u x)
|
||||
(k u)))
|
||||
(k x))))
|
||||
|
||||
(define mref->mref
|
||||
(lambda (a k)
|
||||
(define return
|
||||
|
|
@ -211,19 +182,21 @@
|
|||
(k (with-output-language (L15d Lvalue) `(mref ,u ,%zero 0 uptr)))))]
|
||||
[else (mref->mref a k)])))
|
||||
|
||||
(define fpmem->fpmem mem->mem)
|
||||
|
||||
(define-pass imm->negative-imm : (L15c Triv) (ir) -> (L15d Triv) ()
|
||||
(Lvalue : Lvalue (ir) -> Lvalue ()
|
||||
[(mref ,lvalue1 ,lvalue2 ,imm ,type) (sorry! who "unexpected mref ~s" ir)])
|
||||
(Triv : Triv (ir) -> Triv ()
|
||||
[(immediate ,imm) `(immediate ,(- imm))]))
|
||||
|
||||
;; `define-instruction` code takes care of `ur` and `fpur`, to which
|
||||
;; all type-compatible values must convert
|
||||
(define-syntax coercible?
|
||||
(syntax-rules ()
|
||||
[(_ ?a ?aty*)
|
||||
(let ([a ?a] [aty* ?aty*])
|
||||
(or (and (memq 'ur aty*) (not (or (fpmem? a) (fpur? a))))
|
||||
(and (memq 'fpur aty*) (or (fpmem? a) (fpur? a)))
|
||||
(and (memq 'shift-count aty*) (imm-shift-count? a))
|
||||
(or (and (memq 'shift-count aty*) (imm-shift-count? a))
|
||||
(and (memq 'unsigned16 aty*) (imm-unsigned16? a))
|
||||
(and (memq 'shifted-unsigned16 aty*) (imm-shifted-unsigned16? a))
|
||||
(and (memq 'integer16 aty*) (imm-integer16? a))
|
||||
|
|
@ -234,6 +207,7 @@
|
|||
(and (memq 'mem aty*) (mem? a))
|
||||
(and (memq 'fpmem aty*) (fpmem? a))))]))
|
||||
|
||||
;; `define-instruction` doesn't try to cover `ur` and `fpur`
|
||||
(define-syntax coerce-opnd ; passes k something compatible with aty*
|
||||
(syntax-rules ()
|
||||
[(_ ?a ?aty* ?k)
|
||||
|
|
@ -280,12 +254,6 @@
|
|||
[else (sorry! 'coerce-opnd "unexpected operand ~s" a)])]
|
||||
[else (sorry! 'coerce-opnd "cannot coerce ~s to ~s" a aty*)]))]))
|
||||
|
||||
(define set-ur=mref
|
||||
(lambda (ur mref)
|
||||
(mref->mref mref
|
||||
(lambda (mref)
|
||||
(build-set! ,ur ,mref)))))
|
||||
|
||||
(define md-handle-jump
|
||||
(lambda (t)
|
||||
(with-output-language (L15d Tail)
|
||||
|
|
@ -310,132 +278,6 @@
|
|||
(values '() `(jump (label-ref ,l ,offset)))]
|
||||
[else (long-form t)]))))
|
||||
|
||||
(define-syntax define-instruction
|
||||
(lambda (x)
|
||||
(define make-value-clause
|
||||
(lambda (fmt)
|
||||
(syntax-case fmt (mem ur fpmem fpur)
|
||||
[(op (c xur) (a aty ...) ...)
|
||||
(memq (syntax->datum #'xur) '(ur fpur))
|
||||
#`(lambda (c a ...)
|
||||
(if (and (coercible? a '(aty ...)) ...)
|
||||
#,(let f ([a* #'(a ...)] [aty** #'((aty ...) ...)])
|
||||
(if (null? a*)
|
||||
#`(if (#,(if (eq? (syntax->datum #'xur) 'ur) #'ur? #'fpur?) c)
|
||||
(rhs c a ...)
|
||||
(let ([u (make-tmp 'u '#,(if (eq? (syntax->datum #'xur) 'ur) #'uptr #'fp))])
|
||||
(seq
|
||||
(rhs u a ...)
|
||||
(mref->mref c
|
||||
(lambda (c)
|
||||
(build-set! ,c ,u))))))
|
||||
#`(coerce-opnd #,(car a*) '#,(car aty**)
|
||||
(lambda (#,(car a*)) #,(f (cdr a*) (cdr aty**))))))
|
||||
(next c a ...)))]
|
||||
[(op (c xmem) (a aty ...) ...)
|
||||
(memq (syntax->datum #'xmem) '(mem fpmem))
|
||||
#`(lambda (c a ...)
|
||||
(if (and (#,(if (eq? (syntax->datum #'xmem) 'mem) #'lmem? #'fpmem?) c)
|
||||
(coercible? a '(aty ...)) ...)
|
||||
#,(let f ([a* #'(a ...)] [aty** #'((aty ...) ...)])
|
||||
(if (null? a*)
|
||||
#`(mem->mem c
|
||||
(lambda (c)
|
||||
(rhs c a ...)))
|
||||
#`(coerce-opnd #,(car a*) '#,(car aty**)
|
||||
(lambda (#,(car a*)) #,(f (cdr a*) (cdr aty**))))))
|
||||
(next c a ...)))])))
|
||||
|
||||
(define-who make-pred-clause
|
||||
(lambda (fmt)
|
||||
(syntax-case fmt ()
|
||||
[(op (a aty ...) ...)
|
||||
#`(lambda (a ...)
|
||||
(if (and (coercible? a '(aty ...)) ...)
|
||||
#,(let f ([a* #'(a ...)] [aty** #'((aty ...) ...)])
|
||||
(if (null? a*)
|
||||
#'(rhs a ...)
|
||||
#`(coerce-opnd #,(car a*) '#,(car aty**)
|
||||
(lambda (#,(car a*)) #,(f (cdr a*) (cdr aty**))))))
|
||||
(next a ...)))])))
|
||||
|
||||
(define-who make-effect-clause
|
||||
(lambda (fmt)
|
||||
(syntax-case fmt ()
|
||||
[(op (a aty ...) ...)
|
||||
#`(lambda (a ...)
|
||||
(if (and (coercible? a '(aty ...)) ...)
|
||||
#,(let f ([a* #'(a ...)] [aty** #'((aty ...) ...)])
|
||||
(if (null? a*)
|
||||
#'(rhs a ...)
|
||||
#`(coerce-opnd #,(car a*) '#,(car aty**)
|
||||
(lambda (#,(car a*)) #,(f (cdr a*) (cdr aty**))))))
|
||||
(next a ...)))])))
|
||||
|
||||
(syntax-case x (definitions)
|
||||
[(k context (sym ...) (definitions defn ...) [(op (a aty ...) ...) ?rhs0 ?rhs1 ...] ...)
|
||||
; potentially unnecessary level of checking, but the big thing is to make sure
|
||||
; the number of operands expected is the same on every clause of define-intruction
|
||||
(and (not (null? #'(op ...)))
|
||||
(andmap identifier? #'(sym ...))
|
||||
(andmap identifier? #'(op ...))
|
||||
(andmap identifier? #'(a ... ...))
|
||||
(andmap identifier? #'(aty ... ... ...)))
|
||||
(with-implicit (k info return with-output-language)
|
||||
(with-syntax ([((opnd* ...) . ignore) #'((a ...) ...)])
|
||||
(define make-proc
|
||||
(lambda (make-clause)
|
||||
(let f ([op* #'(op ...)]
|
||||
[fmt* #'((op (a aty ...) ...) ...)]
|
||||
[arg* #'((a ...) ...)]
|
||||
[rhs* #'((?rhs0 ?rhs1 ...) ...)])
|
||||
(if (null? op*)
|
||||
#'(lambda (opnd* ...)
|
||||
(sorry! name "no match found for ~s" (list opnd* ...)))
|
||||
#`(let ([next #,(f (cdr op*) (cdr fmt*) (cdr arg*) (cdr rhs*))]
|
||||
[rhs (lambda #,(car arg*)
|
||||
(let ([#,(car op*) name])
|
||||
#,@(car rhs*)))])
|
||||
#,(make-clause (car fmt*)))))))
|
||||
(unless (let ([a** #'((a ...) ...)])
|
||||
(let* ([a* (car a**)] [len (length a*)])
|
||||
(andmap (lambda (a*) (fx= (length a*) len)) (cdr a**))))
|
||||
(syntax-error x "mismatched instruction arities"))
|
||||
(cond
|
||||
[(free-identifier=? #'context #'value)
|
||||
#`(let ([fvalue (lambda (name)
|
||||
(lambda (info opnd* ...)
|
||||
defn ...
|
||||
(with-output-language (L15d Effect)
|
||||
(#,(make-proc make-value-clause) opnd* ...))))])
|
||||
(begin
|
||||
(safe-assert (eq? (primitive-type (%primitive sym)) 'value))
|
||||
(primitive-handler-set! (%primitive sym) (fvalue 'sym)))
|
||||
...)]
|
||||
[(free-identifier=? #'context #'pred)
|
||||
#`(let ([fpred (lambda (name)
|
||||
(lambda (info opnd* ...)
|
||||
defn ...
|
||||
(with-output-language (L15d Pred)
|
||||
(#,(make-proc make-pred-clause) opnd* ...))))])
|
||||
(begin
|
||||
(safe-assert (eq? (primitive-type (%primitive sym)) 'pred))
|
||||
(primitive-handler-set! (%primitive sym) (fpred 'sym)))
|
||||
...)]
|
||||
[(free-identifier=? #'context #'effect)
|
||||
#`(let ([feffect (lambda (name)
|
||||
(lambda (info opnd* ...)
|
||||
defn ...
|
||||
(with-output-language (L15d Effect)
|
||||
(#,(make-proc make-effect-clause) opnd* ...))))])
|
||||
(begin
|
||||
(safe-assert (eq? (primitive-type (%primitive sym)) 'effect))
|
||||
(primitive-handler-set! (%primitive sym) (feffect 'sym)))
|
||||
...)]
|
||||
[else (syntax-error #'context "unrecognized context")])))]
|
||||
[(k context (sym ...) cl ...) #'(k context (sym ...) (definitions) cl ...)]
|
||||
[(k context sym cl ...) (identifier? #'sym) #'(k context (sym) (definitions) cl ...)])))
|
||||
|
||||
(define info-cc-eq (make-info-condition-code 'eq? #f #t))
|
||||
|
||||
; x is not the same as z in any clause that follows a clause where (x z)
|
||||
|
|
@ -891,8 +733,7 @@
|
|||
asm-logand asm-lognot
|
||||
asm-logtest asm-fp-relop asm-relop asm-logrelop
|
||||
asm-indirect-jump asm-literal-jump
|
||||
asm-direct-jump asm-return-address asm-jump asm-conditional-jump asm-data-label
|
||||
asm-rp-header asm-rp-compact-header
|
||||
asm-direct-jump asm-return-address asm-jump asm-conditional-jump
|
||||
asm-indirect-call asm-condition-code
|
||||
asm-trunc asm-fpt asm-fpcastto asm-fpcastfrom
|
||||
asm-lock asm-lock+/- asm-cas
|
||||
|
|
@ -2171,11 +2012,6 @@
|
|||
(emit b `(label ,(fx+ disp1 4) ,l1)
|
||||
(emit b `(label ,disp2 ,l2) '())))]))))))
|
||||
|
||||
(define asm-data-label
|
||||
(lambda (code* l offset func code-size)
|
||||
(let ([rel (make-funcrel 'abs l offset)])
|
||||
(cons* rel (aop-cons* `(asm "mrv point:" ,rel) code*)))))
|
||||
|
||||
(define asm-helper-jump
|
||||
(lambda (code* reloc)
|
||||
(emit nop
|
||||
|
|
@ -2219,46 +2055,6 @@
|
|||
(lambda (reloc code*)
|
||||
(cons* reloc (aop-cons* `(asm "relocation:" ,reloc) code*))))
|
||||
|
||||
(define asm-rp-header
|
||||
(let ([mrv-error `(abs ,(constant code-data-disp)
|
||||
(library-code ,(lookup-libspec values-error)))])
|
||||
(lambda (code* mrvl fs lpm func code-size)
|
||||
(let* ([code* (cons* `(long . ,fs)
|
||||
(aop-cons* `(asm "frame size:" ,fs)
|
||||
code*))]
|
||||
[code* (cons* (if (target-fixnum? lpm)
|
||||
`(long . ,(fix lpm))
|
||||
`(abs 0 (object ,lpm)))
|
||||
(aop-cons* `(asm livemask: ,(format "~b" lpm))
|
||||
code*))]
|
||||
[code* (if mrvl
|
||||
(asm-data-label code* mrvl 0 func code-size)
|
||||
(cons*
|
||||
mrv-error
|
||||
(aop-cons* `(asm "mrv point:" ,mrv-error)
|
||||
code*)))]
|
||||
[code* (cons*
|
||||
'(code-top-link)
|
||||
(aop-cons* `(asm code-top-link)
|
||||
code*))])
|
||||
code*))))
|
||||
|
||||
(define asm-rp-compact-header
|
||||
(lambda (code* err? fs lpm func code-size)
|
||||
(let* ([code* (cons* `(long . ,(fxior (constant compact-header-mask)
|
||||
(if err?
|
||||
(constant compact-header-values-error-mask)
|
||||
0)
|
||||
(fxsll fs (constant compact-frame-words-offset))
|
||||
(fxsll lpm (constant compact-frame-mask-offset))))
|
||||
(aop-cons* `(asm "mrv pt:" (,lpm ,fs ,(if err? 'error 'continue)))
|
||||
code*))]
|
||||
[code* (cons*
|
||||
'(code-top-link)
|
||||
(aop-cons* `(asm code-top-link)
|
||||
code*))])
|
||||
code*)))
|
||||
|
||||
(define asm-return
|
||||
(lambda ()
|
||||
(emit blr '())))
|
||||
|
|
|
|||
469
s/x86.ss
469
s/x86.ss
|
|
@ -41,45 +41,21 @@
|
|||
#;[%esi #f 6]))
|
||||
|
||||
;;; SECTION 2: instructions
|
||||
(module (md-handle-jump) ; also sets primitive handlers
|
||||
(module (md-handle-jump ; also sets primitive handlers
|
||||
mem->mem
|
||||
fpmem->fpmem
|
||||
coercible?
|
||||
coerce-opnd
|
||||
acsame-mem
|
||||
acsame-ur)
|
||||
(import asm-module)
|
||||
|
||||
(define-syntax seq
|
||||
(lambda (x)
|
||||
(syntax-case x ()
|
||||
[(_ e ... ex)
|
||||
(with-syntax ([(t ...) (generate-temporaries #'(e ...))])
|
||||
#'(let ([t e] ...)
|
||||
(with-values ex
|
||||
(case-lambda
|
||||
[(x*) (cons* t ... x*)]
|
||||
[(x* p) (values (cons* t ... x*) p)]))))])))
|
||||
|
||||
(define all-but-byte-registers
|
||||
; include only allocable registers that aren't byte registers
|
||||
; keep in sync with define-registers above
|
||||
(lambda ()
|
||||
(list %esi)))
|
||||
|
||||
; don't bother with literal@? check since lvalues can't be literals
|
||||
(define lmem? mref?)
|
||||
|
||||
(define mem?
|
||||
(lambda (x)
|
||||
(or (lmem? x) (literal@? x))))
|
||||
|
||||
(define fpmem?
|
||||
(lambda (x)
|
||||
(nanopass-case (L15c Triv) x
|
||||
[(mref ,lvalue0 ,lvalue1 ,imm ,type) (eq? type 'fp)]
|
||||
[else #f])))
|
||||
|
||||
(define-syntax mem-of-type?
|
||||
(lambda (stx)
|
||||
(syntax-case stx (mem fpmem)
|
||||
[(_ mem e) #'(lmem? e)]
|
||||
[(_ fpmem e) #'(fpmem? e)])))
|
||||
|
||||
(define real-imm32?
|
||||
(lambda (x)
|
||||
(nanopass-case (L15c Triv) x
|
||||
|
|
@ -95,15 +71,6 @@
|
|||
[(immediate ,imm) (<= #x-7FFFFFFF imm #x7FFFFFFF)]
|
||||
[else #f])))
|
||||
|
||||
(define lvalue->ur
|
||||
(lambda (x k)
|
||||
(if (mref? x)
|
||||
(let ([u (make-tmp 'u)])
|
||||
(seq
|
||||
(set-ur=mref u x)
|
||||
(k u)))
|
||||
(k x))))
|
||||
|
||||
(define literal@->mem
|
||||
(lambda (a k)
|
||||
(nanopass-case (L15c Triv) a
|
||||
|
|
@ -127,20 +94,23 @@
|
|||
[(literal@? a) (literal@->mem a k)]
|
||||
[else (mref->mref a k)])))
|
||||
|
||||
(define fpmem->fpmem mem->mem)
|
||||
|
||||
;; `define-instruction` code takes care of `ur` and `fpur`, to which
|
||||
;; all type-compatible values must convert
|
||||
(define-syntax coercible?
|
||||
(syntax-rules ()
|
||||
[(_ ?a ?aty*)
|
||||
(let ([a ?a] [aty* ?aty*])
|
||||
(or (and (memq 'ur aty*) (not (or (fpmem? a) (fpur? a))))
|
||||
(and (memq 'fpur aty*) (or (fpmem? a) (fpur? a)))
|
||||
(or (and (memq 'imm32 aty*) (imm32? a))
|
||||
(and (memq 'imm aty*) (imm? a))
|
||||
(and (memq 'zero aty*) (imm0? a))
|
||||
(and (memq 'real-imm32 aty*) (real-imm32? a))
|
||||
(and (memq 'negatable-real-imm32 aty*) (negatable-real-imm32? a))
|
||||
(and (memq 'mem aty*) (mem? a))
|
||||
(and (memq 'fpmem aty*) (fpmem? a)))))]))
|
||||
(or (and (memq 'imm32 aty*) (imm32? a))
|
||||
(and (memq 'imm aty*) (imm? a))
|
||||
(and (memq 'zero aty*) (imm0? a))
|
||||
(and (memq 'real-imm32 aty*) (real-imm32? a))
|
||||
(and (memq 'negatable-real-imm32 aty*) (negatable-real-imm32? a))
|
||||
(and (memq 'mem aty*) (mem? a))
|
||||
(and (memq 'fpmem aty*) (fpmem? a))))]))
|
||||
|
||||
;; `define-instruction` doesn't try to cover `ur` and `fpur`
|
||||
(define-syntax coerce-opnd ; passes k something compatible with aty*
|
||||
(syntax-rules ()
|
||||
[(_ ?a ?aty* ?k)
|
||||
|
|
@ -183,12 +153,6 @@
|
|||
(sorry! 'coerce-opnd "unexpected operand ~s" a)])]
|
||||
[else (sorry! 'coerce-opnd "cannot coerce ~s to ~s" a aty*)]))]))
|
||||
|
||||
(define set-ur=mref
|
||||
(lambda (ur mref)
|
||||
(mref->mref mref
|
||||
(lambda (mref)
|
||||
(build-set! ,ur ,mref)))))
|
||||
|
||||
(define-who extract-imm
|
||||
(lambda (e)
|
||||
(nanopass-case (L15d Triv) e
|
||||
|
|
@ -217,311 +181,50 @@
|
|||
(with-output-language (L15d Effect) `(set! ,(make-live-info) ,tmp ,t))
|
||||
`(jump ,tmp)))]))))
|
||||
|
||||
(define-syntax define-instruction
|
||||
(lambda (x)
|
||||
(define acsame-mem
|
||||
(lambda (c a b bty* k)
|
||||
#`(lambda (c a b)
|
||||
(if (and (lmem? c) (same? a c) (coercible? b '#,bty*))
|
||||
(coerce-opnd b '#,bty*
|
||||
(lambda (b)
|
||||
(mem->mem c
|
||||
(lambda (c)
|
||||
(#,k c b)))))
|
||||
(next c a b)))))
|
||||
(define-syntax acsame-mem
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(_ orig c cty (b bty* ...) k)
|
||||
#'(mem->mem c
|
||||
(lambda (c)
|
||||
(k c b)))]
|
||||
[(_ orig c cty k)
|
||||
#'(mem->mem c
|
||||
(lambda (c)
|
||||
(k c)))])))
|
||||
|
||||
(define-who acsame-ur
|
||||
(lambda (c a b bty* k)
|
||||
#`(lambda (c a b)
|
||||
(if (and (same? a c) (coercible? b '#,bty*))
|
||||
(coerce-opnd b '#,bty*
|
||||
(lambda (b)
|
||||
(cond
|
||||
[(ur? c) (#,k c b)]
|
||||
[(mref? c)
|
||||
(nanopass-case (L15c Triv) c
|
||||
; NOTE: x86_64 and risc arch's will need to deal with limitations on the offset
|
||||
[(mref ,lvalue0 ,lvalue1 ,imm ,type)
|
||||
(lvalue->ur lvalue0
|
||||
(lambda (x0)
|
||||
(lvalue->ur lvalue1
|
||||
(lambda (x1)
|
||||
(let ([u (make-tmp 'u)])
|
||||
(seq
|
||||
(build-set! ,u (mref ,x0 ,x1 ,imm ,type))
|
||||
(#,k u b)
|
||||
(build-set! (mref ,x0 ,x1 ,imm ,type) ,u)))))))])]
|
||||
[else (sorry! '#,(datum->syntax #'* who) "unexpected operand ~s" c)])))
|
||||
(next c a b)))))
|
||||
|
||||
(define mem-type?
|
||||
(lambda (t)
|
||||
(syntax-case t (mem fpmem)
|
||||
[mem #t]
|
||||
[fpmem #t]
|
||||
[else #f])))
|
||||
|
||||
(define make-value-clause
|
||||
(lambda (fmt)
|
||||
(syntax-case fmt (mem ur fpur xp fpmem)
|
||||
[(op (c mem) (a ?c) (b bty* ...))
|
||||
(bound-identifier=? #'?c #'c)
|
||||
(acsame-mem #'c #'a #'b #'(bty* ...) #'(lambda (c b) (rhs c c b)))]
|
||||
[(op (c ur) (a ?c) (b bty* ...))
|
||||
(bound-identifier=? #'?c #'c)
|
||||
(acsame-ur #'c #'a #'b #'(bty* ...) #'(lambda (c b) (rhs c c b)))]
|
||||
[(op (c mem) (a aty* ...) (b ?c))
|
||||
(bound-identifier=? #'?c #'c)
|
||||
(acsame-mem #'c #'b #'a #'(aty* ...) #'(lambda (c a) (rhs c a c)))]
|
||||
[(op (c ur) (a aty* ...) (b ?c))
|
||||
(bound-identifier=? #'?c #'c)
|
||||
(acsame-ur #'c #'b #'a #'(aty* ...) #'(lambda (c a) (rhs c a c)))]
|
||||
[(op (c xmem) (a aty ...) (b bty ...))
|
||||
(mem-type? #'xmem)
|
||||
#`(lambda (c a b)
|
||||
(if (and (mem-of-type? xmem c) (coercible? a '(aty ...)) (coercible? b '(bty ...)))
|
||||
(coerce-opnd b '(bty ...)
|
||||
(lambda (b)
|
||||
(coerce-opnd a '(aty ...)
|
||||
(lambda (a)
|
||||
(mref->mref c (lambda (c) (rhs c a b)))))))
|
||||
(next c a b)))]
|
||||
[(op (c ur) (a aty ...) (b bty ...))
|
||||
#`(lambda (c a b)
|
||||
(if (and (coercible? a '(aty ...)) (coercible? b '(bty ...)))
|
||||
(coerce-opnd b '(bty ...)
|
||||
(lambda (b)
|
||||
(coerce-opnd a '(aty ...)
|
||||
(lambda (a)
|
||||
(if (ur? c)
|
||||
(rhs c a b)
|
||||
(let ([u (make-tmp 'u)])
|
||||
(seq
|
||||
(rhs u a b)
|
||||
(mref->mref c
|
||||
(lambda (c)
|
||||
(build-set! ,c ,u))))))))))
|
||||
(next c a b)))]
|
||||
[(op (c fpur) (a aty ...) (b bty ...))
|
||||
#`(lambda (c a b)
|
||||
(if (and (coercible? a '(aty ...)) (coercible? b '(bty ...)))
|
||||
(coerce-opnd b '(bty ...)
|
||||
(lambda (b)
|
||||
(coerce-opnd a '(aty ...)
|
||||
(lambda (a)
|
||||
(if (fpur? c)
|
||||
(rhs c a b)
|
||||
(let ([u (make-tmp 'u 'fp)])
|
||||
(seq
|
||||
(rhs u a b)
|
||||
(mref->mref c
|
||||
(lambda (c)
|
||||
(build-set! ,c ,u))))))))))
|
||||
(next c a b)))]
|
||||
; four-operand case below can require four unspillables
|
||||
[(op (c ur) (a ur) (b ur) (d dty ...))
|
||||
(not (memq 'mem (datum (dty ...))))
|
||||
#`(lambda (c a b d)
|
||||
(if (coercible? d '(dty ...))
|
||||
(coerce-opnd d '(dty ...)
|
||||
(lambda (d)
|
||||
(coerce-opnd a '(ur)
|
||||
(lambda (a)
|
||||
(coerce-opnd b '(ur)
|
||||
(lambda (b)
|
||||
(if (ur? c)
|
||||
(rhs c a b d)
|
||||
(let ([u (make-tmp 'u)])
|
||||
(seq
|
||||
(rhs u a b d)
|
||||
(mref->mref c
|
||||
(lambda (c)
|
||||
(build-set! ,c ,u))))))))))))
|
||||
(next c a b d)))]
|
||||
[(op (c mem) (a ?c))
|
||||
(bound-identifier=? #'?c #'c)
|
||||
#`(lambda (c a)
|
||||
(if (and (lmem? c) (same? c a))
|
||||
(mem->mem c
|
||||
(lambda (c)
|
||||
(rhs c c)))
|
||||
(next c a)))]
|
||||
[(op (c ur) (a ?c))
|
||||
(bound-identifier=? #'?c #'c)
|
||||
#`(lambda (c a)
|
||||
(if (same? a c)
|
||||
(if (ur? c)
|
||||
(rhs c c)
|
||||
(mem->mem c
|
||||
(lambda (c)
|
||||
(let ([u (make-tmp 'u)])
|
||||
(seq
|
||||
(build-set! ,u ,c)
|
||||
(rhs u u)
|
||||
(build-set! ,c ,u))))))
|
||||
(next c a)))]
|
||||
[(op (c xmem) (a aty ...))
|
||||
(mem-type? #'xmem)
|
||||
#`(lambda (c a)
|
||||
(if (and (mem-of-type? xmem c) (coercible? a '(aty ...)))
|
||||
(coerce-opnd a '(aty ...)
|
||||
(lambda (a)
|
||||
(mem->mem c
|
||||
(lambda (c)
|
||||
(rhs c a)))))
|
||||
(next c a)))]
|
||||
[(op (c ur) (a aty ...))
|
||||
#`(lambda (c a)
|
||||
(if (coercible? a '(aty ...))
|
||||
(coerce-opnd a '(aty ...)
|
||||
(lambda (a)
|
||||
(if (ur? c)
|
||||
(rhs c a)
|
||||
(mem->mem c
|
||||
(lambda (c)
|
||||
(let ([u (make-tmp 'u)])
|
||||
(seq
|
||||
(rhs u a)
|
||||
(build-set! ,c ,u))))))))
|
||||
(next c a)))]
|
||||
[(op (c fpur) (a aty ...))
|
||||
#`(lambda (c a)
|
||||
(if (coercible? a '(aty ...))
|
||||
(coerce-opnd a '(aty ...)
|
||||
(lambda (a)
|
||||
(if (fpur? c)
|
||||
(rhs c a)
|
||||
(mem->mem c
|
||||
(lambda (c)
|
||||
(let ([u (make-tmp 'u 'fp)])
|
||||
(seq
|
||||
(rhs u a)
|
||||
(build-set! ,c ,u))))))))
|
||||
(next c a)))]
|
||||
[(op (c ur))
|
||||
#`(lambda (c)
|
||||
(if (ur? c)
|
||||
(rhs c)
|
||||
(mem->mem c
|
||||
(lambda (c)
|
||||
(let ([u (make-tmp 'u)])
|
||||
(seq
|
||||
(rhs u)
|
||||
(build-set! ,c ,u)))))))]
|
||||
[(op (c mem))
|
||||
#`(lambda (c)
|
||||
(if (lmem? c)
|
||||
(mem->mem c
|
||||
(lambda (c)
|
||||
(rhs c)))
|
||||
(next c)))]
|
||||
[(op (c fpur))
|
||||
#`(lambda (c)
|
||||
(if (fpur? c)
|
||||
(rhs c)
|
||||
(let ([u (make-tmp 'u 'fp)])
|
||||
(seq
|
||||
(rhs u)
|
||||
(mref->mref c
|
||||
(lambda (c)
|
||||
(build-set! ,c ,u)))))))]
|
||||
[(op (c fpmem))
|
||||
#`(lambda (c)
|
||||
(if (fpmem? c)
|
||||
(mem->mem c
|
||||
(lambda (c)
|
||||
(rhs c)))
|
||||
(next c)))])))
|
||||
|
||||
(define-who make-pred-clause
|
||||
(lambda (fmt)
|
||||
(syntax-case fmt ()
|
||||
[(op (a aty ...) ...)
|
||||
#`(lambda (a ...)
|
||||
(if (and (coercible? a '(aty ...)) ...)
|
||||
#,(let f ([a* #'(a ...)] [aty** #'((aty ...) ...)])
|
||||
(if (null? a*)
|
||||
#'(rhs a ...)
|
||||
#`(coerce-opnd #,(car a*) '#,(car aty**)
|
||||
(lambda (#,(car a*)) #,(f (cdr a*) (cdr aty**))))))
|
||||
(next a ...)))])))
|
||||
|
||||
(define-who make-effect-clause
|
||||
(lambda (fmt)
|
||||
(syntax-case fmt ()
|
||||
[(op (a aty ...) ...)
|
||||
#`(lambda (a ...)
|
||||
(if (and (coercible? a '(aty ...)) ...)
|
||||
#,(let f ([a* #'(a ...)] [aty** #'((aty ...) ...)])
|
||||
(if (null? a*)
|
||||
#'(rhs a ...)
|
||||
#`(coerce-opnd #,(car a*) '#,(car aty**)
|
||||
(lambda (#,(car a*)) #,(f (cdr a*) (cdr aty**))))))
|
||||
(next a ...)))])))
|
||||
|
||||
(syntax-case x (definitions)
|
||||
[(k context (sym ...) (definitions defn ...) [(op (a aty ...) ...) ?rhs0 ?rhs1 ...] ...)
|
||||
; potentially unnecessary level of checking, but the big thing is to make sure
|
||||
; the number of operands expected is the same on every clause of define-intruction
|
||||
(and (not (null? #'(op ...)))
|
||||
(andmap identifier? #'(sym ...))
|
||||
(andmap identifier? #'(op ...))
|
||||
(andmap identifier? #'(a ... ...))
|
||||
(andmap identifier? #'(aty ... ... ...)))
|
||||
(with-implicit (k info return with-output-language)
|
||||
(with-syntax ([((opnd* ...) . ignore) #'((a ...) ...)])
|
||||
(define make-proc
|
||||
(lambda (make-clause)
|
||||
(let f ([op* #'(op ...)]
|
||||
[fmt* #'((op (a aty ...) ...) ...)]
|
||||
[arg* #'((a ...) ...)]
|
||||
[rhs* #'((?rhs0 ?rhs1 ...) ...)])
|
||||
(if (null? op*)
|
||||
#'(lambda (opnd* ...)
|
||||
(sorry! name "no match found for ~s" (list opnd* ...)))
|
||||
#`(let ([next #,(f (cdr op*) (cdr fmt*) (cdr arg*) (cdr rhs*))]
|
||||
[rhs (lambda #,(car arg*)
|
||||
(let ([#,(car op*) name])
|
||||
#,@(car rhs*)))])
|
||||
#,(make-clause (car fmt*)))))))
|
||||
(unless (let ([a** #'((a ...) ...)])
|
||||
(let* ([a* (car a**)] [len (length a*)])
|
||||
(andmap (lambda (a*) (fx= (length a*) len)) (cdr a**))))
|
||||
(syntax-error x "mismatched instruction arities"))
|
||||
(cond
|
||||
[(free-identifier=? #'context #'value)
|
||||
#`(let ([fvalue (lambda (name)
|
||||
(lambda (info opnd* ...)
|
||||
defn ...
|
||||
(with-output-language (L15d Effect)
|
||||
(#,(make-proc make-value-clause) opnd* ...))))])
|
||||
(begin
|
||||
(safe-assert (eq? (primitive-type (%primitive sym)) 'value))
|
||||
(primitive-handler-set! (%primitive sym) (fvalue 'sym)))
|
||||
...)]
|
||||
[(free-identifier=? #'context #'pred)
|
||||
#`(let ([fpred (lambda (name)
|
||||
(lambda (info opnd* ...)
|
||||
defn ...
|
||||
(with-output-language (L15d Pred)
|
||||
(#,(make-proc make-pred-clause) opnd* ...))))])
|
||||
(begin
|
||||
(safe-assert (eq? (primitive-type (%primitive sym)) 'pred))
|
||||
(primitive-handler-set! (%primitive sym) (fpred 'sym)))
|
||||
...)]
|
||||
[(free-identifier=? #'context #'effect)
|
||||
#`(let ([feffect (lambda (name)
|
||||
(lambda (info opnd* ...)
|
||||
defn ...
|
||||
(with-output-language (L15d Effect)
|
||||
(#,(make-proc make-effect-clause) opnd* ...))))])
|
||||
(begin
|
||||
(safe-assert (eq? (primitive-type (%primitive sym)) 'effect))
|
||||
(primitive-handler-set! (%primitive sym) (feffect 'sym)))
|
||||
...)]
|
||||
[else (syntax-error #'context "unrecognized context")])))]
|
||||
[(k context (sym ...) cl ...) #'(k context (sym ...) (definitions) cl ...)]
|
||||
[(k context sym cl ...) (identifier? #'sym) #'(k context (sym) (definitions) cl ...)])))
|
||||
(define-syntax acsame-ur
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(moi orig c cty (b bty* ...) k)
|
||||
#`(cond
|
||||
[(ur? c) (k c b)]
|
||||
[(lmem? c)
|
||||
(nanopass-case (L15c Triv) c
|
||||
[(mref ,lvalue0 ,lvalue1 ,imm ,type)
|
||||
(lvalue->ur
|
||||
lvalue0
|
||||
(lambda (x0)
|
||||
(lvalue->ur
|
||||
lvalue1
|
||||
(lambda (x1)
|
||||
(let ([u (make-tmp 'u)])
|
||||
(seq
|
||||
(build-set! ,u (mref ,x0 ,x1 ,imm ,type))
|
||||
(k u b)
|
||||
(build-set! (mref ,x0 ,x1 ,imm ,type) ,u)))))))])]
|
||||
;; can't be literal@ since literals can't be lvalues
|
||||
[else (sorry! 'moi "unexpected operand ~s" c)])]
|
||||
[(moi orig c cty k)
|
||||
#`(if (ur? c)
|
||||
(k c)
|
||||
(mem->mem c
|
||||
(lambda (c)
|
||||
(let ([u (make-tmp 'u)])
|
||||
(seq
|
||||
(build-set! ,u ,c)
|
||||
(k u)
|
||||
(build-set! ,c ,u))))))])))
|
||||
|
||||
; x is not the same as z in any clause that follows a clause where (x z)
|
||||
; and y is coercible to one of its types, however:
|
||||
|
|
@ -1044,8 +747,7 @@
|
|||
asm-mul asm-muli asm-addop asm-add asm-sub asm-negate asm-sub-negate
|
||||
asm-pop asm-shiftop asm-sll asm-logand asm-lognot
|
||||
asm-logtest asm-fp-relop asm-relop asm-push asm-indirect-jump asm-literal-jump
|
||||
asm-direct-jump asm-return-address asm-jump asm-conditional-jump asm-data-label
|
||||
asm-rp-header asm-rp-compact-header
|
||||
asm-direct-jump asm-return-address asm-jump asm-conditional-jump
|
||||
asm-lea1 asm-lea2 asm-indirect-call asm-fstpl asm-fstps asm-fldl asm-flds asm-condition-code
|
||||
asm-fl-cvt asm-store-single asm-fpt asm-fptrunc asm-div
|
||||
asm-exchange asm-pause asm-locked-incr asm-locked-decr asm-locked-cmpxchg
|
||||
|
|
@ -2443,51 +2145,6 @@
|
|||
; inverted: !(fl= x y) iff zf = 0 or cf (or pf) = 1
|
||||
[(fp=) (or bne bcs)]))))))
|
||||
|
||||
(define asm-data-label
|
||||
(lambda (code* l offset func code-size)
|
||||
(let ([rel (make-funcrel 'abs l offset)])
|
||||
(cons* rel (aop-cons* `(asm "mrv point:" ,rel) code*)))))
|
||||
|
||||
(define asm-rp-header
|
||||
(let ([mrv-error `(abs ,(constant code-data-disp)
|
||||
(library-code ,(lookup-libspec values-error)))])
|
||||
(lambda (code* mrvl fs lpm func code-size)
|
||||
(let* ([code* (cons* `(long . ,fs)
|
||||
(aop-cons* `(asm "frame size:" ,fs)
|
||||
code*))]
|
||||
[code* (cons* (if (target-fixnum? lpm)
|
||||
`(long . ,(fix lpm))
|
||||
`(abs 0 (object ,lpm)))
|
||||
(aop-cons* `(asm livemask: ,(format "~b" lpm))
|
||||
code*))]
|
||||
[code* (if mrvl
|
||||
(asm-data-label code* mrvl 0 func code-size)
|
||||
(cons*
|
||||
mrv-error
|
||||
(aop-cons* `(asm "mrv point:" ,mrv-error)
|
||||
code*)))]
|
||||
[code* (cons*
|
||||
'(code-top-link)
|
||||
(aop-cons* `(asm code-top-link)
|
||||
code*))])
|
||||
code*))))
|
||||
|
||||
(define asm-rp-compact-header
|
||||
(lambda (code* err? fs lpm func code-size)
|
||||
(let* ([code* (cons* `(long . ,(fxior (constant compact-header-mask)
|
||||
(if err?
|
||||
(constant compact-header-values-error-mask)
|
||||
0)
|
||||
(fxsll fs (constant compact-frame-words-offset))
|
||||
(fxsll lpm (constant compact-frame-mask-offset))))
|
||||
(aop-cons* `(asm "mrv pt:" (,lpm ,fs ,(if err? 'error 'continue)))
|
||||
code*))]
|
||||
[code* (cons*
|
||||
'(code-top-link)
|
||||
(aop-cons* `(asm code-top-link)
|
||||
code*))])
|
||||
code*)))
|
||||
|
||||
(constant-case machine-type-name
|
||||
[(i3nt ti3nt) (define asm-enter values)]
|
||||
[else
|
||||
|
|
|
|||
475
s/x86_64.ss
475
s/x86_64.ss
|
|
@ -79,39 +79,15 @@
|
|||
[%sp #t 4 uptr])))
|
||||
|
||||
;;; SECTION 2: instructions
|
||||
(module (md-handle-jump) ; also sets primitive handlers
|
||||
(module (md-handle-jump ; also sets primitive handlers
|
||||
mem->mem
|
||||
fpmem->fpmem
|
||||
coercible?
|
||||
coerce-opnd
|
||||
acsame-mem
|
||||
acsame-ur)
|
||||
(import asm-module)
|
||||
|
||||
(define-syntax seq
|
||||
(lambda (x)
|
||||
(syntax-case x ()
|
||||
[(_ e ... ex)
|
||||
(with-syntax ([(t ...) (generate-temporaries #'(e ...))])
|
||||
#'(let ([t e] ...)
|
||||
(with-values ex
|
||||
(case-lambda
|
||||
[(x*) (cons* t ... x*)]
|
||||
[(x* p) (values (cons* t ... x*) p)]))))])))
|
||||
|
||||
; don't bother with literal@? check since lvalues can't be literals
|
||||
(define lmem? mref?)
|
||||
|
||||
(define mem?
|
||||
(lambda (x)
|
||||
(or (lmem? x) (literal@? x))))
|
||||
|
||||
(define fpmem?
|
||||
(lambda (x)
|
||||
(nanopass-case (L15c Triv) x
|
||||
[(mref ,lvalue0 ,lvalue1 ,imm ,type) (eq? type 'fp)]
|
||||
[else #f])))
|
||||
|
||||
(define-syntax mem-of-type?
|
||||
(lambda (stx)
|
||||
(syntax-case stx (mem fpmem)
|
||||
[(_ mem e) #'(lmem? e)]
|
||||
[(_ fpmem e) #'(fpmem? e)])))
|
||||
|
||||
(define real-imm32?
|
||||
(lambda (x)
|
||||
(nanopass-case (L15c Triv) x
|
||||
|
|
@ -127,16 +103,6 @@
|
|||
[(immediate ,imm) (<= #x-7FFFFFFF imm #x7FFFFFFF)]
|
||||
[else #f])))
|
||||
|
||||
(define lvalue->ur
|
||||
(lambda (x k)
|
||||
(safe-assert (not (fpmem? x)))
|
||||
(if (mref? x)
|
||||
(let ([u (make-tmp 'u)])
|
||||
(seq
|
||||
(set-ur=mref u x)
|
||||
(k u)))
|
||||
(k x))))
|
||||
|
||||
(define mref->mref
|
||||
(lambda (a k)
|
||||
(define return
|
||||
|
|
@ -169,25 +135,23 @@
|
|||
(k (with-output-language (L15d Lvalue) `(mref ,u ,%zero 0 ptr)))))]
|
||||
[else (mref->mref a k)])))
|
||||
|
||||
(define literal->literal
|
||||
(lambda (a)
|
||||
(nanopass-case (L15c Triv) a
|
||||
[(literal ,info) (with-output-language (L15d Triv) `(literal ,info))])))
|
||||
(define fpmem->fpmem mem->mem)
|
||||
|
||||
;; `define-instruction` code takes care of `ur` and `fpur`, to which
|
||||
;; all type-compatible values must convert
|
||||
(define-syntax coercible?
|
||||
(syntax-rules ()
|
||||
[(_ ?a ?aty*)
|
||||
(let ([a ?a] [aty* ?aty*])
|
||||
(or (and (memq 'ur aty*) (not (or (fpmem? a) (fpur? a))))
|
||||
(and (memq 'fpur aty*) (or (fpmem? a) (fpur? a)))
|
||||
(or (and (memq 'imm32 aty*) (imm32? a))
|
||||
(and (memq 'imm aty*) (imm? a))
|
||||
(and (memq 'zero aty*) (imm0? a))
|
||||
(and (memq 'real-imm32 aty*) (real-imm32? a))
|
||||
(and (memq 'negatable-real-imm32 aty*) (negatable-real-imm32? a))
|
||||
(and (memq 'mem aty*) (mem? a))
|
||||
(and (memq 'fpmem aty*) (fpmem? a)))))]))
|
||||
(or (and (memq 'imm32 aty*) (imm32? a))
|
||||
(and (memq 'imm aty*) (imm? a))
|
||||
(and (memq 'zero aty*) (imm0? a))
|
||||
(and (memq 'real-imm32 aty*) (real-imm32? a))
|
||||
(and (memq 'negatable-real-imm32 aty*) (negatable-real-imm32? a))
|
||||
(and (memq 'mem aty*) (mem? a))
|
||||
(and (memq 'fpmem aty*) (fpmem? a))))]))
|
||||
|
||||
;; `define-instruction` doesn't try to cover `ur` and `fpur`
|
||||
(define-syntax coerce-opnd ; passes k something compatible with aty*
|
||||
(syntax-rules ()
|
||||
[(_ ?a ?aty* ?k)
|
||||
|
|
@ -230,12 +194,6 @@
|
|||
(sorry! 'coerce-opnd "unexpected operand ~s" a)])]
|
||||
[else (sorry! 'coerce-opnd "cannot coerce ~s to ~s" a aty*)]))]))
|
||||
|
||||
(define set-ur=mref
|
||||
(lambda (ur mref)
|
||||
(mref->mref mref
|
||||
(lambda (mref)
|
||||
(build-set! ,ur ,mref)))))
|
||||
|
||||
(define-who extract-imm
|
||||
(lambda (e)
|
||||
(nanopass-case (L15d Triv) e
|
||||
|
|
@ -264,304 +222,59 @@
|
|||
(with-output-language (L15d Effect) `(set! ,(make-live-info) ,tmp ,t))
|
||||
`(jump ,tmp)))]))))
|
||||
|
||||
(define-syntax define-instruction
|
||||
(lambda (x)
|
||||
(define acsame-mem
|
||||
(lambda (c a b bty* k)
|
||||
#`(lambda (c a b)
|
||||
(if (and (lmem? c) (same? a c) (coercible? b '#,bty*))
|
||||
(coerce-opnd b '#,bty*
|
||||
(lambda (b)
|
||||
(mem->mem c
|
||||
(lambda (c)
|
||||
(#,k c b)))))
|
||||
(next c a b)))))
|
||||
(define-syntax acsame-mem
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(_ orig c cty (b bty* ...) k)
|
||||
#'(mem->mem c
|
||||
(lambda (c)
|
||||
(k c b)))]
|
||||
[(_ orig c cty k)
|
||||
#'(mem->mem c
|
||||
(lambda (c)
|
||||
(k c)))])))
|
||||
|
||||
(define-who acsame-ur
|
||||
(lambda (c a b bty* k)
|
||||
#`(lambda (c a b)
|
||||
(if (and (same? a c) (coercible? b '#,bty*))
|
||||
(coerce-opnd b '#,bty*
|
||||
(lambda (b)
|
||||
(cond
|
||||
[(ur? c) (#,k c b)]
|
||||
[(mref? c)
|
||||
(nanopass-case (L15c Triv) c
|
||||
[(mref ,lvalue0 ,lvalue1 ,imm ,type)
|
||||
; TODO: does this use too many registers? (no longer special casing fv x0, x1 case)
|
||||
(lvalue->ur lvalue0
|
||||
(lambda (x0)
|
||||
(lvalue->ur lvalue1
|
||||
(lambda (x1)
|
||||
(let ([u1 (make-tmp 'u)])
|
||||
(if (signed-32? imm)
|
||||
(seq
|
||||
(build-set! ,u1 (mref ,x0 ,x1 ,imm ,type))
|
||||
(#,k u1 b)
|
||||
(build-set! (mref ,x0 ,x1 ,imm ,type) ,u1))
|
||||
(let ([u2 (make-tmp 'u)])
|
||||
(seq
|
||||
(build-set! ,u2 ,imm)
|
||||
(build-set! ,x1 (asm ,null-info ,asm-add ,x1 ,u2))
|
||||
(build-set! ,u1 (mref ,x0 ,x1 0 ,type))
|
||||
(#,k u1 b)
|
||||
(build-set! (mref ,x0 ,x1 0 ,type) ,u1)))))))))])]
|
||||
; can't be literal@ since literals can't be lvalues
|
||||
[else (sorry! '#,(datum->syntax #'* who) "unexpected operand ~s" c)])))
|
||||
(next c a b)))))
|
||||
|
||||
(define mem-type?
|
||||
(lambda (t)
|
||||
(syntax-case t (mem fpmem)
|
||||
[mem #t]
|
||||
[fpmem #t]
|
||||
[else #f])))
|
||||
|
||||
(define make-value-clause
|
||||
(lambda (fmt)
|
||||
(syntax-case fmt (mem fpmem ur fpur xp)
|
||||
[(op (c mem) (a ?c) (b bty* ...))
|
||||
(bound-identifier=? #'?c #'c)
|
||||
(acsame-mem #'c #'a #'b #'(bty* ...) #'(lambda (c b) (rhs c c b)))]
|
||||
[(op (c ur) (a ?c) (b bty* ...))
|
||||
(bound-identifier=? #'?c #'c)
|
||||
(acsame-ur #'c #'a #'b #'(bty* ...) #'(lambda (c b) (rhs c c b)))]
|
||||
[(op (c mem) (a aty* ...) (b ?c))
|
||||
(bound-identifier=? #'?c #'c)
|
||||
(acsame-mem #'c #'b #'a #'(aty* ...) #'(lambda (c a) (rhs c a c)))]
|
||||
[(op (c ur) (a aty* ...) (b ?c))
|
||||
(bound-identifier=? #'?c #'c)
|
||||
(acsame-ur #'c #'b #'a #'(aty* ...) #'(lambda (c a) (rhs c a c)))]
|
||||
[(op (c xmem) (a aty ...) (b bty ...))
|
||||
(mem-type? #'xmem)
|
||||
#`(lambda (c a b)
|
||||
(if (and (mem-of-type? xmem c) (coercible? a '(aty ...)) (coercible? b '(bty ...)))
|
||||
(coerce-opnd b '(bty ...)
|
||||
(lambda (b)
|
||||
(coerce-opnd a '(aty ...)
|
||||
(lambda (a)
|
||||
(mref->mref c (lambda (c) (rhs c a b)))))))
|
||||
(next c a b)))]
|
||||
[(op (c ur) (a aty ...) (b bty ...))
|
||||
#`(lambda (c a b)
|
||||
(if (and (coercible? a '(aty ...)) (coercible? b '(bty ...)))
|
||||
(coerce-opnd b '(bty ...)
|
||||
(lambda (b)
|
||||
(coerce-opnd a '(aty ...)
|
||||
(lambda (a)
|
||||
(if (ur? c)
|
||||
(rhs c a b)
|
||||
(let ([u (make-tmp 'u)])
|
||||
(seq
|
||||
(rhs u a b)
|
||||
(mref->mref c
|
||||
(lambda (c)
|
||||
(build-set! ,c ,u))))))))))
|
||||
(next c a b)))]
|
||||
[(op (c fpur) (a aty ...) (b bty ...))
|
||||
#`(lambda (c a b)
|
||||
(if (and (coercible? a '(aty ...)) (coercible? b '(bty ...)))
|
||||
(coerce-opnd b '(bty ...)
|
||||
(lambda (b)
|
||||
(coerce-opnd a '(aty ...)
|
||||
(lambda (a)
|
||||
(if (fpur? c)
|
||||
(rhs c a b)
|
||||
(let ([u (make-tmp 'u 'fp)])
|
||||
(seq
|
||||
(rhs u a b)
|
||||
(mref->mref c
|
||||
(lambda (c)
|
||||
(build-set! ,c ,u))))))))))
|
||||
(next c a b)))]
|
||||
; four-operand case below can require four unspillables
|
||||
[(op (c ur) (a ur) (b ur) (d dty ...))
|
||||
(not (memq 'mem (datum (dty ...))))
|
||||
#`(lambda (c a b d)
|
||||
(if (coercible? d '(dty ...))
|
||||
(coerce-opnd d '(dty ...)
|
||||
(lambda (d)
|
||||
(coerce-opnd a '(ur)
|
||||
(lambda (a)
|
||||
(coerce-opnd b '(ur)
|
||||
(lambda (b)
|
||||
(if (ur? c)
|
||||
(rhs c a b d)
|
||||
(let ([u (make-tmp 'u)])
|
||||
(seq
|
||||
(rhs u a b d)
|
||||
(mref->mref c
|
||||
(lambda (c)
|
||||
(build-set! ,c ,u))))))))))))
|
||||
(next c a b d)))]
|
||||
[(op (c mem) (a ?c))
|
||||
(bound-identifier=? #'?c #'c)
|
||||
#`(lambda (c a)
|
||||
(if (and (lmem? c) (same? c a))
|
||||
(mem->mem c
|
||||
(lambda (c)
|
||||
(rhs c c)))
|
||||
(next c a)))]
|
||||
[(op (c ur) (a ?c))
|
||||
(bound-identifier=? #'?c #'c)
|
||||
#`(lambda (c a)
|
||||
(if (same? a c)
|
||||
(if (ur? c)
|
||||
(rhs c c)
|
||||
(mem->mem c
|
||||
(lambda (c)
|
||||
(let ([u (make-tmp 'u)])
|
||||
(define-syntax acsame-ur
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(moi orig c cty (b bty* ...) k)
|
||||
#`(cond
|
||||
[(ur? c) (k c b)]
|
||||
[(lmem? c)
|
||||
(nanopass-case (L15c Triv) c
|
||||
[(mref ,lvalue0 ,lvalue1 ,imm ,type)
|
||||
;; TODO: does this use too many registers? (no longer special casing fv x0, x1 case)
|
||||
(lvalue->ur
|
||||
lvalue0
|
||||
(lambda (x0)
|
||||
(lvalue->ur
|
||||
lvalue1
|
||||
(lambda (x1)
|
||||
(let ([u1 (make-tmp 'u)])
|
||||
(if (signed-32? imm)
|
||||
(seq
|
||||
(build-set! ,u1 (mref ,x0 ,x1 ,imm ,type))
|
||||
(k u1 b)
|
||||
(build-set! (mref ,x0 ,x1 ,imm ,type) ,u1))
|
||||
(let ([u2 (make-tmp 'u)])
|
||||
(seq
|
||||
(build-set! ,u ,c)
|
||||
(rhs u u)
|
||||
(build-set! ,c ,u))))))
|
||||
(next c a)))]
|
||||
[(op (c xmem) (a aty ...))
|
||||
(mem-type? #'xmem)
|
||||
#`(lambda (c a)
|
||||
(if (and (mem-of-type? xmem c) (coercible? a '(aty ...)))
|
||||
(coerce-opnd a '(aty ...)
|
||||
(lambda (a)
|
||||
(mem->mem c
|
||||
(lambda (c)
|
||||
(rhs c a)))))
|
||||
(next c a)))]
|
||||
[(op (c ur) (a aty ...))
|
||||
#`(lambda (c a)
|
||||
(if (coercible? a '(aty ...))
|
||||
(coerce-opnd a '(aty ...)
|
||||
(lambda (a)
|
||||
(if (ur? c)
|
||||
(rhs c a)
|
||||
(mem->mem c
|
||||
(lambda (c)
|
||||
(let ([u (make-tmp 'u)])
|
||||
(seq
|
||||
(rhs u a)
|
||||
(build-set! ,c ,u))))))))
|
||||
(next c a)))]
|
||||
[(op (c fpur) (a aty ...))
|
||||
#`(lambda (c a)
|
||||
(if (coercible? a '(aty ...))
|
||||
(coerce-opnd a '(aty ...)
|
||||
(lambda (a)
|
||||
(if (fpur? c)
|
||||
(rhs c a)
|
||||
(mem->mem c
|
||||
(lambda (c)
|
||||
(let ([u (make-tmp 'u 'fp)])
|
||||
(seq
|
||||
(rhs u a)
|
||||
(build-set! ,c ,u))))))))
|
||||
(next c a)))]
|
||||
[(op (c ur))
|
||||
#`(lambda (c)
|
||||
(if (ur? c)
|
||||
(rhs c)
|
||||
(mem->mem c
|
||||
(lambda (c)
|
||||
(let ([u (make-tmp 'u)])
|
||||
(seq
|
||||
(rhs u)
|
||||
(build-set! ,c ,u)))))))]
|
||||
[(op (c xmem))
|
||||
(mem-type? #'xmem)
|
||||
#`(lambda (c)
|
||||
(if (mem-of-type? xmem c)
|
||||
(mem->mem c
|
||||
(lambda (c)
|
||||
(rhs c)))
|
||||
(next c)))])))
|
||||
|
||||
(define-who make-pred-clause
|
||||
(lambda (fmt)
|
||||
(syntax-case fmt ()
|
||||
[(op (a aty ...) ...)
|
||||
#`(lambda (a ...)
|
||||
(if (and (coercible? a '(aty ...)) ...)
|
||||
#,(let f ([a* #'(a ...)] [aty** #'((aty ...) ...)])
|
||||
(if (null? a*)
|
||||
#'(rhs a ...)
|
||||
#`(coerce-opnd #,(car a*) '#,(car aty**)
|
||||
(lambda (#,(car a*)) #,(f (cdr a*) (cdr aty**))))))
|
||||
(next a ...)))])))
|
||||
|
||||
(define-who make-effect-clause
|
||||
(lambda (fmt)
|
||||
(syntax-case fmt ()
|
||||
[(op (a aty ...) ...)
|
||||
#`(lambda (a ...)
|
||||
(if (and (coercible? a '(aty ...)) ...)
|
||||
#,(let f ([a* #'(a ...)] [aty** #'((aty ...) ...)])
|
||||
(if (null? a*)
|
||||
#'(rhs a ...)
|
||||
#`(coerce-opnd #,(car a*) '#,(car aty**)
|
||||
(lambda (#,(car a*)) #,(f (cdr a*) (cdr aty**))))))
|
||||
(next a ...)))])))
|
||||
|
||||
(syntax-case x (definitions)
|
||||
[(k context (sym ...) (definitions defn ...) [(op (a aty ...) ...) ?rhs0 ?rhs1 ...] ...)
|
||||
; potentially unnecessary level of checking, but the big thing is to make sure
|
||||
; the number of operands expected is the same on every clause of define-intruction
|
||||
(and (not (null? #'(op ...)))
|
||||
(andmap identifier? #'(sym ...))
|
||||
(andmap identifier? #'(op ...))
|
||||
(andmap identifier? #'(a ... ...))
|
||||
(andmap identifier? #'(aty ... ... ...)))
|
||||
(with-implicit (k info return with-output-language)
|
||||
(with-syntax ([((opnd* ...) . ignore) #'((a ...) ...)])
|
||||
(define make-proc
|
||||
(lambda (make-clause)
|
||||
(let f ([op* #'(op ...)]
|
||||
[fmt* #'((op (a aty ...) ...) ...)]
|
||||
[arg* #'((a ...) ...)]
|
||||
[rhs* #'((?rhs0 ?rhs1 ...) ...)])
|
||||
(if (null? op*)
|
||||
#'(lambda (opnd* ...)
|
||||
(sorry! name "no match found for ~s" (list opnd* ...)))
|
||||
#`(let ([next #,(f (cdr op*) (cdr fmt*) (cdr arg*) (cdr rhs*))]
|
||||
[rhs (lambda #,(car arg*)
|
||||
(let ([#,(car op*) name])
|
||||
#,@(car rhs*)))])
|
||||
#,(make-clause (car fmt*)))))))
|
||||
(unless (let ([a** #'((a ...) ...)])
|
||||
(let* ([a* (car a**)] [len (length a*)])
|
||||
(andmap (lambda (a*) (fx= (length a*) len)) (cdr a**))))
|
||||
(syntax-error x "mismatched instruction arities"))
|
||||
(cond
|
||||
[(free-identifier=? #'context #'value)
|
||||
#`(let ([fvalue (lambda (name)
|
||||
(lambda (info opnd* ...)
|
||||
defn ...
|
||||
(with-output-language (L15d Effect)
|
||||
(#,(make-proc make-value-clause) opnd* ...))))])
|
||||
(begin
|
||||
(safe-assert (eq? (primitive-type (%primitive sym)) 'value))
|
||||
(primitive-handler-set! (%primitive sym) (fvalue 'sym)))
|
||||
...)]
|
||||
[(free-identifier=? #'context #'pred)
|
||||
#`(let ([fpred (lambda (name)
|
||||
(lambda (info opnd* ...)
|
||||
defn ...
|
||||
(with-output-language (L15d Pred)
|
||||
(#,(make-proc make-pred-clause) opnd* ...))))])
|
||||
(begin
|
||||
(safe-assert (eq? (primitive-type (%primitive sym)) 'pred))
|
||||
(primitive-handler-set! (%primitive sym) (fpred 'sym)))
|
||||
...)]
|
||||
[(free-identifier=? #'context #'effect)
|
||||
#`(let ([feffect (lambda (name)
|
||||
(lambda (info opnd* ...)
|
||||
defn ...
|
||||
(with-output-language (L15d Effect)
|
||||
(#,(make-proc make-effect-clause) opnd* ...))))])
|
||||
(begin
|
||||
(safe-assert (eq? (primitive-type (%primitive sym)) 'effect))
|
||||
(primitive-handler-set! (%primitive sym) (feffect 'sym)))
|
||||
...)]
|
||||
[else (syntax-error #'context "unrecognized context")])))]
|
||||
[(k context (sym ...) cl ...) #'(k context (sym ...) (definitions) cl ...)]
|
||||
[(k context sym cl ...) (identifier? #'sym) #'(k context (sym) (definitions) cl ...)])))
|
||||
(build-set! ,u2 ,imm)
|
||||
(build-set! ,x1 (asm ,null-info ,asm-add ,x1 ,u2))
|
||||
(build-set! ,u1 (mref ,x0 ,x1 0 ,type))
|
||||
(k u1 b)
|
||||
(build-set! (mref ,x0 ,x1 0 ,type) ,u1)))))))))])]
|
||||
;; can't be literal@ since literals can't be lvalues
|
||||
[else (sorry! 'moi "unexpected operand ~s" c)])]
|
||||
[(moi orig c cty k)
|
||||
#`(if (ur? c)
|
||||
(k c)
|
||||
(mem->mem c
|
||||
(lambda (c)
|
||||
(let ([u (make-tmp 'u)])
|
||||
(seq
|
||||
(build-set! ,u ,c)
|
||||
(k u)
|
||||
(build-set! ,c ,u))))))])))
|
||||
|
||||
; x is not the same as z in any clause that follows a clause where (x z)
|
||||
; and y is coercible to one of its types, however:
|
||||
|
|
@ -1117,8 +830,7 @@
|
|||
asm-mul asm-muli asm-addop asm-add asm-sub asm-negate asm-sub-negate
|
||||
asm-pop asm-shiftop asm-sll asm-logand asm-lognot
|
||||
asm-logtest asm-fp-relop asm-relop asm-push asm-indirect-jump asm-literal-jump
|
||||
asm-direct-jump asm-return-address asm-jump asm-conditional-jump asm-data-label
|
||||
asm-rp-header asm-rp-compact-header
|
||||
asm-direct-jump asm-return-address asm-jump asm-conditional-jump
|
||||
asm-lea1 asm-lea2 asm-indirect-call asm-condition-code
|
||||
asm-fl-cvt asm-store-single asm-load-single asm-fpt asm-fptrunc asm-div asm-popcount
|
||||
asm-exchange asm-pause asm-locked-incr asm-locked-decr asm-locked-cmpxchg
|
||||
|
|
@ -2650,11 +2362,6 @@
|
|||
; inverted: !(fl= x y) iff zf = 0 or cf (or pf) = 1
|
||||
[(fp=) (or bne bcs)]))))))
|
||||
|
||||
(define asm-data-label
|
||||
(lambda (code* l offset func code-size)
|
||||
(let ([rel (make-funcrel 'abs l offset)])
|
||||
(cons* rel (aop-cons* `(asm "mrv point:" ,rel) code*)))))
|
||||
|
||||
(define asm-helper-jump
|
||||
(lambda (code* reloc)
|
||||
(let ([jmp-reg (cons 'reg %ts)])
|
||||
|
|
@ -2676,48 +2383,6 @@
|
|||
(lambda (code* reloc)
|
||||
(cons* reloc (aop-cons* `(asm "relocation:" ,reloc) code*))))
|
||||
|
||||
(define asm-rp-header
|
||||
(let ([mrv-error `(abs ,(constant code-data-disp)
|
||||
(library-code ,(lookup-libspec values-error)))])
|
||||
(lambda (code* mrvl fs lpm func code-size)
|
||||
(let ([size (constant-case ptr-bits [(32) 'long] [(64) 'quad])])
|
||||
(let* ([code* (cons* `(,size . ,fs)
|
||||
(aop-cons* `(asm "frame size:" ,fs)
|
||||
code*))]
|
||||
[code* (cons* (if (target-fixnum? lpm)
|
||||
`(,size . ,(fix lpm))
|
||||
`(abs 0 (object ,lpm)))
|
||||
(aop-cons* `(asm livemask: ,(format "~b" lpm))
|
||||
code*))]
|
||||
[code* (if mrvl
|
||||
(asm-data-label code* mrvl 0 func code-size)
|
||||
(cons*
|
||||
mrv-error
|
||||
(aop-cons* `(asm "mrv point:" ,mrv-error)
|
||||
code*)))]
|
||||
[code* (cons*
|
||||
'(code-top-link)
|
||||
(aop-cons* `(asm code-top-link)
|
||||
code*))])
|
||||
code*)))))
|
||||
|
||||
(define asm-rp-compact-header
|
||||
(lambda (code* err? fs lpm func code-size)
|
||||
(let ([size (constant-case ptr-bits [(32) 'long] [(64) 'quad])])
|
||||
(let* ([code* (cons* `(,size . ,(fxior (constant compact-header-mask)
|
||||
(if err?
|
||||
(constant compact-header-values-error-mask)
|
||||
0)
|
||||
(fxsll fs (constant compact-frame-words-offset))
|
||||
(fxsll lpm (constant compact-frame-mask-offset))))
|
||||
(aop-cons* `(asm "mrv pt:" (,lpm ,fs ,(if err? 'error 'continue)))
|
||||
code*))]
|
||||
[code* (cons*
|
||||
'(code-top-link)
|
||||
(aop-cons* `(asm code-top-link)
|
||||
code*))])
|
||||
code*))))
|
||||
|
||||
(define-syntax asm-enter
|
||||
(lambda (x)
|
||||
(syntax-case x ()
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user