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