Index: /branches/arm/compiler/ARM/arm-arch.lisp =================================================================== --- /branches/arm/compiler/ARM/arm-arch.lisp (revision 13698) +++ /branches/arm/compiler/ARM/arm-arch.lisp (revision 13699) @@ -21,88 +21,70 @@ (in-package "ARM") + + ;;; Lisp registers. -(eval-when (:compile-toplevel :execute) - (defmacro defregs (&body regs) - `(progn - (ccl::defenum () ,@regs) - (defparameter *gpr-register-names* ,(coerce (mapcar #'string regs) 'vector)))) - (defmacro deffpregs (&body regs) - `(progn - (ccl::defenum () ,@regs) - (defparameter *fpr-register-names* ,(coerce (mapcar #'string regs) 'vector)))) - (defmacro defvregs (&body regs) - `(progn - (ccl::defenum () ,@regs) - (defparameter *vector-register-names* ,(coerce (mapcar #'string regs) 'vector)) - ))) - -(defregs - imm0 ; unboxed, immediate register - imm1 - imm2 ; doubles as nargs - rcontext ; TCR when running lisp - arg_z ; tagged, last arg, primary return value - arg_y ; - arg_x - temp0 ; volatile tagged regs - temp1 - temp2 - vsp ; value stack pointer - fn ; current function - allocptr ; for consing - sp ; conventional sp - lr - pc - ) - -(deffpregs - fp0 - fp1 - fp2 - fp3 - fp4 - fp5 - fp6 - fp7 - fp8 - fp9 - fp10 - fp11 - fp12 - fp13 - fp14 - fp15 - fp16 - fp17 - fp18 - fp19 - fp20 - fp21 - fp22 - fp23 - fp24 - fp25 - fp26 - fp27 - fp28 - fp29 - fp30 - fp31) - - - - + + + +(defvar *arm-gprs* (make-hash-table :test #'equalp)) + +(defun get-arm-gpr (name) + (values (gethash (string name) *arm-gprs*))) + + +(defun define-arm-gpr (name val) + (etypecase val + ((mod 16) (setf (gethash (string name) *arm-gprs*) val)) + (symbol (let* ((defined (get-arm-gpr val))) + (if defined + (setf (gethash (string name) *arm-gprs*) defined) + (error "ARM register value ~s not defined" val)))))) + +(defmacro defarmgpr (name val) + `(define-arm-gpr ',name ',val)) + +(defarmgpr r0 0) +(defarmgpr r1 1) +(defarmgpr r2 2) +(defarmgpr r3 3) +(defarmgpr r4 4) +(defarmgpr r5 5) +(defarmgpr r6 6) +(defarmgpr r7 7) +(defarmgpr r8 8) +(defarmgpr r9 9) +(defarmgpr r10 10) +(defarmgpr r11 11) +(defarmgpr r12 12) +(defarmgpr r13 13) +(defarmgpr r14 14) +(defarmgpr r15 15) + +(defarmgpr imm0 r0) +(defarmgpr imm1 r1) +(defarmgpr imm2 r2) +(defarmgpr rcontext r3) +(defarmgpr arg_z r4) +(defarmgpr arg_y r5) +(defarmgpr arg_x r6) +(defarmgpr temp0 r7) +(defarmgpr temp1 r8) +(defarmgpr temp2 r9) +(defarmgpr vsp r10) +(defarmgpr fn r11) +(defarmgpr allocptr r12) +(defarmgpr sp r13) +(defarmgpr lr r14) +(defarmgpr pc r15) ;;; Calling sequence may pass additional arguments in temp registers. ;;; "nfn" (new function) is always passed; it's the new value of "fn". -(defconstant nfn temp2) - +(defarmgpr nfn temp2) ;;; CLOS may pass the context for, e.g.., CALL-NEXT-METHOD in ;;;; the "next-method-context" register. -(defconstant next-method-context temp1) - - - -(defconstant fname temp3) +(defarmgpr next-method-context temp1) + +(defarmgpr fname temp1) + @@ -413,5 +395,5 @@ -) + (eval-when (:compile-toplevel :load-toplevel :execute) @@ -586,6 +568,6 @@ (defconstant max-non-array-node-subtag (logior (ash 18 ntagbits) fulltag-nodeheader)) +(define-subtag lisp-frame-marker fulltag-imm 2) (define-subtag character fulltag-imm 9) -(define-subtag vsp-protect fulltag-imm 7) (define-subtag slot-unbound fulltag-imm 10) (defconstant slot-unbound-marker subtag-slot-unbound) @@ -598,11 +580,11 @@ (defconstant unbound-marker subtag-unbound) (defconstant undefined unbound-marker) - - -(defconstant max-64-bit-constant-index (ash (+ #x7fff arm::misc-dfloat-offset) -3)) -(defconstant max-32-bit-constant-index (ash (+ #x7fff arm::misc-data-offset) -2)) -(defconstant max-16-bit-constant-index (ash (+ #x7fff arm::misc-data-offset) -1)) -(defconstant max-8-bit-constant-index (+ #x7fff arm::misc-data-offset)) -(defconstant max-1-bit-constant-index (ash (+ #x7fff arm::misc-data-offset) 5)) +(defconstant lisp-frame-marker subtag-lisp-frame-marker) + +(defconstant max-64-bit-constant-index (ash (+ #xfff arm::misc-dfloat-offset) -3)) +(defconstant max-32-bit-constant-index (ash (+ #xfff arm::misc-data-offset) -2)) +(defconstant max-16-bit-constant-index (ash (+ #xfff arm::misc-data-offset) -1)) +(defconstant max-8-bit-constant-index (+ #xfff arm::misc-data-offset)) +(defconstant max-1-bit-constant-index (ash (+ #xfff arm::misc-data-offset) 5)) @@ -683,4 +665,10 @@ binding-index ) + +(define-fixedsized-object function + entrypoint + codevector + ) + @@ -860,7 +848,8 @@ (defun %kernel-global (sym) + ;; Returns index relative to (- nil-value fulltag-nil) (let* ((pos (position sym arm::*arm-kernel-globals* :test #'string=))) (if pos - (- (+ fulltag-nil (* (1+ pos) 4))) + (- (* (1+ pos) 4)) (error "Unknown kernel global : ~s ." sym)))) @@ -868,5 +857,5 @@ (let* ((pos (position sym arm::*arm-kernel-globals* :test #'string=))) (if pos - (- (+ fulltag-nil (* (1+ pos) 4))) + (- (* (1+ pos) 4)) (error "Unknown kernel global : ~s ." sym)))) @@ -1249,4 +1238,16 @@ (defconstant arg-check-trap-pc-limit 8) +;;; UUO encoding +(defconstant uuo-format-nullary 0) ; 12 bits of code +(defconstant uuo-format-unary 1) ; 8 bits of info - NOT type info - 4-bit reg +(defconstant uuo-format-error-lisptag 2) ; 2 bits of lisptag info, 4-bit reg +(defconstant uuo-format-error-fulltag 3) ; 3 bits of fulltag info, 4 bit reg + +(defconstant uuo-format-error-xtype 4) ; 8 bits of extended type/subtag info, 4 bit reg +(defconstant uuo-format-cerror-lisptag 10) ; continuable, lisptag, reg +(defconstant uuo-format-cerror-fulltag 11) ; continuable, fulltag, reg +(defconstant uuo-format-cerror-xtype 12) ; continuable, xtype, reg +(defconstant uuo-format-binary 15) ; 4 bits of code, r1, r0 + (provide "ARM-ARCH") Index: /branches/arm/compiler/ARM/arm-asm.lisp =================================================================== --- /branches/arm/compiler/ARM/arm-asm.lisp (revision 13699) +++ /branches/arm/compiler/ARM/arm-asm.lisp (revision 13699) @@ -0,0 +1,597 @@ +;;;-*- Mode: Lisp; Package: (ARM :use CL) -*- +;;; +;;; Copyright (C) 2005-2009 Clozure Associates and contributors. +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(eval-when (:compile-toplevel :load-toplevel :execute) +(require "ARM-ARCH") +) + +(in-package "ARM") + +(defvar *arm-condition-names* (make-hash-table :test #'equalp)) + +(dolist (pair '((eq . 0) (ne . 1) + (cc . 2) (hs . 2) (cs . 3) (lo .3) + (mi . 4) (pl . 5) + (vs . 6) (vc . 7) + (hi . 8) (ls . 9) + (ge . 10) (lt . 11) + (gt . 12) (le . 13) + (al . 14))) ; never say nv + (setf (gethash (string (car pair)) *arm-condition-names*) (cdr pair))) + +(defun lookup-arm-condition-name (name) + (values (gethash (string name) *arm-condition-names*))) + +(defun need-arm-condition-name (name) + (or (lookup-arm-condition-name name) + (error "Unknown ARM condition name ~s." name))) + +(defun arm-constant-index (form) + (error "NYI")) + +(defun need-constant (form) + (if (ccl::quoted-form-p form) + (let* ((quoted (ccl::nx-unquote form))) + (if (null quoted) + arm::canonical-nil-value + (if (typep quoted '(signed-byte 30)) + (ash quoted arm::fixnumshift) + (arm-constant-index quoted)))) + (progn + (unless (and (consp form) (eq (keywordize (car form)) :$)) + (error "Invalid constant syntax in ~s" form)) + (destructuring-bind (val) (cdr form) + (eval val))))) + + +(defstruct arm-instruction-template + name + ordinal ;if we need this + val + mask ;for disassembler + (flags 0) + operand-types) + +(ccl::defenum (:prefix "ARM-OPERAND-TYPE-") + rd ; destination register in bits 12:15 + rn ; unshifted source/base reg in 16:19 + shifter ; composite operand for ALU ops + mem12 ; 12-bit address for LDR/STR/LDRB/STB + reglist + rnw ; rn, with optional writeback. + uuoA ; GPR in UUO bits 8:11 + uuo-unary ; constant in UUO bits 12:15 + uuoB ; GPR in UUO bits 12:15 + +) + +(defparameter *arm-operand-type-names* + `((:rd . ,arm-operand-type-rd) + (:rn . ,arm-operand-type-rn) + (:shifter . ,arm-operand-type-shifter) + (:mem12 . ,arm-operand-type-mem12) + (:reglist . ,arm-operand-type-reglist) + (:rnw . ,arm-operand-type-rnw) + (:uuoA . ,arm-operand-type-uuoA) + (:uuo-unary . ,arm-operand-type-uuo-unary) + (:uuoB . ,arm-operand-type-uuoB) + )) + + + + +(defun encode-arm-operand-type (name) + (or (cdr (assoc name *arm-operand-type-names* :test #'eq)) + (error "Unknown ARM operand type name ~s." name))) + +(ccl::defenum (:prefix "ARM-INSTRUCTION-FLAG-") + non-conditional ;doesn't use standard condition field + ) + +(defparameter *arm-instruction-flag-names* + `((:non-conditional . ,arm-instruction-flag-non-conditional) + )) + +(defun %encode-arm-instruction-flag (name) + (flet ((encode-one-instruction-type (name) + (ash 1 (or (cdr (assoc name *arm-instruction-flag-names* :test #'eq)) + (error "Unknown ARM instruction type: ~s" name))))) + (if name + (if (atom name) + (encode-one-instruction-type name) + (let* ((mask 0)) + (dolist (n name mask) + (setq mask (logior mask (encode-one-instruction-type n)))))) + 0))) + +(defmacro encode-arm-instruction-flag (name) + (%encode-arm-instruction-flag name)) + +(defvar *arm-instruction-ordinals* (make-hash-table :test #'equalp)) + +(defparameter *arm-instruction-stack* (make-array 100 :fill-pointer 0)) + + +(defun %define-arm-instruction (name value flags operand-types) + (let* ((ordinal (length *arm-instruction-stack*))) + (setf (gethash (string name) *arm-instruction-ordinals*) + ordinal) + (vector-push-extend + (make-arm-instruction-template :name name + :val value + :ordinal ordinal + :flags (or flags 0) + :operand-types operand-types) + *arm-instruction-stack*) + name)) + +(defmacro define-arm-instruction (name value flag-names &rest operand-type-names) + `(%define-arm-instruction ,(string-downcase name) ,value ,(%encode-arm-instruction-flag flag-names) ',(mapcar #'encode-arm-operand-type operand-type-names))) + + +(define-arm-instruction and #x0000000 () :rd :rn :shifter) +(define-arm-instruction ands #x0100000 () :rd :rn :shifter) +(define-arm-instruction eor #x0200000 () :rd :rn :shifter) +(define-arm-instruction eors #x0300000 () :rd :rn :shifter) +(define-arm-instruction sub #x0400000 () :rd :rn :shifter) +(define-arm-instruction subs #x0500000 () :rd :rn :shifter) +(define-arm-instruction add #x0800000 () :rd :rn :shifter) +(define-arm-instruction adds #x0900000 () :rd :rn :shifter) +(define-arm-instruction adc #x0a00000 () :rd :rn :shifter) +(define-arm-instruction adcs #x0b00000 () :rd :rn :shifter) +(define-arm-instruction sbc #x0c00000 () :rd :rn :shifter) +(define-arm-instruction sbcs #x0d00000 () :rd :rn :shifter) +(define-arm-instruction orr #x1800000 () :rd :rn :shifter) +(define-arm-instruction orrs #x1900000 () :rd :rn :shifter) +(define-arm-instruction bic #x1c00000 () :rd :rn :shifter) +(define-arm-instruction bics #x1d00000 () :rd :rn :shifter) +(define-arm-instruction tst #x1100000 () :rd :shifter) +(define-arm-instruction tsts #x1100000 () :rd :shifter) +(define-arm-instruction cmp #x1500000 () :rd :shifter) +(define-arm-instruction cmps #x1500000 () :rd :shifter) +(define-arm-instruction cmn #x1700000 () :rd :shifter) +(define-arm-instruction cmns #x1700000 () :rd :shifter) + +(define-arm-instruction mov #x1a00000 () :rd :shifter) +(define-arm-instruction movs #x1b00000 () :rd :shifter) +(define-arm-instruction mvn #x1e00000 () :rd :shifter) +(define-arm-instruction mvns #x1f00000 () :rd :shifter) + +(define-arm-instruction ldr #x4100000 () :rd :mem12) +(define-arm-instruction ldrb #x4500000 () :rd :mem12) +(define-arm-instruction str #x4000000 () :rd :mem12) +(define-arm-instruction strb #x4400000 () :rd :mem12) + +(define-arm-instruction stm #x8800000 () :rnw :reglist) +(define-arm-instruction stmia #x8800000 () :rnw :reglist) +(define-arm-instruction stmea #x8800000 () :rnw :reglist) +(define-arm-instruction ldm #x8900000 () :rnw :reglist) +(define-arm-instruction ldmia #x8900000 () :rnw :reglist) +(define-arm-instruction ldmfd #x8900000 () :rnw :reglist) + +;;; UUOs +;;; Nullary UUOs +(define-arm-instruction uuo-alloc-trap #x07f000f0 ()) +(define-arm-instruction uuo-error-wrong-nargs #x07f001f0 ()) +(define-arm-instruction uuo-gc-trap #x07f002f0 ()) +(define-arm-instruction uuo-debug-trap #x07f003f0 ()) +(define-arm-instruction uuo-interrupt-now #x07f004f0 ()) +(define-arm-instruction uuo-suspend-now #x07f005f0 ()) + +;;; Misc format +(define-arm-instruction uuo-error-reg-not-lisptag #x07f000f2 () :uuoA :uuo-unary) +(define-arm-instruction uuo-error-reg-not-fulltag #x07f000f3 () :uuoA :uuo-unary) +(define-arm-instruction uuo-error-reg-not-xtype #x07f000f4 () :uuoA :uuo-unary) +(define-arm-instruction uuo-cerror-reg-not-lisptag #x07f000fa () :uuoA :uuo-unary) +(define-arm-instruction uuo-cerror-reg-not-fulltag #x07f000fb () :uuoA :uuo-unary) +(define-arm-instruction uuo-cerror-reg-not-xtype #x07f000fc () :uuoA :uuo-unary) + +;;; Unary UUOs +(define-arm-instruction uuo-error-unbound #x07f000f1 () :uuoA) +(define-arm-instruction uuo-cerror-unbound #x07f010f1 () :uuoA) +(define-arm-instruction uuo-error-not-callable #x07f020f1 () :uuoA) +(define-arm-instruction uuo-tlb-too-small #x07f030f1 () :uuoA) +(define-arm-instruction uuo-error-no-throw-tag #x07f040f1 () :uuoA) + +;;; Binary UUOs +(define-arm-instruction uuo-error-vector-bounds #x07f000ff () :uuoA :uuoB) +(define-arm-instruction uuo-error-array-bounds #x07f100ff () :uuoA :uuoB) + + +(defparameter *arm-instruction-table* (copy-seq *arm-instruction-stack*)) + +(defun lookup-arm-instruction (name) + ;; return (values instruction template & condition value), or (NIL NIL) + (let* ((cond-value #xe) ;always + (string (string name)) + (len (length string)) + (ordinal (gethash string *arm-instruction-ordinals*)) + (template (if ordinal (aref *arm-instruction-table* ordinal)))) + (if template + (values template (unless (logbitp (encode-arm-instruction-flag :non-conditional) (arm-instruction-template-flags template)) cond-value) nil) + (if (> len 2) + (let* ((cond-name (make-string 2))) + (declare (dynamic-extent cond-name)) + (setf (schar cond-name 0) + (schar string (- len 2)) + (schar cond-name 1) + (schar string (- len 1))) + (if (setq cond-value (lookup-arm-condition-name cond-name)) + (let* ((prefix-len (- len 2)) + (prefix (make-string prefix-len))) + (declare (dynamic-extent prefix) + (fixnum prefix-len)) + (dotimes (i prefix-len) + (setf (schar prefix i) (schar string i))) + (if (setq template (gethash prefix *arm-instruction-templates*)) + (if (logbitp (encode-arm-instruction-flag :non-conditional) (arm-instruction-template-flags template)) + (values nil nil nil) + (values template cond-value t)) + (values nil nil nil))) + (values nil nil nil))) + (values nil nil nil))))) + +(defun keywordize (name) + (if (typep name 'keyword) + name + (intern (string-upcase (string name)) "KEYWORD"))) + +(defun arm-rotate-left (u32 nbits) + (assert (and (evenp nbits) + (>= nbits 0) + (< nbits 32))) + (let* ((r (- 32 nbits)) + (mask (1- (ash 1 r)))) + (logand #xffffffff + (logior (ash u32 nbits) + (logand mask + (ash u32 (- r))))))) + +;;; Return a 12-bit value encodeing u32 as an 8-bit constant rotated +;;; by an even number of bits if u32 can be encoded that way, nil +;;; otherwise. +(defun encode-arm-immediate (u32) + (do* ((u32 (logand #xffffffff u32)) + (rot 0 (+ rot 2))) + ((= rot 32) (values nil nil)) + (let* ((a (arm-rotate-left u32 rot))) + (if (<= a #xff) + (return (logior (ash rot 7) a)))))) + + +(eval-when (:execute :load-toplevel) + (defstruct (instruction-element (:include ccl::dll-node)) + address) + +;;; A LAP-INSTRUCTION's field-values list contains (byte-spec . value) +;;; pairs, where the byte-spec is encoded as a fixnum. If the BYTE-SIZE +;;; of the byte-spec is non-zero, the value is to be inserted in the +;;; instruction by DPB; if the BYTE-SIZE is zero, the BYTE-POSITION of + +;;; the byte-spec is used to select a function which affects arbitrary +;;; bitfields in the instruction. (E.g., a negative constant in an ADD +;;; instruction might turn the instruction into a SUB.) +;;; The relationship between logical operands and field-values isn't +;;; necessarily 1:1. +;;; For vinsn expansion, the field values with constant values can +;;; be applied at vinsn-definition time. + + (defstruct (lap-instruction (:include instruction-element) + (:constructor %make-lap-instruction (source))) + source ; for LAP, maybe vinsn-template + (opcode 0) + field-values + ) + + (defstruct (lap-note (:include instruction-element)) + peer + id) + + (defstruct (lap-note-begin (:include lap-note))) + (defstruct (lap-note-end (:include lap-note))) + + (defstruct (lap-label (:include instruction-element) + (:constructor %%make-lap-label (name))) + name + refs)) + +(ccl::def-standard-initial-binding *lap-label-freelist* (ccl::make-dll-node-freelist)) +(ccl::def-standard-initial-binding *lap-instruction-freelist* (ccl::make-dll-node-freelist)) + + +(defun make-field-value (size position value) + (cons (byte size position) value)) + +(defun add-field-value (instruction size position value) + (push (make-field-value size position value) + (lap-instruction-field-values instruction))) + +(defun set-field-value (instruction size position value) + (setf (lap-instruction-opcode instruction) + (dpb value (byte size position) (lap-instruction-opcode instruction)))) + + +(defun need-arm-gpr (form) + (or (get-arm-gpr form) + (error "Expected an ARM general-purpose register, got ~s" form))) + +(defun encode-arm-shift-type (op) + (case op + (:lsl 0) + (:lsr 1) + (:asr 2) + (:ror 3))) + + +(defconstant opcode-and 0) +(defconstant opcode-eor 1) +(defconstant opcode-sub 2) +(defconstant opcode-rsb 3) +(defconstant opcode-add 4) +(defconstant opcode-adc 5) +(defconstant opcode-sbc 6) +(defconstant opcode-rsc 7) +(defconstant opcode-tst 8) +(defconstant opcode-teq 9) +(defconstant opcode-cmp 10) +(defconstant opcode-cmn 11) +(defconstant opcode-orr 12) +(defconstant opcode-mov 13) +(defconstant opcode-bic 14) +(defconstant opcode-mvn 15) + +(defvar *equivalent-complemented-opcodes* + (vector opcode-bic ;and->bic + nil ;eor-> + nil ;sub-> + nil ;rsb-> + nil ;add-> + opcode-sbc ;adc->sbc + opcode-adc ;sbc->adc + nil ;rsc-> + nil ;tst-> + nil ;cmp-> + nil ;cmn-> + nil ;orr-> + opcode-mvn ;mov->mvn + opcode-and ;bic->and + opcode-mov ;mvn->mov + )) + +(defvar *equivalent-negated-opcodes* + (vector nil ;and-> + nil ;eor-> + opcode-add ;sub->add + nil ;rsb-> + opcode-sub ;add->sub + nil ;adc-> + nil ;sbc-> + nil ;rsc-> + nil ;tst-> + opcode-cmn ;cmp->cmn + opcode-cmp ;cmn->cmp + nil ;orr-> + nil ;mov-> + nil ;bic-> + nil ;mvn-> + )) + +(defconstant arm-pseudofield-shifter-constant 0) + + +(defun parse-rd-operand (form instruction) + (set-field-value instruction 4 12 (need-arm-gpr form))) + +(defun parse-rn-operand (form instruction) + (set-field-value instruction 4 16 (need-arm-gpr form))) + +(defun parse-shifter-operand (form instruction) + (if (atom form) + ;; rm is shorthand for (:lsl rm (:$ 0)); the :lsl is encoded as 0. + (set-field-value instruction 12 0 (need-arm-gpr form)) + (if (ccl::quoted-form-p form) + (add-field-value instruction 0 arm-pseudofield-shifter-constant + (need-constant form)) + (let* ((op (keywordize (car form)))) + (ecase op + (:$ (destructuring-bind (value) (cdr form) + (add-field-value instruction 0 arm-pseudofield-shifter-constant + (eval value)))) + (:rrx (destructuring-bind (reg) (cdr form) + (set-field-value instruction 12 0 + (logior (need-arm-gpr reg) + (ash (encode-arm-shift-type :ror) 5))))) + ((:lsl :lsr :asr :ror) + (destructuring-bind (reg count) (cdr form) + (if (atom count) + (set-field-value instruction 12 0 + (logior (need-arm-gpr reg) + (ash 1 4) + (ash (encode-arm-shift-type op) 5) + (ash (need-arm-gpr count) 8))) + (ecase (keywordize (car count)) + (:$ (destructuring-bind (countval) (cdr count) + (set-field-value instruction 12 0 + (logior (need-arm-gpr reg) + (ash (encode-arm-shift-type op) 5) + (ash (logand 31 (eval countval)) 8)))))))))))))) + +(defun insert-shifter-constant (value opcode) + (let* ((constant (encode-arm-immediate value))) + (if constant + (logior constant (logior (ash 1 25) opcode)) + ;; If value couldn't be encoded but its complement can be + ;; and there's an instruction that can operate on complemented + ;; values, change the instruction and encode the complemented + ;; value. If that doesn't work, try negating the value and + ;; seeing if there's an equivalent instruction that could use + ;; that. If none of this works, complain that the value can't + ;; be encoded. + (let* ((op (ldb (byte 4 21) opcode)) + (newop nil)) + (if (or (and (setq constant (encode-arm-immediate (lognot value))) + (setq newop (svref op *equivalent-complemented-opcodes*))) + (and (setq constant (encode-arm-immediate (- value))) + (setq newop (svref op *equivalent-negated-opcodes*)))) + (logior constant + (logior (ash 1 25) (dpb newop (byte 4 21) opcode))) + (error "Can't encode ARM constant ~s." value)))))) + +;;; "general" address operand, as used in LDR/LDRB/STR/STRB +(defun parse-memory-operand (form instruction) + (if (atom form) + (error "Invalid memory operand ~s" form) + (let* ((mode (keywordize (car form)))) + (destructuring-bind (rn &optional (index '(:$ 0) index-p)) (cdr form) + (unless (or index-p (eq mode :@)) + (error "missing index in memory operand ~s." form)) + (set-field-value instruction 4 16 (need-arm-gpr rn)) + (let* ((quoted (ccl::quoted-form-p form)) + (index-op (if quoted :quote (and (consp index) (keywordize (car index))))) + (constant-index (or quoted (eq index-op :$)))) + (cond (constant-index + (destructuring-bind (val) (cdr index) + (let* ((constval (if quoted + (need-constant index) + (eval val)))) + (if (< constval 0) + (setq constval (- constval)) + ;; das u bit + (set-field-value instruction 1 23 1)) + (unless (typep constval '(unsigned-byte 12)) + (warn "constant offset too large : ~s" constval)) + (set-field-value instruction 12 0 constval)))) + (t + (set-field-value instruction 1 25 1) + (if (atom index) + (set-field-value instruction 12 0 (need-arm-gpr index)) + ;; Shifts here are always by a constant (not another reg) + (if (eq index-op :rrx) + (destructuring-bind (rm) (cdr index) + (set-field-value instruction 12 0 + (logior (need-arm-gpr rm) + (ash (encode-arm-shift-type :ror) 5)))) + + (destructuring-bind (rm shift-expr) (cdr index) + (unless (and (consp shift-expr) + (eq (keywordize (car shift-expr)) :$)) + (error "Shift count must be immediate : ~s" shift-expr)) + (destructuring-bind (count-expr) (cdr shift-expr) + (set-field-value instruction 12 0 + (logior (need-arm-gpr rm) + (ash (encode-arm-shift-type + index-op) 5) + (ash (logand 31 (eval count-expr)) + 7))))))))) + ;; Now, look at mode and set P/W/U bits. If CONSTANT-INDEX is + ;; true, the U bit depends on the sign of the constant. + (ecase mode + ((:@ :+@ :+@!) + ;; Preindexed, no writeback unless :+@! , add register operands. + (unless constant-index + (set-field-value instruction 1 23 1)) + (when (eq mode :+@!) + (set-field-value instruction 1 21 1)) + (set-field-value instruction 1 24 1)) + ((:-@ :-@!) + ;; Preindexed. Leave the U bit clear, maybe set W if writeback. + (when (eq mode :-@!) + (set-field-value instruction 1 21 1)) + (set-field-value instruction 1 24 1)) + ((:@+ :@-) + ;; Postindex; writeback is implicit (and setting P and W would + ;; change the instruction.) + (unless (or (eq mode :@-) constant-index) + (set-field-value instruction 1 23 1))))))))) + +(defun parse-reglist-operand (form instruction) + (let* ((mask 0)) + (dolist (r form) + (let* ((regno (need-arm-gpr r))) + (when (logbitp regno mask) + (warn "Duplicate register ~s in ~s." r form)) + (setq mask (logior mask (ash 1 regno))))) + (if (zerop mask) + (error "Empty register list ~s." form) + (set-field-value instruction 16 0 mask)))) + +(defun parse-rnw-operand (form instruction) + (if (atom form) + (set-field-value instruction 4 16 (need-arm-gpr form)) + (if (eq (keywordize (car form)) :!) + (destructuring-bind (rn) (cdr form) + (set-field-value instruction 1 21 1) + (set-field-value instruction 4 16 (need-arm-gpr rn))) + (error "Unrecognize writeback indicator in ~s." form)))) + +(defun parse-uuoA-operand (form instruction) + (set-field-value instruction 4 8 (need-arm-gpr form))) + +(defun parse-uuo-unary-operand (form instruction) + (set-field-value instruction 4 12 (need-constant form))) + +(defun parse-uuoB-operand (form instruction) + (set-field-value instruction 4 12 (need-arm-gpr form))) + + + + +(defparameter *arm-operand-parsers* + #(parse-rd-operand + parse-rn-operand + parse-shifter-operand + parse-memory-operand + parse-reglist-operand + parse-rnw-operand + parse-uuoa-operand + parse-uuo-unary-operand + parse-uuob-operand + )) + +;;; FORM is a list; its car isn't a pseudo-op or lapmacro; try to generate +;;; an instruction. +(defun assemble-instruction (form) + (let* ((insn (%make-lap-instruction form))) + (destructuring-bind (name . opvals) form + (multiple-value-bind (template cond explicit-cond) (lookup-arm-instruction name) + (unless template + (error "Unknown ARM instruction - ~s" form)) + (when (and (consp (car opvals)) + (eq (keywordize (caar opvals)) :?)) + (let* ((condform (pop opvals))) + (destructuring-bind (q cond-name) condform + (declare (ignore q)) + (let* ((c (need-arm-condition-name cond-name))) + (if (and explicit-cond (not (eql c cond))) + (error "Can't use explicit condition and :? : ~s" condform) + (setq cond c)))))) + + (let* ((optypes (arm-instruction-template-operand-types template)) + (n (length optypes))) + (unless (= n (length opvals)) + (error "ARM ~a instructions require ~d operands, but ~d were provided in ~s." (arm-instruction-template-name template) n (length opvals) form)) + (setf (lap-instruction-opcode insn) + (arm-instruction-template-val template)) + (dotimes (i n) + (let* ((optype (pop optypes)) + (val (pop opvals))) + (funcall (svref *arm-operand-parsers* optype) val insn))) + (when cond + (setf (lap-instruction-opcode insn) + (dpb cond (byte 4 28) (lap-instruction-opcode insn)))) + insn))))) + +(provide "ARM-ASM") Index: /branches/arm/compiler/ARM/arm-backend.lisp =================================================================== --- /branches/arm/compiler/ARM/arm-backend.lisp (revision 13699) +++ /branches/arm/compiler/ARM/arm-backend.lisp (revision 13699) @@ -0,0 +1,359 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +(next-nx-defops) +(defvar *arm2-specials* nil) +(let* ((newsize (%i+ (next-nx-num-ops) 10)) + (old *arm2-specials*) + (oldsize (length old))) + (declare (fixnum newsize oldsize)) + (unless (>= oldsize newsize) + (let* ((v (make-array newsize :initial-element nil))) + (dotimes (i oldsize (setq *arm2-specials* v)) + (setf (svref v i) (svref old i)))))) + +;;; This defines a template. All expressions in the body must be +;;; evaluable at macroexpansion time. +#+notyet +(defun define-arm-vinsn (backend vinsn-name results args temps body) + (let* ((opcode-vector (backend-lap-opcodes backend)) + (opcode-lookup (backend-lookup-opcode backend)) + (opcode-expander (backend-lookup-macro backend)) + (backend-name (backend-name backend)) + (arch-name (backend-target-arch-name backend)) + (template-hash (backend-p2-template-hash-name backend)) + (name-list ()) + (attrs 0) + (nhybrids 0) + (local-labels ()) + (referenced-labels ()) + (source-indicator (form-symbol arch-name "-VINSN")) + (opcode-alist ())) + (flet ((valid-spec-name (x) + (or (and (consp x) + (consp (cdr x)) + (null (cddr x)) + (atom (car x)) + (or (assoc (cadr x) *vreg-specifier-constant-constraints* :test #'eq) + (assoc (cadr x) *spec-class-storage-class-alist* :test #'eq) + (eq (cadr x) :label) + (and (consp (cadr x)) + (or + (assoc (caadr x) *vreg-specifier-constant-constraints* :test #'eq) + (assoc (caadr x) *spec-class-storage-class-alist* :test #'eq)))) + (car x)) + (error "Invalid vreg spec: ~s" x))) + (add-spec-name (vname) + (if (member vname name-list :test #'eq) + (error "Duplicate name ~s in vinsn ~s" vname vinsn-name) + (push vname name-list)))) + (declare (dynamic-extent #'valid-spec-name #'add-spec-name)) + (when (consp vinsn-name) + (setq attrs (encode-vinsn-attributes (cdr vinsn-name)) + vinsn-name (car vinsn-name))) + (unless (and (symbolp vinsn-name) (eq *CCL-PACKAGE* (symbol-package vinsn-name))) + (setq vinsn-name (intern (string vinsn-name) *CCL-PACKAGE*))) + (dolist (n (append args temps)) + (add-spec-name (valid-spec-name n))) + (dolist (form body) + (if (atom form) + (add-spec-name form))) + (setq name-list (nreverse name-list)) + ;; We now know that "args" is an alist; we don't know if + ;; "results" is. First, make sure that there are no duplicate + ;; result names (and validate "results".) + (do* ((res results tail) + (tail (cdr res) (cdr tail))) + ((null res)) + (let* ((name (valid-spec-name (car res)))) + (if (assoc name tail :test #'eq) + (error "Duplicate result name ~s in ~s." name results)))) + (let* ((non-hybrid-results ()) + (match-args args)) + (dolist (res results) + (let* ((res-name (car res))) + (if (not (assoc res-name args :test #'eq)) + (if (not (= nhybrids 0)) + (error "result ~s should also name an argument. " res-name) + (push res-name non-hybrid-results)) + (if (eq res-name (caar match-args)) + (setf nhybrids (1+ nhybrids) + match-args (cdr match-args)) + (error "~S - hybrid results should appear in same order as arguments." res-name))))) + (dolist (name non-hybrid-results) + (add-spec-name name))) + (let* ((k -1)) + (declare (fixnum k)) + (let* ((name-alist (mapcar #'(lambda (n) (cons n (list (incf k)))) name-list))) + (flet ((find-name (n) + (let* ((pair (assoc n name-alist :test #'eq))) + (declare (list pair)) + (if pair + (cdr pair) + (or (subprim-name->offset n backend) + (error "Unknown name ~s" n)))))) + (labels ((simplify-operand (op) + (if (atom op) + (if (typep op 'fixnum) + op + (if (constantp op) + (progn + (if (keywordp op) + (pushnew op referenced-labels)) + (eval op)) + (find-name op))) + (if (eq (car op) :apply) + `(,(cadr op) ,@(mapcar #'simplify-operand (cddr op))) + (simplify-operand (eval op)))))) ; Handler-case this? + (labels ((simplify-constraint (guard) + ;; A constraint is one of + + ;; (:eq|:lt|:gt vreg-name constant) + + ;; value" of vreg relop constant + + ;; (:pred * ; + ;; unquoted, each + ;; is a vreg-name or constant expression. + + ;; (:type vreg-name typeval) ; vreg is of + ;; "type" typeval + ;; + ;;(:not ) ; constraint is false + ;; (:and ...) ; conjuntion + ;; (:or ...) ; disjunction + ;; There's no "else"; we'll see how ugly it + ;; is without one. + (destructuring-bind (guardname &rest others) guard + (ecase guardname + (:not + (destructuring-bind (negation) others + `(:not ,(simplify-constraint negation)))) + (:pred + (destructuring-bind (predicate &rest operands) others + `(:pred ,predicate ,@(mapcar #'simplify-operand operands)))) + ((:eq :lt :gt :type) + (destructuring-bind (vreg constant) others + (unless (constantp constant) + (error "~S : not constant in constraint ~s ." constant guard)) + `(,guardname ,(find-name vreg) ,(eval constant)))) + ((:or :and) + (unless others (error "Missing constraint list in ~s ." guard)) + `(,guardname ,(mapcar #'simplify-constraint others)))))) + (simplify-form (form) + (if (atom form) + (progn + (if (keywordp form) (push form local-labels) ) + form) + (destructuring-bind (&whole w opname &rest opvals) form + (if (consp opname) ; A constraint, we presume ... + (cons (simplify-constraint opname) + (mapcar #'simplify-form opvals)) + (if (keywordp opname) + form + (let* ((name (string opname)) + (opnum (funcall opcode-lookup name))) + (if (and (not opnum) opcode-expander) + (let* ((expander (funcall opcode-expander name))) + (if expander + (simplify-form (funcall expander form nil)) + (error "Unknown ~A instruction in ~s" backend-name form))) + (let* ((opcode (if (< -1 opnum (length opcode-vector)) + (svref opcode-vector opnum) + (error "~& Invalid ~A opcode: ~s" backend-name name))) + (opvals (mapcar #'simplify-operand opvals))) + (setf (assq opnum opcode-alist) name) + (let* ((operands (opcode-vinsn-operands opcode)) + (nmin (opcode-min-vinsn-args opcode)) + (nmax (opcode-max-vinsn-args opcode)) + (nhave (length opvals))) + (declare (fixnum nmin nmax nhave)) + (if (= nhave nmax) + `(,opnum ,@opvals) + (if (> nhave nmax) + (error "Too many operands in ~s (~a accepts at most ~d)" + (cdr w) name nmax) + (if (= nhave nmin) + (let* ((newops ())) + (dolist (op operands `(,opnum ,@(nreverse newops))) + (let* ((flags (operand-flags op))) + (unless (logbitp operand-fake flags) + (push (if (logbitp operand-optional flags) + 0 + (pop opvals)) + newops))))) + (error "Too few operands in ~s : (~a requires at least ~d)" + (cdr w) name nmin)))))))))))))) + (let* ((template (make-vinsn-template + :name vinsn-name + :result-vreg-specs results + :argument-vreg-specs args + :temp-vreg-specs temps + :nhybrids nhybrids + :results&args (append results (nthcdr nhybrids args)) + :nvp (- (+ (length results) (length args) (length temps)) + nhybrids) + :body (prog1 (mapcar #'simplify-form body) + (dolist (ref referenced-labels) + (unless (memq ref local-labels) + (error + "local label ~S was referenced but never defined in VINSN-TEMPLATE definition for ~s" ref vinsn-name)))) + :local-labels local-labels :attributes attrs :opcode-alist + opcode-alist))) + `(progn (set-vinsn-template ',vinsn-name ,template + ,template-hash) (record-source-file ',vinsn-name ',source-indicator) + ',vinsn-name)))))))))) + + + +(defvar *arm-vinsn-templates* (make-hash-table :test #'eq)) + + + + +(defvar *known-arm-backends* ()) + + +#+linuxarm-target +(defvar *linuxarm-backend* + (make-backend :lookup-opcode #'arm::lookup-arm-instruction + :lookup-macro #'false + :lap-opcodes arm::*arm-instruction-table* + :define-vinsn 'define-arm-vinsn + :platform-syscall-mask (logior platform-os-linux platform-cpu-arm) + :p2-dispatch *arm2-specials* + :p2-vinsn-templates *arm-vinsn-templates* + :p2-template-hash-name '*arm-vinsn-templates* + :p2-compile 'arm2-compile + :target-specific-features + '(:arm :arm-target :eabi-target :linux-target :linuxarm-target :32-bit-target :little-endian-target) + :target-fasl-pathname (make-pathname :type "lafsl") + :target-platform (logior platform-word-size-32 + platform-cpu-arm + platform-os-linux) + :target-os :linuxarm + :name :linuxarm + :target-arch-name :arm + :target-foreign-type-data nil + :target-arch arm::*arm-target-arch*)) + + +#+darwinarm-target +(defvar *darwinarm-backend* + (make-backend :lookup-opcode #'lookup-arm-opcode + :lookup-macro #'arm::arm-macro-function + :lap-opcodes arm::*arm-opcodes* + :define-vinsn 'define-arm-vinsn + :platform-syscall-mask (logior platform-os-darwin platform-cpu-arm) + :p2-dispatch *arm2-specials* + :p2-vinsn-templates *arm-vinsn-templates* + :p2-template-hash-name '*arm-vinsn-templates* + :p2-compile 'arm2-compile + :target-specific-features + '(:powerpc :arm-target :darwin-target :darwinarm-target :arm-target :32-bit-target :big-endian-target) + :target-fasl-pathname (make-pathname :type "dfsl") + :target-platform (logior platform-word-size-32 + platform-cpu-arm + platform-os-darwin) + :target-os :darwinarm + :name :darwinarm + :target-arch-name :arm + :target-foreign-type-data nil + :target-arch arm::*arm-target-arch*)) + +#+linuxarm-target +(pushnew *linuxarm-backend* *known-arm-backends* :key #'backend-name) + + +#+darwinarm-target +(pushnew *darwinarm-backend* *known-arm-backends* :key #'backend-name) + +(defvar *arm-backend* (car *known-arm-backends*)) + +(defun fixup-arm-backend () + (dolist (b *known-arm-backends*) + (setf (backend-lap-opcodes b) arm::*arm-opcodes* + (backend-p2-dispatch b) *arm2-specials* + (backend-p2-vinsn-templates b) *arm-vinsn-templates*) + (or (backend-lap-macros b) (setf (backend-lap-macros b) + (make-hash-table :test #'equalp))))) + + + +(fixup-arm-backend) + +#+arm-target +(setq *host-backend* *arm-backend* *target-backend* *arm-backend*) +#-arm-target +(unless (backend-target-foreign-type-data *arm-backend*) + (let* ((ftd (make-ftd + :interface-db-directory + #+darwinarm-target "ccl:darwin-headers;" + #+linuxarm-target "ccl:headers;" + :interface-package-name + #+darwinarm-target "DARWIN32" + #+linuxarm-target "LINUX32" + :attributes + #+darwinarm-target + '(:signed-char t + :struct-by-value t + :prepend-underscores t + :bits-per-word 32 + :poweropen-alignment t) + #+linuxarm-target + '(:bits-per-word 32) + :ff-call-expand-function + #+linuxarm-target + 'linux32::expand-ff-call + #+darwinarm-target + 'darwin32::expand-ff-call + :ff-call-struct-return-by-implicit-arg-function + #+linuxarm-target + linux32::record-type-returns-structure-as-first-arg + #+darwinarm-target + darwin32::record-type-returns-structure-as-first-arg + :callback-bindings-function + #+linuxarm-target + linux32::generate-callback-bindings + #+darwinarm-target + darwin32::generate-callback-bindings + :callback-return-value-function + #+linuxarm-target + linux32::generate-callback-return-value + #+darwinarm-target + darwin32::generate-callback-return-value + ))) + (install-standard-foreign-types ftd) + (use-interface-dir :libc ftd) + (setf (backend-target-foreign-type-data *arm-backend*) ftd))) + +(pushnew *arm-backend* *known-backends* :key #'backend-name) + +(require "ARM-VINSNS") + +(defparameter *arm-backend* + #+arm-target *arm-backend* + #-(or arm-target) + nil) + + + + + + Index: /branches/arm/compiler/ARM/arm-lap.lisp =================================================================== --- /branches/arm/compiler/ARM/arm-lap.lisp (revision 13699) +++ /branches/arm/compiler/ARM/arm-lap.lisp (revision 13699) @@ -0,0 +1,554 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2010 Clozure Associates +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + + +(in-package "CCL") + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require "ARM-ARCH") + (require "DLL-NODE") + (require "ARM-ASM") + (require "SUBPRIMS")) + + +(defun arm-lap-macro-function (name) + (gethash (string name) (backend-lap-macros *arm-backend*))) + +(defun (setf arm-lap-macro-function) (def name) + (let* ((s (string name))) + (when (gethash s arm::*arm-instruction-templates*) + (error "~s already defines an arm instruction . " name)) + (setf (gethash s (backend-lap-macros *arm-backend*)) def))) + +(defmacro defarmlapmacro (name arglist &body body) + `(progn + (setf (arm-lap-macro-function ',name) + (nfunction (arm-lap-macro ,name) ,(parse-macro name arglist body))) + (record-source-file ',name 'arm-lap) + ',name)) + +(defvar *arm-lap-constants* ()) +(defvar *arm-lap-labels* ()) +(defvar *arm-lap-instructions*) +(defvar *arm-lap-regsave-reg* ()) +(defvar *arm-lap-regsave-addr* ()) +(defvar *arm-lap-regsave-label* ()) +(defvar *arm-lap-lfun-bits* 0) + + + + + +(defun arm-lap-macroexpand-1 (form) + (unless (and (consp form) (atom (car form))) + (values form nil)) + (let* ((expander (arm-lap-macro-function (car form)))) + (if expander + (values (funcall expander form nil) t) + (values form nil)))) + + + + + +(defun %define-arm-lap-function (name body &optional (bits 0)) + (with-dll-node-freelist (*lap-instructions* *lap-instruction-freelist*) + (let* ((*lap-labels* ()) + (*arm-lap-constants* ()) + (*arm-lap-lfun-bits* bits)) + (dolist (form body) + (arm-lap-form form)) + #+arm-lap-scheduler (arm-schedule-instuctions) ; before resolving branch targets + (arm-lap-generate-code name (arm-lap-do-labels) *arm-lap-lfun-bits*)))) + + + +(defun arm-lap-assign-addresses (delete-labels-p) + (let* ((pc 0)) + (declare (fixnum pc)) + (do-dll-nodes (node *lap-instructions*) + (setf (instruction-element-address node) pc) + (if (typep node 'lap-label) + (if delete-labels-p (remove-dll-node node)) + (incf pc 4))) + ;; Don't bother checking code-vector size yet. + pc)) + + + +(defun arm-lap-do-labels () + (do-lap-labels (lab) + (if (and (lap-label-refs lab) (not (lap-label-emitted-p lab))) + (error "Label ~S was referenced but never defined. " + (lap-label-name lab))) + ;; Repeatedly iterate through label's refs, until none of them is + ;; the preceding instruction. This eliminates + ;; (b @next) + ;;@next + ;; + ;; but can probably be fooled by hairier nonsense. + (loop + (when (dolist (ref (lap-label-refs lab) t) + (when (eq lab (lap-instruction-succ ref)) + (remove-dll-node ref) + (setf (lap-label-refs lab) (delete ref (lap-label-refs lab))) + (return))) + (return)))) + ;; Assign pc to emitted labels, splice them out of the list. + + (if (> (the fixnum (dll-header-length *lap-instructions*)) 8191) + ;; -Might- have some conditional branches that are too long. + ;; Definitely don't otherwise, so only bother to check in this case + (arm-lap-remove-long-branches) + (arm-lap-assign-addresses t))) + +;;; Replace each label with the difference between the label's address +;;; and the referencing instruction's address. +(defun arm-lap-resolve-labels () + (do-lap-labels (label) + (let* ((label-address (lap-label-address label))) + (declare (fixnum label-address)) ; had BETTER be ... + (dolist (insn (lap-label-refs label)) + (let* ((diff (- label-address (lap-instruction-address insn)))) + (declare (fixnum diff)) + (let* ((opvals (lap-instruction-parsed-operands insn)) + (pos (position label opvals))) + (unless pos + (error "Bug: label ~s should be referenced by instruction ~s, but isn't." label insn)) + (setf (svref opvals pos) diff))))))) + +(defun arm-lap-generate-instruction (code-vector index insn) + (let* ((op (lap-instruction-opcode insn)) + (vals (lap-instruction-parsed-operands insn)) + (high (opcode-op-high op)) + (low (opcode-op-low op)) + (idx -1)) + (dolist (operand (opcode-operands op)) + (let* ((val (if (logbitp operand-fake (operand-flags operand)) + 0 + (svref vals (incf idx)))) + (insert-function (operand-insert-function operand))) + (multiple-value-setq (high low) + (if insert-function + (funcall insert-function high low val) + (arm::insert-default operand high low val))) + (if (null high) + (error "Invalid operand for ~s instruction: ~d" (opcode-name op) val)))) + (setf (lap-instruction-parsed-operands insn) nil) + (free-lap-operand-vector vals) + (locally (declare (type (simple-array (unsigned-byte 16) (*)) code-vector) + (optimize (speed 3) (safety 0))) + (setf (aref code-vector (+ index index)) high + (aref code-vector (+ index index 1)) low) + nil))) + +(defparameter *use-traceback-tables* nil) + +(defun traceback-fullwords (pname) + (if (and *use-traceback-tables* pname (typep pname 'simple-base-string)) + (ceiling (+ 22 (length pname)) 4) + 0)) + +(defun add-traceback-table (code-vector start pname) + (flet ((out-byte (v i8 b) + (declare (type (simple-array (unsigned-byte 8) (*)) v) + (optimize (speed 3) (safety 0)) + (fixnum i8)) + (setf (aref v i8) b))) + (flet ((out-bytes (v i32 b0 b1 b2 b3) + (declare (type (simple-array (unsigned-byte 8) (*)) v) + (optimize (speed 3) (safety 0)) + (fixnum i32)) + (let* ((i8 (ash i32 2))) + (declare (fixnum i8)) + (setf (aref v i8) b0 + (aref v (%i+ i8 1)) b1 + (aref v (%i+ i8 2)) b2 + (aref v (%i+ i8 3)) b3)))) + (setf (uvref code-vector start) 0) + (out-bytes code-vector (1+ start) + 0 ; traceback table version + 0 ; language id 7 - try 0 instead (means C) or 9 means C++ + #x20 ; ??? + #x41) ; ??? + (out-bytes code-vector (+ start 2) + #x80 #x06 #x01 #x00) ; ??? ??? ??? ??? + (setf (uvref code-vector (+ start 3)) #x0) + (setf (uvref code-vector (+ start 4)) (ash start 2)) + (let* ((namelen (length pname)) + (pos (ash (the fixnum (+ start 5)) 2))) + (declare (fixnum namelen pos)) + (out-byte code-vector pos (ldb (byte 8 8) namelen)) + (incf pos) + (out-byte code-vector pos (ldb (byte 8 0) namelen)) + (incf pos) + (dotimes (i namelen) + (out-byte code-vector pos (char-code (schar pname i))) + (incf pos)))))) + +(defun arm-lap-generate-code (name maxpc bits &optional (traceback nil)) + (declare (fixnum maxpc)) + (let* ((target-backend *target-backend*) + (cross-compiling (not (eq *host-backend* target-backend))) + (traceback-size + (traceback-fullwords (and traceback + name + (setq traceback (symbol-name name))))) + (prefix (arch::target-code-vector-prefix (backend-target-arch *target-backend*))) + (prefix-size (length prefix)) + (code-vector-size (+ (ash maxpc -2) traceback-size prefix-size)) + + (constants-size (+ 3 (length *arm-lap-constants*))) + (constants-vector (%alloc-misc + constants-size + (if cross-compiling + target::subtag-xfunction + target::subtag-function))) + (i prefix-size)) + (declare (fixnum i constants-size)) + #+arm32-target + (if (>= code-vector-size (ash 1 19)) (compiler-function-overflow)) + (let* ((code-vector (%alloc-misc + code-vector-size + (if cross-compiling + target::subtag-xcode-vector + target::subtag-code-vector)))) + (dotimes (j prefix-size) + (setf (uvref code-vector j) (pop prefix))) + (arm-lap-resolve-labels) ; all operands fully evaluated now. + (do-dll-nodes (insn *lap-instructions*) + (arm-lap-generate-instruction code-vector i insn) + (incf i)) + (unless (eql 0 traceback-size) + (add-traceback-table code-vector i traceback)) + (dolist (immpair *arm-lap-constants*) + (let* ((imm (car immpair)) + (k (cdr immpair))) + (declare (fixnum k)) + (setf (uvref constants-vector + (ash + (- k (arch::target-misc-data-offset (backend-target-arch target-backend))) + (- (arch::target-word-shift (backend-target-arch target-backend))))) + imm))) + (setf (uvref constants-vector (1- constants-size)) bits ; lfun-bits + (uvref constants-vector (- constants-size 2)) name + (uvref constants-vector 0) code-vector) + #+arm-target (%make-code-executable code-vector) + constants-vector))) + +(defun arm-lap-pseudo-op (form) + (case (car form) + (:regsave + (if *arm-lap-regsave-label* + (warn "Duplicate :regsave form not handled (yet ?) : ~s" form) + (destructuring-bind (reg addr) (cdr form) + (let* ((regno (arm-register-name-or-expression reg))) + (if (not (<= arm::save7 regno arm::save0)) + (warn "Not a save register: ~s. ~s ignored." reg form) + (let* ((addrexp (arm-register-name-or-expression addr))) ; parses 'fixnum + (if (not (and (typep addrexp 'fixnum) + (<= 0 addrexp #x7ffc) ; not really right + (not (logtest 3 addrexp)))) + (warn "Invalid logical VSP: ~s. ~s ignored." addr form) + (setq *arm-lap-regsave-label* (emit-lap-label (gensym)) + *arm-lap-regsave-reg* regno + *arm-lap-regsave-addr* (- (+ addrexp) + (* 4 (1+ (- arm::save0 regno)))))))))))) + (:arglist (setq *arm-lap-lfun-bits* (encode-lambda-list (cadr form)))))) + + +(defun arm-lap-form (form) + (if (and form (symbolp form)) + (emit-lap-label form) + (if (or (atom form) (not (symbolp (car form)))) + (error "~& unknown ARM-LAP form: ~S ." form) + (multiple-value-bind (expansion expanded) + (arm-lap-macroexpand-1 form) + (if expanded + (arm-lap-form expansion) + (let* ((name (car form))) + (if (keywordp name) + (arm-lap-pseudo-op form) + (case name + ((progn) (dolist (f (cdr form)) (arm-lap-form f))) + ((let) (arm-lap-equate-form (cadr form) (cddr form))) + (t + ; instruction macros expand into instruction forms + ; (with some operands reordered/defaulted.) + (let* ((expander (arm::arm-macro-function name))) + (if expander + (arm-lap-form (funcall expander form nil)) + (arm-lap-instruction name (cdr form))))))))))))) + +;;; (let ((name val) ...) &body body) +;;; each "val" gets a chance to be treated as a ARM register name +;;; before being evaluated. +(defun arm-lap-equate-form (eqlist body) + (let* ((symbols (mapcar #'(lambda (x) + (let* ((name (car x))) + (or + (and name + (symbolp name) + (not (constant-symbol-p name)) + name) + (error + "~S is not a bindable symbol name ." name)))) + eqlist)) + (values (mapcar #'(lambda (x) (or (arm-vr-name-p (cadr x)) + (arm-fpr-name-p (cadr x)) + (arm-register-name-or-expression + (cadr x)))) + eqlist))) + (progv symbols values + (dolist (form body) + (arm-lap-form form))))) + +(defun arm-lap-constant-offset (x) + (or (cdr (assoc x *arm-lap-constants* :test #'equal)) + (let* ((target-backend *target-backend*) + (n (+ (arch::target-misc-data-offset (backend-target-arch target-backend)) + (ash (1+ (length *arm-lap-constants*)) + (arch::target-word-shift (backend-target-arch target-backend)))))) + (push (cons x n) *arm-lap-constants*) + n))) + +; Evaluate an arbitrary expression; warn if the result isn't a fixnum. +(defun arm-lap-evaluated-expression (x) + (if (typep x 'fixnum) + x + (if (null x) + (arch::target-nil-value (backend-target-arch *target-backend*)) + (if (eq x t) + (+ (arch::target-nil-value (backend-target-arch *target-backend*)) + (arch::target-t-offset (backend-target-arch *target-backend*))) + (let* ((val (handler-case (eval x) ; Look! Expression evaluation! + (error (condition) (error "~&Evaluation of ~S signalled assembly-time error ~& ~A ." + x condition))))) + (unless (typep val 'fixnum) + (warn "assembly-time evaluation of ~S returned ~S, which may not have been intended ." + x val)) + val))))) + +(defparameter *arm-lap-register-aliases* + `((nfn . ,arm::nfn) + (fname . ,arm::fname))) + +(defparameter *arm-lap-fp-register-aliases* + ()) + +(defparameter *arm-lap-vector-register-aliases* + ()) + +(defun arm-gpr-name-p (x) + (and (or (symbolp x) (stringp x)) + (or + (position (string x) arm::*gpr-register-names* :test #'string-equal) + (cdr (assoc x *arm-lap-register-aliases* :test #'string-equal))))) + +(defun arm-register-name-or-expression (x) + (if x + (or (arm-gpr-name-p x) + (if (and (consp x) (eq (car x) 'quote)) + (let* ((quoted-form (cadr x))) + (if (null quoted-form) + (arch::target-nil-value (backend-target-arch *target-backend*)) + (if (eq quoted-form t) + (+ (arch::target-nil-value (backend-target-arch *target-backend*)) + (arch::target-t-offset (backend-target-arch *target-backend*))) + (if (typep quoted-form 'fixnum) + (ash quoted-form (arch::target-fixnum-shift (backend-target-arch *target-backend*))) + (arm-lap-constant-offset quoted-form))))) + (arm-lap-evaluated-expression x))) + (arch::target-nil-value (backend-target-arch *target-backend*)))) + +(defun arm-fpr-name-p (x) + (and (or (symbolp x) (stringp x)) + (or + (position (string x) arm::*fpr-register-names* :test #'string-equal) + (cdr (assoc x *arm-lap-fp-register-aliases* :test #'string-equal))))) + +(defun arm-fp-register-name-or-expression (x) + (or (arm-fpr-name-p x) + (arm-lap-evaluated-expression x))) + +(defun arm-vr-name-p (x) + (and (or (symbolp x) (stringp x)) + (or + (position (string x) arm::*vector-register-names* :test #'string-equal) + (cdr (assoc x *arm-lap-vector-register-aliases* :test #'string-equal))))) + +(defun arm-vector-register-name-or-expression (x) + (or (arm-vr-name-p x) + (arm-lap-evaluated-expression x))) + + +(defparameter *arm-cr-field-names* #(:crf0 :crf1 :crf2 :crf3 :crf4 :crf5 :crf6 :crf7)) +(defparameter *arm-cr-names* #(:cr0 :cr1 :cr2 :cr3 :cr4 :cr5 :cr6 :cr7)) +(defparameter *arm-cc-bit-names* #(:lt :gt :eq :so :un)) +(defparameter *arm-cc-bit-inverse-names* #(:ge :le :ne :ns :nu)) + +; This wants a :CC, a negated :CC, or either (:CRn :CC) or (:CRn :~CC). +; Returns the fully-qualified CR bit and an indication of whether or not the CC was +; negated. +(defun arm-lap-parse-test (x) + (if (or (symbolp x) (stringp x)) + (let* ((pos (position x *arm-cc-bit-names* :test #'string-equal))) + (if pos + (values (min pos 3) nil) + (if (setq pos (position x *arm-cc-bit-inverse-names* :test #'string-equal)) + (values (min pos 3) t) + (error "Unknown ARM lap condition form : ~s" x)))) + (if (and (consp x) (keywordp (car x)) (consp (cdr x)) (keywordp (cadr x))) + (let* ((field (position (car x) *arm-cr-names*))) + (unless field (error "Unknown CR field name : ~s" (car x))) + (let* ((bit (position (cadr x) *arm-cc-bit-names*))) + (if bit + (values (logior (ash field 2) (min bit 3)) nil) + (if (setq bit (position (cadr x) *arm-cc-bit-inverse-names*)) + (values (logior (ash field 2) (min bit 3)) t) + (error "Unknown condition name : ~s" (cadr x)))))) + (error "Unknown ARM lap condition form : ~s" x)))) + +; Accept either :CRn, :CC, or (:CRFn :CC), or evaluate an expression. +(defun arm-lap-cr-field-expression (x) + (if (or (symbolp x) (stringp x)) + (let* ((pos (position x *arm-cr-names* :test #'string-equal))) + (if pos + (ash pos 2) + (let* ((cc-pos (position x *arm-cc-bit-names* :test #'string-equal))) + (if cc-pos + (min cc-pos 3) + (arm-lap-evaluated-expression x))))) + (if (and (consp x) (keywordp (car x)) (consp (cdr x)) (keywordp (cadr x))) + (let* ((field (position (car x) *arm-cr-field-names*)) + (bit (position (cadr x) *arm-cc-bit-names*))) + (if (and field bit) + (logior (min bit 3) (ash field 2)) + (error "Bad arm-cr-field-expression: ~s" x))) + (arm-lap-evaluated-expression x)))) + +(defun arm-lap-instruction (name opvals) + (let* ((opnum (gethash (string name) arm::*arm-opcode-numbers*)) + (opcode (and opnum + (< -1 opnum (length arm::*arm-opcodes*)) + (svref arm::*arm-opcodes* opnum)))) + (unless opcode + (error "Unknown ARM opcode: ~a" name)) + ;; Unless either + ;; a) The number of operand values in the macro call exactly + ;; matches the number of operands accepted by the instruction or + ;; b) The number of operand values is one less, and the instuction + ;; takes an optional operand + ;; we've got a wrong-number-of-args error. + ;; In case (b), there's at most one optional argument per instruction; + ;; provide 0 for the missing value. + (let* ((operands (opcode-operands opcode)) + (nmin (opcode-min-args opcode)) + (nmax (opcode-max-args opcode)) + (nhave (length opvals))) + (declare (fixnum nmin nmax nhave)) + (if (= nhave nmax) + (arm-emit-lap-instruction opcode opvals) + (if (> nhave nmax) + (error "Too many operands in ~s (~a accepts at most ~d)" + opvals name nmax) + (if (= nhave nmin) + (let* ((newops ())) + (dolist (op operands (arm-emit-lap-instruction opcode (nreverse newops))) + (let* ((flags (operand-flags op))) + (unless (logbitp operand-fake flags) + (push (if (logbitp operand-optional flags) + 0 + (pop opvals)) + newops))))) + (error "Too few operands in ~s : (~a requires at least ~d)" + opvals name nmin))))))) + +; This is pretty rudimentary: if the operand has the "arm::$arm-operand-relative" bit +; set, we demand a label name and note the fact that we reference the label in question. +; Otherwise, we use the "register-name-or-expression" thing. +; Like most ARM assemblers, this lets you treat everything as an expression, even if +; you've got the order of some arguments wrong ... + +(defun arm-parse-lap-operand (opvalx operand insn) + (let* ((flags (operand-flags operand))) + (declare (fixnum flags)) + (if (logbitp arm::$arm-operand-relative flags) + (lap-note-label-reference opvalx insn) + (if (logbitp arm::$arm-operand-cr flags) + (arm-lap-cr-field-expression opvalx) + (if (logbitp arm::$arm-operand-absolute flags) + (arm-subprimitive-address opvalx) + (if (logbitp arm::$arm-operand-fpr flags) + (arm-fp-register-name-or-expression opvalx) + (if (logbitp arm::$arm-operand-vr flags) ; SVS + (arm-vector-register-name-or-expression opvalx) + (arm-register-name-or-expression opvalx)))))))) + +(defun arm-subprimitive-address (x) + (if (and x (or (symbolp x) (stringp x))) + (let* ((info (find x arm::*arm-subprims* :test #'string-equal :key #'subprimitive-info-name))) + (when info (return-from arm-subprimitive-address + (subprimitive-info-offset info))))) + (arm-lap-evaluated-expression x)) + + +;;; We've checked that the number of operand values match the number +;;; expected (and have set "fake" operand values to 0.) Labels - and +;;; some constructs that might someday do arithmetic on them - are +;;; about the only class of forward references we need to deal with. +;;; This whole two-pass scheme seems overly general, but if/when we +;;; ever do instruction scheduling it'll probably make it simpler. +(defun arm-emit-lap-instruction (opcode opvals) + (let* ((operands (opcode-operands opcode)) + (parsed-values (alloc-lap-operand-vector)) + (insn (make-lap-instruction opcode)) + (idx -1)) + (declare (fixnum idx)) + (dolist (op operands) + (let* ((flags (operand-flags op)) + (val (if (logbitp operand-fake flags) + 0 + (arm-parse-lap-operand (pop opvals) op insn)))) + (declare (fixnum flags)) + (setf (svref parsed-values (incf idx)) val))) + (setf (lap-instruction-parsed-operands insn) parsed-values) + (append-dll-node insn *lap-instructions*))) + + + +(defmacro defarmlapfunction (&environment env name arglist &body body + &aux doc) + (if (not (endp body)) + (and (stringp (car body)) + (cdr body) + (setq doc (car body)) + (setq body (cdr body)))) + `(progn + (eval-when (:compile-toplevel) + (note-function-info ',name t ,env)) + #-arm-target + (progn + (eval-when (:load-toplevel) + (%defun (nfunction ,name (lambda (&lap 0) (arm-lap-function ,name ,arglist ,@body))) ,doc)) + (eval-when (:execute) + (%define-arm-lap-function ',name '((let ,arglist ,@body))))) + #+arm-target ; just shorthand for defun + (%defun (nfunction ,name (lambda (&lap 0) (arm-lap-function ,name ,arglist ,@body))) ,doc))) + + + +(provide "ARM-LAP") Index: /branches/arm/compiler/ARM/arm-lapmacros.lisp =================================================================== --- /branches/arm/compiler/ARM/arm-lapmacros.lisp (revision 13699) +++ /branches/arm/compiler/ARM/arm-lapmacros.lisp (revision 13699) @@ -0,0 +1,355 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2010 Clozure Associates +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require "ARM-LAP")) + + + + +(defarmlapmacro set-nargs (n) + (check-type n (unsigned-byte 8)) + `(mov nargs ($ (ash ,n arm::fixnumshift)))) + +(defarmlapmacro check-nargs (min &optional (max min)) + (if (eq max min) + `(progn + (cmp nargs (:$ (ash ,min arm::fixnumshift))) + (uuo-error-wrong-nargs (:? ne))) + `(trnei nargs ',min) + (if (null max) + (unless (= min 0) + `(progn + (cmp nargs (:$ (ash ,min arm::fixnumshift))) + (uuo-error-wrong-nargs (:? lo)))) + (if (= min 0) + `(progn + (cmp nargs ($ (ash ,max arm::fixnumshift))) + (uuo-error-wrong-nargs (:? hi))) + `(progn + (cmp nargs ($ (ash ,max arm::fixnumshift))) + (uuo-error-wrong-nargs (:? lo)) + (cmp nargs ($ (ash ,max arm::fixnumshift))) + (uuo-error-wrong-nargs (:? hi))))))) + + + + + +;;; This needs to be done if we aren't a leaf function (e.g., if we +;;; clobber our return address or need to reference any constants. Note +;;; that it's not atomic wrt a preemptive scheduler, but we need to +;;; pretend that it will be.) The VSP to be saved is the value of the +;;; VSP before any of this function's arguments were vpushed by its +;;; caller; that's not the same as the VSP register if any non-register +;;; arguments were received, but is usually easy to compute. + +(defarmlapmacro build-lisp-frame (&optional (marker-reg 'imm0) (vsp 'vsp)) + `(progn + (mov ,marker-reg ($ arm::lisp-frame-marker)) + (stmdb (:! sp) (,marker-reg ,vsp fn lr)))) + +(defarmlapmacro restore-lisp-frame (&optional (marker-reg 'imm0) (vsp 'vsp)) + `(ldmia (:! sp) (,marker-reg ,vsp fn lr))) + +(defarmlapmacro return-lisp-frame (&optional (marker-reg 'imm0)) + `(ldmia (:! sp) (,marker-reg vsp fn pc))) + + +(defarmlapmacro push1 (src stack) + `(str ,src (:+@! ,stack (:$ (- arm::node-size))))) + +(defarmlapmacro vpush1 (src) + `(push1 ,src vsp)) + + +(defarmlapmacro pop1 (dest stack) + `(ldr ,dest (:@+ ,stack (:% arm::node-size)))) + +(defarmlapmacro vpop1 (dest) + `(pop ,dest vsp)) + +(defarmlapmacro %cdr (dest node) + `(ldr ,dest (:@ ,node (:$ arm::cons.cdr)))) + +(defarmlapmacro %car (dest node) + `(ldr ,dest (:@ ,node (:$ arm::cons.car)))) + + + +(defarmlapmacro extract-lisptag (dest node) + `(and ,dest ,node (:$ arm::tagmask))) + +(defarmlapmacro extract-fulltag (dest node) + `(and ,dest ,node (:$ arm::fulltagmask))) + + +(defarmlapmacro extract-subtag (dest node) + `(ldrb ,dest (:@ ,node (:$ arm::misc-subtag-offset)))) + +(defarmlapmacro extract-typecode (dest node) + `(progn + (and ,dest ,node (:$ arm::tagmask)) + (cmp ,dest (:$ arm::tag-misc)) + (ldrbeq ,dest (:@ ,node (:$ arm::misc-subtag-offset))))) + +(defarmlapmacro trap-unless-fixnum (node) + `(progn + (tst node (:$ arm::tagmask)) + (uuo-error-reg-not-lisptag (:? ne) node (:$ arm::tag-fixnum)))) + + +(defarmlapmacro trap-unless-lisptag= (node tag &optional (immreg imm0)) + `(progn + (extract-lisptag ,immreg ,node) + (cmp ,immreg (:$ ,tag)) + (uuo-error-reg-not-lisptag (:? ne) ,node (:$ ,tag)))) + +(defarmlapmacro trap-unless-fulltag= (node tag &optional (immreg imm0)) + `(progn + (extract-fulltag ,immreg ,node) + (cmp ,immreg (:$ ,tag)) + (uuo-error-reg-not-fulltag (:? ne) ,node (:$ ,tag)))) + + +(defarmlapmacro trap-unless-xtype= (node tag &optional (immreg imm0)) + `(progn + (extract-typecode ,immreg ,node) + (cmp ,immreg (:$ ,tag)) + (uuo-error-reg-not-xtype (:? ne) ,node (:$ ,tag)))) + + +(defarmlapmacro load-constant (dest constant) + `(ldr ,dest (:@ fn ',constant))) + +;;; This is about as hard on the pipeline as anything I can think of. +(defarmlapmacro call-symbol (function-name) + (load-constant fname ,function-name) + (ldr nfn (:@ fname (:$ arm::symbol.fname))) + (ldr lr (:@ nfn (:$ arm::function.entrypoint))) + (blx lr)) + +(defarmlapmacro sp-call-symbol (function-name) + `(progn + (load-constant fname ,function-name) + (bla .SPjmpsym))) + +(defarmlapmacro getvheader (dest src) + `(ldr ,dest (:@ ,src (:$ arm::misc-header-offset)))) + +;;; "Size" is unboxed element-count. +(defarmlapmacro header-size (dest vheader) + `(mov ,dest (:lsr ,vheader (:$ arm::num-subtag-bits)))) + + +;;; "Length" is fixnum element-count. +(defarmlapmacro header-length (dest vheader) + `(progn + (mov ,dest (:$ (- arm::fixnumone))) + (and ,dest ,dest (:lsr ,src (:$ (- arm::num-subtag-bits arm::fixnumshift)))))) + + +(defarmlapmacro header-subtag[fixnum] (dest vheader) + `(progn + (mov ,dest (:$ (ash arm::subtag-mask arm::fixnumshift))) + (and ,dest ,dest (:lsl ,vheader (:$ arm::fixnumshift))))) + + +(defarmlapmacro vector-size (dest v vheader) + `(progn + (getvheader ,vheader ,v) + (header-size ,dest ,vheader))) + +(defarmlapmacro vector-length (dest v vheader) + `(progn + (getvheader ,vheader ,v) + (header-length ,dest ,vheader))) + + +;;; Reference a 32-bit miscobj entry at a variable index. +;;; Make the caller explicitly designate a scratch register +;;; to use for the scaled index. + +(defarmlapmacro vref32 (dest miscobj index scaled-idx) + `(progn + (add ,scaled-idex ,index (:$ arm::misc-data-offset)) + (ldr ,dest (:@ ,miscobj ,scaled-idx)))) + +;; The simple (no-memoization) case. +(defarmlapmacro vset32 (src miscobj index scaled-idx) + `(progn + (add ,scaled-idex ,index (:$ arm::misc-data-offset)) + (str ,src (:@ ,miscobj ,scaled-idx)))) + +(defarmlapmacro extract-lowbyte (dest src) + `(and ,dest ,src (:$ arm::subtag-mask))) + +(defarmlapmacro unbox-fixnum (dest src) + `(mov ,dest (:asr ,src (:$ arm::fixnumshift)))) + +(defarmlapmacro box-fixnum (dest src) + `(mov ,dest (:lsl ,src (:$ arm::fixnumshift)))) + + + +;;; If check is non-nil, type checks src +(defarmlapmacro unbox-base-char (dest src &optional check) + `(progn + ,@(if check + ((trap-unless-xtype= ,src arm::subtag-character ,dest))) + (mov ,dest ,src (:lsr arm::charcode-shift)))) + + + + +(defarmlapmacro ref-global (reg sym) + (let* ((offset (arm::%kernel-global sym))) + `(progn + (mov ,reg (:$ (- arm::nil-value arm::fulltag-nil))) + (ldr ,reg (:@ ,reg (:$ ,offset)))))) + + + + + + + + + +(defarmlapmacro cond->boolean (cc dest rx ry) + `(progn + (cmp ,rx ,ry) + (mov ,dest 'nil) + (add (:? ,cc) ,dest ,dest (:$ arm::t-offset)))) + + +(defarmlapmacro repeat (n inst) + (let* ((insts ())) + (dotimes (i n `(progn ,@(nreverse insts))) + (push inst insts)))) + +(defarmlapmacro get-single-float (dest node) + (target-arch-case + (:ppc32 + `(lfs ,dest ppc32::single-float.value ,node)) + (:ppc64 + `(progn + (std ,node ppc64::tcr.single-float-convert ppc64::rcontext) + (lfs ,dest ppc64::tcr.single-float-convert ppc64::rcontext))))) + +(defarmlapmacro get-double-float (dest node) + (target-arch-case + (:ppc32 + `(lfd ,dest ppc32::double-float.value ,node)) + (:ppc64 + `(lfd ,dest ppc64::double-float.value ,node)))) + + +(defarmlapmacro put-single-float (src node) + (target-arch-case + (:ppc32 + `(stfs ,src ppc32::single-float.value ,node)) + (:ppc64 + `(progn + (stfs ,src ppc64::tcr.single-float-convert ppc64::rcontext) + (ld ,node ppc64::tcr.single-float-convert ppc64::rcontext))))) + +(defarmlapmacro put-double-float (src node) + (target-arch-case + (:ppc32 + `(stfd ,src ppc32::double-float.value ,node)) + (:ppc64 + `(stfd ,src ppc64::double-float.value ,node)))) + +(defarmlapmacro clear-fpu-exceptions () + `(mtfsf #xfc #.ppc::fp-zero)) + + + +;;; from ppc-bignum.lisp +(defarmlapmacro digit-h (dest src) + (target-arch-case + (:ppc32 + `(rlwinm ,dest ,src (+ 16 ppc32::fixnumshift) (- 16 ppc32::fixnumshift) (- 31 ppc32::fixnumshift))) + (:ppc64 + (error "DIGIT-H on PPC64 ?")))) + +;;; from ppc-bignum.lisp +(defarmlapmacro digit-l (dest src) + (target-arch-case + (:ppc32 + `(clrlslwi ,dest ,src 16 ppc32::fixnumshift)) + (:ppc64 + (error "DIGIT-L on PPC64 ?")))) + +;;; from ppc-bignum.lisp +(defarmlapmacro compose-digit (dest high low) + (target-arch-case + (:ppc32 + `(progn + (rlwinm ,dest ,low (- ppc32::nbits-in-word ppc32::fixnumshift) 16 31) + (rlwimi ,dest ,high (- 16 ppc32::fixnumshift) 0 15))) + (:ppc64 + (error "COMPOSE-DIGIT on PPC64 ?")))) + +(defarmlapmacro macptr-ptr (dest macptr) + `(ldr ,dest (:@ ,macptr (:$ arm::macptr.address)))) + +(defarmlapmacro svref (dest index vector)) + `(ldr ,dest (:@ ,vector (:$ (+ (* 4 ,index) arm::misc-data-offset))))) + +;;; This evals its args in the wrong order. +;;; Can't imagine any code will care. +(defarmlapmacro svset (new-value index vector) + `(str ,new-value (:@ ,vector (:$ (+ (* 4 ,index) arm::misc-data-offset))))) + +(defarmlapmacro vpush-argregs () + (let* ((none (gensym)) + (two (gensym)) + (one (gensym))) + `(progn + (cmpri cr1 nargs '2) + (cmpri cr0 nargs 0) + (beq cr1 ,two) + (beq cr0 ,none) + (blt cr1 ,one) + (vpush arg_x) + ,two + (vpush arg_y) + ,one + (vpush arg_z) + ,none))) + + + + + + +;;; Set the most significant bit in DEST, clear all other bits. +(defarmlapmacro load-highbit (dest) + `(mov ,dest (:$ #x80000000))) + + +(defarmlapmacro u32-ref (dest index vector) + `(ldr ,dest (:@ ,vector (:$ (+ (* 4 ,index) arm::misc-data-offset))))) + +(defarmlapmacro u32-set (new-value index vector) + `(str ,new-value (:@ ,vector (:$ (+ (* 4 ,index) arm::misc-data-offset))))) + +(provide "ARM-LAPMACROS") + +;;; end of arm-lapmacros.lisp Index: /branches/arm/level-0/ARM/arm-clos.lisp =================================================================== --- /branches/arm/level-0/ARM/arm-clos.lisp (revision 13699) +++ /branches/arm/level-0/ARM/arm-clos.lisp (revision 13699) @@ -0,0 +1,329 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +;;; It's easier to keep this is LAP; we want to play around with its +;;; constants. + +;;; This just maps a SLOT-ID to a SLOT-DEFINITION or NIL. +;;; The map is a vector of (UNSIGNED-BYTE 8); this should +;;; be used when there are less than 255 slots in the class. +(defarmlapfunction %small-map-slot-id-lookup ((slot-id arg_z)) + (ldr temp1 'map nfn) + (svref arg_x slot-id.index slot-id) + (getvheader imm0 temp1) + (header-length imm3 imm0) + (ldr temp0 'table nfn) + (cmplr arg_x imm3) + (srri imm0 arg_x target::word-shift) + (la imm0 target::misc-data-offset imm0) + (li imm1 target::misc-data-offset) + (bge @have-scaled-table-index) + (lbzx imm1 temp1 imm0) + (slri imm1 imm1 target::word-shift) + (la imm1 target::misc-data-offset imm1) + @have-scaled-table-index + (ldrx arg_z temp0 imm1) + (blr)) + +;;; The same idea, only the map is a vector of (UNSIGNED-BYTE 32). +(defarmlapfunction %large-map-slot-id-lookup ((slot-id arg_z)) + (ldr temp1 'map nfn) + (svref arg_x slot-id.index slot-id) + (getvheader imm0 temp1) + (header-length imm3 imm0) + (ldr temp0 'table nfn) + (cmplr arg_x imm3) + #+ppc64-target + (progn + (srdi imm0 imm0 1) + (la imm0 target::misc-data-offset imm0)) + #+pp32-target + (progn + (la imm0 target::misc-data-offset arg_x)) + (li imm1 target::misc-data-offset) + (bge @have-scaled-table-index) + (lwzx imm1 temp1 imm0) + (slri imm1 imm1 target::word-shift) + (la imm1 target::misc-data-offset imm1) + @have-scaled-table-index + (ldrx arg_z temp0 imm1) + (blr)) + +(defarmlapfunction %small-slot-id-value ((instance arg_y) (slot-id arg_z)) + (ldr temp1 'map nfn) + (svref arg_x slot-id.index slot-id) + (getvheader imm0 temp1) + (ldr temp0 'table nfn) + (header-length imm3 imm0) + (cmplr arg_x imm3) + (srri imm0 arg_x target::word-shift) + (la imm0 target::misc-data-offset imm0) + (bge @missing) + (lbzx imm1 temp1 imm0) + (cmpri imm1 0) + (slri imm1 imm1 target::word-shift) + (la imm1 target::misc-data-offset imm1) + (beq @missing) + (ldrx arg_z temp0 imm1) + (ldr arg_x 'class nfn) + (ldr nfn '%maybe-std-slot-value nfn) + (ldr temp0 target::misc-data-offset nfn) + (set-nargs 3) + (mtctr temp0) + (bctr) + @missing ; (%slot-id-ref-missing instance id) + (ldr nfn '%slot-id-ref-missing nfn) + (set-nargs 2) + (ldr temp0 target::misc-data-offset nfn) + (mtctr temp0) + (bctr)) + +(defarmlapfunction %large-slot-id-value ((instance arg_y) (slot-id arg_z)) + (ldr temp1 'map nfn) + (svref arg_x slot-id.index slot-id) + (getvheader imm0 temp1) + (ldr temp0 'table nfn) + (header-length imm3 imm0) + (cmplr arg_x imm3) + #+ppc64-target + (progn + (srdi imm0 arg_x 1) + (la imm0 target::misc-data-offset imm0)) + #+ppc32-target + (progn + (la imm0 target::misc-data-offset arg_x)) + (bge @missing) + (lwzx imm1 temp1 imm0) + (cmpri imm1 0) + (slri imm1 imm1 target::word-shift) + (la imm1 target::misc-data-offset imm1) + (beq @missing) + @have-scaled-table-index + (ldr arg_x 'class nfn) + (ldr nfn '%maybe-std-slot-value-using-class nfn) + (ldrx arg_z temp0 imm1) + (ldr temp0 target::misc-data-offset nfn) + (set-nargs 3) + (mtctr temp0) + (bctr) + @missing ; (%slot-id-ref-missing instance id) + (ldr nfn '%slot-id-ref-missing nfn) + (set-nargs 2) + (ldr temp0 target::misc-data-offset nfn) + (mtctr temp0) + (bctr)) + +(defarmlapfunction %small-set-slot-id-value ((instance arg_x) + (slot-id arg_y) + (new-value arg_z)) + (ldr temp1 'map nfn) + (svref imm3 slot-id.index slot-id) + (getvheader imm0 temp1) + (ldr temp0 'table nfn) + (header-length imm5 imm0) + (cmplr imm3 imm5) + (srri imm0 imm3 target::word-shift) + (la imm0 target::misc-data-offset imm0) + (bge @missing) + (lbzx imm1 temp1 imm0) + (cmpwi imm1 0) + (slri imm1 imm1 target::word-shift) + (la imm1 target::misc-data-offset imm1) + (beq @missing) + @have-scaled-table-index + (ldr temp1 'class nfn) + (ldrx arg_y temp0 imm1) + (ldr nfn '%maybe-std-setf-slot-value-using-class nfn) + (set-nargs 4) + (ldr temp0 target::misc-data-offset nfn) + (vpush temp1) + (mtctr temp0) + (bctr) + @missing ; (%slot-id-set-missing instance id new-value) + (ldr nfn '%slot-id-set-missing nfn) + (set-nargs 3) + (ldr temp0 target::misc-data-offset nfn) + (mtctr temp0) + (bctr)) + +(defarmlapfunction %large-set-slot-id-value ((instance arg_x) + (slot-id arg_y) + (new-value arg_z)) + (ldr temp1 'map nfn) + (svref imm3 slot-id.index slot-id) + (getvheader imm0 temp1) + (ldr temp0 'table nfn) + (header-length imm5 imm0) + (cmplr imm3 imm5) + #+ppc64-target (srdi imm3 imm3 1) + (la imm0 target::misc-data-offset imm3) + (bge @missing) + (lwzx imm1 temp1 imm0) + (cmpwi imm1 0) + (slri imm1 imm1 target::word-shift) + (la imm1 target::misc-data-offset imm1) + (beq @missing) + @have-scaled-table-index + (ldr temp1 'class nfn) + (ldrx arg_y temp0 imm1) + (ldr nfn '%maybe-std-setf-slot-value-using-class nfn) + (set-nargs 4) + (svref temp0 0 nfn) + (vpush temp1) + (mtctr temp0) + (bctr) + @missing ; (%slot-id-set-missing instance id new-value) + (ldr nfn '%slot-id-ref-missing nfn) + (set-nargs 3) + (ldr temp0 target::misc-data-offset nfn) + (mtctr temp0) + (bctr)) + +#-dont-use-lexprs +(defparameter *gf-proto* + (nfunction + gag + (lambda (&lap &lexpr args) + (ppc-lap-function + gag + () + (mflr loc-pc) + (vpush-argregs) + (vpush nargs) + (add imm0 vsp nargs) + (la imm0 (ash 1 target::word-shift) imm0) ; caller's vsp + (bla .SPlexpr-entry) + (mtlr loc-pc) ; return to kernel + (mr arg_z vsp) ; lexpr + (svref arg_y gf.dispatch-table nfn) ; dispatch table + (set-nargs 2) + (svref nfn gf.dcode nfn) ; dcode function + (ldr temp0 target::misc-data-offset nfn) + (mtctr temp0) + (bctr))))) + +#+dont-use-lexprs +(defparameter *gf-proto* + (nfunction + gag + (lambda (&lap &rest args) + (ppc-lap-function + gag + () + ;;(bkpt) + (mflr loc-pc) + (bla .SPstack-rest-arg) + (vpop arg_z) + (stru sp (- target::lisp-frame.size) sp) + (str fn target::lisp-frame.savefn sp) + (str loc-pc target::lisp-frame.savelr sp) + (str vsp target::lisp-frame.savevsp sp) + (mr fn nfn) + ;; If we were called for multiple values, call the dcode + ;; for multiple values. + (ref-global imm0 ret1valaddr) + (cmpr imm0 loc-pc) + (svref arg_y gf.dispatch-table fn) ; dispatch table + (set-nargs 2) + (svref nfn gf.dcode fn) ; dcode function + (beq @multiple) + (ldr temp0 target::misc-data-offset nfn) + (mtctr temp0) + (bctrl) + (ldr tsp 0 tsp) + (restore-full-lisp-context) + (blr) + @multiple + (bl @getback) + (mflr loc-pc) + (stru sp (- target::lisp-frame.size) sp) + (str fn target::lisp-frame.savefn sp) + (str loc-pc target::lisp-frame.savelr sp) + (str vsp target::lisp-frame.savevsp sp) + (mtlr imm0) + (li fn 0) + (ldr temp0 target::misc-data-offset nfn) + (mtctr temp0) + (bctr) + @getback + (blrl) + @back + (ldr tsp 0 tsp) + (ba .SPnvalret))))) + + + +(defarmlapfunction funcallable-trampoline () + (svref nfn gf.dcode nfn) + (svref pc 0 nfn)) + +;;; This can't reference any of the function's constants. +(defarmlapfunction unset-fin-trampoline () + (mflr loc-pc) + (bla .SPheap-rest-arg) ; cons up an &rest arg, vpush it + (vpop arg_z) ; whoops, didn't really want to + (bla .SPsavecontextvsp) + (li arg_x '#.$XNOFINFUNCTION) + (mr arg_y nfn) + (set-nargs 3) + (bla .SPksignalerr) + (li arg_z nil) + (ba .SPpopj)) + +;;; is a winner - saves ~15% +(defarmlapfunction gag-one-arg ((arg arg_z)) + (check-nargs 1) + (svref arg_y gf.dispatch-table nfn) ; mention dt first + (set-nargs 2) + (svref nfn gf.dcode nfn) + (ldr temp0 target::misc-data-offset nfn) + (mtctr temp0) + (bctr)) + + +(defarmlapfunction gag-two-arg ((arg0 arg_y) (arg1 arg_z)) + (check-nargs 2) + (svref arg_x gf.dispatch-table nfn) ; mention dt first + (set-nargs 3) + (svref nfn gf.dcode nfn) + (ldr temp0 target::misc-data-offset nfn) + (mtctr temp0) + (bctr)) + +(defparameter *cm-proto* + (nfunction + gag + (lambda (&lap &lexpr args) + (ppc-lap-function + gag + () + (mflr loc-pc) + (vpush-argregs) + (vpush nargs) + (add imm0 vsp nargs) + (la imm0 target::node-size imm0) ; caller's vsp + (bla .SPlexpr-entry) + (mtlr loc-pc) ; return to kernel + (mr arg_z vsp) ; lexpr + (svref arg_y combined-method.thing nfn) ; thing + (set-nargs 2) + (svref nfn combined-method.dcode nfn) ; dcode function + (ldr temp0 target::misc-data-offset nfn) + (mtctr temp0) + (bctr))))) Index: /branches/arm/level-0/ARM/arm-misc.lisp =================================================================== --- /branches/arm/level-0/ARM/arm-misc.lisp (revision 13699) +++ /branches/arm/level-0/ARM/arm-misc.lisp (revision 13699) @@ -0,0 +1,946 @@ +;;; -*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2010 Clozure Associates +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +;;; level-0;ARM;arm-misc.lisp + + +(in-package "CCL") + +;;; Copy N bytes from pointer src, starting at byte offset src-offset, +;;; to ivector dest, starting at offset dest-offset. +;;; It's fine to leave this in lap. +;;; Depending on alignment, it might make sense to move more than +;;; a byte at a time. +;;; Does no arg checking of any kind. Really. + +(defarmlapfunction %copy-ptr-to-ivector ((src (* 1 arm::node-size) ) + (src-byte-offset 0) + (dest arg_x) + (dest-byte-offset arg_y) + (nbytes arg_z)) + (let ((src-reg imm0) + (src-byteptr temp2) + (src-node-reg temp0) + (dest-byteptr imm2) + (val imm1) + (node-temp temp1)) + (cmp nbytes (:$ 0)) + (ldr src-node-reg (:@ vsp (:$ src))) + (macptr-ptr src-reg src-node-reg) + (ldr src-byteptr (:@ vsp (:$ src-byte-offset))) + (add src-reg src-reg (:asr src-byte-ptr (:$ arm::fixnumshift))) + (unbox-fixnum dest-byteptr dest-byte-offset) + (add dest-byteptr dest-byteptr (:$ arm::misc-data-offset)) + (b @test) + @loop + (subs nbytes nbytes '1) + (ldrb val (:@+ src-reg (:$ 1))) + (strb val (:@ dest (:$ dest-byteptr))) + (add dest-byteptr dest-byteptr (:$ 1)) + @test + (bne @loop) + (mov arg_z dest) + (add vsp vsp '2) + (bx lr))) + +(defarmlapfunction %copy-ivector-to-ptr ((src (* 1 arm::node-size)) + (src-byte-offset 0) + (dest arg_x) + (dest-byte-offset arg_y) + (nbytes arg_z)) + (ldr temp0 (:@ vsp (:$ src)) + (cmp nbytes (:$ 0)) + (ldr imm0 (:@ vsp (:$ src-byte-offset)) + (unbox-fixnum imm0 imm0) + (add imm0 imm0 (:$ arm::misc-data-offset)) + (macptr-ptr imm1 dest) + (add imm1 imm1 (:asr dest-byte-offset (:$ arm::fixnumshift))) + (b @test) + @loop + (subs nbytes nbytes '1) + (ldrb imm2 (:@ temp0 imm0)) + (add imm0 imm0 (:$ 1)) + (strb imm2 (:@+ imm1 (:$ 1))) + @test + (bne cr0 @loop) + (mov arg_z dest) + (add vsp vsp '2) + (bx lr)) + +(defarmlapfunction %copy-ivector-to-ivector ((src 4) + (src-byte-offset 0) + (dest arg_x) + (dest-byte-offset arg_y) + (nbytes arg_z)) + (ldr temp0 (:@ vsp (:$ src))) + (cmp nbytes (:$ 0)) + (cmpw cr2 temp0 dest) ; source and dest same? + (rlwinm imm3 nbytes 0 (- 30 arm::fixnum-shift) 31) + (lwz imm0 src-byte-offset vsp) + (rlwinm imm1 imm0 0 (- 30 arm::fixnum-shift) 31) + (or imm3 imm3 imm1) + (unbox-fixnum imm0 imm0) + (la imm0 arm::misc-data-offset imm0) + (unbox-fixnum imm2 dest-byte-offset) + (rlwimi imm1 imm2 0 30 31) + (or imm3 imm3 imm1) + (cmpwi cr1 imm3 0) ; is everybody multiple of 4? + (la imm2 arm::misc-data-offset imm2) + (beq cr2 @SisD) ; source and dest same + @fwd + (beq :cr1 @wtest) + (b @test) + + @loop + (subi nbytes nbytes '1) + (cmpwi cr0 nbytes 0) + (lbzx imm3 temp0 imm0) + (addi imm0 imm0 1) + (stbx imm3 dest imm2) + (addi imm2 imm2 1) + @test + (bne cr0 @loop) + (mr arg_z dest) + (la vsp 8 vsp) + (bx lr) + + @words ; source and dest different - words + (subi nbytes nbytes '4) + (cmpwi cr0 nbytes 0) + (lwzx imm3 temp0 imm0) + (addi imm0 imm0 4) + (stwx imm3 dest imm2) + (addi imm2 imm2 4) + @wtest + (bgt cr0 @words) + @done + (mr arg_z dest) + (la vsp 8 vsp) + (bx lr) + + @SisD + (cmpw cr2 imm0 imm2) ; cmp src and dest + (bgt cr2 @fwd) + ;(B @bwd) + + + ; Copy backwards when src & dest are the same and we're sliding down + @bwd ; ok + (unbox-fixnum imm3 nbytes) + (add imm0 imm0 imm3) + (add imm2 imm2 imm3) + (b @test2) + @loop2 + (subi nbytes nbytes '1) + (cmpwi cr0 nbytes 0) + (subi imm0 imm0 1) + (lbzx imm3 temp0 imm0) + (subi imm2 imm2 1) + (stbx imm3 dest imm2) + @test2 + (bne cr0 @loop2) + (b @done)) + + + + +(defarmlapfunction %copy-gvector-to-gvector ((src (* 1 arm::node-size)) + (src-element 0) + (dest arg_x) + (dest-element arg_y) + (nelements arg_z)) + (subi nelements nelements '1) + (cmpri nelements 0) + (ldr imm0 src-element vsp) + (ldr temp0 src vsp) + (la vsp '2 vsp) + (cmpr cr1 temp0 dest) + (cmpri cr2 src-element dest-element) + (la imm0 arm::misc-data-offset imm0) + (la imm1 arm::misc-data-offset dest-element) + (bne cr1 @test) + ;; Maybe overlap, or maybe nothing to do. + (beq cr2 @done) ; same vectors, same offsets + (blt cr2 @back) ; copy backwards, avoid overlap + (b @test) + @loop + (subi nelements nelements '1) + (cmpri nelements 0) + (ldrx temp1 temp0 imm0) + (addi imm0 imm0 '1) + (strx temp1 dest imm1) + (addi imm1 imm1 '1) + @test + (bge @loop) + @done + (mr arg_z dest) + (bx lr) + @back + ;; We decremented NELEMENTS by 1 above. + (add imm1 nelements imm1) + (add imm0 nelements imm0) + (b @back-test) + @back-loop + (subi nelements nelements '1) + (cmpri nelements 0) + (ldrx temp1 temp0 imm0) + (subi imm0 imm0 '1) + (strx temp1 dest imm1) + (subi imm1 imm1 '1) + @back-test + (bge @back-loop) + (mr arg_z dest) + (bx lr)) + + + + + +#+ppc32-target +(defarmlapfunction %heap-bytes-allocated () + (lwz imm2 arm::tcr.last-allocptr ppc32::rcontext) + (cmpwi cr1 imm2 0) + (cmpwi allocptr -8) ;void_allocptr + (lwz imm0 arm::tcr.total-bytes-allocated-high ppc32::rcontext) + (lwz imm1 arm::tcr.total-bytes-allocated-low ppc32::rcontext) + (sub imm2 imm2 allocptr) + (beq cr1 @go) + (beq @go) + (addc imm1 imm1 imm2) + (addze imm0 imm0) + @go + (ba .SPmakeu64)) + + + + +(defarmlapfunction values () + (:arglist (&rest values)) + (vpush-argregs) + (add temp0 nargs vsp) + (ba .SPvalues)) + +;; It would be nice if (%setf-macptr macptr (ash (the fixnum value) +;; ash::fixnumshift)) would do this inline. +#+ppc-target +(defarmlapfunction %setf-macptr-to-object ((macptr arg_y) (object arg_z)) + (check-nargs 2) + (trap-unless-typecode= arg_y arm::subtag-macptr) + (str arg_z arm::macptr.address arg_y) + (bx lr)) + +(defarmlapfunction %fixnum-from-macptr ((macptr arg_z)) + (check-nargs 1) + (trap-unless-typecode= arg_z arm::subtag-macptr) + (ldr imm0 arm::macptr.address arg_z) + (trap-unless-lisptag= imm0 arm::tag-fixnum imm1) + (mr arg_z imm0) + (bx lr)) + +(defarmlapfunction %%get-unsigned-longlong ((ptr arg_y) (offset arg_z)) + (trap-unless-typecode= ptr ppc32::subtag-macptr) + (macptr-ptr imm1 ptr) + (unbox-fixnum imm2 offset) + (add imm2 imm2 imm1) + (lwz imm0 0 imm2) + (lwz imm1 4 imm2) + (ba .SPmakeu64)) + + + +(defarmlapfunction %%get-signed-longlong ((ptr arg_y) (offset arg_z)) + (trap-unless-typecode= ptr ppc32::subtag-macptr) + (macptr-ptr imm1 ptr) + (unbox-fixnum imm2 offset) + (add imm2 imm2 imm1) + (lwz imm0 0 imm2) + (lwz imm1 4 imm2) + (ba .SPmakes64)) + +#+ppc64-target +(defarmlapfunction %%get-signed-longlong ((ptr arg_y) (offset arg_z)) + (trap-unless-typecode= ptr ppc64::subtag-macptr) + (macptr-ptr imm1 ptr) + (unbox-fixnum imm2 offset) + (ldx imm0 imm2 imm1) + (ba .SPmakes64)) + +#+ppc32-target +(defarmlapfunction %%set-unsigned-longlong ((ptr arg_x) + (offset arg_y) + (val arg_z)) + (save-lisp-context) + (trap-unless-typecode= ptr ppc32::subtag-macptr) + (bla .SPgetu64) + (macptr-ptr imm2 ptr) + (unbox-fixnum imm3 offset) + (add imm2 imm3 imm2) + (stw imm0 0 imm2) + (stw imm1 4 imm2) + (ba .SPpopj)) + +#+ppc64-target +(defarmlapfunction %%set-unsigned-longlong ((ptr arg_x) + (offset arg_y) + (val arg_z)) + (save-lisp-context) + (trap-unless-typecode= ptr ppc64::subtag-macptr) + (bla .SPgetu64) + (macptr-ptr imm2 ptr) + (unbox-fixnum imm3 offset) + (stdx imm0 imm3 imm2) + (ba .SPpopj)) + +#+ppc32-target +(defarmlapfunction %%set-signed-longlong ((ptr arg_x) + (offset arg_y) + (val arg_z)) + (save-lisp-context) + (trap-unless-typecode= ptr ppc32::subtag-macptr) + (bla .SPgets64) + (macptr-ptr imm2 ptr) + (unbox-fixnum imm3 offset) + (add imm2 imm3 imm2) + (stw imm0 0 imm2) + (stw imm1 4 imm2) + (ba .SPpopj)) + +#+ppc64-target +(defarmlapfunction %%set-signed-longlong ((ptr arg_x) + (offset arg_y) + (val arg_z)) + (save-lisp-context) + (trap-unless-typecode= ptr arm::subtag-macptr) + (bla .SPgets64) + (macptr-ptr imm2 ptr) + (unbox-fixnum imm3 offset) + (stdx imm0 imm3 imm2) + (ba .SPpopj)) + +(defarmlapfunction interrupt-level () + (ldr arg_z arm::tcr.tlb-pointer arm::rcontext) + (ldr arg_z arm::interrupt-level-binding-index arg_z) + (bx lr)) + + + + +(defarmlapfunction set-interrupt-level ((new arg_z)) + (ldr imm1 arm::tcr.tlb-pointer arm::rcontext) + (trap-unless-lisptag= new arm::tag-fixnum imm0) + (str new arm::interrupt-level-binding-index imm1) + (bx lr)) + + + +(defarmlapfunction %current-tcr () + (mov arg_z rcontext) + (bx lr)) + +(defarmlapfunction %tcr-toplevel-function ((tcr arg_z)) + (check-nargs 1) + (cmpr tcr arm::rcontext) + (mr imm0 vsp) + (ldr temp0 arm::tcr.vs-area tcr) + (ldr imm1 arm::area.high temp0) + (beq @room) + (ldr imm0 arm::area.active temp0) + @room + (cmpr imm1 imm0) + (li arg_z nil) + (beqlr) + (ldr arg_z (- arm::node-size) imm1) + (bx lr)) + +(defarmlapfunction %set-tcr-toplevel-function ((tcr arg_y) (fun arg_z)) + (check-nargs 2) + (cmpr tcr arm::rcontext) + (mr imm0 vsp) + (ldr temp0 arm::tcr.vs-area tcr) + (ldr imm1 arm::area.high temp0) + (beq @check-room) + (ldr imm0 arm::area.active temp0) + @check-room + (cmpr imm1 imm0) + (push rzero imm1) + (bne @have-room) + (str imm1 arm::area.active temp0) + (str imm1 arm::tcr.save-vsp tcr) + @have-room + (str fun 0 imm1) + (bx lr)) + +;;; This needs to be done out-of-line, to handle EGC memoization. +(defarmlapfunction %store-node-conditional ((offset 0) (object arg_x) (old arg_y) (new arg_z)) + (ba .SPstore-node-conditional)) + +(defarmlapfunction %store-immediate-conditional ((offset 0) (object arg_x) (old arg_y) (new arg_z)) + (vpop temp0) + (unbox-fixnum imm0 temp0) + (let ((current temp1)) + @again + (lrarx current object imm0) + (cmpr current old) + (bne @lose) + (strcx. new object imm0) + (bne @again) + (isync) + (li arg_z (+ arm::t-offset (target-nil-value))) + (bx lr) + @lose + (li imm0 arm::reservation-discharge) + (strcx. rzero rzero imm0) + (li arg_z nil) + (bx lr))) + +(defarmlapfunction set-%gcable-macptrs% ((ptr arm::arg_z)) + (li imm0 (+ (target-nil-value) (arm::kernel-global gcable-pointers))) + @again + (lrarx arg_y rzero imm0) + (str arg_y arm::xmacptr.link ptr) + (strcx. ptr rzero imm0) + (bne @again) + (isync) + (bx lr)) + +;;; Atomically increment or decrement the gc-inhibit-count kernel-global +;;; (It's decremented if it's currently negative, incremented otherwise.) +(defarmlapfunction %lock-gc-lock () + (li imm0 (+ (target-nil-value) (arm::kernel-global gc-inhibit-count))) + @again + (lrarx arg_y rzero imm0) + (cmpri cr1 arg_y 0) + (addi arg_z arg_y '1) + (bge cr1 @store) + (subi arg_z arg_y '1) + @store + (strcx. arg_z rzero imm0) + (bne @again) +;; (isync) + (bx lr)) + +;;; Atomically decrement or increment the gc-inhibit-count kernel-global +;;; (It's incremented if it's currently negative, incremented otherwise.) +;;; If it's incremented from -1 to 0, try to GC (maybe just a little.) +(defarmlapfunction %unlock-gc-lock () +;; (sync) + (li imm0 (+ (target-nil-value) (arm::kernel-global gc-inhibit-count))) + @again + (lrarx arg_y rzero imm0) + (cmpri cr1 arg_y -1) + (subi arg_z arg_y '1) + (bgt cr1 @store) + (addi arg_z arg_y '1) + @store + (strcx. arg_z rzero imm0) + (bne @again) + (bnelr cr1) + ;; The GC tried to run while it was inhibited. Unless something else + ;; has just inhibited it, it should be possible to GC now. + (li imm0 arch::gc-trap-function-immediate-gc) + (trlgei allocptr 0) + (bx lr)) + + + +(defarmlapfunction %atomic-incf-node ((by arg_x) (node arg_y) (disp arg_z)) + (check-nargs 3) + (unbox-fixnum imm1 disp) + @again + (lrarx arg_z node imm1) + (add arg_z arg_z by) + (strcx. arg_z node imm1) + (bne- @again) + (isync) + (bx lr)) + +(defarmlapfunction %atomic-incf-ptr ((ptr arg_z)) + (macptr-ptr imm1 ptr) + @again + (lrarx imm0 0 imm1) + (addi imm0 imm0 1) + (strcx. imm0 0 imm1) + (bne @again) + (isync) + (box-fixnum arg_z imm0) + (bx lr)) + +(defarmlapfunction %atomic-incf-ptr-by ((ptr arg_y) (by arg_z)) + (macptr-ptr imm1 ptr) + (unbox-fixnum imm2 by) + @again + (lrarx imm0 0 imm1) + (add imm0 imm0 imm2) + (strcx. imm0 0 imm1) + (bne @again) + (isync) + (box-fixnum arg_z imm0) + (bx lr)) + +(defarmlapfunction %atomic-decf-ptr ((ptr arg_z)) + (macptr-ptr imm1 ptr) + @again + (lrarx imm0 0 imm1) + (subi imm0 imm0 1) + (strcx. imm0 0 imm1) + (bne @again) + (isync) + (box-fixnum arg_z imm0) + (bx lr)) + +(defarmlapfunction %atomic-decf-ptr-if-positive ((ptr arg_z)) + (macptr-ptr imm1 ptr) + @again + (lrarx imm0 0 imm1) + (cmpri cr1 imm0 0) + (subi imm0 imm0 1) + (beq @done) + (strcx. imm0 0 imm1) + (bne @again) + (isync) + (box-fixnum arg_z imm0) + (bx lr) + @done + (li imm1 arm::reservation-discharge) + (box-fixnum arg_z imm0) + (strcx. rzero rzero imm1) + (bx lr)) + +(defarmlapfunction %atomic-swap-ptr ((ptr arg_y) (newval arg_z)) + (sync) + (macptr-ptr imm1 ptr) + (unbox-fixnum imm2 arg_z) + @again + (lrarx imm0 0 imm1) + (strcx. imm2 0 imm1) + (bne @again) + (isync) + (box-fixnum arg_z imm0) + (bx lr)) + +;;; Try to store the fixnum NEWVAL at PTR, if and only if the old value +;;; was equal to OLDVAL. Return the old value +(defarmlapfunction %ptr-store-conditional ((ptr arg_x) (expected-oldval arg_y) (newval arg_z)) + (macptr-ptr imm0 ptr) + (unbox-fixnum imm1 expected-oldval) + (unbox-fixnum imm2 newval) + @again + (lrarx imm3 0 imm0) + (cmpr imm3 imm1) + (bne- @done) + (strcx. imm2 0 imm0) + (bne- @again) + (isync) + (box-fixnum arg_z imm3) + (bx lr) + @done + (li imm0 arm::reservation-discharge) + (box-fixnum arg_z imm3) + (strcx. rzero 0 imm0) + (bx lr)) + +(defarmlapfunction %ptr-store-fixnum-conditional ((ptr arg_x) (expected-oldval arg_y) (newval arg_z)) + (let ((address imm0) + (actual-oldval imm1)) + (macptr-ptr address ptr) + @again + (lrarx actual-oldval 0 address) + (cmpr actual-oldval expected-oldval) + (bne- @done) + (strcx. newval 0 address) + (bne- @again) + (isync) + (mr arg_z actual-oldval) + (bx lr) + @done + (li address arm::reservation-discharge) + (mr arg_z actual-oldval) + (strcx. rzero 0 address) + (bx lr))) + + + + +(defarmlapfunction %macptr->dead-macptr ((macptr arg_z)) + (check-nargs 1) + (li imm0 arm::subtag-dead-macptr) + (stb imm0 arm::misc-subtag-offset macptr) + (bx lr)) + +(defarmlapfunction %%apply-in-frame ((catch-count imm0) (srv temp0) (tsp-count imm0) (db-link imm0) + (parent arg_x) (function arg_y) (arglist arg_z)) + (check-nargs 7) + + ; Throw through catch-count catch frames + (lwz imm0 12 vsp) ; catch-count + (vpush parent) + (vpush function) + (vpush arglist) + (bla .SPnthrowvalues) + + ; Pop tsp-count TSP frames + (lwz tsp-count 16 vsp) + (cmpi cr0 tsp-count 0) + (b @test) +@loop + (subi tsp-count tsp-count '1) + (cmpi cr0 tsp-count 0) + (lwz tsp 0 tsp) +@test + (bne cr0 @loop) + + ; Pop dynamic bindings until we get to db-link + (lwz imm0 12 vsp) ; db-link + (lwz imm1 arm::tcr.db-link arm::rcontext) + (cmp cr0 imm0 imm1) + (beq cr0 @restore-regs) ; .SPunbind-to expects there to be something to do + (bla .SPunbind-to) + +@restore-regs + ; restore the saved registers from srv + (lwz srv 20 vsp) +@get0 + (svref imm0 1 srv) + (cmpwi cr0 imm0 (target-nil-value)) + (beq @get1) + (lwz save0 0 imm0) +@get1 + (svref imm0 2 srv) + (cmpwi cr0 imm0 (target-nil-value)) + (beq @get2) + (lwz save1 0 imm0) +@get2 + (svref imm0 3 srv) + (cmpwi cr0 imm0 (target-nil-value)) + (beq @get3) + (lwz save2 0 imm0) +@get3 + (svref imm0 4 srv) + (cmpwi cr0 imm0 (target-nil-value)) + (beq @get4) + (lwz save3 0 imm0) +@get4 + (svref imm0 5 srv) + (cmpwi cr0 imm0 (target-nil-value)) + (beq @get5) + (lwz save4 0 imm0) +@get5 + (svref imm0 6 srv) + (cmpwi cr0 imm0 (target-nil-value)) + (beq @get6) + (lwz save5 0 imm0) +@get6 + (svref imm0 7 srv) + (cmpwi cr0 imm0 (target-nil-value)) + (beq @get7) + (lwz save6 0 imm0) +@get7 + (svref imm0 8 srv) + (cmpwi cr0 imm0 (target-nil-value)) + (beq @got) + (lwz save7 0 imm0) +@got + + (vpop arg_z) ; arglist + (vpop temp0) ; function + (vpop parent) ; parent + (extract-lisptag imm0 parent) + (cmpi cr0 imm0 arm::tag-fixnum) + (if (:cr0 :ne) + ; Parent is a fake-stack-frame. Make it real + (progn + (svref sp %fake-stack-frame.sp parent) + (stwu sp (- arm::lisp-frame.size) sp) + (svref fn %fake-stack-frame.fn parent) + (stw fn arm::lisp-frame.savefn sp) + (svref temp1 %fake-stack-frame.vsp parent) + (stw temp1 arm::lisp-frame.savevsp sp) + (svref temp1 %fake-stack-frame.lr parent) + (extract-lisptag imm0 temp1) + (cmpi cr0 imm0 arm::tag-fixnum) + (if (:cr0 :ne) + ;; must be a macptr encoding the actual link register + (macptr-ptr loc-pc temp1) + ;; Fixnum is offset from start of function vector + (progn + (svref temp2 0 fn) ; function vector + (unbox-fixnum temp1 temp1) + (add loc-pc temp2 temp1))) + (stw loc-pc arm::lisp-frame.savelr sp)) + ;; Parent is a real stack frame + (mr sp parent)) + (set-nargs 0) + (bla .SPspreadargz) + (ba .SPtfuncallgen)) + +#+ppc32-target +;;; Easiest to do this in lap, to avoid consing bignums and/or +;;; multiple-value hair. +;;; Bang through code-vector until the end or a 0 (traceback table +;;; header) is found. Return high-half, low-half of last instruction +;;; and index where found. +(defarmlapfunction %code-vector-last-instruction ((cv arg_z)) + (let ((previ imm0) + (nexti imm1) + (idx imm2) + (offset imm3) + (len imm4)) + (vector-length len cv len) + (li idx 0) + (cmpw cr0 idx len) + (li offset arm::misc-data-offset) + (li nexti 0) + (b @test) + @loop + (mr previ nexti) + (lwzx nexti cv offset) + (cmpwi cr1 nexti 0) + (addi idx idx '1) + (cmpw cr0 idx len) + (addi offset offset '1) + (beq cr1 @done) + @test + (bne cr0 @loop) + (mr previ nexti) + @done + (digit-h temp0 previ) + (digit-l temp1 previ) + (subi idx idx '1) + (vpush temp0) + (vpush temp1) + (vpush idx) + (set-nargs 3) + (la temp0 '3 vsp) + (ba .SPvalues))) + +#+ppc64-target +(defun %code-vector-last-instruction (cv) + (do* ((i 1 (1+ i)) + (instr nil) + (n (uvsize cv))) + ((= i n) instr) + (declare (fixnum i n)) + (let* ((next (uvref cv i))) + (declare (type (unsigned-byte 32) next)) + (if (zerop next) + (return instr) + (setq instr next))))) + + + + +(defarmlapfunction %%save-application ((flags arg_y) (fd arg_z)) + (unbox-fixnum imm0 flags) + (ori imm0 imm0 arch::gc-trap-function-save-application) + (unbox-fixnum imm1 fd) + (trlgei allocptr 0) + (bx lr)) + + + +(defarmlapfunction %misc-address-fixnum ((misc-object arg_z)) + (check-nargs 1) + (la arg_z arm::misc-data-offset misc-object) + (bx lr)) + + +(defarmlapfunction fudge-heap-pointer ((ptr arg_x) (subtype arg_y) (len arg_z)) + (check-nargs 3) + (macptr-ptr imm1 ptr) ; address in macptr + (addi imm0 imm1 9) ; 2 for delta + 7 for alignment + (clrrwi imm0 imm0 3) ; Clear low three bits to align + (subf imm1 imm1 imm0) ; imm1 = delta + (sth imm1 -2 imm0) ; save delta halfword + (unbox-fixnum imm1 subtype) ; subtype at low end of imm1 + (rlwimi imm1 len (- arm::num-subtag-bits arm::fixnum-shift) 0 (- 31 arm::num-subtag-bits)) + (stw imm1 0 imm0) ; store subtype & length + (addi arg_z imm0 arm::fulltag-misc) ; tag it, return it + (bx lr)) + + + +(defarmlapfunction %%make-disposable ((ptr arg_y) (vector arg_z)) + (check-nargs 2) + (subi imm0 vector arm::fulltag-misc) ; imm0 is addr = vect less tag + (lhz imm1 -2 imm0) ; get delta + (sub imm0 imm0 imm1) ; vector addr (less tag) - delta is orig addr + (str imm0 arm::macptr.address ptr) + (bx lr)) + +#+arm-target +(defarmlapfunction %vect-data-to-macptr ((vect arg_y) (ptr arg_z)) + ;; put address of vect data in macptr. For all vector types + ;; other than DOUBLE-FLOAT (or vectors thereof), the first byte + ;; of data is at PPC32::MISC-DATA-OFFSET; for the double-float + ;; types, it's at PPC32::MISC-DFLOAT-OFFSET. + (extract-subtag imm0 vect) + (cmpwi cr0 imm0 ppc32::subtag-double-float-vector) + (cmpwi cr1 imm0 ppc32::subtag-double-float) + (addi temp0 vect ppc32::misc-data-offset) + (beq cr0 @dfloat) + (beq cr1 @dfloat) + (stw temp0 ppc32::macptr.address arg_z) + (bx lr) + @dfloat + (addi temp0 vect ppc32::misc-dfloat-offset) + (stw temp0 ppc32::macptr.address arg_z) + (bx lr)) + + + + + + +(defarmlapfunction %current-db-link () + (ldr arg_z arm::tcr.db-link arm::rcontext) + (bx lr)) + +(defarmlapfunction %no-thread-local-binding-marker () + (li arg_z arm::subtag-no-thread-local-binding) + (bx lr)) + + + + + +;;; Should be called with interrupts disabled. +(defarmlapfunction %safe-get-ptr ((src arg_y) (dest arg_z)) + (check-nargs 2) + (macptr-ptr imm0 src) + (str imm0 arm::tcr.safe-ref-address arm::rcontext) + (ldr imm0 0 imm0) ; may fault + (str imm0 arm::macptr.address dest) + (bx lr)) + + + +;;; r13 contains thread context on Linux/Darwin PPC64. +;;; That's maintained in r2 on LinuxPPC32, and not maintained +;;; in a GPR on DarwinPPC32 +(defarmlapfunction %get-os-context () + #+ppc64-target (mr arg_z 13) + #+linuxppc32-target (mr arg_z 2) + #+darinppc32-target (mr arg_z 0) + (bx lr)) + +(defarmlapfunction %check-deferred-gc () + (ldr imm0 arm::tcr.flags arm::rcontext) + (slri. imm0 imm0 (- (1- arm::nbits-in-word) (+ arch::tcr-flag-bit-pending-suspend arm::fixnumshift))) + (li arg_z nil) + (bgelr) + (uuo_interr arch::error-propagate-suspend rzero) + (li arg_z t) + (bx lr)) + +(defarmlapfunction %%tcr-interrupt ((target arg_z)) + (check-nargs 1) + (uuo_interr arch::error-interrupt rzero) + (box-fixnum arg_z imm0) + (bx lr)) + +(defarmlapfunction %suspend-tcr ((target arg_z)) + (check-nargs 1) + (uuo_interr arch::error-suspend rzero) + (ne0->boolean arg_z imm0 imm1) + (bx lr)) + +(defarmlapfunction %suspend-other-threads () + (check-nargs 0) + (uuo_interr arch::error-suspend-all rzero) + (li arg_z nil) + (bx lr)) + +(defarmlapfunction %resume-tcr ((target arg_z)) + (check-nargs 1) + (uuo_interr arch::error-resume rzero) + (ne0->boolean arg_z imm0 imm1) + (bx lr)) + +(defarmlapfunction %resume-other-threads () + (check-nargs 0) + (uuo_interr arch::error-resume-all rzero) + (li arg_z nil) + (bx lr)) + +(defarmlapfunction %kill-tcr ((target arg_z)) + (check-nargs 1) + (uuo_interr arch::error-kill rzero) + (ne0->boolean arg_z imm0 imm1) + (bx lr)) + +(defarmlapfunction %atomic-pop-static-cons () + (li imm0 (+ (target-nil-value) (arm::kernel-global static-conses))) + @again + (lrarx arg_z rzero imm0) + (cmpri arg_z (target-nil-value)) + (beq @lose) + (%cdr arg_y arg_z) + (strcx. arg_y rzero imm0) + (bne @again) + (li imm0 (+ (target-nil-value) (arm::kernel-global free-static-conses))) + @decf + (lrarx imm1 rzero imm0) + (subi imm1 imm1 '1) + (strcx. imm1 rzero imm0) + (bne @decf) + (isync) + (bx lr) + @lose + (li imm0 arm::reservation-discharge) + (strcx. rzero rzero imm0) + (bx lr)) + + + +(defarmlapfunction %staticp ((x arg_z)) + (check-nargs 1) + (ref-global temp0 static-cons-area) + (ldr imm1 arm::area.low temp0) + (sub imm0 x imm1) + (ldr imm1 arm::area.ndnodes temp0) + (srri imm0 imm0 arm::dnode-shift) + (li arg_z nil) + (sub imm1 imm1 imm0) + (cmplri imm1 0) + (la imm1 128 imm1) + (blelr) + (box-fixnum arg_z imm1) + (bx lr)) + +(defarmlapfunction %static-inverse-cons ((n arg_z)) + (check-nargs 1) + (extract-lisptag imm0 arg_z) + (cmpri imm0 0) + (ref-global temp0 static-cons-area) + (bne @fail) + (la n '-128 n) + (ldr imm0 arm::area.ndnodes temp0) + (ldr imm1 arm::area.high temp0) + (box-fixnum arg_y imm0) + (sub imm1 imm1 n) + (cmplr arg_z arg_y) + (sub imm1 imm1 n) + (bgt @fail) + (la arg_z arm::fulltag-cons imm1) + (ldr arg_y arm::cons.car arg_z) + (cmpri arg_y arm::unbound-marker) + (bnelr) + @fail + (li arg_z nil) + (bx lr)) + + +; end of arm-misc.lisp