Changeset 13789

Timestamp:

Jun 8, 2010, 1:14:53 AM (10 years ago)

Author:

gb

Message:

Lots of (mostly small) changes.

Location:

branches/arm

Files:

• compiler/ARM/arm-arch.lisp (modified) (7 diffs)
• compiler/ARM/arm-asm.lisp (modified) (8 diffs)
• compiler/ARM/arm-disassemble.lisp (modified) (1 diff)
• compiler/ARM/arm-lap.lisp (modified) (1 diff)
• compiler/ARM/arm-vinsns.lisp (modified) (20 diffs)
• compiler/ARM/arm2.lisp (modified) (13 diffs)
• level-0/ARM/arm-clos.lisp (modified) (5 diffs)
• level-0/ARM/arm-def.lisp (modified) (16 diffs)
• level-0/ARM/arm-misc.lisp (modified) (3 diffs)
• level-0/ARM/arm-numbers.lisp (added)
• level-0/ARM/arm-symbol.lisp (added)
• level-0/ARM/arm-utils.lisp (added)
• level-0/l0-cfm-support.lisp (modified) (2 diffs)
• level-0/l0-hash.lisp (modified) (1 diff)
• level-0/l0-pred.lisp (modified) (7 diffs)
• level-0/l0-symbol.lisp (modified) (1 diff)
• level-1/l1-sockets.lisp (modified) (1 diff)
• lib/compile-ccl.lisp (modified) (5 diffs)
• lib/foreign-types.lisp (modified) (1 diff)
• lib/nfcomp.lisp (modified) (1 diff)
• lib/systems.lisp (modified) (1 diff)
• lisp-kernel/area.h (modified) (1 diff)
• lisp-kernel/arm-constants.s (modified) (1 diff)
• lisp-kernel/arm-exceptions.c (modified) (1 diff)
• lisp-kernel/arm-spentry.s (modified) (9 diffs)
• lisp-kernel/arm-subprims.s (modified) (1 diff)
• lisp-kernel/image.c (modified) (1 diff)
• lisp-kernel/linuxarm/Makefile (modified) (1 diff)
• lisp-kernel/platform-linuxarm.h (modified) (1 diff)
• lisp-kernel/pmcl-kernel.c (modified) (3 diffs)
• lisp-kernel/thread_manager.c (modified) (1 diff)
• xdump/xarmfasload.lisp (added)
• xdump/xfasload.lisp (modified) (1 diff)

branches/arm/compiler/ARM/arm-arch.lisp

@@ -16 +16 @@
 
 (defpackage "ARM"
-  (:use "CL"))
+  (:use "CL")
+  #+arm-target
+  (:nicknames "TARGET"))
+
 
 (require "ARCH")
@@ -392 +395 @@
              (defarmsubprim .SPstkgvector)
              (defarmsubprim .SPmisc-alloc)
-             (defarmsubprim .SPmacro-bind)
-             (defarmsubprim .SPdestructuring-bind)
-             (defarmsubprim .SPdestructuring-bind-inner)
+             (defarmsubprim .SPunused0)
+             (defarmsubprim .SPunused1)
+             (defarmsubprim .SPunused2)
              (defarmsubprim .SPrecover-values)
              (defarmsubprim .SPinteger-sign)
@@ -406 +409 @@
              (defarmsubprim .SPmisc-alloc-init)
              (defarmsubprim .SPstack-misc-alloc-init)
+             (defarmsubprim .SPpopj)
              (defarmsubprim .SPlexpr-entry)
              (defarmsubprim .SPgetu64)
@@ -431 +435 @@
              (defarmsubprim .SPsdiv32)
              (defarmsubprim .SPeabi-ff-call)
+             (defarmsubprim .SPdebind)
              )))))
 
@@ -894 +899 @@
 
 (arm::define-storage-layout lisp-frame 0
-  backlink
+  marker
+  savevsp
   savefn
   savelr
-  savevsp
 )
 
@@ -1196 +1201 @@
                           :function-tag subtag-function
                           :function-tag-is-subtag t
-                          :big-endian t
+                          :big-endian nil
                           :misc-subtag-offset misc-subtag-offset
                           :car-offset cons.car
@@ -1365 +1370 @@
 ;;; A function's entrypoint should initially reference .SPfix-nfn-entrypoint,
 ;;; which will set it to a locative to the function's code-vector.
-(defparameter *function-initial-entrypoint* (ash *arm-subprims-base* (- arm::fixnumshift)))
+(defconstant *function-initial-entrypoint* (ash *arm-subprims-base* (- arm::fixnumshift)))
 
   

branches/arm/compiler/ARM/arm-asm.lisp

@@ -117 +117 @@
     :rs
     :fpaddr
+    :@rn
     ))
 
@@ -372 +373 @@
       (#x00e00010 . #x0ff00090))
      ())
-   (define-arm-instruction tst (:rd :shifter)
+   (define-arm-instruction tst (:rn :shifter)
      #x01100000
      ((#x03100000 . #x0ff00000)
@@ -378 +379 @@
       (#x01100010 . #x0ff00090))
      ())
-   (define-arm-instruction tsts (:rd :shifter)
+   (define-arm-instruction tsts (:rn :shifter)
      #x01100000
      ((#x03100000 . #x0ff00000)
@@ -408 +409 @@
       (#x01d00010 . #x0ff00090))
      ())
-   (define-arm-instruction cmp (:rd :shifter)
+   (define-arm-instruction cmp (:rn :shifter)
      #x01500000
      ((#x03500000 . #x0ff00000)
@@ -414 +415 @@
       (#x01500010 . #x0ff00090))
      ())
-   (define-arm-instruction cmps (:rd :shifter)
+   (define-arm-instruction cmps (:rn :shifter)
      #x01500000
      ((#x03500000 . #x0ff00000)
@@ -686 +687 @@
      #x0f700f00
      ())     
-   (define-arm-instruction fsts (:sd :fpaddr)
+   (define-arm-instruction flds (:sd :fpaddr)
      #x0d100a00
      #x0f300f00
      ())
-   ))
+   (define-arm-instruction ldrex (:rd :@rn)
+     #x01900f9f
+     #x0ff00fff
+     ())
+   (define-arm-instruction strex (:rd :rm :@rn)
+     #x01800f90
+     #x0ff00ff0
+     ())
+   (define-arm-instruction clrex ()
+     #xf57ff01f
+     #xffffffff
+     (:non-conditional))
+   (define-arm-instruction clz (:rd :rm)
+     #x016f0f10
+     #x0fff0ff0
+     ())
+ ))
 
 (dotimes (i (length *arm-instruction-table*))
@@ -1147 +1164 @@
             (set-field-value instruction (byte 1 23) 1))
           (set-field-value instruction (byte 8 0) (ash offset-val -3)))))))
+
+(defun parse-@rn-operand (form instruction)
+  (when (or (atom form)
+          (not (eq (keywordize (car form)) :@)))
+    (error "Invalid register indirect operand: ~s" form))
+  (destructuring-bind (rn) (cdr form)
+    (set-field-value instruction (byte 4 16) (need-arm-gpr rn))))
   
 (defparameter *arm-operand-parsers*
@@ -1171 +1195 @@
       parse-rs-operand
       parse-fpaddr-operand
+      parse-@rn-operand
       ))
 

branches/arm/compiler/ARM/arm-disassemble.lisp

@@ -266 +266 @@
     extract-arm-rd-operand                  ;rde
     extract-arm-rs-operand
+    extract-arm-fpaddr-operand
+    extract-arm-@rn-operand
     ))
 

branches/arm/compiler/ARM/arm-lap.lisp

@@ -26 +26 @@
 
 (defun arm-lap-macro-function (name)
+  (declare (special *arm-backend*))
   (gethash (string name) (backend-lap-macros *arm-backend*)))
 
 (defun (setf arm-lap-macro-function) (def name)
+  (declare (special *arm-backend*))
   (let* ((s (string name)))
     (when (gethash s arm::*arm-instruction-ordinals*)

branches/arm/compiler/ARM/arm-vinsns.lisp

@@ -572 +572 @@
   (rlwinm dest byteval bit-shift 29 29))
 
-#+notyet
 (define-arm-vinsn mem-ref-bit (((dest :u8))
                                ((src :address)
@@ -578 +577 @@
                                ((byte-index :s16)
                                 (bit-shift :u8)))
-  (srwi byte-index bit-index (+ arm::fixnumshift 3))
-  (extrwi bit-shift bit-index 3 27)
-  (addi bit-shift bit-shift 29)
-  (lbzx dest src byte-index)
-  (rlwnm dest dest bit-shift 31 31))
-
-#+notyet
+
+  (mov byte-index (:lsr bit-index (:$ arm::fixnumshift)))
+  (and bit-shift byte-index (:$ 7))
+  (ldrb byte-index (:@ src (:lsr byte-index (:$ 5))))
+  (mov dest (:lsr byte-index bit-shift))
+  (and dest dest (:$ 1)))
+
+
 (define-arm-vinsn mem-ref-bit-fixnum (((dest :lisp))
                                       ((src :address)
@@ -590 +590 @@
                                       ((byte-index :s16)
                                        (bit-shift :u8)))
-  (srwi byte-index bit-index (+ arm::fixnumshift 3))
-  (extrwi bit-shift bit-index 3 27)
-  (addi bit-shift bit-shift 27)
-  (lbzx byte-index src byte-index)
-  (rlwnm dest
-         byte-index
-         bit-shift
-         (- arm::least-significant-bit arm::fixnum-shift)
-         (- arm::least-significant-bit arm::fixnum-shift)))
+  (mov byte-index (:lsr bit-index (:$ arm::fixnumshift)))
+  (and bit-shift byte-index (:$ 7))
+  (ldrb byte-index (:@ src (:lsr byte-index (:$ 3))))
+  (mov byte-index (:lsr byte-index bit-shift))
+  (mov dest (:$ arm::fixnumone))
+  (and dest dest (:lsl byte-index (:$ arm::fixnumshift))))
 
 (define-arm-vinsn mem-ref-c-double-float (((dest :double-float))
@@ -713 +710 @@
   (strb val (:@ src index)))
 
-#+later
 (define-arm-vinsn mem-set-c-bit-0 (()
                                    ((src :address)
                                     (byte-index :s16const)
-                                    (mask-begin :u8const)
-                                    (mask-end :u8const))
+                                    (mask :u8const))
                                    ((val :u8)))
-  (lbz val byte-index src)
-  (rlwinm val val 0 mask-begin mask-end)
-  (stb val byte-index src))
-
-#+later
+  (ldrb val (:@ src (:$ byte-index)))
+  (bic val val (:$ mask))
+  (strb val (:@ src (:$ byte-index))))
+
+
 (define-arm-vinsn mem-set-c-bit-1 (()
                                    ((src :address)
@@ -730 +725 @@
                                     (mask :u8const))
                                    ((val :u8)))
-  (lbz val byte-index src)
-  (ori val val mask)
-  (stb val byte-index src))
-
-#+later
+  (ldrb val (:@ src (:$ byte-index)))
+  (orr val val (:$ mask))
+  (strb val (:@ src (:$ byte-index))))
+
+
 (define-arm-vinsn mem-set-c-bit (()
                                  ((src :address)
@@ -740 +735 @@
                                   (bit-index :u8const)
                                   (val :imm))
-                                 ((byteval :u8)))
-  (lbz byteval byte-index src)
-  (rlwimi byteval val (:apply logand 31 (:apply - 29 bit-index)) bit-index bit-index)
-  (stb byteval byte-index src))
+                                 ((byteval :u8)
+                                  (mask :u8)))
+  (mov mask (:$ 1))
+  (mov mask (:lsl mask bit-index))
+  (cmp val (:$ 0))
+  (ldrb byteval (:@ src (:$ byte-index)))
+  (orrne byteval byteval mask)
+  (biceq byteval byteval mask)
+  (strb byteval (:@ src (:$ byte-index)))
+)
 
 ;;; Hey, they should be happy that it even works.  Who cares how big it is or how
 ;;; long it takes ...
-#+later
 (define-arm-vinsn mem-set-bit (()
                                ((src :address)
@@ -753 +753 @@
                                 (val :lisp))
                                ((bit-shift :u32)
-                                (mask :u32)
-                                (byte-index :u32)))
-  (cmplwi crf val (ash 1 arm::fixnumshift))
-  (extrwi bit-shift bit-index 3 27)
-  (li mask #x80)
-  (srw mask mask bit-shift)
-  (ble+ crf :got-it)
-  (uuo_interr arch::error-object-not-bit src)
-  :got-it
-  (srwi bit-shift bit-index (+ 3 arm::fixnumshift))
-  (lbzx bit-shift src bit-shift)
-  (beq crf :set)
-  (andc mask bit-shift mask)
-  (b :done)
-  :set
-  (or mask bit-shift mask)
-  :done
-  (srwi bit-shift bit-index (+ 3 arm::fixnumshift))
-  (stbx mask src bit-shift))
+                                (mask :u32)))
+  (cmp val (:$ (ash 1 arm::fixnumshift)))
+  (mov bit-shift (:$ 7))
+  (mov mask (:$ 1))
+  (and bit-shift bit-shift (:lsr bit-index (:$ arm::fixnumshift)))
+  (mov mask (:lsl mask bit-shift))
+  (ldrb bit-shift (:@ src (:lsr bit-index (:$ (+ 3 arm::fixnumshift)))))
+  (uuo-error-reg-not-xtype (:? hi) val (:$ arm::xtype-bit))
+  (orrne bit-shift bit-shift mask)
+  (biceq bit-shift bit-shift mask)
+  (strb bit-shift (:@ src (:lsr bit-index (:$ (+ 3 arm::fixnumshift))))))
      
 ;;; Tag and subtag extraction, comparison, checking, trapping ...
