;;; arm32.ss ;;; Copyright 1984-2017 Cisco Systems, Inc. ;;; ;;; Licensed under the Apache License, Version 2.0 (the "License"); ;;; you may not use this file except in compliance with the License. ;;; You may obtain a copy of the License at ;;; ;;; http://www.apache.org/licenses/LICENSE-2.0 ;;; ;;; Unless required by applicable law or agreed to in writing, software ;;; distributed under the License is distributed on an "AS IS" BASIS, ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. ;;; See the License for the specific language governing permissions and ;;; limitations under the License. ;;; SECTION 1: registers ;;; ABI: ;;; Register usage: ;;; r0-r3 aka a1-a4: C argument registers, caller-save ;;; r4-r8, r10, r11 aka v1-v5, v7, v8: callee-save ;;; r9 aka v6, sb, or tr: platform-specific, callee-save ;;; r12 aka ip: caller-save (possibly usurped by linker at call boundaries) ;;; r13 aka sp: C stack pointer ;;; r14 aka lr: link register ;;; r15 aka pc: program counter ;;; -------- ;;; s0-s31: single-precision registers (with vfp-v2) overlap with d0-d15 ;;; d0-d15: double-precision registers (with vfp-v2) ;;; d16-d31: double-precision registers (with vfp-v3) ;;; Alignment: ;;; double-floats & 64-bit integers are 8-byte aligned in structs ;;; double-floats & 64-bit integers are 8-byte aligned on the stack ;;; stack must be 8-byte aligned at call boundaries (otherwise 4-byte) ;;; Parameter passing: ;;; 8- and 16-bit integer arguments zero- or sign-extended to 32-bits ;;; 32-bit integer arguments passed in a1-a4, then on stack ;;; 64-bit integer arguments passed in a1 or a3, then on stack ;;; little-endian: a1 (a3) holds lsw, a2 (a4) holds msw ;;; big-endian: a1 (a3) holds msw, a2 (a4) holds lsw ;;; 8- and 16-bit integer return value zero- or sign-extended to 32-bits ;;; 32-bit integer return value returned in r0 (aka a1) ;;; 64-bit integer return value passed in r0 & r1 (aka a1 & a2) ;;; little-endian: r0 holds lsw, r1 holds msw ;;; big-endian: r0 holds msw, r1 holds lsw ;;; single-floats passed in s0-s15 ;;; double-floats passed in d0-d7 (overlapping single) ;;; float return value returned in s0 or d0 ;;; must allocate to a single-float reg if it's passed by for double-float alignment ;;; (e.g., single, double, single => s0, d1, s1) ;;; ... unless a double has been stack-allocated ;;; (e.g., 15 singles, double => s0-s14, stack, stack) ;;; stack grows downwards. first stack args passed at lowest new frame address. ;;; return address passed in LR ;;; questions: ;;; least significant bit is always designated as bit 0...how does this affect ;;; bit fields in big-endian mode? ;;; meta questions: ;;; should we have both little- and big-endian support? ;;; can pidora (or some other linux distribution) run using both little- and big-endian modes? (define-registers (reserved [%tc %r9 #t 9] [%sfp %r10 #t 10] [%ap %r5 #t 5] #;[%esp] #;[%eap] [%trap %r8 #t 8]) (allocable [%ac0 %r4 #t 4] [%xp %r6 #t 6] [%ts %ip #f 12] [%td %r11 #t 11] #;[%ret] [%cp %r7 #t 7] #;[%ac1] #;[%yp] [ %r0 %Carg1 %Cretval #f 0] [ %r1 %Carg2 #f 1] [ %r2 %Carg3 #f 2] [ %r3 %Carg4 #f 3] [ %lr #f 14] ; %lr is trashed by 'c' calls including calls to hand-coded routines like get-room ) (machine-dependent [%sp #t 13] [%pc #f 15] [%Cfparg1 %Cfpretval %d0 %s0 #f 0] ; < 32: low bit goes in D, N, or M bit, high bits go in Vd, Vn, Vm [%Cfparg1b %s1 #f 1] [%Cfparg2 %d1 %s2 #f 2] [%Cfparg2b %s3 #f 3] [%Cfparg3 %d2 %s4 #f 4] [%Cfparg3b %s5 #f 5] [%Cfparg4 %d3 %s6 #f 6] [%Cfparg4b %s7 #f 7] [%Cfparg5 %d4 %s8 #f 8] [%Cfparg5b %s9 #f 9] [%Cfparg6 %d5 %s10 #f 10] [%Cfparg6b %s11 #f 11] [%Cfparg7 %d6 %s12 #f 12] [%Cfparg7b %s13 #f 13] [%Cfparg8 %d7 %s14 #f 14] [%Cfparg8b %s15 #f 15] [%flreg1 %d8 %s16 #f 16] [%flreg2 %d9 %s18 #f 18] ; etc. #;[ %d16 #f 32] ; >= 32: high bit goes in D, N, or M bit, low bits go in Vd, Vn, Vm #;[ %d17 #f 33] ; etc. )) ;;; SECTION 2: instructions (module (md-handle-jump) ; also sets primitive handlers (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 imm-funky12? (lambda (x) (nanopass-case (L15c Triv) x [(immediate ,imm) (and (funky12 imm) #t)] [else #f]))) (define imm-negate-funky12? (lambda (x) (nanopass-case (L15c Triv) x [(immediate ,imm) (and (funky12 (- imm)) #t)] [else #f]))) (define imm-lognot-funky12? (lambda (x) (nanopass-case (L15c Triv) x [(immediate ,imm) (and (funky12 (lognot imm)) #t)] [else #f]))) (define imm-shift-count? (lambda (x) (nanopass-case (L15c Triv) x [(immediate ,imm) (shift-count? imm)] [else #f]))) (define imm-unsigned8? (lambda (x) (nanopass-case (L15c Triv) x [(immediate ,imm) (unsigned8? imm)] [else #f]))) (define imm-unsigned12? (lambda (x) (nanopass-case (L15c Triv) x [(immediate ,imm) (unsigned12? imm)] [else #f]))) (define imm-constant? (lambda (x) (nanopass-case (L15c Triv) x [(immediate ,imm) #t] [else #f]))) (define uword8? (lambda (imm) (and (fixnum? imm) ($fxu< imm (expt 2 10)) (not (fxlogtest imm #b11))))) (define imm-uword8? ;; immediate is a nonnegative 8-bit word offset ;; effectively 8-bit unsigned left-shifted by 2 (lambda (x) (nanopass-case (L15c Triv) x [(immediate ,imm) (uword8? imm)] [else #f]))) (define-pass imm->negate-imm : (L15c Triv) (ir) -> (L15d Triv) () (Triv : Triv (ir) -> Triv () [(immediate ,imm) `(immediate ,(- imm))] [else (sorry! who "~s is not an immediate" ir)])) (define-pass imm->lognot-imm : (L15c Triv) (ir) -> (L15d Triv) () (Triv : Triv (ir) -> Triv () [(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 (lambda (x0 x1 imm) ; arm load & store instructions support index or offset but not both (safe-assert (or (eq? x1 %zero) (eqv? imm 0))) (k (with-output-language (L15d Triv) `(mref ,x0 ,x1 ,imm))))) (nanopass-case (L15c Triv) a [(mref ,lvalue0 ,lvalue1 ,imm) (lvalue->ur lvalue0 (lambda (x0) (lvalue->ur lvalue1 (lambda (x1) (cond [(and (eq? x1 %zero) (or (unsigned12? imm) (unsigned12? (- imm)))) (return x0 %zero imm)] [(funky12 imm) ; NB: dubious value? check to see if it's exercised ; NB: might should safe-assert x1 is %zero (let ([u (make-tmp 'u)]) (seq (build-set! ,u (asm ,null-info ,(asm-add #f) ,x0 (immediate ,imm))) (return u x1 0)))] [(funky12 (- imm)) ; NB: dubious value? check to see if it's exercised ; NB: might should safe-assert x1 is %zero (let ([u (make-tmp 'u)]) (seq (build-set! ,u (asm ,null-info ,(asm-sub #f) ,x0 (immediate ,imm))) (return u x1 0)))] [else (let ([u (make-tmp 'u)]) (seq (build-set! ,u (immediate ,imm)) (if (eq? x1 %zero) (return x0 u 0) (seq (build-set! ,u (asm ,null-info ,(asm-add #f) ,u ,x1)) (return x0 u 0)))))])))))]))) (define mem->mem (lambda (a k) (cond [(literal@? a) (let ([u (make-tmp 'u)]) (seq (build-set! ,u ,(literal@->literal a)) (k (with-output-language (L15d Lvalue) `(mref ,u ,%zero 0)))))] [else (mref->mref a k)]))) (define-syntax coercible? (syntax-rules () [(_ ?a ?aty*) (let ([a ?a] [aty* ?aty*]) (or (memq 'ur aty*) (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)) (and (memq 'unsigned8 aty*) (imm-unsigned8? a)) (and (memq 'unsigned12 aty*) (imm-unsigned12? a)) (and (memq 'imm-constant aty*) (imm-constant? a)) (and (memq 'uword8 aty*) (imm-uword8? a)) (and (memq 'mem aty*) (mem? a))))])) (define-syntax coerce-opnd ; passes k something compatible with aty* (syntax-rules () [(_ ?a ?aty* ?k) (let ([a ?a] [aty* ?aty*] [k ?k]) (cond [(and (memq 'mem aty*) (mem? a)) (mem->mem a k)] [(and (memq 'funky12 aty*) (imm-funky12? a)) (k (imm->imm a))] [(and (memq 'negate-funky12 aty*) (imm-negate-funky12? a)) (k (imm->negate-imm a))] [(and (memq 'lognot-funky12 aty*) (imm-lognot-funky12? a)) (k (imm->lognot-imm a))] [(and (memq 'shift-count aty*) (imm-shift-count? a)) (k (imm->imm a))] [(and (memq 'unsigned8 aty*) (imm-unsigned8? a)) (k (imm->imm a))] [(and (memq 'unsigned12 aty*) (imm-unsigned12? a)) (k (imm->imm a))] [(and (memq 'imm-constant aty*) (imm-constant? a)) (k (imm->imm a))] [(and (memq 'uword8 aty*) (imm-uword8? a)) (k (imm->imm a))] [(memq 'ur aty*) (cond [(ur? a) (k a)] [(imm? a) (let ([u (make-tmp 'u)]) (seq (build-set! ,u ,(imm->imm a)) (k u)))] [(mem? a) (mem->mem a (lambda (a) (let ([u (make-tmp 'u)]) (seq (build-set! ,u ,a) (k u)))))] [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) (define long-form (lambda (e) (let ([tmp (make-tmp 'utmp)]) (values (in-context Effect `(set! ,(make-live-info) ,tmp ,e)) `(jump ,tmp))))) (nanopass-case (L15c Triv) t [,lvalue (if (mem? lvalue) (mem->mem lvalue (lambda (e) (values '() `(jump ,e)))) (values '() `(jump ,lvalue)))] [(literal ,info) (guard (and (not (info-literal-indirect? info)) (memq (info-literal-type info) '(entry library-code)))) ; NB: really need to use unspillable or mark %ip (aka %ts) killed here but can't without extending jump syntax (values '() `(jump (literal ,info)))] [(label-ref ,l ,offset) ; NB: really need to use unspillable or mark %ip (aka %ts) killed here but can't without extending jump syntax (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) [(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 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 ...)))]))) (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-instruction (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)) ; 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: ; WARNING: do not assume that if x isn't the same as z then x is independent ; of z, since x might be an mref with z as it's base or index (define-instruction value (- -/ovfl -/eq) [(op (z ur) (x ur) (y funky12)) `(set! ,(make-live-info) ,z (asm ,info ,(asm-sub (memq op '(-/ovfl -/eq))) ,x ,y))] [(op (z ur) (x funky12) (y ur)) `(set! ,(make-live-info) ,z (asm ,info ,(asm-rsb (memq op '(-/ovfl -/eq))) ,y ,x))] [(op (z ur) (x ur) (y negate-funky12)) `(set! ,(make-live-info) ,z (asm ,info ,(asm-add (memq op '(-/ovfl -/eq))) ,x ,y))] [(op (z ur) (x ur) (y ur)) `(set! ,(make-live-info) ,z (asm ,info ,(asm-sub (memq op '(-/ovfl -/eq))) ,x ,y))]) (define-instruction value (+ +/ovfl +/carry) [(op (z ur) (x ur) (y funky12)) `(set! ,(make-live-info) ,z (asm ,info ,(asm-add (memq op '(+/ovfl +/carry))) ,x ,y))] [(op (z ur) (x funky12) (y ur)) `(set! ,(make-live-info) ,z (asm ,info ,(asm-add (memq op '(+/ovfl +/carry))) ,y ,x))] [(op (z ur) (x ur) (y negate-funky12)) `(set! ,(make-live-info) ,z (asm ,info ,(asm-sub (memq op '(+/ovfl +/carry))) ,x ,y))] [(op (z ur) (x negate-funky12) (y ur)) `(set! ,(make-live-info) ,z (asm ,info ,(asm-sub (memq op '(+/ovfl +/carry))) ,y ,x))] [(op (z ur) (x ur) (y ur)) `(set! ,(make-live-info) ,z (asm ,info ,(asm-add (memq op '(+/ovfl +/carry))) ,x ,y))]) (define-instruction value (*) ; no imm form available [(op (z ur) (x ur) (y ur)) `(set! ,(make-live-info) ,z (asm ,info ,asm-mul ,x ,y))]) (define-instruction value (*/ovfl) ; z flag set iff no overflow ; no imm form available [(op (z ur) (x ur) (y ur)) (let ([u (make-tmp 'u)]) (seq `(set! ,(make-live-info) ,u (asm ,null-info ,asm-kill)) `(set! ,(make-live-info) ,z (asm ,null-info ,asm-smull ,x ,y ,u)) `(asm ,null-info ,(asm-cmp/shift 31 'sra) ,u ,z)))]) ; NB: only on ARMv7VE implementations #;(define-instruction value (/) ; does not affect condition codes [(op (z ur) (x ur) (y ur)) `(set! ,(make-live-info) ,z (asm ,info ,asm-div ,x ,y))]) (define-instruction value (logand) [(op (z ur) (x ur) (y funky12)) `(set! ,(make-live-info) ,z (asm ,info ,(asm-logand #f) ,x ,y))] [(op (z ur) (x funky12) (y ur)) `(set! ,(make-live-info) ,z (asm ,info ,(asm-logand #f) ,y ,x))] [(op (z ur) (x ur) (y lognot-funky12)) `(set! ,(make-live-info) ,z (asm ,info ,(asm-bic #f) ,x ,y))] [(op (z ur) (x lognot-funky12) (y ur)) `(set! ,(make-live-info) ,z (asm ,info ,(asm-bic #f) ,y ,x))] [(op (z ur) (x ur) (y ur)) `(set! ,(make-live-info) ,z (asm ,info ,(asm-logand #f) ,x ,y))]) (let () (define select-op (lambda (op) (if (eq? op 'logor) asm-logor asm-logxor))) (define-instruction value (logor logxor) [(op (z ur) (x funky12) (y ur)) `(set! ,(make-live-info) ,z (asm ,info ,((select-op op) #f) ,y ,x))] [(op (z ur) (x ur) (y funky12 ur)) `(set! ,(make-live-info) ,z (asm ,info ,((select-op op) #f) ,x ,y))])) (define-instruction value (lognot) [(op (z ur) (x ur)) `(set! ,(make-live-info) ,z (asm ,info ,asm-lognot ,x))]) (define-instruction value (sll srl sra) [(op (z ur) (x ur) (y ur shift-count)) `(set! ,(make-live-info) ,z (asm ,info ,(asm-shiftop op) ,x ,y))]) (define-instruction value (move) [(op (z mem) (x ur)) `(set! ,(make-live-info) ,z ,x)] [(op (z ur) (x ur mem imm)) `(set! ,(make-live-info) ,z ,x)]) (define-instruction value lea1 ; NB: would be simpler if offset were explicit operand ; NB: why not one version of lea with %zero for y in lea1 case? [(op (z ur) (x ur)) (begin (let ([offset (info-lea-offset info)]) (if (funky12 offset) `(set! ,(make-live-info) ,z (asm ,info ,(asm-add #f) ,x (immediate ,offset))) (let ([u (make-tmp 'u)]) (seq `(set! ,(make-live-info) ,u (immediate ,offset)) `(set! ,(make-live-info) ,z (asm ,info ,(asm-add #f) ,x ,u)))))))]) (define-instruction value lea2 ; NB: would be simpler if offset were explicit operand [(op (z ur) (x ur) (y ur)) (let ([offset (info-lea-offset info)] [u (make-tmp 'u)]) (seq (if (funky12 offset) `(set! ,(make-live-info) ,u (asm ,info ,(asm-add #f) ,y (immediate ,offset))) (seq `(set! ,(make-live-info) ,u (immediate ,offset)) `(set! ,(make-live-info) ,u (asm ,null-info ,(asm-add #f) ,u ,y)))) `(set! ,(make-live-info) ,z (asm ,info ,(asm-add #f) ,x ,u))))]) (define-instruction value (sext8 sext16 zext8 zext16) [(op (z ur) (x ur)) `(set! ,(make-live-info) ,z (asm ,info ,(asm-move/extend op) ,x))]) (let () (define imm-zero (with-output-language (L15d Triv) `(immediate 0))) (define load/store (lambda (x y w imm8? k) ; x ur, y ur, w ur or imm (with-output-language (L15d Effect) (if (ur? w) (if (eq? y %zero) (k x w imm-zero) (let ([u (make-tmp 'u)]) (seq `(set! ,(make-live-info) ,u (asm ,null-info ,(asm-add #f) ,y ,w)) (k x u imm-zero)))) (let ([n (nanopass-case (L15d Triv) w [(immediate ,imm) imm])]) (cond [(if imm8? (or (unsigned8? n) (unsigned8? (- n))) (or (unsigned12? n) (unsigned12? (- n)))) (let ([w (in-context Triv `(immediate ,n))]) (if (or (eq? y %zero) (fx= n 0)) (k x y w) (let ([u (make-tmp 'u)]) (seq `(set! ,(make-live-info) ,u (asm ,null-info ,(asm-add #f) ,x ,y)) (k u %zero w)))))] [(funky12 n) => ; NB: dubious value? check to see if it's exercised (lambda (n) (let ([u (make-tmp 'u)]) (seq `(set! ,(make-live-info) ,u (asm ,null-info ,(asm-add #f) ,x (immediate ,n))) (k u y imm-zero))))] [(funky12 (- n)) => ; NB: dubious value? check to see if it's exercised (lambda (n) (let ([u (make-tmp 'u)]) (seq `(set! ,(make-live-info) ,u (asm ,null-info ,(asm-sub #f) ,x (immediate ,n))) (k u y imm-zero))))] [else (let ([u (make-tmp 'u)]) (seq `(set! ,(make-live-info) ,u (immediate ,n)) (if (eq? y %zero) (k x u imm-zero) (seq `(set! ,(make-live-info) ,u (asm ,null-info ,(asm-add #f) ,x ,u)) (k u y imm-zero)))))])))))) (define-instruction value (load) [(op (z ur) (x ur) (y ur) (w ur imm-constant)) (let ([type (info-load-type info)]) (load/store x y w (memq type '(integer-16 unsigned-16 integer-8)) (lambda (x y w) (let ([instr `(set! ,(make-live-info) ,z (asm ,null-info ,(asm-load type) ,x ,y ,w))]) (if (info-load-swapped? info) (seq instr `(set! ,(make-live-info) ,z (asm ,null-info ,(asm-swap type) ,z))) instr)))))]) (define-instruction effect (store) [(op (x ur) (y ur) (w ur imm-constant) (z ur)) (let ([type (info-load-type info)]) (load/store x y w (memq type '(integer-16 unsigned-16)) (lambda (x y w) (if (info-load-swapped? info) (let ([u (make-tmp 'unique-bob)]) (seq `(set! ,(make-live-info) ,u (asm ,null-info ,(asm-swap type) ,z)) `(asm ,null-info ,(asm-store type) ,x ,y ,w ,u))) `(asm ,null-info ,(asm-store type) ,x ,y ,w ,z)))))])) (let () (define pick-asm-op (lambda (op info) (let ([flreg (info-loadfl-flreg info)]) (case op [(load-single->double load-double->single) (asm-fl-load/cvt op flreg)] [(store-single->double) (asm-fl-store/cvt op flreg)] [else (asm-fl-load/store op flreg)])))) (define-instruction effect (load-single->double load-double->single store-single->double store-single store-double load-single load-double) [(op (x ur) (y ur) (z uword8)) (if (eq? y %zero) `(asm ,info ,(pick-asm-op op info) ,x ,z) (let ([u (make-tmp 'u)]) (seq `(set! ,(make-live-info) ,u (asm ,info ,(asm-add #f) ,x ,y)) `(asm ,info ,(pick-asm-op op info) ,u ,z))))] [(op (x ur) (y ur) (z ur)) (let ([u (make-tmp 'u)]) (seq `(set! ,(make-live-info) ,u (asm ,info ,(asm-add #f) ,x ,z)) (if (eq? y %zero) `(asm ,info ,(pick-asm-op op info) ,u (immediate 0)) (seq `(set! ,(make-live-info) ,u (asm ,info ,(asm-add #f) ,u ,y)) `(asm ,info ,(pick-asm-op op info) ,u (immediate 0))))))])) (let () ; vldr, vstr allow only word offsets, and we require byte offset due to the type tag (module (with-flonum-data-pointers) (define $flonum-data-pointer (lambda (x p) (with-output-language (L15d Effect) (let ([u (make-tmp 'u)]) (seq `(set! ,(make-live-info) ,u (asm ,null-info ,(asm-add #f) ,x (immediate ,(constant flonum-data-disp)))) (p u)))))) (define-syntax with-flonum-data-pointers (syntax-rules () [(_ () e1 e2 ...) (begin e1 e2 ...)] [(_ (x1 x2 ...) e1 e2 ...) ($flonum-data-pointer x1 (lambda (x1) (with-flonum-data-pointers (x2 ...) e1 e2 ...)))]))) (define-instruction effect (flt) [(op (x ur) (y ur)) (with-flonum-data-pointers (y) `(asm ,info ,asm-flt ,x ,y))]) (define-instruction effect (fl+ fl- fl/ fl*) [(op (x ur) (y ur) (z ur)) (with-flonum-data-pointers (x y z) `(asm ,info ,(asm-flop-2 op) ,x ,y ,z))]) (define-instruction effect (flsqrt) [(op (x ur) (y ur)) (with-flonum-data-pointers (x y) `(asm ,info ,asm-flsqrt ,x ,y))]) (define-instruction value (trunc) [(op (z ur) (x ur)) (with-flonum-data-pointers (x) `(set! ,(make-live-info) ,z (asm ,info ,asm-trunc ,x)))]) (define-instruction pred (fl= fl< fl<=) [(op (x ur) (y ur)) (with-flonum-data-pointers (x y) (let ([info (make-info-condition-code op #f #f)]) (values '() `(asm ,info ,(asm-fl-relop info) ,x ,y))))])) (define-instruction effect (inc-cc-counter) [(op (x ur) (w ur funky12) (z funky12 ur)) (let ([u1 (make-tmp 'u1)] [u2 (make-tmp 'u2)]) (seq `(set! ,(make-live-info) ,u1 (asm ,null-info ,(asm-add #f) ,x ,w)) `(set! ,(make-live-info) ,u2 (asm ,null-info ,asm-kill)) `(asm ,null-info ,asm-inc-cc-counter ,u1 ,z ,u2)))]) (define-instruction effect (inc-profile-counter) [(op (x mem) (y ur funky12)) (let ([u (make-tmp 'u)]) (seq `(set! ,(make-live-info) ,u ,x) `(set! ,(make-live-info) ,u (asm ,null-info ,(asm-add #f) ,u ,y)) `(set! ,(make-live-info) ,x ,u)))]) (define-instruction value (read-time-stamp-counter) [(op (z ur)) `(set! ,(make-live-info) ,z (asm ,null-info ,(asm-read-counter 1)))]) (define-instruction value (read-performance-monitoring-counter) [(op (z ur) (x unsigned8)) ; could require unsigned1 and skip the fxmin...but no point burdening instruction scheduler with an additional one-off type (let ([imm (nanopass-case (L15d Triv) x [(immediate ,imm) (fxmin imm 1)])]) `(set! ,(make-live-info) ,z (asm ,null-info ,(asm-read-counter (fx+ imm 2)))))] [(op (z ur) (x ur)) `(set! ,(make-live-info) ,z (asm ,null-info ,(asm-read-counter) ,x))]) ;; no kills since we expect to be called when all necessary state has already been saved (define-instruction value (get-tc) [(op (z ur)) (safe-assert (eq? z %Cretval)) (let ([u (make-tmp 'u)] [ulr (make-precolored-unspillable 'ulr %lr)]) (seq `(set! ,(make-live-info) ,u (asm ,null-info ,asm-kill)) `(set! ,(make-live-info) ,ulr (asm ,null-info ,asm-kill)) `(set! ,(make-live-info) ,z (asm ,info ,asm-get-tc ,u ,ulr))))]) (define-instruction value (asmlibcall) [(op (z ur)) (let ([u (make-tmp 'u)]) (if (info-asmlib-save-ra? info) (seq `(set! ,(make-live-info) ,u (asm ,null-info ,asm-kill)) `(set! ,(make-live-info) ,z (asm ,info ,(asm-library-call (info-asmlib-libspec info) #t) ,u ,(info-kill*-live*-live* info) ...))) (let ([ulr (make-precolored-unspillable 'ulr %lr)]) (seq `(set! ,(make-live-info) ,u (asm ,null-info ,asm-kill)) `(set! ,(make-live-info) ,ulr (asm ,null-info ,asm-kill)) `(set! ,(make-live-info) ,z (asm ,info ,(asm-library-call (info-asmlib-libspec info) #f) ,u ,ulr ,(info-kill*-live*-live* info) ...))))))]) (define-instruction effect (asmlibcall!) [(op) (let ([u (make-tmp 'u)]) (if (info-asmlib-save-ra? info) (let ([ulr (make-precolored-unspillable 'ulr %lr)]) (seq `(set! ,(make-live-info) ,u (asm ,null-info ,asm-kill)) `(asm ,info ,(asm-library-call! (info-asmlib-libspec info) #t) ,u ,(info-kill*-live*-live* info) ...))) (let ([ulr (make-precolored-unspillable 'ulr %lr)]) (seq `(set! ,(make-live-info) ,u (asm ,null-info ,asm-kill)) `(set! ,(make-live-info) ,ulr (asm ,null-info ,asm-kill)) `(asm ,info ,(asm-library-call! (info-asmlib-libspec info) #f) ,u ,ulr ,(info-kill*-live*-live* info) ...)))))]) (safe-assert (reg-callee-save? %tc)) ; no need to save-restore (define-instruction effect (c-simple-call) [(op) (let ([u (make-tmp 'u)]) (if (info-c-simple-call-save-ra? info) (seq `(set! ,(make-live-info) ,u (asm ,null-info ,asm-kill)) `(asm ,info ,(asm-c-simple-call (info-c-simple-call-entry info) #t) ,u)) (let ([ulr (make-precolored-unspillable 'ulr %lr)]) (seq `(set! ,(make-live-info) ,u (asm ,null-info ,asm-kill)) `(set! ,(make-live-info) ,ulr (asm ,null-info ,asm-kill)) `(asm ,info ,(asm-c-simple-call (info-c-simple-call-entry info) #f) ,u ,ulr)))))]) (define-instruction pred (eq? u< < > <= >=) [(op (y funky12) (x ur)) (let ([info (if (eq? op 'eq?) info-cc-eq (make-info-condition-code op #t #t))]) (values '() `(asm ,info ,(asm-relop info) ,x ,y)))] [(op (x ur) (y ur funky12)) (let ([info (if (eq? op 'eq?) info-cc-eq (make-info-condition-code op #f #t))]) (values '() `(asm ,info ,(asm-relop info) ,x ,y)))]) (define-instruction pred (condition-code) [(op) (values '() `(asm ,info ,(asm-condition-code info)))]) (define-instruction pred (type-check?) [(op (x ur) (mask funky12 ur) (type funky12 ur)) (let ([tmp (make-tmp 'u)]) (values (with-output-language (L15d Effect) `(set! ,(make-live-info) ,tmp (asm ,null-info ,(asm-logand #f) ,x ,mask))) `(asm ,info-cc-eq ,asm-eq ,tmp ,type)))]) (define-instruction pred (logtest log!test) [(op (x funky12) (y ur)) (values '() `(asm ,info-cc-eq ,(asm-logtest (eq? op 'log!test) info-cc-eq) ,y ,x))] [(op (x ur) (y ur funky12)) (values '() `(asm ,info-cc-eq ,(asm-logtest (eq? op 'log!test) info-cc-eq) ,x ,y))]) (let () (define lea->reg (lambda (x y w k) (with-output-language (L15d Effect) (define add-offset (lambda (r) (if (eqv? (nanopass-case (L15d Triv) w [(immediate ,imm) imm]) 0) (k r) (let ([u (make-tmp 'u)]) (seq `(set! ,(make-live-info) ,u (asm ,null-info ,(asm-add #f) ,r ,w)) (k u)))))) (if (eq? y %zero) (add-offset x) (let ([u (make-tmp 'u)]) (seq `(set! ,(make-live-info) ,u (asm ,null-info ,(asm-add #f) ,x ,y)) (add-offset u))))))) ; NB: compiler ipmlements init-lock! and unlock! as 32-bit store of zero (define-instruction pred (lock!) [(op (x ur) (y ur) (w funky12)) (let ([u (make-tmp 'u)]) (values (lea->reg x y w (lambda (r) (with-output-language (L15d Effect) (seq `(set! ,(make-live-info) ,u (asm ,null-info ,asm-kill)) `(asm ,null-info ,asm-lock ,r ,u))))) `(asm ,info-cc-eq ,asm-eq ,u (immediate 0))))]) (define-instruction effect (locked-incr! locked-decr!) [(op (x ur) (y ur) (w funky12)) (lea->reg x y w (lambda (r) (let ([u1 (make-tmp 'u1)] [u2 (make-tmp 'u2)]) (seq `(set! ,(make-live-info) ,u1 (asm ,null-info ,asm-kill)) `(set! ,(make-live-info) ,u2 (asm ,null-info ,asm-kill)) `(asm ,null-info ,(asm-lock+/- op) ,r ,u1 ,u2)))))]) (define-instruction effect (cas) [(op (x ur) (y ur) (w funky12) (old ur) (new ur)) (lea->reg x y w (lambda (r) (let ([u1 (make-tmp 'u1)] [u2 (make-tmp 'u2)]) (seq `(set! ,(make-live-info) ,u1 (asm ,null-info ,asm-kill)) `(set! ,(make-live-info) ,u2 (asm ,null-info ,asm-kill)) `(asm ,info ,asm-cas ,r ,old ,new ,u1 ,u2)))))])) (define-instruction effect (pause) ; NB: user sqrt or something like that? [(op) '()]) (define-instruction effect (c-call) [(op (x ur)) (let ([ulr (make-precolored-unspillable 'ulr %lr)]) (seq `(set! ,(make-live-info) ,ulr (asm ,null-info ,asm-kill)) `(asm ,info ,asm-indirect-call ,x ,ulr ,(info-kill*-live*-live* info) ...)))]) (define-instruction effect (pop-multiple) [(op) `(asm ,info ,(asm-pop-multiple (info-kill*-kill* info)))]) (define-instruction effect (push-multiple) [(op) `(asm ,info ,(asm-push-multiple (info-kill*-live*-live* info)))]) (define-instruction effect (vpush-multiple) [(op) `(asm ,info ,(asm-vpush-multiple (info-vpush-reg info) (info-vpush-n info)))]) (define-instruction effect (vpop-multiple) [(op) `(asm ,info ,(asm-vpop-multiple (info-vpush-reg info) (info-vpush-n info)))]) (define-instruction effect save-flrv [(op) `(asm ,info ,asm-save-flrv)]) (define-instruction effect restore-flrv [(op) `(asm ,info ,asm-restore-flrv)]) (define-instruction effect (invoke-prelude) [(op) `(set! ,(make-live-info) ,%tc ,%Carg1)]) ) ;;; SECTION 3: assembler (module asm-module (; required exports asm-move asm-move/extend asm-load asm-store asm-swap asm-library-call asm-library-call! asm-library-jump asm-mul asm-smull asm-cmp/shift asm-add asm-sub asm-rsb asm-logand asm-logor asm-logxor asm-bic asm-pop-multiple asm-shiftop asm-logand asm-lognot asm-logtest asm-fl-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-indirect-call asm-condition-code asm-fl-load/store asm-fl-load/cvt asm-fl-store/cvt asm-flt asm-trunc asm-lock asm-lock+/- asm-cas asm-flop-2 asm-flsqrt asm-c-simple-call asm-save-flrv asm-restore-flrv asm-return asm-c-return asm-size asm-enter asm-foreign-call asm-foreign-callable asm-read-counter asm-inc-cc-counter funky12 shift-count? unsigned8? unsigned12? ; threaded version specific asm-get-tc ; machine dependent exports asm-kill info-vpush-reg info-vpush-n) (define-record-type info-vpush (nongenerative) (parent info) (sealed #t) (fields reg n)) (define ax-register? (case-lambda [(x) (record-case x [(reg) r #t] [else #f])] [(x reg) (record-case x [(reg) r (eq? r reg)] [else #f])])) (define-who ax-ea-reg-code (lambda (ea) (record-case ea [(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 [(reg) ignore #t] [else #f]))) (define ax-imm? (lambda (ea) (record-case ea [(imm) ignore #t] [else #f]))) (define-who ax-imm-data (lambda (ea) (record-case ea [(imm) (n) n] [else (sorry! who "ax-imm-data ea=~s" ea)]))) ; define-op sets up assembly op macros-- ; the opcode and all other expressions are passed to the specified handler-- (define-syntax define-op (lambda (x) (syntax-case x () [(k op handler e ...) (with-syntax ([op (construct-name #'k "asmop-" #'op)]) #'(define-syntax op (syntax-rules () [(_ mneu arg (... ...)) (handler 'mneu e ... arg (... ...))])))]))) (define-syntax emit (lambda (x) (syntax-case x () [(k op x ...) (with-syntax ([emit-op (construct-name #'k "asmop-" #'op)]) #'(emit-op op x ...))]))) ;;; note that the assembler isn't clever--you must be very explicit about ;;; which flavor you want, and there are a few new varieties introduced ;;; (commented-out opcodes are not currently used by the assembler-- ;;; spaces are left to indicate possible size extensions) (define-op movi1 movi-a1-op #b00111010) (define-op mvni movi-a1-op #b00111110) (define-op movi2 movi-a2-op #b00110000) ; ARMv6T, ARMv7 (define-op movt movi-a2-op #b00110100) ; ARMv6T, ARMv7 (define-op addi binary-imm-op #b0010100) (define-op addci binary-imm-op #b0010101) (define-op subi binary-imm-op #b0010010) (define-op rsbi binary-imm-op #b0010011) (define-op andi binary-imm-op #b0010000) (define-op orri binary-imm-op #b0011100) (define-op eori binary-imm-op #b0010001) (define-op bici binary-imm-op #b0011110) (define-op add binary-op #b0000100) (define-op sub binary-op #b0000010) (define-op rsb binary-op #b0000011) (define-op and binary-op #b0000000) (define-op orr binary-op #b0001100) (define-op eor binary-op #b0000001) (define-op bic binary-op #b0001110) (define-op cmp cmp-op #b0001010) (define-op tst cmp-op #b0001000) (define-op cmp/shift cmp-op #b0001010) (define-op cmpi cmp-imm-op #b0011010) (define-op tsti cmp-imm-op #b0011000) (define-op mov unary-op #b0001101 #f) ; note: for mov, bits 5-11 must be zero, corresponding to 00 shift type and 00000 shift count (define-op mvn unary-op #b0001111 #f) (define-op shifti shifti-op) (define-op shift shift-op) (define-op sxtb extend-op #b01101010) (define-op sxth extend-op #b01101011) (define-op uxtb extend-op #b01101110) (define-op uxth extend-op #b01101111) (define-op mul mul-op #b0000000) (define-op smull mull-op #b0000110) (define-op ldri load-imm-op #b1 #b0 #b010 #b0 #b1) (define-op ldrbi load-imm-op #b1 #b0 #b010 #b1 #b1) (define-op stri load-imm-op #b1 #b0 #b010 #b0 #b0) (define-op strbi load-imm-op #b1 #b0 #b010 #b1 #b0) (define-op str/preidx load-imm-op #b1 #b1 #b010 #b0 #b0) (define-op ldr/postidx load-imm-op #b0 #b0 #b010 #b0 #b1) (define-op ldrlit load-lit-op) (define-op ldrshi load-noshift-imm-op #b1 #b1111) (define-op ldrhi load-noshift-imm-op #b1 #b1011) (define-op ldrdi load-noshift-imm-op #b0 #b1101) (define-op ldrsbi load-noshift-imm-op #b1 #b1101) (define-op strhi load-noshift-imm-op #b0 #b1011) (define-op strdi load-noshift-imm-op #b0 #b1111) (define-op ldr load-op #b011 #b0 #b1) (define-op ldrb load-op #b011 #b1 #b1) (define-op str load-op #b011 #b0 #b0) (define-op strb load-op #b011 #b1 #b0) (define-op ldrsh load-noshift-op #b0 #b1 #b1111) (define-op ldrh load-noshift-op #b0 #b1 #b1011) (define-op ldrd load-noshift-op #b0 #b0 #b1101) (define-op ldrsb load-noshift-op #b0 #b1 #b1101) (define-op strh load-noshift-op #b0 #b0 #b1011) (define-op strd load-noshift-op #b0 #b0 #b1111) (define-op ldrex ldrex-op #b00011001) (define-op strex strex-op #b00011000) (define-op bnei branch-imm-op (ax-cond 'ne)) (define-op brai branch-imm-op (ax-cond 'al)) (define-op bx branch-reg-op (ax-cond 'al) #b0001) (define-op blx branch-reg-op (ax-cond 'al) #b0011) (define-op bra branch-label-op (ax-cond 'al)) (define-op beq branch-label-op (ax-cond 'eq)) (define-op bne branch-label-op (ax-cond 'ne)) (define-op blt branch-label-op (ax-cond 'lt)) (define-op ble branch-label-op (ax-cond 'le)) (define-op bgt branch-label-op (ax-cond 'gt)) (define-op bge branch-label-op (ax-cond 'ge)) (define-op bcc branch-label-op (ax-cond 'cc)) (define-op bcs branch-label-op (ax-cond 'cs)) (define-op bvc branch-label-op (ax-cond 'vc)) (define-op bvs branch-label-op (ax-cond 'vs)) (define-op bls branch-label-op (ax-cond 'ls)) (define-op bhi branch-label-op (ax-cond 'hi)) (define-op popm pm-op #b10001011) (define-op pushm pm-op #b10010010) (define-op vpushm vpm-op #b11010 #b10) (define-op vpopm vpm-op #b11001 #b11) (define-op vldr.sgl vldr/vstr-op #b1010 #b01) (define-op vldr.dbl vldr/vstr-op #b1011 #b01) (define-op vstr.sgl vldr/vstr-op #b1010 #b00) (define-op vstr.dbl vldr/vstr-op #b1011 #b00) (define-op vmov.gpr->s32 vmov-op #b0) (define-op vmov.s32->gpr vmov-op #b1) (define-op vcvt.sgl->dbl vcvt-op #b01 #b110111) (define-op vcvt.dbl->sgl vcvt-op #b11 #b110111) (define-op vcvt.s32->dbl vcvt-op #b11 #b111000) (define-op vcvt.dbl->s32 vcvt-op #b11 #b111101) (define-op vcmp vcmp-op) (define-op fpscr->apsr fpscr->apsr-op) (define-op rev rev-op #b01101011 #b0011) (define-op rev16 rev-op #b01101011 #b1011) (define-op revsh rev-op #b01101111 #b1011) (define-op mrs mrs-op) (define-op msr msr-op) (define-op mcr mrc/mcr-op #b0) (define-op mrc mrc/mcr-op #b1) (define-op vadd vadd-op #b11 #b0 #b11100) (define-op vsub vadd-op #b11 #b1 #b11100) (define-op vmul vadd-op #b10 #b0 #b11100) (define-op vdiv vadd-op #b00 #b0 #b11101) (define-op vsqrt vsqrt-op) (define-who movi-a1-op (lambda (op opcode dest-ea f12 code*) (emit-code (op dest-ea f12 code*) ; encoding A1 [28 (ax-cond 'al)] [20 opcode] [16 #b0000] [12 (ax-ea-reg-code dest-ea)] [0 f12]))) (define-who movi-a2-op ; ARMv6T, ARMv7 (lambda (op opcode dest-ea u16 code*) (emit-code (op dest-ea u16 code*) ; movi encoding A2 [28 (ax-cond 'al)] [20 opcode] [16 (fxsrl u16 12)] [12 (ax-ea-reg-code dest-ea)] [0 (fxlogand u16 #xfff)]))) (define shift-op (lambda (op dest-ea src0-ea src1-ea shift-type code*) (emit-code (shift-type dest-ea src0-ea src1-ea code*) [28 (ax-cond 'al)] [21 #b0001101] [20 #b0] [16 #b0000] [12 (ax-ea-reg-code dest-ea)] [8 (ax-ea-reg-code src1-ea)] [7 #b0] [5 (ax-shift-type shift-type)] [4 #b1] [0 (ax-ea-reg-code src0-ea)]))) (define shifti-op (lambda (op dest-ea src0-ea n shift-type code*) (emit-code (shift-type dest-ea src0-ea n code*) [28 (ax-cond 'al)] [21 #b0001101] [20 #b0] [16 #b0000] [12 (ax-ea-reg-code dest-ea)] [7 n] [5 (ax-shift-type shift-type)] [4 #b0] [0 (ax-ea-reg-code src0-ea)]))) (define pm-op (lambda (op opcode regs code*) (emit-code (op regs code*) [28 (ax-cond 'al)] [20 opcode] [16 #b1101] [0 (ax-register-list regs)]))) (define binary-imm-op ; 12-bit immediate (lambda (op opcode set-cc? dest-ea opnd-ea n code*) (emit-code (op set-cc? dest-ea opnd-ea n code*) [28 (ax-cond 'al)] [21 opcode] [20 (if set-cc? #b1 #b0)] [16 (ax-ea-reg-code opnd-ea)] [12 (ax-ea-reg-code dest-ea)] [0 (or (funky12 n) ($oops 'assembler-internal "binary-imm-op n=~s" n))]))) (define binary-op (lambda (op opcode set-cc? dest-ea opnd0-ea opnd1-ea code*) (emit-code (op set-cc? dest-ea opnd0-ea opnd1-ea code*) [28 (ax-cond 'al)] [21 opcode] [20 (if set-cc? #b1 #b0)] [16 (ax-ea-reg-code opnd0-ea)] [12 (ax-ea-reg-code dest-ea)] [7 #b00000] ; shift value [5 #b00] ; shift type [4 #b0] [0 (ax-ea-reg-code opnd1-ea)]))) (define mull-op (lambda (op opcode destlo-ea desthi-ea opnd0-ea opnd1-ea code*) (emit-code (op destlo-ea desthi-ea opnd0-ea opnd1-ea code*) [28 (ax-cond 'al)] [21 opcode] [20 #b0] ; don't need no stinking z & n bits [16 (ax-ea-reg-code desthi-ea)] [12 (ax-ea-reg-code destlo-ea)] [8 (ax-ea-reg-code opnd1-ea)] [4 #b1001] [0 (ax-ea-reg-code opnd0-ea)]))) (define unary-op (lambda (op opcode set-cc? dest-ea opnd-ea code*) (emit-code (op set-cc? dest-ea opnd-ea code*) [28 (ax-cond 'al)] [21 opcode] [20 (if set-cc? #b1 #b0)] [16 #b0000] [12 (ax-ea-reg-code dest-ea)] [7 #b00000] ; shift value [5 #b00] ; shift type [4 #b0] [0 (ax-ea-reg-code opnd-ea)]))) (define cmp-op (case-lambda [(op opcode opnd0-ea opnd1-ea code*) (emit-code (op opnd0-ea opnd1-ea code*) [28 (ax-cond 'al)] [21 opcode] [20 #b1] [16 (ax-ea-reg-code opnd0-ea)] [12 #b0000] [7 #b00000] ; shift value [5 (ax-shift-type 'sll)] [4 #b0] [0 (ax-ea-reg-code opnd1-ea)])] [(op opcode shift-count shift-type opnd0-ea opnd1-ea code*) (emit-code (op opnd0-ea shift-type opnd1-ea shift-count code*) [28 (ax-cond 'al)] [21 opcode] [20 #b1] [16 (ax-ea-reg-code opnd0-ea)] [12 #b0000] [7 shift-count] ; shift value [5 (ax-shift-type shift-type)] [4 #b0] [0 (ax-ea-reg-code opnd1-ea)])])) (define cmp-imm-op (lambda (op opcode opnd-ea n code*) (emit-code (op opnd-ea n code*) [28 (ax-cond 'al)] [21 opcode] [20 #b1] [16 (ax-ea-reg-code opnd-ea)] [12 #b0000] [0 (funky12 n)]))) (define extend-op (lambda (op opcode dest-ea opnd-ea code*) (emit-code (op dest-ea opnd-ea code*) [28 (ax-cond 'al)] [20 opcode] [16 #b1111] [12 (ax-ea-reg-code dest-ea)] [10 #b00] ; ROR value (0, 8, 16, 24) [4 #b000111] [0 (ax-ea-reg-code opnd-ea)]))) (define mul-op (lambda (op opcode set-cc? dest-ea opnd0-ea opnd1-ea code*) (emit-code (op set-cc? dest-ea opnd0-ea opnd1-ea code*) [28 (ax-cond 'al)] [21 opcode] [20 (if set-cc? #b1 #b0)] [16 (ax-ea-reg-code dest-ea)] [12 #b0000] [8 (ax-ea-reg-code opnd1-ea)] [4 #b1001] [0 (ax-ea-reg-code opnd0-ea)]))) (define ldrex-op (lambda (op opcode dest-ea opnd-ea code*) (emit-code (op dest-ea opnd-ea code*) [28 (ax-cond 'al)] [20 opcode] [16 (ax-ea-reg-code opnd-ea)] [12 (ax-ea-reg-code dest-ea)] [8 #b1111] [4 #b1001] [0 #b1111]))) (define strex-op (lambda (op opcode dest-ea opnd0-ea opnd1-ea code*) (emit-code (op dest-ea opnd0-ea opnd1-ea code*) [28 (ax-cond 'al)] [20 opcode] [16 (ax-ea-reg-code opnd1-ea)] [12 (ax-ea-reg-code dest-ea)] [8 #b1111] [4 #b1001] [0 (ax-ea-reg-code opnd0-ea)]))) (define branch-imm-op (lambda (op cond-bits disp code*) (emit-code (op disp code*) [28 cond-bits] [24 #b1010] [0 (fxlogand disp #xffffff)]))) (define-who branch-label-op (lambda (op cond-bits dest code*) (record-case dest [(label) (offset l) (emit-code (op dest code*) [28 cond-bits] [24 #b1010] [0 (fxlogand (fxsrl (fx- offset 4) 2) #xffffff)])] [else (sorry! who "unexpected dest ~s" dest)]))) (define-who branch-reg-op (lambda (op condition-code opcode dest code*) (emit-code (op dest code*) [28 condition-code] [20 #b00010010] [8 #b111111111111] [4 opcode] [0 (ax-ea-reg-code dest)]))) (define mrs-op (lambda (op dest code*) (emit-code (op dest code*) [28 (ax-cond 'al)] [16 #b000100001111] [12 (ax-ea-reg-code dest)] [0 #b000000000000]))) (define msr-op (lambda (op mask src code*) (emit-code (op mask src code*) [28 (ax-cond 'al)] [20 #b00010010] [18 mask] [4 #b00111100000000] [0 (ax-ea-reg-code src)]))) (define-who mrc/mcr-op (lambda (op dir cond coproc opc1 dest-ea CRn CRm opc2 code*) (emit-code (op cond coproc opc1 dest-ea CRn CRm opc2 code*) ; encoding A1 [28 (ax-cond cond)] [24 #b1110] [21 opc1] [20 dir] [16 CRn] [12 (ax-ea-reg-code dest-ea)] [8 coproc] [5 opc2] [4 1] [0 CRm]))) (define vldr/vstr-op (lambda (op opc1 opc2 flreg reg offset code*) (let-values ([(d vd) (ax-flreg->bits flreg)]) (emit-code (op flreg reg offset code*) [28 (ax-cond 'al)] [24 #b1101] ; NB: what's the source of the following comment? [23 #b1] ; U bit for adding or subtracting offset. using SP requires offset #-0 [22 d] [20 opc2] [16 (ax-ea-reg-code reg)] [12 vd] [8 opc1] [0 (fxsrl offset 2)])))) (define vmov-op (lambda (op dir flreg gpreg code*) (let-values ([(n vn) (ax-flreg->bits flreg)]) (emit-code (op flreg gpreg code*) [28 (ax-cond 'al)] [21 #b1110000] [20 dir] [16 vn] [12 (ax-ea-reg-code gpreg)] [8 #b1010] [7 n] [0 #b0010000])))) (define vcvt-op (lambda (op szop opc2 dest src code*) (let-values ([(d vd) (ax-flreg->bits dest)] [(m vm) (ax-flreg->bits src)]) (emit-code (op dest src code*) [28 (ax-cond 'al)] [23 #b11101] [22 d] [16 opc2] [12 vd] [9 #b101] [7 szop] [6 #b1] [5 m] [4 #b0] [0 vm])))) (define vcmp-op (lambda (op src1 src2 code*) (let-values ([(d vd) (ax-flreg->bits src1)] [(m vm) (ax-flreg->bits src2)]) (emit-code (op src1 src2 code*) [28 (ax-cond 'al)] [23 #b11101] [22 d] [16 #b110100] [12 vd] [9 #b101] [6 #b101] [5 m] [4 #b0] [0 vm])))) (define fpscr->apsr-op (lambda (op code*) (emit-code (op code*) [28 (ax-cond 'al)] [16 #b111011110001] [12 #b1111] [0 #b101000010000]))) (define vpm-op (lambda (op opcode opcode2 flreg n code*) (let-values ([(d vd) (ax-flreg->bits flreg)]) (emit-code (op flreg n code*) [28 (ax-cond 'al)] [23 opcode] [22 d] [20 opcode2] [16 #b1101] [12 vd] [8 #b1011] [0 (fxsll n 1)])))) (define rev-op (lambda (op opcode1 opcode2 dest-ea src-ea code*) (emit-code (op dest-ea src-ea code*) [28 (ax-cond 'al)] [20 opcode1] [16 #b1111] [12 (ax-ea-reg-code dest-ea)] [8 #b1111] [4 opcode2] [0 (ax-ea-reg-code src-ea)]))) (define load-op (lambda (op opcode1 opcode2 opcode3 dest-ea base-ea index-ea code*) (emit-code (op dest-ea base-ea index-ea code*) [28 (ax-cond 'al)] [25 opcode1] [24 #b1] ; P "Pay attention to index register" [23 #b1] ; U "Upward (add index)" [22 opcode2] [21 #b0] ; W "Write back" (post-increment/decrement) [20 opcode3] [16 (ax-ea-reg-code base-ea)] [12 (ax-ea-reg-code dest-ea)] [7 #b00000] ; shift amount [5 #b00] ; shift type [4 #b0] [0 (ax-ea-reg-code index-ea)]))) (define load-noshift-op (lambda (op opcode1 opcode2 opcode3 dest-ea base-ea index-ea code*) (emit-code (op dest-ea base-ea index-ea code*) [28 (ax-cond 'al)] [25 #b000] [24 #b1] ; P "Pay attention to index register" [23 #b1] ; U "Upward (add index)" [22 opcode1] [21 #b0] ; W "Write back" (post-increment/decrement) [20 opcode2] [16 (ax-ea-reg-code base-ea)] [12 (ax-ea-reg-code dest-ea)] [8 #b0000] [4 opcode3] [0 (ax-ea-reg-code index-ea)]))) (define load-imm-op (lambda (op P W opcode1 opcode2 opcode3 dest-ea base-ea orig-n code*) (let-values ([(U n) (if (fx< orig-n 0) (values 0 (fx- orig-n)) (values 1 orig-n))]) (emit-code (op dest-ea base-ea orig-n code*) [28 (ax-cond 'al)] [25 opcode1] [24 P] ; P "Pay attention to index register" [23 U] ; U "Upward (add index)" [22 opcode2] [21 W] ; W "Write back" (post-increment/decrement) [20 opcode3] [16 (ax-ea-reg-code base-ea)] [12 (ax-ea-reg-code dest-ea)] [0 n])))) (define load-noshift-imm-op (lambda (op opcode1 opcode2 dest-ea base-ea orig-n code*) (let-values ([(U n) (if (fx< orig-n 0) (values 0 (fx- orig-n)) (values 1 orig-n))]) (emit-code (op dest-ea orig-n code*) [28 (ax-cond 'al)] [25 #b000] [24 #b1] ; P "Pay attention to index register" [23 U] ; U "Upward (add index)" [22 #b1] [21 #b0] ; W "Write back" (post-increment/decrement) [20 opcode1] [16 (ax-ea-reg-code base-ea)] [12 (ax-ea-reg-code dest-ea)] [8 (fxsrl n 4)] [4 opcode2] [0 (fxlogand n #xf)])))) (define load-lit-op (lambda (op dest-ea orig-disp code*) (let-values ([(U disp) (if (fx< orig-disp 0) (values 0 (fx- orig-disp)) (values 1 orig-disp))]) (emit-code (op dest-ea orig-disp code*) [28 (ax-cond 'al)] [25 #b010] [24 #b1] [23 U] ; U "Upward (add index)" [22 #b0] [21 #b0] [20 #b1] [16 #b1111] [12 (ax-ea-reg-code dest-ea)] [0 disp])))) (define vadd-op (lambda (op opcode1 opcode2 opcode3 dest opnd1 opnd2 code*) (let-values ([(d vd) (ax-flreg->bits dest)] [(n vn) (ax-flreg->bits opnd1)] [(m vm) (ax-flreg->bits opnd2)]) (emit-code (op dest opnd1 opnd2 code*) [28 (ax-cond 'al)] [23 opcode3] [22 d] [20 opcode1] [16 vn] [12 vd] [9 #b101] [8 #b1] ;; sz = 1 for double [7 n] [6 opcode2] [5 m] [4 #b0] [0 vm])))) (define vsqrt-op (lambda (op dest src code*) (let-values ([(d vd) (ax-flreg->bits dest)] [(m vm) (ax-flreg->bits src)]) (emit-code (op dest src code*) [28 (ax-cond 'al)] [23 #b11101] [22 d] [20 #b11] [16 #b0001] [12 vd] [9 #b101] [8 #b1] ;; sz = 1 for double [7 #b1] [6 #b1] [5 m] [4 #b0] [0 vm])))) ; asm helpers (define-who ax-cond (lambda (x) (case x [(eq) #b0000] ; fl= [(ne) #b0001] [(cs) #b0010] ; u< [(cc) #b0011] ; u>=, fl< (for fl<, do we need this and mi?) [(mi) #b0100] ; fl< (for fl<, do we need this and cc?) [(pl) #b0101] [(vs) #b0110] [(vc) #b0111] [(hi) #b1000] ; u> [(ls) #b1001] ; u<=, fl<= [(ge) #b1010] ; fl>= [(lt) #b1011] [(gt) #b1100] ; fl> [(le) #b1101] [(al) #b1110] [else (sorry! who "unrecognized cond name ~s" x)]))) (define-who ax-shift-type (lambda (op) (case op [(sll) #b00] [(srl) #b01] [(sra) #b10] [(ror) #b11] [else ($oops who "unsupported op ~s" op)]))) (define ax-flreg->bits (lambda (flreg) (let ([n (reg-mdinfo flreg)]) (if (fx< n 32) (values (fxlogand n 1) (fxsrl n 1)) (values (fxsrl n 4) (fxlogand n #b1111)))))) (define-syntax emit-code (lambda (x) ; NB: probably won't need emit-code to weed out #f (define build-maybe-cons* (lambda (e* e-ls) (if (null? e*) e-ls #`(let ([t #,(car e*)] [ls #,(build-maybe-cons* (cdr e*) e-ls)]) (if t (cons t ls) ls))))) (syntax-case x () [(_ (op opnd ... ?code*) chunk ...) (build-maybe-cons* #'((build long (byte-fields chunk ...))) #'(aop-cons* `(asm ,op ,opnd ...) ?code*))]))) #;(define-syntax emit-code (lambda (x) (syntax-case x () [(_ (op opnd ... ?code*) chunk ...) (fold-right cons #'(aop-cons* `(asm ,op ,opnd ...) ?code*) #'((build long (byte-fields chunk ...))))]))) (define-who ax-size-code (lambda (x) (case x [(byte) 0] [(word) 1] [(long) 1] [else (sorry! who "invalid size ~s" x)]))) (define-syntax build (syntax-rules () [(_ x e) (and (memq (datum x) '(byte word long)) (integer? (datum e))) (quote (x . e))] [(_ x e) (memq (datum x) '(byte word long)) (cons 'x e)])) (define-syntax byte-fields ; NB: make more efficient for fixnums (syntax-rules () [(byte-fields (n e) ...) (andmap fixnum? (datum (n ...))) (+ (bitwise-arithmetic-shift-left e n) ...)])) (define ax-byte-size? (lambda (n) (<= -128 n 127))) (define ax-range? (lambda (low x high) (record-case x [(imm) (n) (<= low n high)] [else #f]))) (define ax-ea-branch-disp (lambda (dest-ea) (record-case dest-ea [(literal) stuff (cons 'rel stuff)] [else ($oops 'assembler-internal "ax-ea-branch-disp dest-ea=~s" dest-ea)]))) (define funky12 (lambda (n) (define (try limit n) (let* ([k (fxlogand (bitwise-first-bit-set n) (fxlognot 1))] [n (bitwise-arithmetic-shift-right n k)]) (and (and (fixnum? n) (#%$fxu< n #x100)) (fxlogor (fxsll (fx- limit k) 7) n)))) (if (and (fixnum? n) (#%$fxu< n #x100)) n (and (<= (- (expt 2 31)) n (- (expt 2 32) 1)) ; bounds check lets caller be sloppy about, e.g., NOT-ing or negating input (let ([n (if (< n 0) (+ (expt 2 32) n) n)]) (or (try 32 n) (try 8 (logor (bitwise-arithmetic-shift-left (logand n #xffffff) 8) (bitwise-arithmetic-shift-right n 24))))))))) ;; restrict funky12 so that an code offset n will not fit ;; if a smaller offset wouldn't fit, which prevents bouncing ;; in the loop that computes label offsets (define code-offset-funky12 (lambda (n) (safe-assert (and (fixnum? n) (fx= 0 (fxand n 3)))) (and (fixnum? n) (#%$fxu< n #x400) (funky12 n)))) (define shift-count? (lambda (imm) ; can also allow 0 for lsl and 32 (represented as 0) for lsr, asr ; but all three agree on the meaning of [1..31] (and (fixnum? imm) (fx<= 1 imm 31)))) (define unsigned8? (lambda (imm) (and (fixnum? imm) ($fxu< imm (expt 2 8))))) (define unsigned12? (lambda (imm) (and (fixnum? imm) ($fxu< imm (expt 2 12))))) (define branch-disp? (lambda (x) (and (fixnum? x) ; -4 accounts for fact that pc reads as the instruction after next, not next (fx<= (- (expt 2 25)) (fx- x 4) (- (expt 2 25) 1)) (not (fxlogtest x #b11))))) (define asm-size (lambda (x) (case (car x) [(asm arm32-abs arm32-jump arm32-call) 0] [else 4]))) (define ax-mov32 (lambda (dest n code*) ; NB: ARMv6T, ARMv7 only #;(emit movi dest (logand n #xffff) (emit movt dest (fxlogand (bitwise-arithmetic-shift-right n 16) #xffff) code*)) ; instead place n at pc+8, load from there, and branch around (emit ldrlit dest 0 (emit brai 0 (cons* `(long . ,n) (aop-cons* `(asm "long:" ,n) code*)))))) (define-who asm-move (lambda (code* dest src) ; move pseudo instruction used by set! case in select-instruction ; guarantees dest is a reg and src is reg, mem, or imm OR dest is ; mem and src is reg. (Trivit (dest src) (define (bad!) (sorry! who "unexpected combination of src ~s and dest ~s" src dest)) (cond [(ax-reg? dest) (record-case src [(reg) ignore (emit mov dest src code*)] [(imm) (n) (cond [(funky12 n) => (lambda (f12) (emit movi1 dest f12 code*))] [(funky12 (lognot n)) => (lambda (f12) (emit mvni dest f12 code*))] [else (ax-mov32 dest n code*)])] [(literal) stuff (ax-mov32 dest 0 (asm-helper-relocation code* (cons 'arm32-abs stuff)))] [(disp) (n breg) (safe-assert (or (unsigned12? n) (unsigned12? (- n)))) (emit ldri dest `(reg . ,breg) n code*)] [(index) (n ireg breg) (safe-assert (eqv? n 0)) (emit ldr dest `(reg . ,breg) `(reg . ,ireg) code*)] [else (bad!)])] [(ax-reg? src) (record-case dest [(disp) (n breg) (safe-assert (or (unsigned12? n) (unsigned12? (- n)))) (emit stri src `(reg . ,breg) n code*)] [(index) (n ireg breg) (safe-assert (eqv? n 0)) (emit str src `(reg . ,breg) `(reg . ,ireg) code*)] [else (bad!)])] [else (bad!)])))) (define-who asm-move/extend (lambda (op) (lambda (code* dest src) (Trivit (dest src) (case op [(sext8) (emit sxtb dest src code*)] [(sext16) (emit sxth dest src code*)] [(zext8) (emit uxtb dest src code*)] [(zext16) (emit uxth dest src code*)] [else (sorry! who "unexpected op ~s" op)]))))) (module (asm-add asm-sub asm-rsb asm-logand asm-logor asm-logxor asm-bic) (define-syntax define-asm-binop (syntax-rules () [(_ name opi op) (define name (lambda (set-cc?) (rec name (lambda (code* dest src0 src1) (Trivit (dest src0 src1) (record-case src1 [(imm) (n) (emit opi set-cc? dest src0 n code*)] [else (emit op set-cc? dest src0 src1 code*)]))))))])) (define-asm-binop asm-add addi add) (define-asm-binop asm-sub subi sub) (define-asm-binop asm-rsb rsbi rsb) (define-asm-binop asm-logand andi and) (define-asm-binop asm-logor orri orr) (define-asm-binop asm-logxor eori eor) (define-asm-binop asm-bic bici bic)) (define asm-mul (lambda (code* dest src0 src1) (Trivit (dest src0 src1) (emit mul #f dest src0 src1 code*)))) (define asm-smull (lambda (code* dest src0 src1 tmp) (Trivit (dest src0 src1 tmp) (emit smull dest tmp src0 src1 code*)))) (define asm-cmp/shift (lambda (count type) (lambda (code* src0 src1) (Trivit (src0 src1) (emit cmp/shift count type src0 src1 code*))))) (define-who asm-fl-load/cvt (lambda (op flreg) (lambda (code* base offset) (Trivit (base offset) (case op [(load-single->double) (emit vldr.sgl %flreg2 base (ax-imm-data offset) (emit vcvt.sgl->dbl flreg %flreg2 code*))] [(load-double->single) (emit vldr.dbl %flreg2 base (ax-imm-data offset) (emit vcvt.dbl->sgl flreg %flreg2 code*))] [else (sorry! who "unrecognized op ~s" op)]))))) (define-who asm-fl-store/cvt (lambda (op flreg) (lambda (code* base offset) (Trivit (base offset) (case op [(store-single->double) (emit vcvt.sgl->dbl %flreg2 flreg (emit vstr.dbl %flreg2 base (ax-imm-data offset) code*))] [else (sorry! who "unrecognized op ~s" op)]))))) (define-who asm-fl-load/store (lambda (op flreg) (lambda (code* base offset) (Trivit (base offset) (let ([offset (ax-imm-data offset)]) (case op [(load-single) (emit vldr.sgl flreg base offset code*)] [(load-double) (emit vldr.dbl flreg base offset code*)] [(store-single) (emit vstr.sgl flreg base offset code*)] [(store-double) (emit vstr.dbl flreg base offset code*)] [else (sorry! who "unrecognized op ~s" op)])))))) (define-who asm-load (lambda (type) (rec asm-load-internal (lambda (code* dest base index offset) (let ([n (nanopass-case (L16 Triv) offset [(immediate ,imm) imm] [else (sorry! who "unexpected non-immediate offset ~s" offset)])]) (Trivit (dest base) (cond [(eq? index %zero) (case type [(integer-32 unsigned-32) (emit ldri dest base n code*)] [(integer-16) (emit ldrshi dest base n code*)] [(unsigned-16) (emit ldrhi dest base n code*)] [(integer-8) (emit ldrsbi dest base n code*)] [(unsigned-8) (emit ldrbi dest base n code*)] [else (sorry! who "unexpected mref type ~s" type)])] [(eqv? n 0) (Trivit (index) (case type [(integer-32 unsigned-32) (emit ldr dest base index code*)] [(integer-16) (emit ldrsh dest base index code*)] [(unsigned-16) (emit ldrh dest base index code*)] [(integer-8) (emit ldrsb dest base index code*)] [(unsigned-8) (emit ldrb dest base index code*)] [else (sorry! who "unexpected mref type ~s" type)]))] [else (sorry! who "expected %zero index or 0 offset, got ~s and ~s" index offset)]))))))) (define-who asm-store (lambda (type) (rec asm-store-internal (lambda (code* base index offset src) (let ([n (nanopass-case (L16 Triv) offset [(immediate ,imm) imm] [else (sorry! who "unexpected non-immediate offset ~s" offset)])]) (Trivit (src base) (cond [(eq? index %zero) (case type [(integer-32 unsigned-32) (emit stri src base n code*)] [(integer-16 unsigned-16) (emit strhi src base n code*)] [(integer-8 unsigned-8) (emit strbi src base n code*)] [else (sorry! who "unexpected mref type ~s" type)])] [(eqv? n 0) (Trivit (index) (case type [(integer-32 unsigned-32) (emit str src base index code*)] [(integer-16 unsigned-16) (emit strh src base index code*)] [(integer-8 unsigned-8) (emit strb src base index code*)] [else (sorry! who "unexpected mref type ~s" type)]))] [else (sorry! who "expected %zero index or 0 offset, got ~s and ~s" index offset)]))))))) (define-who asm-flop-2 (lambda (op) (lambda (code* src1 src2 dest) (Trivit (src1 src2 dest) (emit vldr.dbl %flreg1 src1 0 (emit vldr.dbl %flreg2 src2 0 (let ([code* (emit vstr.dbl %flreg1 dest 0 code*)]) (case op [(fl+) (emit vadd %flreg1 %flreg1 %flreg2 code*)] [(fl-) (emit vsub %flreg1 %flreg1 %flreg2 code*)] [(fl*) (emit vmul %flreg1 %flreg1 %flreg2 code*)] [(fl/) (emit vdiv %flreg1 %flreg1 %flreg2 code*)] [else (sorry! who "unrecognized op ~s" op)])))))))) (define asm-flsqrt (lambda (code* src dest) (Trivit (src dest) (emit vldr.dbl %flreg1 src 0 (emit vsqrt %flreg1 %flreg1 (emit vstr.dbl %flreg1 dest 0 code*)))))) (define asm-trunc (lambda (code* dest flonumreg) (Trivit (dest flonumreg) (emit vldr.dbl %flreg1 flonumreg 0 (emit vcvt.dbl->s32 %flreg1 %flreg1 (emit vmov.s32->gpr %flreg1 dest code*)))))) (define asm-flt (lambda (code* src flonumreg) (Trivit (src flonumreg) (emit vmov.gpr->s32 %flreg1 src (emit vcvt.s32->dbl %flreg1 %flreg1 (emit vstr.dbl %flreg1 flonumreg 0 code*)))))) (define-who asm-swap (lambda (type) (rec asm-swap-internal (lambda (code* dest src) (Trivit (dest src) (case type [(integer-16) (emit revsh dest src code*)] [(unsigned-16) (emit rev16 dest src code*)] [(integer-32 unsigned-32) (emit rev dest src code*)] [else (sorry! who "unexpected asm-swap type argument ~s" type)])))))) (define asm-lock ; tmp = ldrex src ; cmp tmp, 0 ; bne L1 (+2) ; tmp = 1 ; tmp = strex tmp, src ;L1: (lambda (code* src tmp) (Trivit (src tmp) (emit ldrex tmp src (emit cmpi tmp 0 (emit bnei 1 (emit movi1 tmp 1 (emit strex tmp tmp src code*)))))))) (define-who asm-lock+/- ; L: ; tmp1 = ldrex src ; tmp1 = tmp1 +/- 1 ; tmp2 = strex tmp1, src ; cmp tmp2, 0 ; bne L (-6) ; cmp tmp1, 0 (lambda (op) (lambda (code* src tmp1 tmp2) (Trivit (src tmp1 tmp2) (emit ldrex tmp1 src (let ([code* (emit strex tmp2 tmp1 src (emit cmpi tmp2 0 (emit bnei -6 (emit cmpi tmp1 0 code*))))]) (case op [(locked-incr!) (emit addi #f tmp1 tmp1 1 code*)] [(locked-decr!) (emit subi #f tmp1 tmp1 1 code*)] [else (sorry! who "unexpected op ~s" op)]))))))) (define-who asm-cas ; tmp = ldrex src ; cmp tmp, old ; bne L (+2) ; tmp2 = strex new, src ; cmp tmp2, 0 ; L: (lambda (code* src old new tmp1 tmp2) (Trivit (src old new tmp1 tmp2) (emit ldrex tmp1 src (emit cmp tmp1 old (emit bnei 1 (emit strex tmp2 new src (emit cmpi tmp2 0 code*)))))))) (define asm-fl-relop (lambda (info) (lambda (l1 l2 offset x y) (Trivit (x y) (values (emit vldr.dbl %flreg1 x 0 (emit vldr.dbl %flreg2 y 0 (emit vcmp %flreg1 %flreg2 (emit fpscr->apsr '())))) (asm-conditional-jump info l1 l2 offset)))))) (define-who asm-relop (lambda (info) (rec asm-relop-internal (lambda (l1 l2 offset x y) (Trivit (x y) (unless (ax-reg? x) (sorry! who "unexpected first operand ~s" x)) (values (record-case y [(imm) (n) (emit cmpi x n '())] [(reg) ignore (emit cmp x y '())] [else (sorry! who "unexpected second operand ~s" y)]) (asm-conditional-jump info l1 l2 offset))))))) (define asm-condition-code (lambda (info) (rec asm-check-flag-internal (lambda (l1 l2 offset) (values '() (asm-conditional-jump info l1 l2 offset)))))) (define asm-pop-multiple (lambda (regs) (lambda (code*) (emit popm regs code*)))) (define asm-push-multiple (lambda (regs) (lambda (code*) (emit pushm regs code*)))) (define asm-vpush-multiple (lambda (reg n) (lambda (code*) (emit vpushm reg n code*)))) (define asm-vpop-multiple (lambda (reg n) (lambda (code*) (emit vpopm reg n code*)))) (define asm-save-flrv (lambda (code*) (let ([sp (cons 'reg %sp)]) (emit subi #f sp sp 8 (emit vstr.dbl %Cfpretval sp 0 code*))))) (define asm-restore-flrv (lambda (code*) (let ([sp (cons 'reg %sp)]) (emit vldr.dbl %Cfpretval sp 0 (emit addi #f sp sp 8 code*))))) (define asm-read-counter (case-lambda [(k) (lambda (code* dest) (Trivit (dest) (emit mrc 'al 15 0 dest 15 12 k code*)))] [() (lambda (code* dest src) (Trivit (dest src) (emit cmpi src 0 (emit mrc 'eq 15 0 dest 15 12 2 (emit mrc 'ne 15 0 dest 15 12 3 code*)))))])) (define asm-library-jump (lambda (l) (asm-helper-jump '() `(arm32-jump ,(constant code-data-disp) (library-code ,(libspec-label-libspec l)))))) (define asm-library-call (lambda (libspec save-ra?) (let ([target `(arm32-call ,(constant code-data-disp) (library-code ,libspec))]) (rec asm-asm-call-internal (lambda (code* dest jmp-tmp . ignore) ; ignore arguments, which must be in fixed locations (asm-helper-call code* target save-ra? jmp-tmp)))))) (define asm-library-call! (lambda (libspec save-ra?) (let ([target `(arm32-call ,(constant code-data-disp) (library-code ,libspec))]) (rec asm-asm-call-internal (lambda (code* jmp-tmp . ignore) ; ignore arguments, which must be in fixed locations (asm-helper-call code* target save-ra? jmp-tmp)))))) (define asm-c-simple-call (lambda (entry save-ra?) (let ([target `(arm32-call 0 (entry ,entry))]) (rec asm-c-simple-call-internal (lambda (code* jmp-tmp . ignore) (asm-helper-call code* target save-ra? jmp-tmp)))))) (define-who asm-indirect-call (lambda (code* dest lr . ignore) (safe-assert (eq? lr %lr)) (Trivit (dest) (unless (ax-reg? dest) (sorry! who "unexpected dest ~s" dest)) (emit blx dest code*)))) (define asm-direct-jump (lambda (l offset) (asm-helper-jump '() (make-funcrel 'arm32-jump l offset)))) (define asm-literal-jump (lambda (info) (asm-helper-jump '() `(arm32-jump ,(info-literal-offset info) (,(info-literal-type info) ,(info-literal-addr info)))))) (define-who asm-indirect-jump (lambda (src) (Trivit (src) (record-case src [(reg) ignore (emit bx src '())] [(disp) (n breg) (safe-assert (or (unsigned12? n) (unsigned12? (- n)))) (emit ldri `(reg . ,%pc) `(reg . ,breg) n '())] [(index) (n ireg breg) (safe-assert (eqv? n 0)) (emit ldr `(reg . ,%pc) `(reg . ,breg) `(reg . ,ireg) '())] [else (sorry! who "unexpected src ~s" src)])))) (define asm-logtest (lambda (i? info) (lambda (l1 l2 offset x y) (Trivit (x y) (values (record-case y [(imm) (n) (emit tsti x n '())] [else (emit tst x y '())]) (let-values ([(l1 l2) (if i? (values l2 l1) (values l1 l2))]) (asm-conditional-jump info l2 l1 offset))))))) (define asm-get-tc (let ([target `(arm32-call 0 (entry ,(lookup-c-entry get-thread-context)))]) (lambda (code* dest jmp-tmp . ignore) ; dest is ignored, since it is always Cretval (asm-helper-call code* target #f jmp-tmp)))) (define-who asm-return-address (lambda (dest l incr-offset next-addr) (make-rachunk dest l incr-offset next-addr (or (cond [(local-label-offset l) => (lambda (offset) (let ([disp (fx- next-addr (fx- offset incr-offset) 4)]) (cond [(code-offset-funky12 disp) (Trivit (dest) ; aka adr, encoding A1 (emit addi #f dest `(reg . ,%pc) disp '()))] [(code-offset-funky12 (- disp)) (Trivit (dest) ; aka adr, encoding A2 (emit subi #f dest `(reg . ,%pc) (- disp) '()))] [else #f])))] [else #f]) (asm-move '() dest (with-output-language (L16 Triv) `(label-ref ,l ,incr-offset))))))) (define-who asm-jump (lambda (l next-addr) (make-gchunk l next-addr (cond [(local-label-offset l) => (lambda (offset) (let ([disp (fx- next-addr offset)]) (cond [(eqv? disp 0) '()] [(branch-disp? disp) (emit bra `(label ,disp ,l) '())] ; will have to deal with this on architectures with smaller displacements. ; problem is we'll need a temp reg, and we discover this way past register ; allocation. so possibly compute the max possible code-object size at ; instruction selection time. when max possible size exceeds branch range ; (plus or minus), supply asm-jump and others like it an unspillable. don't ; want to supply an unspillable for smaller code objects since this ; unnecessarily constrains the register allocator. [else (sorry! who "no support for code objects > 32MB in length")])))] [else ; label must be somewhere above. generate something so that a hard loop ; doesn't get dropped. this also has some chance of being the right size ; for the final branch instruction. (emit bra `(label 0 ,l) '())])))) (define-who asm-conditional-jump (lambda (info l1 l2 next-addr) (define get-disp-opnd (lambda (next-addr l) (if (local-label? l) (cond [(local-label-offset l) => (lambda (offset) (let ([disp (fx- next-addr offset)]) (unless (branch-disp? disp) (sorry! who "no support for code objects > 32MB in length")) (values disp `(label ,disp ,l))))] [else (values 0 `(label 0 ,l))]) (sorry! who "unexpected label ~s" l)))) (let ([type (info-condition-code-type info)] [reversed? (info-condition-code-reversed? info)]) (make-cgchunk info l1 l2 next-addr (let () (define-syntax pred-case (lambda (x) (define build-bop-seq (lambda (bop opnd1 opnd2 l2 body) #`(let ([code* (emit #,bop #,opnd1 code*)]) (let-values ([(ignore #,opnd2) (get-disp-opnd (fx+ next-addr (asm-size* code*)) #,l2)]) #,body)))) (define ops->code (lambda (bop opnd) #`(emit #,bop #,opnd code*))) (define handle-reverse (lambda (e opnd l) (syntax-case e (r?) [(r? c1 c2) #`(if reversed? #,(ops->code #'c1 opnd) #,(ops->code #'c2 opnd))] [_ (ops->code e opnd)]))) (define handle-inverse (lambda (e) (syntax-case e (i?) [(i? c1 c2) #`(cond [(fx= disp1 0) #,(handle-reverse #'c1 #'opnd2 #'l2)] [(fx= disp2 0) #,(handle-reverse #'c2 #'opnd1 #'l1)] [else #,(build-bop-seq #'bra #'opnd2 #'opnd1 #'l1 (handle-reverse #'c2 #'opnd1 #'l1))])] [_ #`(cond [(fx= disp1 0) #,(handle-reverse e #'opnd2 #'l2)] [else #,(build-bop-seq #'bra #'opnd1 #'opnd2 #'l2 (handle-reverse e #'opnd2 #'l2))])]))) (syntax-case x () [(_ [(pred ...) cl-body] ...) (with-syntax ([(cl-body ...) (map handle-inverse #'(cl-body ...))]) #'(let ([code* '()]) (let-values ([(disp1 opnd1) (get-disp-opnd next-addr l1)] [(disp2 opnd2) (get-disp-opnd next-addr l2)]) (case type [(pred ...) cl-body] ... [else (sorry! who "~s branch type is currently unsupported" type)]))))]))) (pred-case [(eq?) (i? bne beq)] [(u<) (i? (r? bls bcs) (r? bhi bcc))] [(<) (i? (r? ble bge) (r? bgt blt))] [(<=) (i? (r? blt bgt) (r? bge ble))] [(>) (i? (r? bge ble) (r? blt bgt))] [(>=) (i? (r? bgt blt) (r? ble bge))] [(overflow) (i? bvc bvs)] [(multiply-overflow) (i? beq bne)] ; result of comparing sign bit of low word with all bits in high word: eq if no overflow, ne if overflow [(carry) (i? bcc bcs)] [(fl<) (i? (r? ble bcs) (r? bgt bcc))] [(fl<=) (i? (r? blt bhi) (r? bge bls))] [(fl=) (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 ; NB: jmp-tmp should be included in jump syntax, introduced by md-handle-jump, and passed in from code generator ; NB: probably works despite this since %ts is never live at the jmp point anyway (let ([jmp-tmp (cons 'reg %ts)]) (ax-mov32 jmp-tmp 0 (emit bx jmp-tmp (asm-helper-relocation code* reloc)))))) (define asm-kill (lambda (code* dest) code*)) (define ax-save/restore ; push/pop while maintaining 8-byte alignment (lambda (code* reg-ea p) (let ([sp (cons 'reg %sp)]) (emit str/preidx reg-ea sp -8 (p (emit ldr/postidx reg-ea sp 8 code*)))))) (define asm-helper-call (lambda (code* reloc save-ra? jmp-tmp) ; NB: kills %lr (let ([jmp-tmp (cons 'reg jmp-tmp)]) (define maybe-save-ra (lambda (code* p) (if save-ra? (ax-save/restore code* (cons 'reg %lr) p) (p code*)))) (maybe-save-ra code* (lambda (code*) (ax-mov32 jmp-tmp 0 (emit blx jmp-tmp (asm-helper-relocation code* reloc)))))))) (define asm-helper-relocation (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) (cons* (if (target-fixnum? lpm) `(long . ,(fix lpm)) `(abs 0 (object ,lpm))) (aop-cons* `(asm livemask: ,(format "~b" lpm)) '(code-top-link) (aop-cons* `(asm code-top-link) `(long . ,fs) (aop-cons* `(asm "frame size:" ,fs) (if mrvl (asm-data-label code* mrvl 0 func code-size) (cons* mrv-error (aop-cons* `(asm "mrv point:" ,mrv-error) 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) '()))) (define asm-c-return (lambda (info) (emit bx (cons 'reg %lr) '()))) (define-who asm-shiftop (lambda (op) (lambda (code* dest src0 src1) (Trivit (dest src0 src1) (record-case src1 [(imm) (n) (emit shifti dest src0 n op code*)] [else (emit shift dest src0 src1 op code*)]))))) (define asm-lognot (lambda (code* dest src) (Trivit (dest src) (emit mvn dest src code*)))) (define asm-enter values) (define-who asm-inc-cc-counter (lambda (code* addr val tmp) (Trivit (addr val tmp) (define do-ldr (lambda (offset k code*) (emit ldri tmp addr offset (k (emit stri tmp addr offset code*))))) (define do-add/cc (lambda (code*) (record-case val [(imm) (n) (emit addi #t tmp tmp n code*)] [else (emit add #t tmp tmp val code*)]))) (do-ldr 0 do-add/cc (emit bnei 2 (do-ldr 4 (lambda (code*) (emit addi #f tmp tmp 1 code*)) code*)))))) (module (asm-foreign-call asm-foreign-callable) (define align (lambda (b x) (let ([k (- b 1)]) (fxlogand (fx+ x k) (fxlognot k))))) (define (double-member? m) (and (eq? (car m) 'float) (fx= (cadr m) 8))) (define (float-member? m) (and (eq? (car m) 'float) (fx= (cadr m) 4))) (define (indirect-result-that-fits-in-registers? result-type) (nanopass-case (Ltype Type) result-type [(fp-ftd& ,ftd) (let* ([members ($ftd->members ftd)] [num-members (length members)]) (or (fx<= ($ftd-size ftd) 4) (and (fx= num-members 1) ;; a struct containing only int64 is not returned in a register (or (not ($ftd-compound? ftd)))) (and (fx<= num-members 4) (or (andmap double-member? members) (andmap float-member? members)))))] [else #f])) (define sgl-regs (lambda () (list %Cfparg1 %Cfparg1b %Cfparg2 %Cfparg2b %Cfparg3 %Cfparg3b %Cfparg4 %Cfparg4b %Cfparg5 %Cfparg5b %Cfparg6 %Cfparg6b %Cfparg7 %Cfparg7b %Cfparg8 %Cfparg8b))) (define-who asm-foreign-call (with-output-language (L13 Effect) (define int-regs (lambda () (list %Carg1 %Carg2 %Carg3 %Carg4))) (letrec ([load-double-stack (lambda (offset) (lambda (x) ; requires var (%seq (inline ,(make-info-loadfl %flreg1) ,%load-double ,x ,%zero ,(%constant flonum-data-disp)) (inline ,(make-info-loadfl %flreg1) ,%store-double ,%sp ,%zero (immediate ,offset)))))] [load-single-stack (lambda (offset) (lambda (x) ; requires var (%seq (inline ,(make-info-loadfl %flreg1) ,%load-double->single ,x ,%zero ,(%constant flonum-data-disp)) (inline ,(make-info-loadfl %flreg1) ,%store-single ,%sp ,%zero (immediate ,offset)))))] [load-int-stack (lambda (offset) (lambda (rhs) ; requires rhs `(set! ,(%mref ,%sp ,offset) ,rhs)))] [load-int64-stack (lambda (offset) (lambda (lorhs hirhs) ; requires rhs (%seq (set! ,(%mref ,%sp ,offset) ,lorhs) (set! ,(%mref ,%sp ,(fx+ offset 4)) ,hirhs))))] [load-int-indirect-stack (lambda (offset from-offset size) (lambda (x) ; requires var (case size [(3) (%seq (set! ,(%mref ,%sp ,offset) (inline ,(make-info-load 'integer-16 #f) ,%load ,x ,%zero (immediate ,from-offset))) (set! ,(%mref ,%sp ,(fx+ offset 2)) (inline ,(make-info-load 'integer-8 #f) ,%load ,x ,%zero (immediate ,(fx+ from-offset 2)))))] [else `(set! ,(%mref ,%sp ,offset) ,(case size [(1) `(inline ,(make-info-load 'integer-8 #f) ,%load ,x ,%zero (immediate ,from-offset))] [(2) `(inline ,(make-info-load 'integer-16 #f) ,%load ,x ,%zero (immediate ,from-offset))] [(4) (%mref ,x ,from-offset)]))])))] [load-int64-indirect-stack (lambda (offset from-offset) (lambda (x) ; requires var (%seq (set! ,(%mref ,%sp ,offset) ,(%mref ,x ,from-offset)) (set! ,(%mref ,%sp ,(fx+ offset 4)) ,(%mref ,x ,(fx+ from-offset 4))))))] [load-double-reg (lambda (fpreg fp-disp) (lambda (x) ; requires var `(inline ,(make-info-loadfl fpreg) ,%load-double ,x ,%zero (immediate ,fp-disp))))] [load-single-reg (lambda (fpreg fp-disp single?) (lambda (x) ; requires var `(inline ,(make-info-loadfl fpreg) ,(if single? %load-single %load-double->single) ,x ,%zero (immediate ,fp-disp))))] [load-int-reg (lambda (ireg) (lambda (x) `(set! ,ireg ,x)))] [load-int64-reg (lambda (loreg hireg) (lambda (lo hi) (%seq (set! ,loreg ,lo) (set! ,hireg ,hi))))] [load-int-indirect-reg (lambda (ireg from-offset size) (lambda (x) (case size [(3) (let ([tmp %lr]) ; ok to use %lr here? (%seq (set! ,ireg (inline ,(make-info-load 'integer-16 #f) ,%load ,x ,%zero (immediate ,from-offset))) (set! ,tmp (inline ,(make-info-load 'integer-8 #f) ,%load ,x ,%zero (immediate ,(fx+ from-offset 2)))) (set! ,tmp ,(%inline sll ,tmp (immediate 16))) (set! ,ireg ,(%inline + ,ireg ,tmp))))] [else `(set! ,ireg ,(case size [(1) `(inline ,(make-info-load 'integer-8 #f) ,%load ,x ,%zero (immediate ,from-offset))] [(2) `(inline ,(make-info-load 'integer-16 #f) ,%load ,x ,%zero (immediate ,from-offset))] [(4) (%mref ,x ,from-offset)]))])))] [load-int64-indirect-reg (lambda (loreg hireg from-offset) (lambda (x) (%seq (set! ,loreg ,(%mref ,x ,from-offset)) (set! ,hireg ,(%mref ,x ,(fx+ from-offset 4))))))] [do-args (lambda (types) ; sgl* is always of even-length, i.e., has a sgl/dbl reg first ; bsgl is set to "b" single (second half of double) if we have one to fill (let loop ([types types] [locs '()] [live* '()] [int* (int-regs)] [sgl* (sgl-regs)] [bsgl #f] [isp 0]) (if (null? types) (values isp locs live*) (nanopass-case (Ltype Type) (car types) [(fp-double-float) (if (null? sgl*) (let ([isp (align 8 isp)]) (loop (cdr types) (cons (load-double-stack isp) locs) live* int* '() #f (fx+ isp 8))) (loop (cdr types) (cons (load-double-reg (car sgl*) (constant flonum-data-disp)) locs) live* int* (cddr sgl*) bsgl isp))] [(fp-single-float) (if bsgl (loop (cdr types) (cons (load-single-reg bsgl (constant flonum-data-disp) #f) locs) live* int* sgl* #f isp) (if (null? sgl*) (loop (cdr types) (cons (load-single-stack isp) locs) live* int* '() #f (fx+ isp 4)) (loop (cdr types) (cons (load-single-reg (car sgl*) (constant flonum-data-disp) #f) locs) live* int* (cddr sgl*) (cadr sgl*) isp)))] [(fp-ftd& ,ftd) (let ([size ($ftd-size ftd)] [members ($ftd->members ftd)] [combine-loc (lambda (loc f) (if loc (lambda (x) (%seq ,(loc x) ,(f x))) f))]) (case ($ftd-alignment ftd) [(8) (let* ([int* (if (even? (length int*)) int* (cdr int*))] [num-members (length members)] [doubles? (and (fx<= num-members 4) (andmap double-member? members))]) ;; Sequence of up to 4 doubles that fits in registers? (cond [(and doubles? (fx>= (length sgl*) (fx* 2 num-members))) ;; Allocate each double to a register (let dbl-loop ([size size] [offset 0] [sgl* sgl*] [loc #f]) (cond [(fx= size 0) (loop (cdr types) (cons loc locs) live* int* sgl* #f isp)] [else (dbl-loop (fx- size 8) (fx+ offset 8) (cddr sgl*) (combine-loc loc (load-double-reg (car sgl*) offset)))]))] [else ;; General case; for non-doubles, use integer registers while available, ;; possibly splitting between registers and stack (let obj-loop ([size size] [offset 0] [loc #f] [live* live*] [int* int*] [isp isp]) (cond [(fx= size 0) (loop (cdr types) (cons loc locs) live* int* sgl* bsgl isp)] [else (if (or (null? int*) doubles?) (let ([isp (align 8 isp)]) (obj-loop (fx- size 8) (fx+ offset 8) (combine-loc loc (load-int64-indirect-stack isp offset)) live* int* (fx+ isp 8))) (obj-loop (fx- size 8) (fx+ offset 8) (combine-loc loc (load-int64-indirect-reg (car int*) (cadr int*) offset)) (cons* (car int*) (cadr int*) live*) (cddr int*) isp))]))]))] [else (let* ([num-members (length members)] [floats? (and (fx<= num-members 4) (andmap float-member? members))]) ;; Sequence of up to 4 floats that fits in registers? (cond [(and floats? (fx>= (fx+ (length sgl*) (if bsgl 1 0)) num-members)) ;; Allocate each float to register (let flt-loop ([size size] [offset 0] [sgl* sgl*] [bsgl bsgl] [loc #f]) (cond [(fx= size 0) (loop (cdr types) (cons loc locs) live* int* sgl* bsgl isp)] [else (flt-loop (fx- size 4) (fx+ offset 4) (if bsgl sgl* (cddr sgl*)) (if bsgl #f (cadr sgl*)) (combine-loc loc (load-single-reg (or bsgl (car sgl*)) offset #t)))]))] [else ;; General case; use integer registers while available, ;; possibly splitting between registers and stack (let obj-loop ([size size] [offset 0] [loc #f] [live* live*] [int* int*] [isp isp]) (cond [(fx<= size 0) (loop (cdr types) (cons loc locs) live* int* sgl* bsgl isp)] [else (if (or (null? int*) floats?) (obj-loop (fx- size 4) (fx+ offset 4) (combine-loc loc (load-int-indirect-stack isp offset (fxmin size 4))) live* int* (fx+ isp 4)) (obj-loop (fx- size 4) (fx+ offset 4) (combine-loc loc (load-int-indirect-reg (car int*) offset (fxmin size 4))) (cons (car int*) live*) (cdr int*) isp))]))]))]))] [else (if (nanopass-case (Ltype Type) (car types) [(fp-integer ,bits) (fx= bits 64)] [(fp-unsigned ,bits) (fx= bits 64)] [else #f]) (let ([int* (if (even? (length int*)) int* (cdr int*))]) (if (null? int*) (let ([isp (align 8 isp)]) (loop (cdr types) (cons (load-int64-stack isp) locs) live* '() sgl* bsgl (fx+ isp 8))) (loop (cdr types) (cons (load-int64-reg (car int*) (cadr int*)) locs) (cons* (car int*) (cadr int*) live*) (cddr int*) sgl* bsgl isp))) (if (null? int*) (loop (cdr types) (cons (load-int-stack isp) locs) live* '() sgl* bsgl (fx+ isp 4)) (loop (cdr types) (cons (load-int-reg (car int*)) locs) (cons (car int*) live*) (cdr int*) sgl* bsgl isp)))]))))] [add-fill-result (lambda (fill-result-here? result-type args-frame-size e) (cond [fill-result-here? (nanopass-case (Ltype Type) result-type [(fp-ftd& ,ftd) (let* ([members ($ftd->members ftd)] [num-members (length members)] ;; result pointer is stashed on the stack after all arguments: [dest-x %r2] [init-dest-e `(seq ,e (set! ,dest-x ,(%mref ,%sp ,args-frame-size)))]) (cond [(and (fx<= num-members 4) (or (andmap double-member? members) (andmap float-member? members))) ;; double/float results are in floating-point registers (let ([double? (and (pair? members) (double-member? (car members)))]) (let loop ([members members] [sgl* (sgl-regs)] [offset 0] [e init-dest-e]) (cond [(null? members) e] [else (loop (cdr members) (if double? (cddr sgl*) (cdr sgl*)) (fx+ offset (if double? 8 4)) `(seq ,e (inline ,(make-info-loadfl (car sgl*)) ,(if double? %store-double %store-single) ,dest-x ,%zero (immediate ,offset))))])))] [else ;; result is in %Cretval and maybe %r1 `(seq ,init-dest-e ,(case ($ftd-size ftd) [(1) `(inline ,(make-info-load 'integer-8 #f) ,%store ,dest-x ,%zero (immediate 0) ,%Cretval)] [(2) `(inline ,(make-info-load 'integer-16 #f) ,%store ,dest-x ,%zero (immediate 0) ,%Cretval)] [(3) (%seq (inline ,(make-info-load 'integer-16 #f) ,%store ,dest-x ,%zero (immediate 0) ,%Cretval) (set! ,%Cretval ,(%inline srl ,%Cretval (immediate 16))) (inline ,(make-info-load 'integer-8 #f) ,%store ,dest-x ,%zero (immediate 2) ,%Cretval))] [(4) `(set! ,(%mref ,dest-x ,0) ,%Cretval)] [(8) `(seq (set! ,(%mref ,dest-x ,0) ,%Cretval) (set! ,(%mref ,dest-x ,4) ,%r1))]))]))])] [else e]))]) (lambda (info) (safe-assert (reg-callee-save? %tc)) ; no need to save-restore (let* ([arg-type* (info-foreign-arg-type* info)] [result-type (info-foreign-result-type info)] [fill-result-here? (indirect-result-that-fits-in-registers? result-type)]) (with-values (do-args (if fill-result-here? (cdr arg-type*) arg-type*)) (lambda (args-frame-size locs live*) (let* ([frame-size (align 8 (+ args-frame-size (if fill-result-here? 4 0)))] [adjust-frame (lambda (op) (lambda () (if (fx= frame-size 0) `(nop) `(set! ,%sp (inline ,null-info ,op ,%sp (immediate ,frame-size))))))]) (values (adjust-frame %-) (let ([locs (reverse locs)]) (cond [fill-result-here? ;; stash extra argument on the stack to be retrieved after call and filled with the result: (cons (load-int-stack args-frame-size) locs)] [else locs])) (lambda (t0) (add-fill-result fill-result-here? result-type args-frame-size `(inline ,(make-info-kill*-live* (reg-list %r0) live*) ,%c-call ,t0))) (nanopass-case (Ltype Type) result-type [(fp-double-float) (lambda (lvalue) `(inline ,(make-info-loadfl %Cfpretval) ,%store-double ,lvalue ,%zero ,(%constant flonum-data-disp)))] [(fp-single-float) (lambda (lvalue) `(inline ,(make-info-loadfl %Cfpretval) ,%store-single->double ,lvalue ,%zero ,(%constant flonum-data-disp)))] [(fp-integer ,bits) (case bits [(8) (lambda (lvalue) `(set! ,lvalue ,(%inline sext8 ,%r0)))] [(16) (lambda (lvalue) `(set! ,lvalue ,(%inline sext16 ,%r0)))] [(32) (lambda (lvalue) `(set! ,lvalue ,%r0))] [(64) (lambda (lvlow lvhigh) `(seq (set! ,lvhigh ,%r1) (set! ,lvlow ,%r0)))] [else (sorry! who "unexpected asm-foreign-procedures fp-integer size ~s" bits)])] [(fp-unsigned ,bits) (case bits [(8) (lambda (lvalue) `(set! ,lvalue ,(%inline zext8 ,%r0)))] [(16) (lambda (lvalue) `(set! ,lvalue ,(%inline zext16 ,%r0)))] [(32) (lambda (lvalue) `(set! ,lvalue ,%r0))] [(64) (lambda (lvlow lvhigh) `(seq (set! ,lvhigh ,%r1) (set! ,lvlow ,%r0)))] [else (sorry! who "unexpected asm-foreign-procedures fp-unsigned size ~s" bits)])] [else (lambda (lvalue) `(set! ,lvalue ,%r0))]) (adjust-frame %+))) ))))))) (define-who asm-foreign-callable #| Frame Layout +---------------------------+ | | | incoming stack args | sp+52+R+X+Y+Z+W: | | +---------------------------+<- 8-byte boundary | | | saved int reg args | 0-4 words sp+52+R+X+Y+Z: | | +---------------------------+ | | | pad word if necessary | 0-1 words sp+52+R+X+Y: | | +---------------------------+<- 8-byte boundary | | | saved float reg args | 0-16 words sp+52+R+X: | | +---------------------------+<- 8-byte boundary | | | &-return space | up to 8 words sp+52+R: | | +---------------------------+<- 8-byte boundary | | | pad word if necessary | 0-1 words sp+52: | | +---------------------------+ | | | callee-save regs + lr | 13 words sp+0: | callee-save fpregs | +---------------------------+<- 8-byte boundary X = 0 or 4 (depending on whether pad is present) Y = int-reg-bytes Z = float-reg-bytes |# (with-output-language (L13 Effect) (let () (define load-double-stack (lambda (offset) (lambda (x) ; requires var (%seq (inline ,(make-info-loadfl %flreg1) ,%load-double ,%sp ,%zero (immediate ,offset)) (inline ,(make-info-loadfl %flreg1) ,%store-double ,x ,%zero ,(%constant flonum-data-disp)))))) (define load-single-stack (lambda (offset) (lambda (x) ; requires var (%seq (inline ,(make-info-loadfl %flreg1) ,%load-single->double ,%sp ,%zero (immediate ,offset)) (inline ,(make-info-loadfl %flreg1) ,%store-double ,x ,%zero ,(%constant flonum-data-disp)))))) (define load-int-stack (lambda (type offset) (lambda (lvalue) (nanopass-case (Ltype Type) type [(fp-integer ,bits) (case bits [(8) `(set! ,lvalue (inline ,(make-info-load 'integer-8 #f) ,%load ,%sp ,%zero (immediate ,offset)))] [(16) `(set! ,lvalue (inline ,(make-info-load 'integer-16 #f) ,%load ,%sp ,%zero (immediate ,offset)))] [(32) `(set! ,lvalue ,(%mref ,%sp ,offset))] [else (sorry! who "unexpected load-int-stack fp-integer size ~s" bits)])] [(fp-unsigned ,bits) (case bits [(8) `(set! ,lvalue (inline ,(make-info-load 'unsigned-8 #f) ,%load ,%sp ,%zero (immediate ,offset)))] [(16) `(set! ,lvalue (inline ,(make-info-load 'unsigned-16 #f) ,%load ,%sp ,%zero (immediate ,offset)))] [(32) `(set! ,lvalue ,(%mref ,%sp ,offset))] [else (sorry! who "unexpected load-int-stack fp-unsigned size ~s" bits)])] [else `(set! ,lvalue ,(%mref ,%sp ,offset))])))) (define load-int64-stack (lambda (offset) (lambda (lolvalue hilvalue) (%seq (set! ,lolvalue ,(%mref ,%sp ,offset)) (set! ,hilvalue ,(%mref ,%sp ,(fx+ offset 4))))))) (define load-stack-address (lambda (offset) (lambda (lvalue) `(set! ,lvalue ,(%inline + ,%sp (immediate ,offset)))))) (define count-reg-args (lambda (types synthesize-first?) ; bsgl? is #t iff we have a "b" single (second half of double) float reg to fill (let f ([types types] [iint (if synthesize-first? -1 0)] [idbl 0] [bsgl? #f]) (if (null? types) (values iint idbl) (nanopass-case (Ltype Type) (car types) [(fp-double-float) (if (fx< idbl 8) (f (cdr types) iint (fx+ idbl 1) bsgl?) (f (cdr types) iint idbl #f))] [(fp-single-float) (if bsgl? (f (cdr types) iint idbl #f) (if (fx< idbl 8) (f (cdr types) iint (fx+ idbl 1) #t) (f (cdr types) iint idbl #f)))] [(fp-ftd& ,ftd) (let* ([size ($ftd-size ftd)] [members ($ftd->members ftd)] [num-members (length members)]) (cond [(and (fx<= num-members 4) (andmap double-member? members)) ;; doubles are either in registers or all on stack (if (fx<= (fx+ idbl num-members) 8) (f (cdr types) iint (fx+ idbl num-members) #f) ;; no more floating-point registers should be used, but ok if we count more (f (cdr types) iint idbl #f))] [(and (fx<= num-members 4) (andmap float-member? members)) ;; floats are either in registers or all on stack (let ([amt (fxsrl (align 2 (fx- num-members (if bsgl? 1 0))) 1)]) (if (fx<= (fx+ idbl amt) 8) (let ([odd-floats? (fxodd? num-members)]) (if bsgl? (f (cdr types) iint (+ idbl amt) (not odd-floats?)) (f (cdr types) iint (+ idbl amt) odd-floats?))) ;; no more floating-point registers should be used, but ok if we count more (f (cdr types) iint idbl #f)))] [(fx= 8 ($ftd-alignment ftd)) (f (cdr types) (fxmin 4 (fx+ (align 2 iint) (fxsrl size 2))) idbl bsgl?)] [else (let ([size (align 4 size)]) (f (cdr types) (fxmin 4 (fx+ iint (fxsrl size 2))) idbl bsgl?))]))] [else (if (nanopass-case (Ltype Type) (car types) [(fp-integer ,bits) (fx= bits 64)] [(fp-unsigned ,bits) (fx= bits 64)] [else #f]) (let ([iint (align 2 iint)]) (f (cdr types) (if (fx< iint 4) (fx+ iint 2) iint) idbl bsgl?)) (f (cdr types) (if (fx< iint 4) (fx+ iint 1) iint) idbl bsgl?))]))))) (define do-stack ; all of the args are on the stack at this point, though not contiguous since ; we push all of the int reg args with one push instruction and all of the ; float reg args with another (v)push instruction; the saved int regs ; continue on into the stack variables, which is convenient when a struct ; argument is split across registers and the stack (lambda (types saved-reg-bytes pre-pad-bytes return-bytes float-reg-bytes post-pad-bytes int-reg-bytes synthesize-first?) (let* ([return-space-offset (fx+ saved-reg-bytes pre-pad-bytes)] [float-reg-offset (fx+ return-space-offset return-bytes)] [int-reg-offset (fx+ float-reg-offset float-reg-bytes post-pad-bytes)] [stack-arg-offset (fx+ int-reg-offset int-reg-bytes)]) (let loop ([types (if synthesize-first? (cdr types) types)] [locs '()] [iint 0] [idbl 0] [bsgl-offset #f] [int-reg-offset int-reg-offset] [float-reg-offset float-reg-offset] [stack-arg-offset stack-arg-offset]) (if (null? types) (let ([locs (reverse locs)]) (if synthesize-first? (cons (load-stack-address return-space-offset) locs) locs)) (nanopass-case (Ltype Type) (car types) [(fp-double-float) (if (< idbl 8) (loop (cdr types) (cons (load-double-stack float-reg-offset) locs) iint (fx+ idbl 1) bsgl-offset int-reg-offset (fx+ float-reg-offset 8) stack-arg-offset) (let ([stack-arg-offset (align 8 stack-arg-offset)]) (loop (cdr types) (cons (load-double-stack stack-arg-offset) locs) iint 8 #f int-reg-offset float-reg-offset (fx+ stack-arg-offset 8))))] [(fp-single-float) (if bsgl-offset (loop (cdr types) (cons (load-single-stack bsgl-offset) locs) iint idbl #f int-reg-offset float-reg-offset stack-arg-offset) (if (< idbl 8) (loop (cdr types) ; with big-endian ARM might need to adjust offset +/- 4 since pair of ; single floats in a pushed double float might be reversed (cons (load-single-stack float-reg-offset) locs) iint (fx+ idbl 1) (fx+ float-reg-offset 4) int-reg-offset (fx+ float-reg-offset 8) stack-arg-offset) (loop (cdr types) (cons (load-single-stack stack-arg-offset) locs) iint 8 #f int-reg-offset float-reg-offset (fx+ stack-arg-offset 4))))] [(fp-ftd& ,ftd) (let* ([size ($ftd-size ftd)] [members ($ftd->members ftd)] [num-members (length members)]) (cond [(and (fx<= num-members 4) (andmap double-member? members)) ;; doubles are either in registers or all on stack (if (fx<= (fx+ idbl num-members) 8) (loop (cdr types) (cons (load-stack-address float-reg-offset) locs) iint (fx+ idbl num-members) #f int-reg-offset (fx+ float-reg-offset size) stack-arg-offset) (let ([stack-arg-offset (align 8 stack-arg-offset)]) (loop (cdr types) (cons (load-stack-address stack-arg-offset) locs) iint 8 #f int-reg-offset #f (fx+ stack-arg-offset size))))] [(and (fx<= num-members 4) (andmap float-member? members)) ;; floats are either in registers or all on stack (let ([amt (fxsrl (align 2 (fx- num-members (if bsgl-offset 1 0))) 1)]) (if (fx<= (fx+ idbl amt) 8) (let ([odd-floats? (fxodd? num-members)]) (if bsgl-offset (let ([dbl-size (align 8 (fx- size 4))]) (loop (cdr types) (cons (load-stack-address bsgl-offset) locs) iint (fx+ idbl amt) (if odd-floats? #f (+ bsgl-offset size)) int-reg-offset (fx+ float-reg-offset dbl-size) stack-arg-offset)) (let ([dbl-size (align 8 size)]) (loop (cdr types) (cons (load-stack-address float-reg-offset) locs) iint (fx+ idbl amt) (and odd-floats? (fx+ float-reg-offset size)) int-reg-offset (fx+ float-reg-offset dbl-size) stack-arg-offset)))) (loop (cdr types) (cons (load-stack-address stack-arg-offset) locs) iint 8 #f int-reg-offset float-reg-offset (fx+ stack-arg-offset size))))] [(fx= 8 ($ftd-alignment ftd)) (let ([int-reg-offset (if (fxeven? iint) int-reg-offset (fx+ int-reg-offset 4))] [iint (align 2 iint)] [amt (fxsrl size 2)]) (if (fx< iint 4) ; argument starts in registers, may continue on stack (loop (cdr types) (cons (load-stack-address int-reg-offset) locs) (fxmin 4 (fx+ iint amt)) idbl bsgl-offset (fx+ int-reg-offset size) float-reg-offset (fx+ stack-arg-offset (fxmax 0 (fx* 4 (fx- (fx+ iint amt) 4))))) (let ([stack-arg-offset (align 8 stack-arg-offset)]) (loop (cdr types) (cons (load-stack-address stack-arg-offset) locs) iint idbl bsgl-offset int-reg-offset float-reg-offset (fx+ stack-arg-offset size)))))] [else (let* ([size (align 4 size)] [amt (fxsrl size 2)]) (if (fx< iint 4) ; argument starts in registers, may continue on stack (loop (cdr types) (cons (load-stack-address int-reg-offset) locs) (fxmin 4 (fx+ iint amt)) idbl bsgl-offset (fx+ int-reg-offset size) float-reg-offset (fx+ stack-arg-offset (fxmax 0 (fx* 4 (fx- (fx+ iint amt) 4))))) (loop (cdr types) (cons (load-stack-address stack-arg-offset) locs) iint idbl bsgl-offset int-reg-offset float-reg-offset (fx+ stack-arg-offset size))))]))] [else (if (nanopass-case (Ltype Type) (car types) [(fp-integer ,bits) (fx= bits 64)] [(fp-unsigned ,bits) (fx= bits 64)] [else #f]) (let ([int-reg-offset (if (fxeven? iint) int-reg-offset (fx+ int-reg-offset 4))] [iint (align 2 iint)]) (if (fx= iint 4) (let ([stack-arg-offset (align 8 stack-arg-offset)]) (loop (cdr types) (cons (load-int64-stack stack-arg-offset) locs) iint idbl bsgl-offset int-reg-offset float-reg-offset (fx+ stack-arg-offset 8))) (loop (cdr types) (cons (load-int64-stack int-reg-offset) locs) (fx+ iint 2) idbl bsgl-offset (fx+ int-reg-offset 8) float-reg-offset stack-arg-offset))) (if (fx= iint 4) (loop (cdr types) (cons (load-int-stack (car types) stack-arg-offset) locs) iint idbl bsgl-offset int-reg-offset float-reg-offset (fx+ stack-arg-offset 4)) (loop (cdr types) (cons (load-int-stack (car types) int-reg-offset) locs) (fx+ iint 1) idbl bsgl-offset (fx+ int-reg-offset 4) float-reg-offset stack-arg-offset)))])))))) (define do-result (lambda (result-type synthesize-first? return-stack-offset) (nanopass-case (Ltype Type) result-type [(fp-ftd& ,ftd) (let* ([members ($ftd->members ftd)] [num-members (length members)]) (cond [(and (fx<= 1 num-members 4) (or (andmap double-member? members) (andmap float-member? members))) ;; double/float results returned in floating-point registers (values (lambda () (let ([double? (and (pair? members) (double-member? (car members)))]) (let loop ([members members] [sgl* (sgl-regs)] [offset return-stack-offset] [e #f]) (cond [(null? members) e] [else (loop (cdr members) (if double? (cddr sgl*) (cdr sgl*)) (fx+ offset (if double? 8 4)) (let ([new-e `(inline ,(make-info-loadfl (car sgl*)) ,(if double? %load-double %load-single) ,%sp ,%zero (immediate ,offset))]) (if e `(seq ,e ,new-e) new-e)))])))) '() ($ftd-size ftd))] [else (case ($ftd-size ftd) [(8) (values (lambda () `(seq (set! ,%Cretval ,(%mref ,%sp ,return-stack-offset)) (set! ,%r1 ,(%mref ,%sp ,(fx+ 4 return-stack-offset))))) (list %Cretval %r1) 8)] [else (values (lambda () (case ($ftd-size ftd) [(1) (let ([rep (if ($ftd-unsigned? ftd) 'unsigned-8 'integer-8)]) `(set! ,%Cretval (inline ,(make-info-load rep #f) ,%load ,%sp ,%zero (immediate ,return-stack-offset))))] [(2) (let ([rep (if ($ftd-unsigned? ftd) 'unsigned-16 'integer-16)]) `(set! ,%Cretval (inline ,(make-info-load rep #f) ,%load ,%sp ,%zero (immediate ,return-stack-offset))))] [else `(set! ,%Cretval ,(%mref ,%sp ,return-stack-offset))])) (list %Cretval) 4)])]))] [(fp-double-float) (values (lambda (rhs) `(inline ,(make-info-loadfl %Cfpretval) ,%load-double ,rhs ,%zero ,(%constant flonum-data-disp))) '() 0)] [(fp-single-float) (values (lambda (rhs) `(inline ,(make-info-loadfl %Cfpretval) ,%load-double->single ,rhs ,%zero ,(%constant flonum-data-disp))) '() 0)] [(fp-void) (values (lambda () `(nop)) '() 0)] [else (cond [(nanopass-case (Ltype Type) result-type [(fp-integer ,bits) (fx= bits 64)] [(fp-unsigned ,bits) (fx= bits 64)] [else #f]) (values (lambda (lo hi) `(seq (set! ,%Cretval ,lo) (set! ,%r1 ,hi))) (list %Cretval %r1) 0)] [else (values (lambda (x) `(set! ,%Cretval ,x)) (list %Cretval) 0)])]))) (lambda (info) (define callee-save-regs+lr (list %r4 %r5 %r6 %r7 %r8 %r9 %r10 %r11 %lr)) (define callee-save-fpregs (list %flreg1 %flreg2)) ; must be consecutive (define isaved (length callee-save-regs+lr)) (define fpsaved (length callee-save-fpregs)) (let* ([arg-type* (info-foreign-arg-type* info)] [result-type (info-foreign-result-type info)] [synthesize-first? (indirect-result-that-fits-in-registers? result-type)]) (let-values ([(iint idbl) (count-reg-args arg-type* synthesize-first?)]) (let ([saved-reg-bytes (fx+ (fx* isaved 4) (fx* fpsaved 8))] [pre-pad-bytes (if (fxeven? isaved) 0 4)] [int-reg-bytes (fx* iint 4)] [post-pad-bytes (if (fxeven? iint) 0 4)] [float-reg-bytes (fx* idbl 8)]) (let-values ([(get-result result-regs return-bytes) (do-result result-type synthesize-first? (fx+ saved-reg-bytes pre-pad-bytes))]) (let ([return-bytes (align 8 return-bytes)]) (values (lambda () (%seq ; save argument register values to the stack so we don't lose the values ; across possible calls to C while setting up the tc and allocating memory ,(if (fx= iint 0) `(nop) `(inline ,(make-info-kill*-live* '() (list-head (list %Carg1 %Carg2 %Carg3 %Carg4) iint)) ,%push-multiple)) ; pad if necessary to force 8-byte boundary, and make room for indirect return: ,(let ([len (+ post-pad-bytes return-bytes)]) (if (fx= len 0) `(nop) `(set! ,%sp ,(%inline - ,%sp (immediate ,len))))) ,(if (fx= idbl 0) `(nop) `(inline ,(make-info-vpush %Cfparg1 idbl) ,%vpush-multiple)) ; pad if necessary to force 8-byte boundary after saving callee-save-regs+lr ,(if (fx= pre-pad-bytes 0) `(nop) `(set! ,%sp ,(%inline - ,%sp (immediate 4)))) ; save the callee save registers & return address (inline ,(make-info-kill*-live* '() callee-save-regs+lr) ,%push-multiple) (inline ,(make-info-vpush (car callee-save-fpregs) fpsaved) ,%vpush-multiple) ; set up tc for benefit of argument-conversion code, which might allocate ,(if-feature pthreads (%seq (set! ,%r0 ,(%inline get-tc)) (set! ,%tc ,%r0)) `(set! ,%tc (literal ,(make-info-literal #f 'entry (lookup-c-entry thread-context) 0)))))) ; list of procedures that marshal arguments from their C stack locations ; to the Scheme argument locations (do-stack arg-type* saved-reg-bytes pre-pad-bytes return-bytes float-reg-bytes post-pad-bytes int-reg-bytes synthesize-first?) get-result (lambda () (in-context Tail (%seq ; restore the callee save registers (inline ,(make-info-vpush (car callee-save-fpregs) fpsaved) ,%vpop-multiple) (inline ,(make-info-kill* callee-save-regs+lr) ,%pop-multiple) ; deallocate space for pad & arg reg values (set! ,%sp ,(%inline + ,%sp (immediate ,(fx+ pre-pad-bytes int-reg-bytes post-pad-bytes float-reg-bytes return-bytes)))) ; done (asm-c-return ,null-info ,callee-save-regs+lr ... ,result-regs ...))))))))))))))) )