[Openmcl-cvs-notifications] r15093 - in /trunk/source: compiler/ compiler/ARM/ compiler/PPC/PPC32/ compiler/PPC/PPC64/ compiler/X86/X8632/ compiler/X86/X8664/ level-0/ level-0/ARM/ level-1/ lib/ lisp-kernel/ xdump/
gb at clozure.com
gb at clozure.com
Mon Nov 28 12:33:00 CST 2011
Author: gb
Date: Mon Nov 28 12:32:59 2011
New Revision: 15093
Log:
New Linux ARM binaries.
The image and FASL versions changed on the ARM, but (if I did it right)
not on other platforms.
(The image and FASL versions are now architecture-specific. This may
make it somewhat easier and less disruptive to change them, since the
motivation for such a change is often also architecture-specific.)
The FASL and current image version are defined (in the "TARGET" package)
in the architecture-specific *-arch.lisp files; the min, max, and current
image versions are defined in the *constants*.h file for the architecture.
Most of the changes are ARM-specific. =
Each TCR now contains a 256-word table at byte offset 256. (We've
been using about 168 bytes in the TCR, so there are still 88 bytes/22
words left for expansion.) The table is initialized at TCR-creation
time to contain the absolute addresses of the subprims (there are
currently around 130 defined); we try otherwise not to reference
subprims by absolute address. Jumping to a subprim is:
(ldr pc (:@ rcontext (:$ offset-of-subprim-in-tcr-table)))
and calling one involves loading its address from that table into a
register and doing (blx reg). We canonically use LR as the register,
since it's going to be clobbered by the blx anyway and there doesn't
seem to be a performance hazard there. The old scheme (which involved
using BA and BLA pseudoinstructions to jump to/call a hidden jump table
at the end of the function) is no longer supported.
ARM Subprims no longer need to be aligned (on anything more than an
instruction boundary.) Some remnants of the consequences of an old
scheme (where subprims had to "fit" in small regions and sometimes
had to jump out of line if they would overflow that region's bounds)
still remain, but we can repair that (and it'll be a bit more straightforwa=
rd
to add new ARM subprims.) We no longer care (much) about where subprims
are mapped in memory, and don't have to bias suprimitive addresses by
a platform-specific constant (and have to figure out whether or not we've
already done so) on (e.g.) Android.
Rather than setting the first element (fn.entrypoint) of a
newly-created function to the (absolute) address of a subprim that updates
that entrypoint on the first call, we use a little LAP function to correct
the address before the function can be called.
Non-function objects that can be stored in symbols' function cells
(the UNDEFINED-FUNCTION object, the things that encapsulate
special-operator names and global macro-functions) need to be
structured like FUNCTIONS: the need to have a word-aligned entrypoint
in element 0 that tracks the CODE-VECTOR object in element 1. We
don't want these things to be of type FUNCTION, but do want the GC to
adjust the entrypoint if the codevector moves. We've been essentially
out of GVECTOR subtags on 32-bit platforms, largely because of the
constraints that vector/array subtags must be greater than other
subtags and numeric types be less. The first constraint is probably
reasonable, but the second isn't: other typecodes (tag-list, etc) may
be less than the maximum numeric typecode, so tests like NUMBERP can't
reliably involve a simple comparison. (As long as a mask of all
numeric typecodes will fit in a machine word/FIXNUM, a simple LOGBITP
test can be used instead.) Removed all portable and ARM-specific code
that made assumptions about numeric typecode ordering, made a few more
gvector typecodes available, and used one of them to define a new
"pseudofunction" type. Made the GC update the entrypoints of
pseudofunctions and used them for the undefined-function object and
for the function cells of macros/special-operators.
Since we don't need the subprim jump table at the end of each function
anymore, we can more easily revive the idea of embedded pc-relative
constant data ("constant pools") and initialize FPRs from constant
data, avoiding most remaining traffic between FPRs and GPRs.
I've had a fairly-reproducible cache-coherency problem: on the first
GC in the cold load, the thread misbehaves mysteriously when it
resumes. The GC tries to synchronize the I and D caches on the entire
range of addresses that may contain newly-moved code-vectors. I'm not
at all sure why, but walking that range and flushing the cache for
each code-vector individually seems to avoid the problem (and may actually
be faster.)
Fix ticket:894
Fixed a few typos in error messages/comments/etc.
I -think- that the non-ARM-specific changes (how FASL/image versions are
defined) should bootstrap cleanly, but won't know for sure until this is
committed. (I imagine that the buildbot will complain if not.)
Modified:
trunk/source/compiler/ARM/arm-arch.lisp
trunk/source/compiler/ARM/arm-asm.lisp
trunk/source/compiler/ARM/arm-backend.lisp
trunk/source/compiler/ARM/arm-disassemble.lisp
trunk/source/compiler/ARM/arm-lap.lisp
trunk/source/compiler/ARM/arm-lapmacros.lisp
trunk/source/compiler/ARM/arm-vinsns.lisp
trunk/source/compiler/ARM/arm2.lisp
trunk/source/compiler/PPC/PPC32/ppc32-arch.lisp
trunk/source/compiler/PPC/PPC64/ppc64-arch.lisp
trunk/source/compiler/X86/X8632/x8632-arch.lisp
trunk/source/compiler/X86/X8664/x8664-arch.lisp
trunk/source/compiler/optimizers.lisp
trunk/source/level-0/ARM/arm-array.lisp
trunk/source/level-0/ARM/arm-bignum.lisp
trunk/source/level-0/ARM/arm-clos.lisp
trunk/source/level-0/ARM/arm-def.lisp
trunk/source/level-0/ARM/arm-float.lisp
trunk/source/level-0/ARM/arm-hash.lisp
trunk/source/level-0/ARM/arm-misc.lisp
trunk/source/level-0/ARM/arm-numbers.lisp
trunk/source/level-0/ARM/arm-pred.lisp
trunk/source/level-0/ARM/arm-symbol.lisp
trunk/source/level-0/ARM/arm-utils.lisp
trunk/source/level-0/l0-def.lisp
trunk/source/level-0/l0-error.lisp
trunk/source/level-0/l0-hash.lisp
trunk/source/level-0/l0-pred.lisp
trunk/source/level-0/l0-symbol.lisp
trunk/source/level-0/l0-utils.lisp
trunk/source/level-0/nfasload.lisp
trunk/source/level-1/arm-callback-support.lisp
trunk/source/level-1/l1-clos-boot.lisp
trunk/source/level-1/l1-clos.lisp
trunk/source/level-1/l1-dcode.lisp
trunk/source/level-1/l1-sockets.lisp
trunk/source/level-1/l1-typesys.lisp
trunk/source/lib/nfcomp.lisp
trunk/source/lisp-kernel/arm-asmutils.s
trunk/source/lisp-kernel/arm-constants.h
trunk/source/lisp-kernel/arm-constants.s
trunk/source/lisp-kernel/arm-exceptions.c
trunk/source/lisp-kernel/arm-gc.c
trunk/source/lisp-kernel/arm-spentry.s
trunk/source/lisp-kernel/image.c
trunk/source/lisp-kernel/image.h
trunk/source/lisp-kernel/lisp-debug.c
trunk/source/lisp-kernel/pmcl-kernel.c
trunk/source/lisp-kernel/ppc-constants32.h
trunk/source/lisp-kernel/ppc-constants64.h
trunk/source/lisp-kernel/thread_manager.c
trunk/source/lisp-kernel/x86-constants32.h
trunk/source/lisp-kernel/x86-constants64.h
trunk/source/xdump/faslenv.lisp
trunk/source/xdump/heap-image.lisp
trunk/source/xdump/xarmfasload.lisp
trunk/source/xdump/xfasload.lisp
Modified: trunk/source/compiler/ARM/arm-arch.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/compiler/ARM/arm-arch.lisp (original)
+++ trunk/source/compiler/ARM/arm-arch.lisp Mon Nov 28 12:32:59 2011
@@ -288,21 +288,20 @@
=
=
(eval-when (:compile-toplevel :load-toplevel :execute)
-(defparameter *arm-subprims-shift* 8)
-(defparameter *arm-subprims-base* (ash 9 12) )
+(defparameter *arm-subprims-shift* 2)
+(defconstant tcr.sptab 256)
+(defparameter *arm-subprims-base* tcr.sptab )
)
(defvar *arm-subprims*)
=
-;;; For now, nothing's nailed down and we don't say anything about
-;;; registers clobbered.
+
(let* ((origin *arm-subprims-base*)
(step (ash 1 *arm-subprims-shift*)))
(flet ((define-arm-subprim (name)
(ccl::make-subprimitive-info :name (string name)
- :offset (prog1 origin
- (when (=3D origin #x10=
000)
- (setq step (ash 1 10=
)))
- (incf origin step)))))
+ :offset
+ (prog1 origin
+ (incf origin step)))))
(macrolet ((defarmsubprim (name)
`(define-arm-subprim ',name)))
(setq *arm-subprims*
@@ -566,18 +565,10 @@
=
;;; Numeric subtags.
(define-imm-subtag bignum 0)
-(defconstant min-numeric-subtag subtag-bignum)
(define-node-subtag ratio 1)
-(defconstant max-rational-subtag subtag-ratio)
-
(define-imm-subtag single-float 1) ; "SINGLE" float, aka short-fl=
oat in the new order.
(define-imm-subtag double-float 2)
-(defconstant min-float-subtag subtag-single-float)
-(defconstant max-float-subtag subtag-double-float)
-(defconstant max-real-subtag subtag-double-float)
-
(define-node-subtag complex 3)
-(defconstant max-numeric-subtag subtag-complex)
=
;;; CL array types. There are more immediate types than node types; all C=
L array subtags must be > than
;;; all non-CL-array subtags. So we start by defining the immediate subta=
gs in decreasing order, starting
@@ -613,12 +604,11 @@
(defconstant min-vector-subtag subtag-vectorH)
(defconstant min-array-subtag subtag-arrayH)
=
-;;; So, we get the remaining subtags (n: (n > max-numeric-subtag) & (n < m=
in-array-subtag))
+;;; So, we get the remaining subtags (n: (n < min-array-subtag))
;;; for various immediate/node object types.
=
+(define-node-subtag pseudofunction 0)
(define-imm-subtag macptr 3)
-(defconstant min-non-numeric-imm-subtag subtag-macptr)
-(assert (> min-non-numeric-imm-subtag max-numeric-subtag))
(define-imm-subtag dead-macptr 4)
(define-imm-subtag code-vector 5)
(define-imm-subtag creole-object 6)
@@ -628,7 +618,6 @@
=
(define-node-subtag catch-frame 4)
(defconstant min-non-numeric-node-subtag subtag-catch-frame)
-(assert (> min-non-numeric-node-subtag max-numeric-subtag))
(define-node-subtag function 5)
(define-node-subtag basic-stream 6)
(define-node-subtag symbol 7)
@@ -878,6 +867,7 @@
shutdown-count
safe-ref-address
)
+
=
(defconstant interrupt-level-binding-index (ash 1 fixnumshift))
=
@@ -1074,7 +1064,9 @@
(:double-float-vector . ,subtag-double-float-vector )
(:simple-vector . ,subtag-simple-vector )
(:vector-header . ,subtag-vectorH)
- (:array-header . ,subtag-arrayH)))
+ (:array-header . ,subtag-arrayH)
+ (:xfunction . ,subtag-xfunction)
+ (:pseudofunction . ,subtag-pseudofunction)))
=
=
;;; This should return NIL unless it's sure of how the indicated
@@ -1162,7 +1154,8 @@
:pool :population :hash-vector
:package :value-cell :instance
:lock :slot-vector
- :simple-vector)
+ :simple-vector :xfunction
+ :pseudofunction)
:1-bit-ivector-types '(:bit-vector)
:8-bit-ivector-types '(:signed-8-bit-vector
:unsigned-8-bit-vector)
@@ -1391,9 +1384,7 @@
(defconstant ufe 11) ;underflow enable
(defconstant ixe 12) ;inexact enable
=
-;;; A function's entrypoint should initially reference .SPfix-nfn-entrypoi=
nt,
-;;; which will set it to a locative to the function's code-vector.
-(defconstant *function-initial-entrypoint* (ash *arm-subprims-base* (- arm=
::fixnumshift)))
+
=
;;; These are always stack-allocated, "near" where the missing lisp frame
;;; that they represent would be.
@@ -1419,5 +1410,9 @@
(defconstant numeric-tags-mask (logior real-tags-mask (ash 1 subtag-comple=
x)))
=
=
+(defconstant fasl-version #x60)
+(defconstant fasl-max-version #x60)
+(defconstant fasl-min-version #x60)
+(defparameter *image-abi-version* 1038)
=
(provide "ARM-ARCH")
Modified: trunk/source/compiler/ARM/arm-asm.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/compiler/ARM/arm-asm.lisp (original)
+++ trunk/source/compiler/ARM/arm-asm.lisp Mon Nov 28 12:32:59 2011
@@ -43,20 +43,20 @@
=
(defvar *arm-constants* ())
(defvar *lap-labels* ())
-(defvar *called-subprim-jmp-labels* ())
-
-
-
-
-(defun arm-subprimitive-address (x)
+
+
+
+
+
+
+(defun arm-subprimitive-offset (x)
(if (and x (or (symbolp x) (stringp x)))
(let* ((info (find x arm::*arm-subprims* :test #'string-equal :key #'c=
cl::subprimitive-info-name)))
(when info
- (+ (ccl::backend-real-subprims-bias ccl::*target-backend*)
- (ccl::subprimitive-info-offset info))))))
+ (ccl::subprimitive-info-offset info)))))
=
(defun arm-subprimitive-name (addr)
- (let* ((info (find (- addr (ccl::backend-real-subprims-bias ccl::*target=
-backend*)) arm::*arm-subprims* :key #'ccl::subprimitive-info-offset)))
+ (let* ((info (find addr arm::*arm-subprims* :key #'ccl::subprimitive-inf=
o-offset)))
(when info
(string (ccl::subprimitive-info-name info)))))
=
@@ -125,6 +125,7 @@
:imm16
:srcount ;single register count
:drcount
+ :spentry
))
=
(defun %encode-arm-operand-type (name)
@@ -529,6 +530,14 @@
#x049a0004
#x0fff0fff
())
+ (define-arm-instruction spjump (:spentry)
+ #x0593f000
+ #x0ffff000
+ ())
+ (define-arm-instruction sploadlr (:spentry)
+ #x0593e000
+ #x0ffff000
+ ())
(define-arm-instruction ldr (:rd :mem12)
#x04100000
#x0c500000
@@ -645,16 +654,7 @@
#x0b000000
#x0f000000
())
- ;; BA and BLA are indistinguishable from B/BL in their
- ;; generated code; they branch to/call subprim glue.
- (define-arm-instruction ba (:subprim)
- #x0a000000
- #x0f000000
- ()) =
- (define-arm-instruction bla (:subprim)
- #x0b000000
- #x0f000000
- ()) =
+ =
(define-arm-instruction bx (:rm)
#x012fff10
#x0ffffff0
@@ -1251,7 +1251,7 @@
(let* ((mode (car form)))
(if (eq mode :=3D)
(destructuring-bind (label) (cdr form)
- (when (arm::arm-subprimitive-address label)
+ (when (arm::arm-subprimitive-offset label)
(error "Invalid label in ~s." form))
(set-field-value instruction (byte 4 16) arm::pc)
(set-field-value instruction (byte 1 24) 1) ;P bit
@@ -1379,18 +1379,19 @@
(lap-note-label-reference form instruction :b))
=
(defun parse-subprim-operand (form instruction)
+ (declare (ignore form instruction))
+ (ccl::compiler-bug "Obsolete operand type :SUBPRIM."))
+
+(defun parse-spentry-operand (form instruction)
(multiple-value-bind (addr name)
(if (typep form 'fixnum)
(values form
(arm-subprimitive-name form))
- (values (arm-subprimitive-address form)
+ (values (arm-subprimitive-offset form)
form))
(unless (and name addr)
(error "~s is not the name or address of an ARM subprimitive." form))
- (let* ((lab (or (find-lap-label name)
- (make-lap-label name))))
- (pushnew lab *called-subprim-jmp-labels*)
- (push (cons instruction :b) (lap-label-refs lab)))))
+ (set-field-value instruction (byte 12 0) addr)))
=
=
=
@@ -1452,20 +1453,24 @@
(defun parse-fpaddr-operand (form instruction)
(if (atom form)
(error "Invalid FP address: ~s" form)
- (destructuring-bind (op rn offset) form
- (unless (eq op :@)
- (error "Invalid FP addressing mode ~s in ~s." op form))
- (set-field-value instruction (byte 4 16) (need-arm-gpr rn))
- (unless (and (consp offset) (eq (car offset) :$))
- (error "Invalid FP address offset ~s in ~s." offset form))
- (destructuring-bind (offset-form) (cdr offset)
- (let* ((offset-val (eval offset-form)))
- (when (logtest offset-val 3)
- (error "FP address offset ~s must be a multiple of 4 in ~s." o=
ffset form))
- (if (< offset-val 0)
- (setq offset-val (- offset-val))
- (set-field-value instruction (byte 1 23) 1))
- (set-field-value instruction (byte 8 0) (ash offset-val -2)))))))
+ (if (eq (car form) :=3D)
+ (destructuring-bind (label) (cdr form)
+ (set-field-value instruction (byte 4 16) pc)
+ (lap-note-label-reference label instruction :fpmem))
+ (destructuring-bind (op rn offset) form
+ (unless (eq op :@)
+ (error "Invalid FP addressing mode ~s in ~s." op form))
+ (set-field-value instruction (byte 4 16) (need-arm-gpr rn))
+ (unless (and (consp offset) (eq (car offset) :$))
+ (error "Invalid FP address offset ~s in ~s." offset form))
+ (destructuring-bind (offset-form) (cdr offset)
+ (let* ((offset-val (eval offset-form)))
+ (when (logtest offset-val 3)
+ (error "FP address offset ~s must be a multiple of 4 in ~s."=
offset form))
+ (if (< offset-val 0)
+ (setq offset-val (- offset-val))
+ (set-field-value instruction (byte 1 23) 1))
+ (set-field-value instruction (byte 8 0) (ash offset-val -2))))=
))))
=
(defun parse- at rn-operand (form instruction)
(when (or (atom form)
@@ -1503,6 +1508,7 @@
parse-imm16-operand
parse-srcount-operand
parse-drcount-operand
+ parse-spentry-operand
))
=
=
@@ -1642,9 +1648,8 @@
=
=
=
-(defun arm-finalize (seg)
- (let* ((data-labels ())
- (removed nil))
+(defun arm-finalize (seg &optional drained)
+ (let* ((removed nil))
(do-lap-labels (lab)
(loop
(when (dolist (ref (lap-label-refs lab) t) =
@@ -1658,27 +1663,16 @@
(return))))
(when removed
(set-element-addresses 0 seg))
- (dolist (jmp-label *called-subprim-jmp-labels*)
- (let* ((spname (lap-label-name jmp-label))
- (data-label-name (cons spname (arm-subprimitive-address spnam=
e)))
- (data-label (make-lap-label data-label-name)))
- (push data-label data-labels)
- (emit-lap-label seg spname)
- (assemble-instruction seg `(ldr pc (:=3D ,data-label-name)))))
+
=
- (let* ((marker (make-lap-instruction nil))
- (code-count (make-lap-instruction nil)))
- (emit-lap-instruction-element marker seg)
- (emit-lap-instruction-element code-count seg)
- (set-field-value code-count (byte 32 0) (ash (section-size seg) -2)))
+ (unless drained
+ (let* ((marker (make-lap-instruction nil))
+ (code-count (make-lap-instruction nil)))
+ (emit-lap-instruction-element marker seg)
+ (emit-lap-instruction-element code-count seg)
+ (set-field-value code-count (byte 32 0) (ash (section-size seg) -2=
))))
=
- (dolist (data-label (nreverse data-labels))
- (let* ((name (lap-label-name data-label))
- (addr (cdr name)))
- (emit-lap-label seg name)
- (let* ((insn (make-lap-instruction nil)))
- (set-field-value insn (byte 32 0) addr)
- (emit-lap-instruction-element insn seg))))
+
=
=
;; Now fix up label references. Recall that the PC value at some
@@ -1691,13 +1685,15 @@
(let* ((diff-in-bytes (- labaddr (+ 8 (lap-instruction-addre=
ss insn)))))
(case reftype
(:b (set-field-value insn (byte 24 0) (ash diff-in-bytes=
-2)))
- (:mem12
+ ((:mem12 :fpmem)
(if (>=3D diff-in-bytes 0)
(set-field-value insn (byte 1 23) 1)
(setq diff-in-bytes (- diff-in-bytes)))
(when (> (integer-length diff-in-bytes) 12)
(error "PC-relative displacement can't be encoded."))
- (set-field-value insn (byte 12 0) diff-in-bytes))
+ (if (eq reftype :fpmem)
+ (set-field-value insn (byte 8 0) (ash diff-in-bytes -=
2))
+ (set-field-value insn (byte 12 0) diff-in-bytes)))
(:offset
(set-field-value insn (byte 32 0)(1+ (ash (lap-instruct=
ion-address insn) (- arm::word-shift)))))
(t
@@ -1800,6 +1796,8 @@
:srcount
:drcount
:reglist
+ :spentry
+ :fplabel
)))
=
(defmacro encode-vinsn-field-type (name)
@@ -1835,6 +1833,7 @@
vinsn-parse-imm16-operand
vinsn-parse-srcount-operand
vinsn-parse-drcount-operand
+ vinsn-parse-spentry-operand
))
=
(defun vinsn-arg-or-gpr (avi form vinsn-params encoded-type bytespec)
@@ -2060,10 +2059,22 @@
(addr nil))
(cond (p
(add-avi-operand avi (encode-vinsn-field-type :subprim) (list p=
)))
- ((setq addr (arm-subprimitive-address value))
+ ((setq addr (arm-subprimitive-offset value))
(add-avi-operand avi (encode-vinsn-field-type :subprim) addr))
((arm-subprimitive-name value)
(add-avi-operand avi (encode-vinsn-field-type :subprim) value))=
=
+ (t
+ (error "Unknown subprimitive name or address: ~s." value)))))
+
+(defun vinsn-parse-spentry-operand (avi value vinsn-params)
+ (let* ((p (position value vinsn-params))
+ (addr nil))
+ (cond (p
+ (add-avi-operand avi (encode-vinsn-field-type :spentry) (list p=
)))
+ ((setq addr (arm-subprimitive-offset value))
+ (add-avi-operand avi (encode-vinsn-field-type :spentry) addr))
+ ((arm-subprimitive-name value)
+ (add-avi-operand avi (encode-vinsn-field-type :spentry) value))=
=
(t
(error "Unknown subprimitive name or address: ~s." value)))))
=
@@ -2136,19 +2147,28 @@
(vinsn-arg-or-gpr avi value vinsn-params (encode-vinsn-field-type :rs) (=
byte 4 8)))
=
(defun vinsn-parse-fpaddr-operand (avi value vinsn-params)
- (destructuring-bind (op rn offset) value
- (unless (eq op :@) (error "Bad FP address operand: ~s." value))
- (vinsn-arg-or-gpr avi rn vinsn-params (encode-vinsn-field-type :rn) (b=
yte 4 16))
- (destructuring-bind (marker offform) offset
- (unless (eq marker :$) (error "Bad FP offset: ~s" offset))
- (let* ((offval (vinsn-arg-or-constant avi offform vinsn-params (enco=
de-vinsn-field-type :fpaddr-offset) nil)))
- (when offval
- (if (< offval 0)
- (setq offval (- offval))
- (set-avi-opcode-field avi (byte 1 23) 1))
- (when (logtest 3 offval)
- (error "Memory offset ~s must be a multiple of 4." offval))
- (set-avi-opcode-field avi (byte 8 0) (ash offval -2)))))))
+ (if (and (consp value) (eq (car value) :=3D))
+ (destructuring-bind (label) (cdr value)
+ (set-avi-opcode-field avi (byte 4 16) arm::pc)
+ (let* ((p (position value vinsn-params)))
+ (cond (p
+ (add-avi-operand avi (encode-vinsn-field-type :fplabel) (li=
st p)))
+ ((typep label 'keyword)
+ (add-avi-operand avi (encode-vinsn-field-type :fplabel) lab=
el))
+ (t (error "Unknown label: ~s" label)))))
+ (destructuring-bind (op rn offset) value
+ (unless (eq op :@) (error "Bad FP address operand: ~s." value))
+ (vinsn-arg-or-gpr avi rn vinsn-params (encode-vinsn-field-type :rn) =
(byte 4 16))
+ (destructuring-bind (marker offform) offset
+ (unless (eq marker :$) (error "Bad FP offset: ~s" offset))
+ (let* ((offval (vinsn-arg-or-constant avi offform vinsn-params (en=
code-vinsn-field-type :fpaddr-offset) nil)))
+ (when offval
+ (if (< offval 0)
+ (setq offval (- offval))
+ (set-avi-opcode-field avi (byte 1 23) 1))
+ (when (logtest 3 offval)
+ (error "Memory offset ~s must be a multiple of 4." offval))
+ (set-avi-opcode-field avi (byte 8 0) (ash offval -2))))))))
=
(defun vinsn-parse-imm16-operand (avi value vinsn-params)
(unless (and (consp value)
@@ -2253,6 +2273,8 @@
vinsn-insert-srcount-operand
vinsn-insert-drcount-operand
vinsn-insert-reglist-operand
+ vinsn-insert-spentry-operand
+ vinsn-insert-fplabel-operand
))
=
(defun vinsn-insert-cond-operand (instruction value)
@@ -2320,13 +2342,27 @@
(make-lap-label value))))))
(push (cons instruction :b) (lap-label-refs label))))
=
+(defun vinsn-insert-fplabel-operand (instruction value)
+ (let* ((label (etypecase value
+ (cons (or (find-lap-label value)
+ (error "No LAP label for ~s." (car value))))
+ (lap-label value)
+ (ccl::vinsn-label
+ (or (find-lap-label value)
+ (make-lap-label value))))))
+ (push (cons instruction :fpmem) (lap-label-refs label))))
+
(defun vinsn-insert-subprim-operand (instruction value)
- (let* ((name (or (arm-subprimitive-name value)
- (arm-subprimitive-name (+ value (ccl::backend-real-subp=
rims-bias ccl::*target-backend*)))))
- (label (or (find-lap-label name)
- (make-lap-label name))))
- (pushnew label *called-subprim-jmp-labels*)
- (push (cons instruction :b) (lap-label-refs label))))
+ (declare (ignorable instruction value))
+ (ccl::compiler-bug "Obsolete SUBPRIM vinsn operand."))
+
+(defun vinsn-insert-spentry-operand (instruction value)
+ (unless (and (typep value 'fixnum)
+ (>=3D value arm::tcr.sptab)
+ (< value (+ arm::tcr.sptab (* 256 4)))
+ (not (logtest value 3)))
+ (error "Bad subprim index: ~s" value))
+ (set-field-value instruction (byte 12 0) value))
=
=
=
@@ -2336,6 +2372,8 @@
(error "Mystery data label: ~s" value))
(push (cons instruction :mem12) (lap-label-refs label))))
=
+
+
(defun vinsn-insert-dd-operand (instruction value)
(set-field-value instruction (byte 4 12) value) )
=
Modified: trunk/source/compiler/ARM/arm-backend.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/compiler/ARM/arm-backend.lisp (original)
+++ trunk/source/compiler/ARM/arm-backend.lisp Mon Nov 28 12:32:59 2011
@@ -106,7 +106,7 @@
(declare (list pair))
(if pair
(cdr pair)
- (or (subprim-name->offset n backend)
+ (or (arm::arm-subprimitive-offset n)
(error "Unknown name ~s" n))))))
(labels ((simplify-operand (op)
(if (atom op)
@@ -167,7 +167,7 @@
(mapcar #'simplify-form opvals))
(if (keywordp opname)
(ecase opname
- ((:code :data) form)
+ ((:code :data :drain-constant-pool) fo=
rm)
(:word (destructuring-bind (val) opvals
(list opname
(let* ((p (position val =
name-list)))
@@ -271,8 +271,7 @@
:name :androidarm
:target-arch-name :arm
:target-foreign-type-data nil
- :target-arch arm::*arm-target-arch*
- :lowmem-bias (cons 0 (- #x04002000 #x9000))))
+ :target-arch arm::*arm-target-arch*))
=
#+(or linuxarm-target (not arm-target))
(pushnew *linuxarm-backend* *known-arm-backends* :key #'backend-name)
Modified: trunk/source/compiler/ARM/arm-disassemble.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/compiler/ARM/arm-disassemble.lisp (original)
+++ trunk/source/compiler/ARM/arm-disassemble.lisp Mon Nov 28 12:32:59 2011
@@ -69,10 +69,17 @@
=
(defun extract-arm-fpaddr-operand (opcodes i)
(let* ((opcode (adi-opcode (svref opcodes i)))
- (offset (ash (ldb (byte 8 0) opcode) 2)))
+ (offset (ash (ldb (byte 8 0) opcode) 2))
+ (rn (ldb (byte 4 16) opcode)))
(unless (logbitp 23 opcode)
(setq offset (- offset)))
- `(:@ ,(arm-gpr-name (ldb (byte 4 16) opcode)) (:$ ,offset))))
+ (cond ((eql rn arm::pc)
+ (let* ((target (+ i 2 (ash offset -2))))
+ (when (and (>=3D target 0)
+ (< target (uvsize opcodes)))
+ (setf (adi-labeled (uvref opcodes target)) t))
+ `(:=3D (:label ,target))))
+ (t `(:@ ,(arm-gpr-name rn) (:$ ,offset))))))
=
(defun extract-arm- at rn-operand (opcodes i)
(let* ((opcode (adi-opcode (svref opcodes i))))
@@ -294,6 +301,13 @@
(let* ((opcode (adi-opcode (svref opcodes i))))
(ldb (byte 7 1) opcode)))
=
+(defun extract-arm-spentry-operand (opcodes i)
+ (let* ((opcode (adi-opcode (svref opcodes i)))
+ (val (ldb (byte 12 0) opcode)))
+ `(:spname ,(or (arm::arm-subprimitive-name val)
+ (format nil "??? subprim ~d" val)))))
+ =
+
(defparameter *arm-operand-extract-functions*
#(extract-arm-rd-operand
extract-arm-rn-operand
@@ -323,6 +337,7 @@
extract-arm-imm16-operand
extract-arm-srcount-operand
extract-arm-drcount-operand
+ extract-arm-spentry-operand
))
=
(defun make-adi-vector (code-vector)
@@ -335,34 +350,22 @@
=
(defun process-adi-vector (adi-vector)
(let* ((n (length adi-vector))
- (data nil))
+ (data nil)
+ (data-count 0))
(declare (fixnum n))
- (do* ((i (1- n) (1- i)))
- ((< i 0))
- (declare (fixnum i))
- (let* ((adi (svref adi-vector i))
- (opcode (adi-opcode adi)))
- (when (=3D opcode 0)
- (do* ((w (1- n) (1- w))
- (j (1- i) (1- j))
- (ndata (- n (1+ i)) (1- ndata)))
- ((zerop ndata))
- (let* ((addr (adi-opcode (svref adi-vector w)))
- (jmp (svref adi-vector j)))
- (setf (adi-labeled jmp)
- (arm::arm-subprimitive-name addr))))
- (return))))
(do* ((i 0 (1+ i)))
((=3D i n) adi-vector)
(declare (fixnum i))
(let* ((adi (svref adi-vector i))
(opcode (adi-opcode adi)))
- (cond ((=3D opcode 0)
+ (cond (data (setq data-count opcode data nil))
+ ((> data-count 0)
+ (setf (adi-mnemonic adi) ":word"
+ (adi-operands adi) (list (adi-opcode adi)))
+ (decf data-count))
+ ((=3D opcode 0)
(setq data t)
(incf i))
- (data
- (setf (adi-mnemonic adi) ":word"
- (adi-operands adi) (list (adi-opcode adi))))
(t
(let* ((template (find-arm-instruction-template opcode)))
(if (null template)
Modified: trunk/source/compiler/ARM/arm-lap.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/compiler/ARM/arm-lap.lisp (original)
+++ trunk/source/compiler/ARM/arm-lap.lisp Mon Nov 28 12:32:59 2011
@@ -63,19 +63,23 @@
=
(defun %define-arm-lap-function (name body &optional (bits 0))
(with-dll-node-freelist (primary arm::*lap-instruction-freelist*)
+ (with-dll-node-freelist (data arm::*lap-instruction-freelist*)
+ =
(let* ((arm::*lap-labels* ())
- (arm::*called-subprim-jmp-labels* ())
(name-cell (list name))
(arm::*arm-constants* ())
(*arm-lap-lfun-bits* bits)
- (arm::*arm-register-names* arm::*standard-arm-register-names*=
))
+ (current primary)
+ (arm::*arm-register-names* arm::*standard-arm-register-names*)
+ (sections (vector primary data)))
+ (declare (dynamic-extent primary))
(dolist (form body)
- (arm-lap-form form primary))
+ (setq current (arm-lap-form form current sections)))
(rplacd name-cell (length arm::*arm-constants*))
(push name-cell arm::*arm-constants*)
(arm-lap-generate-code primary
- (arm::arm-finalize primary)
- *arm-lap-lfun-bits*))))
+ (arm::arm-finalize primary (arm-drain-const=
ant-pool primary data))
+ *arm-lap-lfun-bits*)))))
=
=
=
@@ -130,38 +134,95 @@
(setf (uvref constants-vector (+ 2 k)) imm)))
(setf (uvref constants-vector (1- constants-size)) bits ; lfun-bits
(uvref constants-vector 1) code-vector
- (uvref constants-vector 0) (ash (arm::arm-subprimitive-address=
'.SPfix-nfn-entrypoint) (- arm::fixnumshift)))
- #+arm-target (%make-code-executable code-vector)
+ (uvref constants-vector 0) 0)
+ #+arm-target (progn
+ (%fix-fn-entrypoint constants-vector)
+ (%make-code-executable code-vector))
constants-vector)))
=
-(defun arm-lap-pseudo-op (directive arg)
- (ecase directive
- (:arglist (setq *arm-lap-lfun-bits* (encode-lambda-list arg)))))
+;;; This can be called as a result of a :DRAIN-CONSTANT-POOL directive
+;;; or at the end of a function. In either case, it shouldn't be possible
+;;; for code to reach the point where the constants are appended to
+;;; the primary section.
+(defun arm-drain-constant-pool (primary constants &optional force)
+ (let* ((constants-size (arm::section-size constants)))
+ (unless (=3D constants-size 0)
+ (let* ((force-label-name (when force (gensym))))
+ (when force
+ (arm::assemble-instruction primary `(b ,force-label-name)))
+ (when (logtest 7 (arm::section-size primary))
+ (arm::assemble-instruction primary '(nop)))
+ (let* ((marker (arm::make-lap-instruction nil))
+ (code-count (arm::make-lap-instruction nil))
+ (constant-count (arm::make-lap-instruction nil)))
+ (arm::emit-lap-instruction-element marker primary)
+ (arm::emit-lap-instruction-element code-count primary)
+ (arm::set-field-value code-count (byte 32 0) (ash (arm::section-=
size primary) -2))
+ (arm::emit-lap-instruction-element constant-count primary)
+ (arm::set-field-value constant-count (byte 32 0) (ash (arm::sect=
ion-size constants) -2))
+ (do-dll-nodes (element constants)
+ (remove-dll-node element)
+ (arm::emit-lap-instruction-element element primary))
+ (when force (arm::emit-lap-label primary force-label-name))
+ t)))))
+
+ =
+(defun arm-lap-pseudo-op (directive arg current sections)
+ (flet ((check-data-section (directive)
+ (unless (eq current (svref sections 1))
+ (error "~s directive should only be used inside :data section"
+ directive))))
+ (ecase directive
+ (:arglist (setq *arm-lap-lfun-bits* (encode-lambda-list arg)))
+ ((:code :text) (setq current (svref sections 0)))
+ (:data (setq current (svref sections 1))
+ (when (logtest 7 (arm::section-size current))
+ (arm-lap-pseudo-op :word 0 current sections)))
+ (:word (check-data-section :word)
+ (let* ((val (logand #xffffffff (eval arg)))
+ (instruction (arm::make-lap-instruction nil)))
+ (setf (arm::lap-instruction-opcode-low instruction)
+ (ldb (byte 16 0) val)
+ (arm::lap-instruction-opcode-high instruction)
+ (ldb (byte 16 16) val))
+ (arm::emit-lap-instruction-element instruction current)))
+ (:single (check-data-section :single)
+ (arm-lap-pseudo-op :word (single-float-bits (float (eval ar=
g) 0.0)) current sections))
+ (:double (check-data-section :double)
+ (multiple-value-bind (high low)
+ (double-float-bits (float (eval arg) 0.0d0))
+ (arm-lap-pseudo-op :word low current sections)
+ (arm-lap-pseudo-op :word high current sections)))
+ (:drain-constant-pool
+ (setq current (svref sections 0))
+ (arm-drain-constant-pool current (svref sections 1))))
+ current))
=
=
=
-(defun arm-lap-form (form seg)
+(defun arm-lap-form (form current sections)
(if (and form (symbolp form))
- (arm::emit-lap-label seg form)
+ (arm::emit-lap-label current 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 seg)
+ (setq current (arm-lap-form expansion current sections))
(let* ((name (car form)))
(if (keywordp name)
- (arm-lap-pseudo-op name (cadr form))
+ (setq current (arm-lap-pseudo-op name (cadr form) current se=
ctions))
(case name
- ((progn) (dolist (f (cdr form)) (arm-lap-form f seg)))
- ((let) (arm-lap-equate-form (cadr form) (cddr form) seg))
+ ((progn) (dolist (f (cdr form)) (setq current (arm-lap-for=
m f current sections))))
+ ((let) (setq current (arm-lap-equate-form (cadr form) (cdd=
r form) current sections)))
(t
- (arm::assemble-instruction seg form))))))))))
+ (arm::assemble-instruction current form)))))))))
+ current)
=
;;; (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 seg)
+(defun arm-lap-equate-form (eqlist body current sections)
(collect ((symbols)
(values))
(let* ((arm::*arm-register-names* arm::*arm-register-names*))
@@ -181,10 +242,9 @@
(progn
(symbols symbol)
(values (eval value)))))))
-
(progv (symbols) (values)
- (dolist (form body)
- (arm-lap-form form seg))))))
+ (dolist (form body current)
+ (setq current (arm-lap-form form current sections)))))))
=
=
=
Modified: trunk/source/compiler/ARM/arm-lapmacros.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/compiler/ARM/arm-lapmacros.lisp (original)
+++ trunk/source/compiler/ARM/arm-lapmacros.lisp Mon Nov 28 12:32:59 2011
@@ -369,12 +369,16 @@
=
;;; Load the low 32 bits of the integer constant VAL into REG, using movw/=
movt.
(defarmlapmacro lri (reg val)
- (let* ((high (ldb (byte 16 16) val))
- (low (ldb (byte 16 0) val)))
- `(progn
- (movw ,reg (:$ ,low))
- ,@(unless (zerop high)
- `((movt ,reg (:$ ,high)))))))
+ (setq val (eval val))
+ (if (or (arm::encode-arm-immediate val)
+ (arm::encode-arm-immediate (lognot val)))
+ `(mov ,reg (:$ ,val))
+ (let* ((high (ldb (byte 16 16) val))
+ (low (ldb (byte 16 0) val)))
+ `(progn
+ (movw ,reg (:$ ,low))
+ ,@(unless (zerop high)
+ `((movt ,reg (:$ ,high))))))))
=
(defarmlapmacro push-fprs (n)
"Save N fprs starting at d8 on the control stack.
Modified: trunk/source/compiler/ARM/arm-vinsns.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/compiler/ARM/arm-vinsns.lisp (original)
+++ trunk/source/compiler/ARM/arm-vinsns.lisp Mon Nov 28 12:32:59 2011
@@ -32,14 +32,16 @@
;;; Non-volatile FPRs.
(define-arm-vinsn (push-nvfprs :push :multiple :doubleword :csp :predicata=
ble)
(()
- ((n :u16const))
- ((imm0 (:u32 #.arm::imm0))
- (imm1 (:u32 #.arm::imm1))
- (d7 (:double-float #.arm::d7))))
- (movw imm0 (:$ (:apply logior (:apply ash n arm::num-subtag-bits) arm::s=
ubtag-double-float-vector)))
- (mov imm1 (:$ 0))
- (fmdrr d7 imm0 imm1)
- (fstmdbd d7 (:! arm::sp) (:apply + n 1)))
+ ((n :u16const)
+ (header :u16const))
+ ((d7 (:double-float #.arm::d7))))
+ (fldd d7 (:=3D :header))
+ (fstmdbd d7 (:! arm::sp) (:apply + n 1))
+ (:data)
+ :header
+ (:word header)
+ (:word 0)
+ (:code))
=
(define-arm-vinsn (pop-nvfprs :push :multiple :doubleword :csp :predicatab=
le)
(()
@@ -1315,7 +1317,8 @@
(mov imm (:asr src (:$ arm::fixnumshift)))
(fmsr dest imm)
(fsitos dest dest)
- (bla .SPcheck-fpu-exception))
+ (sploadlr .SPcheck-fpu-exception)
+ (blx lr))
=
(define-arm-vinsn (shift-left-variable-word :predicatable)
(((dest :u32))
@@ -1547,7 +1550,8 @@
(bic imm imm (:$ #xff))
(fmxr :fpscr imm)
(faddd result x y)
- (bla .SPcheck-fpu-exception))
+ (sploadlr .SPcheck-fpu-exception)
+ (blx lr))
=
(define-arm-vinsn (double-float--2 :predicatable)
(((result :double-float))
@@ -1564,7 +1568,8 @@
(bic imm imm (:$ #xff))
(fmxr :fpscr imm)
(fsubd result x y)
- (bla .SPcheck-fpu-exception))
+ (sploadlr .SPcheck-fpu-exception)
+ (blx lr))
=
(define-arm-vinsn (double-float*-2 :predicatable)
(((result :double-float))
@@ -1581,7 +1586,8 @@
(bic imm imm (:$ #xff))
(fmxr :fpscr imm)
(fmuld result x y)
- (bla .SPcheck-fpu-exception))
+ (sploadlr .SPcheck-fpu-exception)
+ (blx lr))
=
(define-arm-vinsn (double-float/-2 :predicatable)
(((result :double-float))
@@ -1598,7 +1604,8 @@
(bic imm imm (:$ #xff))
(fmxr :fpscr imm)
(fdivd result x y)
- (bla .SPcheck-fpu-exception))
+ (sploadlr .SPcheck-fpu-exception)
+ (blx lr))
=
(define-arm-vinsn (double-float-negate :predicatable) (((dest :double-floa=
t))
((src :double-float=
)))
@@ -1629,7 +1636,8 @@
(bic imm imm (:$ #xff))
(fmxr :fpscr imm)
(fadds result x y)
- (bla .SPcheck-fpu-exception))
+ (sploadlr .SPcheck-fpu-exception)
+ (blx lr))
=
(define-arm-vinsn (single-float--2 :predicatable)
(((result :single-float))
@@ -1646,7 +1654,8 @@
(bic imm imm (:$ #xff))
(fmxr :fpscr imm)
(fsubs result x y)
- (bla .SPcheck-fpu-exception))
+ (sploadlr .SPcheck-fpu-exception)
+ (blx lr))
=
(define-arm-vinsn (single-float*-2 :predicatable)
(((result :single-float))
@@ -1663,7 +1672,8 @@
(bic imm imm (:$ #xff))
(fmxr :fpscr imm)
(fmuls result x y)
- (bla .SPcheck-fpu-exception))
+ (sploadlr .SPcheck-fpu-exception)
+ (blx lr))
=
(define-arm-vinsn (single-float/-2 :predicatable)
(((result :single-float))
@@ -1680,7 +1690,8 @@
(bic imm imm (:$ #xff))
(fmxr :fpscr imm)
(fdivs result x y)
- (bla .SPcheck-fpu-exception))
+ (sploadlr .SPcheck-fpu-exception)
+ (blx lr))
=
(define-arm-vinsn (single-float-negate :predicatable) (((dest :single-floa=
t))
((src :single-float=
)))
@@ -1938,6 +1949,11 @@
(mov dest (:$ arm::nil-value))
(ldr dest (:@ dest (:$ (:apply + arm::symbol.vcell (arm::nrs-offset %clo=
sure-code%))))))
=
+;;; DEST pretty much has to be the LR, which won't stay alive very long.
+(define-arm-vinsn %codevector-entry (((dest t))
+ ((cv :lisp)))
+ (add dest cv (:$ arm::misc-data-offset)))
+
=
(define-arm-vinsn (single-float-bits :predicatable)
(((dest :u32))
@@ -1946,35 +1962,40 @@
=
(define-arm-vinsn (call-subprim :call :subprim-call) (()
((spno :s32const)))
- (bla spno))
+ (sploadlr spno)
+ (blx lr))
=
(define-arm-vinsn (jump-subprim :jumpLR) (()
((spno :s32const)))
- (ba spno))
+ (spjump spno))
=
;;; Same as "call-subprim", but gives us a place to =
;;; track args, results, etc.
(define-arm-vinsn (call-subprim-0 :call :subprim-call) (((dest t))
((spno :s32const)))
- (bla spno))
+ (sploadlr spno)
+ (blx lr))
=
(define-arm-vinsn (call-subprim-1 :call :subprim-call) (((dest t))
((spno :s32const)
(z t)))
- (bla spno))
+ (sploadlr spno)
+ (blx lr))
=
(define-arm-vinsn (call-subprim-2 :call :subprim-call) (((dest t))
((spno :s32const)
(y t)
(z t)))
- (bla spno))
+ (sploadlr spno)
+ (blx lr))
=
(define-arm-vinsn (call-subprim-3 :call :subprim-call) (((dest t))
((spno :s32const)
(x t)
(y t)
(z t)))
- (bla spno))
+ (sploadlr spno)
+ (blx lr))
=
=
=
@@ -2559,7 +2580,8 @@
(bic imm imm (:$ #xff))
(fmxr :fpscr imm)
(fcvtsd result arg)
- (bla .SPcheck-fpu-exception))
+ (sploadlr .SPcheck-fpu-exception)
+ (blx lr))
=
(define-arm-vinsn single-to-double (((result :double-float))
((arg :single-float)))
@@ -2573,7 +2595,8 @@
(bic imm imm (:$ #xff))
(fmxr :fpscr imm)
(fcvtds result arg)
- (bla .SPcheck-fpu-exception))
+ (sploadlr .SPcheck-fpu-exception)
+ (blx lr))
=
(define-arm-vinsn (store-single :predicatable :sets-lr)
(()
@@ -2738,7 +2761,8 @@
((src :imm))
)
(rsbs arm::arg_z src (:$ 0))
- (blavs .SPfix-overflow))
+ (sploadlrvs .SPfix-overflow)
+ (blxvs lr))
=
=
=
@@ -2951,7 +2975,8 @@
(y :imm))
())
(adds arm::arg_z x y)
- (blavs .SPfix-overflow))
+ (sploadlrvs .SPfix-overflow)
+ (blxvs lr))
=
(define-arm-vinsn fixnum-add-overflow-inline (((dest :lisp))
((x :imm)
@@ -3022,7 +3047,8 @@
((x :imm)
(y :imm)))
(subs arm::arg_z x y)
- (blavs .SPfix-overflow))
+ (sploadlrvs .SPfix-overflow)
+ (blxvs lr))
=
(define-arm-vinsn fixnum-sub-overflow-inline (((dest :lisp))
((x :imm)
@@ -3110,7 +3136,8 @@
(define-arm-vinsn (ref-symbol-value :call :subprim-call)
(((val :lisp))
((sym (:lisp (:ne val)))))
- (bla .SPspecrefcheck))
+ (sploadlr .SPspecrefcheck)
+ (blx lr))
=
(define-arm-vinsn ref-symbol-value-inline (((dest :lisp))
((src (:lisp (:ne dest))))
@@ -3132,7 +3159,8 @@
(define-arm-vinsn (%ref-symbol-value :call :subprim-call)
(((val :lisp))
((sym (:lisp (:ne val)))))
- (bla .SPspecref))
+ (sploadlr .SPspecref)
+ (blx lr))
=
(define-arm-vinsn %ref-symbol-value-inline (((dest :lisp))
((src (:lisp (:ne dest))))
@@ -3151,7 +3179,8 @@
(()
((sym :lisp)
(val :lisp)))
- (bla .SPspecset))
+ (sploadlr .SPspecset)
+ (blx lr))
=
=
(define-arm-vinsn symbol-function (((val :lisp))
@@ -3234,29 +3263,40 @@
((temp (:u32 #.arm::imm0=
))))
((:pred > n 1)
(mov temp (:$ n))
- (bla .SPunbind-n))
+ (sploadlr .SPunbind-n))
((:pred =3D n 1)
- (bla .SPunbind)))
+ (sploadlr .SPunbind))
+ (blx lr))
=
(define-arm-vinsn (zero-double-float-register :predicatable)
(((dest :double-float))
- ()
- ((low :u32)))
- (mov low (:$ 0))
- (fmdrr dest low low))
+ ())
+ (fldd dest (:=3D :zero))
+ (:data)
+ :zero
+ (:word 0)
+ (:word 0)
+ (:code))
=
(define-arm-vinsn (zero-single-float-register :predicatable)
(((dest :single-float))
- ()
- ((temp :imm)))
- (mov temp (:$ 0))
- (fmsr dest temp))
-
-(define-arm-vinsn (load-double-float-constant :predicatable)
+ ())
+ (flds dest (:=3D :zero))
+ (:data)
+ :zero
+ (:word 0)
+ (:code))
+
+(define-arm-vinsn (load-double-float-constant-from-data :predicatable)
(((dest :double-float))
- ((high :u32)
- (low :u32)))
- (fmdrr dest low high))
+ ((high :u32const)
+ (low :u32const)))
+ (fldd dest (:=3D :x))
+ (:data)
+ :x
+ (:word low)
+ (:word high)
+ :code)
=
(define-arm-vinsn (load-single-float-constant :predicatable)
(((dest :single-float))
@@ -3529,7 +3569,8 @@
(define-arm-vinsn (default-optionals :call :subprim-call) (()
((n :u16const)))
(mov imm0 (:$ (:apply ash n 2)))
- (bla .SPdefault-optional-args))
+ (sploadlr .SPdefault-optional-args)
+ (blx lr))
=
;;; fname contains a known symbol
(define-arm-vinsn (call-known-symbol :call) (((result (:lisp arm::arg_z)))
@@ -3764,11 +3805,12 @@
;;; Subprim calls. Done this way for the benefit of VINSN-OPTIMIZE.
(defmacro define-arm-subprim-call-vinsn ((name &rest other-attrs) spno)
`(define-arm-vinsn (,name :call :subprim-call , at other-attrs) (() ())
- (bla ,spno)))
+ (sploadlr ,spno)
+ (blx lr)))
=
(defmacro define-arm-subprim-jump-vinsn ((name &rest other-attrs) spno &op=
tional)
`(define-arm-vinsn (,name :jumpLR , at other-attrs) (() ())
- (ba ,spno)))
+ (spjump ,spno)))
=
=
(define-arm-subprim-call-vinsn (save-values) .SPsave-values)
@@ -3804,7 +3846,7 @@
=
(define-arm-vinsn (tail-funcall-vsp :jumpLR :predicatable) (() ())
(ldmia (:! sp) (imm0 vsp fn lr))
- (ba .SPfuncall))
+ (spjump .SPfuncall))
=
(define-arm-subprim-call-vinsn (spread-lexpr) .SPspread-lexprz)
=
@@ -3833,6 +3875,13 @@
(define-arm-subprim-call-vinsn (make-stack-vector) .SPmkstackv)
=
(define-arm-subprim-call-vinsn (make-stack-gvector) .SPstkgvector)
+(define-arm-vinsn (make-stack-closure :call :subprim-call) (() ())
+ (sploadlr .SPstkgvector)
+ (blx lr)
+ (ldr lr (:@ arg_z (:$ arm::function.codevector)))
+ (add lr lr (:$ arm::misc-data-offset))
+ (str lr (:@ arg_z (:$ arm::function.entrypoint))))
+ =
=
(define-arm-subprim-call-vinsn (stack-misc-alloc) .SPstack-misc-alloc)
=
@@ -3880,7 +3929,8 @@
=
(define-arm-vinsn (nth-value :call :subprim-call) (((result :lisp))
())
- (bla .SPnthvalue))
+ (sploadlr .SPnthvalue)
+ (blx lr))
=
(define-arm-subprim-call-vinsn (fitvals) .SPfitvals)
=
@@ -3896,7 +3946,8 @@
;;; transfer & jump ...)
(define-arm-vinsn (throw :jump-unknown) (()
())
- (bla .SPthrow))
+ (sploadlr .SPthrow)
+ (blx lr))
=
(define-arm-subprim-call-vinsn (mkcatchmv) .SPmkcatchmv)
=
Modified: trunk/source/compiler/ARM/arm2.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/compiler/ARM/arm2.lisp (original)
+++ trunk/source/compiler/ARM/arm2.lisp Mon Nov 28 12:32:59 2011
@@ -299,7 +299,7 @@
(arm2-copy-register seg arm::arg_z valreg)
(arm2-stack-to-register seg ea arm::arg_x)
(arm2-lri seg arm::arg_y 0)
- (! call-subprim-3 arm::arg_z (arm::arm-subprimitive-address '.=
SPgvset) arm::arg_x arm::arg_y arm::arg_z)
+ (! call-subprim-3 arm::arg_z (arm::arm-subprimitive-offset '.S=
Pgvset) arm::arg_x arm::arg_y arm::arg_z)
(setq valreg arm::arg_z))
((memory-spec-p ea) ; vstack slot
(arm2-register-to-stack seg valreg ea))
@@ -475,10 +475,12 @@
(format t "~%~%"))
=
(with-dll-node-freelist (code arm::*lap-instruction-freelis=
t*)
+ (with-dll-node-freelist (data arm::*lap-instruction-freel=
ist*)
(let* ((arm::*lap-labels* nil)
- (arm::*called-subprim-jmp-labels* nil)
+ (sections (vector code data))
debug-info)
- (arm2-expand-vinsns vinsns code)
+ (declare (dynamic-extent sections))
+ (arm2-expand-vinsns vinsns code sections)
(if (logbitp $fbitnonnullenv (the fixnum (afunc-bits =
afunc)))
(setq bits (+ bits (ash 1 $lfbits-nonnullenv-bit))))
(setq debug-info (afunc-lfun-info afunc))
@@ -503,21 +505,22 @@
(arm2-xmake-function
code
*backend-immediates*
- bits))
+ bits
+ data))
(when (getf debug-info 'pc-source-map)
(setf (getf debug-info 'pc-source-map) (arm2-genera=
te-pc-source-map debug-info)))
(when (getf debug-info 'function-symbol-map)
- (setf (getf debug-info 'function-symbol-map) (arm2-=
digest-symbols))))))
+ (setf (getf debug-info 'function-symbol-map) (arm2-=
digest-symbols)))))))
(backend-remove-labels))))
afunc))
=
-(defun arm2-xmake-function (code imms bits)
+(defun arm2-xmake-function (code imms bits &optional data)
(collect ((lap-imms))
(dotimes (i (length imms))
(lap-imms (cons (aref imms i) i)))
(let* ((arm::*arm-constants* (lap-imms)))
(arm-lap-generate-code code
- (arm::arm-finalize code)
+ (arm::arm-finalize code (if data (arm-drain-c=
onstant-pool code data)))
bits))))
=
=
@@ -737,7 +740,7 @@
(defun arm2-save-non-volatile-fprs (seg n)
(unless (eql n 0)
(with-arm-local-vinsn-macros (seg)
- (! push-nvfprs n))
+ (! push-nvfprs n (logior (ash n arm::num-subtag-bits) arm::subtag-do=
uble-float)))
(setq *arm2-non-volatile-fpr-count* n)))
=
(defun arm2-restore-non-volatile-fprs (seg)
@@ -1383,10 +1386,7 @@
(! load-single-float-constant vreg bitsreg)))
(multiple-value-bind (high low) (arm2-double-float-bits form)
(declare (integer high low))
- (with-imm-temps () ((highreg :u32) (lowreg :u32))
- (! lri highreg high)
- (! lri lowreg low)
- (! load-double-float-constant vreg highreg lowreg)))))
+ (! load-double-float-constant-from-data vreg high low))))
(if (and (typep form '(unsigned-byte 32))
(=3D (hard-regspec-class vreg) hard-reg-class-gpr)
(=3D (get-regspec-mode vreg)
@@ -1470,7 +1470,7 @@
(let* ((arg_z ($ arm::arg_z))
(imm0 ($ arm::imm0 :mode :s32)))
(arm2-copy-register seg imm0 s32-src)
- (! call-subprim (arm::arm-subprimitive-address '.SPmakes32))
+ (! call-subprim (arm::arm-subprimitive-offset '.SPmakes32))
(arm2-copy-register seg node-dest arg_z)))))
=
=
@@ -1482,7 +1482,7 @@
(let* ((arg_z ($ arm::arg_z))
(imm0 ($ arm::imm0 :mode :u32)))
(arm2-copy-register seg imm0 u32-src)
- (! call-subprim (arm::arm-subprimitive-address '.SPmakeu32))
+ (! call-subprim (arm::arm-subprimitive-offset '.SPmakeu32))
(arm2-copy-register seg node-dest arg_z)))))
=
=
@@ -2210,7 +2210,7 @@
(eql (hard-regspec-value unscaled-idx) arm::arg_=
y)
(eql (hard-regspec-value val-reg) arm::arg_z))
(compiler-bug "Bug: invalid register targeting for gvset: ~=
s" (list src unscaled-idx val-reg)))
- (! call-subprim-3 val-reg (arm::arm-subprimitive-address '.SP=
gvset) src unscaled-idx val-reg))
+ (! call-subprim-3 val-reg (arm::arm-subprimitive-offset '.SPg=
vset) src unscaled-idx val-reg))
(is-node
(if (and index-known-fixnum (<=3D index-known-fixnum
(arch::target-max-32-bit-cons=
tant-index arch)))
@@ -2697,7 +2697,7 @@
(let* ((*arm2-vstack* *arm2-vstack*)
(*arm2-top-vstack-lcell* *arm2-top-vstack-lcell*))
(arm2-lri seg arm::arg_x (ash (nx-lookup-target-uvector-subt=
ag :function) *arm2-target-fixnum-shift*))
- (arm2-lri seg arm::temp0 (arm::arm-subprimitive-address '.SP=
fix-nfn-entrypoint))
+ (arm2-lri seg arm::temp0 0)
(! %closure-code% arm::arg_y)
(arm2-store-immediate seg (arm2-afunc-lfun-ref afunc) arm::a=
rg_z)
(arm2-vpush-register-arg seg arm::arg_x)
@@ -2712,7 +2712,7 @@
(arm2-lri seg arm::arg_z (ash (ash 1 $lfbits-trampoline-bit)=
*arm2-target-fixnum-shift*))
(arm2-vpush-register-arg seg arm::arg_z)
(arm2-set-nargs seg (1+ vsize)) ; account for subtag
- (! make-stack-gvector))
+ (! make-stack-closure))
(arm2-open-undo $undostkblk))
(let* ((cell 1))
(declare (fixnum cell))
@@ -2722,9 +2722,9 @@
(arch::make-vheader vsize (nx-lookup-target-uvecto=
r-subtag :function)))
(! %alloc-misc-fixed dest arm::imm0 (ash vsize (arch::target=
-word-shift arch)))
)
- (! lri arm::arg_x (arm::arm-subprimitive-address '.SPfix-nfn-e=
ntrypoint))
- (! misc-set-c-node arm::arg_x dest 0)
(! %closure-code% arm::arg_x)
+ (! %codevector-entry arm::lr arm::arg_x)
+ (! misc-set-c-node arm::lr dest 0)
(arm2-store-immediate seg (arm2-afunc-lfun-ref afunc) arm::arg=
_y)
(with-node-temps (arm::arg_z) (t0 t1 t2 t3)
(do* ((ccode arm::arg_x nil)
@@ -4771,8 +4771,8 @@
(when safe
(! trap-unless-cons ptr-vreg))
(if setcdr
- (! call-subprim-2 ($ arm::arg_z) (arm::arm-subprimitive-address '.=
SPrplacd) ptr-vreg val-vreg)
- (! call-subprim-2 ($ arm::arg_z) (arm::arm-subprimitive-address '.=
SPrplaca) ptr-vreg val-vreg))
+ (! call-subprim-2 ($ arm::arg_z) (arm::arm-subprimitive-offset '.S=
Prplacd) ptr-vreg val-vreg)
+ (! call-subprim-2 ($ arm::arg_z) (arm::arm-subprimitive-offset '.S=
Prplaca) ptr-vreg val-vreg))
(if returnptr
(<- ptr-vreg)
(<- val-vreg))
@@ -5301,15 +5301,16 @@
(setf (vinsn-label-info lab) (arm::emit-lap-label header lab))))))
=
=
-(defun arm2-expand-vinsns (header seg)
+(defun arm2-expand-vinsns (header current &optional sections)
+ (declare (ignorable sections))
(do-dll-nodes (v header)
(if (%vinsn-label-p v)
(let* ((id (vinsn-label-id v)))
(if (or (typep id 'fixnum) (null id))
(when (or t (vinsn-label-refs v) (null id))
- (setf (vinsn-label-info v) (arm::emit-lap-label seg v)))
- (arm2-expand-note seg id)))
- (arm2-expand-vinsn v seg)))
+ (setf (vinsn-label-info v) (arm::emit-lap-label current v)))
+ (arm2-expand-note current id)))
+ (arm2-expand-vinsn v current sections)))
;;; This doesn't have too much to do with anything else that's
;;; going on here, but it needs to happen before the lregs
;;; are freed. There really shouldn't be such a thing as a
@@ -5330,8 +5331,11 @@
;;; For now, we replace lregs in the operand vector with their values
;;; on entry, but it might be reasonable to make PARSE-OPERAND-FORM
;;; deal with lregs ...
-(defun arm2-expand-vinsn (vinsn seg)
+(defun arm2-expand-vinsn (vinsn current &optional sections)
+ (declare (ignorable sections))
(let* ((template (vinsn-template vinsn))
+ (code (svref sections 0))
+ (data (svref sections 1))
(vp (vinsn-variable-parts vinsn))
(nvp (vinsn-template-nvp template))
(predicate (vinsn-annotation vinsn))
@@ -5347,7 +5351,7 @@
(push unique unique-labels)
(arm::make-lap-label unique)))
(labels ((parse-operand-form (valform)
- ;(break "valform =3D ~s" valform)
+ ;;(break "valform =3D ~s" valform)
(cond ((typep valform 'keyword)
(or (assq valform unique-labels)
(compiler-bug "unknown vinsn label ~s" valform)))
@@ -5363,19 +5367,48 @@
(dolist (op op-vals (apply (car valform) parsed-=
ops))
(setq tail (cdr (rplaca tail (parse-operand-fo=
rm op)))))))))
(expand-insn-form (f)
- (let* ((insn (arm::make-lap-instruction nil))
- (opcode (car f))
- (operands (cdr f)))
- (setf (arm::lap-instruction-opcode-high insn) (car opcode)
- (arm::lap-instruction-opcode-low insn) (cdr opcode))
- (when predicate
- (funcall (svref operand-insert-functions
- (arm::encode-vinsn-field-type :cond))
- insn
- predicate))
- (dolist (op operands (arm::emit-lap-instruction-element i=
nsn seg))
- (let* ((insert-function (svref operand-insert-functions=
(car op))))
- (funcall insert-function insn (parse-operand-form (cd=
r op)))))))
+ (case (car f)
+ (:code (setq current code))
+ (:data (setq current data)
+ (when (logtest 7 (arm::section-size data))
+ (expand-insn-form '((0 . 0)))))
+ (:word (let* ((val (parse-operand-form (cadr f))))
+ (expand-insn-form (list (cons (ldb (byte 16 16) =
val)
+ (ldb (byte 16 0) v=
al))))))
+ (:drain-constant-pool
+ (arm-drain-constant-pool code data t))
+ (t
+ =
+ (let* ((insn (arm::make-lap-instruction nil))
+ (opcode (car f))
+ (operands (cdr f)))
+ (setf (arm::lap-instruction-opcode-high insn) (car opc=
ode)
+ (arm::lap-instruction-opcode-low insn) (cdr opco=
de))
+ (when predicate
+ (funcall (svref operand-insert-functions
+ (arm::encode-vinsn-field-type :cond))
+ insn
+ predicate))
+ (dolist (op operands (arm::emit-lap-instruction-elemen=
t insn current))
+ (let* ((insert-function (svref operand-insert-functi=
ons (car op))))
+ (funcall insert-function insn (parse-operand-form =
(cdr op)))))
+ ;; If we just emitted an unconditional control transfer
+ ;; and we have data in the constant pool, drain the po=
ol.
+ (when (and (eql current code)
+ (not (eq (dll-header-succ data) data)))
+ (let* ((high (arm::lap-instruction-opcode-high insn)=
))
+ (declare (type (unsigned-byte 16) high))
+ (when (>=3D high #xe000)
+ (let* ((low (arm::lap-instruction-opcode-low ins=
n)))
+ (declare (type (unsigned-byte 16) low))
+ (when (or (eql #x0a00 (logand high #x0f00)) ;b
+ (and (eql #x012f (logand high #x0fff=
))
+ (eql #xff10 (logand low #xfff0)=
)) ;bx
+ (and (eql #x0890 (logand high #x0fd0=
))
+ (logbitp 15 low)) ;ldm w/PC
+ (and (eql #x0590 (logand #x0ff0 high=
))
+ (eql #xf000 (logand #xf000 low)=
))) ;ldr pc
+ (arm-drain-constant-pool code data))))))))))
(eval-predicate (f)
(case (car f)
(:pred (let* ((op-vals (cddr f))
@@ -5395,7 +5428,7 @@
(t (compiler-bug "Unknown predicate: ~s" f))))
(expand-form (f)
(if (keywordp f)
- (arm::emit-lap-label seg (assq f unique-labels))
+ (arm::emit-lap-label current (assq f unique-labels))
(if (atom f)
(compiler-bug "Invalid form in vinsn body: ~s" f)
(if (or (atom (car f))
@@ -5410,7 +5443,8 @@
(expand-form form ))
(setf (vinsn-variable-parts vinsn) nil)
(when vp
- (free-varparts-vector vp)))))
+ (free-varparts-vector vp))))
+ current)
=
=
=
@@ -5431,7 +5465,7 @@
(let* ((index (arch::builtin-function-name-offset name))
(subprim (if index
(arm2-builtin-index-subprim index)
- (or (arm::arm-subprimitive-address name)
+ (or (arm::arm-subprimitive-offset name)
(compiler-bug "Unknown builtin subprim index for=
~s" name))))
(tail-p (arm2-tailcallok xfer)))
(when tail-p
@@ -6448,11 +6482,11 @@
(compiler-bug "Isn't this code long since unused ?")
#+nil
(case nargs
- (0 (arm::arm-subprimitive-address '.SPcallbuiltin0))
- (1 (arm::arm-subprimitive-address '.SPcallbuiltin1))
- (2 (arm::arm-subprimitive-address '.SPcallbuiltin2))
- (3 (arm::arm-subprimitive-address '.SPcallbuiltin3))
- (t (arm::arm-subprimitive-address '.SPcallbuiltin))))))
+ (0 (arm::arm-subprimitive-offset '.SPcallbuiltin0))
+ (1 (arm::arm-subprimitive-offset '.SPcallbuiltin1))
+ (2 (arm::arm-subprimitive-offset '.SPcallbuiltin2))
+ (3 (arm::arm-subprimitive-offset '.SPcallbuiltin3))
+ (t (arm::arm-subprimitive-offset '.SPcallbuiltin))))))
(when tail-p
(arm2-restore-nvrs seg nil)
(arm2-restore-non-volatile-fprs seg)
@@ -6460,7 +6494,7 @@
#+nil
(unless idx-subprim
(! lri arm::imm0 (ash idx *arm2-target-fixnum-shift*))
- (when (eql subprim (arm::arm-subprimitive-address '.SPcallbuiltin))
+ (when (eql subprim (arm::arm-subprimitive-offset '.SPcallbuiltin))
(arm2-set-nargs seg nargs)))
(if tail-p
(! jump-subprim subprim)
@@ -6823,7 +6857,7 @@
(! fixnum-add-overflow-ool ($ arm::arg_z) ($ arm::arg_y) ($ ar=
m::arg_z))
(-> done)))
(@ out-of-line)
- (! call-subprim-2 ($ arm::arg_z) (arm::arm-subprimitive-address '.=
SPbuiltin-plus) ($ arm::arg_y) ($ arm::arg_z))
+ (! call-subprim-2 ($ arm::arg_z) (arm::arm-subprimitive-offset '.S=
Pbuiltin-plus) ($ arm::arg_y) ($ arm::arg_z))
(@ done)
(arm2-copy-register seg target ($ arm::arg_z)))
(^))))
@@ -6845,7 +6879,7 @@
(! fixnum-sub-overflow-ool ($ arm::arg_z)($ arm::arg_y) ($ arm=
::arg_z))
(-> done)))
(@ out-of-line)
- (! call-subprim-2 ($ arm::arg_z) (arm::arm-subprimitive-address '.=
SPbuiltin-minus) ($ arm::arg_y) ($ arm::arg_z))
+ (! call-subprim-2 ($ arm::arg_z) (arm::arm-subprimitive-offset '.S=
Pbuiltin-minus) ($ arm::arg_y) ($ arm::arg_z))
(@ done)
(arm2-copy-register seg target ($ arm::arg_z)))
(^))))
@@ -6919,7 +6953,7 @@
(@ out-of-line)
(if otherform
(arm2-lri seg ($ arm::arg_y) (ash fixval *arm2-target-fixnum=
-shift*)))
- (! call-subprim-2 ($ arm::arg_z) (arm::arm-subprimitive-addres=
s '.SPbuiltin-logior) ($ arm::arg_y) ($ arm::arg_z))
+ (! call-subprim-2 ($ arm::arg_z) (arm::arm-subprimitive-offset=
'.SPbuiltin-logior) ($ arm::arg_y) ($ arm::arg_z))
(@ done)
(arm2-copy-register seg target ($ arm::arg_z)))
(^))))))
@@ -6968,7 +7002,7 @@
(@ out-of-line)
(if otherform
(arm2-lri seg ($ arm::arg_y) (ash fixval *arm2-target-fixnum-s=
hift*)))
- (! call-subprim-2 ($ arm::arg_z) (arm::arm-subprimitive-addres=
s '.SPbuiltin-logand) ($ arm::arg_y) ($ arm::arg_z)) =
+ (! call-subprim-2 ($ arm::arg_z) (arm::arm-subprimitive-offset=
'.SPbuiltin-logand) ($ arm::arg_y) ($ arm::arg_z)) =
(@ done)
(arm2-copy-register seg target ($ arm::arg_z)))
(^))))))
Modified: trunk/source/compiler/PPC/PPC32/ppc32-arch.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/compiler/PPC/PPC32/ppc32-arch.lisp (original)
+++ trunk/source/compiler/PPC/PPC32/ppc32-arch.lisp Mon Nov 28 12:32:59 2011
@@ -941,4 +941,9 @@
=
(defconstant arg-check-trap-pc-limit 8)
=
+(defconstant fasl-version #x5f)
+(defconstant fasl-max-version #x5f)
+(defconstant fasl-min-version #x5e)
+(defparameter *image-abi-version* 1037)
+
(provide "PPC32-ARCH")
Modified: trunk/source/compiler/PPC/PPC64/ppc64-arch.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/compiler/PPC/PPC64/ppc64-arch.lisp (original)
+++ trunk/source/compiler/PPC/PPC64/ppc64-arch.lisp Mon Nov 28 12:32:59 2011
@@ -1008,5 +1008,10 @@
, at body)))
=
(defconstant arg-check-trap-pc-limit 8)
- =
+
+(defconstant fasl-version #x5f)
+(defconstant fasl-max-version #x5f)
+(defconstant fasl-min-version #x5e)
+(defparameter *image-abi-version* 1037)
+
(provide "PPC64-ARCH")
Modified: trunk/source/compiler/X86/X8632/x8632-arch.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/compiler/X86/X8632/x8632-arch.lisp (original)
+++ trunk/source/compiler/X86/X8632/x8632-arch.lisp Mon Nov 28 12:32:59 2011
@@ -1335,4 +1335,9 @@
;;; (maybe not =3D on x8632)
(defconstant arg-check-trap-pc-limit 7)
=
+(defconstant fasl-version #x5f)
+(defconstant fasl-max-version #x5f)
+(defconstant fasl-min-version #x5e
+(defparameter *image-abi-version* 1037)
+
(provide "X8632-ARCH")
Modified: trunk/source/compiler/X86/X8664/x8664-arch.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/compiler/X86/X8664/x8664-arch.lisp (original)
+++ trunk/source/compiler/X86/X8664/x8664-arch.lisp Mon Nov 28 12:32:59 2011
@@ -1350,4 +1350,9 @@
=
(defconstant arg-check-trap-pc-limit 7)
=
+(defconstant fasl-version #x5f)
+(defconstant fasl-max-version #x5f)
+(defconstant fasl-min-version #x5e
+(defparameter *image-abi-version* 1037)
+
(provide "X8664-ARCH")
Modified: trunk/source/compiler/optimizers.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/compiler/optimizers.lisp (original)
+++ trunk/source/compiler/optimizers.lisp Mon Nov 28 12:32:59 2011
@@ -2116,31 +2116,14 @@
(let* ((typecode (gensym)))
`(let* ((,typecode (typecode ,x)))
(declare (type (unsigned-byte 8) ,typecode))
- #+(or ppc32-target x8632-target arm-target)
- (and (<=3D ,typecode target::max-real-subtag)
- (logbitp (the (integer 0 ,target::max-real-subtag)
+ (and (< ,typecode (- target::nbits-in-word target::fixnumshift))
+ (logbitp (the (integer 0 (#.(- target::nbits-in-word target::fixn=
umshift)))
,typecode)
- (logior (ash 1 target::tag-fixnum)
- (ash 1 target::subtag-single-float)
- (ash 1 target::subtag-double-float)
- (ash 1 target::subtag-bignum)
- (ash 1 target::subtag-ratio) )))
- #+ppc64-target
- (if (<=3D ,typecode ppc64::subtag-double-float)
- (logbitp (the (integer 0 #.ppc64::subtag-double-float) ,typecode)
- (logior (ash 1 ppc64::tag-fixnum)
- (ash 1 ppc64::subtag-single-float)
- (ash 1 ppc64::subtag-double-float)
- (ash 1 ppc64::subtag-bignum)
- (ash 1 ppc64::subtag-ratio))))
- #+x8664-target
- (if (<=3D ,typecode x8664::subtag-double-float)
- (logbitp (the (integer 0 #.x8664::subtag-double-float) ,typecode)
- (logior (ash 1 x8664::tag-fixnum)
- (ash 1 x8664::subtag-bignum)
- (ash 1 x8664::tag-single-float)
- (ash 1 x8664::subtag-double-float)
- (ash 1 x8664::subtag-ratio))))))))
+ (logior (ash 1 target::tag-fixnum)
+ (ash 1 target::subtag-single-float)
+ (ash 1 target::subtag-double-float)
+ (ash 1 target::subtag-bignum)
+ (ash 1 target::subtag-ratio))))))))
=
(define-compiler-macro %composite-pointer-ref (size pointer offset)
(if (constantp size)
Modified: trunk/source/level-0/ARM/arm-array.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/level-0/ARM/arm-array.lisp (original)
+++ trunk/source/level-0/ARM/arm-array.lisp Mon Nov 28 12:32:59 2011
@@ -143,7 +143,8 @@
@bad
(mov arg_x '#.$xnotelt)
(set-nargs 3)
- (bla .SPksignalerr)
+ (sploadlr .SPksignalerr)
+ (blx lr)
@fixnum
(tst val (:$ arm::fixnum-mask))
(unbox-fixnum imm0 val)
@@ -261,7 +262,7 @@
(vpush1 a)
(vpush1 offset)
(set-nargs 2)
- (ba .SPvalues)))
+ (spjump .SPvalues)))
=
(defarmlapfunction %boole-clr ((len 0) (b0 arg_x) (b1 arg_y) (dest arg_z))
(vpop1 temp0)
@@ -529,23 +530,23 @@
=
(defarmlapfunction %aref2 ((array arg_x) (i arg_y) (j arg_z))
(check-nargs 3)
- (ba .SParef2))
+ (spjump .SParef2))
=
(defarmlapfunction %aref3 ((array 0) (i arg_x) (j arg_y) (k arg_z))
(check-nargs 4)
(vpop1 temp0)
- (ba .SParef3))
+ (spjump .SParef3))
=
=
(defarmlapfunction %aset2 ((array 0) (i arg_x) (j arg_y) (newval arg_z))
(check-nargs 4)
(vpop1 temp0)
- (ba .SPaset2))
+ (spjump .SPaset2))
=
(defarmlapfunction %aset3 ((array #.target::node-size) (i 0) (j arg_x) (k =
arg_y) (newval arg_z))
(check-nargs 5)
(vpop1 temp0)
(vpop1 temp1)
- (ba .SPaset3))
+ (spjump .SPaset3))
=
=
Modified: trunk/source/level-0/ARM/arm-bignum.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/level-0/ARM/arm-bignum.lisp (original)
+++ trunk/source/level-0/ARM/arm-bignum.lisp Mon Nov 28 12:32:59 2011
@@ -35,7 +35,7 @@
(vpush1 temp1)
(add temp0 vsp (:$ 8)) =
(set-nargs 2) =
- (ba .SPvalues))
+ (spjump .SPvalues))
=
=
;;; Set the 0th element of DEST (a bignum or some other 32-bit ivector)
@@ -160,7 +160,7 @@
(vpush1 temp1)
(add temp0 vsp '2)
(set-nargs 2)
- (ba .SPvalues)))
+ (spjump .SPvalues)))
=
=
=
@@ -295,7 +295,7 @@
(vpush temp1)
(add temp0 vsp (:$ 8))
(set-nargs 2)
- (ba .SPvalues)))
+ (spjump .SPvalues)))
=
=
=
@@ -332,7 +332,7 @@
(vpush1 c)
(add temp0 vsp (:$ 20))
(set-nargs 3)
- (ba .SPvalues)))
+ (spjump .SPvalues)))
=
=
(defarmlapfunction %subtract-one ((a-h arg_y)(a-l arg_z))
@@ -345,7 +345,7 @@
(vpush1 temp0)
(add temp0 vsp (:$ 8))
(set-nargs 2)
- (ba .SPvalues)))
+ (spjump .SPvalues)))
=
=
=
@@ -395,7 +395,7 @@
(vpush1 arg_z)
(set-nargs 4)
(add temp0 vsp (:$ 16))
- (ba .SPvalues)))
+ (spjump .SPvalues)))
=
=
(defarmlapfunction %logcount-complement ((bignum arg_y) (idx arg_z))
@@ -935,7 +935,7 @@
(add temp0 vsp (:$ 20))
(add sp sp (:$ 32))
(set-nargs 2)
- (ba .SPvalues)))
+ (spjump .SPvalues)))
=
(defarmlapfunction normalize-bignum-loop ((sign arg_x)(res arg_y)(len arg_=
z))
(let ((idx imm0)
@@ -1122,7 +1122,8 @@
(ldr imm0 (:@ bignum imm0))
(mov imm1 imm2)
(compose-digit imm2 yhi ylo)
- (bla .SPudiv64by32)
+ (sploadlr .SPudiv64by32)
+ (blx lr)
(add imm1 len (:$ arm::misc-data-offset))
(str imm0 (:@ res imm1))
@next
@@ -1133,7 +1134,7 @@
(vpush1 yhi)
(vpush1 ylo)
(set-nargs 2)
- (ba .SPnvalret)))
+ (spjump .SPnvalret)))
=
;;; For TRUNCATE-BY-FIXNUM et al.
;;; Doesn't store quotient: just returns rem in 2 halves.
@@ -1148,7 +1149,8 @@
(ldr imm0 (:@ x imm0))
(mov imm1 imm2)
(compose-digit imm2 yhi ylo)
- (bla .SPudiv64by32)
+ (sploadlr .SPudiv64by32)
+ (blx lr)
@next
(subs len len '1)
(bge @loop)
@@ -1157,7 +1159,7 @@
(vpush1 yhi)
(vpush1 ylo)
(set-nargs 2)
- (ba .SPnvalret)))
+ (spjump .SPnvalret)))
=
=
=
@@ -1280,13 +1282,14 @@
(vpush1 imm0)
(vpush1 imm0)
(set-nargs 2)
- (ba .SPnvalret)
+ (spjump .SPnvalret)
@more
(add imm1 xidx (:$ (- arm::misc-data-offset arm::node-size)))
(ldr imm0 (:@ temp0 imm1))
(add imm1 imm1 (:$ arm::node-size))
(ldr imm1 (:@ temp0 imm1))
- (bla .SPudiv64by32)
+ (sploadlr .SPudiv64by32)
+ (blx lr)
(mov arg_y '-1)
(and arg_y arg_y (:lsr imm0 (:$ (- 16 arm::fixnumshift))))
(mov imm0 (:lsl imm0 (:$ 16)))
@@ -1294,7 +1297,7 @@
(and arg_z arg_z (:lsr imm0 (:$ (- 16 arm::fixnumshift))))
(stmdb (:! vsp) (arg_z arg_y))
(set-nargs 2)
- (ba .SPnvalret))
+ (spjump .SPnvalret))
=
;;; Karatsuba multiplication stuff. NYI.
;;; Copy the limb SRC points to to where DEST points.
Modified: trunk/source/level-0/ARM/arm-clos.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/level-0/ARM/arm-clos.lisp (original)
+++ trunk/source/level-0/ARM/arm-clos.lisp Mon Nov 28 12:32:59 2011
@@ -198,12 +198,14 @@
;;; This can't reference any of the function's constants.
(defarmlapfunction unset-fin-trampoline ()
(build-lisp-frame)
- (bla .SPheap-rest-arg) ; cons up an &rest arg, vpush it
+ (sploadlr .SPheap-rest-arg) ; cons up an &rest arg, vpus=
h it
+ (blx lr)
(vpop1 arg_z) ; whoops, didn't really want to
(mov arg_x '#.$XNOFINFUNCTION)
(mov arg_y nfn)
(set-nargs 3)
- (bla .SPksignalerr)
+ (sploadlr .SPksignalerr)
+ (blx lr)
(mov arg_z 'nil)
(return-lisp-frame))
=
Modified: trunk/source/level-0/ARM/arm-def.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/level-0/ARM/arm-def.lisp (original)
+++ trunk/source/level-0/ARM/arm-def.lisp Mon Nov 28 12:32:59 2011
@@ -16,6 +16,13 @@
=
(in-package "CCL")
=
+(defarmlapfunction %fix-fn-entrypoint ((func arg_z))
+ (build-lisp-frame imm0)
+ (ldr temp0 (:@ func (:$ arm::function.codevector)))
+ (add lr temp0 (:$ arm::misc-data-offset))
+ (str lr (:@ func (:$ arm::function.entrypoint)))
+ (return-lisp-frame imm0))
+
;;; Do an FF-CALL to MakeDataExecutable so that the data cache gets flushe=
d.
;;; 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.
@@ -74,7 +81,7 @@
(moveq offset (:$ 0))
(unbox-fixnum imm0 offset)
(ldr imm0 (:@ imm0 fixnum))
- (ba .SPmakeu32))
+ (spjump .SPmakeu32))
=
=
=
@@ -222,7 +229,7 @@
(vpush1 imm1)
@go
(set-nargs 2)
- (ba .SPnvalret)
+ (spjump .SPnvalret)
@no
(mov imm0 'nil)
(vpush1 imm0)
@@ -299,7 +306,8 @@
=
(defarmlapfunction %do-ff-call ((tag arg_x) (result arg_y) (entry arg_z))
(stmdb (:! vsp) (tag result))
- (bla .SPeabi-ff-call)
+ (sploadlr .SPeabi-ff-call)
+ (blx lr)
(ldmia (:! vsp) (tag result))
(macptr-ptr imm2 result)
(str imm0 (:@ imm2 (:$ 0)))
@@ -308,7 +316,8 @@
(mov arg_z 'nil)
(vpush1 arg_z)
(set-nargs 1)
- (bla .SPthrow))
+ (sploadlr .SPthrow)
+ (blx lr))
=
(defun %ff-call (entry &rest specs-and-vals)
(declare (dynamic-extent specs-and-vals))
@@ -450,7 +459,8 @@
(mov arm::nfn function)
(set-nargs 0)
(build-lisp-frame)
- (bla .SPspread-lexprz)
+ (sploadlr .SPspread-lexprz)
+ (blx lr)
(ldr lr (:@ sp (:$ arm::lisp-frame.savelr)))
;; Nothing's changed FN.
;;(ldr fn (:@ sp (:$ arm::lisp-frame.savefn)))
@@ -471,7 +481,8 @@
(mov arm::nfn function)
(set-nargs 0)
(build-lisp-frame)
- (bla .SPspreadargZ)
+ (sploadlr .SPspreadargZ)
+ (blx lr)
(ldr lr (:@ sp (:$ arm::lisp-frame.savelr)))
;; Nothing's changed FN.
;; (ldr fn (:@ sp (:$ arm::lisp-frame.savefn)))
@@ -522,14 +533,16 @@
(unless (eql total-size (uvsize target))
(error "Wrong size target ~s" target)))
(%copy-gvector-to-gvector proto 0 new 0 total-size)
- (setf (%svref new 0) #.(ash (arm::arm-subprimitive-address '.SPfix-nfn=
-entrypoint) (- arm::fixnumshift)))
- new))
+ (%fix-fn-entrypoint new)))
=
(defun replace-function-code (target-fn proto-fn)
(if (typep target-fn 'function)
(if (typep proto-fn 'function)
- (setf (uvref target-fn 0) #.(ash (arm::arm-subprimitive-address '.SP=
fix-nfn-entrypoint) (- arm::fixnumshift))
- (uvref target-fn 1) (uvref proto-fn 1))
+ (progn
+ (setf (uvref target-fn 0) (%lookup-subprim-address
+ #.(arm::arm-subprimitive-offset '.SPfix=
-nfn-entrypoint))
+ (uvref target-fn 1) (uvref proto-fn 1))
+ (%fix-fn-entrypoint target-fn))
(report-bad-arg proto-fn 'function))
(report-bad-arg target-fn 'function)))
=
@@ -551,7 +564,8 @@
(mov arg_z arg_y) ; butlast
(sub nargs nargs '2) ; remove count for butlast & last
(build-lisp-frame)
- (bla .SPspreadargz)
+ (sploadlr .SPspreadargz)
+ (blx lr)
(cmp nargs '3)
(ldr lr (:@ sp (:$ arm::lisp-frame.savelr)))
(discard-lisp-frame)
@@ -561,8 +575,11 @@
(mov arg_y arg_z)
(mov arg_z temp0)
(ldr nfn (:@ nfn 'funcall))
- (ba .SPfuncall))
-
-
+ (spjump .SPfuncall))
+
+(defarmlapfunction %lookup-subprim-address ((subp arg_z))
+ (ldr imm0 (:@ rcontext (:lsr subp (:$ arm::fixnumshift))))
+ (box-fixnum arg_z imm0)
+ (bx lr))
=
;;; end of arm-def.lisp
Modified: trunk/source/level-0/ARM/arm-float.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/level-0/ARM/arm-float.lisp (original)
+++ trunk/source/level-0/ARM/arm-float.lisp Mon Nov 28 12:32:59 2011
@@ -113,7 +113,7 @@
(vpush1 temp0) ; sign
(set-nargs 4)
(add temp0 vsp '4)
- (ba .SPvalues))
+ (spjump .SPvalues))
=
=
;;; hi is 25 bits lo is 28 bits
@@ -534,7 +534,8 @@
(bic imm0 imm0 (:$ #xff))
(fmxr :fpscr imm0)
(fsqrts s1 s0)
- (bla .SPcheck-fpu-exception)
+ (sploadlr .SPcheck-fpu-exception)
+ (blx lr)
(put-single-float s1 dest imm0)
(return-lisp-frame))
=
@@ -547,7 +548,8 @@
(bic imm0 imm0 (:$ #xff))
(fmxr :fpscr imm0)
(fsqrtd d1 d0)
- (bla .SPcheck-fpu-exception)
+ (sploadlr .SPcheck-fpu-exception)
+ (blx lr)
(put-double-float d1 dest)
(return-lisp-frame))
=
Modified: trunk/source/level-0/ARM/arm-hash.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/level-0/ARM/arm-hash.lisp (original)
+++ trunk/source/level-0/ARM/arm-hash.lisp Mon Nov 28 12:32:59 2011
@@ -31,7 +31,8 @@
(build-lisp-frame imm0)
(mov imm0 (:lsr number (:$ arm::fixnumshift)))
(mov imm1 (:lsr divisor (:$ arm::fixnumshift)))
- (bla .SPudiv32)
+ (sploadlr .SPudiv32)
+ (blx lr)
(box-fixnum arg_z imm1)
(return-lisp-frame imm0))
=
@@ -104,10 +105,10 @@
;;; Setting a key in a hash-table vector needs to =
;;; ensure that the vector header gets memoized as well
(defarmlapfunction %set-hash-table-vector-key ((vector arg_x) (index arg_y=
) (value arg_z))
- (ba .SPset-hash-key))
+ (spjump .SPset-hash-key))
=
(defarmlapfunction %set-hash-table-vector-key-conditional ((offset 0) (vec=
tor arg_x) (old arg_y) (new arg_z))
- (ba .SPset-hash-key-conditional))
+ (spjump .SPset-hash-key-conditional))
=
;;; Strip the tag bits to turn x into a fixnum
(defarmlapfunction strip-tag-to-fixnum ((x arg_z))
Modified: trunk/source/level-0/ARM/arm-misc.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/level-0/ARM/arm-misc.lisp (original)
+++ trunk/source/level-0/ARM/arm-misc.lisp Mon Nov 28 12:32:59 2011
@@ -530,48 +530,30 @@
(restore-lisp-frame imm0)
(bx lr)))
=
-(defarmlapfunction %copy-gvector-to-gvector ((src (* 1 arm::node-size))
- (src-element 0)
- (dest arg_x)
- (dest-element arg_y)
- (nelements arg_z))
- (ldr temp2 (:@ vsp (:$ src-element)))
- (ldr temp0 (:@ vsp (:$ src)))
- (add vsp vsp '2)
- (cmp temp0 dest)
- (add imm0 temp2 (:$ arm::misc-data-offset))
- (add imm1 dest-element (:$ arm::misc-data-offset))
- (bne @test)
- ;; Maybe overlap, or maybe nothing to do.
- (cmp temp2 dest-element)
- (beq @done) ; same vectors, same offsets
- (blt @back) ; copy backwards, avoid overlap
- (b @test)
- @loop
- (ldr temp1 (:@ temp0 imm0))
- (add imm0 imm0 '1)
- (str temp1 (:@ dest imm1))
- (add imm1 imm1 '1)
- @test
- (subs nelements nelements '1)
- (bge @loop)
- @done
- (mov arg_z dest)
- (bx lr)
- @back
- (add imm1 nelements imm1)
- (add imm0 nelements imm0)
- (b @back-test)
- @back-loop
- (sub imm0 imm0 '1)
- (ldr temp1 (:@ temp0 imm0))
- (sub imm1 imm1 '1)
- (str temp1 (:@ dest imm1))
- @back-test
- (subs nelements nelements '1)
- (bge @back-loop)
- (mov arg_z dest)
- (bx lr))
+;;; Unless we're sure that DEST is newly-created, we have to do this
+;;; in a way that honors the write barrier.
+(defun %copy-gvector-to-gvector (src src-element dest dest-element nelemen=
ts)
+ (declare (fixnum src-element dest-element nelements)
+ (optimize (speed 3) (safety 0)))
+ (if (or (not (eq src dest))
+ (< dest-element src-element)
+ (>=3D dest-element (the fixnum (+ src-element nelements))))
+ (do* ()
+ ((<=3D nelements 0) dest)
+ (setf (%svref dest dest-element)
+ (%svref src src-element))
+ (incf dest-element)
+ (incf src-element)
+ (decf nelements))
+ (do* ((src-element (+ src-element nelements))
+ (dest-element (+ dest-element nelements)))
+ ((<=3D nelements 0) dest)
+ (declare (fixnum src-element dest-element))
+ (decf src-element)
+ (decf dest-element)
+ (setf (%svref dest dest-element)
+ (%svref src src-element))
+ (decf nelements))))
=
=
=
@@ -587,7 +569,7 @@
(adds imm0 imm0 imm2)
(adc imm1 imm1 (:$ 0))
@go
- (ba .SPmakeu64))
+ (spjump .SPmakeu64))
=
=
=
@@ -596,7 +578,7 @@
(:arglist (&rest values))
(vpush-argregs)
(add temp0 nargs vsp)
- (ba .SPvalues))
+ (spjump .SPvalues))
=
;; It would be nice if (%setf-macptr macptr (ash (the fixnum value)
;; ash::fixnumshift)) would do this inline.
@@ -621,7 +603,7 @@
(add imm2 imm2 imm1)
(ldr imm0 (:@ imm2 (:$ 0)))
(ldr imm1 (:@ imm2 (:$ 4)))
- (ba .SPmakeu64))
+ (spjump .SPmakeu64))
=
=
=
@@ -632,7 +614,7 @@
(add imm2 imm2 imm1)
(ldr imm0 (:@ imm2 (:$ 0))) ;low
(ldr imm1 (:@ imm2 (:$ 4))) ;high
- (ba .SPmakes64))
+ (spjump .SPmakes64))
=
=
=
@@ -642,7 +624,8 @@
(build-lisp-frame imm0)
(mov fn nfn)
(trap-unless-xtype=3D ptr arm::subtag-macptr) =
- (bla .SPgetu64)
+ (sploadlr .SPgetu64)
+ (blx lr)
(macptr-ptr imm2 ptr)
(add imm2 imm2 (:asr offset (:$ arm::fixnumshift)))
(str imm0 (:@ imm2 (:$ 0)))
@@ -657,7 +640,8 @@
(build-lisp-frame imm0)
(mov fn nfn)
(trap-unless-xtype=3D ptr arm::subtag-macptr)
- (bla .SPgets64)
+ (sploadlr .SPgets64)
+ (blx lr)
(macptr-ptr imm2 ptr)
(add imm2 imm2 (:asr offset (:$ arm::fixnumshift)))
(str imm0 (:@ imm2 (:$ 0)))
@@ -715,7 +699,7 @@
=
;;; 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))
+ (spjump .SPstore-node-conditional))
=
#+notyet ; needs a subprim on ARM
(defarmlapfunction %store-immediate-conditional ((offset 0) (object arg_x)=
(old arg_y) (new arg_z))
@@ -789,7 +773,7 @@
=
=
(defarmlapfunction %atomic-incf-node ((by arg_x) (node arg_y) (disp arg_z))
- (ba .SPatomic-incf-node))
+ (spjump .SPatomic-incf-node))
=
(defarmlapfunction %atomic-incf-ptr ((ptr arg_z))
(macptr-ptr imm1 ptr)
@@ -911,7 +895,8 @@
(vpush parent)
(vpush function)
(vpush arglist)
- (bla .SPnthrowvalues)
+ (sploadlr .SPnthrowvalues)
+ (blx lr)
=
; Pop tsp-count TSP frames
(lwz tsp-count 16 vsp)
@@ -929,7 +914,8 @@
(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)
+ (sploadlr .SPunbind-to)
+ (blx lr)
=
@restore-regs
; restore the saved registers from srv
@@ -1005,8 +991,9 @@
;; Parent is a real stack frame
(mov sp parent))
(set-nargs 0)
- (bla .SPspreadargz)
- (ba .SPtfuncallgen))
+ (sploadlr .SPspreadargz)
+ (blx lr)
+ (spjump .SPtfuncallgen))
=
=
=
Modified: trunk/source/level-0/ARM/arm-numbers.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/level-0/ARM/arm-numbers.lisp (original)
+++ trunk/source/level-0/ARM/arm-numbers.lisp Mon Nov 28 12:32:59 2011
@@ -65,7 +65,7 @@
(vpush1 temp1)
(add temp0 vsp '2)
(set-nargs 2)
- (ba .SPvalues))
+ (spjump .SPvalues))
=
=
; (integer-length arg) =3D (- 32 (clz (if (>=3D arg 0) arg (lognot arg))))
@@ -143,12 +143,13 @@
(unbox-fixnum unboxed-dividend dividend)
(unbox-fixnum unboxed-divisor divisor)
(beq @neg)
- (bla .SPsdiv32)
+ (sploadlr .SPsdiv32)
+ (blx lr)
(box-fixnum quotient unboxed-quotient)
(box-fixnum remainder unboxed-remainder)
(stmdb (:! vsp) (quotient remainder))
(set-nargs 2)
- (ba .SPnvalret)
+ (spjump .SPnvalret)
@neg
(ldr arg_z (:@ fn '*least-positive-bignum*))
(rsbs dividend dividend (:$ 0))
@@ -158,7 +159,7 @@
(vpush1 dividend)
(vpush1 temp0)
(set-nargs 2)
- (ba .SPnvalret)))
+ (spjump .SPnvalret)))
=
=
=
Modified: trunk/source/level-0/ARM/arm-pred.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/level-0/ARM/arm-pred.lisp (original)
+++ trunk/source/level-0/ARM/arm-pred.lisp Mon Nov 28 12:32:59 2011
@@ -39,8 +39,17 @@
(beq @macptr)
(cmp imm0 imm1)
(bne @lose)
- (cmp imm2 (:$ arm::max-numeric-subtag))
- (bgt @lose)
+ (lri imm1 (logior (ash 1 target::tag-fixnum)
+ (ash 1 target::subtag-bignum)
+ (ash 1 target::subtag-single-float)
+ (ash 1 target::subtag-double-float)
+ (ash 1 target::subtag-ratio)
+ (ash 1 target::subtag-complex)))
+ (mov imm0 (:$ 1))
+ (tst imm1 (:lsl imm0 imm2))
+ (getvheader imm0 x)
+ (getvheader imm1 y)
+ (beq @lose)
(cmp imm2 (:$ arm::subtag-ratio))
(cmpne imm2 (:$ arm::subtag-complex))
(beq @node)
Modified: trunk/source/level-0/ARM/arm-symbol.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/level-0/ARM/arm-symbol.lisp (original)
+++ trunk/source/level-0/ARM/arm-symbol.lisp Mon Nov 28 12:32:59 2011
@@ -68,10 +68,10 @@
(bx lr))
=
(defarmlapfunction %symptr-value ((symptr arg_z))
- (ba .SPspecref))
+ (spjump .SPspecref))
=
(defarmlapfunction %set-symptr-value ((symptr arg_y) (val arg_z))
- (ba .SPspecset))
+ (spjump .SPspecset))
=
(defarmlapfunction %symptr-binding-address ((symptr arg_z))
(ldr imm0 (:@ symptr (:$ arm::symbol.binding-index)))
@@ -87,14 +87,14 @@
(vpush1 imm0)
(set-nargs 2)
(add temp0 vsp '2)
- (ba .SPvalues)
+ (spjump .SPvalues)
@sym
(mov arg_y '#.arm::symbol.vcell)
(vpush1 arg_z)
(vpush1 arg_y)
(set-nargs 2)
(add temp0 vsp '2)
- (ba .SPvalues))
+ (spjump .SPvalues))
=
(defarmlapfunction %tcr-binding-location ((tcr arg_y) (sym arg_z))
(ldr imm1 (:@ sym (:$ arm::symbol.binding-index)))
Modified: trunk/source/level-0/ARM/arm-utils.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/level-0/ARM/arm-utils.lisp (original)
+++ trunk/source/level-0/ARM/arm-utils.lisp Mon Nov 28 12:32:59 2011
@@ -26,7 +26,7 @@
(tst imm0 (:$ #xc0000000)) ; see if result fits in a fixnum, =
sorta
(box-fixnum arg_z imm0) ; assume it did
(bxeq lr) ; else arg_z tagged ok, but missin=
g bits
- (ba .SPmakeu32) ; put all bits in bignum.
+ (spjump .SPmakeu32) ; put all bits in bignum.
)
=
=
@@ -111,7 +111,8 @@
(set-nargs 1)
(stmdb (:! vsp) (fun obj limit))
(mov nfn fun)
- (bla .SPfuncall)
+ (sploadlr .SPfuncall)
+ (blx lr)
(ldmia (:! vsp) (fun obj limit))
(add obj obj (:$ arm::cons.size))
(b @test)
@@ -120,7 +121,8 @@
(stmdb (:! vsp) (fun obj limit))
(set-nargs 1)
(mov nfn fun)
- (bla .SPfuncall)
+ (sploadlr .SPfuncall)
+ (blx lr)
(ldmia (:! vsp) (fun obj limit))
(ldr header (:@ obj (:$ 0)))
(extract-fulltag tag header)
@@ -211,7 +213,8 @@
(set-nargs 1)
(stmdb (:! vsp) (arg_z fun sentinel))
(mov nfn fun)
- (bla .SPfuncall)
+ (sploadlr .SPfuncall)
+ (blx lr)
(ldmia (:! vsp) (obj fun sentinel))
(add obj obj (:$ (- arm::cons.size arm::fulltag-cons)))
(b @test)
@@ -220,7 +223,8 @@
(stmdb (:! vsp) (arg_z fun sentinel))
(set-nargs 1)
(mov nfn fun)
- (bla .SPfuncall)
+ (sploadlr .SPfuncall)
+ (blx lr)
(ldmia (:! vsp) (obj fun sentinel))
(sub obj obj (:$ arm::fulltag-misc))
(ldr header (:@ obj (:$ 0)))
@@ -333,7 +337,7 @@
(vpush1 arg_z)
(vpush1 arg_y)
(set-nargs 2)
- (ba .SPnvalret))
+ (spjump .SPnvalret))
=
=
=
@@ -377,7 +381,7 @@
(check-nargs 0)
(mov imm0 (:$ arch::gc-trap-function-get-lisp-heap-threshold))
(uuo-gc-trap)
- (ba .SPmakeu32))
+ (spjump .SPmakeu32))
=
(defarmlapfunction set-lisp-heap-gc-threshold ((new arg_z))
"Set the value of the kernel variable that specifies the amount of free
@@ -386,12 +390,13 @@
be somewhat larger than what was specified)." =
(check-nargs 1)
(build-lisp-frame)
- (bla .SPgetu32)
+ (sploadlr .SPgetu32)
+ (blx lr)
(mov imm1 imm0)
(mov imm0 (:$ arch::gc-trap-function-set-lisp-heap-threshold))
(uuo-gc-trap)
(restore-lisp-frame imm1)
- (ba .SPmakeu32))
+ (spjump .SPmakeu32))
=
=
(defarmlapfunction use-lisp-heap-gc-threshold ()
@@ -408,14 +413,14 @@
(check-nargs 0)
(mov imm0 (:$ arch::gc-trap-function-freeze))
(uuo-gc-trap)
- (ba .SPmakeu32))
+ (spjump .SPmakeu32))
=
(defarmlapfunction flash-freeze ()
"Like FREEZE, but don't GC first."
(check-nargs 0)
(mov imm0 (:$ arch::gc-trap-function-flash-freeze))
(uuo-gc-trap)
- (ba .SPmakeu32))
+ (spjump .SPmakeu32))
=
(defarmlapfunction allow-heap-allocation ((arg arg_z))
"If ARG is true, signal an ALLOCATION-DISABLED condition on attempts
Modified: trunk/source/level-0/l0-def.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/level-0/l0-def.lisp (original)
+++ trunk/source/level-0/l0-def.lisp Mon Nov 28 12:32:59 2011
@@ -209,7 +209,9 @@
=
(defun %macro-have (symbol macro-function)
(declare (special %macro-code%)) ; magically set by xloader.
- (%fhave symbol (vector %macro-code% macro-function)))
+ (%fhave symbol
+ #-arm-target (vector %macro-code% macro-function)
+ #+arm-target (%fix-fn-entrypoint (gvector :pseudofunction 0 %mac=
ro-code% macro-function))))
=
=
(defun special-operator-p (symbol)
@@ -233,8 +235,8 @@
environment only."
(setq form (require-type form 'symbol))
(when env
- ; A definition-environment isn't a lexical environment, but it can
- ; be an ancestor of one.
+ ;; A definition-environment isn't a lexical environment, but it can
+ ;; be an ancestor of one.
(unless (istruct-typep env 'lexical-environment)
(report-bad-arg env 'lexical-environment))
(let ((cell nil))
@@ -245,7 +247,7 @@
(if (eq (car cell) 'macro) (%cdr cell))))
(unless (listp (setq env (lexenv.parent-env env)))
(go top)))))
- ; Not found in env, look in function cell.
+ ;; Not found in env, look in function cell.
(%global-macro-function form))
=
(defun %fixnum-ref-macptr (fixnum &optional (offset 0))
Modified: trunk/source/level-0/l0-error.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/level-0/l0-error.lisp (original)
+++ trunk/source/level-0/l0-error.lisp Mon Nov 28 12:32:59 2011
@@ -23,7 +23,7 @@
(4 . "Too few arguments.")
(5 . "Argument ~S is not of the required type.")
(6 . "Undefined function: ~S .")
- (7 . "Invalid assignnnt of ~s at index ~s, to ~s.")
+ (7 . "Invalid assignment of ~s at index ~s, to ~s.")
(8 . "Can't coerce ~S to ~S")
(9 . "Funcallable instance ~S was called with args ~s, but has no FUNC=
ALLABLE-INSTANCE-FUNCTION")
(10 . "Out of memory.")
Modified: trunk/source/level-0/l0-hash.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/level-0/l0-hash.lisp (original)
+++ trunk/source/level-0/l0-hash.lisp Mon Nov 28 12:32:59 2011
@@ -95,14 +95,15 @@
(let* ((typecode (typecode key)))
(declare (fixnum typecode))
(or (=3D typecode target::subtag-macptr)
- #+(or ppc32-target x8632-target arm-target)
- (and (>=3D typecode target::min-numeric-subtag)
- (<=3D typecode target::max-numeric-subtag))
- #+64-bit-target
- (or (=3D typecode target::subtag-bignum)
- (=3D typecode target::subtag-double-float)
- (=3D typecode target::subtag-ratio)
- (=3D typecode target::subtag-complex)))))
+ (and (< typecode (- target::nbits-in-word target::fixnumshift))
+ (logbitp (the (integer 0 (#.(- target::nbits-in-word target::=
fixnumshift)))
+ typecode)
+ (logior (ash 1 target::tag-fixnum)
+ (ash 1 target::subtag-bignum)
+ (ash 1 target::subtag-single-float)
+ (ash 1 target::subtag-double-float)
+ (ash 1 target::subtag-ratio)
+ (ash 1 target::subtag-complex)))))))
=
;;; Don't rehash at all, unless some key is address-based (directly or
;;; indirectly.)
Modified: trunk/source/level-0/l0-pred.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/level-0/l0-pred.lisp (original)
+++ trunk/source/level-0/l0-pred.lisp Mon Nov 28 12:32:59 2011
@@ -86,15 +86,14 @@
=
(defun rationalp (x)
"Return true if OBJECT is a RATIONAL, and NIL otherwise."
- (or (fixnump x)
- (let* ((typecode (typecode x)))
- (declare (fixnum typecode))
- #+(or ppc32-target x8632-target arm-target)
- (and (>=3D typecode target::min-numeric-subtag)
- (<=3D typecode target::max-rational-subtag))
- #+(or ppc64-target x8664-target)
- (cond ((=3D typecode target::subtag-bignum) t)
- ((=3D typecode target::subtag-ratio) t)))))
+ (let* ((typecode (typecode x)))
+ (declare (fixnum typecode))
+ (and (< typecode (- target::nbits-in-word target::fixnumshift))
+ (logbitp (the (integer 0 (#.(- target::nbits-in-word target::fixn=
umshift)))
+ typecode)
+ (logior (ash 1 target::tag-fixnum)
+ (ash 1 target::subtag-bignum)
+ (ash 1 target::subtag-ratio))))))
=
(defun short-float-p (x)
(=3D (the fixnum (typecode x)) target::subtag-single-float))
@@ -374,7 +373,7 @@
#+(or ppc32-target arm-target)
(progn
(defparameter *nodeheader-types*
- #(bogus ; 0
+ #(#+arm-target pseudofunction #+ppc32-target bogus ; 0
ratio ; 1
bogus ; 2
complex ; 3
Modified: trunk/source/level-0/l0-symbol.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/level-0/l0-symbol.lisp (original)
+++ trunk/source/level-0/l0-symbol.lisp Mon Nov 28 12:32:59 2011
@@ -218,9 +218,10 @@
=
(defun %global-macro-function (symbol)
(let* ((fbinding (fboundp symbol)))
- (if (and (typep fbinding 'simple-vector)
- (=3D (the fixnum (uvsize fbinding)) 2))
- (let* ((fun (%svref fbinding 1)))
+ (if (and #-arm-target (typep fbinding 'simple-vector)
+ #+arm-target (=3D (typecode fbinding) arm::subtag-pseudofunct=
ion)
+ (=3D (the fixnum (uvsize fbinding)) #-arm-target 2 #+arm-targ=
et 3))
+ (let* ((fun (%svref fbinding #-arm-target 1 #+arm-target 2)))
(if (functionp fun) fun)))))
=
(defun %symbol-binding-address (sym)
Modified: trunk/source/level-0/l0-utils.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/level-0/l0-utils.lisp (original)
+++ trunk/source/level-0/l0-utils.lisp Mon Nov 28 12:32:59 2011
@@ -115,24 +115,19 @@
=
=
(eval-when (:compile-toplevel :execute)
- #+32-bit-target
(defmacro need-use-eql-macro (key)
`(let* ((typecode (typecode ,key)))
(declare (fixnum typecode))
(or (=3D typecode target::subtag-macptr)
- (and (>=3D typecode target::min-numeric-subtag)
- (<=3D typecode target::max-numeric-subtag)))))
- #+64-bit-target
- (defmacro need-use-eql-macro (key)
- `(let* ((typecode (typecode ,key)))
- (declare (fixnum typecode))
- (cond ((=3D typecode target::tag-fixnum) t)
- ((=3D typecode target::subtag-single-float) t)
- ((=3D typecode target::subtag-bignum) t)
- ((=3D typecode target::subtag-double-float) t)
- ((=3D typecode target::subtag-ratio) t)
- ((=3D typecode target::subtag-complex) t)
- ((=3D typecode target::subtag-macptr) t))))
+ (and (< typecode (- target::nbits-in-word target::fixnumshift))
+ (logbitp (the (integer 0 (#.(- target::nbits-in-word target::fixn=
umshift)))
+ typecode)
+ (logior (ash 1 target::tag-fixnum)
+ (ash 1 target::subtag-bignum)
+ (ash 1 target::subtag-single-float)
+ (ash 1 target::subtag-double-float)
+ (ash 1 target::subtag-ratio)
+ (ash 1 target::subtag-complex)))))))
=
)
=
Modified: trunk/source/level-0/nfasload.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/level-0/nfasload.lisp (original)
+++ trunk/source/level-0/nfasload.lisp Mon Nov 28 12:32:59 2011
@@ -683,8 +683,11 @@
(vector (%alloc-misc n subtype)))
(declare (fixnum n subtype))
(%epushval s vector)
- (dotimes (i n (setf (faslstate.faslval s) vector))
- (setf (%svref vector i) (%fasl-expr s)))))
+ (dotimes (i n)
+ (setf (%svref vector i) (%fasl-expr s)))
+ #+arm-target (when (=3D subtype arm::subtag-function)
+ (%fix-fn-entrypoint vector))
+ (setf (faslstate.faslval s) vector)))
=
(deffaslop $fasl-vgvec (s)
(let* ((subtype (%fasl-read-byte s)))
@@ -959,8 +962,8 @@
(incf pos 8)
(let* ((version (%fasl-read-word s)))
(declare (fixnum version))
- (if (or (> version (+ #xff00 $fasl-vers))
- (< version (+ #xff00 $fasl-min-vers)))
+ (if (or (> version (+ #xff00 target::fasl-max-ver=
sion))
+ (< version (+ #xff00 target::fasl-min-ver=
sion)))
(%err-disp (if (>=3D version #xff00) $xfaslvers=
$xnotfasl))
(progn
(setf (faslstate.faslversion s) version)
Modified: trunk/source/level-1/arm-callback-support.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/level-1/arm-callback-support.lisp (original)
+++ trunk/source/level-1/arm-callback-support.lisp Mon Nov 28 12:32:59 2011
@@ -30,7 +30,7 @@
(%get-unsigned-long p 4)
(arm-lap-word (ldr pc (:@ pc (:$ -4))))
(%get-unsigned-long p 8)
- #.(subprim-name->offset '.SPeabi-callback))
+ (%lookup-subprim-address #.(subprim-name->offset '.SPeabi-call=
back)))
(ff-call (%kernel-import #.arm::kernel-import-makedataexecutable) =
:address p =
:unsigned-fullword 12
Modified: trunk/source/level-1/l1-clos-boot.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/level-1/l1-clos-boot.lisp (original)
+++ trunk/source/level-1/l1-clos-boot.lisp Mon Nov 28 12:32:59 2011
@@ -1679,6 +1679,9 @@
=
(defstatic *function-class* (make-built-in-class 'function))
=
+#+arm-target
+(make-built-in-class 'pseudofunction)
+
(defun alias-class (name class)
(setf (find-class name) class
(info-type-kind name) :instance)
@@ -2348,6 +2351,8 @@
(map-subtag ppc32::subtag-creole-object creole-object)
(map-subtag target::subtag-xcode-vector xcode-vector)
(map-subtag target::subtag-xfunction xfunction)
+ #+arm-target
+ (map-subtag arm::subtag-pseudofunction pseudofunction)
(map-subtag target::subtag-single-float-vector simple-short-floa=
t-vector)
#+64-bit-target
(map-subtag target::subtag-u64-vector simple-unsigned-doubleword=
-vector)
@@ -2612,13 +2617,15 @@
nil ;method-function name
(dpb 1 $lfbits-numreq (ash 1 $lfbits-method-bit)))
#+arm-target
- (gvector :function
- #.(ash (arm::arm-subprimitive-address '.SPfix-nfn-entrypoint) (=
- arm::fixnumshift))
+ (%fix-fn-entrypoint
+ (gvector :function
+ 0
(uvref *reader-method-function-proto* 1)
(ensure-slot-id (%slot-definition-name dslotd))
'slot-id-value
nil ;method-function name
(dpb 1 $lfbits-numreq (ash 1 $lfbits-method-bit))))
+ )
=
(defmethod create-writer-method-function ((class slots-class)
(writer-method-class standard-writer-method)
@@ -2638,13 +2645,14 @@
nil
(dpb 2 $lfbits-numreq (ash 1 $lfbits-method-bit)))
#+arm-target
- (gvector :function
- #.(ash (arm::arm-subprimitive-address '.SPfix-nfn-entrypoint)=
(- arm::fixnumshift))
+ (%fix-fn-entrypoint
+ (gvector :function
+ 0
(uvref *writer-method-function-proto* 1)
(ensure-slot-id (%slot-definition-name dslotd))
'set-slot-id-value
nil
- (dpb 2 $lfbits-numreq (ash 1 $lfbits-method-bit)))
+ (dpb 2 $lfbits-numreq (ash 1 $lfbits-method-bit))))
)
=
=
Modified: trunk/source/level-1/l1-clos.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/level-1/l1-clos.lisp (original)
+++ trunk/source/level-1/l1-clos.lisp Mon Nov 28 12:32:59 2011
@@ -380,15 +380,16 @@
(dpb 1 $lfbits-numreq
(ash -1 $lfbits-noname-bit)))
#+arm-target
- (gvector :function
- #.(ash (arm::arm-subprimitive-address '.SPfix-nfn-e=
ntrypoint) (- arm::fixnumshift))
+ (%fix-fn-entrypoint
+ (gvector :function
+ 0
(%svref (if small
#'%small-map-slot-id-lookup
#'%large-map-slot-id-lookup) 1)
map
table
(dpb 1 $lfbits-numreq
- (ash -1 $lfbits-noname-bit)))
+ (ash -1 $lfbits-noname-bit))))
#+x86-target
(%clone-x86-function (if small
#'%small-map-slot-id-lookup
@@ -412,8 +413,9 @@
(dpb 2 $lfbits-numreq
(ash -1 $lfbits-noname-bit)))
#+arm-target
- (gvector :function
- #.(ash (arm::arm-subprimitive-address '.SPfix-nfn-e=
ntrypoint) (- arm::fixnumshift))
+ (%fix-fn-entrypoint
+ (gvector :function
+ 0
(%svref (if small
#'%small-slot-id-value
#'%large-slot-id-value) 1)
@@ -423,7 +425,7 @@
#'%maybe-std-slot-value-using-class
#'%slot-id-ref-missing
(dpb 2 $lfbits-numreq
- (ash -1 $lfbits-noname-bit)))
+ (ash -1 $lfbits-noname-bit))))
#+x86-target
(%clone-x86-function (if small
#'%small-slot-id-value
@@ -449,8 +451,9 @@
(dpb 3 $lfbits-numreq
(ash -1 $lfbits-noname-bit)))
#+arm-target
- (gvector :function
- #.(ash (arm::arm-subprimitive-address '.SPfix-nfn-e=
ntrypoint) (- arm::fixnumshift))
+ (%fix-fn-entrypoint
+ (gvector :function
+ 0
(%svref (if small
#'%small-set-slot-id-value
#'%large-set-slot-id-value) 1)
@@ -460,7 +463,7 @@
#'%maybe-std-setf-slot-value-using-class
#'%slot-id-set-missing
(dpb 3 $lfbits-numreq
- (ash -1 $lfbits-noname-bit)))
+ (ash -1 $lfbits-noname-bit))))
#+x86-target
(%clone-x86-function
(if small
@@ -1704,8 +1707,9 @@
(logior (ash 1 $lfbits-gfn-bit)
(ash 1 $lfbits-aok-bit)))
#+arm-target
- (gvector :function
- #.(ash (arm::arm-subprimitive-address '.SPfix-nfn-entr=
ypoint) (- arm::fixnumshift))
+ (%fix-fn-entrypoint
+ (gvector :function
+ 0
*unset-fin-code*
wrapper
slots
@@ -1713,7 +1717,7 @@
#'false
0
(logior (ash 1 $lfbits-gfn-bit)
- (ash 1 $lfbits-aok-bit)))))
+ (ash 1 $lfbits-aok-bit))))))
(setf (slot-vector.instance slots) fn)
(when dt
(setf (%gf-dispatch-table-gf dt) fn))
Modified: trunk/source/level-1/l1-dcode.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/level-1/l1-dcode.lisp (original)
+++ trunk/source/level-1/l1-dcode.lisp Mon Nov 28 12:32:59 2011
@@ -427,8 +427,12 @@
(dt (make-gf-dispatch-table))
(slots (allocate-typed-vector :slot-vector (1+ len) (%slot-unbound-mark=
er)))
(fn #+(or ppc-target arm-target)
- (gvector :function
- #+arm-target #.(ash (arm::arm-subprimitive-add=
ress '.SPfix-nfn-entrypoint) (- arm::fixnumshift))
+ (#+arm-target
+ %fix-fn-entrypoint
+ #-arm-target
+ progn
+ (gvector :function
+ #+arm-target 0
*gf-proto-code*
wrapper
slots
@@ -436,7 +440,7 @@
#'%%0-arg-dcode
0
(%ilogior (%ilsl $lfbits-gfn-bit 1)
- (%ilogand $lfbits-args-mask 0)))
+ (%ilogand $lfbits-args-mask 0))))
#+x86-target
(%clone-x86-function *gf-proto*
wrapper
@@ -475,14 +479,18 @@
(defun %cons-combined-method (gf thing dcode)
;; set bits and name =3D gf
#+(or ppc-target arm-target)
- (gvector :function
- #+arm-target #.(ash (arm::arm-subprimitive-address '.SPfix-nfn-=
entrypoint) (- arm::fixnumshift))
+ (#+arm-target
+ %fix-fn-entrypoint
+ #-arm-target
+ progn
+ (gvector :function =
+ #+arm-target 0
*cm-proto-code*
thing
dcode
gf
(%ilogior (%ilsl $lfbits-cm-bit 1)
- (%ilogand $lfbits-args-mask (lfun-bits gf))))
+ (%ilogand $lfbits-args-mask (lfun-bits gf)))))
#+x86-target
(%clone-x86-function *cm-proto*
thing
Modified: trunk/source/level-1/l1-sockets.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/level-1/l1-sockets.lisp (original)
+++ trunk/source/level-1/l1-sockets.lisp Mon Nov 28 12:32:59 2011
@@ -1265,7 +1265,7 @@
(> (#_select 1 (%null-ptr) writefds exceptfds (if timeout-in-milliseco=
nds tv (%null-ptr))) 0)))
=
=
-;;; If attempts to connnect are interrupted, we basically have to
+;;; If attempts to connect are interrupted, we basically have to
;;; wait in #_select (or the equivalent). There's a good rant
;;; about these issues in:
;;; <http://www.madore.org/~david/computers/connect-intr.html>
Modified: trunk/source/level-1/l1-typesys.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/level-1/l1-typesys.lisp (original)
+++ trunk/source/level-1/l1-typesys.lisp Mon Nov 28 12:32:59 2011
@@ -4305,13 +4305,14 @@
nil
(dpb 1 $lfbits-numreq 0))
#+arm-target
- (gvector :function
- #.(ash (arm::arm-subprimitive-address '.SPfix-nfn-entrypoint) (=
- arm::fixnumshift))
+ (%fix-fn-entrypoint
+ (gvector :function
+ 0
(uvref *simple-predicate-function-prototype* 1)
datum
function
nil
- (dpb 1 $lfbits-numreq 0))
+ (dpb 1 $lfbits-numreq 0)))
#+x86-target
(%clone-x86-function
*simple-predicate-function-prototype*
Modified: trunk/source/lib/nfcomp.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/lib/nfcomp.lisp (original)
+++ trunk/source/lib/nfcomp.lisp Mon Nov 28 12:32:59 2011
@@ -1196,7 +1196,6 @@
;;;;
;These should be constants, but it's too much trouble when need to change =
'em.
(defparameter FASL-FILE-ID #xFF00) ;Overall file format, shouldn't change=
much
-(defparameter FASL-VERSION #xFF5f) ;Fasl block format. ($fasl-vers)
=
(defvar *fasdump-hash*)
(defvar *fasdump-read-package*)
@@ -1486,9 +1485,16 @@
(when (and opened? (not finished?))
(delete-file filename)))))
=
+(defun target-fasl-version ()
+ (let* ((package (find-package "TARGET"))
+ (sym (find-symbol "FASL-VERSION" package)))
+ (unless (and sym (boundp sym))
+ (error "FASL-VERSION not defined in target package ~s." package))
+ (logior #xff00 (logand #xff (symbol-value sym)))))
+
(defun fasl-dump-block (gnames goffsets forms hash)
(let ((etab-size (hash-table-count hash)))
- (fasl-out-word FASL-VERSION) ; Word 0
+ (fasl-out-word (target-fasl-version)) ; Word 0
(fasl-out-long 0)
(fasl-out-byte $fasl-vetab-alloc)
(fasl-out-count etab-size)
@@ -1734,12 +1740,7 @@
(dotimes (i n)
(if (=3D i 0)
(target-arch-case
- (:arm
- (let ((arm-subprimitive-address
- (find-symbol "ARM-SUBPRIMITIVE-ADDRESS" "ARM")))
- (fasl-dump-form
- (ash (funcall arm-subprimitive-address '.SPfix-nfn-entrypoint)
- (- target::fixnumshift))))) ; host's fixnumshift
+ (:arm (fasl-dump-form 0))
(t (fasl-dump-form (%svref f i))))
(fasl-dump-form (%svref f i)))))))
=
Modified: trunk/source/lisp-kernel/arm-asmutils.s
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/lisp-kernel/arm-asmutils.s (original)
+++ trunk/source/lisp-kernel/arm-asmutils.s Mon Nov 28 12:32:59 2011
@@ -36,7 +36,8 @@
__(mov r3,#0)
__(mov r12,#0x80000000)
__(svc #0)
- __endif =
+ __endif =
+ __(isb sy) =
__(bx lr)
=
_exportfn(C(touch_page))
Modified: trunk/source/lisp-kernel/arm-constants.h
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/lisp-kernel/arm-constants.h (original)
+++ trunk/source/lisp-kernel/arm-constants.h Mon Nov 28 12:32:59 2011
@@ -118,11 +118,13 @@
#define t_value (lisp_nil+t_offset)
=
/* The order in which various header values are defined is significant in=
several ways: */
-/* 1) Numeric subtags precede non-numeric ones; there are further orderin=
gs among numeric subtags. */
+/* 1) Numeric subtags are small enough that we can implement things like
+ NUMBERP via LOGBITP. There can be other (non-numeric) typecodes who=
se
+ value is smaller than that of some numeric typecodes. */
/* 2) All subtags which denote CL arrays are preceded by those that don't=
, */
/* with a further ordering which requires that (< header-arrayH header=
-vectorH , at all-other-CL-vector-types) */
/* 3) The element-size of ivectors is determined by the ordering of ivect=
or subtags. */
-/* 4) All subtags are >=3D fulltag-immheader . */
+
=
#define SUBTAG(tag,subtag) ((tag) | ((subtag) << ntagbits))
#define IMM_SUBTAG(subtag) SUBTAG(fulltag_immheader,(subtag))
@@ -132,19 +134,10 @@
/* Numeric subtags. */
=
#define subtag_bignum IMM_SUBTAG(0)
-#define min_numeric_subtag subtag_bignum
-
#define subtag_ratio NODE_SUBTAG(1)
-#define max_rational_subtag subtag_ratio
-
#define subtag_single_float IMM_SUBTAG(1)
#define subtag_double_float IMM_SUBTAG(2)
-#define min_float_subtag subtag_single_float
-#define max_float_subtag subtag_double_float
-#define max_real_subtag subtag_double_float
-
#define subtag_complex NODE_SUBTAG(3)
-#define max_numeric_subtag subtag_complex
=
=
/* CL array types. There are more immediate types than node types; all C=
L array subtags must be > than */
@@ -179,18 +172,17 @@
#define min_vector_subtag subtag_vectorH
#define min_array_subtag subtag_arrayH
=
-/* So, we get the remaining subtags (n: (n > max-numeric-subtag) & (n < m=
in-array-subtag)) */
+/* So, we get the remaining subtags (n: (n < min-array-subtag)) */
/* for various immediate/node object types. */
=
#define subtag_macptr IMM_SUBTAG(3)
-#define min_non_numeric_imm_subtag subtag_macptr
-
#define subtag_dead_macptr IMM_SUBTAG(4)
#define subtag_code_vector IMM_SUBTAG(5)
#define subtag_creole IMM_SUBTAG(6)
=
#define max_non_array_imm_subtag ((19<<ntagbits)|fulltag_immheader)
=
+#define subtag_pseudofunction NODE_SUBTAG(0)
#define subtag_catch_frame NODE_SUBTAG(4)
#define subtag_function NODE_SUBTAG(5)
#define subtag_basic_stream NODE_SUBTAG(6)
@@ -204,7 +196,9 @@
#define subtag_instance NODE_SUBTAG(14)
#define subtag_struct NODE_SUBTAG(15)
#define subtag_istruct NODE_SUBTAG(16)
-#define max_non_array_node_subtag ((19<<ntagbits)|fulltag_immheader)
+#define subtag_value_cell NODE_SUBTAG(17)
+#define subtag_xfunction NODE_SUBTAG(18)
+#define max_non_array_node_subtag ((18<<ntagbits)|fulltag_immheader)
=
=
typedef struct double_float {
@@ -301,6 +295,8 @@
LispObj *tlb_pointer;
unsigned shutdown_count;
void *safe_ref_address;
+ LispObj spare[22]; /* allocate new things here */
+ LispObj sptab[256]; /* subprims table */
} TCR;
=
/* =
@@ -327,3 +323,7 @@
#define FPSCR_OFE_BIT 10 /* overflow enable */
#define FPSCR_UFE_BIT 11 /* underflow enable */
#define FPSCR_IXE_BIT 12 /* inexact enable */
+
+#define ABI_VERSION_MIN 1038
+#define ABI_VERSION_CURRENT 1038
+#define ABI_VERSION_MAX 1038
Modified: trunk/source/lisp-kernel/arm-constants.s
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/lisp-kernel/arm-constants.s (original)
+++ trunk/source/lisp-kernel/arm-constants.s Mon Nov 28 12:32:59 2011
@@ -211,22 +211,19 @@
stack_alloc_marker =3D subtag_stack_alloc_marker =
=
=
-/*Numeric subtags. */
+/*Numeric subtags. We want to keep these small, so that things like
+ NUMBERP can do LOGBITP of a bitmask that fits in a machine word/fixnum,
+ but we don't want to assume that all small typecodes are numbers.
+ Trying to enforce that assumption has wasted a few typecodes, and it's
+ not like we have so many that we can afford to do that.
+*/ =
=
define_imm_subtag(bignum,0)
-min_numeric_subtag =3D subtag_bignum
-
define_node_subtag(ratio,1)
-max_rational_subtag =3D subtag_ratio
-
define_imm_subtag(single_float,1)
define_imm_subtag(double_float,2)
-min_float_subtag =3D subtag_single_float
-max_float_subtag =3D subtag_double_float
-max_real_subtag =3D subtag_double_float
-
define_node_subtag(complex,3)
-max_numeric_subtag =3D subtag_complex
+
=
=
/* CL array types. There are more immediate types than node types; all CL=
array subtags must be > than */
@@ -263,14 +260,12 @@
/* for various immediate/node object types. */
=
define_imm_subtag(macptr,3)
-min_non_numeric_imm_subtag =3D subtag_macptr
-
define_imm_subtag(dead_macptr,4)
define_imm_subtag(code_vector,5)
define_imm_subtag(creole,6)
=
max_non_array_imm_subtag =3D (18<<ntagbits)|fulltag_immheader
-
+ define_node_subtag(pseudofunction,0)
define_node_subtag(catch_frame,4)
define_node_subtag(function,5)
define_node_subtag(basic_stream,6)
Modified: trunk/source/lisp-kernel/arm-exceptions.c
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/lisp-kernel/arm-exceptions.c (original)
+++ trunk/source/lisp-kernel/arm-exceptions.c Mon Nov 28 12:32:59 2011
@@ -1398,7 +1398,7 @@
sigset_t mask;
sigfillset(&mask);
#else
- int mask [] =3D {0,0};
+ int mask [] =3D {-1,-1};
#endif
=
pthread_sigmask(SIG_SETMASK,(sigset_t *)&mask, NULL);
@@ -1409,13 +1409,16 @@
=
=
void
-signal_handler(int signum, siginfo_t *info, ExceptionInformation *context=
, TCR *tcr, int old_valence, natural old_last_lisp_frame)
+signal_handler(int signum, siginfo_t *info, ExceptionInformation *context
+#ifdef DARWIN
+, TCR *tcr, int old_valence, natural old_last_lisp_frame
+#endif
+)
{
xframe_list xframe_link;
-
- if (!use_mach_exception_handling) {
+#ifndef DARWIN
=
- tcr =3D (TCR *) get_interrupt_tcr(false);
+ TCR *tcr =3D (TCR *) get_interrupt_tcr(false);
=
/* The signal handler's entered with all signals (notably the
thread_suspend signal) blocked. Don't allow any other signals
@@ -1424,10 +1427,12 @@
context.
*/
=
- old_last_lisp_frame =3D tcr->last_lisp_frame;
+ natural old_last_lisp_frame =3D tcr->last_lisp_frame;
+ int old_valence;
+
tcr->last_lisp_frame =3D xpGPR(context,Rsp);
old_valence =3D prepare_to_wait_for_exception_lock(tcr, context);
- }
+#endif
=
if (tcr->flags & (1<<TCR_FLAG_BIT_PENDING_SUSPEND)) {
CLR_TCR_FLAG(tcr, TCR_FLAG_BIT_PENDING_SUSPEND);
@@ -1439,7 +1444,7 @@
if ((!handle_exception(signum, context, tcr, info, old_valence))) {
char msg[512];
snprintf(msg, sizeof(msg), "Unhandled exception %d at 0x%lx, context->=
regs at #x%lx", signum, xpPC(context), (natural)xpGPRvector(context));
- if (lisp_Debugger(context, info, signum, false, msg)) {
+ if (lisp_Debugger(context, info, signum, (old_valence !=3D TCR_STATE_L=
ISP), msg)) {
SET_TCR_FLAG(tcr,TCR_FLAG_BIT_PROPAGATE_EXCEPTION);
}
}
@@ -1509,7 +1514,7 @@
return;
}
}
- signal_handler(signum,info,xp, NULL, 0, 0);
+ signal_handler(signum,info,xp);
}
=
=
@@ -1922,6 +1927,7 @@
signal(SIGPIPE, SIG_IGN);
}
=
+
#ifdef USE_SIGALTSTACK
void
setup_sigaltstack(area *a)
Modified: trunk/source/lisp-kernel/arm-gc.c
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/lisp-kernel/arm-gc.c (original)
+++ trunk/source/lisp-kernel/arm-gc.c Mon Nov 28 12:32:59 2011
@@ -102,7 +102,7 @@
check_range(LispObj *start, LispObj *end, Boolean header_allowed)
{
LispObj node, *current =3D start, *prev =3D NULL;
- int tag;
+ int tag,subtag;
natural elements;
=
while (current < end) {
@@ -118,7 +118,9 @@
if (! header_allowed) {
Bug(NULL, "Header not expected at 0x%lx\n", prev);
}
- if (header_subtag(node) =3D=3D subtag_function) {
+ subtag =3D header_subtag(node);
+ if ((subtag =3D=3D subtag_function) ||
+ (subtag =3D=3D subtag_pseudofunction)) {
if (fulltag_of(current[0]) =3D=3D fulltag_odd_fixnum) {
if (untag(current[0]) !=3D untag(current[1])) {
Bug(NULL, "In function at 0x%lx, entrypoint (0x%lx) and codeve=
ctor (0x%lx) don't match\n", (LispObj)prev,current[0],current[1]);
@@ -1207,7 +1209,7 @@
forward_range(LispObj *range_start, LispObj *range_end)
{
LispObj *p =3D range_start, node, new;
- int tag_n;
+ int tag_n,subtag;
natural nwords;
hash_table_vector_header *hashp;
=
@@ -1246,7 +1248,9 @@
*p++ =3D 0;
} else {
p++;
- if (header_subtag(node) =3D=3D subtag_function) {
+ subtag =3D header_subtag(node);
+ if ((subtag =3D=3D subtag_function) ||
+ (subtag =3D=3D subtag_pseudofunction)) {
update_locref(p);
p++;
nwords--;
@@ -1299,6 +1303,7 @@
LispObj *current =3D (LispObj *)(a->active)
, *limit =3D (LispObj*)(a->high), header;
lisp_frame *frame;
+ unsigned subtag;
=
while (current < limit) {
header =3D *current;
@@ -1315,7 +1320,9 @@
natural elements =3D header_element_count(header);
=
current++;
- if (header_subtag(header) =3D=3D subtag_function) {
+ subtag =3D header_subtag(header);
+ if ((subtag =3D=3D subtag_function) ||
+ (subtag =3D=3D subtag_pseudofunction)) {
update_locref(current);
current++;
elements--;
@@ -1358,6 +1365,33 @@
=
}
=
+void
+flush_code_vectors_in_range(LispObj *start,LispObj *end)
+{
+ LispObj *current =3D start,header;
+ unsigned tag,subtag;
+ natural nbytes, nwords;
+ char *range_start;
+
+ while (current !=3D end) {
+ header =3D *current;
+ tag =3D fulltag_of(header);
+ if (immheader_tag_p(tag)) {
+ subtag =3D header_subtag(header);
+ if (subtag =3D=3D subtag_code_vector) {
+ range_start =3D (char *)(current+1);
+ nbytes =3D header_element_count(header)<<2;
+ flush_cache_lines(range_start,nbytes);
+ }
+ current =3D skip_over_ivector((LispObj)current,header);
+ } else if (nodeheader_tag_p(tag)) {
+ nwords =3D header_element_count(header)+1;
+ current +=3D (nwords+(nwords&1));
+ } else {
+ current +=3D 2;
+ }
+ }
+}
=
void
forward_tcr_xframes(TCR *tcr)
@@ -1398,7 +1432,7 @@
bits, =
nextbit, =
diff;
- int tag;
+ int tag, subtag;
bitvector markbits =3D GCmarkbits;
/* keep track of whether or not we saw any
code_vector headers, and only flush cache if so. */
@@ -1474,7 +1508,9 @@
src++;
} else {
*dest++ =3D node;
- if (header_subtag(node) =3D=3D subtag_function) {
+ subtag =3D header_subtag(node);
+ if ((subtag =3D=3D subtag_function) ||
+ (subtag =3D=3D subtag_pseudofunction)) {
*dest++ =3D locative_forwarding_address(*src++);
} else {
*dest++ =3D node_forwarding_address(*src++);
@@ -1525,7 +1561,8 @@
{
natural nbytes =3D (natural)ptr_to_lispobj(dest) - (natural)GCfirstu=
nmarked;
if ((nbytes !=3D 0) && GCrelocated_code_vector) {
- xMakeDataExecutable((LogicalAddress)ptr_from_lispobj(GCfirstunmark=
ed), nbytes);
+ flush_code_vectors_in_range((LispObj *)GCfirstunmarked,
+ (LispObj *)dest);
}
}
}
@@ -1690,7 +1727,7 @@
purify_range(LispObj *start, LispObj *end, BytePtr low, BytePtr high, area=
*to)
{
LispObj header;
- unsigned tag;
+ unsigned tag, subtag;
=
while (start < end) {
header =3D *start;
@@ -1705,7 +1742,9 @@
copy_ivector_reference(start, low, high, to);
}
start++;
- if (header_subtag(header) =3D=3D subtag_function) {
+ subtag =3D header_subtag(header);
+ if ((subtag =3D=3D subtag_function) ||
+ (subtag =3D=3D subtag_pseudofunction)) {
LispObj entrypt =3D *start;
if ((entrypt > (LispObj)low) && =
(entrypt < (LispObj)high) &&
@@ -1748,6 +1787,7 @@
LispObj *current =3D (LispObj *)(a->active)
, *limit =3D (LispObj*)(a->high), header;
lisp_frame *frame;
+ unsigned subtag;
=
=
while(current < limit) {
@@ -1766,7 +1806,9 @@
natural elements =3D header_element_count(header);
=
current++;
- if (header_subtag(header) =3D=3D subtag_function) {
+ subtag =3D header_subtag(header);
+ if ((subtag =3D=3D subtag_function) ||
+ (subtag =3D=3D subtag_pseudofunction)) {
purify_locref(current, low, high, to);
current++;
elements--;
@@ -1962,6 +2004,8 @@
LispObj *current =3D (LispObj *)(a->active)
, *limit =3D (LispObj*)(a->high), header;
lisp_frame *frame;
+ unsigned subtag;
+
while(current < limit) {
header =3D *current;
=
@@ -1978,7 +2022,9 @@
natural elements =3D header_element_count(header);
=
current++;
- if (header_subtag(header) =3D=3D subtag_function) {
+ subtag =3D header_subtag(header);
+ if ((subtag =3D=3D subtag_function) || =
+ (subtag =3D=3D subtag_pseudofunction)) {
impurify_locref(current, low, high, delta);
current++;
elements--;
@@ -2024,7 +2070,7 @@
impurify_range(LispObj *start, LispObj *end, LispObj low, LispObj high, in=
t delta)
{
LispObj header;
- unsigned tag;
+ unsigned tag, subtag;
=
while (start < end) {
header =3D *start;
@@ -2036,7 +2082,9 @@
impurify_noderef(start, low, high, delta);
}
start++;
- if (header_subtag(header) =3D=3D subtag_function) {
+ subtag =3D header_subtag(header);
+ if ((subtag =3D=3D subtag_function) ||
+ (subtag =3D=3D subtag_pseudofunction)) {
LispObj entrypt =3D *start;
if ((entrypt > (LispObj)low) && =
(entrypt < (LispObj)high) &&
Modified: trunk/source/lisp-kernel/arm-spentry.s
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/lisp-kernel/arm-spentry.s (original)
+++ trunk/source/lisp-kernel/arm-spentry.s Mon Nov 28 12:32:59 2011
@@ -21,16 +21,7 @@
.syntax unified
=
local_label(start):
- .set delta,256
- .set spnum,0
- .set sporg,0
define(`_spentry',`ifdef(`__func_name',`_endfn',`')
- .org sporg
- .set sporg,sporg+delta
- .set spnum,spnum+1
- .if spnum >=3D 112
- .set delta,1024
- .endif
_startfn(_SP$1)
L__SP$1: =
.line __line__
@@ -66,18 +57,6 @@
__(restore_lisp_frame(imm0))
__(jump_nfn())
=
- /* This isn't a subprim - we never have to MOV this address
- to the PC, but it gets LDRed into the PC as part of the
- standard calling sequence. Ensuring that that happens -
- without having to deal with updating the entrypoint associated
- with a relocatable code-vector stored in a non-function -
- is easiest if we use a fixed address here. */
- =
- .org sporg-delta+0x40
-_startfn(udfcall)
- __(uuo_error_udf_call(al,fname))
- __(jump_fname)
-_endfn =
=
_spentry(builtin_plus)
__(test_two_fixnums(arg_y,arg_z,imm0))
@@ -2186,14 +2165,22 @@
__(uuo_error_reg_not_xtype(al,arg_z,xtype_u64))
2: __(movc16(imm1,three_digit_bignum_header))
__(cmp imm0,imm1)
- __(uuo_error_reg_not_xtype(ne,arg_z,xtype_u64))
+ __(bne 3f)
__(vrefr(imm2,arg_z,2))
__(cmp imm2,#0)
__(vrefr(imm1,arg_z,1))
__(vrefr(imm0,arg_z,0))
__(bxeq lr)
__(uuo_error_reg_not_xtype(al,arg_z,xtype_u64))
-
+3: __(movc16(imm1,one_digit_bignum_header))
+ __(cmp imm0,imm1)
+ __(bne 0b)
+ __(vrefr(imm0,arg_z,0))
+ __(mov imm1,#0)
+ __(cmp imm0,#0)
+ __(bxgt lr)
+ __(b 0b)
+ __
=
/* arg_z should be of type (SIGNED-BYTE 64); */
/* return high 32 bits in imm1, low 32 bits in imm0 */
@@ -2206,7 +2193,14 @@
__(mov imm2,#0)
__(extract_lisptag(imm0,arg_z))
__(cmp imm0,#tag_misc)
+ __(movc16(imm1,one_digit_bignum_header))
__(ldreq imm2,[arg_z,#misc_header_offset])
+ __(cmp imm1,imm2)
+ __(bne 0f)
+ __(vrefr(imm0,arg_z,0))
+ __(mov imm1,imm0,asr #31)
+ __(bx lr)
+0: =
__(movc16(imm1,two_digit_bignum_header))
__(cmp imm1,imm2)
__(beq 1f)
@@ -3173,7 +3167,7 @@
__(b local_label(misc_ref_invalid)) /* 00 even_fixnum */
=
__(b local_label(misc_ref_invalid)) /* 01 cons */
- __(b local_label(misc_ref_invalid)) /* 02 nodeheader */
+ __(b local_label(misc_ref_node)) /* 02 pseudofunction */
__(b local_label(misc_ref_invalid)) /* 03 imm */
__(b local_label(misc_ref_invalid)) /* 04 odd_fixnum */
__(b local_label(misc_ref_invalid)) /* 05 nil */
@@ -3539,7 +3533,7 @@
/* 00-0f */
__(b local_label(misc_set_invalid)) /* 00 even_fixnum */
__(b local_label(misc_set_invalid)) /* 01 cons */
- __(b local_label(misc_set_invalid)) /* 02 nodeheader */
+ __(b _SPgvset) /* 02 pseudofunction */
__(b local_label(misc_set_invalid)) /* 03 imm */
__(b local_label(misc_set_invalid)) /* 04 odd_fixnum */
__(b local_label(misc_set_invalid)) /* 05 nil */
@@ -4416,6 +4410,143 @@
__(ldmia sp!,{r4,r5,r6,r7,r8,r9,r10,r11,r12,lr})
__(bx lr)
=
-_exportfn(_SPsp_end)
- __(nop)
+ .data
+ .global C(sptab)
+ .global C(sptab_end)
+ new_local_labels()
+C(sptab):
+ .long local_label(start)
+C(sptab_end): =
+ .long local_label(end)
+local_label(start): =
+ .long _SPfix_nfn_entrypoint /* must be first */
+ .long _SPbuiltin_plus
+ .long _SPbuiltin_minus
+ .long _SPbuiltin_times
+ .long _SPbuiltin_div
+ .long _SPbuiltin_eq
+ .long _SPbuiltin_ne
+ .long _SPbuiltin_gt
+ .long _SPbuiltin_ge
+ .long _SPbuiltin_lt
+ .long _SPbuiltin_le
+ .long _SPbuiltin_eql
+ .long _SPbuiltin_length
+ .long _SPbuiltin_seqtype
+ .long _SPbuiltin_assq
+ .long _SPbuiltin_memq
+ .long _SPbuiltin_logbitp
+ .long _SPbuiltin_logior
+ .long _SPbuiltin_logand
+ .long _SPbuiltin_ash
+ .long _SPbuiltin_negate
+ .long _SPbuiltin_logxor
+ .long _SPbuiltin_aref1
+ .long _SPbuiltin_aset1
+ .long _SPfuncall
+ .long _SPmkcatch1v
+ .long _SPmkcatchmv
+ .long _SPmkunwind
+ .long _SPbind
+ .long _SPconslist
+ .long _SPconslist_star
+ .long _SPmakes32
+ .long _SPmakeu32
+ .long _SPfix_overflow
+ .long _SPmakeu64
+ .long _SPmakes64
+ .long _SPmvpass
+ .long _SPvalues
+ .long _SPnvalret
+ .long _SPthrow
+ .long _SPnthrowvalues
+ .long _SPnthrow1value
+ .long _SPbind_self
+ .long _SPbind_nil
+ .long _SPbind_self_boundp_check
+ .long _SPrplaca
+ .long _SPrplacd
+ .long _SPgvset
+ .long _SPset_hash_key
+ .long _SPstore_node_conditional
+ .long _SPset_hash_key_conditional
+ .long _SPstkconslist
+ .long _SPstkconslist_star
+ .long _SPmkstackv
+ .long _SPsetqsym
+ .long _SPprogvsave
+ .long _SPstack_misc_alloc
+ .long _SPgvector
+ .long _SPfitvals
+ .long _SPnthvalue
+ .long _SPdefault_optional_args
+ .long _SPopt_supplied_p
+ .long _SPheap_rest_arg
+ .long _SPreq_heap_rest_arg
+ .long _SPheap_cons_rest_arg
+ .long _SPcheck_fpu_exception
+ .long _SPdiscard_stack_object
+ .long _SPksignalerr
+ .long _SPstack_rest_arg
+ .long _SPreq_stack_rest_arg
+ .long _SPstack_cons_rest_arg
+ .long _SPcall_closure =
+ .long _SPspreadargz
+ .long _SPtfuncallgen
+ .long _SPtfuncallslide
+ .long _SPjmpsym
+ .long _SPtcallsymgen
+ .long _SPtcallsymslide
+ .long _SPtcallnfngen
+ .long _SPtcallnfnslide
+ .long _SPmisc_ref
+ .long _SPsubtag_misc_ref
+ .long _SPmakestackblock
+ .long _SPmakestackblock0
+ .long _SPmakestacklist
+ .long _SPstkgvector
+ .long _SPmisc_alloc
+ .long _SPatomic_incf_node
+ .long _SPunused1
+ .long _SPunused2
+ .long _SPrecover_values
+ .long _SPinteger_sign
+ .long _SPsubtag_misc_set
+ .long _SPmisc_set
+ .long _SPspread_lexprz
+ .long _SPreset
+ .long _SPmvslide
+ .long _SPsave_values
+ .long _SPadd_values
+ .long _SPmisc_alloc_init
+ .long _SPstack_misc_alloc_init
+ .long _SPpopj
+ .long _SPudiv64by32
+ .long _SPgetu64
+ .long _SPgets64
+ .long _SPspecref
+ .long _SPspecrefcheck
+ .long _SPspecset
+ .long _SPgets32
+ .long _SPgetu32
+ .long _SPmvpasssym
+ .long _SPunbind
+ .long _SPunbind_n
+ .long _SPunbind_to
+ .long _SPprogvrestore
+ .long _SPbind_interrupt_level_0
+ .long _SPbind_interrupt_level_m1
+ .long _SPbind_interrupt_level
+ .long _SPunbind_interrupt_level
+ .long _SParef2
+ .long _SParef3
+ .long _SPaset2
+ .long _SPaset3
+ .long _SPkeyword_bind
+ .long _SPudiv32
+ .long _SPsdiv32
+ .long _SPeabi_ff_call
+ .long _SPdebind
+ .long _SPeabi_callback
+local_label(end): =
_endfile
Modified: trunk/source/lisp-kernel/image.c
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/lisp-kernel/image.c (original)
+++ trunk/source/lisp-kernel/image.c Mon Nov 28 12:32:59 2011
@@ -81,7 +81,8 @@
}
#endif
#ifdef ARM
- if (header_subtag(w0) =3D=3D subtag_function) {
+ if ((header_subtag(w0) =3D=3D subtag_function) ||
+ (header_subtag(w0) =3D=3D subtag_pseudofunction)) {
w1 =3D start[1];
if ((w1 >=3D low) && (w1 < high)) {
start[1]=3D(w1+bias);
Modified: trunk/source/lisp-kernel/image.h
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/lisp-kernel/image.h (original)
+++ trunk/source/lisp-kernel/image.h Mon Nov 28 12:32:59 2011
@@ -90,8 +90,5 @@
=
=
=
-#define ABI_VERSION_MIN 1037
-#define ABI_VERSION_CURRENT 1037
-#define ABI_VERSION_MAX 1037
=
#define NUM_IMAGE_SECTIONS 5 /* used to be 3 */
Modified: trunk/source/lisp-kernel/lisp-debug.c
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/lisp-kernel/lisp-debug.c (original)
+++ trunk/source/lisp-kernel/lisp-debug.c Mon Nov 28 12:32:59 2011
@@ -1438,6 +1438,8 @@
#endif
=
=
+static Boolean in_postmortem =3D false;
+
OSStatus
lisp_Debugger(ExceptionInformation *xp, =
siginfo_t *info, =
@@ -1449,7 +1451,17 @@
va_list args;
debug_command_return state =3D debug_continue;
=
-
+ if (in_postmortem) {
+ /* If we get reentered trying to print crash info, just exit
+ as quickly and quietly as possible. Don't even print a
+ message: stdio may be hosed.
+ */
+#ifdef ANDROID
+ _exit(1);
+#else
+ abort();
+#endif
+ }
if (stdin_is_dev_null()) {
return -1;
}
@@ -1481,6 +1493,7 @@
debug_identify_function(xp, info);
}
if (lisp_global(BATCH_FLAG)) {
+ in_postmortem =3D true;
#ifdef WINDOWS
fprintf(dbgout, "Current Process Id %d\n", (int)GetCurrentProcessId());
#else
@@ -1495,7 +1508,12 @@
debug_memory_areas(xp, info, 0);
debug_show_lisp_version(xp, info, 0);
debug_backtrace(xp, info, 0);
+#ifdef ANDROID
+ /* Android crashes when abort() is called */
+ _exit(1);
+#else
abort();
+#endif
}
=
fprintf(dbgout, "? for help\n");
Modified: trunk/source/lisp-kernel/pmcl-kernel.c
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/lisp-kernel/pmcl-kernel.c (original)
+++ trunk/source/lisp-kernel/pmcl-kernel.c Mon Nov 28 12:32:59 2011
@@ -2060,6 +2060,14 @@
lisp_global(OLDSPACE_DNODE_COUNT) =3D area_dnode(managed_static_area->=
active,managed_static_area->low);
}
atexit(lazarus);
+#ifdef ARM
+#ifdef LINUX
+#ifdef SET_INITIAL_THREAD_AFFINITY
+ /* Maybe work around an apparent cache coherency problem */
+ set_thread_affinity(tcr,0);
+#endif
+#endif
+#endif
start_lisp(TCR_TO_TSD(tcr), 0);
_exit(0);
}
Modified: trunk/source/lisp-kernel/ppc-constants32.h
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/lisp-kernel/ppc-constants32.h (original)
+++ trunk/source/lisp-kernel/ppc-constants32.h Mon Nov 28 12:32:59 2011
@@ -328,6 +328,9 @@
#define heap_segment_size 0x00010000
#define log2_heap_segment_size 16
=
+#define ABI_VERSION_MIN 1037
+#define ABI_VERSION_CURRENT 1037
+#define ABI_VERSION_MAX 1037
=
#endif
=
Modified: trunk/source/lisp-kernel/ppc-constants64.h
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/lisp-kernel/ppc-constants64.h (original)
+++ trunk/source/lisp-kernel/ppc-constants64.h Mon Nov 28 12:32:59 2011
@@ -302,3 +302,6 @@
#define heap_segment_size 0x00020000L
#define log2_heap_segment_size 17L
=
+#define ABI_VERSION_MIN 1037
+#define ABI_VERSION_CURRENT 1037
+#define ABI_VERSION_MAX 1037
Modified: trunk/source/lisp-kernel/thread_manager.c
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/lisp-kernel/thread_manager.c (original)
+++ trunk/source/lisp-kernel/thread_manager.c Mon Nov 28 12:32:59 2011
@@ -181,6 +181,21 @@
return ESRCH;
}
#endif
+
+void
+set_thread_affinity(TCR *target, unsigned cpuno)
+{
+#ifdef LINUX
+ pthread_t thread =3D (pthread_t)(target->osid);
+ cpu_set_t mask;
+ =
+ CPU_ZERO(&mask);
+ CPU_SET(cpuno,&mask);
+ pthread_setaffinity_np(thread,sizeof(mask),&mask);
+#endif
+}
+
+
=
signed_natural
atomic_incf_by(signed_natural *ptr, signed_natural by)
@@ -1225,6 +1240,25 @@
#endif
#endif
=
+#ifdef ARM
+void
+init_arm_tcr_sptab(TCR *tcr)
+{
+ extern LispObj *sptab;
+ extern LispObj *sptab_end;
+ LispObj *p, *q;
+
+ for (p=3Dsptab,q =3D tcr->sptab;
+ p<sptab_end;
+ p++,q++) {
+ *q =3D *p;
+ }
+}
+#endif =
+ =
+ =
+
+
/*
Caller must hold the area_lock.
*/
@@ -1250,6 +1284,9 @@
TCR *tcr =3D allocate_tcr();
#endif
=
+#ifdef ARM
+ init_arm_tcr_sptab(tcr);
+#endif
#ifdef X86
setup_tcr_extra_segment(tcr);
tcr->linear =3D tcr;
Modified: trunk/source/lisp-kernel/x86-constants32.h
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/lisp-kernel/x86-constants32.h (original)
+++ trunk/source/lisp-kernel/x86-constants32.h Mon Nov 28 12:32:59 2011
@@ -462,3 +462,6 @@
#define EFL_DF 1024
#endif
=
+#define ABI_VERSION_MIN 1037
+#define ABI_VERSION_CURRENT 1037
+#define ABI_VERSION_MAX 1037
Modified: trunk/source/lisp-kernel/x86-constants64.h
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/lisp-kernel/x86-constants64.h (original)
+++ trunk/source/lisp-kernel/x86-constants64.h Mon Nov 28 12:32:59 2011
@@ -410,3 +410,6 @@
#define heap_segment_size 0x00020000L
#define log2_heap_segment_size 17L
=
+#define ABI_VERSION_MIN 1037
+#define ABI_VERSION_CURRENT 1037
+#define ABI_VERSION_MAX 1037
Modified: trunk/source/xdump/faslenv.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/xdump/faslenv.lisp (original)
+++ trunk/source/xdump/faslenv.lisp Mon Nov 28 12:32:59 2011
@@ -43,8 +43,6 @@
(defconstant $fasl-epush-bit 7)
(defconstant $fasl-file-id #xff00)
(defconstant $fasl-file-id1 #xff01)
-(defconstant $fasl-vers #x5f)
-(defconstant $fasl-min-vers #x5e)
(defconstant $faslend #xff)
(defconstant $fasl-buf-len 2048)
(defmacro deffaslop (n arglist &body body)
Modified: trunk/source/xdump/heap-image.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/xdump/heap-image.lisp (original)
+++ trunk/source/xdump/heap-image.lisp Mon Nov 28 12:32:59 2011
@@ -96,65 +96,71 @@
(+ 4095 (file-position f)))))
=
=
-(defparameter *image-abi-version* 1037)
+(defun target-image-abi-version ()
+ (let* ((pkg (pkg-arg "TARGET"))
+ (sym (find-symbol "*IMAGE-ABI-VERSION*" pkg)))
+ (or (and sym (boundp sym) (symbol-value sym))
+ (error "*IMAGE-ABI-VERSION* not defined in ~s" pkg))))
+ =
=
-(defun write-image-file (pathname image-base spaces &optional (abi-version=
*image-abi-version*))
- (target-setup-image-header-sizes)
- (with-open-file (f pathname
- :direction :output
- :if-does-not-exist :create
- :if-exists :supersede
- :element-type '(unsigned-byte 8))
- (let* ((nsections (length spaces))
- (header-pos (- 4096 (+ *image-header-size*
- (* nsections *image-section-size*)))))
- (file-position f header-pos)
- (image-write-fullword image-sig0 f)
- (image-write-fullword image-sig1 f)
- (image-write-fullword image-sig2 f)
- (image-write-fullword image-sig3 f)
- (image-write-fullword (get-universal-time) f)
- (image-write-fullword (target-word-size-case
- (32 *xload-image-base-address*)
- (64 0)) f)
- (image-write-fullword (target-word-size-case
- (32 image-base)
- (64 0)) f)
- (image-write-fullword nsections f)
- (image-write-fullword abi-version f)
- (target-word-size-case
- (32
- (dotimes (i 2) (image-write-fullword 0 f))
+(defun write-image-file (pathname image-base spaces )
+ (let* ((abi-version (target-image-abi-version)))
+ (target-setup-image-header-sizes)
+ (with-open-file (f pathname
+ :direction :output
+ :if-does-not-exist :create
+ :if-exists :supersede
+ :element-type '(unsigned-byte 8))
+ (let* ((nsections (length spaces))
+ (header-pos (- 4096 (+ *image-header-size*
+ (* nsections *image-section-size*)))))
+ (file-position f header-pos)
+ (image-write-fullword image-sig0 f)
+ (image-write-fullword image-sig1 f)
+ (image-write-fullword image-sig2 f)
+ (image-write-fullword image-sig3 f)
+ (image-write-fullword (get-universal-time) f)
+ (image-write-fullword (target-word-size-case
+ (32 *xload-image-base-address*)
+ (64 0)) f)
+ (image-write-fullword (target-word-size-case
+ (32 image-base)
+ (64 0)) f)
+ (image-write-fullword nsections f)
+ (image-write-fullword abi-version f)
+ (target-word-size-case
+ (32
+ (dotimes (i 2) (image-write-fullword 0 f))
=
- (image-write-fullword (backend-target-platform *target-backend*) f)
- (dotimes (i 4) (image-write-fullword 0 f)))
- (64
- (image-write-fullword 0 f)
- (image-write-fullword 0 f)
- (image-write-fullword (backend-target-platform *target-backend*) f)
- (image-write-doubleword *xload-image-base-address* f)
- (image-write-doubleword image-base f)))
- (dolist (sect spaces)
- (image-write-natural (ash (xload-space-code sect)
- *xload-target-fixnumshift*)
- f)
- (image-write-natural 0 f)
- (let* ((size (xload-space-lowptr sect)))
- (image-write-natural size f)
- (image-write-natural 0 f))) ; static dnodes.
- (dolist (sect spaces)
- (image-align-output-position f)
- (stream-write-ivector f
- (xload-space-data sect)
- 0
- (xload-space-lowptr sect)))
- ;; Write an openmcl_image_file_trailer.
- (image-write-fullword image-sig0 f)
- (image-write-fullword image-sig1 f)
- (image-write-fullword image-sig2 f)
- (let* ((pos (+ 4 (file-position f))))
- (image-write-fullword (- header-pos pos) f))
- nil)))
+ (image-write-fullword (backend-target-platform *target-backend*)=
f)
+ (dotimes (i 4) (image-write-fullword 0 f)))
+ (64
+ (image-write-fullword 0 f)
+ (image-write-fullword 0 f)
+ (image-write-fullword (backend-target-platform *target-backend*)=
f)
+ (image-write-doubleword *xload-image-base-address* f)
+ (image-write-doubleword image-base f)))
+ (dolist (sect spaces)
+ (image-write-natural (ash (xload-space-code sect)
+ *xload-target-fixnumshift*)
+ f)
+ (image-write-natural 0 f)
+ (let* ((size (xload-space-lowptr sect)))
+ (image-write-natural size f)
+ (image-write-natural 0 f))) ; static dnodes.
+ (dolist (sect spaces)
+ (image-align-output-position f)
+ (stream-write-ivector f
+ (xload-space-data sect)
+ 0
+ (xload-space-lowptr sect)))
+ ;; Write an openmcl_image_file_trailer.
+ (image-write-fullword image-sig0 f)
+ (image-write-fullword image-sig1 f)
+ (image-write-fullword image-sig2 f)
+ (let* ((pos (+ 4 (file-position f))))
+ (image-write-fullword (- header-pos pos) f))
+ nil))))
=
=
=
Modified: trunk/source/xdump/xarmfasload.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/xdump/xarmfasload.lisp (original)
+++ trunk/source/xdump/xarmfasload.lisp Mon Nov 28 12:32:59 2011
@@ -24,6 +24,10 @@
(require "XFASLOAD" "ccl:xdump;xfasload"))
=
=
+(defun xload-arm-set-entrypoint (xload-fn)
+ (setf (xload-%svref xload-fn 0)
+ (logandc2 (xload-%svref xload-fn 1) arm::fixnummask)))
+
(defun xload-arm-lap-word (instruction-form)
(if (listp instruction-form)
(uvref (uvref (compile nil
@@ -36,19 +40,19 @@
=
(defparameter *arm-macro-apply-code*
(let* ((code-vector (uvref (compile nil
- '(lambda (&lap 0)
- (arm-lap-function () ()
- (build-lisp-frame imm0)
- (bla .SPheap-rest-arg)
- (vpop1 arg_z)
- (mov arg_y fname)
- (mov arg_x '#.$xnotfun)
- (set-nargs 3)
- (ba .SPksignalerr))))
+ '(lambda (&lap 0)
+ (arm-lap-function () ()
+ (build-lisp-frame imm0)
+ (sploadlr .SPheap-rest-arg)
+ (blx lr)
+ (vpop1 arg_z)
+ (mov arg_y fname)
+ (mov arg_x '#.$xnotfun)
+ (set-nargs 3)
+ (spjump .SPksignalerr))))
1))
(n (uvsize code-vector))
- (u32-vector (make-array n
- :element-type '(unsigned-byte 32))))
+ (u32-vector (make-array n :element-type '(unsigned-byte 32))))
(declare (fixnum n))
(dotimes (i n u32-vector)
(setf (uvref u32-vector i)
@@ -60,25 +64,19 @@
=
=
(defparameter *arm-closure-trampoline-code*
- (let* ((code0 (xload-arm-lap-word '(ldr pc (:@ pc (:$ 4))))))
- (make-array 4
+ (let* ((code0 (xload-arm-lap-word `(ldr pc (:@ rcontext (:$ ,(arm::arm-s=
ubprimitive-offset '.SPcall-closure)))))))
+ (make-array 1
:element-type '(unsigned-byte 32)
:initial-contents
- (list code0 0 3 (arm::arm-subprimitive-address '.SPcall-cl=
osure)))))
+ (list code0))))
=
-(defun adjust-closure-trampoline-for-subprims-bias (backend-name)
- (let* ((backend (find-backend backend-name))
- (bias (if backend (backend-real-subprims-bias backend) 0))
- (code *arm-closure-trampoline-code*))
- (if (eql bias 0)
- code
- (let* ((new (copy-seq code)))
- (incf (aref new (1- (length new))) bias)
- new))))
+
=
;;; For now, do this with a UUO so that the kernel can catch it.
(defparameter *arm-udf-code*
- (let* ((code '((uuo-error-udf-call (:? al) fname))))
+ (let* ((code '((uuo-error-udf-call (:? al) fname)
+ (ldr nfn (:@ fname (:$ arm::symbol.fcell)))
+ (ldr pc (:@ nfn (:$ arm::function.entrypoint))))))
(make-array (length code)
:element-type '(unsigned-byte 32)
:initial-contents
@@ -136,7 +134,7 @@
(make-backend-xload-info
:name :androidarm
:macro-apply-code-function 'arm-fixup-macro-apply-code
- :closure-trampoline-code (adjust-closure-trampoline-for-subprims-bias :=
androidarm)
+ :closure-trampoline-code *arm-closure-trampoline-code*
:udf-code *arm-udf-code*
:default-image-name "ccl:aarm-boot"
:default-startup-file-name "level-1.aafsl"
Modified: trunk/source/xdump/xfasload.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/xdump/xfasload.lisp (original)
+++ trunk/source/xdump/xfasload.lisp Mon Nov 28 12:32:59 2011
@@ -1050,17 +1050,21 @@
;; then fill in the nilreg-relative symbols in static space.
;; Then start consing ..
(if *xload-target-use-code-vectors*
- ;; The undefined-function object is a 1-element simple-vector (not
- ;; a function vector). The code-vector in its 0th element should
- ;; report the appropriate error.
- ;; On the ARM: make a two-element vector: entrypoint, code-vector.
- (let* ((udf-object (xload-make-gvector :simple-vector 1)))
- (target-arch-case
- (:arm
- (setf (xload-%svref udf-object 0)
- (+ (subprim-name->offset '.SPfix-nfn-entrypoint *target-ba=
ckend*)
- #x40)))
- (otherwise
+ (target-arch-case
+ (:arm
+ ;; On the ARM: make a two-element vector: entrypoint, code-vector.
+ (let* ((udf-object (xload-make-gvector :pseudofunction 2)))
+ (setf (xload-%svref udf-object 1)
+ (xload-save-code-vector
+ (backend-xload-info-udf-code
+ *xload-target-backend*)))
+ (locally (declare (ftype (function (t) t) xload-arm-set-entrypoi=
nt))
+ (xload-arm-set-entrypoint udf-object))))
+ (otherwise
+ ;; The undefined-function object is a 1-element simple-vector (not
+ ;; a function vector). The code-vector in its 0th element should
+ ;; report the appropriate error.
+ (let* ((udf-object (xload-make-gvector :simple-vector 1)))
(setf (xload-%svref udf-object 0)
(xload-save-code-vector
(backend-xload-info-udf-code
@@ -1603,8 +1607,14 @@
(let* ((n (%fasl-read-count s))
(vector (xload-make-gvector subtype n)))
(%epushval s vector)
- (dotimes (i n (setf (faslstate.faslval s) vector))
- (setf (xload-%svref vector i) (%fasl-expr s)))))
+ (dotimes (i n )
+ (setf (xload-%svref vector i) (%fasl-expr s)))
+ (target-arch-case
+ (:arm
+ (when (=3D subtype (xload-target-subtype :function))
+ (locally (declare (ftype (function (t) t) xload-arm-set-entrypoint=
))
+ (xload-arm-set-entrypoint vector)))))
+ (setf (faslstate.faslval s) vector)))
=
(defxloadfaslop $fasl-vgvec (s)
(let* ((subtype (%fasl-read-byte s)))
More information about the Openmcl-cvs-notifications
mailing list