Changeset 13705
- Timestamp:
- May 16, 2010, 1:51:57 AM (10 years ago)
- Location:
- branches/arm/compiler/ARM
- Files:
-
- 5 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/arm/compiler/ARM/arm-arch.lisp
r13699 r13705 26 26 27 27 28 29 (defvar *arm-gprs* (make-hash-table :test #'equalp)) 28 (defvar *standard-arm-register-names* ()) 29 (defvar *arm-register-names* ()) 30 31 32 (defun get-arm-register (name) 33 (let* ((pair (assoc (string name) *arm-register-names* :test #'string-equal))) 34 (if pair 35 (cdr pair)))) 30 36 31 37 (defun get-arm-gpr (name) 32 (values (gethash (string name) *arm-gprs*))) 33 34 35 (defun define-arm-gpr (name val) 36 (etypecase val 37 ((mod 16) (setf (gethash (string name) *arm-gprs*) val)) 38 (symbol (let* ((defined (get-arm-gpr val))) 39 (if defined 40 (setf (gethash (string name) *arm-gprs*) defined) 41 (error "ARM register value ~s not defined" val)))))) 38 (let* ((value (get-arm-register name))) 39 (and value (< value 16) value))) 40 41 42 ;;; This allows redefinition, which might be helpful while 43 ;;; boostrapping. ARM-LAP-EQUATE-FORM checks for redefinition 44 ;;; before calling this. 45 (defun define-arm-register (name val) 46 (let* ((value (if (typep val 'fixnum) val (get-arm-gpr val))) 47 (string (string name))) 48 (unless value 49 (error "invalid ARM register value ~d for ~s." val name)) 50 (let* ((pair (assoc string *arm-register-names* :test #'string-equal))) 51 (if pair 52 (progn 53 (unless (eql (cdr pair) value) 54 (when ccl::*cerror-on-constant-redefinition* 55 (cerror "Redefine ARM register ~s to have value ~*~d." 56 "ARM register ~s currently has value ~d." 57 name (cdr pair) value) 58 (setf (cdr pair) value))) 59 (push (cons string value) *arm-register-names*)) 60 value)))) 42 61 43 62 (defmacro defarmgpr (name val) 44 `(def ine-arm-gpr ',name ',val))63 `(defconstant ,name (define-arm-register ',name ',val))) 45 64 46 65 (defarmgpr r0 0) … … 198 217 (defparameter *arm-subprims-base* (ash 4 12) ) 199 218 ) 219 (defvar *arm-subprims*) 200 220 201 221 ;;; For now, nothing's nailed down and we don't say anything about … … 209 229 (macrolet ((defarmsubprim (name) 210 230 `(define-arm-subprim ',name))) 211 ( defparameter*arm-subprims*231 (setq *arm-subprims* 212 232 (vector 213 233 (defarmsubprim .SPjmpsym) … … 1201 1221 `(arm::%kernel-global ,name)) 1202 1222 1203 (defarmarchmacro ccl::lfun-vector (f n)1204 f n)1223 (defarmarchmacro ccl::lfun-vector (fun) 1224 fun) 1205 1225 1206 1226 (defarmarchmacro ccl::lfun-vector-lfun (lfv) -
branches/arm/compiler/ARM/arm-asm.lisp
r13699 r13705 40 40 (error "Unknown ARM condition name ~s." name))) 41 41 42 (defvar *arm-constants* ()) 43 (defvar *lap-labels* ()) 44 45 42 46 (defun arm-constant-index (form) 43 (error "NYI")) 47 (let* ((idx (or (assoc form *arm-constants* :test 'equal) 48 (let* ((n (length *arm-constants*))) 49 (push (cons form n) *arm-constants*) 50 n)))) 51 (+ (ash (+ idx 2) arm::word-shift) ; skip entrypoint, codevector 52 arm::misc-data-offset))) 53 54 44 55 45 56 (defun need-constant (form) … … 66 77 operand-types) 67 78 79 (eval-when (:compile-toplevel :load-toplevel :execute) 80 68 81 (ccl::defenum (:prefix "ARM-OPERAND-TYPE-") 69 82 rd ; destination register in bits 12:15 … … 76 89 uuo-unary ; constant in UUO bits 12:15 77 90 uuoB ; GPR in UUO bits 12:15 78 91 rm 92 b 79 93 ) 80 94 … … 89 103 (:uuo-unary . ,arm-operand-type-uuo-unary) 90 104 (:uuoB . ,arm-operand-type-uuoB) 105 (:rm . ,arm-operand-type-rm) 106 (:b . ,arm-operand-type-b) 91 107 )) 92 108 … … 117 133 (setq mask (logior mask (encode-one-instruction-type n)))))) 118 134 0))) 135 ) 119 136 120 137 (defmacro encode-arm-instruction-flag (name) … … 182 199 (define-arm-instruction ldmia #x8900000 () :rnw :reglist) 183 200 (define-arm-instruction ldmfd #x8900000 () :rnw :reglist) 201 202 (define-arm-instruction b #xa000000 () :b) 203 (define-arm-instruction bl #xb000000 () :b) 204 (define-arm-instruction bx #x12fff10 () :rm) 205 (define-arm-instruction blx #x12fff30 () :rm) 184 206 185 207 ;;; UUOs … … 237 259 (dotimes (i prefix-len) 238 260 (setf (schar prefix i) (schar string i))) 239 (if (setq template (gethash prefix *arm-instruction-templates*)) 261 (if (setq template 262 (progn 263 (setq ordinal (gethash prefix *arm-instruction-ordinals*)) 264 (when ordinal 265 (svref *arm-instruction-table* ordinal)))) 240 266 (if (logbitp (encode-arm-instruction-flag :non-conditional) (arm-instruction-template-flags template)) 241 267 (values nil nil nil) … … 547 573 (set-field-value instruction 4 12 (need-arm-gpr form))) 548 574 575 (defun parse-rm-operand (form instruction) 576 (set-field-value instruction 4 0 (need-arm-gpr form))) 577 578 (defun parse-b-operand (form instruction) 579 (lap-note-label-reference form instruction :b)) 580 581 549 582 550 583 … … 560 593 parse-uuo-unary-operand 561 594 parse-uuob-operand 595 parse-rm-operand 596 parse-b-operand 562 597 )) 563 598 … … 595 630 insn))))) 596 631 632 ;;; A label can only be emitted once. Once it's been emitted, its pred/succ 633 ;;; slots will be non-nil. 634 635 (defun lap-label-emitted-p (lab) 636 (not (null (lap-label-pred lab)))) 637 638 (defun %make-lap-label (name) 639 (let* ((lab (ccl::alloc-dll-node *lap-label-freelist*))) 640 (if lab 641 (progn 642 (setf (lap-label-address lab) nil 643 (lap-label-refs lab) nil 644 (lap-label-name lab) name) 645 lab) 646 (%%make-lap-label name)))) 647 648 (defun make-lap-label (name) 649 (let* ((lab (%make-lap-label name))) 650 (if (typep *lap-labels* 'hash-table) 651 (setf (gethash name *lap-labels*) lab) 652 (progn 653 (push lab *lap-labels*) 654 (if (> (length *lap-labels*) 255) 655 (let* ((hash (make-hash-table :size 512 :test #'eq))) 656 (dolist (l *lap-labels* (setq *lap-labels* hash)) 657 (setf (gethash (lap-label-name l) hash) l)))))) 658 lab)) 659 660 (defun find-lap-label (name) 661 (if (typep *lap-labels* 'hash-table) 662 (gethash name *lap-labels*) 663 (car (member name *lap-labels* :test #'eq :key #'lap-label-name)))) 664 665 (defun lap-note-label-reference (labx insn type) 666 (let* ((lab (or (find-lap-label labx) 667 (make-lap-label labx)))) 668 (push (cons insn type) (lap-label-refs lab)) 669 lab)) 670 597 671 (provide "ARM-ASM") -
branches/arm/compiler/ARM/arm-backend.lisp
r13699 r13705 231 231 232 232 233 #+ linuxarm-target233 #+(or linuxarm-target (not arm-target)) 234 234 (defvar *linuxarm-backend* 235 235 (make-backend :lookup-opcode #'arm::lookup-arm-instruction … … 278 278 :target-arch arm::*arm-target-arch*)) 279 279 280 #+ linuxarm-target280 #+(or linuxarm-target (not arm-target)) 281 281 (pushnew *linuxarm-backend* *known-arm-backends* :key #'backend-name) 282 282 … … 289 289 (defun fixup-arm-backend () 290 290 (dolist (b *known-arm-backends*) 291 (setf (backend-lap-opcodes b) arm::*arm- opcodes*291 (setf (backend-lap-opcodes b) arm::*arm-instruction-table* 292 292 (backend-p2-dispatch b) *arm2-specials* 293 293 (backend-p2-vinsn-templates b) *arm-vinsn-templates*) … … 301 301 #+arm-target 302 302 (setq *host-backend* *arm-backend* *target-backend* *arm-backend*) 303 #-arm-target 304 (unless (backend-target-foreign-type-data *arm-backend*) 305 (let* ((ftd (make-ftd 306 :interface-db-directory 307 #+darwinarm-target "ccl:darwin-headers;" 308 #+linuxarm-target "ccl:headers;" 309 :interface-package-name 310 #+darwinarm-target "DARWIN32" 311 #+linuxarm-target "LINUX32" 312 :attributes 313 #+darwinarm-target 314 '(:signed-char t 315 :struct-by-value t 316 :prepend-underscores t 317 :bits-per-word 32 318 :poweropen-alignment t) 319 #+linuxarm-target 320 '(:bits-per-word 32) 321 :ff-call-expand-function 322 #+linuxarm-target 323 'linux32::expand-ff-call 324 #+darwinarm-target 325 'darwin32::expand-ff-call 326 :ff-call-struct-return-by-implicit-arg-function 327 #+linuxarm-target 328 linux32::record-type-returns-structure-as-first-arg 329 #+darwinarm-target 330 darwin32::record-type-returns-structure-as-first-arg 331 :callback-bindings-function 332 #+linuxarm-target 333 linux32::generate-callback-bindings 334 #+darwinarm-target 335 darwin32::generate-callback-bindings 336 :callback-return-value-function 337 #+linuxarm-target 338 linux32::generate-callback-return-value 339 #+darwinarm-target 340 darwin32::generate-callback-return-value 341 ))) 342 (install-standard-foreign-types ftd) 343 (use-interface-dir :libc ftd) 344 (setf (backend-target-foreign-type-data *arm-backend*) ftd))) 303 304 (defun setup-arm-ftd (backend) 305 (or (backend-target-foreign-type-data backend) 306 (let* ((name (backend-name backend)) 307 (ftd 308 (case name 309 (:darwinarm 310 (make-ftd :interface-db-directory "ccl:darwin-arm-headers;" 311 :interface-package-name "ARM-DARWIN" 312 :attributes '(:bits-per-word 32 313 :signed-char t 314 :struct-by-value t 315 :prepend-underscore nil) 316 :ff-call-expand-function 317 (intern "EXPAND-FF-CALL" "ARM-DARWIN") 318 :ff-call-struct-return-by-implicit-arg-function 319 (intern "RECORD-TYPE-RETURNS-STRUCTURE-AS-FIRST-ARG" 320 "ARM-DARWIN") 321 :callback-bindings-function 322 (intern "GENERATE-CALLBACK-BINDINGS" "ARM-DARWIN") 323 :callback-return-value-function 324 (intern "GENERATE-CALLBACK-RETURN-VALUE" "ARM-DARWIN"))) 325 (:linuxarm 326 (make-ftd :interface-db-directory "ccl:arm-headers;" 327 :interface-package-name "ARM-LINUX" 328 :attributes '(:bits-per-word 32 329 :signed-char nil 330 :struct-by-value t 331 :float-results-in-x87 t) 332 :ff-call-expand-function 333 (intern "EXPAND-FF-CALL" "ARM-LINUX") 334 :ff-call-struct-return-by-implicit-arg-function 335 (intern "RECORD-TYPE-RETURNS-STRUCTURE-AS-FIRST-ARG" 336 "ARM-LINUX") 337 :callback-bindings-function 338 (intern "GENERATE-CALLBACK-BINDINGS" "ARM-LINUX") 339 :callback-return-value-function 340 (intern "GENERATE-CALLBACK-RETURN-VALUE" "ARM-LINUX")))))) 341 (install-standard-foreign-types ftd) 342 (use-interface-dir :libc ftd) 343 (setf (backend-target-foreign-type-data backend) ftd)))) 345 344 346 345 (pushnew *arm-backend* *known-backends* :key #'backend-name) 347 346 347 #+notyet 348 348 (require "ARM-VINSNS") 349 349 350 (defparameter *arm-backend* 351 #+arm-target *arm-backend* 352 #-(or arm-target) 353 nil) 350 354 351 355 352 -
branches/arm/compiler/ARM/arm-lap.lisp
r13699 r13705 30 30 (defun (setf arm-lap-macro-function) (def name) 31 31 (let* ((s (string name))) 32 (when (gethash s arm::*arm-instruction- templates*)32 (when (gethash s arm::*arm-instruction-ordinals*) 33 33 (error "~s already defines an arm instruction . " name)) 34 34 (setf (gethash s (backend-lap-macros *arm-backend*)) def))) … … 42 42 43 43 (defvar *arm-lap-constants* ()) 44 (defvar *arm-lap-labels* ())45 (defvar *arm-lap-instructions*)46 44 (defvar *arm-lap-regsave-reg* ()) 47 45 (defvar *arm-lap-regsave-addr* ()) … … 50 48 51 49 50 (defmacro do-lap-labels ((lab &optional result) &body body) 51 (let* ((thunk-name (gensym)) 52 (k (gensym)) 53 (xlab (gensym))) 54 `(flet ((,thunk-name (,lab) ,@body)) 55 (if (listp arm::*lap-labels*) 56 (dolist (,xlab arm::*lap-labels*) 57 (,thunk-name ,xlab)) 58 (maphash #'(lambda (,k ,xlab) 59 (declare (ignore ,k)) 60 (,thunk-name ,xlab)) 61 arm::*lap-labels*)) 62 ,result))) 52 63 53 64 … … 66 77 67 78 (defun %define-arm-lap-function (name body &optional (bits 0)) 68 (with-dll-node-freelist (*lap-instructions* *lap-instruction-freelist*)79 (with-dll-node-freelist (*lap-instructions* arm::*lap-instruction-freelist*) 69 80 (let* ((*lap-labels* ()) 70 ( *arm-lap-constants* ())81 (arm::*arm-constants* ()) 71 82 (*arm-lap-lfun-bits* bits)) 72 83 (dolist (form body) 73 84 (arm-lap-form form)) 74 #+arm-lap-scheduler (arm-schedule-instuctions) ; before resolving branch targets75 85 (arm-lap-generate-code name (arm-lap-do-labels) *arm-lap-lfun-bits*)))) 76 86 … … 81 91 (declare (fixnum pc)) 82 92 (do-dll-nodes (node *lap-instructions*) 83 (setf ( instruction-element-address node) pc)84 (if (typep node ' lap-label)93 (setf (arm::instruction-element-address node) pc) 94 (if (typep node 'arm::lap-label) 85 95 (if delete-labels-p (remove-dll-node node)) 86 96 (incf pc 4))) … … 92 102 (defun arm-lap-do-labels () 93 103 (do-lap-labels (lab) 94 (if (and ( lap-label-refs lab) (not (lap-label-emitted-p lab)))104 (if (and (arm::lap-label-refs lab) (not (arm::lap-label-emitted-p lab))) 95 105 (error "Label ~S was referenced but never defined. " 96 ( lap-label-name lab)))106 (arm::lap-label-name lab))) 97 107 ;; Repeatedly iterate through label's refs, until none of them is 98 108 ;; the preceding instruction. This eliminates … … 102 112 ;; but can probably be fooled by hairier nonsense. 103 113 (loop 104 (when (dolist (ref ( lap-label-refs lab) t)105 (when (eq lab ( lap-instruction-succ ref))114 (when (dolist (ref (arm::lap-label-refs lab) t) 115 (when (eq lab (arm::lap-instruction-succ ref)) 106 116 (remove-dll-node ref) 107 (setf ( lap-label-refs lab) (delete ref (lap-label-refs lab)))117 (setf (arm::lap-label-refs lab) (delete ref (arm::lap-label-refs lab))) 108 118 (return))) 109 119 (return)))) 110 120 ;; Assign pc to emitted labels, splice them out of the list. 111 121 112 (if (> (the fixnum (dll-header-length *lap-instructions*)) 8191) 113 ;; -Might- have some conditional branches that are too long. 114 ;; Definitely don't otherwise, so only bother to check in this case 115 (arm-lap-remove-long-branches) 116 (arm-lap-assign-addresses t))) 122 (arm-lap-assign-addresses t)) 117 123 118 124 ;;; Replace each label with the difference between the label's address … … 120 126 (defun arm-lap-resolve-labels () 121 127 (do-lap-labels (label) 122 (let* ((label-address ( lap-label-address label)))128 (let* ((label-address (arm::lap-label-address label))) 123 129 (declare (fixnum label-address)) ; had BETTER be ... 124 (dolist (insn ( lap-label-refs label))125 (let* ((diff (- label-address ( lap-instruction-address insn))))130 (dolist (insn (arm::lap-label-refs label)) 131 (let* ((diff (- label-address (arm::lap-instruction-address insn)))) 126 132 (declare (fixnum diff)) 127 (let* ((opvals ( lap-instruction-parsed-operands insn))133 (let* ((opvals (arm::lap-instruction-parsed-operands insn)) 128 134 (pos (position label opvals))) 129 135 (unless pos … … 132 138 133 139 (defun arm-lap-generate-instruction (code-vector index insn) 134 (let* ((op ( lap-instruction-opcode insn))140 (let* ((op (arm::lap-instruction-opcode insn)) 135 141 (vals (lap-instruction-parsed-operands insn)) 136 142 (high (opcode-op-high op)) … … 156 162 nil))) 157 163 158 (defparameter *use-traceback-tables* nil) 159 160 (defun traceback-fullwords (pname) 161 (if (and *use-traceback-tables* pname (typep pname 'simple-base-string)) 162 (ceiling (+ 22 (length pname)) 4) 163 0)) 164 165 (defun add-traceback-table (code-vector start pname) 166 (flet ((out-byte (v i8 b) 167 (declare (type (simple-array (unsigned-byte 8) (*)) v) 168 (optimize (speed 3) (safety 0)) 169 (fixnum i8)) 170 (setf (aref v i8) b))) 171 (flet ((out-bytes (v i32 b0 b1 b2 b3) 172 (declare (type (simple-array (unsigned-byte 8) (*)) v) 173 (optimize (speed 3) (safety 0)) 174 (fixnum i32)) 175 (let* ((i8 (ash i32 2))) 176 (declare (fixnum i8)) 177 (setf (aref v i8) b0 178 (aref v (%i+ i8 1)) b1 179 (aref v (%i+ i8 2)) b2 180 (aref v (%i+ i8 3)) b3)))) 181 (setf (uvref code-vector start) 0) 182 (out-bytes code-vector (1+ start) 183 0 ; traceback table version 184 0 ; language id 7 - try 0 instead (means C) or 9 means C++ 185 #x20 ; ??? 186 #x41) ; ??? 187 (out-bytes code-vector (+ start 2) 188 #x80 #x06 #x01 #x00) ; ??? ??? ??? ??? 189 (setf (uvref code-vector (+ start 3)) #x0) 190 (setf (uvref code-vector (+ start 4)) (ash start 2)) 191 (let* ((namelen (length pname)) 192 (pos (ash (the fixnum (+ start 5)) 2))) 193 (declare (fixnum namelen pos)) 194 (out-byte code-vector pos (ldb (byte 8 8) namelen)) 195 (incf pos) 196 (out-byte code-vector pos (ldb (byte 8 0) namelen)) 197 (incf pos) 198 (dotimes (i namelen) 199 (out-byte code-vector pos (char-code (schar pname i))) 200 (incf pos)))))) 201 202 (defun arm-lap-generate-code (name maxpc bits &optional (traceback nil)) 164 165 166 (defun arm-lap-generate-code (name maxpc bits) 203 167 (declare (fixnum maxpc)) 204 168 (let* ((target-backend *target-backend*) 205 169 (cross-compiling (not (eq *host-backend* target-backend))) 206 (traceback-size 207 (traceback-fullwords (and traceback 208 name 209 (setq traceback (symbol-name name))))) 170 210 171 (prefix (arch::target-code-vector-prefix (backend-target-arch *target-backend*))) 211 172 (prefix-size (length prefix)) 212 (code-vector-size (+ (ash maxpc -2) traceback-sizeprefix-size))213 214 (constants-size (+ 3(length *arm-lap-constants*)))173 (code-vector-size (+ (ash maxpc -2) prefix-size)) 174 175 (constants-size (+ 4 (length *arm-lap-constants*))) 215 176 (constants-vector (%alloc-misc 216 177 constants-size … … 220 181 (i prefix-size)) 221 182 (declare (fixnum i constants-size)) 222 #+arm32-target223 (if (>= code-vector-size (ash 1 19)) (compiler-function-overflow))224 183 (let* ((code-vector (%alloc-misc 225 184 code-vector-size 226 185 (if cross-compiling 227 186 target::subtag-xcode-vector 228 target::subtag-code-vector))))187 arm::subtag-code-vector)))) 229 188 (dotimes (j prefix-size) 230 189 (setf (uvref code-vector j) (pop prefix))) … … 233 192 (arm-lap-generate-instruction code-vector i insn) 234 193 (incf i)) 235 (unless (eql 0 traceback-size) 236 (add-traceback-table code-vector i traceback)) 194 237 195 (dolist (immpair *arm-lap-constants*) 238 196 (let* ((imm (car immpair)) … … 252 210 (defun arm-lap-pseudo-op (form) 253 211 (case (car form) 254 (:regsave255 (if *arm-lap-regsave-label*256 (warn "Duplicate :regsave form not handled (yet ?) : ~s" form)257 (destructuring-bind (reg addr) (cdr form)258 (let* ((regno (arm-register-name-or-expression reg)))259 (if (not (<= arm::save7 regno arm::save0))260 (warn "Not a save register: ~s. ~s ignored." reg form)261 (let* ((addrexp (arm-register-name-or-expression addr))) ; parses 'fixnum262 (if (not (and (typep addrexp 'fixnum)263 (<= 0 addrexp #x7ffc) ; not really right264 (not (logtest 3 addrexp))))265 (warn "Invalid logical VSP: ~s. ~s ignored." addr form)266 (setq *arm-lap-regsave-label* (emit-lap-label (gensym))267 *arm-lap-regsave-reg* regno268 *arm-lap-regsave-addr* (- (+ addrexp)269 (* 4 (1+ (- arm::save0 regno))))))))))))270 212 (:arglist (setq *arm-lap-lfun-bits* (encode-lambda-list (cadr form)))))) 271 213 … … 287 229 ((let) (arm-lap-equate-form (cadr form) (cddr form))) 288 230 (t 289 ; instruction macros expand into instruction forms 290 ; (with some operands reordered/defaulted.) 291 (let* ((expander (arm::arm-macro-function name))) 292 (if expander 293 (arm-lap-form (funcall expander form nil)) 294 (arm-lap-instruction name (cdr form))))))))))))) 231 (arm-lap-instruction name (cdr form))))))))))) 295 232 296 233 ;;; (let ((name val) ...) &body body) 297 234 ;;; each "val" gets a chance to be treated as a ARM register name 298 235 ;;; before being evaluated. 299 (defun arm-lap-equate-form (eqlist body) 300 (let* ((symbols (mapcar #'(lambda (x) 301 (let* ((name (car x))) 302 (or 303 (and name 304 (symbolp name) 305 (not (constant-symbol-p name)) 306 name) 307 (error 308 "~S is not a bindable symbol name ." name)))) 309 eqlist)) 310 (values (mapcar #'(lambda (x) (or (arm-vr-name-p (cadr x)) 311 (arm-fpr-name-p (cadr x)) 312 (arm-register-name-or-expression 313 (cadr x)))) 314 eqlist))) 315 (progv symbols values 316 (dolist (form body) 317 (arm-lap-form form))))) 236 (defun arm-lap-equate-form (eqlist body) 237 (collect ((symbols) 238 (values)) 239 (let* ((arm::*arm-register-names* arm::*arm-register-names*)) 240 (dolist (pair eqlist) 241 (destructuring-bind (symbol value) pair 242 (unless (and symbol 243 (symbolp symbol) 244 (not (constant-symbol-p symbol)) 245 (not (arm::get-arm-register symbol))) 246 (error "~s is not a bindable symbol name . " symbol)) 247 (let* ((regval (arm::get-arm-register value))) 248 (if regval 249 (arm::define-arm-register symbol regval) 250 (progn 251 (symbols symbol) 252 (values (eval value))))))) 253 254 (progv (symbols) (values) 255 (dolist (form body) 256 (arm-lap-form form)))))) 318 257 319 258 (defun arm-lap-constant-offset (x) -
branches/arm/compiler/ARM/arm-lapmacros.lisp
r13699 r13705 31 31 (cmp nargs (:$ (ash ,min arm::fixnumshift))) 32 32 (uuo-error-wrong-nargs (:? ne))) 33 `(trnei nargs ',min)34 33 (if (null max) 35 34 (unless (= min 0) … … 243 242 (push inst insts)))) 244 243 245 (defarmlapmacro get-single-float (dest node) 246 (target-arch-case 247 (:ppc32 248 `(lfs ,dest ppc32::single-float.value ,node)) 249 (:ppc64 250 `(progn 251 (std ,node ppc64::tcr.single-float-convert ppc64::rcontext) 252 (lfs ,dest ppc64::tcr.single-float-convert ppc64::rcontext))))) 244 (defarmlapmacro get-single-float (dest node temp) 245 `(progn 246 (ldr ,temp (:@ ,node (:$ arm::single-float.value))) 247 (fmsr ,dest ,temp))) 253 248 254 249 (defarmlapmacro get-double-float (dest node) 255 (target-arch-case 256 (:ppc32 257 `(lfd ,dest ppc32::double-float.value ,node)) 258 (:ppc64 259 `(lfd ,dest ppc64::double-float.value ,node)))) 250 `(progn 251 (ldrdd imm0 imm1 (:@ ,node (:$ arm::double-float.value))) 252 (fmdrr ,dest imm0 imm1))) 260 253 261 254 262 (defarmlapmacro put-single-float (src node) 263 (target-arch-case 264 (:ppc32 265 `(stfs ,src ppc32::single-float.value ,node)) 266 (:ppc64 267 `(progn 268 (stfs ,src ppc64::tcr.single-float-convert ppc64::rcontext) 269 (ld ,node ppc64::tcr.single-float-convert ppc64::rcontext))))) 255 (defarmlapmacro put-single-float (src node temp) 256 `(progn 257 (fmrs ,temp ,src) 258 (str ,temp (:@ ,node (:$ arm::single-float.value)))) 270 259 271 260 (defarmlapmacro put-double-float (src node) 272 (target-arch-case 273 (:ppc32 274 `(stfd ,src ppc32::double-float.value ,node)) 275 (:ppc64 276 `(stfd ,src ppc64::double-float.value ,node)))) 261 `(progn 262 (fmrrd imm0 imm1 ,src) 263 (strdd imm0 imm1 (:@ ,node (:$ arm::double-float.value))))) 264 277 265 278 266 (defarmlapmacro clear-fpu-exceptions () 279 `(mtfsf #xfc #.ppc::fp-zero)) 280 281 282 283 ;;; from ppc-bignum.lisp 267 (error "Later.")) 268 269 270 284 271 (defarmlapmacro digit-h (dest src) 285 (target-arch-case 286 (:ppc32 287 `(rlwinm ,dest ,src (+ 16 ppc32::fixnumshift) (- 16 ppc32::fixnumshift) (- 31 ppc32::fixnumshift))) 288 (:ppc64 289 (error "DIGIT-H on PPC64 ?")))) 290 291 ;;; from ppc-bignum.lisp 272 `(progn 273 (mov ,dest (:$ (ash #xff arm::fixnumshift))) 274 (orr ,dest ,dest (:lsl ,dest (:$ 8))) 275 (and ,dest ,dest (:lsr ,src (:$ (- 16 arm::fixnumshift)))))) 276 292 277 (defarmlapmacro digit-l (dest src) 293 (target-arch-case 294 (:ppc32 295 `(clrlslwi ,dest ,src 16 ppc32::fixnumshift)) 296 (:ppc64 297 (error "DIGIT-L on PPC64 ?")))) 278 `(progn 279 (mov ,dest (:$ (ash #xff arm::fixnumshift))) 280 (orr ,dest ,dest (:lsl ,dest (:$ 8))) 281 (and ,dest ,dest (:lsl ,src (:$ arm::fixnumshift))))) 298 282 299 ;;; from ppc-bignum.lisp 283 300 284 (defarmlapmacro compose-digit (dest high low) 301 (target-arch-case 302 (:ppc32 303 `(progn 304 (rlwinm ,dest ,low (- ppc32::nbits-in-word ppc32::fixnumshift) 16 31) 305 (rlwimi ,dest ,high (- 16 ppc32::fixnumshift) 0 15))) 306 (:ppc64 307 (error "COMPOSE-DIGIT on PPC64 ?")))) 285 ;; Can we assume that HIGH and LOW are boxed 16-bit fixnums ? 286 ;; This code does ... 287 `(progn 288 (mov ,dest (:lsl ,high (:$ (- 16 arm::fixnumshift)))) 289 (orr ,dest ,dest (:lsr ,low (:$ arm::fixnumshift))))) 308 290 309 291 (defarmlapmacro macptr-ptr (dest macptr) … … 323 305 (one (gensym))) 324 306 `(progn 325 (cmpri cr1 nargs '2) 326 (cmpri cr0 nargs 0) 327 (beq cr1 ,two) 328 (beq cr0 ,none) 329 (blt cr1 ,one) 330 (vpush arg_x) 331 ,two 332 (vpush arg_y) 333 ,one 334 (vpush arg_z) 307 (cmp nargs (:$ 0)) 308 (beq ,none) 309 (cmp nargs '2) 310 (strgt arg_x (:@! vsp (:$ (- arm::node-size)))) 311 (strge arg_y (:@! vsp (:$ (- arm::node-size)))) 312 (str arg_z (:@! vsp (:$ (- arm::node-size)))) 335 313 ,none))) 336 314
Note: See TracChangeset
for help on using the changeset viewer.