@@ -1346 +1338 @@
   (cmp arg (:$ imm)))
 
-(define-arm-vinsn double-float-compare (()
+(define-arm-vinsn double-float-compare (((crf :crf))
                                         ((arg0 :double-float)
                                          (arg1 :double-float))
@@ -1482 +1474 @@
   (str cell (:@ new (:$ arm::cons.cdr))))
 
-#+later
+
 (define-arm-vinsn load-adl (()
                             ((n :u32const)))
-  (lis nargs (:apply ldb (byte 16 16) n))
-  (ori nargs nargs (:apply ldb (byte 16 0) n)))
+  (mov nargs (:$ (:apply logand #x00ff0000 n)))
+  ((:not (:pred = 0 (:apply logand #xff000000 n)))
+   (orr nargs nargs (:$ (:apply logand #xff000000 n))))
+  ((:not (:pred = 0 (:apply logand #x0000ff00 n)))
+   (orr nargs nargs (:$ (:apply logand #x0000ff00 n))))
+  ((:not (:pred = 0 (:apply logand #x000000ff n)))
+   (orr nargs nargs (:$ (:apply logand #x000000ff n)))))
                             
 (define-arm-vinsn set-nargs (()
@@ -1783 +1780 @@
   (str argval (:@ sp (:$ (:apply + arm::dnode-size (:apply ash argnum arm::word-shift))))))
 
-(define-arm-vinsn set-eabi-single-c-arg (()
+
+(define-arm-vinsn set-single-eabi-c-arg (()
                                     ((argval :single-float)
                                      (argnum :u16const)))
   (fsts argval (:@ sp (:$ (:apply + arm::dnode-size (:apply ash argnum arm::word-shift))))))
 
-(define-arm-vinsn set-eabi-double-c-arg (()
+(define-arm-vinsn set-double-eabi-c-arg (()
                                          ((argval :double-float)
                                           (argnum :u16const)))
@@ -1874 +1872 @@
   (sub allocptr allocptr (:$ (:apply
                               logand #xff
-                              (:apply - (:apply logand (lognot 7)
-                                                (:apply + (+ 7 4) nbytes))))))
-  ((:pred > (:apply -
-                    (:apply logand (lognot 7)
-                            (:apply + (+ 7 4) nbytes))
+                              (:apply -  (:apply logand (lognot 7)
+                                                 (:apply + (+ 7 4) nbytes))
+                                      arm::fulltag-misc))))
+  ((:pred > (:apply - (:apply logand (lognot 7)
+                              (:apply + (+ 7 4) nbytes))
                     arm::fulltag-misc) #xff)
    (sub allocptr allocptr (:$ (:apply logand #xff00
-                                 (:apply -
-                                    (:apply logand (lognot 7)
-                                    (:apply + (+ 7 4) nbytes))
-                                    arm::fulltag-misc)))))
+                                      (:apply -
+                                              (:apply logand (lognot 7)
+                                                      (:apply + (+ 7 4) nbytes))
+                                              arm::fulltag-misc)))))
   (ldr dest (:@ rcontext (:$ arm::tcr.save-allocbase)))
   (cmp allocptr dest)
@@ -2679 +2677 @@
   (add sp sp (:$ arm::dnode-size)))
 
-#+notyet
 (define-arm-vinsn (temp-push-double-float :push :doubleword :sp)
     (()
@@ -2689 +2686 @@
   (fstd d (:@ sp (:$ 8))))
 
-#+notyet
 (define-arm-vinsn (temp-pop-double-float :pop :doubleword :sp)
     (()
@@ -2696 +2692 @@
   (add sp sp (:$ (* 2 arm::dnode-size))))
 
-#+notyet
+
 (define-arm-vinsn (temp-push-single-float :push :word :tsp)
     (()
@@ -2706 +2702 @@
   (fsts s (:@ sp (:$ 4))))
 
-#+notyet
+
 (define-arm-vinsn (temp-pop-single-float :pop :word :sp)
     (()
      ((s :single-float)))
-  (flds s (:@ sp 4))
+  (flds s (:@ sp (:$ 4)))
   (add sp sp (:$ arm::dnode-size)))
 
@@ -2734 +2730 @@
 (define-arm-vinsn zero-double-float-register (((dest :double-float))
                                               ()
-                                              ((temp t)))
+                                              ((temp :imm)))
   (mov temp (:$ 0))
   (fmsr dest temp))
@@ -2740 +2736 @@
 (define-arm-vinsn zero-single-float-register (((dest :single-float))
                                               ()
-                                              ((temp t)))
+                                              ((temp :imm)))
   (mov temp (:$ 0))
   (fmdrr dest temp temp))
@@ -2805 +2801 @@
 
 
-#+later
-(define-arm-vinsn save-lisp-context-lexpr (()
-                                           ()
-                                           ((imm :u32)))
-  (stwu arm::sp (- arm::lisp-frame.size) arm::sp)
-  (str arm::rzero (:@ arm::sp (:$ arm::lisp-frame.savefn)))
-  (str arm::loc-pc (:@ arm::sp (:$ arm::lisp-frame.savelr)))
-  (str vsp (:@ arm::sp (:$ arm::lisp-frame.savevsp)))
-  (mr arm::fn arm::nfn)
-  ;; Do a stack-probe ...
-  (ldr imm (:@ rcontext (:$ arm::tcr.cs-limit)))
-  (twllt arm::sp imm))
   
 (define-arm-vinsn save-cleanup-context (()
@@ -2827 +2811 @@
 ;; Vpush the argument registers.  We got at least "min-fixed" args;
 ;; that knowledge may help us generate better code.
-#+later
 (define-arm-vinsn (save-lexpr-argregs :call :subprim-call)
     (()
      ((min-fixed :u16const))
-     ((crfx :crf)
-      (crfy :crf)
-      (entry-vsp (:u32 #.arm::imm0))
-      (arg-temp :u32)))
+     ((entry-vsp (:u32 #.arm::imm1))
+      (arg-temp (:u32 #.arm::imm0))
+      (other-temp :imm)))
   ((:pred >= min-fixed $numarmargregs)
-   (stwu arm::arg_x -4 vsp)   
-   (stwu arm::arg_y -4 vsp)   
-   (stwu arm::arg_z -4 vsp))
+   (stm (:! vsp) (arg_z arg_y arg_x)))
   ((:pred = min-fixed 2)                ; at least 2 args
-   (cmplwi crfx nargs (ash 2 arm::word-shift))
-   (beq crfx :yz2)                      ; skip arg_x if exactly 2
-   (stwu arm::arg_x -4 vsp)
-   :yz2
-   (stwu arm::arg_y -4 vsp)
-   (stwu arm::arg_z -4 vsp))
+   (cmp nargs (:$ (ash 2 arm::word-shift)))
+   (strne arg_x (:@! vsp (:$ -4)))
+   (stm (:! vsp) (arg_z arg_y)))
   ((:pred = min-fixed 1)                ; at least one arg
-   (cmplwi crfx nargs (ash 2 arm::word-shift))
-   (blt crfx :z1)                       ; branch if exactly one
-   (beq crfx :yz1)                      ; branch if exactly two
-   (stwu arm::arg_x -4 vsp)
-   :yz1
-   (stwu arm::arg_y -4 vsp)   
-   :z1
-   (stwu arm::arg_z -4 vsp))
+   (cmp nargs (:$ (ash 2 arm::word-shift)))
+   (strlo arg_z (:@! vsp (:$ (- arm::node-size))))
+   (stmeq (:! vsp) (arg_z arg_y))
+   (stmhi (:! vsp) (arg_z arg_y arg_x)))
   ((:pred = min-fixed 0)
-   (cmplwi crfx nargs (ash 2 arm::word-shift))
-   (cmplwi crfy nargs 0)
-   (beq crfx :yz0)                      ; exactly two
-   (beq crfy :none)                     ; exactly zero
-   (blt crfx :z0)                       ; one
-                                        ; Three or more ...
-   (stwu arm::arg_x -4 vsp)
-   :yz0
-   (stwu arm::arg_y -4 vsp)
-   :z0
-   (stwu arm::arg_z -4 vsp)
-   :none
+   (cmp nargs (:$ 0))
+   (beq :done)
+   (cmp nargs (:$ (ash 2 arm::word-shift)))
+   (strlo arg_z (:@! vsp (:$ (- arm::node-size))))
+   (stmeq (:! vsp) (arg_z arg_y))
+   (stmhi (:! vsp) (arg_z arg_y arg_x))
+   :done
    )
   ((:pred = min-fixed 0)
-   (stwu nargs -4 vsp))
+   (str nargs (:@! vsp (:$ -4))))
   ((:not (:pred = min-fixed 0))
-   (subi arg-temp nargs (:apply ash min-fixed arm::word-shift))
-   (stwu arg-temp -4 vsp))
+   (sub arg-temp nargs (:$ (:apply ash min-fixed arm::word-shift)))
+   (str arg-temp (:@! vsp (:$ -4))))
   (add entry-vsp vsp nargs)
-  (la entry-vsp 4 entry-vsp)
-  (bl .SPlexpr-entry))
+  (mov other-temp (:$ (- arm::nil-value arm::fulltag-nil)))
+  (ldr other-temp (:@ other-temp (:$ (arm::%kernel-global 'arm::ret1valaddr))))
+  (add entry-vsp entry-vsp (:$ 4))
+  (cmp other-temp lr)
+  (mov arg-temp (:$ arm::lisp-frame-marker))
+  (stmdb (:! vsp) (arg-temp entry-vsp fn lr))
+  (mov fn (:$ 0))
+  (moveq lr (:$ (- arm::nil-value arm::fulltag-nil)))
+  (ldreq lr (:@ lr (:$ (arm::%kernel-global 'arm::lexpr-return))))
+  (stmdbeq (:! vsp) (arg-temp entry-vsp fn lr))
+  (moveq lr other-temp)
+  (movne lr (:$ (- arm::nil-value arm::fulltag-nil)))
+  (ldrne lr (:@ lr (:$ (arm::%kernel-global 'arm::lexpr-return1v))))
+  )
+
 
 
@@ -3288 +3269 @@
 (define-arm-subprim-call-vinsn (slide-values) .SPmvslide)
 
-(define-arm-subprim-call-vinsn (macro-bind) .SPmacro-bind)
-
-(define-arm-subprim-call-vinsn (destructuring-bind-inner) .SPdestructuring-bind-inner)
-
-(define-arm-subprim-call-vinsn (destructuring-bind) .SPdestructuring-bind)
+
+(define-arm-subprim-call-vinsn (debind) .SPdebind)
 
 

branches/arm/compiler/ARM/arm2.lisp

@@ -896 +896 @@
     (dotimes (i num-fixed)
       (! copy-lexpr-argument))
-    (! save-lisp-context-lexpr)))
+    (! save-lisp-context-vsp)))
 
 (defun arm2-load-lexpr-address (seg dest)
@@ -2309 +2309 @@
            (expression-p (or (typep fn 'lreg) (and (fixnump fn) (not label-p))))
            (callable (or symp lfunp label-p))
-           (destreg (if symp ($ arm::fname) (if lfunp ($ arm::nfn) (unless label-p ($ arm::temp0)))))
+           (destreg (if symp ($ arm::fname) (if lfunp ($ arm::nfn) (unless label-p ($ arm::nfn)))))
            (alternate-tail-call
             (and tail-p label-p *arm2-tail-label* (eql nargs *arm2-tail-nargs*) (not spread-p)))
@@ -3137 +3137 @@
          (! double-float-compare dest ireg jreg)
          (^ cr-bit true-p))
-       (with-imm-temps () ((lowbit-reg :natural))
+       (progn
          (with-crf-target () flags
            (! double-float-compare flags ireg jreg)
-           (! crbit->bit31 lowbit-reg flags cr-bit))
-         (unless true-p
-           (! invert-lowbit lowbit-reg))
-         (ensuring-node-target (target dest)
-           (! lowbit->truth target lowbit-reg))
+
+           (! cond->boolean dest (if true-p cr-bit (logxor cr-bit 1))))
          (^)))
       (^))))
@@ -4528 +4525 @@
         (arm2-init-regvar seg var reg (arm2-vloc-ea vloc))
         (arm2-bind-var seg var vloc lcell)))
-    (let* ((v2 (%cdr var))
-           (v v2)
-           (vstack *arm2-vstack*)
-           (whole (pop v))
-           (req (pop v))
-           (opt (pop v))
-           (rest (pop v))
-           (keys (pop v)))
-      
-      (apply #'arm2-bind-structured-lambda seg 
-             (arm2-spread-lambda-list seg (arm2-vloc-ea vloc) whole req opt rest keys context)
-             vstack context v2))))
+    (compiler-bug "Old destructuring code ...")))
 
 (defun arm2-bind-structured-lambda (seg lcells vloc context whole req opt rest keys auxen
@@ -4673 +4659 @@
             (compiler-bug "unknown payback token ~s" r)))))))
 
-(defun arm2-spread-lambda-list (seg listform whole req opt rest keys 
-                                    &optional enclosing-ea cdr-p)
+(defun arm2-spread-lambda-list (seg listform whole req opt rest keys)
   (with-arm-local-vinsn-macros (seg)
     (let* ((numopt (length (%car opt)))
@@ -4681 +4666 @@
            (vtotal numreq)
            (old-top *arm2-top-vstack-lcell*)
-           (listreg ($ arm::temp3))
+           (listreg ($ arm::arg_z))
            (doadlword (dpb nkeys (byte 8 16) (dpb numopt (byte 8 8) (dpb numreq (byte 8 0) 0 )))))
       (declare (fixnum numopt nkeys numreq vtotal doadlword))
@@ -4692 +4677 @@
         (arm2-vpush-register seg listreg :reserved))
       (when keys
-        (setq doadlword (%ilogior2 (ash #x80000000 -6) doadlword))
+        (setq doadlword (%ilogior2 (ash 1 25) doadlword))
         (incf  vtotal (%ilsl 1 nkeys))
         (if (%car keys)                 ; &allow-other-keys
@@ -4700 +4685 @@
         (setq vtotal (%i+ vtotal numopt))
         (when (arm2-hard-opt-p opt)
-          (setq doadlword (%ilogior2 doadlword (ash #x80000000 -7)))
+          (setq doadlword (logior doadlword (ash 1 29)))
           (setq vtotal (%i+ vtotal numopt))))
       (when rest
-        (setq doadlword (%ilogior2 (ash #x80000000 -4) doadlword) vtotal (%i+ vtotal 1)))
+        (setq doadlword (%ilogior2 (ash 1 26) doadlword) vtotal (%i+ vtotal 1)))
       (arm2-reserve-vstack-lcells vtotal)
       (! load-adl doadlword)
-      (if cdr-p
-        (! macro-bind)
-        (if enclosing-ea
-          (progn
-            (arm2-store-ea seg enclosing-ea arm::arg_z)
-            (! destructuring-bind-inner))
-          (! destructuring-bind)))
+      (! debind)
       (arm2-set-vstack (%i+ *arm2-vstack* (* *arm2-target-node-size* vtotal)))
       (arm2-collect-lcells :reserved old-top))))
@@ -4962 +4941 @@
                 (unless (or rest keys)
                   (! check-max-nargs (+ num-fixed num-opt)))
-                (! save-lisp-context-variable)
+                (unless lexprp
+                  (! save-lisp-context-variable))
                 ;; If there were &optional args, initialize their values
                 ;; to NIL.  All of the argregs get vpushed as a result of this.
@@ -6425 +6405 @@
 (defarm2 arm2-debind debind (seg vreg xfer lambda-list bindform req opt rest keys auxen whole body p2decls cdr-p)
   (declare (ignore lambda-list))
+  (when cdr-p
+    (compiler-bug "Unsupported: old destructuring code, cdr-p case."))
   (let* ((old-stack (arm2-encode-stack))
          (*arm2-top-vstack-lcell* *arm2-top-vstack-lcell*)
@@ -6431 +6413 @@
       (arm2-bind-structured-lambda
        seg 
-       (arm2-spread-lambda-list seg bindform whole req opt rest keys nil cdr-p)
+       (arm2-spread-lambda-list seg bindform whole req opt rest keys)
        vloc (arm2-vloc-ea vloc) whole req opt rest keys auxen)
       (arm2-undo-body seg vreg xfer body old-stack)
@@ -7218 +7200 @@
                                           i ($ arm::arg_y)
                                           j ($ arm::arg_z))
-           (arm2-fixed-call-builtin seg vreg xfer 'SParef2))))  )
+           (arm2-fixed-call-builtin seg vreg xfer '.SParef2))))  )
 
 
@@ -7276 +7258 @@
                                          j ($ arm::arg_y)
                                          k ($ arm::arg_z))
-           (arm2-fixed-call-builtin seg vreg xfer 'SParef3)))))
+           (arm2-fixed-call-builtin seg vreg xfer '.SParef3)))))
 
 (defarm2 arm2-%aset2 simple-typed-aset2 (seg vreg xfer typename arr i j new &optional dim0 dim1)

branches/arm/level-0/ARM/arm-clos.lisp

@@ -25 +25 @@
 ;;; be used when there are less than 255 slots in the class.
 (defarmlapfunction %small-map-slot-id-lookup ((slot-id arg_z))
-  (ldr temp1 'map nfn)
-  (svref arg_x slot-id.index slot-id)
-  (getvheader imm0 temp1)
-  (header-length imm3 imm0)
-  (ldr temp0 'table nfn)
-  (cmplr arg_x imm3)
-  (srri imm0 arg_x target::word-shift)
-  (la imm0 target::misc-data-offset imm0)
-  (li imm1 target::misc-data-offset)
-  (bge @have-scaled-table-index)
-  (lbzx imm1 temp1 imm0)
-  (slri imm1 imm1 target::word-shift)
-  (la imm1 target::misc-data-offset imm1)
-  @have-scaled-table-index
-  (ldrx arg_z temp0 imm1)
-  (blr))
+  (ldr temp1 (:@ nfn 'map))
+  (svref arg_x slot-id.index slot-id)
+  (getvheader imm0 temp1)
+  (header-length imm1 imm0)
+  (ldr temp0 (:@ nfn 'table))
+  (cmp arg_x imm1)
+  (mov imm0 (:lsr arg_x (:$ arm::word-shift)))
+  (add imm0 imm0 (:$ arm::misc-data-offset))
+  (mov imm1 (:$ arm::misc-data-offset))
+  (ldrblo imm1 (:@ temp1 imm0))
+  (movlo imm1 (:lsr imm1 (:$ arm::word-shift)))
+  (addlo imm1 imm1 (:$ arm::misc-data-offset))
+  (ldr arg_z (:@ temp0 imm1))
+  (bx lr))
 
 ;;; The same idea, only the map is a vector of (UNSIGNED-BYTE 32).
 (defarmlapfunction %large-map-slot-id-lookup ((slot-id arg_z))
-  (ldr temp1 'map nfn)
-  (svref arg_x slot-id.index slot-id)
-  (getvheader imm0 temp1)
-  (header-length imm3 imm0)
-  (ldr temp0 'table nfn)
-  (cmplr arg_x imm3)
-  #+ppc64-target
-  (progn
-    (srdi imm0 imm0 1)
-    (la imm0 target::misc-data-offset imm0))
-  #+pp32-target
-  (progn
-    (la imm0 target::misc-data-offset arg_x))
-  (li imm1 target::misc-data-offset)
-  (bge @have-scaled-table-index)
-  (lwzx imm1 temp1 imm0)
-  (slri imm1 imm1 target::word-shift)
-  (la imm1 target::misc-data-offset imm1)
+  (ldr temp1 (:@ nfn 'map))
+  (svref arg_x slot-id.index slot-id)
+  (getvheader imm0 temp1)
+  (header-length imm1 imm0)
+  (ldr temp0 (:@ nfn 'table))
+  (cmp arg_x imm1)
+  (add imm0 arg_x (:$ arm::misc-data-offset))
+  (mov imm1 (:$ arm::misc-data-offset))
+  (ldrlo imm1 (:@ temp1 imm0))
+  (movhi imm1 (:lsr imm1 (:$ arm::word-shift)))
+  (addlo imm1 imm1 (:$ arm::misc-data-offset))
+  (ldr arg_z (:@ temp0 imm1))
+  (bx lr))
+
+(defarmlapfunction %small-slot-id-value ((instance arg_y) (slot-id arg_z))
+  (ldr temp1 (:@ nfn 'map))
+  (svref arg_x slot-id.index slot-id)
+  (getvheader imm0 temp1)
+  (ldr temp0 (:@ nfn 'table))
+  (header-length imm1 imm0)
+  (cmp arg_x imm1)
+  (mov imm0 (:lsr arg_x (:$ arm::word-shift)))
+  (add imm0 imm0 (:$ arm::misc-data-offset))
+  (bhs @missing)
+  (ldrb imm1 (:@ temp1 imm0))
+  (cmp imm1 (:$ 0))
+  (mov imm1 (:lsr imm1 (:$ arm::word-shift)))
+  (add imm1 imm1 (:$ arm::misc-data-offset))
+  (beq @missing)
+  (ldr arg_z (:@ temp0 imm1))
+  (ldr arg_x (:@ nfn 'class))
+  (ldr nfn (:@ nfn '%maybe-std-slot-value))
+  (set-nargs 3)
+  (ldr pc (:@ nfn (:$ arm::function.entrypoint)))
+  @missing                              ; (%slot-id-ref-missing instance id)
+  (ldr nfn (:@ nfn '%slot-id-ref-missing))
+  (set-nargs 2)
+  (ldr pc (:@ nfn (:$ arm::function.entrypoint))))
+
+(defarmlapfunction %large-slot-id-value ((instance arg_y) (slot-id arg_z))
+  (ldr temp1 (:@ nfn 'map))
+  (svref arg_x slot-id.index slot-id)
+  (getvheader imm0 temp1)
+  (ldr temp0 (:@ nfn 'table))
+  (header-length imm1 imm0)
+  (cmp arg_x imm1)
+  (add imm0 arg_x (:$ arm::misc-data-offset))
+  (bhs @missing)
+  (ldr imm1 (:@ temp1 imm0))
+  (cmp imm1 (:$ 0))
+  (mov imm1 (:lsr imm1 (:$ arm::word-shift)))
+  (add imm1 imm1 (:$ arm::misc-data-offset))
+  (beq @missing)
   @have-scaled-table-index
-  (ldrx arg_z temp0 imm1)
-  (blr))
-
-(defarmlapfunction %small-slot-id-value ((instance arg_y) (slot-id arg_z))
-  (ldr temp1 'map nfn)
-  (svref arg_x slot-id.index slot-id)
-  (getvheader imm0 temp1)
-  (ldr temp0 'table nfn)
-  (header-length imm3 imm0)
-  (cmplr arg_x imm3)
-  (srri imm0 arg_x target::word-shift)
-  (la imm0 target::misc-data-offset imm0)
-  (bge @missing)
-  (lbzx imm1 temp1 imm0)
-  (cmpri imm1 0)
-  (slri imm1 imm1 target::word-shift)
-  (la imm1 target::misc-data-offset imm1)
-  (beq @missing)
-  (ldrx arg_z temp0 imm1)
-  (ldr arg_x 'class nfn)
-  (ldr nfn '%maybe-std-slot-value nfn)
-  (ldr temp0 target::misc-data-offset nfn)
-  (set-nargs 3)
-  (mtctr temp0)
-  (bctr)
+  (ldr arg_x (:@ nfn 'class))
+  (ldr nfn (:@ nfn '%maybe-std-slot-value-using-class))
+  (ldr arg_z (:@ temp0 imm1))
+  (set-nargs 3)
+  (ldr pc (:@ nfn (:$ arm::function.entrypoint)))
   @missing                              ; (%slot-id-ref-missing instance id)
-  (ldr nfn '%slot-id-ref-missing nfn)
+  (ldr nfn (:@ nfn '%slot-id-ref-missing))
   (set-nargs 2)
-  (ldr temp0 target::misc-data-offset nfn)
-  (mtctr temp0)
-  (bctr))
-
-(defarmlapfunction %large-slot-id-value ((instance arg_y) (slot-id arg_z))
-  (ldr temp1 'map nfn)
-  (svref arg_x slot-id.index slot-id)
-  (getvheader imm0 temp1)
-  (ldr temp0 'table nfn)
-  (header-length imm3 imm0)
-  (cmplr arg_x imm3)
-  #+ppc64-target
-  (progn
-    (srdi imm0 arg_x 1)
-    (la imm0 target::misc-data-offset imm0))
-  #+ppc32-target
-  (progn
-    (la imm0 target::misc-data-offset arg_x))
-  (bge @missing)
-  (lwzx imm1 temp1 imm0)
-  (cmpri imm1 0)
-  (slri imm1 imm1 target::word-shift)
-  (la imm1 target::misc-data-offset imm1)
-  (beq @missing)
-  @have-scaled-table-index
-  (ldr arg_x 'class nfn)
-  (ldr nfn '%maybe-std-slot-value-using-class nfn)
-  (ldrx arg_z temp0 imm1)
-  (ldr temp0 target::misc-data-offset nfn)
-  (set-nargs 3)
-  (mtctr temp0)
-  (bctr)
-  @missing                              ; (%slot-id-ref-missing instance id)
-  (ldr nfn '%slot-id-ref-missing nfn)
-  (set-nargs 2)
-  (ldr temp0 target::misc-data-offset nfn)
-  (mtctr temp0)
-  (bctr))
+  (ldr pc (:@ nfn (:$ arm::function.entrypoint))))
   
 (defarmlapfunction %small-set-slot-id-value ((instance arg_x)
                                              (slot-id arg_y)
                                              (new-value arg_z))
-  (ldr temp1 'map nfn)
-  (svref imm3 slot-id.index slot-id)
-  (getvheader imm0 temp1)
-  (ldr temp0 'table nfn)
-  (header-length imm5 imm0)
-  (cmplr imm3 imm5)
-  (srri imm0 imm3 target::word-shift)
-  (la imm0 target::misc-data-offset imm0)
-  (bge @missing)
-  (lbzx imm1 temp1 imm0)
-  (cmpwi imm1 0)
-  (slri imm1 imm1 target::word-shift)
-  (la imm1 target::misc-data-offset imm1)
+  (ldr temp1 (:@ nfn 'map))
+  (svref temp0 slot-id.index slot-id)
+  (getvheader imm0 temp1)
+  (ldr temp0 (:@ nfn 'table))
+  (header-length imm1 imm0)
+  (cmp temp0 imm1)
+  (mov imm0 (:lsr temp0 (:$ arm::word-shift)))
+  (add imm0 imm0 (:$ arm::misc-data-offset))
+  (bhs @missing)
+  (ldrb imm1 (:@ temp1 imm0))
+  (cmp imm1 (:$ 0))
+  (mov imm1 (:lsr imm1 (:$ arm::word-shift)))
+  (add imm1 imm1 (:$ arm::misc-data-offset))
   (beq @missing)
   @have-scaled-table-index
-  (ldr temp1 'class nfn)
-  (ldrx arg_y temp0 imm1)
-  (ldr nfn '%maybe-std-setf-slot-value-using-class nfn)
+  (ldr temp1 (:@ nfn 'class))
+  (ldr arg_y (:@ temp0 imm1))
+  (ldr nfn (:@ nfn '%maybe-std-setf-slot-value-using-class))
   (set-nargs 4)
-  (ldr temp0 target::misc-data-offset nfn)
-  (vpush temp1)
-  (mtctr temp0)
-  (bctr)
+  (vpush1 temp1)
+  (ldr pc (:@ nfn (:$ arm::function.entrypoint)))
   @missing                              ; (%slot-id-set-missing instance id new-value)
-  (ldr nfn '%slot-id-set-missing nfn)
-  (set-nargs 3)
-  (ldr temp0 target::misc-data-offset nfn)
-  (mtctr temp0)
-  (bctr))
+  (ldr nfn (:@ nfn '%slot-id-set-missing))
+  (set-nargs 3)
+  (ldr pc (:@ nfn (:$ arm::function.entrypoint))))
 
 (defarmlapfunction %large-set-slot-id-value ((instance arg_x)
                                              (slot-id arg_y)
                                              (new-value arg_z))
-  (ldr temp1 'map nfn)
-  (svref imm3 slot-id.index slot-id)
-  (getvheader imm0 temp1)
-  (ldr temp0 'table nfn)
-  (header-length imm5 imm0)
-  (cmplr imm3 imm5)
-  #+ppc64-target (srdi imm3 imm3 1)
-  (la imm0 target::misc-data-offset imm3)
-  (bge @missing)
-  (lwzx imm1 temp1 imm0)
-  (cmpwi imm1 0)
-  (slri imm1 imm1 target::word-shift)
-  (la imm1 target::misc-data-offset imm1)
+  (ldr temp1 (:@ nfn 'map))
+  (svref temp0 slot-id.index slot-id)
+  (getvheader imm0 temp1)
+  (ldr temp0 (:@ nfn 'table))
+  (header-length imm1 imm0)
+  (cmp temp0 imm1)
+  (add imm0 temp0 (:$ arm::misc-data-offset))
+  (bhs @missing)
+  (ldr imm1 (:@ temp1 imm0))
+  (cmp imm1 (:$ 0))
+  (mov imm1 (:lsr imm1 (:$ arm::word-shift)))
+  (add imm1 imm1 (:$ arm::misc-data-offset))
   (beq @missing)
   @have-scaled-table-index
-  (ldr temp1 'class nfn)
-  (ldrx arg_y temp0 imm1)
-  (ldr nfn '%maybe-std-setf-slot-value-using-class nfn)
+  (ldr temp1 (:@ nfn 'class))
+  (ldr arg_y (:@ temp0 imm1))
+  (ldr nfn (:@ nfn '%maybe-std-setf-slot-value-using-class))
   (set-nargs 4)
-  (svref temp0 0 nfn)
-  (vpush temp1)
-  (mtctr temp0)
-  (bctr)
+  (vpush1 temp1)
+  (ldr pc (:@ nfn (:$ arm::function.entrypoint)))
   @missing                              ; (%slot-id-set-missing instance id new-value)
-  (ldr nfn '%slot-id-ref-missing nfn)
-  (set-nargs 3)
-  (ldr temp0 target::misc-data-offset nfn)
-  (mtctr temp0)
-  (bctr))
-
-#-dont-use-lexprs
-(defparameter *gf-proto*
-  (nfunction
-   gag
-   (lambda (&lap &lexpr args)
-     (ppc-lap-function 
-      gag 
-      ()
-      (mflr loc-pc)
-      (vpush-argregs)
-      (vpush nargs)
-      (add imm0 vsp nargs)
-      (la imm0 (ash 1 target::word-shift) imm0)                  ; caller's vsp
-      (bla .SPlexpr-entry)
-      (mtlr loc-pc)                     ; return to kernel
-      (mr arg_z vsp)                    ; lexpr
-      (svref arg_y gf.dispatch-table nfn) ; dispatch table
-      (set-nargs 2)
-      (svref nfn gf.dcode nfn)          ; dcode function
-      (ldr temp0 target::misc-data-offset nfn)
-      (mtctr temp0)
-      (bctr)))))
-
-#+dont-use-lexprs
-(defparameter *gf-proto*
-  (nfunction
-   gag
-   (lambda (&lap &rest args)
-     (ppc-lap-function
-      gag
-      ()
-      ;;(bkpt)
-      (mflr loc-pc)
-      (bla .SPstack-rest-arg)
-      (vpop arg_z)
-      (stru sp (- target::lisp-frame.size) sp)
-      (str fn target::lisp-frame.savefn sp)
-      (str loc-pc target::lisp-frame.savelr sp)
-      (str vsp target::lisp-frame.savevsp sp)
-      (mr fn nfn)
-      ;; If we were called for multiple values, call the dcode
-      ;; for multiple values.
-      (ref-global imm0 ret1valaddr)
-      (cmpr imm0 loc-pc)
-      (svref arg_y gf.dispatch-table fn) ; dispatch table
-      (set-nargs 2)
-      (svref nfn gf.dcode fn)           ; dcode function
-      (beq @multiple)
-      (ldr temp0 target::misc-data-offset nfn)
-      (mtctr temp0)
-      (bctrl)
-      (ldr tsp 0 tsp)
-      (restore-full-lisp-context)
-      (blr)
-      @multiple
-      (bl @getback)
-      (mflr loc-pc)
-      (stru sp (- target::lisp-frame.size) sp)
-      (str fn target::lisp-frame.savefn sp)
-      (str loc-pc target::lisp-frame.savelr sp)
-      (str vsp target::lisp-frame.savevsp sp)
-      (mtlr imm0)
-      (li fn 0)
-      (ldr temp0 target::misc-data-offset nfn)
-      (mtctr temp0)
-      (bctr)
-      @getback
-      (blrl)
-      @back
-      (ldr tsp 0 tsp)
-      (ba .SPnvalret)))))
+  (ldr nfn (:@ nfn '%slot-id-ref-missing))
+  (set-nargs 3)
+  (ldr pc (:@ nfn (:$ arm::function.entrypoint)))
+)
+
+
+
+
       
       
@@ -276 +176 @@
 ;;; This can't reference any of the function's constants.
 (defarmlapfunction unset-fin-trampoline ()
-  (mflr loc-pc)
-  (bla .SPheap-rest-arg)                ; cons up an &rest arg, vpush it
-  (vpop arg_z)                          ; whoops, didn't really want to
-  (bla .SPsavecontextvsp)
-  (li arg_x '#.$XNOFINFUNCTION)
-  (mr arg_y nfn)
-  (set-nargs 3)
-  (bla .SPksignalerr)
-  (li arg_z nil)
-  (ba .SPpopj))
+  (build-lisp-frame)
+  (bl .SPheap-rest-arg)                ; cons up an &rest arg, vpush it
+  (vpop1 arg_z)                          ; whoops, didn't really want to
+  (mov arg_x '#.$XNOFINFUNCTION)
+  (mov arg_y nfn)
+  (set-nargs 3)
+  (bl .SPksignalerr)
+  (mov arg_z 'nil)
+  (return-lisp-frame))
 
 ;;; is a winner - saves ~15%
@@ -293 +192 @@
   (set-nargs 2)
   (svref nfn gf.dcode nfn)
-  (ldr temp0 target::misc-data-offset nfn)
-  (mtctr temp0)
-  (bctr))
+  (ldr pc (:@ nfn (:$ arm::function.entrypoint))))
 
 
@@ -303 +200 @@
   (set-nargs 3)
   (svref nfn gf.dcode nfn)
-  (ldr temp0 target::misc-data-offset nfn)
-  (mtctr temp0)
-  (bctr))
+  (ldr pc (:@ nfn (:$ arm::function.entrypoint))))
 
 (defparameter *cm-proto*
@@ -311 +206 @@
    gag
    (lambda (&lap &lexpr args)
-     (ppc-lap-function 
+     (arm-lap-function 
       gag 
       ()
-      (mflr loc-pc)
       (vpush-argregs)
-      (vpush nargs)
-      (add imm0 vsp nargs)
-      (la imm0 target::node-size imm0)                  ; caller's vsp
-      (bla .SPlexpr-entry)
-      (mtlr loc-pc)                     ; return to kernel
-      (mr arg_z vsp)                    ; lexpr
+      (vpush1 nargs)
+      (ref-global arg_x ret1valaddr)
+      (add imm1 vsp nargs)
+      (add imm1 imm1 (:$ arm::node-size))                  ; caller's vsp
+      (cmp lr arg_x)
+      (build-lisp-frame imm0 imm1)
+      (mov fn (:$ 0))
+      (moveq lr (:$ (- arm::nil-value arm::fulltag-nil)))
+      (ldreq lr (:@ lr (:$ (arm::%kernel-global 'arm::lexpr-return))))
+      (stmdbeq (:! vsp) (imm0 imm1 fn lr))
+      (moveq lr arg_x)
+      (movne lr (:$ (- arm::nil-value arm::fulltag-nil)))
+      (ldrne lr (:@ lr (:$ (arm::%kernel-global 'arm::lexpr-return1v))))
+      (mov arg_z vsp)
       (svref arg_y combined-method.thing nfn) ; thing
       (set-nargs 2)
       (svref nfn combined-method.dcode nfn) ; dcode function
-      (ldr temp0 target::misc-data-offset nfn)
-      (mtctr temp0)
-      (bctr)))))
+      (ldr pc (:@ nfn (:$ arm::function.entrypoint)))))))

branches/arm/level-0/ARM/arm-def.lisp

@@ -20 +20 @@
 ;;; If the GC moves this function while we're trying to flush the cache,
 ;;; it'll flush the cache: no harm done in that case.
-#+notyet                                ;though we need to on ARM.
-(defppclapfunction %make-code-executable ((codev arg_z))
-  (let ((len imm2)
-        (word-offset imm0))
-    (save-lisp-context)
-    (getvheader word-offset codev)
-    (header-size len word-offset)
-    ;; The idea is that if we GC here, no harm is done (since the GC
-    ;; will do any necessary cache-flushing.)  The idea may be
-    ;; incorrect: if we pass an address that's not mapped anymore,
-    ;; could we fault ?
-    (stru sp (- (+ #+eabi-target ppc32::eabi-c-frame.minsize
-                   #+poweropen-target target::c-frame.minsize target::lisp-frame.size)) sp)     ; make an FFI frame.
-    (la imm0 target::misc-data-offset codev)
-    (slri len len 2)
-    (str imm0 #+eabi-target ppc32::eabi-c-frame.param0 #+poweropen-target target::c-frame.param0  sp)
-    (str len #+eabi-target ppc32::eabi-c-frame.param1 #+poweropen-target target::c-frame.param1 sp)
-    (ref-global imm3 kernel-imports)
-    (ldr arg_z target::kernel-import-MakeDataExecutable imm3)
-    (bla #+eabi-target .SPeabi-ff-call #+poweropen-target .SPpoweropen-ffcall)
-    (li arg_z nil)
-    (restore-full-lisp-context)
-    (blr)))
+
+(defun %make-code-executable (codev)
+  (with-macptrs (p)
+    (let* ((nbytes (ash (uvsize codev) arm::word-shift)))
+      (%vect-data-to-macptr codev p)
+      (ff-call (%kernel-import arm::kernel-import-MakeDataExecutable)
+               :address p
+               :unsigned-fullword nbytes
+               :void))))
 
 (defarmlapfunction %get-kernel-global-from-offset ((offset arg_z))
@@ -75 +61 @@
   (moveq fixnum offset)
   (moveq offset (:$ 0))
-  @2-args
   (unbox-fixnum imm0 offset)
   (ldr arg_z (:@ imm0 fixnum))
@@ -156 +141 @@
 (defarmlapfunction %%frame-backlink ((p arg_z))
   (check-nargs 1)
-  (ldr arg_z target::lisp-frame.backlink arg_z)
+  (add arg_z p (:$ arm::lisp-frame.size))
   (bx lr))
 
@@ -165 +150 @@
 (defarmlapfunction %%frame-savefn ((p arg_z))
   (check-nargs 1)
-  (ldr arg_z target::lisp-frame.savefn arg_z)
+  (ldr arg_z (:@ arg_z (:$ arm::lisp-frame.savefn)))
   (bx lr))
 
 (defarmlapfunction %cfp-lfun ((p arg_z))
-  (ldr arg_y target::lisp-frame.savefn p)
+  (build-lisp-frame)
+  (ldr arg_y (:@ p (:$ arm::lisp-frame.savefn)))
   (extract-typecode imm0 arg_y)
-  (cmpri imm0 target::subtag-function)
-  (ldr loc-pc target::lisp-frame.savelr p)
+  (cmp imm0 (:$ arm::subtag-function))
+  (ldr lr (:@ p (:$ arm::lisp-frame.savelr)))
   (bne @no)
-  (ldr arg_x target::misc-data-offset arg_y)
-  (sub imm1 loc-pc arg_x)
-  (la imm1 (- target::misc-data-offset) imm1)
+  (ldr arg_x (:@ arg_y (:$ (+ arm::node-size arm::misc-data-offset))))
+  (sub imm1 lr arg_x)
+  (add imm1 imm1 (:$ (- arm::misc-data-offset)))
   (getvheader imm0 arg_x)
   (header-length imm0 imm0)
-  (cmplr imm1 imm0)
+  (cmp imm1 imm0)
   (box-fixnum imm1 imm1)
-  (bge @no)
-  (vpush arg_y)
-  (vpush imm1)
+  (bhs @no)
+  (vpush1 arg_y)
+  (vpush1 imm1)
   @go
   (set-nargs 2)
-  (la temp0 '2 vsp)
-  (ba .SPvalues)
+  (ba .SPnvalret)
   @no
-  (li imm0 nil)
-  (vpush imm0)
-  (vpush imm0)
+  (mov imm0 'nil)
+  (vpush1 imm0)
+  (vpush1 imm0)
   (b @go))
 
@@ -199 +184 @@
 (defarmlapfunction %%frame-savevsp ((p arg_z))
   (check-nargs 1)
-  (ldr arg_z target::lisp-frame.savevsp arg_z)
-  (bx lr))
-
-
-
-
-
-#+ppc32-target
-(eval-when (:compile-toplevel :execute)
-  (assert (eql ppc32::t-offset #x11)))
+  (ldr arg_z (:@ arg_z (:$ arm::lisp-frame.savevsp)))
+  (bx lr))
+
+
+
+
+
+
 
 (defarmlapfunction %uvector-data-fixnum ((uv arg_z))
   (check-nargs 1)
-  (trap-unless-fulltag= arg_z target::fulltag-misc)
-  (la arg_z target::misc-data-offset arg_z)
+  (trap-unless-fulltag= arg_z arm::fulltag-misc)
+  (add arg_z arg_z (:$ arm::misc-data-offset))
   (bx lr))
 
 (defarmlapfunction %catch-top ((tcr arg_z))
   (check-nargs 1)
-  (ldr arg_z target::tcr.catch-top tcr)
-  (cmpri cr0 arg_z 0)
-  (bne @ret)
-  (li arg_z nil)
- @ret
-  (bx lr))
-
-(defarmlapfunction %catch-tsp ((catch arg_z))
-  (check-nargs 1)
-  (la arg_z (- (+ target::fulltag-misc
-                                 (ash 1 (1+ target::word-shift)))) arg_z)
-  (bx lr))
+  (ldr arg_z (:@ tcr (:$ arm::tcr.catch-top)))
+  (cmp arg_z (:$ 0))
+  (moveq arg_z 'nil)
+  (bx lr))
+
+
 
 
@@ -243 +220 @@
 
 (defarmlapfunction %save-standard-binding-list ((bindings arg_z))
-  (ldr imm0 target::tcr.vs-area target::rcontext)
-  (ldr imm1 target::area.high imm0)
-  (push bindings imm1)
+  (ldr imm0 (:@ arm::rcontext (:$ arm::tcr.vs-area)))
+  (ldr imm1 (:@ imm0 (:$ arm::area.high)))
+  (push1 bindings imm1)
   (bx lr))
 
 (defarmlapfunction %saved-bindings-address ()
-  (ldr imm0 target::tcr.vs-area target::rcontext)
-  (ldr imm1 target::area.high imm0)
-  (la arg_z (- target::node-size) imm1)
+  (ldr imm0 (:@ arm::rcontext (:$ arm::tcr.vs-area)))
+  (ldr imm1 (:@ imm0 (:$ arm::area.high)))
+  (add arg_z imm1 (:$ (- arm::node-size)))
   (bx lr))
 
 (defarmlapfunction %code-vector-pc ((code-vector arg_y) (pcptr arg_z))
+  (build-lisp-frame)
   (macptr-ptr imm0 pcptr)
-  (ldr loc-pc 0 imm0)
-  (sub imm0 loc-pc code-vector)
-  (subi imm0 imm0 target::misc-data-offset)
+  (ldr lr (:@ imm0 (:$ 0)))
+  (sub imm0 lr code-vector)
+  (sub imm0 imm0 (:$ arm::misc-data-offset))
   (getvheader imm1 code-vector)
   (header-size imm1 imm1)
-  (slri imm1 imm1 2)
-  (cmplr imm0 imm1)
-  (li arg_z nil)
-  (bgelr)
-  (box-fixnum arg_z imm0)
-  (bx lr))
-
+  (mov imm1 (:lsr imm1 (:$ 2)))
+  (cmp imm0 imm1)
+  (movhs arg_z 'nil)
+  (movlo arg_z (:lsl imm0 (:$ arm::fixnumshift)))
+  (return-lisp-frame))
+
+#+notyet
+(progn
 ;;; FF-call, in LAP.
 #+eabi-target
@@ -1050 +1029 @@
     )
   )
+)
 
 
@@ -1055 +1035 @@
 (defarmlapfunction %get-object ((macptr arg_y) (offset arg_z))
   (check-nargs 2)
-  (trap-unless-typecode= arg_y target::subtag-macptr)
+  (trap-unless-xtype= arg_y arm::subtag-macptr)
   (macptr-ptr imm0 arg_y)
-  (trap-unless-lisptag= arg_z target::tag-fixnum imm1)
+  (trap-unless-fixnum arg_z)
   (unbox-fixnum imm1 arg_z)
-  (ldrx arg_z imm0 imm1)
+  (ldr arg_z (:@ imm0 imm1))
   (bx lr))
 
@@ -1065 +1045 @@
 (defarmlapfunction %set-object ((macptr arg_x) (offset arg_y) (value arg_z))
   (check-nargs 3)
-  (trap-unless-typecode= arg_x target::subtag-macptr)
+  (trap-unless-xtype= arg_x arm::subtag-macptr)
   (macptr-ptr imm0 arg_x)
-  (trap-unless-lisptag= arg_y target::tag-fixnum imm1)
+  (trap-unless-fixnum arg_y)
   (unbox-fixnum imm1 arg_y)
-  (strx arg_z imm0 imm1)
+  (str arg_z (:@ imm0 imm1))
   (bx lr))
 
@@ -1077 +1057 @@
                                                      (args arg_z))
   ;; Somebody's called (or tail-called) us.
-  ;; Put magic arg in ppc::next-method-context (= ppc::temp1).
-  ;; Put function in ppc::nfn (= ppc::temp2).
+  ;; Put magic arg in arm::next-method-context (= arm::temp1).
+  ;; Put function in arm::nfn (= arm::temp2).
   ;; Set nargs to 0, then spread "args" on stack (clobbers arg_x, arg_y, arg_z,
-  ;;   but preserves ppc::nfn/ppc::next-method-context.
-  ;; Jump to the function in ppc::nfn.
-  (mov ppc::next-method-context magic)
-  (mov ppc::nfn function)
+  ;;   but preserves arm::nfn/arm::next-method-context.
+  ;; Jump to the function in arm::nfn.
+  (mov arm::next-method-context magic)
+  (mov arm::nfn function)
   (set-nargs 0)
-  (mflr loc-pc)
-  (bla .SPspread-lexpr-z)
-  (mtlr loc-pc)
-  (ldr temp0 target::misc-data-offset nfn)
-  (mtctr temp0)
-  (bctr))
+  (build-lisp-frame)
+  (bl .SPspread-lexprz)
+  (restore-lisp-frame)
+  (ldr pc (:@ nfn (:$ arm::function.entrypoint))))
 
 
@@ -1097 +1075 @@
                                                (args arg_z))
   ;; Somebody's called (or tail-called) us.
-  ;; Put magic arg in ppc::next-method-context (= ppc::temp1).
-  ;; Put function in ppc::nfn (= ppc::temp2).
+  ;; Put magic arg in arm::next-method-context (= arm::temp1).
+  ;; Put function in arm::nfn (= arm::temp2).
   ;; Set nargs to 0, then spread "args" on stack (clobbers arg_x, arg_y, arg_z,
-  ;;   but preserves ppc::nfn/ppc::next-method-context.
-  ;; Jump to the function in ppc::nfn.
-  (mov ppc::next-method-context magic)
-  (mov ppc::nfn function)
+  ;;   but preserves arm::nfn/arm::next-method-context.
+  ;; Jump to the function in arm::nfn.
+  (mov arm::next-method-context magic)
+  (mov arm::nfn function)
   (set-nargs 0)
-  (mflr loc-pc)
-  (bla .SPspreadargZ)
-  (mtlr loc-pc)
-  (ldr temp0 target::misc-data-offset nfn)
-  (mtctr temp0)
-  (bctr))
+  (build-lisp-frame)
+  (bl .SPspreadargZ)
+  (restore-lisp-frame)
+  (ldr pc (:@ nfn (:$ arm::function.entrypoint))))
 
 
@@ -1127 +1103 @@
   ;; the first frame that .SPlexpr-entry pushed, restore vsp from (+
   ;; args node-size), pop the argregs, and jump to the function.
-  (mflr loc-pc)
   (ref-global imm0 ret1valaddr)
-  (cmpr cr2 loc-pc imm0)
-  (ldr nargs 0 args)
-  (mov imm5 nargs)
-  (cmpri cr0 nargs 0)
-  (cmpri cr1 nargs '2)
+  (cmp lr imm0)
+  (ldr nargs (:@ args (:$ 0)))
   (mov nfn method)
-  (ldr temp0 target::misc-data-offset nfn)
-  (mtctr temp0)
-  (if (:cr2 :eq)
-    (la sp target::lisp-frame.size sp))
-  (ldr loc-pc target::lisp-frame.savelr sp)
-  (ldr fn target::lisp-frame.savefn sp)
-  (ldr imm0 target::lisp-frame.savevsp sp)
+  (addeq sp sp (:$ arm::lisp-frame.size))
+  (ldr lr (:@ sp (:$ arm::lisp-frame.savelr)))
+  (ldr fn (:@ sp (:$ arm::lisp-frame.savefn)))
+  (ldr imm0 (:@ sp (:$ arm::lisp-frame.savevsp)))
   (sub vsp imm0 nargs)
-  (mtlr loc-pc)
-  (la sp target::lisp-frame.size sp)
-  (beqctr)
-  (vpop arg_z)
-  (bltctr cr1)
-  (vpop arg_y)
-  (beqctr cr1)
-  (vpop arg_x)
-  (bctr))
+  (add sp sp (:$ arm::lisp-frame.size))
+  (cmp nargs (:$ 0))
+  (ldreq pc (:@ nfn (:$ arm::function.entrypoint)))
+  (cmp nargs '2)
+  (vpop1 arg_z)
+  (ldrlo pc (:@ nfn (:$ arm::function.entrypoint)))
+  (vpop1 arg_y)
+  (ldreq pc (:@ nfn (:$ arm::function.entrypoint)))
+  (vpop1 arg_x)
+  (ldr pc (:@ nfn (:$ arm::function.entrypoint))))
 
 
@@ -1162 +1132 @@
         (error "Wrong size target ~s" target)))
     (%copy-gvector-to-gvector proto 0 new 0 total-size)
+    (setf (%svref new 0 )arm::*function-initial-entrypoint*)
     new))
 
@@ -1167 +1138 @@
   (if (typep target-fn 'function)
     (if (typep proto-fn 'function)
-      (setf (uvref target-fn 0)
-            (uvref proto-fn 0))
+      (setf (uvref target-fn 0) arm::*function-initial-entrypoint*
+            (uvref target-fn 1) (uvref proto-fn 1))
       (report-bad-arg proto-fn 'function))
     (report-bad-arg target-fn 'function)))
@@ -1174 +1145 @@
 (defun closure-function (fun)
   (while (and (functionp fun)  (not (compiled-function-p fun)))
-    (setq fun (%svref fun 1))
+    (setq fun (%svref fun 2))
     (when (vectorp fun)
       (setq fun (svref fun 0))))
@@ -1182 +1153 @@
 ;;; For use by (setf (apply ...) ...)
 ;;; (apply+ f butlast last) = (apply f (append butlast (list last)))
-#+ppc-target
-(defun apply+ (&lap function arg1 arg2 &rest other-args)
-  (ppc-lap-function apply+ ()
-   (check-nargs 3 nil)
-   (vpush arg_x)
-   (mov temp0 arg_z)                     ; last
-   (mov arg_z arg_y)                     ; butlast
-   (subi nargs nargs '2)                ; remove count for butlast & last
-   (mflr loc-pc)
-   (bla .SPspreadargz)
-   (cmpri cr0 nargs '3)
-   (mtlr loc-pc)
-   (addi nargs nargs '1)                ; count for last
-   (blt cr0 @nopush)
-   (vpush arg_x)
-@nopush
-   (mov arg_x arg_y)
-   (mov arg_y arg_z)
-   (mov arg_z temp0)
-   (ldr temp0 'funcall nfn)
-   (ba .SPfuncall)))
-
-(lfun-bits #'apply+ (logior $lfbits-rest-bit
-                            (dpb 3 $lfbits-numreq 0)))
-
-;;; end of ppc-def.lisp
+(defarmlapfunction apply+ ()
+  (:arglist (function arg1 arg2 &rest other-args))
+  (check-nargs 3 nil)
+  (vpush1 arg_x)
+  (mov temp0 arg_z)                     ; last
+  (mov arg_z arg_y)                     ; butlast
+  (sub nargs nargs '2)                  ; remove count for butlast & last
+  (build-lisp-frame)
+  (bl .SPspreadargz)
+  (cmp nargs '3)
+  (restore-lisp-frame)
+  (add nargs nargs '1)                  ; count for last
+  (strhs arg_x (:@! vsp (:$ -4)))
+  (mov arg_x arg_y)
+  (mov arg_y arg_z)
+  (mov arg_z temp0)
+  (ldr nfn (:@ nfn 'funcall))
+  (ba .SPfuncall))
+
+
+
+;;; end of arm-def.lisp

branches/arm/level-0/ARM/arm-misc.lisp

@@ -371 +371 @@
     (bx lr)))
 
-#+notyet                                ; needs ARM subprim ?
 (defarmlapfunction set-%gcable-macptrs% ((ptr arm::arg_z))
-  (li imm0 (+ (target-nil-value) (arm::kernel-global gcable-pointers)))
-  @again
-  (lrarx arg_y rzero imm0)
-  (str arg_y arm::xmacptr.link ptr)
-  (strcx. ptr rzero imm0)
+  (mov imm0 (:$ (- arm::nil-value arm::fulltag-nil)))
+  (add imm1 imm0 (:$ (arm::kernel-global gcable-pointers)))
+  @again
+  (ldrex arg_y (:@ imm1))
+  (str arg_y (:@ ptr (:$ arm::xmacptr.link)))
+  (strex imm0 ptr (:@ imm1))
+  (cmp imm0 (:$ 0))
   (bne @again)
-  (isync)
   (bx lr))
 
 ;;; Atomically increment or decrement the gc-inhibit-count kernel-global
 ;;; (It's decremented if it's currently negative, incremented otherwise.)
-#+notyet                                ;needs ARM subprim ?
 (defarmlapfunction %lock-gc-lock ()
-  (li imm0 (+ (target-nil-value) (arm::kernel-global gc-inhibit-count)))
-  @again
-  (lrarx arg_y rzero imm0)
-  (cmpri cr1 arg_y 0)
-  (addi arg_z arg_y '1)
-  (bge cr1 @store)
-  (subi arg_z arg_y '1)
+  (mov imm0 (:$ (- arm::nil-value arm::fulltag-nil)))
+  (add imm1 imm0 (:$ (arm::kernel-global gc-inhibit-count)))
+  @again
+  (ldrex arg_y (:@ imm1))
+  (cmp arg_y (:$ 0))
+  (add arg_z arg_y '1)
+  (sublt arg_z arg_y '1)
   @store
-  (strcx. arg_z rzero imm0)
+  (strex imm0 arg_z (:@ imm1))
+  (cmp imm0 (:$ 0))
   (bne @again)
-;;  (isync)
   (bx lr))
 
@@ -506 +505 @@
 ;;; Try to store the fixnum NEWVAL at PTR, if and only if the old value
 ;;; was equal to OLDVAL.  Return the old value
-#notyet                                 ;still
+#+notyet                                 ;still
 (defarmlapfunction %ptr-store-conditional ((ptr arg_x) (expected-oldval arg_y) (newval arg_z))
   (macptr-ptr imm0 ptr)
@@ -666 +665 @@
         
 
-  
+#+notyet
 (defarmlapfunction %%save-application ((flags arg_y) (fd arg_z))
   (unbox-fixnum imm0 flags)
-  (ori imm0 imm0 arch::gc-trap-function-save-application)
+  (orr imm0 imm0 arch::gc-trap-function-save-application)
   (unbox-fixnum imm1 fd)
   (trlgei allocptr 0)

branches/arm/level-0/l0-cfm-support.lisp

@@ -46 +46 @@
   ;; be more likely to be fixnums, for instance), so ensure that they
   ;; aren't.
-  #+x86-target
+  #+(or x86-target arm-target)
   (%setf-macptr addr (%int-to-ptr
                       (if (< entry 0)
                         (logand entry (1- (ash 1 target::nbits-in-word)))
                         entry)))
-  #-(or ppc-target x86-target) (dbg "Fix entry->addr"))
+  #-(or ppc-target x86-target arm-target) (dbg "Fix entry->addr"))
 
 
@@ -653 +653 @@
       (unless (%null-ptr-p addr)        ; No function can have address 0
         (or (macptr->fixnum addr) (%inc-ptr addr 0))))
-    #+x8632-target
+    #+(or x8632-target arm-target)
     (let* ((addr (ff-call (%kernel-import target::kernel-import-FindSymbol)
                           :address handle

branches/arm/level-0/l0-hash.lisp

@@ -96 +96 @@
     (declare (fixnum typecode))
     (or (= typecode target::subtag-macptr)
-        #+(or ppc32-target x8632-target)
+        #+(or ppc32-target x8632-target arm-target)
         (and (>= typecode target::min-numeric-subtag)
              (<= typecode target::max-numeric-subtag))

branches/arm/level-0/l0-pred.lisp

@@ -90 +90 @@
       (let* ((typecode (typecode x)))
         (declare (fixnum typecode))
-        #+(or ppc32-target x8632-target)
+        #+(or ppc32-target x8632-target arm-target)
         (and (>= typecode target::min-numeric-subtag)
              (<= typecode target::max-rational-subtag))
@@ -115 +115 @@
   (let* ((typecode (typecode x)))
     (declare (fixnum typecode))
-    #+(or ppc32-target x8632-target)
+    #+(or ppc32-target x8632-target arm-target)
     (or (= typecode target::tag-fixnum)
         (and (>= typecode target::min-numeric-subtag)
@@ -144 +144 @@
   (let* ((typecode (typecode x)))
     (declare (fixnum typecode))
-    #+(or ppc32-target x8632-target)
+    #+(or ppc32-target x8632-target arm-target)
     (or (= typecode target::tag-fixnum)
         (and (>= typecode target::min-numeric-subtag)
@@ -223 +223 @@
 ;;; things that it wasn't true of on the 68K.
 (defun gvectorp (x)
-  #+(or ppc32-target x8632-target)
+  #+(or ppc32-target x8632-target arm-target)
   (= (the fixnum (logand (the fixnum (typecode x)) target::fulltagmask)) target::fulltag-nodeheader)
   #+ppc64-target
@@ -238 +238 @@
 
 (defun ivectorp (x)
-  #+(or ppc32-target x8632-target)
+  #+(or ppc32-target x8632-target arm-target)
   (= (the fixnum (logand (the fixnum (typecode x)) target::fulltagmask))
      target::fulltag-immheader)
@@ -254 +254 @@
 
 (defun miscobjp (x)
-  #+(or ppc32-target x8632-target x8664-target)
+  #+(or ppc32-target x8632-target x8664-target arm-target)
   (= (the fixnum (lisptag x)) target::tag-misc)
   #+ppc64-target
@@ -1053 +1053 @@
 (defun symbolp (thing)
   "Return true if OBJECT is a SYMBOL, and NIL otherwise."
-  #+(or ppc32-target x8632-target)
+  #+(or ppc32-target x8632-target arm-target)
   (if thing
     (= (the fixnum (typecode thing)) target::subtag-symbol)

branches/arm/level-0/l0-symbol.lisp

@@ -206 +206 @@
 (defun symbol-name (sym)
   "Return SYMBOL's name as a string."
-  #+(or ppc32-target x8632-target x8664-target)
+  #+(or ppc32-target x8632-target x8664-target arm-target)
   (%svref (symptr->symvector (%symbol->symptr sym)) target::symbol.pname-cell)
   #+ppc64-target

branches/arm/level-1/l1-sockets.lisp

@@ -949 +949 @@
             #+x8664-target (and (>= subtype x8664::min-8-bit-ivector-subtag)
                                 (<= subtype x8664::max-8-bit-ivector-subtag))
+            #+arm-target (and (<= arm::min-8-bit-ivector-subtag subtype)
+                                (<= subtype arm::max-8-bit-ivector-subtag))
       (report-bad-arg buf `(or (array character)
                                (array (unsigned-byte 8))

branches/arm/lib/compile-ccl.lisp

@@ -102 +102 @@
 (defparameter *x8632-xload-modules* '(xx8632fasload xfasload heap-image ))
 (defparameter *x8664-xload-modules* '(xx8664fasload xfasload heap-image ))
+(defparameter *arm-xload-modules* '(xarmfasload xfasload heap-image ))
 
 
@@ -107 +108 @@
 (defparameter *ppc-xdev-modules* '(ppc-lapmacros ))
 (defparameter *x86-xdev-modules* '(x86-lapmacros ))
+(defparameter *arm-xdev-modules* '(arm-lapmacros ))
 
 (defun target-xdev-modules (&optional (target
@@ -113 +115 @@
   (case target
     ((:ppc32 :ppc64) *ppc-xdev-modules*)
-    ((:x8632 :x8664) *x86-xdev-modules*)))
+    ((:x8632 :x8664) *x86-xdev-modules*)
+    (:arm *arm-xdev-modules*)))
 
 (defun target-xload-modules (&optional (target
@@ -120 +123 @@
     ((:ppc32 :ppc64) *ppc-xload-modules*)
     (:x8632 *x8632-xload-modules*)
-    (:x8664 *x8664-xload-modules*)))
+    (:x8664 *x8664-xload-modules*)
+    (:arm *arm-xload-modules*)))
 
 
@@ -386 +390 @@
 
 (defun target-xcompile-ccl (target &optional force)
-  (require-update-modules *sysdef-modules* force) ;in the host
+  (let* ((*target-backend* *host-backend*))
+    (require-update-modules *sysdef-modules* force)) ;in the host
   (let* ((backend (or (find-backend target) *target-backend*))
          (arch (backend-target-arch-name backend))

branches/arm/lib/foreign-types.lisp

@@ -102 +102 @@
                         (:win32 "ccl:win32-headers;")
                         (:solarisx8632 "ccl:solarisx86-headers;")
-                        (:freebsdx8632 "ccl:freebsd-headers;"))
+                        (:freebsdx8632 "ccl:freebsd-headers;")
+                        (:linuxarm "ccl:arm-headers;"))
                     :interface-package-name
                     #.(ftd-interface-package-name *target-ftd*)

branches/arm/lib/nfcomp.lisp

@@ -144 +144 @@
       (warn "Unknown :TARGET : ~S.  Reverting to ~s ..." target *fasl-target*)
       (setq target *fasl-target*  backend *target-backend*))
+    (unless (eq *target-backend* *host-backend*)
+      (setq save-source-locations nil))
     (multiple-value-bind (output-file truename warnings-p serious-p)
         (loop

branches/arm/lib/systems.lisp

@@ -134 +134 @@
     (xx8632fasload    "ccl:xdump;xx8632-fasload"  ("ccl:xdump;xx8632-fasload.lisp"))
     (xx8664fasload    "ccl:xdump;xx8664-fasload"  ("ccl:xdump;xx8664-fasload.lisp"))
+    (xarmfasload      "ccl:xdump;xarm-fasload"   ("ccl:xdump;xarmfasload.lisp"))
     (heap-image       "ccl:xdump;heap-image"     ("ccl:xdump;heap-image.lisp"))
     (xsym             "ccl:xdump;xsym"           ("ccl:xdump;xsym.lisp"))

branches/arm/lisp-kernel/area.h

@@ -153 +153 @@
 #define PURESPACE_SIZE (1LL<<30LL)
 #else
+#ifdef ARM
+#define PURESPACE_RESERVE (8<<20)
+#define PURESPACE_SIZE (4<<20)
+#else
 #define PURESPACE_RESERVE (128<<20) /* MB */
 #define PURESPACE_SIZE (64<<20)
+#endif
 #endif
 

branches/arm/lisp-kernel/arm-constants.s

@@ -348 +348 @@
         _struct(lisp_frame,0)
          _node(marker)
+         _node(savevsp) 
          _node(savefn) 
-         _node(savevsp) 
          _node(savelr)  
         _ends

branches/arm/lisp-kernel/arm-exceptions.c

@@ -129 +129 @@
 
       instr = program_counter[-4];
-      if (IS_SUB_LOW_FROM_ALLOCPTR(instr)) {
+      if (IS_SUB_LO_FROM_ALLOCPTR(instr)) {
         return -((signed_natural)(disp | (instr & 0xff)));
       }

branches/arm/lisp-kernel/arm-spentry.s

@@ -296 +296 @@
         __(beq _SPmakes64)
         __(bgt 9f)
-        __(mov imm1,imm1,asl imm2)
-        __(rsb imm2,imm2,#32)
-        __(orr imm1,imm1,imm0,asr imm2)
-        __(unbox_fixnum(imm2,arg_z))
-        __(mov imm0,imm0,asl imm2)
+        __(rsb imm1,imm2,#32)
+        __(mov imm1,imm0,asr imm1)
+        __(mov imm0,imm0,lsl imm2)
         __(b _SPmakes64)
 9:  
@@ -803 +801 @@
         __(cmp arg_z,arg_y)
         __(_rplaca(arg_y,arg_z))
-        __(bxls lr)
+        __(bxhs lr)
         __(ref_global(temp0,ref_base))
         __(sub imm0,arg_y,temp0)
         __(mov imm0,imm0,lsr #dnode_shift)
-        __(ref_global(temp0,oldspace_dnode_count))
-        __(cmp imm0,temp0)
+        __(ref_global(imm1,oldspace_dnode_count))
+        __(cmp imm0,imm1)
         __(bxhs lr)
         __(and imm2,imm0,#31)
@@ -814 +812 @@
         __(mov imm1,imm1,lsr imm2)
         __(mov imm0,imm0,lsr #bitmap_shift)
-        __(ref_global(imm2,refbits))
-        __(add imm2,imm2,imm0,lsl #word_shift)
-        __(ldr imm0,[imm2])
-        __(ands imm0,imm0,imm1)
-        __(bxne lr)
-        __(build_lisp_frame(imm0))
-        __(set_ref_bit(rplaca))
+        __(ref_global(temp0,refbits))
+        __(add temp0,temp0,imm0,lsl #word_shift)
+0:      __(ldrex imm2,[temp0])
+        __(orr imm2,imm2,imm1)
+        __(strex imm0,imm2,[temp0])
+        __(cmp imm0,#0)
+        __(bne 0b)        
         __(bx lr)
 
@@ -829 +827 @@
         __(cmp arg_z,arg_y)
         __(_rplacd(arg_y,arg_z))
-        __(bxls lr)
+        __(bxhs lr)
         __(ref_global(temp0,ref_base))
         __(sub imm0,arg_y,temp0)
         __(mov imm0,imm0,lsr #dnode_shift)
-        __(ref_global(temp0,oldspace_dnode_count))
-        __(cmp imm0,temp0)
+        __(ref_global(imm1,oldspace_dnode_count))
+        __(cmp imm0,imm1)
         __(bxhs lr)
         __(and imm2,imm0,#31)
@@ -840 +838 @@
         __(mov imm1,imm1,lsr imm2)
         __(mov imm0,imm0,lsr #bitmap_shift)
-        __(ref_global(imm2,refbits))
-        __(add imm2,imm2,imm0,lsl #word_shift)
-        __(ldr imm0,[imm2])
-        __(ands imm0,imm0,imm1)
-        __(bxne lr)
-        __(build_lisp_frame(imm0))
-        __(set_ref_bit(rplacd))
+        __(ref_global(temp0,refbits))
+        __(add temp0,temp0,imm0,lsl #word_shift)
+0:      __(ldrex imm2,[temp0])
+        __(orr imm2,imm2,imm1)
+        __(strex imm0,imm2,[temp0])
+        __(cmp imm0,#0)
+        __(bne 0b)        
         __(bx lr)
         
@@ -929 +927 @@
 dnl         __(isync)
 dnl         __(bx lr)
-dnl         
-dnl /*
-dnl    Interrupt handling (in pc_luser_xp()) notes: 
-dnl    If we are in this function and before the test which follows the
-dnl    conditional (at egc_store_node_conditional), or at that test
-dnl    and cr0`eq' is clear, pc_luser_xp() should just let this continue
-dnl    (we either haven't done the store conditional yet, or got a
-dnl    possibly transient failure.)  If we're at that test and the
-dnl    cr0`EQ' bit is set, then the conditional store succeeded and
-dnl    we have to atomically memoize the possible intergenerational
-dnl    reference.  Note that the local labels 4 and 5 are in the
-dnl    body of the next subprim (and at or beyond 'egc_write_barrier_end').
-dnl 
-dnl    N.B: it's not possible to really understand what's going on just
-dnl    by the state of the cr0`eq' bit.  A transient failure in the
-dnl    conditional stores that handle memoization might clear cr0`eq'
-dnl    without having completed the memoization.
-dnl */
-dnl 
+
+
+/*
+   Interrupt handling (in pc_luser_xp()) notes: 
+   If we are in this function and before the test which follows the
+   conditional (at egc_store_node_conditional), or at that test
+   and cr0`eq' is clear, pc_luser_xp() should just let this continue
+   (we either haven't done the store conditional yet, or got a
+   possibly transient failure.)  If we're at that test and the
+   cr0`EQ' bit is set, then the conditional store succeeded and
+   we have to atomically memoize the possible intergenerational
+   reference.  Note that the local labels 4 and 5 are in the
+   body of the next subprim (and at or beyond 'egc_write_barrier_end').
+
+   N.B: it's not possible to really understand what's going on just
+   by the state of the cr0`eq' bit.  A transient failure in the
+   conditional stores that handle memoization might clear cr0`eq'
+   without having completed the memoization.
+*/
+
             .globl C(egc_store_node_conditional)
             .globl C(egc_write_barrier_end)
 _spentry(store_node_conditional)
 C(egc_store_node_conditional):
-dnl         __(cmplr(cr2,arg_z,arg_x))
-dnl         __(vpop(temp0))
-dnl         __(unbox_fixnum(imm4,temp0))
-dnl 1:      __(lrarx(temp1,arg_x,imm4))
-dnl         __(cmpr(cr1,temp1,arg_y))
-dnl         __(bne cr1,5f)
-dnl         __(strcx(arg_z,arg_x,imm4))
-           .globl C(egc_store_node_conditional_test)
+        __(vpop1(temp0))
+         
+1:      __(unbox_fixnum(imm2,temp0))
+        __(add imm2,imm2,arg_x)
+        __(ldrex temp1,[imm2])
+        __(cmp temp1,arg_y)
+        __(bne 5f)
+        __(strex imm0,arg_z,[imm2])
+        .globl C(egc_store_node_conditional_test)
 C(egc_store_node_conditional_test): 
-dnl         __(bne 1b)
-dnl         __(isync)
-dnl         __(add imm0,imm4,arg_x)
-dnl         __(ref_global(imm2,ref_base))
-dnl         __(ref_global(imm1,oldspace_dnode_count))
-dnl         __(sub imm0,imm0,imm2)
-dnl         __(load_highbit(imm3))
-dnl         __(srri(imm0,imm0,dnode_shift))       
-dnl         __(cmplr(imm0,imm1))
-dnl         __(extract_bit_shift_count(imm2,imm0))
-dnl         __(srri(imm0,imm0,bitmap_shift))       
-dnl         __(srr(imm3,imm3,imm2))
-dnl         __(ref_global(imm2,refbits))
-dnl         __(bge 4f)
-dnl         __(slri(imm0,imm0,word_shift))
-dnl 2:      __(lrarx(imm1,imm2,imm0))
-dnl         __(or imm1,imm1,imm3)
-dnl         __(strcx( imm1,imm2,imm0))
-dnl         __(bne- 2b)
-dnl         __(isync)
-dnl         __(b 4f)
-dnl 
-dnl /* arg_z = new value, arg_y = expected old value, arg_x = hash-vector,
-dnl    vsp`0' = (boxed) byte-offset 
-dnl    Interrupt-related issues are as in store_node_conditional, but
-dnl    we have to do more work to actually do the memoization.*/
+        __(cmp imm0,#0)
+        __(bne 1b)
+        __(cmp arg_z,arg_x)
+        __(blo 4f)
+
+        __(ref_global(imm0,ref_base))
+        __(ref_global(imm1,oldspace_dnode_count))
+        __(sub imm0,imm2,imm0)
+        __(mov imm0,imm0,lsr #dnode_shift)
+        __(cmp imm0,imm1)
+        __(bhs 4f)
+        __(and imm1,imm0,#31)
+        __(mov arg_x,#0x80000000)
+        __(mov imm1,arg_x,lsr imm1)
+        __(ref_global(temp0,refbits))
+        __(mov imm0,imm0,lsr #bitmap_shift)
+        __(add temp0,temp0,imm0,lsl #word_shift)
+2:      __(ldrex imm2,[temp0])
+        __(orr imm2,imm2,imm1)
+        __(strex imm0,imm2,[temp0])
+        __(cmp imm0,#0)
+        __(bne 2b)
+        __(b 4f)
+ 
+/* arg_z = new value, arg_y = expected old value, arg_x = hash-vector,
+    vsp`0' = (boxed) byte-offset 
+    Interrupt-related issues are as in store_node_conditional, but
+l    we have to do more work to actually do the memoization.*/
 _spentry(set_hash_key_conditional)
         .globl C(egc_set_hash_key_conditional)
@@ -1037 +1039 @@
 dnl         __(isync)
 C(egc_write_barrier_end):
-dnl 4: __(mov arg_z,#t_value)
-dnl  __(bx lr)
-dnl 5:      __(mov imm0,#RESERVATION_DISCHARGE)
-dnl         __(strcx(rzero,0,imm0))
-dnl  __(mov arg_z,#nil_value)
-dnl  __(bx lr)
-dnl  
-dnl  
-dnl         
-dnl  
-dnl 
+4:      __(mov arg_z,#nil_value)
+        __(add arg_z,arg_z,#t_offset)
+        __(bx lr)
+5:      __(clrex)
+        __(mov arg_z,#nil_value)
+        __(bx lr)
+
+
+
+
         
 /* We always have to create a stack frame (even if nargs is 0), so the compiler  */
@@ -1316 +1317 @@
         /* (vpush (< imm1 nargs))  */
         __(cmp imm1,nargs)
+        __(add imm1,imm1,#fixnumone)
         __(subeq arg_x,arg_x,#t_offset)
         __(vpush1(arg_x))
@@ -2940 +2942 @@
 popdef(`r',)                
         
+
+               
+_spentry(eabi_ff_call)
+        __(ldr arg_y,[rcontext,#tcr.last_lisp_frame])
+        __(stmdb vsp!,{arg_y,arg_x,temp0,temp1,temp2})
+/* There's a u32 vector on top of the stack ; its first data word points
+   to the previous stack object.  The 4 words at the bottom of the vector
+   are reserved for a lisp frame, which we construct carefully ... */
+        __(mov imm0,#lisp_frame_marker)
+        __(mov imm1,#0)
+        __(ldr temp0,[sp,#4])
+        __(sub temp0,temp0,#lisp_frame.size)
+        __(str imm0,[temp0,#lisp_frame.marker])
+        __(ldr imm0,[sp,#0])        
+        __(str imm1,[temp0,#lisp_frame.savefn])
+        __(str imm1,[temp0,#lisp_frame.savelr])
+        __(sub imm0,imm0,#(lisp_frame.size/4)<<num_subtag_bits)
+        __(str vsp,[temp0,#lisp_frame.savevsp])
+        __(str imm0,[sp,#0])
+        __(str lr,[temp0,#lisp_frame.savelr])
+        __(str fn,[temp0,#lisp_frame.savefn])
+        __(str allocptr,[rcontext,#tcr.save_allocptr])
+        __(str temp0,[rcontext,#tcr.last_lisp_frame])
+        __(mov temp0,rcontext)
+        __(mov imm0,#TCR_STATE_FOREIGN)
+        __(str imm0,[rcontext,#tcr.valence])
+        __(add sp,sp,#dnode_size)
+        __(ldmia sp!,{r0,r1,r2,r3})
+        __(blx arg_z)           /* fix this */
+        __(mov temp1,#0)
+        __(mov temp2,#0)
+        __(mov arg_z,#0)
+        __(mov arg_y,#0)
+        __(mov arg_x,#0)
+        __(mov fn,#0)
+        __(mov allocptr,#VOID_ALLOCPTR)
+        __(mov rcontext,temp0)
+        __(ldr sp,[rcontext,#tcr.last_lisp_frame])
+        __(str fn,[rcontext,#tcr.valence])
+        __(ldr allocptr,[rcontext,#tcr.save_allocptr])
+        __(restore_lisp_frame(temp0))
+        __(ldmia vsp!,{arg_y,arg_x,temp0,temp1,temp2})
+        __(str arg_y,[rcontext,#tcr.last_lisp_frame])
+        __(bx lr)
         
-_spentry(eabi_ff_call)                                
+        
 
 _spentry(debind)

branches/arm/lisp-kernel/arm-subprims.s

@@ -76 +76 @@
         __(mov imm0,imm0,lsl #num_subtag_bits-word_shift)
         __(orr imm0,imm0,#subtag_u32_vector)
-        __(stm sp!,{imm0,imm2})
+        __(stmdb sp!,{imm0,imm2})
         __(mov imm0,#TCR_STATE_LISP)
         __(str imm0,[rcontext,#tcr.valence])
         __(ldr allocptr,[rcontext,#tcr.save_allocptr])
         __(bl toplevel_loop)
-        __(ldr imm1,[sp,#4])
+        __(ldmia sp!,{imm0,imm1})
         __(mov imm0,#TCR_STATE_FOREIGN)
         __(str imm1,[rcontext,#tcr.last_lisp_frame])

branches/arm/lisp-kernel/image.c

@@ -353 +353 @@
         image_nil = (LispObj)(a->low) + (1024*4) + fulltag_cons;
 #endif
+#endif
+#ifdef ARM
+        image_nil = (LispObj)(a->low) + (1024*4) + fulltag_nil;
 #endif
         set_nil(image_nil);

branches/arm/lisp-kernel/linuxarm/Makefile

@@ -25 +25 @@
 CDEFINES = -DLINUX -DARM -D_REENTRANT -D_GNU_SOURCE
 CDEBUG = -g
-COPT = -O2
+COPT = #-O2
 # Once in a while, -Wformat says something useful.  The odds are against that,
 # however.

branches/arm/lisp-kernel/platform-linuxarm.h

@@ -26 +26 @@
 
 
-#define MAXIMUM_MAPPABLE_MEMORY (1U<<30) /* uh, no */
-#define IMAGE_BASE_ADDRESS 0x31000000 /*  not likely */
+#define MAXIMUM_MAPPABLE_MEMORY (256<<20) /* uh, no */
+#define IMAGE_BASE_ADDRESS 0x10001000
 
 #include "lisptypes.h"

branches/arm/lisp-kernel/pmcl-kernel.c

@@ -1816 +1816 @@
 #ifdef X86
   lisp_global(SUBPRIMS_BASE) = (LispObj)((1<<16)+(5<<10));
-#else
+#endif
+#ifdef PPC
   lisp_global(SUBPRIMS_BASE) = (LispObj)(5<<10);
 #endif
+#ifdef ARM
+  lisp_global(SUBPRIMS_BASE) = (LispObj)(9<<12);
+#endif
+
   lisp_global(RET1VALN) = (LispObj)&ret1valn;
   lisp_global(LEXPR_RETURN) = (LispObj)&nvalret;
@@ -1941 +1946 @@
 xMakeDataExecutable(void *start, unsigned long nbytes)
 {
-#ifndef X86
+#ifdef PPC
   extern void flush_cache_lines();
   natural ustart = (natural) start, base, end;
@@ -1948 +1953 @@
   end = (ustart + nbytes + cache_block_size - 1) & ~(cache_block_size-1);
   flush_cache_lines(base, (end-base)/cache_block_size, cache_block_size);
+#endif
+#ifdef ARM
+  extern void flush_cache_lines(void *, void *);
+  flush_cache_lines(start,((char *)start)+nbytes);
 #endif
 }

branches/arm/lisp-kernel/thread_manager.c

@@ -1524 +1524 @@
   tcr->cs_area = a;
   a->owner = tcr;
+#ifdef ARM
+  tcr->last_lisp_frame = (lisp_frame *)(a->high);
+#endif
   if (!(tcr->flags & (1<<TCR_FLAG_BIT_FOREIGN))) {
     tcr->cs_limit = (LispObj)ptr_to_lispobj(a->softlimit);

branches/arm/xdump/xfasload.lisp

@@ -1054 +1054 @@
       ;; 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
-                                            *xload-target-backend*))))
+      ;; On the ARM: make a two-element vector: entrypoint, code-vector.
+      (let* ((udf-object (xload-make-gvector :simple-vector (target-arch-case (:arm 2) (otherwise 1)))))
+        (target-arch-case
+         (:arm
+          (setf (xload-%svref udf-object 0)
+                (subprim-name->offset '.SPfix-nfn-entrypoint *target-backend*)))
+         (otherwise ))
+        (setf (xload-%svref udf-object (target-arch-case
+                                        (:arm 1) (otherwise 0)))
+              (xload-save-code-vector
+               (backend-xload-info-udf-code
+                *xload-target-backend*))))
       (let* ((udf-object (xload-make-gvector :simple-vector 1)))
         (setf (xload-%svref udf-object 0) (backend-xload-info-udf-code