Index: /branches/arm/level-0/ARM/arm-def.lisp =================================================================== --- /branches/arm/level-0/ARM/arm-def.lisp (revision 13706) +++ /branches/arm/level-0/ARM/arm-def.lisp (revision 13706) @@ -0,0 +1,1209 @@ +;;; -*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2009 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") + +;;; Do an FF-CALL to MakeDataExecutable so that the data cache gets flushed. +;;; If the GC moves this function while we're trying to flush the cache, +;;; it'll flush the cache: no harm done in that case. +#+notyet ;though we need to on ARM. +(defppclapfunction %make-code-executable ((codev arg_z)) + (let ((len imm2) + (word-offset imm0)) + (save-lisp-context) + (getvheader word-offset codev) + (header-size len word-offset) + ;; The idea is that if we GC here, no harm is done (since the GC + ;; will do any necessary cache-flushing.) The idea may be + ;; incorrect: if we pass an address that's not mapped anymore, + ;; could we fault ? + (stru sp (- (+ #+eabi-target ppc32::eabi-c-frame.minsize + #+poweropen-target target::c-frame.minsize target::lisp-frame.size)) sp) ; make an FFI frame. + (la imm0 target::misc-data-offset codev) + (slri len len 2) + (str imm0 #+eabi-target ppc32::eabi-c-frame.param0 #+poweropen-target target::c-frame.param0 sp) + (str len #+eabi-target ppc32::eabi-c-frame.param1 #+poweropen-target target::c-frame.param1 sp) + (ref-global imm3 kernel-imports) + (ldr arg_z target::kernel-import-MakeDataExecutable imm3) + (bla #+eabi-target .SPeabi-ff-call #+poweropen-target .SPpoweropen-ffcall) + (li arg_z nil) + (restore-full-lisp-context) + (blr))) + +(defarmlapfunction %get-kernel-global-from-offset ((offset arg_z)) + (check-nargs 1) + (mov imm0 (:$ (- arm::nil-value arm::fulltag-nil))) + (ldr arg_z (:-@ imm0 (:asr offset (:$ arm::fixnumshift)))) + (bx lr)) + + +(defarmlapfunction %set-kernel-global-from-offset ((offset arg_y) (new-value arg_z)) + (check-nargs 2) + (mov imm0 (:$ (- arm::nil-value arm::fulltag-nil))) + (ldr new-value (:-@ imm0 (:asr offset (:$ arm::fixnumshift)))) + (bx lr)) + + + +(defarmlapfunction %get-kernel-global-ptr-from-offset ((offset arg_y) + (ptr arg_z)) + (check-nargs 2) + (mov imm0 (:$ (- arm::nil-value arm::fulltag-nil))) + (ldr imm0 (:-@ imm0 (:asr offset (:$ arm::fixnumshift)))) + (str imm0 (:@ ptr (:$ target::macptr.address))) + (bx lr)) + + + + +(defarmlapfunction %fixnum-ref ((fixnum arg_y) #| &optional |# (offset arg_z)) + (check-nargs 1 2) + (cmp nargs '1) + (moveq fixnum offset) + (moveq offset (:$ 0)) + @2-args + (unbox-fixnum imm0 offset) + (ldr arg_z (:@ imm0 fixnum)) + (bx lr)) + + +(defarmlapfunction %fixnum-ref-natural ((fixnum arg_y) #| &optional |# (offset arg_z)) + (check-nargs 1 2) + (cmp nargs '1) + (moveq fixnum offset) + (moveq offset (:$ 0)) + (unbox-fixnum imm0 offset) + (ldr imm0 (:@ imm0 fixnum)) + (ba .SPmakeu32)) + + + +(defarmlapfunction %fixnum-set ((fixnum arg_x) (offset arg_y) #| &optional |# (new-value arg_z)) + (check-nargs 2 3) + (cmp nargs '2) + (moveq fixnum offset) + (moveq offset (:$ 0)) + (unbox-fixnum imm0 offset) + (str new-value (:@ imm0 fixnum)) + (mov arg_z new-value) + (bx lr)) + +(defarmlapfunction %fixnum-set-natural ((fixnum arg_x) (offset arg_y) #| &optional |# (new-value arg_z)) + (check-nargs 2 3) + (cmp nargs '2) + (moveq fixnum offset) + (moveq offset (:$ 0)) + (unbox-fixnum imm0 offset) + (test-fixnum new-value) + (unbox-fixnum imm2 new-value) + (beq @store) + (extract-subtag imm1 new-value) + (cmp imm1 (:$ arm::subtag-bignum)) + (uuo-error-reg-not-xtype (:? ne) new-value (:$ arm::xtype-u32)) + (getvheader imm0 new-value) + (header-length temp0 imm0) + (cmp temp0 '2) + (ldr imm2 (:@ new-value (:$ arm::misc-data-offset))) + (ldreq imm1 (:@ new-value (:$ (+ arm::misc-data-offset)))) + (uuo-error-reg-not-xtype (:? gt) new-value (:$ arm::xtype-u32)) + (bne @one) + (cmp imm1 ($ 0)) + (beq @store) + (uuo-error-reg-not-xtype (:? ne) new-value (:$ arm::xtype-u32)) + @one + (cmp imm2 ($ 0)) + (uuo-error-reg-not-xtype (:? mi) new-value (:$ arm::xtype-u32)) + @store + (str imm2 (:@ imm0 fixnum)) + (mov arg_z new-value) + (bx lr)) + + + +(defarmlapfunction %current-frame-ptr () + (check-nargs 0) + (mov arg_z sp) + (bx lr)) + +(defarmlapfunction %current-vsp () + (check-nargs 0) + (mov arg_z vsp) + (bx lr)) + + + + +(defarmlapfunction %set-current-vsp ((new-vsp arg_z)) + (check-nargs 1) + (mov vsp new-vsp) + (bx lr)) + + + +(defarmlapfunction %%frame-backlink ((p arg_z)) + (check-nargs 1) + (ldr arg_z target::lisp-frame.backlink arg_z) + (bx lr)) + + + + + +(defarmlapfunction %%frame-savefn ((p arg_z)) + (check-nargs 1) + (ldr arg_z target::lisp-frame.savefn arg_z) + (bx lr)) + +(defarmlapfunction %cfp-lfun ((p arg_z)) + (ldr arg_y target::lisp-frame.savefn p) + (extract-typecode imm0 arg_y) + (cmpri imm0 target::subtag-function) + (ldr loc-pc target::lisp-frame.savelr p) + (bne @no) + (ldr arg_x target::misc-data-offset arg_y) + (sub imm1 loc-pc arg_x) + (la imm1 (- target::misc-data-offset) imm1) + (getvheader imm0 arg_x) + (header-length imm0 imm0) + (cmplr imm1 imm0) + (box-fixnum imm1 imm1) + (bge @no) + (vpush arg_y) + (vpush imm1) + @go + (set-nargs 2) + (la temp0 '2 vsp) + (ba .SPvalues) + @no + (li imm0 nil) + (vpush imm0) + (vpush imm0) + (b @go)) + + + + +(defarmlapfunction %%frame-savevsp ((p arg_z)) + (check-nargs 1) + (ldr arg_z target::lisp-frame.savevsp arg_z) + (bx lr)) + + + + + +#+ppc32-target +(eval-when (:compile-toplevel :execute) + (assert (eql ppc32::t-offset #x11))) + +(defarmlapfunction %uvector-data-fixnum ((uv arg_z)) + (check-nargs 1) + (trap-unless-fulltag= arg_z target::fulltag-misc) + (la arg_z target::misc-data-offset arg_z) + (bx lr)) + +(defarmlapfunction %catch-top ((tcr arg_z)) + (check-nargs 1) + (ldr arg_z target::tcr.catch-top tcr) + (cmpri cr0 arg_z 0) + (bne @ret) + (li arg_z nil) + @ret + (bx lr)) + +(defarmlapfunction %catch-tsp ((catch arg_z)) + (check-nargs 1) + (la arg_z (- (+ target::fulltag-misc + (ash 1 (1+ target::word-shift)))) arg_z) + (bx lr)) + + + +;;; Same as %address-of, but doesn't cons any bignums +;;; It also left shift fixnums just like everything else. +(defarmlapfunction %fixnum-address-of ((x arg_z)) + (check-nargs 1) + (box-fixnum arg_z x) + (bx lr)) + + + +(defarmlapfunction %save-standard-binding-list ((bindings arg_z)) + (ldr imm0 target::tcr.vs-area target::rcontext) + (ldr imm1 target::area.high imm0) + (push bindings imm1) + (bx lr)) + +(defarmlapfunction %saved-bindings-address () + (ldr imm0 target::tcr.vs-area target::rcontext) + (ldr imm1 target::area.high imm0) + (la arg_z (- target::node-size) imm1) + (bx lr)) + +(defarmlapfunction %code-vector-pc ((code-vector arg_y) (pcptr arg_z)) + (macptr-ptr imm0 pcptr) + (ldr loc-pc 0 imm0) + (sub imm0 loc-pc code-vector) + (subi imm0 imm0 target::misc-data-offset) + (getvheader imm1 code-vector) + (header-size imm1 imm1) + (slri imm1 imm1 2) + (cmplr imm0 imm1) + (li arg_z nil) + (bgelr) + (box-fixnum arg_z imm0) + (bx lr)) + +;;; FF-call, in LAP. +#+eabi-target +(progn + (defarmlapfunction %%ff-call ((fploads 8) + (single-offset 4) + (double-offset 0) + (framesize arg_x) ;always even, negative, includes frame overhead + (buf arg_y) + (entry arg_z)) + (check-nargs 6) + (la imm0 12 vsp) + (save-lisp-context imm0) + (stwux sp sp framesize) + (stw sp 4 sp) + (macptr-ptr imm2 buf) + (mov imm1 imm2) + (la imm3 ppc32::eabi-c-frame.param0 sp) + (li imm0 0) + (lwz temp1 single-offset vsp) + (lwz temp2 double-offset vsp) + @copy + (addi imm0 imm0 8) + (cmpw imm0 temp1) + (lfd fp0 0 imm2) + (la imm2 8 imm2) + (stfd fp0 0 imm3) + (la imm3 8 imm3) + (blt @copy) + ;; We've copied the gpr-save area and the "other" arg words. + ;; Sadly, we may still need to load up to 8 FPRs, and we have + ;; to use some pretty ugly code to do so. + (add temp1 temp1 imm1) + (add temp2 temp2 imm1) + (lwz temp0 fploads vsp) + @load-fp1 + (lbz imm0 (+ ppc32::misc-data-offset 0) temp0) + (cmpwi imm0 1) + (blt @loaded) + (bne @load-fp1-double) + (lfs fp1 0 temp1) + (la temp1 4 temp1) + (b @load-fp2) + @load-fp1-double + (lfd fp1 0 temp2) + (la temp2 8 temp2) + @load-fp2 + (lbz imm0 (+ ppc32::misc-data-offset 1) temp0) + (cmpwi imm0 1) + (blt @loaded) + (bne @load-fp2-double) + (lfs fp2 0 temp1) + (la temp1 4 temp1) + (b @load-fp3) + @load-fp2-double + (lfd fp2 0 temp2) + (la temp2 8 temp2) + @load-fp3 + (lbz imm0 (+ ppc32::misc-data-offset 2) temp0) + (cmpwi imm0 1) + (blt @loaded) + (bne @load-fp3-double) + (lfs fp3 0 temp1) + (la temp1 4 temp1) + (b @load-fp4) + @load-fp3-double + (lfd fp3 0 temp2) + (la temp2 8 temp2) + @load-fp4 + (lbz imm0 (+ ppc32::misc-data-offset 3) temp0) + (cmpwi imm0 1) + (blt @loaded) + (bne @load-fp4-double) + (lfs fp4 0 temp1) + (la temp1 4 temp1) + (b @load-fp5) + @load-fp4-double + (lfd fp4 0 temp2) + (la temp2 8 temp2) + @load-fp5 + (lbz imm0 (+ ppc32::misc-data-offset 4) temp0) + (cmpwi imm0 1) + (blt @loaded) + (bne @load-fp5-double) + (lfs fp5 0 temp1) + (la temp1 4 temp1) + (b @load-fp6) + @load-fp5-double + (lfd fp5 0 temp2) + (la temp2 8 temp2) + @load-fp6 + (lbz imm0 (+ ppc32::misc-data-offset 5) temp0) + (cmpwi imm0 1) + (blt @loaded) + (bne @load-fp6-double) + (lfs fp6 0 temp1) + (la temp1 4 temp1) + (b @load-fp7) + @load-fp6-double + (lfd fp6 0 temp2) + (la temp2 8 temp2) + @load-fp7 + (lbz imm0 (+ ppc32::misc-data-offset 6) temp0) + (cmpwi imm0 1) + (blt @loaded) + (bne @load-fp7-double) + (lfs fp7 0 temp1) + (la temp1 4 temp1) + (b @load-fp8) + @load-fp7-double + (lfd fp7 0 temp2) + (la temp2 8 temp2) + @load-fp8 + (lbz imm0 (+ ppc32::misc-data-offset 0) temp0) + (cmpwi imm0 1) + (blt @loaded) + (bne @load-fp8-double) + (lfs fp8 0 temp1) + (b @loaded) + @load-fp8-double + (lfd fp8 0 temp2) + @loaded + (vpush buf) + (bla .SPeabi-ff-call) + (vpop buf) + (macptr-ptr imm2 buf) + (stw imm0 0 imm2) + (stw imm1 4 imm2) + (stfs fp1 8 imm2) + (stfd fp1 16 imm2) + (restore-full-lisp-context) + (li arg_z (target-nil-value)) + (bx lr)) + + (defun %ff-call (entry &rest specs-and-vals) + "Call the foreign function at address entrypoint passing the values of +each arg as a foreign argument of type indicated by the corresponding +arg-type-keyword. Returns the foreign function result (coerced to a Lisp +object of type indicated by result-type-keyword), or NIL if +result-type-keyword is :VOID or NIL" + (declare (dynamic-extent specs-and-vals)) + (let* ((len (length specs-and-vals)) + (other-offset 8) + (single-float-offset 8) + (double-float-offset 0) + (nsingle-floats 0) + (ndouble-floats 0) + (nother-words 0) + (nfpr-args 0) + (ngpr-args 0)) + (declare (fixnum len other-offset single-float-offset double-float-offset + nsingle-floats ndouble-floats nother-words nfpr-args ngpr-args)) + (unless (oddp len) + (error "Length of ~s is even. Missing result ?" specs-and-vals)) + + (let* ((result-spec (or (car (last specs-and-vals)) :void)) + (nargs (ash (the fixnum (1- len)) -1)) + (fpr-reloads (make-array 8 :element-type '(unsigned-byte 8)))) + (declare (fixnum nargs) (dynamic-extent fpr-reloads)) + (do* ((i 0 (1+ i)) + (specs specs-and-vals (cddr specs)) + (spec (car specs) (car specs))) + ((= i nargs)) + (declare (fixnum i)) + (ecase spec + (:double-float (incf nfpr-args) + (if (<= nfpr-args 8) + (incf ndouble-floats) + (progn + (if (oddp nother-words) + (incf nother-words)) + (incf nother-words 2)))) + (:single-float (incf nfpr-args) + (if (<= nfpr-args 8) + (incf nsingle-floats) + (incf nother-words))) + ((:signed-doubleword :unsigned-doubleword) + (if (oddp ngpr-args) + (incf ngpr-args)) + (incf ngpr-args 2) + (when (> ngpr-args 8) + (if (oddp nother-words) + (incf nother-words)) + (incf nother-words 2))) + ((:signed-byte :unsigned-byte :signed-halfword :unsigned-halfword + :signed-fullword :unsigned-fullword :address) + (incf ngpr-args) + (if (> ngpr-args 8) + (incf nother-words))))) + (let* ((single-words (+ 8 nother-words nsingle-floats)) + (total-words (if (zerop ndouble-floats) + single-words + (+ (the fixnum (+ ndouble-floats ndouble-floats)) + (the fixnum (logand (lognot 1) + (the fixnum (1+ single-words)))))))) + (declare (fixnum total-words single-words)) + (%stack-block + ((buf (ash total-words 2))) + (setq single-float-offset (+ other-offset nother-words)) + (setq double-float-offset + (logand (lognot 1) + (the fixnum (1+ (the fixnum (+ single-float-offset nsingle-floats)))))) + ;;; Make another pass through the arg/value pairs, evaluating each arg into + ;;; the buffer. + (do* ((i 0 (1+ i)) + (specs specs-and-vals (cddr specs)) + (spec (car specs) (car specs)) + (val (cadr specs) (cadr specs)) + (ngpr 0) + (nfpr 0) + (gpr-byte-offset 0) + (other-byte-offset (ash other-offset 2)) + (single-byte-offset (ash single-float-offset 2)) + (double-byte-offset (ash double-float-offset 2))) + ((= i nargs)) + (declare (fixnum i gpr-byte-offset single-byte-offset double-byte-offset + ngpr nfpr)) + (case spec + (:double-float + (cond ((< nfpr 8) + (setf (uvref fpr-reloads nfpr) 2 + (%get-double-float buf double-byte-offset) val + double-byte-offset (+ double-byte-offset 8))) + (t + (setq other-byte-offset (logand (lognot 7) + (the fixnum (+ other-byte-offset 4)))) + (setf (%get-double-float buf other-byte-offset) val) + (setq other-byte-offset (+ other-byte-offset 8)))) + (incf nfpr)) + (:single-float + (cond ((< nfpr 8) + (setf (uvref fpr-reloads nfpr) 1 + (%get-single-float buf single-byte-offset) val + single-byte-offset (+ single-byte-offset 4))) + + (t + (setf (%get-single-float buf other-byte-offset) val + other-byte-offset (+ other-byte-offset 4)))) + (incf nfpr)) + (:address + (cond ((< ngpr 8) + (setf (%get-ptr buf gpr-byte-offset) val + gpr-byte-offset (+ gpr-byte-offset 4))) + (t + (setf (%get-ptr buf other-byte-offset) val + other-byte-offset (+ other-byte-offset 4)))) + (incf ngpr)) + ((:signed-doubleword :unsigned-doubleword) + (when (oddp ngpr) + (incf ngpr) + (incf gpr-byte-offset 4)) + (cond ((< ngpr 8) + (if (eq spec :signed-doubleword) + (setf (%get-signed-long-long buf gpr-byte-offset) val) + (setf (%get-unsigned-long-long buf gpr-byte-offset) val)) + (incf gpr-byte-offset 8)) + (t + (when (logtest other-byte-offset 7) + (incf other-byte-offset 4)) + (if (eq spec :signed-doubleword) + (setf (%get-signed-long-long buf other-byte-offset) val) + (setf (%get-unsigned-long-long buf other-byte-offset) val)) + (incf other-byte-offset 8))) + (incf ngpr 2)) + ((:unsigned-byte :unsigned-halfword :unsigned-fullword) + (cond ((< ngpr 8) + (setf (%get-unsigned-long buf gpr-byte-offset) val + gpr-byte-offset (+ gpr-byte-offset 4))) + (t + (setf (%get-unsigned-long buf other-byte-offset) val + other-byte-offset (+ other-byte-offset 4)))) + (incf ngpr)) + (t + (cond ((< ngpr 8) + (setf (%get-long buf gpr-byte-offset) val + gpr-byte-offset (+ gpr-byte-offset 4))) + (t + (setf (%get-long buf other-byte-offset) val + other-byte-offset (+ other-byte-offset 4)))) + (incf ngpr)))) + (%%ff-call fpr-reloads + single-float-offset + double-float-offset + (the fixnum (- + (ash (the fixnum + (+ 6 + (the fixnum (logand + (lognot 1) + (the fixnum (1+ total-words)))))) + 2))) + buf + entry) + (ecase result-spec + (:void nil) + (:single-float (%get-single-float buf 8)) + (:double-float (%get-double-float buf 16)) + (:address (%get-ptr buf)) + (:signed-doubleword (%get-signed-long-long buf 0)) + (:unsigned-doubleword (%get-unsigned-long-long buf 0)) + (:signed-fullword (%get-signed-long buf)) + (:unsigned-fullword (%get-unsigned-long buf)) + (:signed-halfword (%get-signed-word buf 2)) + (:unsigned-halfword (%get-unsigned-word buf 2)) + (:signed-byte (%get-signed-byte buf 3)) + (:unsigned-byte (%get-unsigned-byte buf 3)))))))) + ) + + + + + +;;; In the PowerOpen ABI, all arguments are passed in a contiguous +;;; block. The first 13 (!) FP args are passed in FP regs; doubleword +;;; arguments are aligned on word boundaries. +#+poweropen-target +(progn + #+ppc32-target + (progn + (defun %ff-call (entry &rest specs-and-vals) + (declare (dynamic-extent specs-and-vals)) + (let* ((len (length specs-and-vals)) + (total-words 0)) + (declare (fixnum len total-words)) + (unless (oddp len) + (error "Length of ~s is even. Missing result ?" specs-and-vals)) + (let* ((result-spec (or (car (last specs-and-vals)) :void)) + (nargs (ash (the fixnum (1- len)) -1)) + (fpr-reload-sizes (make-array 13 :element-type '(unsigned-byte 8))) + (fpr-reload-offsets (make-array 13 :element-type '(unsigned-byte 16)))) + (declare (fixnum nargs) (dynamic-extent fpr-reload-sizes fpr-reload-offsets)) + (do* ((i 0 (1+ i)) + (specs specs-and-vals (cddr specs)) + (spec (car specs) (car specs))) + ((= i nargs)) + (declare (fixnum i)) + (case spec + ((:double-float :signed-doubleword :unsigned-doubleword) + (incf total-words 2)) + ((:single-float :signed-byte :unsigned-byte :signed-halfword + :unsigned-halfword :signed-fullword + :unsigned-fullword :address) + (incf total-words)) + (t (if (typep spec 'unsigned-byte) + (incf total-words spec) + (error "Invalid argument spec ~s" spec))))) + (%stack-block ((buf (ash (logand (lognot 1) (1+ (max 6 total-words))) 2))) + (do* ((i 0 (1+ i)) + (fpr 0) + (offset 0 (+ offset 4)) + (specs specs-and-vals (cddr specs)) + (spec (car specs) (car specs)) + (val (cadr specs) (cadr specs))) + ((= i nargs)) + (declare (fixnum i offset fpr)) + (case spec + (:double-float + (when (< fpr 13) + (setf (uvref fpr-reload-sizes fpr) 2 + (uvref fpr-reload-offsets fpr) offset)) + (incf fpr) + (setf (%get-double-float buf offset) val) + (incf offset 4)) + (:single-float + (when (< fpr 13) + (setf (uvref fpr-reload-sizes fpr) 1 + (uvref fpr-reload-offsets fpr) offset)) + (incf fpr) + (setf (%get-single-float buf offset) val)) + (:signed-doubleword + (setf (%get-signed-long-long buf offset) val) + (incf offset 4)) + (:unsigned-doubleword + (setf (%get-unsigned-long-long buf offset) val) + (incf offset 4)) + (:address + (setf (%get-ptr buf offset) val)) + ((:unsigned-byte :unsigned-halfword :unsigned-fullword) + (setf (%get-unsigned-long buf offset) val)) + (t + (if (typep spec 'unsigned-byte) + (dotimes (i spec (decf offset 4)) + (setf (%get-ptr buf offset) + (%get-ptr val (* i 4))) + (incf offset 4)) + (setf (%get-long buf offset) val))))) + (let* ((frame-size (if (<= total-words 8) + (ash + (+ ppc32::c-frame.size ppc32::lisp-frame.size) + -2) + (+ + (ash + (+ ppc32::c-frame.size ppc32::lisp-frame.size) + -2) + (logand (lognot 1) + (1+ (- total-words 8))))))) + + (%%ff-call + fpr-reload-sizes + fpr-reload-offsets + (- (logandc2 (+ frame-size 3) 3)) + total-words + buf + entry)) + (ecase result-spec + (:void nil) + (:single-float (%get-single-float buf 8)) + (:double-float (%get-double-float buf 16)) + (:address (%get-ptr buf)) + (:signed-doubleword (%get-signed-long-long buf 0)) + (:unsigned-doubleword (%get-unsigned-long-long buf 0)) + (:signed-fullword (%get-signed-long buf)) + (:unsigned-fullword (%get-unsigned-long buf)) + (:signed-halfword (%get-signed-word buf 2)) + (:unsigned-halfword (%get-unsigned-word buf 2)) + (:signed-byte (%get-signed-byte buf 3)) + (:unsigned-byte (%get-unsigned-byte buf 3))))))) + + + (defarmlapfunction %%ff-call ((reload-sizes 8) + (reload-offsets 4) + (frame-size 0) + (total-words arg_x) + (buf arg_y) + (entry arg_z)) + (check-nargs 6) + (la imm0 12 vsp) + (save-lisp-context imm0) + (lwz imm0 frame-size vsp) + (stwux sp sp imm0) + (stw sp ppc32::c-frame.savelr sp) + (macptr-ptr imm2 buf) + (mov imm1 imm2) + (la imm3 ppc32::c-frame.param0 sp) + (li temp1 0) + @copy + (addi temp1 temp1 '1) + (cmpw temp1 total-words) + (lwz imm0 0 imm2) + (la imm2 4 imm2) + (stw imm0 0 imm3) + (la imm3 4 imm3) + (blt @copy) + (lwz temp0 reload-sizes vsp) + (lwz temp1 reload-offsets vsp) + @load-fp1 + (lbz imm0 (+ ppc32::misc-data-offset 0) temp0) + (cmpwi imm0 1) + (lhz imm2 (+ ppc32::misc-data-offset 0) temp1) + (blt @loaded) + (bne @load-fp1-double) + (lfsx fp1 imm1 imm2) + (b @load-fp2) + @load-fp1-double + (lfdx fp1 imm1 imm2) + + @load-fp2 + (lbz imm0 (+ ppc32::misc-data-offset 1) temp0) + (cmpwi imm0 1) + (lhz imm2 (+ ppc32::misc-data-offset 2) temp1) + (blt @loaded) + (bne @load-fp2-double) + (lfsx fp2 imm1 imm2) + (b @load-fp3) + @load-fp2-double + (lfdx fp2 imm1 imm2) + + @load-fp3 + (lbz imm0 (+ ppc32::misc-data-offset 2) temp0) + (cmpwi imm0 1) + (lhz imm2 (+ ppc32::misc-data-offset 4) temp1) + (blt @loaded) + (bne @load-fp3-double) + (lfsx fp3 imm1 imm2) + (b @load-fp4) + @load-fp3-double + (lfdx fp3 imm1 imm2) + + @load-fp4 + (lbz imm0 (+ ppc32::misc-data-offset 3) temp0) + (cmpwi imm0 1) + (lhz imm2 (+ ppc32::misc-data-offset 6) temp1) + (blt @loaded) + (bne @load-fp4-double) + (lfsx fp4 imm1 imm2) + (b @load-fp5) + @load-fp4-double + (lfdx fp4 imm1 imm2) + + @load-fp5 + (lbz imm0 (+ ppc32::misc-data-offset 4) temp0) + (cmpwi imm0 1) + (lhz imm2 (+ ppc32::misc-data-offset 8) temp1) + (blt @loaded) + (bne @load-fp5-double) + (lfsx fp5 imm1 imm2) + (b @load-fp6) + @load-fp5-double + (lfdx fp5 imm1 imm2) + + @load-fp6 + (lbz imm0 (+ ppc32::misc-data-offset 5) temp0) + (cmpwi imm0 1) + (lhz imm2 (+ ppc32::misc-data-offset 10) temp1) + (blt @loaded) + (bne @load-fp1-double) + (lfsx fp6 imm1 imm2) + (b @load-fp7) + @load-fp6-double + (lfdx fp6 imm1 imm2) + + @load-fp7 + (lbz imm0 (+ ppc32::misc-data-offset 6) temp0) + (cmpwi imm0 1) + (lhz imm2 (+ ppc32::misc-data-offset 12) temp1) + (blt @loaded) + (bne @load-fp1-double) + (lfsx fp7 imm1 imm2) + (b @load-fp8) + @load-fp7-double + (lfdx fp7 imm1 imm2) + + @load-fp8 + (lbz imm0 (+ ppc32::misc-data-offset 7) temp0) + (cmpwi imm0 1) + (lhz imm2 (+ ppc32::misc-data-offset 14) temp1) + (blt @loaded) + (bne @load-fp8-double) + (lfsx fp8 imm1 imm2) + (b @load-fp9) + @load-fp8-double + (lfdx fp8 imm1 imm2) + + @load-fp9 + (lbz imm0 (+ ppc32::misc-data-offset 8) temp0) + (cmpwi imm0 1) + (lhz imm2 (+ ppc32::misc-data-offset 16) temp1) + (blt @loaded) + (bne @load-fp9-double) + (lfsx fp9 imm1 imm2) + (b @load-fp10) + @load-fp9-double + (lfdx fp9 imm1 imm2) + + @load-fp10 + (lbz imm0 (+ ppc32::misc-data-offset 9) temp0) + (cmpwi imm0 1) + (lhz imm2 (+ ppc32::misc-data-offset 18) temp1) + (blt @loaded) + (bne @load-fp10-double) + (lfsx fp10 imm1 imm2) + (b @load-fp11) + @load-fp10-double + (lfdx fp10 imm1 imm2) + + @load-fp11 + (lbz imm0 (+ ppc32::misc-data-offset 10) temp0) + (cmpwi imm0 1) + (lhz imm2 (+ ppc32::misc-data-offset 20) temp1) + (blt @loaded) + (bne @load-fp11-double) + (lfsx fp11 imm1 imm2) + (b @load-fp12) + @load-fp11-double + (lfdx fp11 imm1 imm2) + + @load-fp12 + (lbz imm0 (+ ppc32::misc-data-offset 11) temp0) + (cmpwi imm0 1) + (lhz imm2 (+ ppc32::misc-data-offset 22) temp1) + (blt @loaded) + (bne @load-fp12-double) + (lfsx fp12 imm1 imm2) + (b @load-fp13) + @load-fp12-double + (lfdx fp12 imm1 imm2) + + @load-fp13 + (lbz imm0 (+ ppc32::misc-data-offset 12) temp0) + (cmpwi imm0 1) + (lhz imm2 (+ ppc32::misc-data-offset 24) temp1) + (blt @loaded) + (bne @load-fp13-double) + (lfsx fp13 imm1 imm2) + (b @loaded) + @load-fp13-double + (lfdx fp13 imm1 imm2) + @loaded + (vpush buf) + (bla .SPpoweropen-ffcall) + @called + (vpop buf) + (macptr-ptr imm2 buf) + (stw imm0 0 imm2) + (stw imm1 4 imm2) + (stfs fp1 8 imm2) + (stfd fp1 16 imm2) + (restore-full-lisp-context) + (li arg_z (target-nil-value)) + (bx lr)) + ) + + #+ppc64-target + (progn + ;;; There are a few funky, non-obvious things going on here. + ;;; The main %FF-CALL function uses WITH-VARIABLE-C-FRAME; + ;;; the compiler will generate code to pop that frame off + ;;; of the C/control stack, but the subprim that implements + ;;; %ff-call has already popped it off. To put things back + ;;; in balance, the LAP function %%FF-RESULT pushes an + ;;; extra frame on the cstack. + ;;; %FF-CALL calls %%FF-RESULT to box the result, which may + ;;; be in r3/imm0 or in fp1. It's critical that the call + ;;; to %%FF-RESULT not be compiled as "multiple-value returning", + ;;; since the MV machinery may clobber IMM0. + (defarmlapfunction %%ff-result ((spec arg_z)) + (stdu sp -160 sp) + (ld arg_y ':void nfn) + (cmpd cr0 spec arg_y) + (ld arg_x ':address nfn) + (cmpd cr1 spec arg_x) + (ld temp3 ':single-float nfn) + (cmpd cr2 spec temp3) + (ld arg_y ':double-float nfn) + (cmpd cr3 spec arg_y) + (ld arg_x ':unsigned-doubleword nfn) + (cmpd cr4 spec arg_x) + (ld temp3 ':signed-doubleword nfn) + (cmpd cr5 spec temp3) + (beq cr0 @void) + (beq cr1 @address) + (beq cr2 @single-float) + (beq cr3 @double-float) + (beq cr4 @unsigned-doubleword) + (beq cr5 @signed-doubleword) + (box-fixnum arg_z imm0) + (bx lr) + @void + (li arg_z nil) + (bx lr) + @address + (li imm1 ppc64::macptr-header) + (subi allocptr allocptr (- ppc64::macptr.size ppc64::fulltag-misc)) + (tdlt allocptr allocbase) + (std imm1 ppc64::misc-header-offset allocptr) + (mov arg_z allocptr) + (clrrdi allocptr allocptr 4) + (std imm0 ppc64::macptr.address arg_z) + (bx lr) + @single-float + (put-single-float fp1 arg_z) + (bx lr) + @double-float + (li imm1 ppc64::double-float-header) + (subi allocptr allocptr (- ppc64::double-float.size ppc64::fulltag-misc)) + (tdlt allocptr allocbase) + (std imm1 ppc64::misc-header-offset allocptr) + (mov arg_z allocptr) + (clrrdi allocptr allocptr 4) + (stfd fp1 ppc64::macptr.address arg_z) + (bx lr) + @unsigned-doubleword + (ba .SPmakeu64) + @signed-doubleword + (ba .SPmakes64)) + + ;;; This is just here so that we can jump to a subprim from lisp. + (defarmlapfunction %do-ff-call ((regbuf arg_y) (entry arg_z)) + (cmpdi cr0 regbuf nil) + (bnea cr0 .SPpoweropen-ffcall-return-registers) + (ba .SPpoweropen-ffcall)) + + (defun %ff-call (entry &rest specs-and-vals) + (declare (dynamic-extent specs-and-vals)) + (let* ((len (length specs-and-vals)) + (total-words 0) + (registers nil)) + (declare (fixnum len total-words)) + (let* ((result-spec (or (car (last specs-and-vals)) :void)) + (nargs (ash (the fixnum (1- len)) -1))) + (declare (fixnum nargs)) + (ecase result-spec + ((:address :unsigned-doubleword :signed-doubleword + :single-float :double-float + :signed-fullword :unsigned-fullword + :signed-halfword :unsigned-halfword + :signed-byte :unsigned-byte + :void) + (do* ((i 0 (1+ i)) + (specs specs-and-vals (cddr specs)) + (spec (car specs) (car specs))) + ((= i nargs)) + (declare (fixnum i)) + (case spec + (:registers nil) + ((:address :unsigned-doubleword :signed-doubleword + :single-float :double-float + :signed-fullword :unsigned-fullword + :signed-halfword :unsigned-halfword + :signed-byte :unsigned-byte + :hybrid-int-float :hybrid-float-float + :hybrid-float-int) + (incf total-words)) + (t (if (typep spec 'unsigned-byte) + (incf total-words spec) + (error "unknown arg spec ~s" spec))))) + (%stack-block ((fp-args (* 13 8))) + (with-variable-c-frame + total-words frame + (with-macptrs ((argptr)) + (%setf-macptr-to-object argptr frame) + (let* ((offset ppc64::c-frame.param0) + (n-fp-args 0)) + (declare (fixnum offset n-fp-args)) + (do* ((i 0 (1+ i)) + (specs specs-and-vals (cddr specs)) + (spec (car specs) (car specs)) + (val (cadr specs) (cadr specs))) + ((= i nargs)) + (declare (fixnum i)) + (case spec + (:registers (setq registers val)) + (:address (setf (%get-ptr argptr offset) val) + (incf offset 8)) + ((:signed-doubleword :signed-fullword :signed-halfword + :signed-byte) + + (setf (%%get-signed-longlong argptr offset) val) + (incf offset 8)) + ((:unsigned-doubleword :unsigned-fullword :unsigned-halfword + :unsigned-byte) + (setf (%%get-unsigned-longlong argptr offset) val) + (incf offset 8)) + (:hybrid-int-float + (setf (%%get-unsigned-longlong argptr offset) val) + (when (< n-fp-args 13) + (setf (%get-double-float fp-args (* n-fp-args 8)) + (%double-float (%get-single-float argptr (+ offset 4))))) + (incf n-fp-args) + (incf offset 8)) + (:hybrid-float-int + (setf (%%get-unsigned-longlong argptr offset) val) + (when (< n-fp-args 13) + (setf (%get-double-float fp-args (* n-fp-args 8)) + (%double-float (%get-single-float argptr offset)))) + (incf n-fp-args) + (incf offset 8)) + (:hybrid-float-float + (setf (%%get-unsigned-longlong argptr offset) val) + (when (< n-fp-args 13) + (setf (%get-double-float fp-args (* n-fp-args 8)) + (%double-float (%get-single-float argptr offset)))) + (incf n-fp-args) + (when (< n-fp-args 13) + (setf (%get-double-float fp-args (* n-fp-args 8)) + (%double-float (%get-single-float argptr (+ offset 4))))) + (incf n-fp-args) + (incf offset 8)) + (:double-float + (setf (%get-double-float argptr offset) val) + (when (< n-fp-args 13) + (setf (%get-double-float fp-args (* n-fp-args 8)) val)) + (incf n-fp-args) + (incf offset 8)) + (:single-float + (setf (%get-single-float argptr offset) val) + (when (< n-fp-args 13) + (setf (%get-double-float fp-args (* n-fp-args 8)) + (%double-float val))) + (incf n-fp-args) + (incf offset 8)) + (t + (let* ((p 0)) + (declare (fixnum p)) + (dotimes (i (the fixnum spec)) + (setf (%get-ptr argptr offset) (%get-ptr val p)) + (incf p 8) + (incf offset 8)))))) + (%load-fp-arg-regs n-fp-args fp-args) + (%do-ff-call registers entry) + (values (%%ff-result result-spec))))))))))) + + ) + ) + + + +(defarmlapfunction %get-object ((macptr arg_y) (offset arg_z)) + (check-nargs 2) + (trap-unless-typecode= arg_y target::subtag-macptr) + (macptr-ptr imm0 arg_y) + (trap-unless-lisptag= arg_z target::tag-fixnum imm1) + (unbox-fixnum imm1 arg_z) + (ldrx arg_z imm0 imm1) + (bx lr)) + + +(defarmlapfunction %set-object ((macptr arg_x) (offset arg_y) (value arg_z)) + (check-nargs 3) + (trap-unless-typecode= arg_x target::subtag-macptr) + (macptr-ptr imm0 arg_x) + (trap-unless-lisptag= arg_y target::tag-fixnum imm1) + (unbox-fixnum imm1 arg_y) + (strx arg_z imm0 imm1) + (bx lr)) + + +(defarmlapfunction %apply-lexpr-with-method-context ((magic arg_x) + (function arg_y) + (args arg_z)) + ;; Somebody's called (or tail-called) us. + ;; Put magic arg in ppc::next-method-context (= ppc::temp1). + ;; Put function in ppc::nfn (= ppc::temp2). + ;; Set nargs to 0, then spread "args" on stack (clobbers arg_x, arg_y, arg_z, + ;; but preserves ppc::nfn/ppc::next-method-context. + ;; Jump to the function in ppc::nfn. + (mov ppc::next-method-context magic) + (mov ppc::nfn function) + (set-nargs 0) + (mflr loc-pc) + (bla .SPspread-lexpr-z) + (mtlr loc-pc) + (ldr temp0 target::misc-data-offset nfn) + (mtctr temp0) + (bctr)) + + +(defarmlapfunction %apply-with-method-context ((magic arg_x) + (function arg_y) + (args arg_z)) + ;; Somebody's called (or tail-called) us. + ;; Put magic arg in ppc::next-method-context (= ppc::temp1). + ;; Put function in ppc::nfn (= ppc::temp2). + ;; Set nargs to 0, then spread "args" on stack (clobbers arg_x, arg_y, arg_z, + ;; but preserves ppc::nfn/ppc::next-method-context. + ;; Jump to the function in ppc::nfn. + (mov ppc::next-method-context magic) + (mov ppc::nfn function) + (set-nargs 0) + (mflr loc-pc) + (bla .SPspreadargZ) + (mtlr loc-pc) + (ldr temp0 target::misc-data-offset nfn) + (mtctr temp0) + (bctr)) + + + + +(defarmlapfunction %apply-lexpr-tail-wise ((method arg_y) (args arg_z)) + ;; This assumes + ;; a) that "args" is a lexpr made via the .SPlexpr-entry mechanism + ;; b) That the LR on entry to this function points to the lexpr-cleanup + ;; code that .SPlexpr-entry set up + ;; c) That there weren't any required args to the lexpr, e.g. that + ;; (%lexpr-ref args (%lexpr-count args) 0) was the first arg to the gf. + ;; The lexpr-cleanup code will be EQ to either (lisp-global ret1valaddr) + ;; or (lisp-global lexpr-return1v). In the former case, discard a frame + ;; from the cstack (multiple-value tossing). Restore FN and LR from + ;; the first frame that .SPlexpr-entry pushed, restore vsp from (+ + ;; args node-size), pop the argregs, and jump to the function. + (mflr loc-pc) + (ref-global imm0 ret1valaddr) + (cmpr cr2 loc-pc imm0) + (ldr nargs 0 args) + (mov imm5 nargs) + (cmpri cr0 nargs 0) + (cmpri cr1 nargs '2) + (mov nfn method) + (ldr temp0 target::misc-data-offset nfn) + (mtctr temp0) + (if (:cr2 :eq) + (la sp target::lisp-frame.size sp)) + (ldr loc-pc target::lisp-frame.savelr sp) + (ldr fn target::lisp-frame.savefn sp) + (ldr imm0 target::lisp-frame.savevsp sp) + (sub vsp imm0 nargs) + (mtlr loc-pc) + (la sp target::lisp-frame.size sp) + (beqctr) + (vpop arg_z) + (bltctr cr1) + (vpop arg_y) + (beqctr cr1) + (vpop arg_x) + (bctr)) + + +(defun %copy-function (proto &optional target) + (let* ((total-size (uvsize proto)) + (new (or target (allocate-typed-vector :function total-size)))) + (declare (fixnum total-size)) + (when target + (unless (eql total-size (uvsize target)) + (error "Wrong size target ~s" target))) + (%copy-gvector-to-gvector proto 0 new 0 total-size) + new)) + +(defun replace-function-code (target-fn proto-fn) + (if (typep target-fn 'function) + (if (typep proto-fn 'function) + (setf (uvref target-fn 0) + (uvref proto-fn 0)) + (report-bad-arg proto-fn 'function)) + (report-bad-arg target-fn 'function))) + +(defun closure-function (fun) + (while (and (functionp fun) (not (compiled-function-p fun))) + (setq fun (%svref fun 1)) + (when (vectorp fun) + (setq fun (svref fun 0)))) + fun) + + +;;; For use by (setf (apply ...) ...) +;;; (apply+ f butlast last) = (apply f (append butlast (list last))) +#+ppc-target +(defun apply+ (&lap function arg1 arg2 &rest other-args) + (ppc-lap-function apply+ () + (check-nargs 3 nil) + (vpush arg_x) + (mov temp0 arg_z) ; last + (mov arg_z arg_y) ; butlast + (subi nargs nargs '2) ; remove count for butlast & last + (mflr loc-pc) + (bla .SPspreadargz) + (cmpri cr0 nargs '3) + (mtlr loc-pc) + (addi nargs nargs '1) ; count for last + (blt cr0 @nopush) + (vpush arg_x) +@nopush + (mov arg_x arg_y) + (mov arg_y arg_z) + (mov arg_z temp0) + (ldr temp0 'funcall nfn) + (ba .SPfuncall))) + +(lfun-bits #'apply+ (logior $lfbits-rest-bit + (dpb 3 $lfbits-numreq 0))) + +;;; end of ppc-def.lisp Index: /branches/arm/level-0/ARM/arm-misc.lisp =================================================================== --- /branches/arm/level-0/ARM/arm-misc.lisp (revision 13705) +++ /branches/arm/level-0/ARM/arm-misc.lisp (revision 13706) @@ -42,5 +42,5 @@ (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))) + (add src-reg src-reg (:asr src-byteptr (:$ arm::fixnumshift))) (unbox-fixnum dest-byteptr dest-byte-offset) (add dest-byteptr dest-byteptr (:$ arm::misc-data-offset)) @@ -49,5 +49,5 @@ (subs nbytes nbytes '1) (ldrb val (:@+ src-reg (:$ 1))) - (strb val (:@ dest (:$ dest-byteptr))) + (strb val (:@ dest dest-byteptr)) (add dest-byteptr dest-byteptr (:$ 1)) @test @@ -58,11 +58,11 @@ (defarmlapfunction %copy-ivector-to-ptr ((src (* 1 arm::node-size)) - (src-byte-offset 0) + (src-byte-offset 0) (dest arg_x) (dest-byte-offset arg_y) (nbytes arg_z)) - (ldr temp0 (:@ vsp (:$ src)) + (ldr temp0 (:@ vsp (:$ src))) (cmp nbytes (:$ 0)) - (ldr imm0 (:@ vsp (:$ src-byte-offset)) + (ldr imm0 (:@ vsp (:$ src-byte-offset))) (unbox-fixnum imm0 imm0) (add imm0 imm0 (:$ arm::misc-data-offset)) @@ -76,9 +76,10 @@ (strb imm2 (:@+ imm1 (:$ 1))) @test - (bne cr0 @loop) + (bne @loop) (mov arg_z dest) (add vsp vsp '2) (bx lr)) +#+notyet (defarmlapfunction %copy-ivector-to-ivector ((src 4) (src-byte-offset 0) @@ -157,5 +158,5 @@ - +#+notyet (defarmlapfunction %copy-gvector-to-gvector ((src (* 1 arm::node-size)) (src-element 0) @@ -208,20 +209,17 @@ - - -#+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) + (ldr imm2 (:@ rcontext (:$ arm::tcr.last-allocptr))) + (ldr imm1 (:@ rcontext (:$ arm::tcr.total-bytes-allocated-high))) + (ldr imm0 (:@ rcontext (:$ arm::tcr.total-bytes-allocated-low))) + (cmp imm2 (:$ 0)) (sub imm2 imm2 allocptr) - (beq cr1 @go) (beq @go) - (addc imm1 imm1 imm2) - (addze imm0 imm0) + (cmp allocptr (:$ -8)) + (beq @go) + (adds imm1 imm1 imm2) + (adc imm0 imm0 (:$ 0)) @go - (ba .SPmakeu64)) + (b .SPmakeu64)) @@ -236,26 +234,25 @@ ;; 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) + (trap-unless-xtype= arg_y arm::subtag-macptr) + (str arg_z (:@ arg_y (:$ arm::macptr.address))) (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) + (trap-unless-xtype= arg_z arm::subtag-macptr) + (ldr imm0 (:@ arg_z (:$ arm::macptr.address))) + (trap-unless-fixnum imm0) + (mov arg_z imm0) (bx lr)) (defarmlapfunction %%get-unsigned-longlong ((ptr arg_y) (offset arg_z)) - (trap-unless-typecode= ptr ppc32::subtag-macptr) + (trap-unless-xtype= ptr arm::subtag-macptr) (macptr-ptr imm1 ptr) (unbox-fixnum imm2 offset) (add imm2 imm2 imm1) - (lwz imm0 0 imm2) - (lwz imm1 4 imm2) + (ldr imm0 (:@ imm2 (:$ 0))) + (ldr imm1 (:@ imm2 (:$ 4))) (ba .SPmakeu64)) @@ -263,75 +260,47 @@ (defarmlapfunction %%get-signed-longlong ((ptr arg_y) (offset arg_z)) - (trap-unless-typecode= ptr ppc32::subtag-macptr) + (trap-unless-xtype= ptr arm::subtag-macptr) (macptr-ptr imm1 ptr) (unbox-fixnum imm2 offset) (add imm2 imm2 imm1) - (lwz imm0 0 imm2) - (lwz imm1 4 imm2) + (ldr imm0 (:@ imm2 (:$ 0))) ;low + (ldr imm1 (:@ imm2 (:$ 1))) ;high (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) + (build-lisp-frame imm0) + (mov fn nfn) + (trap-unless-xtype= ptr arm::subtag-macptr) + (bl .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 + (add imm2 imm2 (:asr offset (:$ arm::fixnumshift))) + (str imm0 (:@ imm2 (:$ 0))) + (str imm1 (:@ imm2 (:$ 4))) + (return-lisp-frame imm0)) + + + (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) + (build-lisp-frame imm0) + (mov fn nfn) + (trap-unless-xtype= ptr arm::subtag-macptr) + (bl .SPgets64) (macptr-ptr imm2 ptr) - (unbox-fixnum imm3 offset) - (stdx imm0 imm3 imm2) - (ba .SPpopj)) + (add imm2 imm2 (:asr offset (:$ arm::fixnumshift))) + (str imm0 (:@ imm2 (:$ 0))) + (str imm1 (:@ imm2 (:$ 4))) + (return-lisp-frame imm0)) + + (defarmlapfunction interrupt-level () - (ldr arg_z arm::tcr.tlb-pointer arm::rcontext) - (ldr arg_z arm::interrupt-level-binding-index arg_z) + (ldr arg_z (:@ arm::rcontext (:$ arm::tcr.tlb-pointer))) + (ldr arg_z (:@ arg_z (:$ arm::interrupt-level-binding-index))) (bx lr)) @@ -340,7 +309,7 @@ (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) + (ldr imm1 (:@ arm::rcontext (:$ arm::tcr.tlb-pointer))) + (trap-unless-fixnum new) + (str new (:@ imm1 (:$ arm::interrupt-level-binding-index))) (bx lr)) @@ -353,33 +322,27 @@ (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) + (cmp tcr arm::rcontext) + (mov imm0 vsp) + (ldr temp0 (:@ tcr (:$ arm::tcr.vs-area))) + (ldr imm1 (:@ temp0 (:$ arm::area.high))) + (ldrne imm0 (:@ temp0 (:$ arm::area.active))) + (cmp imm1 imm0) + (moveq arg_z 'nil) + (ldrne arg_z (:@ imm1 (:$ (- arm::node-size)))) (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) + (cmp tcr arm::rcontext) + (mov imm0 vsp) + (ldr temp0 (:@ tcr (:$ arm::tcr.vs-area))) + (ldr imm1 (:@ temp0 (:$ arm::area.high))) + (ldrne imm0 (:@ temp0 (:$ arm::area.active))) + (cmp imm1 imm0) + (mov imm0 ($ 0)) + (push1 imm0 imm1) + (streq imm1 (:@ temp0 (:$ arm::area.active))) + (streq imm1 (:@ tcr (:$ arm::tcr.save-vsp))) + (str fun (:@ imm1 (:$ 0))) (bx lr)) @@ -388,4 +351,5 @@ (ba .SPstore-node-conditional)) +#+notyet ; needs a subprim on ARM (defarmlapfunction %store-immediate-conditional ((offset 0) (object arg_x) (old arg_y) (new arg_z)) (vpop temp0) @@ -407,4 +371,5 @@ (bx lr))) +#+notyet ; needs ARM subprim ? (defarmlapfunction set-%gcable-macptrs% ((ptr arm::arg_z)) (li imm0 (+ (target-nil-value) (arm::kernel-global gcable-pointers))) @@ -419,4 +384,5 @@ ;;; Atomically increment or decrement the gc-inhibit-count kernel-global ;;; (It's decremented if it's currently negative, incremented otherwise.) +#+notyet ;needs ARM subprim ? (defarmlapfunction %lock-gc-lock () (li imm0 (+ (target-nil-value) (arm::kernel-global gc-inhibit-count))) @@ -436,4 +402,5 @@ ;;; (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.) +#+notyet ;Needs ARM subprim ? (defarmlapfunction %unlock-gc-lock () ;; (sync) @@ -456,5 +423,5 @@ - +#+notyet ;needs ARM subprim ? (defarmlapfunction %atomic-incf-node ((by arg_x) (node arg_y) (disp arg_z)) (check-nargs 3) @@ -468,4 +435,5 @@ (bx lr)) +#+notyet ;needs ARM subprim ? (defarmlapfunction %atomic-incf-ptr ((ptr arg_z)) (macptr-ptr imm1 ptr) @@ -479,4 +447,5 @@ (bx lr)) +#+notyet ;needs ARM subprim ? (defarmlapfunction %atomic-incf-ptr-by ((ptr arg_y) (by arg_z)) (macptr-ptr imm1 ptr) @@ -491,4 +460,5 @@ (bx lr)) +#+notyet ;needs ARM subprim (defarmlapfunction %atomic-decf-ptr ((ptr arg_z)) (macptr-ptr imm1 ptr) @@ -502,4 +472,5 @@ (bx lr)) +#+notyet ;Needs ARM subprim ? (defarmlapfunction %atomic-decf-ptr-if-positive ((ptr arg_z)) (macptr-ptr imm1 ptr) @@ -520,4 +491,5 @@ (bx lr)) +#+notyet ;guess why not ? (defarmlapfunction %atomic-swap-ptr ((ptr arg_y) (newval arg_z)) (sync) @@ -534,4 +506,5 @@ ;;; Try to store the fixnum NEWVAL at PTR, if and only if the old value ;;; was equal to OLDVAL. Return the old value +#notyet ;still (defarmlapfunction %ptr-store-conditional ((ptr arg_x) (expected-oldval arg_y) (newval arg_z)) (macptr-ptr imm0 ptr) @@ -553,4 +526,5 @@ (bx lr)) +#+notyet ; Yet ? Not. (defarmlapfunction %ptr-store-fixnum-conditional ((ptr arg_x) (expected-oldval arg_y) (newval arg_z)) (let ((address imm0) @@ -564,9 +538,9 @@ (bne- @again) (isync) - (mr arg_z actual-oldval) + (mov arg_z actual-oldval) (bx lr) @done (li address arm::reservation-discharge) - (mr arg_z actual-oldval) + (mov arg_z actual-oldval) (strcx. rzero 0 address) (bx lr))) @@ -577,8 +551,9 @@ (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)) - + (mov imm0 (:$ arm::subtag-dead-macptr)) + (strb imm0 (:@ macptr (:$ arm::misc-subtag-offset))) + (bx lr)) + +#+notyet ;for different reasons (defarmlapfunction %%apply-in-frame ((catch-count imm0) (srv temp0) (tsp-count imm0) (db-link imm0) (parent arg_x) (function arg_y) (arglist arg_z)) @@ -682,61 +657,10 @@ (stw loc-pc arm::lisp-frame.savelr sp)) ;; Parent is a real stack frame - (mr sp parent)) + (mov 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))))) + @@ -754,5 +678,5 @@ (defarmlapfunction %misc-address-fixnum ((misc-object arg_z)) (check-nargs 1) - (la arg_z arm::misc-data-offset misc-object) + (add arg_z misc-object (:$ arm::misc-data-offset)) (bx lr)) @@ -761,12 +685,12 @@ (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 + (add imm0 imm1 (:$ 9)) ; 2 for delta + 7 for alignment + (bic imm0 imm0 (:$ 7)) ; Clear low three bits to align + (rsb imm1 imm1 imm0) ; imm1 = delta + (strh imm1 (:@ imm0 (:$ -2))) ; 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 + (orr imm1 imm1 (:lsl len (:$ (- arm::num-subtag-bits arm::fixnum-shift)))) + (str imm1 (:@ imm0 (:$ 0))) ; store subtype & length + (add arg_z imm0 (:$ arm::fulltag-misc)) ; tag it, return it (bx lr)) @@ -775,43 +699,31 @@ (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 vector (:$ arm::fulltag-misc)) ; imm0 is addr = vect less tag + (ldrh imm1 (:@ imm0 (:$ -2))) ; get delta (sub imm0 imm0 imm1) ; vector addr (less tag) - delta is orig addr - (str imm0 arm::macptr.address ptr) - (bx lr)) - -#+arm-target + (str imm0 (:@ ptr (:$ arm::macptr.address))) + (bx lr)) + (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. + ;; of data is at ARM::MISC-DATA-OFFSET; for the double-float + ;; types, it's at ARM::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)) - - - - + (cmp imm0 (:$ arm::subtag-double-float-vector)) + (cmpne imm0 (:$ arm::subtag-double-float)) + (addne temp0 vect (:$ arm::misc-data-offset)) + (addeq temp0 vect (:$ arm::misc-dfloat-offset)) + (str temp0 (:@ arg_z (:$ arm::macptr.address))) + (bx lr)) (defarmlapfunction %current-db-link () - (ldr arg_z arm::tcr.db-link arm::rcontext) + (ldr arg_z (:@ arm::rcontext (:$ arm::tcr.db-link))) (bx lr)) (defarmlapfunction %no-thread-local-binding-marker () - (li arg_z arm::subtag-no-thread-local-binding) - (bx lr)) - - + (mov arg_z (:$ arm::subtag-no-thread-local-binding)) + (bx lr)) @@ -821,7 +733,7 @@ (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) + (str imm0 (:@ arm::rcontext (:$ arm::tcr.safe-ref-address))) + (ldr imm0 (:@ imm0 (:$ 0))) ; may fault + (str imm0 (:@ dest (:$ arm::macptr.address))) (bx lr)) @@ -831,10 +743,12 @@ ;;; That's maintained in r2 on LinuxPPC32, and not maintained ;;; in a GPR on DarwinPPC32 +#+huh (defarmlapfunction %get-os-context () - #+ppc64-target (mr arg_z 13) - #+linuxppc32-target (mr arg_z 2) - #+darinppc32-target (mr arg_z 0) - (bx lr)) - + #+ppc64-target (mov arg_z 13) + #+linuxppc32-target (mov arg_z 2) + #+darinppc32-target (mov arg_z 0) + (bx lr)) + +#+bad-idea (defarmlapfunction %check-deferred-gc () (ldr imm0 arm::tcr.flags arm::rcontext) @@ -845,4 +759,7 @@ (li arg_z t) (bx lr)) + +#+later +(progn (defarmlapfunction %%tcr-interrupt ((target arg_z)) @@ -942,5 +859,6 @@ (li arg_z nil) (bx lr)) - +); #+later + ; end of arm-misc.lisp Index: /branches/arm/level-0/ARM/arm-utils.lisp =================================================================== --- /branches/arm/level-0/ARM/arm-utils.lisp (revision 13706) +++ /branches/arm/level-0/ARM/arm-utils.lisp (revision 13706) @@ -0,0 +1,526 @@ +;;; -*- 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") + +(defppclapfunction %address-of ((arg arg_z)) + ;; %address-of a fixnum is a fixnum, just for spite. + ;; %address-of anything else is the address of that thing as an integer. + (clrlwi. imm0 arg (- 32 ppc32::nlisptagbits)) + (beqlr cr0) + (mr imm0 arg_z) + ;; set cr0_eq if result fits in a fixnum + (clrrwi. imm1 imm0 (- ppc32::least-significant-bit ppc32::nfixnumtagbits)) + (box-fixnum arg_z imm0) ; assume it did + (beqlr+ cr0) ; else arg_z tagged ok, but missing bits + (ba .SPmakeu32) ; put all bits in bignum. +) + + + +;;; "areas" are fixnum-tagged and, for the most part, so are their +;;; contents. + +;;; The nilreg-relative global all-areas is a doubly-linked-list header +;;; that describes nothing. Its successor describes the current/active +;;; dynamic heap. Return a fixnum which "points to" that area, after +;;; ensuring that the "active" pointers associated with the current thread's +;;; stacks are correct. + + + +(defppclapfunction %normalize-areas () + (let ((address imm0) + (temp imm2)) + + ; update active pointer for tsp area. + (ldr address target::tcr.ts-area target::rcontext) + (str tsp target::area.active address) + + ;; Update active pointer for vsp area. + (ldr address target::tcr.vs-area target::rcontext) + (str vsp target::area.active address) + + ; Update active pointer for SP area + (ldr arg_z target::tcr.cs-area target::rcontext) + (str sp target::area.active arg_z) + + + (ref-global arg_z all-areas) + (ldr arg_z target::area.succ arg_z) + + (blr))) + +(defppclapfunction %active-dynamic-area () + (ref-global arg_z all-areas) + (ldr arg_z target::area.succ arg_z) + (blr)) + + +(defppclapfunction %object-in-stack-area-p ((object arg_y) (area arg_z)) + (ldr imm0 target::area.active area) + (cmplr cr0 object imm0) + (ldr imm1 target::area.high area) + (cmplr cr1 object imm1) + (li arg_z nil) + (bltlr cr0) + (bgelr cr1) + (la arg_z target::t-offset arg_z) + (blr)) + +(defppclapfunction %object-in-heap-area-p ((object arg_y) (area arg_z)) + (ldr imm0 target::area.low area) + (cmplr cr0 object imm0) + (ldr imm1 target::area.active area) + (cmplr cr1 object imm1) + (li arg_z nil) + (bltlr cr0) + (bgelr cr1) + (la arg_z target::t-offset arg_z) + (blr)) + + +#+ppc32-target +(defppclapfunction walk-static-area ((a arg_y) (f arg_z)) + (let ((fun save0) + (obj save1) + (limit save2) + (header imm0) + (tag imm1) + (subtag imm2) + (bytes imm3) + (elements imm0)) + (save-lisp-context) + (:regsave limit 0) + (vpush fun) + (vpush obj) + (vpush limit) + (mr fun f) + (lwz limit ppc32::area.active a) + (lwz obj ppc32::area.low a) + (b @test) + @loop + (lwz header 0 obj) + (extract-fulltag tag header) + (cmpwi cr0 tag ppc32::fulltag-immheader) + (cmpwi cr1 tag ppc32::fulltag-nodeheader) + (beq cr0 @misc) + (beq cr1 @misc) + (la arg_z ppc32::fulltag-cons obj) + (set-nargs 1) + (mr temp0 fun) + (bla .SPFuncall) + (la obj ppc32::cons.size obj) + (b @test) + @misc + (la arg_z ppc32::fulltag-misc obj) + (set-nargs 1) + (mr temp0 fun) + (bla .SPFuncall) + (lwz header 0 obj) + (extract-fulltag tag header) + (cmpwi cr1 tag ppc32::fulltag-nodeheader) + (clrlwi subtag header (- 32 ppc32::num-subtag-bits)) + (cmpwi cr2 subtag ppc32::max-32-bit-ivector-subtag) + (cmpwi cr3 subtag ppc32::max-8-bit-ivector-subtag) + (cmpwi cr4 subtag ppc32::max-16-bit-ivector-subtag) + (cmpwi cr5 subtag ppc32::subtag-double-float-vector) + (header-size elements header) + (slwi bytes elements 2) + (beq cr1 @bump) + (ble cr2 @bump) + (mr bytes elements) + (ble cr3 @bump) + (slwi bytes elements 1) + (ble cr4 @bump) + (slwi bytes elements 3) + (beq cr5 @bump) + (la elements 7 elements) + (srwi bytes elements 3) + @bump + (la bytes (+ 4 7) bytes) + (clrrwi bytes bytes 3) + (add obj obj bytes) + @test + (cmplw :cr0 obj limit) + (blt cr0 @loop) + (vpop limit) + (vpop obj) + (vpop fun) + (restore-full-lisp-context) + (blr))) + + + +;;; This walks the active "dynamic" area. Objects might be moving around +;;; while we're doing this, so we have to be a lot more careful than we +;;; are when walking a static area. +;;; There's the vague notion that we can't take an interrupt when +;;; "initptr" doesn't equal "freeptr", though what kind of hooks into a +;;; preemptive scheduler we'd need to enforce this is unclear. We use +;;; initptr as an untagged pointer here (and set it to freeptr when we've +;;; got a tagged pointer to the current object.) +;;; There are a couple of approaches to termination: +;;; a) Allocate a "sentinel" cons, and terminate when we run into it. +;;; b) Check the area limit (which is changing if we're consing) and +;;; terminate when we hit it. +;;; (b) loses if the function conses. (a) conses. I can't think of anything +;;; better than (a). +;;; This, of course, assumes that any GC we're doing does in-place compaction +;;; (or at least preserves the relative order of objects in the heap.) + +#+ppc32-target +(defppclapfunction %walk-dynamic-area ((a arg_y) (f arg_z)) + (let ((fun save0) + (obj save1) + (sentinel save2) + (header imm0) + (tag imm1) + (subtag imm2) + (bytes imm3) + (elements imm4)) + (save-lisp-context) + (:regsave sentinel 0) + (vpush fun) + (vpush obj) + (vpush sentinel) + (ref-global imm0 tenured-area) + (cmpwi cr0 imm0 0) + (li allocbase #xfff8) + (la allocptr (- ppc32::fulltag-cons ppc32::cons.size) allocptr) + (twllt allocptr allocbase) + (mr sentinel allocptr) + (clrrwi allocptr allocptr ppc32::ntagbits) + (mr fun f) + (if :ne + (mr a imm0)) + (lwz imm5 ppc32::area.low a) + @loop + (lwz header 0 imm5) + (extract-fulltag tag header) + (cmpwi cr0 tag ppc32::fulltag-immheader) + (cmpwi cr1 tag ppc32::fulltag-nodeheader) + (beq cr0 @misc) + (beq cr1 @misc) + (la obj ppc32::fulltag-cons imm5) + (cmpw cr0 obj sentinel) + (mr arg_z obj) + (set-nargs 1) + (mr temp0 fun) + (beq cr0 @done) + (bla .SPfuncall) + (la imm5 (- ppc32::cons.size ppc32::fulltag-cons) obj) + (b @loop) + @misc + (la obj ppc32::fulltag-misc imm5) + (mr arg_z obj) + (set-nargs 1) + (mr temp0 fun) + (bla .SPFuncall) + (getvheader header obj) + (extract-fulltag tag header) + (cmpwi cr1 tag ppc32::fulltag-nodeheader) + (cmpwi cr7 tag ppc32::fulltag-immheader) + (clrlwi subtag header (- 32 ppc32::num-subtag-bits)) + (cmpwi cr2 subtag ppc32::max-32-bit-ivector-subtag) + (cmpwi cr3 subtag ppc32::max-8-bit-ivector-subtag) + (cmpwi cr4 subtag ppc32::max-16-bit-ivector-subtag) + (cmpwi cr5 subtag ppc32::subtag-double-float-vector) + (header-size elements header) + (slwi bytes elements 2) + (beq cr1 @bump) + (if (:cr7 :ne) + (twle 0 0)) + (ble cr2 @bump) + (mr bytes elements) + (ble cr3 @bump) + (slwi bytes elements 1) + (ble cr4 @bump) + (slwi bytes elements 3) + (beq cr5 @bump) + (la elements 7 elements) + (srwi bytes elements 3) + @bump + (la bytes (+ 4 7) bytes) + (clrrwi bytes bytes 3) + (subi imm5 obj ppc32::fulltag-misc) + (add imm5 imm5 bytes) + (cmpw cr0 imm5 sentinel) + (blt cr0 @loop) + (uuo_interr 0 0) + (b @loop) + @done + (li arg_z nil) + (vpop sentinel) + (vpop obj) + (vpop fun) + (restore-full-lisp-context) + (blr))) + + + +(defun walk-dynamic-area (area func) + (with-other-threads-suspended + (%walk-dynamic-area area func))) + + + +(defppclapfunction %class-of-instance ((i arg_z)) + (svref arg_z instance.class-wrapper i) + (svref arg_z %wrapper-class arg_z) + (blr)) + +(defppclapfunction class-of ((x arg_z)) + (check-nargs 1) + (extract-fulltag imm0 x) + (cmpri imm0 target::fulltag-misc) + (beq @misc) + (extract-lowbyte imm0 x) + (b @done) + @misc + (extract-subtag imm0 x) + @done + (slri imm0 imm0 target::word-shift) + (ldr temp1 '*class-table* nfn) + (addi imm0 imm0 target::misc-data-offset) + (ldr temp1 target::symbol.vcell temp1) + (ldrx temp0 temp1 imm0) ; get entry from table + (cmpri cr0 temp0 nil) + (beq @bad) + ;; functionp? + (extract-typecode imm1 temp0) + (cmpri imm1 target::subtag-function) + (bne @ret) ; not function - return entry + ;; else jump to the fn + (mr nfn temp0) + (ldr temp0 target::misc-data-offset temp0) + (SET-NARGS 1) + (mtctr temp0) + (bctr) + @bad + (ldr fname 'no-class-error nfn) + (ba .spjmpsym) + @ret + (mr arg_z temp0) ; return frob from table + (blr)) + +(defppclapfunction full-gccount () + (ref-global arg_z tenured-area) + (cmpri cr0 arg_z 0) + (if :eq + (ref-global arg_z gc-count) + (ldr arg_z target::area.gc-count arg_z)) + (blr)) + + +(defppclapfunction gc () + (check-nargs 0) + (li imm0 arch::gc-trap-function-gc) + (trlgei allocptr 0) + (li arg_z (target-nil-value)) + (blr)) + + +(defppclapfunction egc ((arg arg_z)) + "Enable the EGC if arg is non-nil, disables the EGC otherwise. Return +the previous enabled status. Although this function is thread-safe (in +the sense that calls to it are serialized), it doesn't make a whole lot +of sense to be turning the EGC on and off from multiple threads ..." + (check-nargs 1) + (subi imm1 arg nil) + (li imm0 arch::gc-trap-function-egc-control) + (trlgei allocptr 0) + (blr)) + + + +(defppclapfunction %configure-egc ((e0size arg_x) + (e1size arg_y) + (e2size arg_z)) + (check-nargs 3) + (li imm0 arch::gc-trap-function-configure-egc) + (trlgei allocptr 0) + (blr)) + +(defppclapfunction purify () + (li imm0 arch::gc-trap-function-purify) + (trlgei allocptr 0) + (li arg_z nil) + (blr)) + + +(defppclapfunction impurify () + (li imm0 arch::gc-trap-function-impurify) + (trlgei allocptr 0) + (li arg_z nil) + (blr)) + +(defppclapfunction lisp-heap-gc-threshold () + "Return the value of the kernel variable that specifies the amount +of free space to leave in the heap after full GC." + (check-nargs 0) + (li imm0 arch::gc-trap-function-get-lisp-heap-threshold) + (trlgei allocptr 0) + #+ppc32-target + (ba .SPmakeu32) + #+ppc64-target + (ba .SPmakeu64)) + +(defppclapfunction set-lisp-heap-gc-threshold ((new arg_z)) + "Set the value of the kernel variable that specifies the amount of free +space to leave in the heap after full GC to new-value, which should be a +non-negative fixnum. Returns the value of that kernel variable (which may +be somewhat larger than what was specified)." + (check-nargs 1) + (mflr loc-pc) + #+ppc32-target + (bla .SPgetu32) + #+ppc64-target + (bla .SPgetu64) + (mtlr loc-pc) + (mr imm1 imm0) + (li imm0 arch::gc-trap-function-set-lisp-heap-threshold) + (trlgei allocptr 0) + #+ppc32-target + (ba .SPmakeu32) + #+ppc64-target + (ba .SPmakeu64)) + + +(defppclapfunction use-lisp-heap-gc-threshold () + "Try to grow or shrink lisp's heap space, so that the free space is(approximately) equal to the current heap threshold. Return NIL" + (check-nargs 0) + (li imm0 arch::gc-trap-function-use-lisp-heap-threshold) + (trlgei allocptr 0) + (li arg_z nil) + (blr)) + + +(defppclapfunction freeze () + "Do a full GC, then consider all heap-allocated objects which survive to be non-relocatable." + (check-nargs 0) + (li imm0 arch::gc-trap-function-freeze) + (trlgei allocptr 0) + #+64-bit-target + (ba .SPmakeu64) + #+32-bit-target + (ba .SPmakeu32)) + +(defppclapfunction flash-freeze () + "Like FREEZE, but don't GC first." + (check-nargs 0) + (li imm0 arch::gc-trap-function-flash-freeze) + (trlgei allocptr 0) + #+64-bit-target + (ba .SPmakeu64) + #+32-bit-target + (ba .SPmakeu32)) + +(defun %watch (uvector) + (declare (ignore uvector)) + (error "watching objects not supported on PPC yet")) + +(defun %unwatch (watched new) + (declare (ignore watched new)) + (error "watching objects not supported on PPC yet")) + +;;; Make a list. This can be faster than doing so by doing CONS +;;; repeatedly, since the latter strategy might triger the GC several +;;; times if N is large. +(defppclapfunction %allocate-list ((initial-element arg_y) (nconses arg_z)) + (check-nargs 2) + (save-lisp-context) + (uuo_interr arch::error-allocate-list rzero) + (vpush arg_z) + (vpush arg_y) + (set-nargs 2) + (ba .SPnvalret)) + +(defppclapfunction %ensure-static-conses () + (check-nargs 0) + (li imm0 arch::gc-trap-function-ensure-static-conses) + (trlgei allocptr 0) + (li arg_z nil) + (blr)) + +;;; offset is a fixnum, one of the target::kernel-import-xxx constants. +;;; Returns that kernel import, a fixnum. +(defppclapfunction %kernel-import ((offset arg_z)) + (ref-global imm0 kernel-imports) + (unbox-fixnum imm1 arg_z) + (ldrx arg_z imm0 imm1) + (blr)) + +(defppclapfunction %get-unboxed-ptr ((macptr arg_z)) + (macptr-ptr imm0 arg_z) + (ldr arg_z 0 imm0) + (blr)) + + +(defppclapfunction %revive-macptr ((p arg_z)) + (li imm0 target::subtag-macptr) + (stb imm0 target::misc-subtag-offset p) + (blr)) + +(defppclapfunction %macptr-type ((p arg_z)) + (check-nargs 1) + (trap-unless-typecode= p target::subtag-macptr) + (svref imm0 target::macptr.type-cell p) + (box-fixnum arg_z imm0) + (blr)) + +(defppclapfunction %macptr-domain ((p arg_z)) + (check-nargs 1) + (trap-unless-typecode= p target::subtag-macptr) + (svref imm0 target::macptr.domain-cell p) + (box-fixnum arg_z imm0) + (blr)) + +(defppclapfunction %set-macptr-type ((p arg_y) (new arg_z)) + (check-nargs 2) + (unbox-fixnum imm1 new) + (trap-unless-typecode= p target::subtag-macptr) + (svset imm1 target::macptr.type-cell p) + (blr)) + +(defppclapfunction %set-macptr-domain ((p arg_y) (new arg_z)) + (check-nargs 2) + (unbox-fixnum imm1 new) + (trap-unless-typecode= p target::subtag-macptr) + (svset imm1 target::macptr.domain-cell p) + (blr)) + +(defppclapfunction true () + (cmplri nargs '3) + (li arg_z t) + (blelr) + (subi imm0 nargs '3) + (add vsp vsp imm0) + (blr)) + +(defppclapfunction false () + (cmplri nargs '3) + (li arg_z nil) + (blelr) + (subi imm0 nargs '3) + (add vsp vsp imm0) + (blr)) + +(lfun-bits #'true #.(encode-lambda-list '(&lap &rest ignore))) +(lfun-bits #'false #.(encode-lambda-list '(&lap &rest ignore))) + +;;; end