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
|
;;; 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)
|
(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?
|
(define imm-funky12?
|
||||||
(lambda (x)
|
(lambda (x)
|
||||||
(nanopass-case (L15c Triv) x
|
(nanopass-case (L15c Triv) x
|
||||||
|
|
@ -206,15 +180,6 @@
|
||||||
[(immediate ,imm) `(immediate ,(lognot imm))]
|
[(immediate ,imm) `(immediate ,(lognot imm))]
|
||||||
[else (sorry! who "~s is not an immediate" ir)]))
|
[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
|
(define mref->mref
|
||||||
(lambda (a k)
|
(lambda (a k)
|
||||||
(define return
|
(define return
|
||||||
|
|
@ -294,17 +259,13 @@
|
||||||
[else
|
[else
|
||||||
(return x0 %zero imm)])))))])))
|
(return x0 %zero imm)])))))])))
|
||||||
|
|
||||||
(define mem->fpmem
|
;; `define-instruction` code takes care of `ur` and `fpur`, to which
|
||||||
(lambda (a k)
|
;; all type-compatible values must convert
|
||||||
(fpmem->fpmem a k)))
|
|
||||||
|
|
||||||
(define-syntax coercible?
|
(define-syntax coercible?
|
||||||
(syntax-rules ()
|
(syntax-rules ()
|
||||||
[(_ ?a ?aty*)
|
[(_ ?a ?aty*)
|
||||||
(let ([a ?a] [aty* ?aty*])
|
(let ([a ?a] [aty* ?aty*])
|
||||||
(or (and (memq 'ur aty*) (not (or (fpmem? a) (fpur? a))))
|
(or (and (memq 'funky12 aty*) (imm-funky12? a))
|
||||||
(and (memq 'fpur aty*) (or (fpmem? a) (fpur? a)))
|
|
||||||
(and (memq 'funky12 aty*) (imm-funky12? a))
|
|
||||||
(and (memq 'negate-funky12 aty*) (imm-negate-funky12? a))
|
(and (memq 'negate-funky12 aty*) (imm-negate-funky12? a))
|
||||||
(and (memq 'lognot-funky12 aty*) (imm-lognot-funky12? a))
|
(and (memq 'lognot-funky12 aty*) (imm-lognot-funky12? a))
|
||||||
(and (memq 'shift-count aty*) (imm-shift-count? a))
|
(and (memq 'shift-count aty*) (imm-shift-count? a))
|
||||||
|
|
@ -315,6 +276,7 @@
|
||||||
(and (memq 'mem aty*) (mem? a))
|
(and (memq 'mem aty*) (mem? a))
|
||||||
(and (memq 'fpmem aty*) (fpmem? 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*
|
(define-syntax coerce-opnd ; passes k something compatible with aty*
|
||||||
(syntax-rules ()
|
(syntax-rules ()
|
||||||
[(_ ?a ?aty* ?k)
|
[(_ ?a ?aty* ?k)
|
||||||
|
|
@ -360,12 +322,6 @@
|
||||||
(sorry! 'coerce-opnd "unexpected operand ~s" a)])]
|
(sorry! 'coerce-opnd "unexpected operand ~s" a)])]
|
||||||
[else (sorry! 'coerce-opnd "cannot coerce ~s to ~s" a aty*)]))]))
|
[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
|
(define md-handle-jump
|
||||||
(lambda (t)
|
(lambda (t)
|
||||||
(with-output-language (L15d Tail)
|
(with-output-language (L15d Tail)
|
||||||
|
|
@ -390,157 +346,6 @@
|
||||||
(values '() `(jump (label-ref ,l ,offset)))]
|
(values '() `(jump (label-ref ,l ,offset)))]
|
||||||
[else (long-form t)]))))
|
[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 info-cc-eq (make-info-condition-code 'eq? #f #t))
|
||||||
(define asm-eq (asm-relop info-cc-eq))
|
(define asm-eq (asm-relop info-cc-eq))
|
||||||
|
|
||||||
|
|
@ -1037,8 +842,7 @@
|
||||||
asm-pop-multiple asm-shiftop asm-logand asm-lognot
|
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-logtest asm-fp-relop asm-relop asm-push-multiple asm-vpush-multiple asm-vpop-multiple
|
||||||
asm-indirect-jump asm-literal-jump
|
asm-indirect-jump asm-literal-jump
|
||||||
asm-direct-jump asm-return-address asm-jump asm-conditional-jump asm-data-label
|
asm-direct-jump asm-return-address asm-jump asm-conditional-jump
|
||||||
asm-rp-header asm-rp-compact-header
|
|
||||||
asm-indirect-call asm-condition-code
|
asm-indirect-call asm-condition-code
|
||||||
asm-fpmove-single asm-fl-cvt asm-fpt asm-fpmove asm-fpcastto asm-fpcastfrom asm-fptrunc
|
asm-fpmove-single asm-fl-cvt asm-fpt asm-fpmove asm-fpcastto asm-fpcastfrom asm-fptrunc
|
||||||
asm-lock asm-lock+/- asm-cas asm-fence
|
asm-lock asm-lock+/- asm-cas asm-fence
|
||||||
|
|
@ -2473,11 +2277,6 @@
|
||||||
[(fp<=) (i? (r? blt bhi) (r? bge bls))]
|
[(fp<=) (i? (r? blt bhi) (r? bge bls))]
|
||||||
[(fp=) (i? bne beq)]))))))
|
[(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
|
(define asm-helper-jump
|
||||||
(lambda (code* reloc)
|
(lambda (code* reloc)
|
||||||
; NB: kills %ts, unbeknownst to the instruction scheduler
|
; NB: kills %ts, unbeknownst to the instruction scheduler
|
||||||
|
|
@ -2518,46 +2317,6 @@
|
||||||
(lambda (code* reloc)
|
(lambda (code* reloc)
|
||||||
(cons* reloc (aop-cons* `(asm "relocation:" ,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*)))
|
|
||||||
|
|
||||||
; NB: reads from %lr...should be okay if declare-intrinsics sets up return-live* properly
|
; NB: reads from %lr...should be okay if declare-intrinsics sets up return-live* properly
|
||||||
(define asm-return (lambda () (emit bx (cons 'reg %lr) '())))
|
(define asm-return (lambda () (emit bx (cons 'reg %lr) '())))
|
||||||
|
|
||||||
|
|
|
||||||
268
s/arm64.ss
268
s/arm64.ss
|
|
@ -57,33 +57,13 @@
|
||||||
))
|
))
|
||||||
|
|
||||||
;;; SECTION 2: instructions
|
;;; 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)
|
(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?
|
(define imm-funkymask?
|
||||||
(lambda (x)
|
(lambda (x)
|
||||||
(nanopass-case (L15c Triv) x
|
(nanopass-case (L15c Triv) x
|
||||||
|
|
@ -113,21 +93,6 @@
|
||||||
[(immediate ,imm) `(immediate ,(- imm))]
|
[(immediate ,imm) `(immediate ,(- imm))]
|
||||||
[else (sorry! who "~s is not an immediate" ir)]))
|
[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
|
(define mref->mref
|
||||||
(lambda (a k)
|
(lambda (a k)
|
||||||
(define return
|
(define return
|
||||||
|
|
@ -177,19 +142,20 @@
|
||||||
|
|
||||||
(define fpmem->fpmem mem->mem)
|
(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?
|
(define-syntax coercible?
|
||||||
(syntax-rules ()
|
(syntax-rules ()
|
||||||
[(_ ?a ?aty*)
|
[(_ ?a ?aty*)
|
||||||
(let ([a ?a] [aty* ?aty*])
|
(let ([a ?a] [aty* ?aty*])
|
||||||
(or (and (memq 'ur aty*) (not (or (fpmem? a) (fpur? a))))
|
(or (and (memq 'unsigned12 aty*) (imm-unsigned12? a))
|
||||||
(and (memq 'fpur aty*) (or (fpmem? a) (fpur? a)))
|
|
||||||
(and (memq 'unsigned12 aty*) (imm-unsigned12? a))
|
|
||||||
(and (memq 'neg-unsigned12 aty*) (imm-neg-unsigned12? a))
|
(and (memq 'neg-unsigned12 aty*) (imm-neg-unsigned12? a))
|
||||||
(and (memq 'funkymask aty*) (imm-funkymask? a))
|
(and (memq 'funkymask aty*) (imm-funkymask? a))
|
||||||
(and (memq 'imm-constant aty*) (imm-constant? a))
|
(and (memq 'imm-constant aty*) (imm-constant? a))
|
||||||
(and (memq 'mem aty*) (mem? a))
|
(and (memq 'mem aty*) (mem? a))
|
||||||
(and (memq 'fpmem aty*) (fpmem? 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*
|
(define-syntax coerce-opnd ; passes k something compatible with aty*
|
||||||
(syntax-rules ()
|
(syntax-rules ()
|
||||||
[(_ ?a ?aty* ?k)
|
[(_ ?a ?aty* ?k)
|
||||||
|
|
@ -231,12 +197,6 @@
|
||||||
(sorry! 'coerce-opnd "unexpected operand ~s" a)])]
|
(sorry! 'coerce-opnd "unexpected operand ~s" a)])]
|
||||||
[else (sorry! 'coerce-opnd "cannot coerce ~s to ~s" a aty*)]))]))
|
[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
|
(define md-handle-jump
|
||||||
(lambda (t)
|
(lambda (t)
|
||||||
(with-output-language (L15d Tail)
|
(with-output-language (L15d Tail)
|
||||||
|
|
@ -259,162 +219,6 @@
|
||||||
(values '() `(jump (label-ref ,l ,offset)))]
|
(values '() `(jump (label-ref ,l ,offset)))]
|
||||||
[else (long-form t)]))))
|
[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 info-cc-eq (make-info-condition-code 'eq? #f #t))
|
||||||
(define asm-eq (asm-relop info-cc-eq #f))
|
(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-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-logtest asm-fp-relop asm-relop asm-push-multiple asm-push-fpmultiple asm-pop-fpmultiple
|
||||||
asm-indirect-jump asm-literal-jump
|
asm-indirect-jump asm-literal-jump
|
||||||
asm-direct-jump asm-return-address asm-jump asm-conditional-jump asm-data-label
|
asm-direct-jump asm-return-address asm-jump asm-conditional-jump
|
||||||
asm-rp-header asm-rp-compact-header
|
|
||||||
asm-indirect-call asm-condition-code
|
asm-indirect-call asm-condition-code
|
||||||
asm-fpmove-single asm-fl-cvt asm-fpt asm-fpmove asm-fpcastto asm-fpcastfrom asm-fptrunc
|
asm-fpmove-single asm-fl-cvt asm-fpt asm-fpmove asm-fpcastto asm-fpcastfrom asm-fptrunc
|
||||||
asm-lock asm-lock+/- asm-cas asm-fence
|
asm-lock asm-lock+/- asm-cas asm-fence
|
||||||
|
|
@ -902,12 +705,6 @@
|
||||||
[(reg) r (reg-mdinfo r)]
|
[(reg) r (reg-mdinfo r)]
|
||||||
[else (sorry! who "ea=~s" ea)])))
|
[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?
|
(define ax-reg?
|
||||||
(lambda (ea)
|
(lambda (ea)
|
||||||
(record-case ea
|
(record-case ea
|
||||||
|
|
@ -2420,11 +2217,6 @@
|
||||||
[(fp<=) (i? (r? blt bhi) (r? bge bls))]
|
[(fp<=) (i? (r? blt bhi) (r? bge bls))]
|
||||||
[(fp=) (i? bne beq)]))))))
|
[(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
|
(define asm-helper-jump
|
||||||
(lambda (code* reloc)
|
(lambda (code* reloc)
|
||||||
(let ([jmp-tmp (cons 'reg %jmptmp)])
|
(let ([jmp-tmp (cons 'reg %jmptmp)])
|
||||||
|
|
@ -2462,46 +2254,6 @@
|
||||||
(lambda (code* reloc)
|
(lambda (code* reloc)
|
||||||
(cons* reloc (aop-cons* `(asm "relocation:" ,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* `(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
|
; NB: reads from %lr...should be okay if declare-intrinsics sets up return-live* properly
|
||||||
(define asm-return (lambda () (emit ret (cons 'reg %lr) '())))
|
(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 ()
|
(define-pass np-impose-calling-conventions : L12.5 (ir) -> L13 ()
|
||||||
(definitions
|
(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))
|
(import (only asm-module asm-foreign-call asm-foreign-callable asm-enter))
|
||||||
(define newframe-info-for-mventry-point)
|
(define newframe-info-for-mventry-point)
|
||||||
(define Lcall-error (make-Lcall-error))
|
(define Lcall-error (make-Lcall-error))
|
||||||
|
|
@ -13377,6 +13383,7 @@
|
||||||
(define-pass np-expand-hand-coded : L13 (ir) -> L13.5 ()
|
(define-pass np-expand-hand-coded : L13 (ir) -> L13.5 ()
|
||||||
(definitions
|
(definitions
|
||||||
(import (only asm-module asm-enter))
|
(import (only asm-module asm-enter))
|
||||||
|
;; ----------------------------------------
|
||||||
(define Ldoargerr (make-Ldoargerr))
|
(define Ldoargerr (make-Ldoargerr))
|
||||||
(define-$type-check (L13.5 Pred))
|
(define-$type-check (L13.5 Pred))
|
||||||
(define make-info
|
(define make-info
|
||||||
|
|
@ -16153,6 +16160,53 @@
|
||||||
(fx- offset (fx- (constant size-rp-header)
|
(fx- offset (fx- (constant size-rp-header)
|
||||||
(constant size-rp-compact-header)))
|
(constant size-rp-compact-header)))
|
||||||
offset)))
|
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)
|
(architecture assembler)
|
||||||
|
|
||||||
|
|
@ -17162,11 +17216,30 @@
|
||||||
(nanopass-case (L15c Triv) x
|
(nanopass-case (L15c Triv) x
|
||||||
[(literal ,info) (info-literal-indirect? info)]
|
[(literal ,info) (info-literal-indirect? info)]
|
||||||
[else #f])))
|
[else #f])))
|
||||||
(define mref?
|
(define lmem?
|
||||||
(lambda (x)
|
(lambda (x)
|
||||||
(nanopass-case (L15c Triv) x
|
(nanopass-case (L15c Triv) x
|
||||||
[(mref ,lvalue1 ,lvalue2 ,imm ,type) #t]
|
[(mref ,lvalue1 ,lvalue2 ,imm ,type) (not (eq? type 'fp))]
|
||||||
[else #f])))
|
[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?
|
(define same?
|
||||||
(lambda (a b)
|
(lambda (a b)
|
||||||
(or (eq? a b)
|
(or (eq? a b)
|
||||||
|
|
@ -17194,6 +17267,221 @@
|
||||||
(info-literal-addr info) (info-literal-offset info)))]
|
(info-literal-addr info) (info-literal-offset info)))]
|
||||||
[else (sorry! who "unexpected literal ~s" ir)]))
|
[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) ()
|
(define-pass select-instructions! : (L15c Dummy) (ir block* live-size force-overflow?) -> (L15d Dummy) ()
|
||||||
(definitions
|
(definitions
|
||||||
(module (handle-jump handle-effect-inline handle-pred-inline handle-value-inline)
|
(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
|
;;; 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)
|
(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
|
(define-syntax define-imm-pred
|
||||||
(lambda (x)
|
(lambda (x)
|
||||||
(syntax-case x ()
|
(syntax-case x ()
|
||||||
|
|
@ -167,15 +147,6 @@
|
||||||
[(immediate ,imm) #t]
|
[(immediate ,imm) #t]
|
||||||
[else #f])))
|
[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
|
(define mref->mref
|
||||||
(lambda (a k)
|
(lambda (a k)
|
||||||
(define return
|
(define return
|
||||||
|
|
@ -211,19 +182,21 @@
|
||||||
(k (with-output-language (L15d Lvalue) `(mref ,u ,%zero 0 uptr)))))]
|
(k (with-output-language (L15d Lvalue) `(mref ,u ,%zero 0 uptr)))))]
|
||||||
[else (mref->mref a k)])))
|
[else (mref->mref a k)])))
|
||||||
|
|
||||||
|
(define fpmem->fpmem mem->mem)
|
||||||
|
|
||||||
(define-pass imm->negative-imm : (L15c Triv) (ir) -> (L15d Triv) ()
|
(define-pass imm->negative-imm : (L15c Triv) (ir) -> (L15d Triv) ()
|
||||||
(Lvalue : Lvalue (ir) -> Lvalue ()
|
(Lvalue : Lvalue (ir) -> Lvalue ()
|
||||||
[(mref ,lvalue1 ,lvalue2 ,imm ,type) (sorry! who "unexpected mref ~s" ir)])
|
[(mref ,lvalue1 ,lvalue2 ,imm ,type) (sorry! who "unexpected mref ~s" ir)])
|
||||||
(Triv : Triv (ir) -> Triv ()
|
(Triv : Triv (ir) -> Triv ()
|
||||||
[(immediate ,imm) `(immediate ,(- imm))]))
|
[(immediate ,imm) `(immediate ,(- imm))]))
|
||||||
|
|
||||||
|
;; `define-instruction` code takes care of `ur` and `fpur`, to which
|
||||||
|
;; all type-compatible values must convert
|
||||||
(define-syntax coercible?
|
(define-syntax coercible?
|
||||||
(syntax-rules ()
|
(syntax-rules ()
|
||||||
[(_ ?a ?aty*)
|
[(_ ?a ?aty*)
|
||||||
(let ([a ?a] [aty* ?aty*])
|
(let ([a ?a] [aty* ?aty*])
|
||||||
(or (and (memq 'ur aty*) (not (or (fpmem? a) (fpur? a))))
|
(or (and (memq 'shift-count aty*) (imm-shift-count? a))
|
||||||
(and (memq 'fpur aty*) (or (fpmem? a) (fpur? a)))
|
|
||||||
(and (memq 'shift-count aty*) (imm-shift-count? a))
|
|
||||||
(and (memq 'unsigned16 aty*) (imm-unsigned16? a))
|
(and (memq 'unsigned16 aty*) (imm-unsigned16? a))
|
||||||
(and (memq 'shifted-unsigned16 aty*) (imm-shifted-unsigned16? a))
|
(and (memq 'shifted-unsigned16 aty*) (imm-shifted-unsigned16? a))
|
||||||
(and (memq 'integer16 aty*) (imm-integer16? a))
|
(and (memq 'integer16 aty*) (imm-integer16? a))
|
||||||
|
|
@ -234,6 +207,7 @@
|
||||||
(and (memq 'mem aty*) (mem? a))
|
(and (memq 'mem aty*) (mem? a))
|
||||||
(and (memq 'fpmem aty*) (fpmem? 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*
|
(define-syntax coerce-opnd ; passes k something compatible with aty*
|
||||||
(syntax-rules ()
|
(syntax-rules ()
|
||||||
[(_ ?a ?aty* ?k)
|
[(_ ?a ?aty* ?k)
|
||||||
|
|
@ -280,12 +254,6 @@
|
||||||
[else (sorry! 'coerce-opnd "unexpected operand ~s" a)])]
|
[else (sorry! 'coerce-opnd "unexpected operand ~s" a)])]
|
||||||
[else (sorry! 'coerce-opnd "cannot coerce ~s to ~s" a aty*)]))]))
|
[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
|
(define md-handle-jump
|
||||||
(lambda (t)
|
(lambda (t)
|
||||||
(with-output-language (L15d Tail)
|
(with-output-language (L15d Tail)
|
||||||
|
|
@ -310,132 +278,6 @@
|
||||||
(values '() `(jump (label-ref ,l ,offset)))]
|
(values '() `(jump (label-ref ,l ,offset)))]
|
||||||
[else (long-form t)]))))
|
[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))
|
(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)
|
; 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-logand asm-lognot
|
||||||
asm-logtest asm-fp-relop asm-relop asm-logrelop
|
asm-logtest asm-fp-relop asm-relop asm-logrelop
|
||||||
asm-indirect-jump asm-literal-jump
|
asm-indirect-jump asm-literal-jump
|
||||||
asm-direct-jump asm-return-address asm-jump asm-conditional-jump asm-data-label
|
asm-direct-jump asm-return-address asm-jump asm-conditional-jump
|
||||||
asm-rp-header asm-rp-compact-header
|
|
||||||
asm-indirect-call asm-condition-code
|
asm-indirect-call asm-condition-code
|
||||||
asm-trunc asm-fpt asm-fpcastto asm-fpcastfrom
|
asm-trunc asm-fpt asm-fpcastto asm-fpcastfrom
|
||||||
asm-lock asm-lock+/- asm-cas
|
asm-lock asm-lock+/- asm-cas
|
||||||
|
|
@ -2171,11 +2012,6 @@
|
||||||
(emit b `(label ,(fx+ disp1 4) ,l1)
|
(emit b `(label ,(fx+ disp1 4) ,l1)
|
||||||
(emit b `(label ,disp2 ,l2) '())))]))))))
|
(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
|
(define asm-helper-jump
|
||||||
(lambda (code* reloc)
|
(lambda (code* reloc)
|
||||||
(emit nop
|
(emit nop
|
||||||
|
|
@ -2219,46 +2055,6 @@
|
||||||
(lambda (reloc code*)
|
(lambda (reloc code*)
|
||||||
(cons* reloc (aop-cons* `(asm "relocation:" ,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
|
(define asm-return
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(emit blr '())))
|
(emit blr '())))
|
||||||
|
|
|
||||||
469
s/x86.ss
469
s/x86.ss
|
|
@ -41,45 +41,21 @@
|
||||||
#;[%esi #f 6]))
|
#;[%esi #f 6]))
|
||||||
|
|
||||||
;;; SECTION 2: instructions
|
;;; 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)
|
(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
|
(define all-but-byte-registers
|
||||||
; include only allocable registers that aren't byte registers
|
; include only allocable registers that aren't byte registers
|
||||||
; keep in sync with define-registers above
|
; keep in sync with define-registers above
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(list %esi)))
|
(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?
|
(define real-imm32?
|
||||||
(lambda (x)
|
(lambda (x)
|
||||||
(nanopass-case (L15c Triv) x
|
(nanopass-case (L15c Triv) x
|
||||||
|
|
@ -95,15 +71,6 @@
|
||||||
[(immediate ,imm) (<= #x-7FFFFFFF imm #x7FFFFFFF)]
|
[(immediate ,imm) (<= #x-7FFFFFFF imm #x7FFFFFFF)]
|
||||||
[else #f])))
|
[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
|
(define literal@->mem
|
||||||
(lambda (a k)
|
(lambda (a k)
|
||||||
(nanopass-case (L15c Triv) a
|
(nanopass-case (L15c Triv) a
|
||||||
|
|
@ -127,20 +94,23 @@
|
||||||
[(literal@? a) (literal@->mem a k)]
|
[(literal@? a) (literal@->mem a k)]
|
||||||
[else (mref->mref 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?
|
(define-syntax coercible?
|
||||||
(syntax-rules ()
|
(syntax-rules ()
|
||||||
[(_ ?a ?aty*)
|
[(_ ?a ?aty*)
|
||||||
(let ([a ?a] [aty* ?aty*])
|
(let ([a ?a] [aty* ?aty*])
|
||||||
(or (and (memq 'ur aty*) (not (or (fpmem? a) (fpur? a))))
|
(or (and (memq 'imm32 aty*) (imm32? a))
|
||||||
(and (memq 'fpur aty*) (or (fpmem? a) (fpur? a)))
|
(and (memq 'imm aty*) (imm? a))
|
||||||
(or (and (memq 'imm32 aty*) (imm32? a))
|
(and (memq 'zero aty*) (imm0? a))
|
||||||
(and (memq 'imm aty*) (imm? a))
|
(and (memq 'real-imm32 aty*) (real-imm32? a))
|
||||||
(and (memq 'zero aty*) (imm0? a))
|
(and (memq 'negatable-real-imm32 aty*) (negatable-real-imm32? a))
|
||||||
(and (memq 'real-imm32 aty*) (real-imm32? a))
|
(and (memq 'mem aty*) (mem? a))
|
||||||
(and (memq 'negatable-real-imm32 aty*) (negatable-real-imm32? a))
|
(and (memq 'fpmem aty*) (fpmem? 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*
|
(define-syntax coerce-opnd ; passes k something compatible with aty*
|
||||||
(syntax-rules ()
|
(syntax-rules ()
|
||||||
[(_ ?a ?aty* ?k)
|
[(_ ?a ?aty* ?k)
|
||||||
|
|
@ -183,12 +153,6 @@
|
||||||
(sorry! 'coerce-opnd "unexpected operand ~s" a)])]
|
(sorry! 'coerce-opnd "unexpected operand ~s" a)])]
|
||||||
[else (sorry! 'coerce-opnd "cannot coerce ~s to ~s" a aty*)]))]))
|
[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
|
(define-who extract-imm
|
||||||
(lambda (e)
|
(lambda (e)
|
||||||
(nanopass-case (L15d Triv) e
|
(nanopass-case (L15d Triv) e
|
||||||
|
|
@ -217,311 +181,50 @@
|
||||||
(with-output-language (L15d Effect) `(set! ,(make-live-info) ,tmp ,t))
|
(with-output-language (L15d Effect) `(set! ,(make-live-info) ,tmp ,t))
|
||||||
`(jump ,tmp)))]))))
|
`(jump ,tmp)))]))))
|
||||||
|
|
||||||
(define-syntax define-instruction
|
(define-syntax acsame-mem
|
||||||
(lambda (x)
|
(lambda (stx)
|
||||||
(define acsame-mem
|
(syntax-case stx ()
|
||||||
(lambda (c a b bty* k)
|
[(_ orig c cty (b bty* ...) k)
|
||||||
#`(lambda (c a b)
|
#'(mem->mem c
|
||||||
(if (and (lmem? c) (same? a c) (coercible? b '#,bty*))
|
(lambda (c)
|
||||||
(coerce-opnd b '#,bty*
|
(k c b)))]
|
||||||
(lambda (b)
|
[(_ orig c cty k)
|
||||||
(mem->mem c
|
#'(mem->mem c
|
||||||
(lambda (c)
|
(lambda (c)
|
||||||
(#,k c b)))))
|
(k c)))])))
|
||||||
(next c a b)))))
|
|
||||||
|
|
||||||
(define-who acsame-ur
|
(define-syntax acsame-ur
|
||||||
(lambda (c a b bty* k)
|
(lambda (stx)
|
||||||
#`(lambda (c a b)
|
(syntax-case stx ()
|
||||||
(if (and (same? a c) (coercible? b '#,bty*))
|
[(moi orig c cty (b bty* ...) k)
|
||||||
(coerce-opnd b '#,bty*
|
#`(cond
|
||||||
(lambda (b)
|
[(ur? c) (k c b)]
|
||||||
(cond
|
[(lmem? c)
|
||||||
[(ur? c) (#,k c b)]
|
(nanopass-case (L15c Triv) c
|
||||||
[(mref? c)
|
[(mref ,lvalue0 ,lvalue1 ,imm ,type)
|
||||||
(nanopass-case (L15c Triv) c
|
(lvalue->ur
|
||||||
; NOTE: x86_64 and risc arch's will need to deal with limitations on the offset
|
lvalue0
|
||||||
[(mref ,lvalue0 ,lvalue1 ,imm ,type)
|
(lambda (x0)
|
||||||
(lvalue->ur lvalue0
|
(lvalue->ur
|
||||||
(lambda (x0)
|
lvalue1
|
||||||
(lvalue->ur lvalue1
|
(lambda (x1)
|
||||||
(lambda (x1)
|
(let ([u (make-tmp 'u)])
|
||||||
(let ([u (make-tmp 'u)])
|
(seq
|
||||||
(seq
|
(build-set! ,u (mref ,x0 ,x1 ,imm ,type))
|
||||||
(build-set! ,u (mref ,x0 ,x1 ,imm ,type))
|
(k u b)
|
||||||
(#,k u b)
|
(build-set! (mref ,x0 ,x1 ,imm ,type) ,u)))))))])]
|
||||||
(build-set! (mref ,x0 ,x1 ,imm ,type) ,u)))))))])]
|
;; can't be literal@ since literals can't be lvalues
|
||||||
[else (sorry! '#,(datum->syntax #'* who) "unexpected operand ~s" c)])))
|
[else (sorry! 'moi "unexpected operand ~s" c)])]
|
||||||
(next c a b)))))
|
[(moi orig c cty k)
|
||||||
|
#`(if (ur? c)
|
||||||
(define mem-type?
|
(k c)
|
||||||
(lambda (t)
|
(mem->mem c
|
||||||
(syntax-case t (mem fpmem)
|
(lambda (c)
|
||||||
[mem #t]
|
(let ([u (make-tmp 'u)])
|
||||||
[fpmem #t]
|
(seq
|
||||||
[else #f])))
|
(build-set! ,u ,c)
|
||||||
|
(k u)
|
||||||
(define make-value-clause
|
(build-set! ,c ,u))))))])))
|
||||||
(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 ...)])))
|
|
||||||
|
|
||||||
; x is not the same as z in any clause that follows a clause where (x z)
|
; 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:
|
; 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-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-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-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-direct-jump asm-return-address asm-jump asm-conditional-jump
|
||||||
asm-rp-header asm-rp-compact-header
|
|
||||||
asm-lea1 asm-lea2 asm-indirect-call asm-fstpl asm-fstps asm-fldl asm-flds asm-condition-code
|
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-fl-cvt asm-store-single asm-fpt asm-fptrunc asm-div
|
||||||
asm-exchange asm-pause asm-locked-incr asm-locked-decr asm-locked-cmpxchg
|
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
|
; inverted: !(fl= x y) iff zf = 0 or cf (or pf) = 1
|
||||||
[(fp=) (or bne bcs)]))))))
|
[(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
|
(constant-case machine-type-name
|
||||||
[(i3nt ti3nt) (define asm-enter values)]
|
[(i3nt ti3nt) (define asm-enter values)]
|
||||||
[else
|
[else
|
||||||
|
|
|
||||||
475
s/x86_64.ss
475
s/x86_64.ss
|
|
@ -79,39 +79,15 @@
|
||||||
[%sp #t 4 uptr])))
|
[%sp #t 4 uptr])))
|
||||||
|
|
||||||
;;; SECTION 2: instructions
|
;;; 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)
|
(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?
|
(define real-imm32?
|
||||||
(lambda (x)
|
(lambda (x)
|
||||||
(nanopass-case (L15c Triv) x
|
(nanopass-case (L15c Triv) x
|
||||||
|
|
@ -127,16 +103,6 @@
|
||||||
[(immediate ,imm) (<= #x-7FFFFFFF imm #x7FFFFFFF)]
|
[(immediate ,imm) (<= #x-7FFFFFFF imm #x7FFFFFFF)]
|
||||||
[else #f])))
|
[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
|
(define mref->mref
|
||||||
(lambda (a k)
|
(lambda (a k)
|
||||||
(define return
|
(define return
|
||||||
|
|
@ -169,25 +135,23 @@
|
||||||
(k (with-output-language (L15d Lvalue) `(mref ,u ,%zero 0 ptr)))))]
|
(k (with-output-language (L15d Lvalue) `(mref ,u ,%zero 0 ptr)))))]
|
||||||
[else (mref->mref a k)])))
|
[else (mref->mref a k)])))
|
||||||
|
|
||||||
(define literal->literal
|
(define fpmem->fpmem mem->mem)
|
||||||
(lambda (a)
|
|
||||||
(nanopass-case (L15c Triv) a
|
|
||||||
[(literal ,info) (with-output-language (L15d Triv) `(literal ,info))])))
|
|
||||||
|
|
||||||
|
;; `define-instruction` code takes care of `ur` and `fpur`, to which
|
||||||
|
;; all type-compatible values must convert
|
||||||
(define-syntax coercible?
|
(define-syntax coercible?
|
||||||
(syntax-rules ()
|
(syntax-rules ()
|
||||||
[(_ ?a ?aty*)
|
[(_ ?a ?aty*)
|
||||||
(let ([a ?a] [aty* ?aty*])
|
(let ([a ?a] [aty* ?aty*])
|
||||||
(or (and (memq 'ur aty*) (not (or (fpmem? a) (fpur? a))))
|
(or (and (memq 'imm32 aty*) (imm32? a))
|
||||||
(and (memq 'fpur aty*) (or (fpmem? a) (fpur? a)))
|
(and (memq 'imm aty*) (imm? a))
|
||||||
(or (and (memq 'imm32 aty*) (imm32? a))
|
(and (memq 'zero aty*) (imm0? a))
|
||||||
(and (memq 'imm aty*) (imm? a))
|
(and (memq 'real-imm32 aty*) (real-imm32? a))
|
||||||
(and (memq 'zero aty*) (imm0? a))
|
(and (memq 'negatable-real-imm32 aty*) (negatable-real-imm32? a))
|
||||||
(and (memq 'real-imm32 aty*) (real-imm32? a))
|
(and (memq 'mem aty*) (mem? a))
|
||||||
(and (memq 'negatable-real-imm32 aty*) (negatable-real-imm32? a))
|
(and (memq 'fpmem aty*) (fpmem? 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*
|
(define-syntax coerce-opnd ; passes k something compatible with aty*
|
||||||
(syntax-rules ()
|
(syntax-rules ()
|
||||||
[(_ ?a ?aty* ?k)
|
[(_ ?a ?aty* ?k)
|
||||||
|
|
@ -230,12 +194,6 @@
|
||||||
(sorry! 'coerce-opnd "unexpected operand ~s" a)])]
|
(sorry! 'coerce-opnd "unexpected operand ~s" a)])]
|
||||||
[else (sorry! 'coerce-opnd "cannot coerce ~s to ~s" a aty*)]))]))
|
[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
|
(define-who extract-imm
|
||||||
(lambda (e)
|
(lambda (e)
|
||||||
(nanopass-case (L15d Triv) e
|
(nanopass-case (L15d Triv) e
|
||||||
|
|
@ -264,304 +222,59 @@
|
||||||
(with-output-language (L15d Effect) `(set! ,(make-live-info) ,tmp ,t))
|
(with-output-language (L15d Effect) `(set! ,(make-live-info) ,tmp ,t))
|
||||||
`(jump ,tmp)))]))))
|
`(jump ,tmp)))]))))
|
||||||
|
|
||||||
(define-syntax define-instruction
|
(define-syntax acsame-mem
|
||||||
(lambda (x)
|
(lambda (stx)
|
||||||
(define acsame-mem
|
(syntax-case stx ()
|
||||||
(lambda (c a b bty* k)
|
[(_ orig c cty (b bty* ...) k)
|
||||||
#`(lambda (c a b)
|
#'(mem->mem c
|
||||||
(if (and (lmem? c) (same? a c) (coercible? b '#,bty*))
|
(lambda (c)
|
||||||
(coerce-opnd b '#,bty*
|
(k c b)))]
|
||||||
(lambda (b)
|
[(_ orig c cty k)
|
||||||
(mem->mem c
|
#'(mem->mem c
|
||||||
(lambda (c)
|
(lambda (c)
|
||||||
(#,k c b)))))
|
(k c)))])))
|
||||||
(next c a b)))))
|
|
||||||
|
|
||||||
(define-who acsame-ur
|
(define-syntax acsame-ur
|
||||||
(lambda (c a b bty* k)
|
(lambda (stx)
|
||||||
#`(lambda (c a b)
|
(syntax-case stx ()
|
||||||
(if (and (same? a c) (coercible? b '#,bty*))
|
[(moi orig c cty (b bty* ...) k)
|
||||||
(coerce-opnd b '#,bty*
|
#`(cond
|
||||||
(lambda (b)
|
[(ur? c) (k c b)]
|
||||||
(cond
|
[(lmem? c)
|
||||||
[(ur? c) (#,k c b)]
|
(nanopass-case (L15c Triv) c
|
||||||
[(mref? c)
|
[(mref ,lvalue0 ,lvalue1 ,imm ,type)
|
||||||
(nanopass-case (L15c Triv) c
|
;; TODO: does this use too many registers? (no longer special casing fv x0, x1 case)
|
||||||
[(mref ,lvalue0 ,lvalue1 ,imm ,type)
|
(lvalue->ur
|
||||||
; TODO: does this use too many registers? (no longer special casing fv x0, x1 case)
|
lvalue0
|
||||||
(lvalue->ur lvalue0
|
(lambda (x0)
|
||||||
(lambda (x0)
|
(lvalue->ur
|
||||||
(lvalue->ur lvalue1
|
lvalue1
|
||||||
(lambda (x1)
|
(lambda (x1)
|
||||||
(let ([u1 (make-tmp 'u)])
|
(let ([u1 (make-tmp 'u)])
|
||||||
(if (signed-32? imm)
|
(if (signed-32? imm)
|
||||||
(seq
|
(seq
|
||||||
(build-set! ,u1 (mref ,x0 ,x1 ,imm ,type))
|
(build-set! ,u1 (mref ,x0 ,x1 ,imm ,type))
|
||||||
(#,k u1 b)
|
(k u1 b)
|
||||||
(build-set! (mref ,x0 ,x1 ,imm ,type) ,u1))
|
(build-set! (mref ,x0 ,x1 ,imm ,type) ,u1))
|
||||||
(let ([u2 (make-tmp 'u)])
|
(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)])
|
|
||||||
(seq
|
(seq
|
||||||
(build-set! ,u ,c)
|
(build-set! ,u2 ,imm)
|
||||||
(rhs u u)
|
(build-set! ,x1 (asm ,null-info ,asm-add ,x1 ,u2))
|
||||||
(build-set! ,c ,u))))))
|
(build-set! ,u1 (mref ,x0 ,x1 0 ,type))
|
||||||
(next c a)))]
|
(k u1 b)
|
||||||
[(op (c xmem) (a aty ...))
|
(build-set! (mref ,x0 ,x1 0 ,type) ,u1)))))))))])]
|
||||||
(mem-type? #'xmem)
|
;; can't be literal@ since literals can't be lvalues
|
||||||
#`(lambda (c a)
|
[else (sorry! 'moi "unexpected operand ~s" c)])]
|
||||||
(if (and (mem-of-type? xmem c) (coercible? a '(aty ...)))
|
[(moi orig c cty k)
|
||||||
(coerce-opnd a '(aty ...)
|
#`(if (ur? c)
|
||||||
(lambda (a)
|
(k c)
|
||||||
(mem->mem c
|
(mem->mem c
|
||||||
(lambda (c)
|
(lambda (c)
|
||||||
(rhs c a)))))
|
(let ([u (make-tmp 'u)])
|
||||||
(next c a)))]
|
(seq
|
||||||
[(op (c ur) (a aty ...))
|
(build-set! ,u ,c)
|
||||||
#`(lambda (c a)
|
(k u)
|
||||||
(if (coercible? a '(aty ...))
|
(build-set! ,c ,u))))))])))
|
||||||
(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 ...)])))
|
|
||||||
|
|
||||||
; x is not the same as z in any clause that follows a clause where (x z)
|
; 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:
|
; 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-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-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-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-direct-jump asm-return-address asm-jump asm-conditional-jump
|
||||||
asm-rp-header asm-rp-compact-header
|
|
||||||
asm-lea1 asm-lea2 asm-indirect-call asm-condition-code
|
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-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
|
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
|
; inverted: !(fl= x y) iff zf = 0 or cf (or pf) = 1
|
||||||
[(fp=) (or bne bcs)]))))))
|
[(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
|
(define asm-helper-jump
|
||||||
(lambda (code* reloc)
|
(lambda (code* reloc)
|
||||||
(let ([jmp-reg (cons 'reg %ts)])
|
(let ([jmp-reg (cons 'reg %ts)])
|
||||||
|
|
@ -2676,48 +2383,6 @@
|
||||||
(lambda (code* reloc)
|
(lambda (code* reloc)
|
||||||
(cons* reloc (aop-cons* `(asm "relocation:" ,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 ([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
|
(define-syntax asm-enter
|
||||||
(lambda (x)
|
(lambda (x)
|
||||||
(syntax-case x ()
|
(syntax-case x ()
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue
Block a user