Changeset 14119


Ignore:
Timestamp:
Aug 5, 2010, 7:33:28 AM (9 years ago)
Author:
gb
Message:

Changes from ARM branch. Need testing ...

Location:
trunk/source
Files:
50 added
59 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/compiler/backend.lisp

    r13067 r14119  
    2929(defconstant platform-cpu-sparc (ash 1 3))
    3030(defconstant platform-cpu-x86 (ash 2 3))
     31(defconstant platform-cpu-arm (ash 3 3))
    3132(defconstant platform-os-vxworks 0)
    3233(defconstant platform-os-linux 1)
  • trunk/source/compiler/nx1.lisp

    r14047 r14119  
    14431443    address-expression arg-specs-and-result-spec
    14441444    (ecase (backend-name *target-backend*)
    1445       (:linuxppc32 (%nx1-operator eabi-ff-call))
     1445      ((:linuxppc32 :linuxarm) (%nx1-operator eabi-ff-call))
    14461446      ((:darwinppc32 :linuxppc64 :darwinppc64) (%nx1-operator poweropen-ff-call))
    14471447      ((:darwinx8632 :linuxx8632 :win32 :solarisx8632 :freebsdx8632) (%nx1-operator i386-ff-call))
     
    20772077                                    (dpb (length bindings) $lfbits-numreq 0))))
    20782078
     2079(defnx1 nx1-arm-lap-function (arm-lap-function) (name bindings &body body)
     2080  (require "ARM-LAP")
     2081  (setf (afunc-lfun *nx-current-function*)
     2082        (%define-arm-lap-function name `((let ,bindings ,@body))
     2083                                    (dpb (length bindings) $lfbits-numreq 0))))
     2084
     2085                   
     2086
    20792087
    20802088
  • trunk/source/compiler/optimizers.lisp

    r13251 r14119  
    18261826(define-compiler-macro listp (n)
    18271827  (let* ((arch (backend-target-arch *target-backend*))
    1828          (cons-tag (arch::target-cons-tag arch))
     1828         (list-tag (logand (arch::target-cons-tag arch)
     1829                           (1- (ash 1 (arch::target-nlisptagbits arch)))))
    18291830         (nil-tag  (arch::target-null-tag arch))
    18301831         (symbol-tag (arch::target-symbol-tag arch)))
     
    18331834        `(let* ((,nvar ,n))
    18341835          (if ,nvar (consp ,nvar) t)))
    1835       `(eql (lisptag ,n) ,cons-tag))))
     1836      `(eql (lisptag ,n) ,list-tag))))
    18361837
    18371838(define-compiler-macro consp (&whole call n)
     
    21062107      `(let* ((,typecode (typecode ,x)))
    21072108        (declare (type (unsigned-byte 8) ,typecode))
    2108         #+(or ppc32-target x8632-target)
    2109         (or (= ,typecode target::tag-fixnum)
    2110          (and (>= ,typecode target::min-numeric-subtag)
    2111           (<= ,typecode target::max-real-subtag)))
     2109        #+(or ppc32-target x8632-target arm-target)
     2110        (and (<= ,typecode target::max-real-subtag)
     2111         (logbitp (the (integer 0 ,target::max-real-subtag)
     2112                    ,typecode)
     2113                    (logior (ash 1 target::tag-fixnum)
     2114                           (ash 1 target::subtag-single-float)
     2115                           (ash 1 target::subtag-double-float)
     2116                           (ash 1 target::subtag-bignum)
     2117                           (ash 1 target::subtag-ratio) )))
    21122118        #+ppc64-target
    21132119        (if (<= ,typecode ppc64::subtag-double-float)
  • trunk/source/compiler/vinsn.lisp

    r13067 r14119  
    263263    :sets-cc                            ; vinsn sets condition codes based on result
    264264    :discard                            ; adjusts a stack pointer
     265    :sp
     266    :predicatable                       ; all instructions can be predicated, no instructions set or test condition codes.
    265267    ))
    266268
  • trunk/source/level-0/l0-aprims.lisp

    r13067 r14119  
    102102    (string thing)
    103103    (symbol (symbol-name thing))
    104     (character (make-string 1 :initial-element thing))))
     104    (character
     105     (let* ((s (make-string 1)))
     106       (setf (schar s 0) thing)
     107       s))))
    105108
    106109
  • trunk/source/level-0/l0-array.lisp

    r13067 r14119  
    172172   
    173173)
     174
     175#+arm-target
     176(defconstant arm::*immheader-array-types*
     177  '#(short-float
     178     (unsigned-byte 32)
     179     (signed-byte 32)
     180     fixnum
     181     character
     182     (unsigned-byte 8)
     183     (signed-byte 8)
     184     unused
     185     (unsigned-byte 16)
     186     (signed-byte 16)
     187     double-float
     188     bit))
    174189
    175190
     
    202217              (t
    203218               (%svref x8664::*immheader-0-array-types* idx))))
     219      #+arm-target
     220      (svref arm::*immheader-array-types*
     221             (ash (the fixnum (- subtag arm::min-cl-ivector-subtag)) -3))
    204222      )))
    205223
     
    699717  (%extend-vector 0 src (uvsize src)))
    700718
    701 #+ppc32-target
     719#+(or ppc32-target arm-target)
    702720(defun subtag-bytes (subtag element-count)
    703721  (declare (fixnum subtag element-count))
    704   (unless (= #.ppc32::fulltag-immheader (logand subtag #.ppc32::fulltagmask))
     722  (unless (= #.target::fulltag-immheader (logand subtag #.target::fulltagmask))
    705723    (error "Not an ivector subtag: ~s" subtag))
    706724  (let* ((element-bit-shift
    707           (if (<= subtag ppc32::max-32-bit-ivector-subtag)
     725          (if (<= subtag target::max-32-bit-ivector-subtag)
    708726            5
    709             (if (<= subtag ppc32::max-8-bit-ivector-subtag)
     727            (if (<= subtag target::max-8-bit-ivector-subtag)
    710728              3
    711               (if (<= subtag ppc32::max-16-bit-ivector-subtag)
     729              (if (<= subtag target::max-16-bit-ivector-subtag)
    712730                4
    713                 (if (= subtag ppc32::subtag-double-float-vector)
     731                (if (= subtag target::subtag-double-float-vector)
    714732                  6
    715733                  0)))))
  • trunk/source/level-0/l0-bignum32.lisp

    r13067 r14119  
    690690               (if (and (>= len-a 16)
    691691                        (>= len-b 16)
    692                         #+x8632-target
     692                        #+(or x8632-target arm-target)
    693693                        nil)
    694694                 (let* ((ubytes (* len-a 4))
     
    14341434
    14351435
    1436 ;;; These are used by BIGNUM-TRUNCATE and friends in the general case.
    1437 ;;;
    1438 (defvar *truncate-x* nil)
    1439 (defvar *truncate-y* nil)
    14401436
    14411437;;; BIGNUM-TRUNCATE -- Public.
     
    14771473               (let* ((len-x+1 (1+ len-x)))
    14781474                 (declare (fixnum len-x+1))
    1479                  (with-bignum-buffers ((*truncate-x* len-x+1)
    1480                                        (*truncate-y* (the fixnum (1+ len-y))))
     1475                 (with-bignum-buffers ((truncate-x len-x+1)
     1476                                       (truncate-y (the fixnum (1+ len-y))))
    14811477                   (let ((y-shift (shift-y-for-truncate y)))
    1482                      (shift-and-store-truncate-buffers x len-x y len-y y-shift)
    1483                      (values (do-truncate len-x+1 len-y)
     1478                     (shift-and-store-truncate-buffers truncate-x truncate-y x len-x y len-y y-shift)
     1479                     (values (do-truncate truncate-x truncate-y len-x+1 len-y)
    14841480                             ;; DO-TRUNCATE must execute first.
    14851481                             (when (not no-rem)                               
     
    14871483                                 (let* ((res-len-1 (1- len-y)))
    14881484                                   (declare (fixnum res-len-1))
    1489                                    (bignum-shift-right-loop-1 y-shift *truncate-x* *truncate-x* res-len-1 0)))                               
    1490                                (let ((the-res (%normalize-bignum-macro *truncate-x* )))
     1485                                   (bignum-shift-right-loop-1 y-shift truncate-x truncate-x res-len-1 0)))                               
     1486                               (let ((the-res (%normalize-bignum-macro truncate-x )))
    14911487                                 (if (not (fixnump the-res))
    14921488                                   (if x-plusp (copy-bignum the-res) (negate-bignum the-res))
     
    15231519               (let* ((len-x+1 (1+ len-x)))
    15241520                 (declare (fixnum len-x+1))
    1525                  (with-bignum-buffers ((*truncate-x* len-x+1)
    1526                                        (*truncate-y* (the fixnum (1+ len-y))))
     1521                 (with-bignum-buffers ((truncate-x len-x+1)
     1522                                       (truncate-y (the fixnum (1+ len-y))))
    15271523                   (let ((y-shift (shift-y-for-truncate y)))
    1528                      (shift-and-store-truncate-buffers x len-x y len-y y-shift)
    1529                      (do-truncate-no-quo len-x+1 len-y)
     1524                     (shift-and-store-truncate-buffers truncate-x truncate-y x len-x y len-y y-shift)
     1525                     (do-truncate-no-quo truncate-x truncate-y len-x+1 len-y)
    15301526                     (when (not (eql 0 y-shift))                                 
    15311527                       (let* ((res-len-1 (1- len-y)))
    15321528                         (declare (fixnum res-len-1))
    1533                          (bignum-shift-right-loop-1 y-shift *truncate-x* *truncate-x* res-len-1 0)))
    1534                      (let ((the-res (%normalize-bignum-macro *truncate-x*)))
     1529                         (bignum-shift-right-loop-1 y-shift truncate-x truncate-x res-len-1 0)))
     1530                     (let ((the-res (%normalize-bignum-macro truncate-x)))
    15351531                       (if (not (fixnump the-res))
    15361532                         (if x-plusp (copy-bignum the-res) (negate-bignum the-res))
     
    16691665
    16701666
    1671 (defun do-truncate (len-x len-y)
     1667(defun do-truncate (truncate-x truncate-y len-x len-y)
    16721668  (declare (type bignum-index len-x len-y))
    16731669  (let* ((len-q (- len-x len-y))
     
    16841680      (digit-bind (h l)
    16851681                  (digit-bind (guess-h guess-l)
    1686                               (bignum-truncate-guess-2 *truncate-x* i *truncate-y* (the fixnum (1- len-y)))                                 
    1687                     (try-bignum-truncate-guess guess-h guess-l len-y low-x-digit))
     1682                              (bignum-truncate-guess-2 truncate-x i truncate-y (the fixnum (1- len-y)))                                 
     1683                    (try-bignum-truncate-guess truncate-x truncate-y guess-h guess-l len-y low-x-digit))
    16881684        (%bignum-set q k h l))
    16891685      (cond ((zerop k) (return))
     
    16971693      (%normalize-bignum-macro q))))
    16981694
    1699 (defun do-truncate-no-quo (len-x len-y)
     1695(defun do-truncate-no-quo (truncate-x truncate-y len-x len-y)
    17001696  (declare (type bignum-index len-x len-y))
    17011697  (let* ((len-q (- len-x len-y))
     
    17051701    (declare (type bignum-index len-q k i  low-x-digit))
    17061702    (loop
    1707       (digit-bind (guess-h guess-l) (bignum-truncate-guess-2 *truncate-x* i *truncate-y* (the fixnum (1- len-y)))                                 
    1708         (try-bignum-truncate-guess guess-h guess-l len-y low-x-digit)
     1703      (digit-bind (guess-h guess-l) (bignum-truncate-guess-2 truncate-x i truncate-y (the fixnum (1- len-y)))                                 
     1704        (try-bignum-truncate-guess truncate-x truncate-y guess-h guess-l len-y low-x-digit)
    17091705        (cond ((zerop k) (return))
    17101706              (t (decf k)
     
    17261722;;;
    17271723
    1728 (defun try-bignum-truncate-guess (guess-h guess-l len-y low-x-digit)
     1724(defun try-bignum-truncate-guess (truncate-x truncate-y guess-h guess-l len-y low-x-digit)
    17291725  (declare (type bignum-index low-x-digit len-y))
    17301726
     
    17371733    ;; Multiply guess and divisor, subtracting from dividend simultaneously.
    17381734    (dotimes (j len-y)
    1739       (multiple-value-bind (y-h y-l) (%bignum-ref *truncate-y* j)
     1735      (multiple-value-bind (y-h y-l) (%bignum-ref truncate-y j)
    17401736        (multiple-value-bind (high-h high-l low-h low-l)
    17411737            (%multiply-and-add-1 guess-h
     
    17471743          (setq carry-digit-h high-h
    17481744                carry-digit-l high-l)
    1749           (multiple-value-bind (tx-h tx-l) (%bignum-ref *truncate-x* i)
     1745          (multiple-value-bind (tx-h tx-l) (%bignum-ref truncate-x i)
    17501746            (multiple-value-bind (x-h x-l temp-borrow)
    17511747                (%subtract-with-borrow-1 tx-h tx-l low-h low-l borrow)
    1752               (%bignum-set *truncate-x* i x-h x-l)
     1748              (%bignum-set truncate-x i x-h x-l)
    17531749              (setq borrow temp-borrow)))))
    17541750      (incf i))
    1755     (multiple-value-bind (tx-h tx-l) (%bignum-ref *truncate-x* i)
     1751    (multiple-value-bind (tx-h tx-l) (%bignum-ref truncate-x i)
    17561752      (multiple-value-bind (x-h x-l)
    17571753          (%subtract-with-borrow-1 tx-h tx-l carry-digit-h carry-digit-l borrow)
    1758         (%bignum-set *truncate-x* i x-h x-l)))
     1754        (%bignum-set truncate-x i x-h x-l)))
    17591755    ;; See if guess is off by one, adding one Y back in if necessary.
    17601756
    17611757
    1762     (cond ((%digit-0-or-plusp *truncate-x* i)
     1758    (cond ((%digit-0-or-plusp truncate-x i)
    17631759           (values guess-h guess-l))
    17641760          (t
     
    17661762           ;; in.  The guess was one too large in magnitude.
    17671763           ;; hmm - happens about 1.6% of the time
    1768            (bignum-add-loop-+ low-x-digit *truncate-x* *truncate-y* len-y)
     1764           (bignum-add-loop-+ low-x-digit truncate-x truncate-y len-y)
    17691765           (%subtract-one guess-h guess-l)
    17701766           ;(%subtract-with-borrow guess-h guess-l 0 1 1)
     
    18341830;;; it assumes *truncate-x* and *truncate-y* are one digit longer than x and y.
    18351831;;;
    1836 (defun shift-and-store-truncate-buffers (x len-x y len-y shift)
     1832(defun shift-and-store-truncate-buffers (truncate-x truncate-y x len-x y len-y shift)
    18371833  (declare (type bignum-index len-x len-y)
    18381834           (type (integer 0 (#.digit-size)) shift))
    18391835  (cond ((eql 0 shift)
    1840          (bignum-replace *truncate-x* x :end1 len-x)
    1841          (bignum-replace *truncate-y* y :end1 len-y))
     1836         (bignum-replace truncate-x x :end1 len-x)
     1837         (bignum-replace truncate-y y :end1 len-y))
    18421838        (t
    1843          (bignum-ashift-left-unaligned x 0 shift (the fixnum (1+ len-x)) *truncate-x*)
    1844          (bignum-ashift-left-unaligned y 0 shift (the fixnum (1+ len-y)) *truncate-y*))))
     1839         (bignum-ashift-left-unaligned x 0 shift (the fixnum (1+ len-x)) truncate-x)
     1840         (bignum-ashift-left-unaligned y 0 shift (the fixnum (1+ len-y)) truncate-y))))
    18451841
    18461842
  • trunk/source/level-0/l0-cfm-support.lisp

    r13067 r14119  
    4646  ;; be more likely to be fixnums, for instance), so ensure that they
    4747  ;; aren't.
    48   #+x86-target
     48  #+(or x86-target arm-target)
    4949  (%setf-macptr addr (%int-to-ptr
    5050                      (if (< entry 0)
    5151                        (logand entry (1- (ash 1 target::nbits-in-word)))
    5252                        entry)))
    53   #-(or ppc-target x86-target) (dbg "Fix entry->addr"))
     53  #-(or ppc-target x86-target arm-target) (dbg "Fix entry->addr"))
    5454
    5555
     
    653653      (unless (%null-ptr-p addr)        ; No function can have address 0
    654654        (or (macptr->fixnum addr) (%inc-ptr addr 0))))
    655     #+x8632-target
     655    #+(or x8632-target arm-target)
    656656    (let* ((addr (ff-call (%kernel-import target::kernel-import-FindSymbol)
    657657                          :address handle
  • trunk/source/level-0/l0-float.lisp

    r13769 r14119  
    840840           (%single-float-expt (%short-float b) (%short-float e))
    841841           ))
    842         ((typep (realpart e) 'double-float)
    843          ;; Avoid intermediate single-float result from LOG
    844          (let ((promoted-base (* 1d0 b)))
    845            (exp (* e (log promoted-base)))))
    846842        (t (exp (* e (log b))))))
    847843
  • trunk/source/level-0/l0-hash.lisp

    r13279 r14119  
    9696    (declare (fixnum typecode))
    9797    (or (= typecode target::subtag-macptr)
    98         #+(or ppc32-target x8632-target)
     98        #+(or ppc32-target x8632-target arm-target)
    9999        (and (>= typecode target::min-numeric-subtag)
    100100             (<= typecode target::max-numeric-subtag))
  • trunk/source/level-0/l0-init.lisp

    r13660 r14119  
    6666    #+x8664-target :x8664-target
    6767    #+x8664-target :x8664-host
     68    #+arm-target :arm-target
    6869    #+linux-target :linux-host
    6970    #+linux-target :linux-target
     
    7576    #+linuxx8632-target :linuxx8632-target
    7677    #+linuxx8632-target :linuxx8632-host
     78    #+linuxarm-target :linuxarm-target
     79    #+linuxarm-target :linuxarm-host
    7780    #+darwinppc-target :darwinppc-target
    7881    #+darwinppc-target :darwinppc-host
     
    110113    #+32-bit-target :32-bit-target
    111114    #+32-bit-target :32-bit-host
    112     #+ppc-target :big-endian-target
    113     #+ppc-target :big-endian-host
    114     #+x86-target :little-endian-target
    115     #+x86-target :little-endian-host
    116115    #+darwin-target :darwin
    117116    #+linux-target :linux
     
    119118    #+solaris-target :solaris
    120119    #+windows-target :windows
     120    #+little-endian-target :little-endian-target
     121    #+little-endian-target :little-endian-host
     122    #+big-endian-target :big-endian-target
     123    #+big-endian-target :big-endian-host
    121124    )
    122125  "a list of symbols that describe features provided by the
  • trunk/source/level-0/l0-misc.lisp

    r13279 r14119  
    2020
    2121;;; Bootstrapping for futexes
    22 #+(and linux-target x86-target)
     22#+(and linux-target (or x86-target arm-target))
    2323(eval-when (:compile-toplevel :execute)
    2424  (pushnew :futex *features*))
     
    219219
    220220
    221 ;;; Returns six values.
     221;;; Returns six values on most platforms, 4 on ARM.
    222222;;;   sp free
    223223;;;   sp used
    224224;;;   vsp free
    225225;;;   vsp used
    226 ;;;   tsp free
    227 ;;;   tsp used
     226;;;   tsp free  (not on ARM)
     227;;;   tsp used  (not on ARM)
    228228(defun %thread-stack-space (&optional (thread *current-lisp-thread*))
    229229  (when (eq thread *current-lisp-thread*)
     
    272272        (multiple-value-bind (cf cu) (free-and-used (%fixnum-ref tcr target::tcr.cs-area))
    273273          (multiple-value-bind (vf vu) (free-and-used (%fixnum-ref tcr target::tcr.vs-area))
     274            #+arm-target
     275            (values cf cu vf vu)
     276            #-arm-target
    274277            (multiple-value-bind (tf tu) (free-and-used (%fixnum-ref tcr target::tcr.ts-area ))
    275278              (values cf cu vf vu tf tu))))))))
     
    344347          (let* ((processes (all-processes)))
    345348            (dolist (thread-info stack-used-by-thread)
    346               (destructuring-bind (thread sp-free sp-used vsp-free vsp-used tsp-free tsp-used)
     349              (destructuring-bind (thread sp-free sp-used vsp-free vsp-used #-arm-target tsp-free #-arm-target tsp-used)
    347350                  thread-info
    348351                (let* ((process (dolist (p processes)
     
    352355                    (let ((sp-total (+ sp-used sp-free))
    353356                          (vsp-total (+ vsp-used vsp-free))
     357                          #-arm-target
    354358                          (tsp-total (+ tsp-used tsp-free)))
    355359                      (format t "~%~a(~d)~%  cstack:~12T~10D (~DK)  ~33T~10D (~DK)  ~54T~10D (~DK)~
    356                                ~%  vstack:~12T~10D (~DK)  ~33T~10D (~DK)  ~54T~10D (~DK)~
    357                                ~%  tstack:~12T~10D (~DK)  ~33T~10D (~DK)  ~54T~10D (~DK)"
     360                               ~%  vstack:~12T~10D (~DK)  ~33T~10D (~DK)  ~54T~10D (~DK)"
    358361                              (process-name process)
    359362                              (process-serial-number process)
    360363                              sp-total (k sp-total) sp-free (k sp-free) sp-used (k sp-used)
    361                               vsp-total (k vsp-total) vsp-free (k vsp-free) vsp-used (k vsp-used)
     364                              vsp-total (k vsp-total) vsp-free (k vsp-free) vsp-used  (k vsp-used))
     365                      #-arm-target
     366                      (format t
     367                               "~%  tstack:~12T~10D (~DK)  ~33T~10D (~DK)  ~54T~10D (~DK)"
     368
    362369                              tsp-total (k tsp-total) tsp-free (k tsp-free) tsp-used (k tsp-used)))))))))))))
    363370
     
    11361143
    11371144
    1138 ;;; Useless for anything but using RLET in early level-1 code without
    1139 ;;; having to bootstrap canonical type ordinals.
    1140 (%fhave 'parse-foreign-type (lambda (spec) (declare (ignore spec))))
    1141 (%fhave 'foreign-type-ordinal (lambda (thing) (declare (ignore thing)) 0))
    1142 (%fhave '%foreign-type-or-record (lambda (x) (declare (ignore x))))
  • trunk/source/level-0/l0-numbers.lisp

    r13583 r14119  
    18021802;;; too bad in a 64-bit CCL, but the generator pretty much has to be
    18031803;;; in LAP for 32-bit ports.
    1804 #-(or x8632-target ppc32-target x8664-target ppc64-target)
     1804#-(or x8632-target ppc32-target x8664-target ppc64-target arm-target)
    18051805(defun %mrg31k3p (state)
    18061806  (let* ((v (random.mrg31k3p-state state)))
  • trunk/source/level-0/l0-pred.lisp

    r13067 r14119  
    9090      (let* ((typecode (typecode x)))
    9191        (declare (fixnum typecode))
    92         #+(or ppc32-target x8632-target)
     92        #+(or ppc32-target x8632-target arm-target)
    9393        (and (>= typecode target::min-numeric-subtag)
    9494             (<= typecode target::max-rational-subtag))
     
    115115  (let* ((typecode (typecode x)))
    116116    (declare (fixnum typecode))
    117     #+(or ppc32-target x8632-target)
    118     (or (= typecode target::tag-fixnum)
    119         (and (>= typecode target::min-numeric-subtag)
    120              (<= typecode target::max-real-subtag)))
    121     #+ppc64-target
    122     (if (<= typecode ppc64::subtag-double-float)
    123       (logbitp (the (integer 0 #.ppc64::subtag-double-float) typecode)
    124                (logior (ash 1 ppc64::tag-fixnum)
    125                        (ash 1 ppc64::subtag-single-float)
    126                        (ash 1 ppc64::subtag-double-float)
    127                        (ash 1 ppc64::subtag-bignum)
    128                        (ash 1 ppc64::subtag-ratio))))
    129     #+x8664-target
    130     (if (<= typecode x8664::subtag-double-float)
    131       (logbitp (the (integer 0 #.x8664::subtag-double-float) typecode)
    132                (logior (ash 1 x8664::tag-fixnum)
    133                        (ash 1 x8664::subtag-bignum)
    134                        (ash 1 x8664::tag-single-float)
    135                        (ash 1 x8664::subtag-double-float)
    136                        (ash 1 x8664::subtag-ratio))))))
     117    (and (<= typecode target::max-real-subtag)
     118         (logbitp (the (integer 0 #.target::max-real-subtag)
     119                    typecode)
     120                  (logior (ash 1 target::tag-fixnum)
     121                          (ash 1 target::subtag-single-float)
     122                          (ash 1 target::subtag-double-float)
     123                          (ash 1 target::subtag-bignum)
     124                          (ash 1 target::subtag-ratio))))))
     125
    137126
    138127(defun complexp (x)
     
    144133  (let* ((typecode (typecode x)))
    145134    (declare (fixnum typecode))
    146     #+(or ppc32-target x8632-target)
    147     (or (= typecode target::tag-fixnum)
    148         (and (>= typecode target::min-numeric-subtag)
    149              (<= typecode target::max-numeric-subtag)))
    150     #+ppc64-target
    151     (if (<= typecode ppc64::subtag-double-float)
    152       (logbitp (the (integer 0 #.ppc64::subtag-double-float) typecode)
    153                (logior (ash 1 ppc64::tag-fixnum)
    154                        (ash 1 ppc64::subtag-bignum)
    155                        (ash 1 ppc64::subtag-single-float)
    156                        (ash 1 ppc64::subtag-double-float)
    157                        (ash 1 ppc64::subtag-ratio)
    158                        (ash 1 ppc64::subtag-complex))))
    159     #+x8664-target
    160     (if (< typecode x8664::nbits-in-word)
    161       (logbitp (the (integer 0 #.x8664::subtag-double-float) typecode)
    162                (logior (ash 1 x8664::tag-fixnum)
    163                        (ash 1 x8664::subtag-bignum)
    164                        (ash 1 x8664::tag-single-float)
    165                        (ash 1 x8664::subtag-double-float)
    166                        (ash 1 x8664::subtag-ratio)
    167                        (ash 1 x8664::subtag-complex))))
    168    
    169     ))
     135    (and (<= typecode target::max-numeric-subtag)
     136         (logbitp (the (integer 0 #.target::max-numeric-subtag)
     137                    typecode)
     138                  (logior (ash 1 target::tag-fixnum)
     139                          (ash 1 target::subtag-bignum)
     140                          (ash 1 target::subtag-single-float)
     141                          (ash 1 target::subtag-double-float)
     142                          (ash 1 target::subtag-ratio)
     143                          (ash 1 target::subtag-complex))))))
    170144
    171145(defun arrayp (x)
     
    223197;;; things that it wasn't true of on the 68K.
    224198(defun gvectorp (x)
    225   #+(or ppc32-target x8632-target)
     199  #+(or ppc32-target x8632-target arm-target)
    226200  (= (the fixnum (logand (the fixnum (typecode x)) target::fulltagmask)) target::fulltag-nodeheader)
    227201  #+ppc64-target
     
    238212
    239213(defun ivectorp (x)
    240   #+(or ppc32-target x8632-target)
     214  #+(or ppc32-target x8632-target arm-target)
    241215  (= (the fixnum (logand (the fixnum (typecode x)) target::fulltagmask))
    242216     target::fulltag-immheader)
     
    254228
    255229(defun miscobjp (x)
    256   #+(or ppc32-target x8632-target x8664-target)
     230  #+(or ppc32-target x8632-target x8664-target arm-target)
    257231  (= (the fixnum (lisptag x)) target::tag-misc)
    258232  #+ppc64-target
     
    398372                                   (return))))))))))))))
    399373
    400 #+ppc32-target
     374#+(or ppc32-target arm-target)
    401375(progn
    402376(defparameter *nodeheader-types*
     
    475449  (let* ((typecode (typecode thing)))
    476450    (declare (fixnum typecode))
    477     (if (= typecode ppc32::tag-fixnum)
     451    (if (= typecode target::tag-fixnum)
    478452      'fixnum
    479       (if (= typecode ppc32::tag-list)
     453      (if (= typecode target::tag-list)
    480454        (if thing 'cons 'null)
    481         (if (= typecode ppc32::tag-imm)
     455        (if (= typecode target::tag-imm)
    482456          (if (base-char-p thing)
    483457            'base-char
    484458            'immediate)
    485           (if (= typecode ppc32::subtag-macptr)
     459          (if (= typecode target::subtag-macptr)
    486460            (if (classp thing)
    487461              (class-name thing)
    488462              'macptr)
    489             (let* ((tag-type (logand typecode ppc32::full-tag-mask))
    490                    (tag-val (ash typecode (- ppc32::ntagbits))))
     463            (let* ((tag-type (logand typecode target::full-tag-mask))
     464                   (tag-val (ash typecode (- target::ntagbits))))
    491465              (declare (fixnum tag-type tag-val))
    492               (if (/= tag-type ppc32::fulltag-nodeheader)
     466              (if (/= tag-type target::fulltag-nodeheader)
    493467                (%svref *immheader-types* tag-val)
    494468                (let ((type (%svref *nodeheader-types* tag-val)))
     
    512486                          'compiled-function)))
    513487                    (if (eq type 'lock)
    514                       (or (uvref thing ppc32::lock.kind-cell)
     488                      (or (uvref thing target::lock.kind-cell)
    515489                          type)
    516490                      type)))))))))))
    517491
    518 );#+ppc32-target
     492);#+(or ppc32-target arm-target)
    519493
    520494#+ppc64-target
     
    1014988(defun structure-typep (thing type)
    1015989  (if (= (the fixnum (typecode thing)) target::subtag-struct)
    1016     (let* ((types (%svref thing 0)))
    1017       (if (typep type 'symbol)
    1018         (dolist (x types)
    1019           (when (eq (class-cell-name x) type)
    1020             (return t)))
    1021         (dolist (x types)
    1022           (when (eq x type)
    1023             (return t)))))))
     990    (dolist (x (%svref thing 0))
     991      (when (eq x type)
     992        (return t)))))
    1024993
    1025994
     
    10531022(defun symbolp (thing)
    10541023  "Return true if OBJECT is a SYMBOL, and NIL otherwise."
    1055   #+(or ppc32-target x8632-target)
     1024  #+(or ppc32-target x8632-target arm-target)
    10561025  (if thing
    10571026    (= (the fixnum (typecode thing)) target::subtag-symbol)
  • trunk/source/level-0/l0-symbol.lisp

    r13279 r14119  
    206206(defun symbol-name (sym)
    207207  "Return SYMBOL's name as a string."
    208   #+(or ppc32-target x8632-target x8664-target)
     208  #+(or ppc32-target x8632-target x8664-target arm-target)
    209209  (%svref (symptr->symvector (%symbol->symptr sym)) target::symbol.pname-cell)
    210210  #+ppc64-target
  • trunk/source/level-1/l1-aprims.lisp

    r13327 r14119  
    697697               (%svref *immheader-2-array-element-types* class))
    698698              (t 'bogus)))))
     699  )
     700
     701#+arm-target
     702(progn
     703  (defparameter array-element-subtypes
     704    #(single-float
     705      (unsigned-byte 32)
     706      (signed-byte 32)
     707      fixnum
     708      base-char                         ;ucs4
     709      (unsigned-byte 8)
     710      (signed-byte 8)
     711      base-char
     712      (unsigned-byte 16)
     713      (signed-byte 16)
     714      double-float
     715      bit))
     716 
     717  ;; given uvector subtype - what is the corresponding element-type
     718  (defun element-subtype-type (subtype)
     719    (declare (fixnum subtype))
     720    (if  (= subtype arm::subtag-simple-vector) t
     721        (svref array-element-subtypes
     722               (ash (- subtype arm::min-cl-ivector-subtag) (- arm::ntagbits)))))
    699723  )
    700724
  • trunk/source/level-1/l1-boot-1.lisp

    r13067 r14119  
    4747  `((,platform-cpu-ppc . :ppc)
    4848    (,platform-cpu-sparc . :sparc)
    49     (,platform-cpu-x86 . :x86)))
     49    (,platform-cpu-x86 . :x86)
     50    (,platform-cpu-arm . :arm)))
    5051
    5152(defun host-platform ()
  • trunk/source/level-1/l1-boot-2.lisp

    r13563 r14119  
    4848    #+x86-target
    4949    (l1-load "x86-error-signal")
     50    #+arm-target
     51    (l1-load "arm-error-signal")
    5052    (l1-load "l1-error-signal")
    5153    (l1-load "l1-sockets")
     
    230232      #+x86-target
    231233      (bin-load-provide "X8664-ARCH" "x8664-arch")
     234      #+arm-target
     235      (bin-load-provide "ARM-ARCH" "arm-arch")
    232236      (bin-load-provide "VREG" "vreg")
    233237     
    234238      #+ppc-target
    235239      (bin-load-provide "PPC-ASM" "ppc-asm")
     240      #+arm-target
     241      (bin-load-provide "ARM-ASM" "arm-asm")
    236242     
    237243      (bin-load-provide "VINSN" "vinsn")
     
    240246      #+ppc-target
    241247      (bin-load-provide "PPC-LAP" "ppc-lap")
     248      #+arm-target
     249      (bin-load-provide "ARM-LAP" "arm-lap")
    242250      (bin-load-provide "BACKEND" "backend")
    243251      (bin-load-provide "NX2" "nx2")
     
    248256      #+x86-target
    249257      (provide "X862")
     258
     259      #+arm-target
     260      (provide "ARM2")
    250261     
    251262      (l1-load-provide "NX" "nx")
     
    256267      #+x86-target
    257268      (bin-load "x862")
     269
     270      #+arm-target
     271      (bin-load "arm2")
    258272     
    259273      (bin-load-provide "LEVEL-2" "level-2")
     
    286300        (bin-load "x86-watch"))
    287301
     302      #+arm-target
     303      (progn
     304        (bin-load-provide "ARM-DISASSEMBLE" "arm-disassemble")
     305        (bin-load-provide "ARM-LAPMACROS" "arm-lapmacros"))
    288306
    289307      (bin-load-provide "FOREIGN-TYPES" "foreign-types")
     
    318336      #+freebsdx8632-target
    319337      (bin-load-provide "FFI-FREEBSDX8632" "ffi-freebsdx8632")
     338      #+(and arm-target linux-target)
     339      (bin-load-provide "FFI-LINUXARM" "ffi-linuxarm")
    320340
    321341
  • trunk/source/level-1/l1-clos-boot.lisp

    r13980 r14119  
    14521452                      (setf (%wrapper-cpl wrapper) cpl
    14531453                            (%class.own-wrapper class) wrapper
    1454                             (%wrapper-cpl-bits wrapper) #*1)
     1454                            (%wrapper-cpl-bits wrapper)
     1455                            (let* ((bv (make-array 1 :element-type 'bit)))
     1456                                     (setf (aref bv 0) 1)
     1457                                     bv))
    14551458                      (setf (%class.ctype class) (make-class-ctype class))
    14561459                      (setf (find-class 't) class)
     
    20932096              (find-class 'unsigned-doubleword-vector)
    20942097              (find-class 'double-float-vector))))
     2098
     2099  #+arm-target
     2100  (defparameter *ivector-vector-classes*
     2101    (vector (find-class 'short-float-vector)
     2102            (find-class 'unsigned-long-vector)
     2103            (find-class 'long-vector)
     2104            (find-class 'fixnum-vector)
     2105            (find-class 'base-string)
     2106            (find-class 'unsigned-byte-vector)
     2107            (find-class 'byte-vector)
     2108            *t-class*                   ; old base-string
     2109            (find-class 'unsigned-word-vector)
     2110            (find-class 'word-vector)
     2111            (find-class 'double-float-vector)
     2112            (find-class 'bit-vector)))
     2113
    20952114
    20962115
     
    23062325                (%svref v (+ slice x8664::fulltag-tra-1)) *tagged-return-address-class*
    23072326                (%svref v (+ slice x8664::fulltag-nil)) *null-class*))
     2327        #+arm-target
     2328        (do* ((slice 0 (+ 8 slice)))
     2329             ((= slice 256))
     2330          (declare (type (unsigned-byte 8) slice))
     2331          (setf (%svref v (+ slice arm::fulltag-even-fixnum)) *fixnum-class*
     2332                (%svref v (+ slice arm::fulltag-odd-fixnum))  *fixnum-class*
     2333                (%svref v (+ slice arm::fulltag-cons)) *cons-class*
     2334                (%svref v (+ slice arm::fulltag-nil)) *null-class*
     2335                (%svref v (+ slice arm::fulltag-imm)) *immediate-class*))
     2336
    23082337        (macrolet ((map-subtag (subtag class-name)
    23092338                     `(setf (%svref v ,subtag) (find-class ',class-name))))
     
    23132342          (map-subtag target::subtag-single-float short-float)
    23142343          (map-subtag target::subtag-dead-macptr ivector)
    2315           #-x86-target
    2316           (map-subtag target::subtag-code-vector code-vector)
     2344          #+ppc32-target
     2345          (map-subtag ppc32::subtag-code-vector code-vector)
     2346          #+ppc64-target
     2347          (map-subtag ppc64::subtag-code-vector code-vector)
     2348          #+arm-target
     2349          (map-subtag arm::subtag-code-vector code-vector)
    23172350          #+ppc32-target
    23182351          (map-subtag ppc32::subtag-creole-object creole-object)
     
    23782411              #'%class-of-instance)
    23792412        (setf (%svref v #+ppc-target target::subtag-symbol
     2413                      #+arm-target target::subtag-symbol
    23802414                      #+x8632-target target::subtag-symbol
    23812415                      #+x8664-target target::tag-symbol)
     
    23942428        (setf (%svref v
    23952429                      #+ppc-target target::subtag-function
     2430                      #+arm-target target::subtag-function
    23962431                      #+x8632-target target::subtag-function
    23972432                      #+x8664-target target::tag-function)
     
    24082443                              (ash (the fixnum (- subtype ppc32::min-cl-ivector-subtag))
    24092444                                   (- ppc32::ntagbits))
     2445                              #+arm-target
     2446                              (ash (the fixnum (- subtype arm::min-cl-ivector-subtag))
     2447                                   (- arm::ntagbits))
    24102448                              #+ppc64-target
    24112449                              (ash (the fixnum (logand subtype #x7f)) (- ppc64::nlowtagbits))
     
    25762614   'slot-id-value
    25772615   nil                          ;method-function name
    2578    (dpb 1 $lfbits-numreq (ash 1 $lfbits-method-bit))))
     2616   (dpb 1 $lfbits-numreq (ash 1 $lfbits-method-bit)))
     2617  #+arm-target
     2618  (gvector :function
     2619           arm::*function-initial-entrypoint*
     2620           (uvref *reader-method-function-proto* 1)
     2621           (ensure-slot-id (%slot-definition-name dslotd))
     2622           'slot-id-value
     2623           nil                          ;method-function name
     2624           (dpb 1 $lfbits-numreq (ash 1 $lfbits-method-bit))))
    25792625
    25802626(defmethod create-writer-method-function ((class slots-class)
     
    25952641     nil
    25962642     (dpb 2 $lfbits-numreq (ash 1 $lfbits-method-bit)))
     2643    #+arm-target
     2644    (gvector :function
     2645             arm::*function-initial-entrypoint*
     2646             (uvref *writer-method-function-proto* 1)
     2647             (ensure-slot-id (%slot-definition-name dslotd))
     2648             'set-slot-id-value
     2649             nil
     2650             (dpb 2 $lfbits-numreq (ash 1 $lfbits-method-bit)))
    25972651  )
    25982652
  • trunk/source/level-1/l1-clos.lisp

    r13067 r14119  
    375375                                (dpb 1 $lfbits-numreq
    376376                                     (ash -1 $lfbits-noname-bit)))
     377              #+arm-target
     378              (gvector :function
     379                       arm::*function-initial-entrypoint*
     380                       (%svref (if small
     381                                 #'%small-map-slot-id-lookup
     382                                 #'%large-map-slot-id-lookup) 1)
     383                       map
     384                       table
     385                       (dpb 1 $lfbits-numreq
     386                            (ash -1 $lfbits-noname-bit)))
    377387              #+x86-target
    378388              (%clone-x86-function (if small
     
    390400                                 #'%small-slot-id-value
    391401                                 #'%large-slot-id-value) 0)
     402                       map
     403                       table
     404                       class
     405                       #'%maybe-std-slot-value-using-class
     406                       #'%slot-id-ref-missing
     407                       (dpb 2 $lfbits-numreq
     408                            (ash -1 $lfbits-noname-bit)))
     409              #+arm-target
     410              (gvector :function
     411                       arm::*function-initial-entrypoint*
     412                       (%svref (if small
     413                                 #'%small-slot-id-value
     414                                 #'%large-slot-id-value) 1)
    392415                       map
    393416                       table
     
    414437                                 #'%small-set-slot-id-value
    415438                                 #'%large-set-slot-id-value) 0)
     439                       map
     440                       table
     441                       class
     442                       #'%maybe-std-setf-slot-value-using-class
     443                       #'%slot-id-set-missing
     444                       (dpb 3 $lfbits-numreq
     445                            (ash -1 $lfbits-noname-bit)))
     446              #+arm-target
     447              (gvector :function
     448                       arm::*function-initial-entrypoint*
     449                       (%svref (if small
     450                                 #'%small-set-slot-id-value
     451                                 #'%large-set-slot-id-value) 1)
    416452                       map
    417453                       table
     
    16421678                                0
    16431679                                (logior (ash 1 $lfbits-gfn-bit)
    1644                                         (ash 1 $lfbits-aok-bit)))))
    1645     (setf
    1646           (slot-vector.instance slots) fn)
     1680                                        (ash 1 $lfbits-aok-bit)))
     1681           #+arm-target
     1682           (gvector :function
     1683                    arm::*function-initial-entrypoint*
     1684                    *unset-fin-code*
     1685                    wrapper
     1686                    slots
     1687                    dt
     1688                    #'false
     1689                    0
     1690                    (logior (ash 1 $lfbits-gfn-bit)
     1691                            (ash 1 $lfbits-aok-bit)))))
     1692    (setf (slot-vector.instance slots) fn)
    16471693    (when dt
    16481694      (setf (%gf-dispatch-table-gf dt) fn))
  • trunk/source/level-1/l1-dcode.lisp

    r13980 r14119  
    401401#+ppc-target
    402402(defvar *fi-trampoline-code* (uvref #'funcallable-trampoline 0))
     403#+arm-target
     404(defvar *fi-trampoline-code* (uvref #'funcallable-trampoline 1))
    403405
    404406
    405407#+ppc-target
    406408(defvar *unset-fin-code* (uvref #'unset-fin-trampoline 0))
    407 
     409#+arm-target
     410(defvar *unset-fin-code* (uvref #'unset-fin-trampoline 1))
    408411
    409412
    410413#+ppc-target
    411414(defvar *gf-proto-code* (uvref *gf-proto* 0))
     415#+arm-target
     416(defvar *gf-proto-code* (uvref *gf-proto* 1))
    412417
    413418;;; The "early" version of %ALLOCATE-GF-INSTANCE.
     
    421426                 (dt (make-gf-dispatch-table))
    422427                 (slots (allocate-typed-vector :slot-vector (1+ len) (%slot-unbound-marker)))
    423                  (fn #+ppc-target
     428                 (fn #+(or ppc-target arm-target)
    424429                   (gvector :function
     430                            #+arm-target arm::*function-initial-entrypoint*
    425431                              *gf-proto-code*
    426432                              wrapper
     
    463469(defvar *cm-proto-code* (uvref *cm-proto* 0))
    464470
     471#+arm-target
     472(defvar *cm-proto-code* (uvref *cm-proto* 1))
     473
    465474(defun %cons-combined-method (gf thing dcode)
    466475  ;; set bits and name = gf
    467   #+ppc-target
     476  #+(or ppc-target arm-target)
    468477  (gvector :function
     478           #+arm-target arm::*function-initial-entrypoint*
    469479           *cm-proto-code*
    470480           thing
  • trunk/source/level-1/l1-error-signal.lisp

    r13067 r14119  
    103103                                    :expected-type (array-element-type array)
    104104                                    :array array)))
    105                                   
     105                 (division-by-zero (make-condition condition-name))
    106106                 (t (make-condition condition-name
    107107                                    :format-control format-string
  • trunk/source/level-1/l1-io.lisp

    r13647 r14119  
    15971597(defun %macptr-allocation-string (macptr)
    15981598  (if (or (on-any-csp-stack macptr)
     1599          #-arm-target
    15991600          (on-any-tsp-stack macptr))
    16001601    "[stack-allocated]"
  • trunk/source/level-1/l1-lisp-threads.lisp

    r13745 r14119  
    196196  (let* ((cs-area (%fixnum-ref tcr target::tcr.cs-area))
    197197         (vs-area (%fixnum-ref tcr target::tcr.vs-area))
     198         #-arm-target
    198199         (ts-area (%fixnum-ref tcr target::tcr.ts-area)))
    199200    (when (or (zerop cs-area)
    200201              (zerop vs-area)
     202              #-arm-target
    201203              (zerop ts-area))
    202204      (error "Can't allocate new thread"))
     
    207209          (%stack-area-usable-size vs-area)
    208210          (lisp-thread.ts-size thread)
     211          #+arm-target 0
     212          #-arm-target
    209213          (%stack-area-usable-size ts-area)
    210214          (lisp-thread.startup-function thread)
     
    559563                     (if xcf
    560564                       (%%frame-backlink xcf)))
     565                   (%current-frame-ptr))
     566  #+arm-target (or (current-fake-stack-frame)
    561567                   (%current-frame-ptr)))
    562568
     
    676682  (%ptr-in-area-p idx (%fixnum-ref tcr target::tcr.vs-area)))
    677683
     684#-arm-target
    678685(defun %on-tsp-stack (tcr object)
    679686  (%ptr-in-area-p object (%fixnum-ref tcr target::tcr.ts-area)))
     
    699706      (return t))))
    700707
    701 
     708#-arm-target
    702709(defun on-any-tsp-stack (object)
    703710  (or (%on-tsp-stack (%current-tcr) object)
     
    716723  (and (consp x)
    717724       (not (null (or (on-any-vstack x)
    718                       (on-any-tsp-stack x))))))
     725                      #-arm-target
     726                      (on-any-tsp-stack x)
     727                      #+arm-target
     728                      (on-any-csp-stack x))))))
    719729
    720730
  • trunk/source/level-1/l1-numbers.lisp

    r13373 r14119  
    513513  (declare (double-float b e result))
    514514  (with-stack-double-floats ((temp))
     515    #+arm-target (%set-fpscr-status 0)
    515516    (%setf-double-float temp (#_pow b e))
    516517    (%df-check-exception-2 'expt b e (%ffi-exception-status))
     
    521522  (declare (single-float b e result))
    522523  (target::with-stack-short-floats ((temp))
     524    #+arm-target (%set-fpscr-status 0)
    523525    (%setf-short-float temp (#_powf b e))
    524526    (%sf-check-exception-2 'expt b e (%ffi-exception-status))
     
    543545  (declare (double-float n result))
    544546  (with-stack-double-floats ((temp))
     547    #+arm-target (%set-fpscr-status 0)
    545548    (%setf-double-float TEMP (#_sin n))
    546549    (%df-check-exception-1 'sin n (%ffi-exception-status))
     
    551554  (declare (single-float n result))
    552555  (target::with-stack-short-floats ((temp))
     556    #+arm-target (%set-fpscr-status 0)
    553557    (%setf-short-float TEMP (#_sinf n))
    554558    (%sf-check-exception-1 'sin n (%ffi-exception-status))
     
    565569  (declare (double-float n result))
    566570  (with-stack-double-floats ((temp))
     571    #+arm-target (%set-fpscr-status 0)
    567572    (%setf-double-float TEMP (#_cos n))
    568573    (%df-check-exception-1 'cos n (%ffi-exception-status))
     
    573578  (declare (single-float n result))
    574579  (target::with-stack-short-floats ((temp))
     580    #+arm-target (%set-fpscr-status 0)
    575581    (%setf-short-float TEMP (#_cosf n))
    576582    (%sf-check-exception-1 'cos n (%ffi-exception-status))
     
    587593  (declare (double-float n result))
    588594  (with-stack-double-floats ((temp))
     595    #+arm-target (%set-fpscr-status 0)
    589596    (%setf-double-float TEMP (#_acos n))
    590597    (%df-check-exception-1 'acos n (%ffi-exception-status))
     
    595602  (declare (single-float n result))
    596603  (target::with-stack-short-floats ((temp))
     604    #+arm-target (%set-fpscr-status 0)
    597605    (%setf-short-float TEMP (#_acosf n))
    598606    (%sf-check-exception-1 'acos n (%ffi-exception-status))
     
    609617  (declare (double-float n result))
    610618  (with-stack-double-floats ((temp))
     619    #+arm-target (%set-fpscr-status 0)
    611620    (%setf-double-float TEMP (#_asin n))
    612621    (%df-check-exception-1 'asin n (%ffi-exception-status))
     
    617626  (declare (single-float n result))
    618627  (target::with-stack-short-floats ((temp))
     628    #+arm-target (%set-fpscr-status 0)
    619629    (%setf-short-float TEMP (#_asinf n))
    620630    (%sf-check-exception-1 'asin n (%ffi-exception-status))
     
    631641  (declare (double-float n result))
    632642  (with-stack-double-floats ((temp))
     643    #+arm-target (%set-fpscr-status 0)
    633644    (%setf-double-float TEMP (#_cosh n))
    634645    (%df-check-exception-1 'cosh n (%ffi-exception-status))
     
    639650  (declare (single-float n result))
    640651  (target::with-stack-short-floats ((temp))
     652    #+arm-target (%set-fpscr-status 0)
    641653    (%setf-short-float TEMP (external-call "coshf" :single-float n :single-float))
    642654    (%sf-check-exception-1 'cosh n (%ffi-exception-status))
     
    653665  (declare (double-float n result))
    654666  (with-stack-double-floats ((temp))
     667    #+arm-target (%set-fpscr-status 0)
    655668    (%setf-double-float TEMP (#_log n))
    656669    (%df-check-exception-1 'log n (%ffi-exception-status))
     
    661674  (declare (single-float n result))
    662675  (target::with-stack-short-floats ((temp))
     676    #+arm-target (%set-fpscr-status 0)
    663677    (%setf-short-float TEMP (#_logf n))
    664678    (%sf-check-exception-1 'log n (%ffi-exception-status))
     
    674688  (declare (double-float n result))
    675689  (with-stack-double-floats ((temp))
     690    #+arm-target (%set-fpscr-status 0)
    676691    (%setf-double-float TEMP (#_tan n))
    677692    (%df-check-exception-1 'tan n (%ffi-exception-status))
     
    682697  (declare (single-float n result))
    683698  (target::with-stack-short-floats ((temp))
     699    #+arm-target (%set-fpscr-status 0)
    684700    (%setf-short-float TEMP (#_tanf n))
    685701    (%sf-check-exception-1 'tan n (%ffi-exception-status))
     
    696712  (declare (double-float n result))
    697713  (with-stack-double-floats ((temp))
     714    #+arm-target (%set-fpscr-status 0)
    698715    (%setf-double-float TEMP (#_atan n))
    699716    (%df-check-exception-1 'atan n (%ffi-exception-status))
     
    705722  (declare (single-float n result))
    706723  (target::with-stack-short-floats ((temp))
     724    #+arm-target (%set-fpscr-status 0)
    707725    (%setf-short-float TEMP (#_atanf n))
    708726    (%sf-check-exception-1 'atan n (%ffi-exception-status))
     
    719737  (declare (double-float x y result))
    720738  (with-stack-double-floats ((temp))
     739    #+arm-target (%set-fpscr-status 0)
    721740    (%setf-double-float TEMP (#_atan2 x y))
    722741    (%df-check-exception-2 'atan2 x y (%ffi-exception-status))
     
    727746  (declare (single-float x y result))
    728747  (target::with-stack-short-floats ((temp))
     748    #+arm-target (%set-fpscr-status 0)
    729749    (%setf-short-float TEMP (#_atan2f x y))
    730750    (%sf-check-exception-2 'atan2 x y (%ffi-exception-status))
     
    741761  (declare (double-float n result))
    742762  (with-stack-double-floats ((temp))
     763    #+arm-target (%set-fpscr-status 0)
    743764    (%setf-double-float TEMP (#_exp n))
    744765    (%df-check-exception-1 'exp n (%ffi-exception-status))
     
    749770  (declare (single-float n result))
    750771  (target::with-stack-short-floats ((temp))
     772    #+arm-target (%set-fpscr-status 0)
    751773    (%setf-short-float TEMP (#_expf n))
    752774    (%sf-check-exception-1 'exp n (%ffi-exception-status))
     
    771793  (declare (double-float n result))
    772794  (with-stack-double-floats ((temp))
     795    #+arm-target (%set-fpscr-status 0)
    773796    (%setf-double-float TEMP (#_sinh n))
    774797    (%df-check-exception-1 'sinh n (%ffi-exception-status))
     
    779802  (declare (single-float n result))
    780803  (target::with-stack-short-floats ((temp))
     804    #+arm-target (%set-fpscr-status 0)
    781805    (%setf-short-float TEMP (external-call "sinhf" :single-float n :single-float))
    782806    (%sf-check-exception-1 'sinh n (%ffi-exception-status))
     
    793817  (declare (double-float n result))
    794818  (with-stack-double-floats ((temp))
     819    #+arm-target (%set-fpscr-status 0)
    795820    (%setf-double-float TEMP (#_tanh n))
    796821    (%df-check-exception-1 'tanh n (%ffi-exception-status))
     
    801826  (declare (single-float n result))
    802827  (target::with-stack-short-floats ((temp))
     828    #+arm-target (%set-fpscr-status 0)
    803829    (%setf-short-float TEMP (external-call "tanhf" :single-float n :single-float))
    804830    (%sf-check-exception-1 'tanh n (%ffi-exception-status))
     
    825851  (declare (single-float n result))
    826852  (target::with-stack-short-floats ((temp))
     853    #+arm-target (%set-fpscr-status 0)
    827854    (%setf-short-float TEMP (external-call "asinhf" :float n :float))
    828855    (%sf-check-exception-1 'asinh n (%ffi-exception-status))
     
    841868  (declare (double-float n result))
    842869  (with-stack-double-floats ((temp))
     870    #+arm-target (%set-fpscr-status 0)
    843871    (%setf-double-float TEMP (#_asinh n))
    844872    (%df-check-exception-1 'asinh n (%ffi-exception-status))
     
    850878  (declare (single-float n result))
    851879  (target::with-stack-short-floats ((temp))
     880    #+arm-target (%set-fpscr-status 0)
    852881    (%setf-short-float TEMP (#_asinhf n))
    853882    (%sf-check-exception-1 'asinh n (%ffi-exception-status))
     
    875904  (declare (single-float n result))
    876905  (target::with-stack-short-floats ((temp))
     906    #+arm-target (%set-fpscr-status 0)
    877907    (%setf-short-float TEMP (external-call "acoshf" :float n :float))
    878908    (%sf-check-exception-1 'acosh n (%ffi-exception-status))
     
    893923  (declare (double-float n result))
    894924  (with-stack-double-floats ((temp))
     925    #+arm-target (%set-fpscr-status 0)
    895926    (%setf-double-float TEMP (#_acosh n))
    896927    (%df-check-exception-1 'acosh n (%ffi-exception-status))
     
    901932  (declare (single-float n result))
    902933  (target::with-stack-short-floats ((temp))
     934    #+arm-target (%set-fpscr-status 0)
    903935    (%setf-short-float TEMP (#_acoshf n))
    904936    (%sf-check-exception-1 'acosh n (%ffi-exception-status))
     
    926958  (declare (single-float n result))
    927959  (target::with-stack-short-floats ((temp))
     960    #+arm-target (%set-fpscr-status 0)
    928961    (%setf-short-float TEMP (external-call "atanhf" :float n :float))
    929962    (%sf-check-exception-1 'atanh n (%ffi-exception-status))
     
    944977  (declare (double-float n result))
    945978  (with-stack-double-floats ((temp))
     979    #+arm-target (%set-fpscr-status 0)
    946980    (%setf-double-float TEMP (#_atanh n))
    947981    (%df-check-exception-1 'atanh n (%ffi-exception-status))
     
    952986  (declare (single-float n result))
    953987  (target::with-stack-short-floats ((temp))
     988    #+arm-target (%set-fpscr-status 0)
    954989    (%setf-short-float TEMP (#_atanhf n))
    955990    (%sf-check-exception-1 'atanh n (%ffi-exception-status))
  • trunk/source/level-1/l1-readloop-lds.lisp

    r13744 r14119  
    684684                                      #+ppc-target *fake-stack-frames*
    685685                                      #+x86-target (%current-frame-ptr)
     686                                      #+arm-target (or (current-fake-stack-frame) (%current-frame-ptr))
    686687                                      (db-link)
    687688                                      (1+ *break-level*)))
  • trunk/source/level-1/l1-sockets.lisp

    r13990 r14119  
    950950            #+x8664-target (and (>= subtype x8664::min-8-bit-ivector-subtag)
    951951                                (<= subtype x8664::max-8-bit-ivector-subtag))
    952       (report-bad-arg buf '(or (array (unsigned-byte 8))
     952            #+arm-target (and (<= arm::min-8-bit-ivector-subtag subtype)
     953                                (<= subtype arm::max-8-bit-ivector-subtag))
     954      (report-bad-arg buf `(or (array character)
     955                               (array (unsigned-byte 8))
    953956                               (array (signed-byte 8))))))
    954957  (values buf offset))
  • trunk/source/level-1/l1-streams.lisp

    r13901 r14119  
    243243                         (ash 1 x8664::fulltag-immheader-1)
    244244                         (ash 1 x8664::fulltag-immheader-2)))
     245        #+arm-target
     246        (= (logand subtag arm::fulltagmask)
     247           arm::fulltag-immheader)
    245248      (error "~s is not an ivector subtype." element-type))
    246249    (let* ((size-in-octets (ccl::subtag-bytes subtag element-count)))
  • trunk/source/level-1/l1-typesys.lisp

    r13099 r14119  
    43154315           nil
    43164316           (dpb 1 $lfbits-numreq 0))
     4317  #+arm-target
     4318  (gvector :function
     4319           arm::*function-initial-entrypoint*
     4320           (uvref *simple-predicate-function-prototype* 1)
     4321           datum
     4322           function
     4323           nil
     4324           (dpb 1 $lfbits-numreq 0))
    43174325  #+x86-target
    43184326  (%clone-x86-function
  • trunk/source/level-1/level-1.lisp

    r13067 r14119  
    4747  #+x86-target
    4848  (l1-load "x86-callback-support")
     49  #+arm-target
     50  (l1-load "arm-callback-support")
    4951  (l1-load "l1-callbacks")
    5052  (l1-load "l1-sort")
     
    7375  #+x86-target
    7476  (l1-load "x86-threads-utils")
     77  #+arm-target
     78  (l1-load "arm-threads-utils")
    7579  (l1-load "l1-lisp-threads")
    7680  (l1-load "l1-application")
     
    8791  #+x86-target
    8892  (l1-load "x86-trap-support")
     93  #+arm-target
     94  (l1-load "arm-trap-support")
    8995  (l1-load "l1-format")
    9096  (l1-load "l1-sysio")
  • trunk/source/lib/backtrace-lds.lisp

    r13067 r14119  
    2323
    2424(defparameter *saved-register-count*
    25   #+x8632-target 0
     25  #+(or x8632-target arm-target) 0
    2626  #+x8664-target 4
    2727  #+ppc-target 8)
    2828
    2929(defparameter *saved-register-names*
    30   #+x8632-target nil
     30  #+(or x8632-target arm-target) nil
    3131  #+x8664-target #(save3 save2 save1 save0)
    3232  #+ppc-target #(save7 save6 save5 save4 save3 save2 save1 save0))
  • trunk/source/lib/backtrace.lisp

    r13675 r14119  
    2323#+ppc-target (require "PPC-BACKTRACE")
    2424#+x86-target (require "X86-BACKTRACE")
     25#+arm-target (require "ARM-BACKTRACE")
    2526
    2627
     
    4243                        frame-ptr ;; current
    4344                        #+ppc-target *fake-stack-frames*
    44                         #+x86-target frame-ptr
     45                        #+(or x86-target arm-target) frame-ptr
    4546                        (%fixnum-ref tcr target::tcr.db-link)
    4647                        0         ;; break level - not used
  • trunk/source/lib/compile-ccl.lisp

    r14030 r14119  
    6666))
    6767
     68(defparameter *arm-compiler-modules*
     69  '(arm-arch
     70    armenv
     71    arm-asm
     72    arm-lap
     73))
     74
    6875(defparameter *ppc32-compiler-backend-modules*
    6976  '(ppc32-backend ppc32-vinsns))
     
    8592(defparameter *x86-compiler-backend-modules*
    8693  '(x862))
     94
     95(defparameter *arm-compiler-backend-modules*
     96  '(arm-backend arm-vinsns arm2))
    8797
    8898
     
    92102(defparameter *x8632-xload-modules* '(xx8632fasload xfasload heap-image ))
    93103(defparameter *x8664-xload-modules* '(xx8664fasload xfasload heap-image ))
     104(defparameter *arm-xload-modules* '(xarmfasload xfasload heap-image ))
    94105
    95106
     
    97108(defparameter *ppc-xdev-modules* '(ppc-lapmacros ))
    98109(defparameter *x86-xdev-modules* '(x86-lapmacros ))
     110(defparameter *arm-xdev-modules* '(arm-lapmacros ))
    99111
    100112(defun target-xdev-modules (&optional (target
     
    103115  (case target
    104116    ((:ppc32 :ppc64) *ppc-xdev-modules*)
    105     ((:x8632 :x8664) *x86-xdev-modules*)))
     117    ((:x8632 :x8664) *x86-xdev-modules*)
     118    (:arm *arm-xdev-modules*)))
    106119
    107120(defun target-xload-modules (&optional (target
     
    110123    ((:ppc32 :ppc64) *ppc-xload-modules*)
    111124    (:x8632 *x8632-xload-modules*)
    112     (:x8664 *x8664-xload-modules*)))
     125    (:x8664 *x8664-xload-modules*)
     126    (:arm *arm-xload-modules*)))
    113127
    114128
     
    144158             (:win32 'ffi-win32)
    145159             (:solarisx8632 'ffi-solarisx8632)
    146              (:freebsdx8632 'ffi-freebsdx8632)))))
     160             (:freebsdx8632 'ffi-freebsdx8632)
     161             (:linuxarm 'ffi-linuxarm)))))
    147162
    148163
     
    162177    (:x8664 (append *x86-compiler-modules*
    163178                    *x8664-compiler-backend-modules*
    164                     *x86-compiler-backend-modules*))))
     179                    *x86-compiler-backend-modules*))
     180    (:arm (append *arm-compiler-modules*
     181                  *arm-compiler-backend-modules*))))
    165182
    166183(defparameter *other-lib-modules*
     
    176193          (case target
    177194            ((:ppc32 :ppc64) '(ppc-backtrace ppc-disassemble))
    178             ((:x8632 :x8664) '(x86-backtrace x86-disassemble x86-watch)))))
     195            ((:x8632 :x8664) '(x86-backtrace x86-disassemble x86-watch))
     196            (:arm '(arm-backtrace arm-disassemble)))))
    179197         
    180198
     
    226244            ((:linuxppc32 :darwinppc32 :linuxppc64 :darwinppc64)
    227245             '(ppc-error-signal ppc-trap-support
    228                ppc-threads-utils ppc-callback-support))
     246               ppc-threads-utils ppc-callback-support))           
    229247            ((:linuxx8664 :freebsdx8664 :darwinx8664 :solarisx8664
    230248                          :darwinx8632 :win64  :linuxx8632 :win32 :solarisx8632
    231249                          :freebsdx8632)
    232250             '(x86-error-signal x86-trap-support
    233                x86-threads-utils x86-callback-support)))))
     251               x86-threads-utils x86-callback-support))
     252            (:linuxarm
     253             '(arm-error-signal arm-trap-support
     254               arm-threads-utils arm-callback-support)))))
    234255
    235256
     
    300321  (target-compile-modules modules (backend-name *host-backend*) force-compile)
    301322)
     323
     324(defmacro with-global-optimization-settings ((&rest override) &body body)
     325  `(let* ((*nx-speed* ,(or (cadr (assoc 'speed override)) 1))
     326          (*nx-space* ,(or (cadr (assoc 'space override)) 1))
     327          (*nx-cspeed* ,(or (cadr (assoc 'compilation-speed override)) 1))
     328          (*nx-safety* ,(or (cadr (assoc 'safety override)) 1))
     329          (*nx-debug* ,(or (cadr (assoc 'debug override)) 1)))
     330    ,@body))
    302331
    303332(defun compile-ccl (&optional force-compile)
     
    369398
    370399(defun target-xcompile-ccl (target &optional force)
    371   (require-update-modules *sysdef-modules* force) ;in the host
     400  (let* ((*target-backend* *host-backend*))
     401    (require-update-modules *sysdef-modules* force)) ;in the host
    372402  (let* ((backend (or (find-backend target) *target-backend*))
    373403         (arch (backend-target-arch-name backend))
     
    434464    (:win32 "wx86-boot32.image")
    435465    (:solarisx8632 "sx86-boot32")
    436     (:freebsdx8632 "fx86-boot32")))
     466    (:freebsdx8632 "fx86-boot32")
     467    (:linuxarm "arm-boot")))
    437468
    438469(defun standard-kernel-name (&optional (target (backend-name *host-backend*)))
     
    451482    (:win32 "wx86cl.exe")
    452483    (:solarisx8632 "sx86cl")
    453     (:freebsdx8632 "fx86cl")))
     484    (:freebsdx8632 "fx86cl")
     485    (:linuxarm "armcl")))
    454486
    455487(defun standard-image-name (&optional (target (backend-name *host-backend*)))
     
    471503    (:win32 "win32")
    472504    (:solarisx8632 "solarisx86")
    473     (:freebsdx8632 "freebsdx8632")))
     505    (:freebsdx8632 "freebsdx8632")
     506    (:linuxarm "linuxarm")))
    474507
    475508;;; If we distribute (e.g.) 32- and 64-bit versions for the same
     
    522555
    523556(defun rebuild-ccl (&key update full clean kernel force (reload t) exit
    524                     reload-arguments verbose optional-features
    525                     (save-source-locations *ccl-save-source-locations*)
    526                     (allow-constant-redefinition nil allow-constant-redefinition-p))
     557                         reload-arguments verbose optional-features
     558                         (save-source-locations *ccl-save-source-locations*)
     559                         (allow-constant-redefinition nil allow-constant-redefinition-p))
    527560  (let* ((*build-time-optional-features* (intersection *known-optional-features* optional-features))
    528561         (*features* (append *build-time-optional-features* *features*))
     
    546579              (lisp-implementation-type)
    547580              (lisp-implementation-version))
    548           (unless allow-constant-redefinition-p
    549       (when (or force clean update)
    550         (setq allow-constant-redefinition t))))
     581      (unless allow-constant-redefinition-p
     582        (when (or force clean update)
     583          (setq allow-constant-redefinition t))))
    551584    (let* ((cd (current-directory))
    552585           (*cerror-on-constant-redefinition* (not allow-constant-redefinition ))
     
    573606               (format t "~&;Building lisp-kernel ...")
    574607               (with-output-to-string (s)
    575                  (let* ((proc (run-program (make-program)
    576                                            (list "-k" "-C"
    577                                                  (format nil "lisp-kernel/~a"
    578                                                          (kernel-build-directory))
    579                                                  "-j"
     608                                      (let* ((proc (run-program (make-program)
     609                                                                (list "-k" "-C"
     610                                                                      (format nil "lisp-kernel/~a"
     611                                                                              (kernel-build-directory))
     612                                                                      "-j"
    580613                                                           
    581                                                  (format nil "~d" (1+ (cpu-count))))
    582                                            :output s
    583                                            :error :output)))
    584                    (multiple-value-bind (status exit-code)
    585                        (external-process-status proc)
    586                      (if (and (eq :exited status) (zerop exit-code))
    587                        (progn
    588                          (format t "~&;Kernel built successfully.")
    589                          (when verbose
    590                            (format t "~&;kernel build output:~%~a"
    591                                    (get-output-stream-string s)))
    592                          (sleep 1))
    593                        (error "Error(s) during kernel compilation.~%~a"
    594                               (or
    595                                (describe-external-process-failure
    596                                 proc
    597                                 "Developer tools may not be installed correctly.")
    598                                (get-output-stream-string s))))))))
    599              (compile-ccl (not (null force)))
    600              (if force (xload-level-0 :force) (xload-level-0))
     614                                                                      (format nil "~d" (1+ (cpu-count))))
     615                                                                :output s
     616                                                                :error :output)))
     617                                        (multiple-value-bind (status exit-code)
     618                                            (external-process-status proc)
     619                                          (if (and (eq :exited status) (zerop exit-code))
     620                                            (progn
     621                                              (format t "~&;Kernel built successfully.")
     622                                              (when verbose
     623                                                (format t "~&;kernel build output:~%~a"
     624                                                        (get-output-stream-string s)))
     625                                              (sleep 1))
     626                                            (error "Error(s) during kernel compilation.~%~a"
     627                                                   (or
     628                                                    (describe-external-process-failure
     629                                                     proc
     630                                                     "Developer tools may not be installed correctly.")
     631                                                    (get-output-stream-string s))))))))
     632             (with-global-optimization-settings ()
     633               (compile-ccl (not (null force)))
     634               (if force (xload-level-0 :force) (xload-level-0)))
    601635             (when reload
    602636               (with-input-from-string (cmd (format nil
    603                                               "(save-application ~s)"
    604                                               (standard-image-name)))
     637                                                    "(save-application ~s)"
     638                                                    (standard-image-name)))
    605639                 (with-output-to-string (output)
    606                    (multiple-value-bind (status exit-code)
    607                        (external-process-status
    608                         (run-program
    609                          (format nil "./~a" (standard-kernel-name))
    610                          (list* "--image-name" (standard-boot-image-name)
    611                                 "--batch"
    612                                 reload-arguments)
    613                          :input cmd
    614                          :output output
    615                          :error output))
    616                      (if (and (eq status :exited)
    617                               (eql exit-code 0))
    618                        (progn
    619                          (format t "~&;Wrote heap image: ~s"
    620                                  (truename (format nil "ccl:~a"
    621                                                    (standard-image-name))))
    622                          (when verbose
    623                            (format t "~&;Reload heap image output:~%~a"
    624                                    (get-output-stream-string output))))
    625                        (error "Errors (~s ~s) reloading boot image:~&~a"
    626                               status exit-code
    627                               (get-output-stream-string output)))))))
     640                                        (multiple-value-bind (status exit-code)
     641                                            (external-process-status
     642                                             (run-program
     643                                              (format nil "./~a" (standard-kernel-name))
     644                                              (list* "--image-name" (standard-boot-image-name)
     645                                                     "--batch"
     646                                                     reload-arguments)
     647                                              :input cmd
     648                                              :output output
     649                                              :error output))
     650                                          (if (and (eq status :exited)
     651                                                   (eql exit-code 0))
     652                                            (progn
     653                                              (format t "~&;Wrote heap image: ~s"
     654                                                      (truename (format nil "ccl:~a"
     655                                                                        (standard-image-name))))
     656                                              (when verbose
     657                                                (format t "~&;Reload heap image output:~%~a"
     658                                                        (get-output-stream-string output))))
     659                                            (error "Errors (~s ~s) reloading boot image:~&~a"
     660                                                   status exit-code
     661                                                   (get-output-stream-string output)))))))
    628662             (when exit
    629663               (quit)))
  • trunk/source/lib/describe.lisp

    r13961 r14119  
    16511651             :context context
    16521652             :break-condition (ccl::bt.break-condition context))
    1653            :tsp-range (make-tsp-stack-range tcr context)
     1653           #-arm-target
     1654           :tsp-range #-arm-target (make-tsp-stack-range tcr context)
    16541655           :vsp-range (make-vsp-stack-range tcr context)
    16551656           :csp-range (make-csp-stack-range tcr context)
     
    17571758;;; addresses; they can be used to addresses of stack-allocated objects
    17581759;;; for printing.
     1760#-arm-target
    17591761(defun make-tsp-stack-range (tcr bt-info)
    17601762  (list (cons (ccl::%catch-tsp (ccl::bt.top-catch bt-info))
     
    17811783                                target::area.high))))
    17821784
     1785#+arm-target
     1786(defun make-vsp-stack-range (tcr bt-info)
     1787  (list (cons (ccl::%fixnum-ref (ccl::catch-frame-sp (ccl::bt.top-catch bt-info))
     1788                                target::lisp-frame.savevsp)
     1789              (ccl::%fixnum-ref (ccl::%fixnum-ref tcr target::tcr.vs-area)
     1790                                target::area.high))))
     1791
    17831792#+ppc-target
    17841793(defun make-csp-stack-range (tcr bt-info)
     
    17961805(defun make-csp-stack-range (tcr bt-info)
    17971806  (list (cons (ccl::%svref (ccl::bt.top-catch bt-info) target::catch-frame.foreign-sp-cell)
     1807              (ccl::%fixnum-ref (ccl::%fixnum-ref tcr target::tcr.cs-area)
     1808                                target::area.high))))
     1809
     1810#+arm-target
     1811(defun make-csp-stack-range (tcr bt-info)
     1812  (list (cons (ccl::catch-frame-sp (ccl::bt.top-catch bt-info))
    17981813              (ccl::%fixnum-ref (ccl::%fixnum-ref tcr target::tcr.cs-area)
    17991814                                target::area.high))))
  • trunk/source/lib/edit-callers.lisp

    r13067 r14119  
    189189               (when (logbitp $lfbits-info-bit bits)
    190190                 (decf end))
    191                (loop for i from #+ppc-target 1 #+x86-target (%function-code-words fun) below end
     191               (loop for i from #+ppc-target 1 #+x86-target (%function-code-words fun) #+arm-target 2 below end
    192192                     as im = (%svref lfv i)
    193193                     when (or (eq function im)
     
    236236      (declare (fixnum i))
    237237      (funcall f (%svref lfv (%i+ 1 i))))
     238    #+arm-target
     239    (do* ((i 2 (1+ i)))
     240         ((>= i n))
     241      (declare (fixnum i))
     242      (funcall f (uvref lfv i)))
    238243    ))
    239244         
  • trunk/source/lib/foreign-types.lisp

    r13067 r14119  
    102102                        (:win32 "ccl:win32-headers;")
    103103                        (:solarisx8632 "ccl:solarisx86-headers;")
    104                         (:freebsdx8632 "ccl:freebsd-headers;"))
     104                        (:freebsdx8632 "ccl:freebsd-headers;")
     105                        (:linuxarm "ccl:arm-headers;"))
    105106                    :interface-package-name
    106107                    #.(ftd-interface-package-name *target-ftd*)
  • trunk/source/lib/macros.lisp

    r13980 r14119  
    822822    `(loop with ,fn = ,function
    823823           with ,lfv = (function-to-function-vector ,fn)
    824            for ,i from #+ppc-target 1 #+x86-target (%function-code-words ,fn) below (%i- (uvsize  ,lfv) 1)
     824           for ,i from #+ppc-target 1 #+x86-target (%function-code-words ,fn) #+arm-target 2  below (%i- (uvsize  ,lfv) 1)
    825825           as ,var = (%svref ,lfv ,i)
    826826           ,@loop-body)))
  • trunk/source/lib/misc.lisp

    r13873 r14119  
    9494                              (read-line f nil nil))
    9595                        (target #+ppc-target "machine"
    96                                 #+x86-target "model name"))
     96                                #+x86-target "model name"
     97                                #+arm-target "Hardware"))
    9798                       ((null line))
    9899                    (let* ((matched (cpu-info-match target line)))
     
    778779  (#+ppc-target ppc-xdisassemble
    779780   #+x86-target x86-xdisassemble
     781   #+arm-target arm-xdisassemble
    780782   (require-type (function-for-disassembly thing) 'compiled-function)))
    781783
     
    11101112                    ((= lowtag ppc64::lowtag-nodeheader)
    11111113                     (%svref *nodeheader-types* (ash i -2)))))))
    1112     #+(or ppc32-target x8632-target)
     1114    #+(or ppc32-target x8632-target arm-target)
    11131115    (dotimes (i 256)
    11141116      (let* ((fulltag (logand i target::fulltagmask)))
  • trunk/source/lib/nfcomp.lisp

    r14046 r14119  
    144144      (warn "Unknown :TARGET : ~S.  Reverting to ~s ..." target *fasl-target*)
    145145      (setq target *fasl-target*  backend *target-backend*))
     146    (unless (eq *target-backend* *host-backend*)
     147      (setq save-source-locations nil))
    146148    (multiple-value-bind (output-file truename warnings-p serious-p)
    147149        (loop
     
    11031105  (unless (memq lfun refs)
    11041106    (let* ((lfv (function-to-function-vector lfun))
    1105            (start #+ppc-target 0 #+x86-target (%function-code-words lfun))
     1107           (start #-x86-target 0 #+x86-target (%function-code-words lfun))
    11061108           (refs (cons lfun refs)))
    11071109      (declare (dynamic-extent refs))
     
    12381240        (#.target::tag-fixnum
    12391241         (fasl-scan-fixnum exp))
    1240         (#.target::fulltag-cons (fasl-scan-list exp))
     1242        (#.target::tag-list (fasl-scan-list exp))
    12411243        #+ppc32-target
    12421244        (#.ppc32::tag-imm)
     
    12511253        ((#.x8664::fulltag-imm-0
    12521254          #.x8664::fulltag-imm-1))
     1255        #+arm-target
     1256        (#.arm::tag-imm)
    12531257        (t
    12541258         (if
     
    12651269                                 (ash 1 x8664::fulltag-immheader-1)
    12661270                                 (ash 1 x8664::fulltag-immheader-2))))
     1271           #+arm-target
     1272           (= (the fixnum (logand type-code arm::fulltagmask)) arm::fulltag-immheader)
    12671273           (case type-code
    12681274             (#.target::subtag-dead-macptr (fasl-unknown exp))
     
    12831289             (#+ppc-target #.target::subtag-symbol
    12841290              #+x8632-target #.target::subtag-symbol
    1285               #+x8664-target #.target::tag-symbol (fasl-scan-symbol exp))
     1291              #+x8664-target #.target::tag-symbol
     1292              #+arm-target #.target::subtag-symbol (fasl-scan-symbol exp))
    12861293             ((#.target::subtag-instance #.target::subtag-struct)
    12871294              (fasl-scan-user-form exp))
     
    17081715           (= (typecode (uvref f 0)) target::subtag-u8-vector))
    17091716    (fasl-xdump-clfun f)
    1710     (let* ((code-size (%function-code-words f))
    1711            (function-vector (function-to-function-vector f))
    1712            (function-size (uvsize function-vector)))
    1713       (fasl-out-opcode $fasl-clfun f)
    1714       (fasl-out-count function-size)
    1715       (fasl-out-count code-size)
    1716       (fasl-out-ivect function-vector 0 (ash code-size target::word-shift))
    1717       (do* ((k code-size (1+ k)))
    1718            ((= k function-size))
    1719         (declare (fixnum k))
    1720         (fasl-dump-form (uvref function-vector k))))))
     1717    (if (= (typecode f) target::subtag-xfunction)
     1718      (let* ((n (uvsize f)))
     1719        (fasl-out-opcode $fasl-function f)
     1720        (fasl-out-count n)
     1721        (dotimes (i n)
     1722          (fasl-dump-form (%svref f i))))       
     1723
     1724      (let* ((code-size (%function-code-words f))
     1725             (function-vector (function-to-function-vector f))
     1726             (function-size (uvsize function-vector)))
     1727        (fasl-out-opcode $fasl-clfun f)
     1728        (fasl-out-count function-size)
     1729        (fasl-out-count code-size)
     1730        (fasl-out-ivect function-vector 0 (ash code-size target::word-shift))
     1731        (do* ((k code-size (1+ k)))
     1732             ((= k function-size))
     1733          (declare (fixnum k))
     1734          (fasl-dump-form (uvref function-vector k)))))))
    17211735       
    17221736
  • trunk/source/lib/sequences.lisp

    r13067 r14119  
    171171                                   (the fixnum (ash n 2))))
    172172        ;; DOUBLE-FLOAT vectors have extra alignment padding on ppc32/x8632.
    173         #+(or ppc32-target x8632-target)
     173        #+32-bit-target
    174174        (#.target::subtag-double-float-vector
    175175         (%copy-ivector-to-ivector src
  • trunk/source/lib/systems.lisp

    r13494 r14119  
    4747    (x86-trap-support "ccl:l1f;x86-trap-support" ("ccl:l1;x86-trap-support.lisp"))
    4848
     49    (arm-trap-support "ccl:l1f;arm-trap-support" ("ccl:l1;arm-trap-support.lisp"))
    4950    (l1-format        "ccl:l1f;l1-format"        ("ccl:l1;l1-format.lisp"))
    5051    (l1-readloop      "ccl:l1f;l1-readloop"      ("ccl:l1;l1-readloop.lisp"))
     
    5354    (l1-error-system  "ccl:l1f;l1-error-system"  ("ccl:l1;l1-error-system.lisp"))
    5455    (ppc-error-signal "ccl:l1f;ppc-error-signal" ("ccl:l1;ppc-error-signal.lisp"))
    55     (x86-error-signal "ccl:l1f;x86-error-signal" ("ccl:l1;x86-error-signal.lisp"))   
     56    (x86-error-signal "ccl:l1f;x86-error-signal" ("ccl:l1;x86-error-signal.lisp"))
     57    (arm-error-signal "ccl:l1f;arm-error-signal" ("ccl:l1;arm-error-signal.lisp"))
    5658    (l1-error-signal  "ccl:l1f;l1-error-signal"  ("ccl:l1;l1-error-signal.lisp"))
    5759    (l1-aprims        "ccl:l1f;l1-aprims"        ("ccl:l1;l1-aprims.lisp"))
    5860    (l1-callbacks     "ccl:l1f;l1-callbacks"    ("ccl:l1;l1-callbacks.lisp"))
    5961    (ppc-callback-support "ccl:l1f;ppc-callback-support" ("ccl:l1;ppc-callback-support.lisp"))
    60     (x86-callback-support "ccl:l1f;x86-callback-support" ("ccl:l1;x86-callback-support.lisp"))   
     62    (x86-callback-support "ccl:l1f;x86-callback-support" ("ccl:l1;x86-callback-support.lisp"))
     63    (arm-callback-support "ccl:l1f;arm-callback-support" ("ccl:l1;arm-callback-support.lisp"))
    6164    (l1-sysio         "ccl:l1f;l1-sysio"         ("ccl:l1;l1-sysio.lisp"))
    6265    (l1-symhash       "ccl:l1f;l1-symhash"       ("ccl:l1;l1-symhash.lisp"))
     
    6669    (ppc-threads-utils "ccl:l1f;ppc-threads-utils" ("ccl:l1;ppc-threads-utils.lisp"))
    6770    (x86-threads-utils "ccl:l1f;x86-threads-utils" ("ccl:l1;x86-threads-utils.lisp"))
     71    (arm-threads-utils "ccl:l1f;arm-threads-utils" ("ccl:l1;arm-threads-utils.lisp"))
    6872    (l1-application   "ccl:l1f;l1-application"   ("ccl:l1;l1-application.lisp"))
    6973    (l1-processes     "ccl:l1f;l1-processes"     ("ccl:l1;l1-processes.lisp"))
     
    8791    (x8632-arch       "ccl:bin;x8632-arch"       ("ccl:compiler;X86;X8632;x8632-arch.lisp"))
    8892    (x8664-arch       "ccl:bin;x8664-arch"       ("ccl:compiler;X86;X8664;x8664-arch.lisp"))
     93    (arm-arch         "ccl:bin;arm-arch"         ("ccl:compiler;ARM;arm-arch.lisp"))
    8994    (arch             "ccl:bin;arch"             ("ccl:compiler;arch.lisp"))
    9095    (ppcenv           "ccl:bin;ppcenv"           ("ccl:lib;ppcenv.lisp"))
    9196    (x8664env         "ccl:bin;x8664env"         ("ccl:lib;x8664env.lisp"))
    9297    (x8632env         "ccl:bin;x8632env"         ("ccl:lib;x8632env.lisp"))
     98    (armenv           "ccl:bin;armenv"           ("ccl:lib;armenv.lisp"))
    9399    (vreg             "ccl:bin;vreg"             ("ccl:compiler;vreg.lisp"))
    94100    (ppc-asm          "ccl:bin;ppc-asm"          ("ccl:compiler;PPC;ppc-asm.lisp"))
    95101    (x86-asm          "ccl:bin;x86-asm"          ("ccl:compiler;X86;x86-asm.lisp"))
     102    (arm-asm          "ccl:bin;arm-asm"          ("ccl:compiler;ARM;arm-asm.lisp"))
    96103    (vinsn            "ccl:bin;vinsn"            ("ccl:compiler;vinsn.lisp"))
    97104    (ppc32-vinsns     "ccl:bin;ppc32-vinsns"     ("ccl:compiler;PPC;PPC32;ppc32-vinsns.lisp"))
     
    99106    (x8632-vinsns     "ccl:bin;x8632-vinsns"     ("ccl:compiler;X86;X8632;x8632-vinsns.lisp"))
    100107    (x8664-vinsns     "ccl:bin;x8664-vinsns"     ("ccl:compiler;X86;X8664;x8664-vinsns.lisp"))
     108    (arm-vinsns       "ccl:bin;arm-vinsns"       ("ccl:compiler;ARM;arm-vinsns.lisp"))
    101109    (reg              "ccl:bin;reg"              ("ccl:compiler;reg.lisp"))
    102110    (subprims         "ccl:bin;subprims"         ("ccl:compiler;subprims.lisp"))
     
    104112    (ppc-lap          "ccl:bin;ppc-lap"          ("ccl:compiler;PPC;ppc-lap.lisp"))
    105113    (x86-lap          "ccl:bin;x86-lap"          ("ccl:compiler;X86;x86-lap.lisp"))
     114    (arm-lap          "ccl:bin;arm-lap"          ("ccl:compiler;ARM;arm-lap.lisp"))
    106115    (backend          "ccl:bin;backend"          ("ccl:compiler;backend.lisp"))
    107116    (ppc32-backend    "ccl:bin;ppc32-backend"    ("ccl:compiler;PPC;PPC32;ppc32-backend.lisp"))                   
     
    111120    (x8664-backend    "ccl:bin;x8664-backend"    ("ccl:compiler;X86;X8664;x8664-backend.lisp"))
    112121    (x86-backend      "ccl:bin;x86-backend"      ("ccl:compiler;X86;x86-backend.lisp"))
     122    (arm-backend      "ccl:bin;arm-backend"      ("ccl:compiler;ARM;arm-backend.lisp"))
    113123    (ppc2             "ccl:bin;ppc2"             ("ccl:compiler;PPC;ppc2.lisp"))
    114124    (x862             "ccl:bin;x862"             ("ccl:compiler;X86;x862.lisp"))
    115 
     125    (arm2             "ccl:bin;arm2"             ("ccl:compiler;ARM;arm2.lisp"))
    116126    (ppc-lapmacros    "ccl:bin;ppc-lapmacros"    ("ccl:compiler;PPC;ppc-lapmacros.lisp"))
    117127    (x86-lapmacros    "ccl:bin;x86-lapmacros"    ("ccl:compiler;X86;x86-lapmacros.lisp"))
     128    (arm-lapmacros    "ccl:bin;arm-lapmacros"    ("ccl:compiler;ARM;arm-lapmacros.lisp"))
    118129    (ppc-disassemble  "ccl:bin;ppc-disassemble"  ("ccl:compiler;PPC;ppc-disassemble.lisp"))
    119130    (x86-disassemble  "ccl:bin;x86-disassemble"  ("ccl:compiler;X86;x86-disassemble.lisp"))
     131    (arm-disassemble  "ccl:bin;arm-disassemble"  ("ccl:compiler;ARM;arm-disassemble.lisp"))
    120132    (xfasload         "ccl:xdump;xfasload"       ("ccl:xdump;xfasload.lisp"))
    121133    (xppcfasload      "ccl:xdump;xppcfasload"    ("ccl:xdump;xppcfasload.lisp"))
    122134    (xx8632fasload    "ccl:xdump;xx8632-fasload"  ("ccl:xdump;xx8632-fasload.lisp"))
    123135    (xx8664fasload    "ccl:xdump;xx8664-fasload"  ("ccl:xdump;xx8664-fasload.lisp"))
     136    (xarmfasload      "ccl:xdump;xarm-fasload"   ("ccl:xdump;xarmfasload.lisp"))
    124137    (heap-image       "ccl:xdump;heap-image"     ("ccl:xdump;heap-image.lisp"))
    125138    (xsym             "ccl:xdump;xsym"           ("ccl:xdump;xsym.lisp"))
     
    149162    (ffi-solarisx8632 "ccl:bin;ffi-solarisx8632" ("ccl:lib;ffi-solarisx8632.lisp"))
    150163    (ffi-freebsdx8632 "ccl:bin;ffi-freebsdx8632" ("ccl:lib;ffi-freebsdx8632.lisp"))
    151    
     164    (ffi-linuxarm     "ccl:bin;ffi-linuxarm"     ("ccl:lib;ffi-linuxarm.lisp"))
    152165    (db-io            "ccl:bin;db-io"            ("ccl:lib;db-io.lisp"))
    153166    (hash             "ccl:bin;hash"             ("ccl:lib;hash.lisp"))
     
    162175    (ppc-backtrace    "ccl:bin;ppc-backtrace"    ("ccl:lib;ppc-backtrace.lisp"))
    163176    (x86-backtrace    "ccl:bin;x86-backtrace"    ("ccl:lib;x86-backtrace.lisp"))
     177    (arm-backtrace    "ccl:bin;arm-backtrace"    ("ccl:lib;arm-backtrace.lisp"))
    164178    (x86-watch        "ccl:bin;x86-watch"        ("ccl:lib;x86-watch.lisp"))
    165179    (backtrace-lds    "ccl:bin;backtrace-lds"    ("ccl:lib;backtrace-lds.lisp"))
  • trunk/source/library/elf.lisp

    r13279 r14119  
    170170
    171171
    172 
     172#+x86-target
    173173(defun collect-elf-static-functions ()
    174174  (collect ((functions))
     
    184184                  ))
    185185    (functions)))
     186
     187#+(or arm-target ppc-target)
     188(defun collect-elf-static-functions ()
     189  (ccl::purify)
     190  (multiple-value-bind (pure-low pure-high)
     191      (ccl::do-gc-areas (a)
     192        (when (eql(ccl::%fixnum-ref a target::area.code)
     193                  ccl::area-readonly)
     194          (return
     195            (values (ash (ccl::%fixnum-ref a target::area.low) target::fixnumshift)
     196                    (ash (ccl::%fixnum-ref a target::area.active) target::fixnumshift)))))
     197    (let* ((hash (make-hash-table :test #'eq))
     198           (code-vector-index #+ppc-target 0 #+arm-target 1))
     199      (ccl::%map-lfuns #'(lambda (f)
     200                           (let* ((code-vector  (ccl:uvref f code-vector-index))
     201                                  (startaddr (+ (ccl::%address-of code-vector)
     202                                                target::misc-data-offset)))
     203                             (when (and (>= startaddr pure-low)
     204                                        (< startaddr pure-high))
     205                               (push f (gethash code-vector hash))))))
     206      (let* ((n 0))
     207        (declare (fixnum n))
     208        (maphash #'(lambda (k v)
     209                     (declare (ignore k))
     210                     (if (null (cdr v))
     211                       (incf n)))
     212                 hash)
     213        (let* ((functions ()))
     214          (maphash #'(lambda (k v)
     215                       (declare (ignore k))
     216                       (when (null (cdr v))
     217                         (push (car v) functions)))
     218                   hash)
     219          (sort functions
     220                #'(lambda (x y)
     221                    (< (ccl::%address-of (uvref x code-vector-index))
     222                       (ccl::%address-of (uvref y code-vector-index))))))))))
    186223
    187224(defun register-elf-functions (section-number)
     
    217254            (pref p
    218255                  #+64-bit-target :<E>lf64_<S>ym.st_value
    219                   #+32-bit-target :<E>lf32_<S>ym.st_value) (%address-of f)
     256                  #+32-bit-target :<E>lf32_<S>ym.st_value)
     257            #+x86-target (%address-of f)
     258            #+ppc-target (- (%address-of (uvref f 0)) (- ppc::fulltag-misc ppc::node-size))
     259            #+arm-target (- (%address-of (uvref f 1)) (- arm::fulltag-misc arm::node-size))
    220260            (pref p
    221261                  #+64-bit-target :<E>lf64_<S>ym.st_size
    222                   #+32-bit-target :<E>lf32_<S>ym.st_size) (1+ (ash (1- (%function-code-words f)) target::word-shift))))))
     262                  #+32-bit-target :<E>lf32_<S>ym.st_size)
     263            #+x86-target (1+ (ash (1- (%function-code-words f)) target::word-shift))
     264            #+ppc-target (ash (uvsize (uvref f 0)) ppc::word-shift)
     265            #+arm-target (ash (uvsize (uvref f 1)) arm::word-shift)
     266            ))))
    223267
    224268(defun elf-section-index (section)
     
    325369                                           #+ppc32-target #$EM_PPC
    326370                                           #+ppc64-target #$EM_PPC64
     371                                           #+arm-target #$EM_ARM
    327372                                           ))
    328373         (program-header (new-elf-program-header object))
  • trunk/source/lisp-kernel/area.h

    r13617 r14119  
    143143#endif
    144144
     145#ifdef ARM
     146#define CS_OVERFLOW_FORCE_LIMIT ((natural)(-(sizeof(lisp_frame))))
     147#endif
    145148
    146149
     
    150153#define PURESPACE_SIZE (1LL<<30LL)
    151154#else
     155#ifdef ARM
     156#define PURESPACE_RESERVE (64<<20)
     157#define PURESPACE_SIZE (32<<20)
     158#else
    152159#define PURESPACE_RESERVE (128<<20) /* MB */
    153160#define PURESPACE_SIZE (64<<20)
    154161#endif
     162#endif
    155163
    156 #define STATIC_RESERVE heap_segment_size
     164#define STATIC_RESERVE (2<<12)
    157165
    158166
  • trunk/source/lisp-kernel/bits.h

    r13330 r14119  
    131131  register natural _sp __asm__("%esp");
    132132#endif
     133#ifdef ARM
     134  register natural _sp __asm__("sp");
     135#endif
    133136  return _sp;
    134137}
  • trunk/source/lisp-kernel/gc-common.c

    r13954 r14119  
    14441444    if (GCDebug) {
    14451445      check_all_areas(tcr);
    1446     }
    1447     check_static_cons_freelist("in pre-gc static-cons check");
     1446      check_static_cons_freelist("i`n pre-gc static-cons check");
     1447    }
    14481448  }
    14491449
     
    14711471      {
    14721472        LispObj
    1473           itab;
     1473          itab,
     1474          pkgidx = nrs_PACKAGE.binding_index;
    14741475        natural
    14751476          dnode, ndnodes;
    14761477     
    1477         pkg = nrs_PACKAGE.vcell;
     1478        if ((pkgidx >= tcr->tlb_limit) ||
     1479            ((pkg = tcr->tlb_pointer[pkgidx>>fixnumshift]) ==
     1480             no_thread_local_binding_marker)) {
     1481          pkg = nrs_PACKAGE.vcell;
     1482        }
    14781483        if ((fulltag_of(pkg) == fulltag_misc) &&
    14791484            (header_subtag(header_of(pkg)) == subtag_package)) {
     
    17141719  if (GCDebug) {
    17151720    check_all_areas(tcr);
    1716   }
    1717   check_static_cons_freelist("in post-gc static-cons check");
    1718 
     1721    check_static_cons_freelist("in post-gc static-cons check");
     1722  }
    17191723
    17201724 
  • trunk/source/lisp-kernel/gc.h

    r13880 r14119  
    5757#endif
    5858
     59#ifdef ARM
     60#define is_node_fulltag(f)  ((1<<(f))&((1<<fulltag_cons)|(1<<fulltag_misc)))
     61#endif
    5962
    6063extern void zero_memory_range(BytePtr,BytePtr);
     
    106109#define forward_marker subtag_forward_marker
    107110#else
     111#ifdef ARM
     112#define forward_marker (0xe7fffff0|uuo_format_unary)
     113#else
    108114#define forward_marker fulltag_nil
     115#endif
    109116#endif
    110117
  • trunk/source/lisp-kernel/image.c

    r13792 r14119  
    353353        image_nil = (LispObj)(a->low) + (1024*4) + fulltag_cons;
    354354#endif
     355#endif
     356#ifdef ARM
     357        image_nil = (LispObj)(a->low) + (1024*4) + fulltag_nil;
    355358#endif
    356359        set_nil(image_nil);
  • trunk/source/lisp-kernel/lisp-debug.c

    r13930 r14119  
    285285  }
    286286#endif
    287 
     287#ifdef ARM
     288  fprintf(dbgout, "r%02d (%s) = %s\n", r, label, print_lisp_object(val));
     289#endif
    288290}
    289291
     
    543545#endif
    544546
     547#ifdef ARM
     548void
     549describe_arm_uuo(ExceptionInformation *xp)
     550{
     551  pc program_counter = xpPC(xp);
     552  opcode instruction = *program_counter;
     553
     554  if (IS_UUO(instruction)) {
     555    unsigned format = UUO_FORMAT(instruction);
     556
     557    switch(format) {
     558    case uuo_format_nullary:
     559    case uuo_format_nullary_error:
     560      switch UUOA_field(instruction) {
     561      case 0:
     562        fprintf(dbgout,"alloc_trap\n");
     563        break;
     564      case 1:
     565        fprintf(dbgout,"wrong number of args (%d) to %s\n",xpGPR(xp,nargs)>>node_shift,
     566                print_lisp_object(xpGPR(xp,nfn)));
     567        break;
     568      case 2:
     569        fprintf(dbgout,"gc trap\n");
     570        break;
     571      case 3:
     572        fprintf(dbgout,"debug trap\n");
     573        break;
     574      case 4:
     575        fprintf(dbgout,"deferred interrupt\n");
     576        break;
     577      case 5:
     578        fprintf(dbgout,"deferred suspend\n");
     579        break;
     580      default:
     581        break;
     582      }
     583      break;
     584
     585    case uuo_format_unary_error:
     586      switch (UUO_UNARY_field(instruction)) {
     587      case 0:
     588      case 1:
     589        fprintf(dbgout,"%s is unbound\n", print_lisp_object(xpGPR(xp,UUOA_field(instruction))));
     590        break;
     591
     592      default:
     593        break;
     594      }
     595    default:
     596      break;
     597    }
     598  }
     599}
     600#endif
     601
    545602char *
    546603area_code_name(int code)
     
    644701  }
    645702#endif
     703#ifdef ARM
     704    TCR *xpcontext = (TCR *)ptr_from_lispobj(xpGPR(xp, rcontext));
     705
     706    fprintf(dbgout, "rcontext = 0x%lX ", xpcontext);
     707    if (!active_tcr_p(xpcontext)) {
     708      fprintf(dbgout, "(INVALID)\n");
     709    } else {
     710      fprintf(dbgout, "\nnargs = %d\n", xpGPR(xp, nargs) >> fixnumshift);
     711      show_lisp_register(xp, "fn", fn);
     712      show_lisp_register(xp, "arg_z", arg_z);
     713      show_lisp_register(xp, "arg_y", arg_y);
     714      show_lisp_register(xp, "arg_x", arg_x);
     715      show_lisp_register(xp, "temp0", temp0);
     716      show_lisp_register(xp, "temp1/fname/next_method_context", temp1);
     717      show_lisp_register(xp, "temp2/nfn", temp2);
     718    }
     719#endif
    646720  }
    647721 
     
    649723}
    650724
    651 #ifdef PPC
     725#ifndef X86
    652726debug_command_return
    653727debug_advance_pc(ExceptionInformation *xp, siginfo_t *info, int arg)
     
    661735debug_identify_exception(ExceptionInformation *xp, siginfo_t *info, int arg)
    662736{
    663 #ifdef PPC
     737#ifndef X86
    664738  pc program_counter = xpPC(xp);
    665739  opcode instruction = 0;
     740#endif
    666741
    667742  switch (arg) {
     743#ifdef PPC
    668744  case SIGILL:
    669745  case SIGTRAP:
     
    676752    }
    677753    break;
     754#endif
     755
     756#ifdef ARM 
     757  case SIGILL:
     758    instruction = *program_counter;
     759    if (IS_UUO(instruction)) {
     760      describe_arm_uuo(xp);
     761    }
     762    break;
     763  }
     764#endif
    678765  case SIGSEGV:
    679766  case SIGBUS:
     
    683770    break;
    684771  }
    685 #else
    686   switch (arg) {
    687   case SIGSEGV:
    688   case SIGBUS:
    689     describe_memfault(xp, info);
    690     break;
    691   default:
    692     break;
    693   }
    694 #endif
    695772  return debug_continue;
    696773}
     
    719796debug_get_natural_value(char *prompt)
    720797{
    721   char s[32], *res;
     798  char s[32], *res, *endptr;
    722799  int n;
    723800  natural val;
     
    728805    s[0]=0;
    729806    res = fgets(s, 24, stdin);
    730     n = sscanf(s, "%lu", &val);
    731   } while (n != 1);
     807    val = strtoul(res,&endptr,0);
     808  } while (*endptr);
    732809  return val;
    733810}
     
    782859              (u64_t) (natural)(xpGPR(xp,Isp))
    783860#endif           
     861#ifdef ARM
     862              (u64_t) (natural)(xpGPR(xp,Rsp))
     863#endif
    784864              );
    785865    }
     
    9251005#endif
    9261006
     1007#ifdef ARM
     1008  int a, b;
     1009  for (a = 0, b = 8; a < 8; a++, b++) {
     1010    fprintf(dbgout,"r%02d = 0x%08lX    r%02d = 0x%08lX\n",
     1011            a, xpGPR(xp, a),
     1012            b, xpGPR(xp, b));
     1013  }
     1014#endif
     1015
    9271016  return debug_continue;
    9281017}
     
    10751164   "GPR to set (0-31) ?",
    10761165   'G'},
    1077 #ifdef PPC
     1166#ifndef X86
    10781167  {debug_advance_pc,
    10791168   "Advance the program counter by one instruction (use with caution!)",
     
    10811170   NULL,
    10821171   'A'},
    1083 #endif
    10841172  {debug_identify_exception,
    10851173   "Describe the current exception in greater detail",
     
    10881176   NULL,
    10891177   'D'},
     1178#endif
    10901179  {debug_show_registers,
    10911180   "Show raw GPR/SPR register values",
  • trunk/source/lisp-kernel/lisp-exceptions.h

    r13067 r14119  
    151151#endif
    152152
     153#ifdef ARM
     154#include "arm-exceptions.h"
     155#endif
     156
    153157void suspend_other_threads(Boolean);
    154158void resume_other_threads(Boolean);
  • trunk/source/lisp-kernel/lisp.h

    r13970 r14119  
    9696
    9797void
    98 install_signal_handler(int, void*, Boolean);
     98install_signal_handler(int, void*, Boolean, Boolean);
    9999
    100100#endif /* __lisp__ */
  • trunk/source/lisp-kernel/lisp.s

    r13337 r14119  
    6666         include(x86-uuo.s)
    6767        ')
     68        ifdef(`ARM',`
     69         include(arm-constants.s)
     70         include(arm-macros.s)
     71         include(arm-uuo.s)
     72        ')
    6873
  • trunk/source/lisp-kernel/lisp_globals.h

    r13792 r14119  
    8484#define GC_NOTIFY_THRESHOLD (-506)
    8585#else
     86#ifdef ARM
     87#define LISP_HEAP_THRESHOLD (-1021)
     88#define EGC_ENABLED (-1020)
     89#define G0_THRESHOLD (-1019)
     90#define G1_THRESHOLD (-1018)
     91#define G2_THRESHOLD (-1017)
     92#define GC_NOTIFY_THRESHOLD (-1016)
     93#else
    8694#define LISP_HEAP_THRESHOLD (-1023)
    8795#define EGC_ENABLED (-1022)
     
    9098#define G2_THRESHOLD (-1019)
    9199#define GC_NOTIFY_THRESHOLD (-1018)
     100#endif
    92101#endif
    93102
     
    110119#define lisp_global(g) (((LispObj *) (0x13000+(LOWMEM_BIAS)))[(g)])
    111120#define nrs_symbol(s) (((lispsymbol *) (0x13008+(LOWMEM_BIAS)))[(s)])
     121#endif
     122
     123#ifdef ARM
     124#define lisp_global(g) (((LispObj *) (nil_value-fulltag_nil-dnode_size))[(g)])
     125#define nrs_symbol(s) (((lispsymbol *) (nil_value-fulltag_nil+dnode_size))[(s)])
    112126#endif
    113127
  • trunk/source/lisp-kernel/m4macros.m4

    r13337 r14119  
    44
    55/*   Copyright (C) 1994-2001 Digitool, Inc  */
     6/*   Copyright (c) 2009 Clozure Associates */
    67/*   This file is part of Clozure CL.    */
    78
     
    179180# __line__
    180181        ifelse(eval(SYSstabs),eval(ELFstabs),`
    181         .type $1,@function
     182        .type $1,ifdef(`ARM',%function,@function)
    182183')
    183184
  • trunk/source/lisp-kernel/macros.h

    r13589 r14119  
    7979#endif
    8080
     81#ifdef ARM
     82#define nodeheader_tag_p(tag) (tag == fulltag_nodeheader)
     83#define immheader_tag_p(tag) (tag == fulltag_immheader)
     84#endif
     85
    8186#ifdef VC
    8287#define inline
  • trunk/source/lisp-kernel/pmcl-kernel.c

    r13970 r14119  
    314314#ifdef USE_SIGALTSTACK
    315315  setup_sigaltstack(a);
     316#endif
     317#ifdef PROTECT_CSTACK
     318  a->softprot=new_protected_area(a->hardlimit,a->softlimit,kSPsoftguard,CSTACK_SOFTPROT,true);
     319  a->hardprot=new_protected_area(lowlimit,a->hardlimit,kSPhardguard,CSTACK_HARDPROT,true);
    316320#endif
    317321  add_area_holding_area_lock(a);
     
    800804  SetConsoleCtrlHandler(ControlEventHandler,TRUE);
    801805#else
    802   install_signal_handler(SIGINT, (void *)user_signal_handler, false);
    803   install_signal_handler(SIGTERM, (void *)user_signal_handler, false);
    804   install_signal_handler(SIGQUIT, (void *)user_signal_handler, false);
     806  install_signal_handler(SIGINT, (void *)user_signal_handler, false, false);
     807  install_signal_handler(SIGTERM, (void *)user_signal_handler, false, false);
     808  install_signal_handler(SIGQUIT, (void *)user_signal_handler, false, false);
    805809#endif
    806810}
     
    820824  if (user_signal_semaphores[signo] == 0) {
    821825    user_signal_semaphores[signo] = (natural)new_semaphore(0);
    822     install_signal_handler(signo,(void *)user_signal_handler, false);
     826    install_signal_handler(signo,(void *)user_signal_handler, false, false);
    823827  }
    824828  return wait_on_semaphore((void *)user_signal_semaphores[signo],seconds,milliseconds);
     
    13361340#define min_os_version "2.6"
    13371341#endif
     1342#ifdef ARM
     1343#define min_os_version "2.6"
     1344#endif
    13381345#endif
    13391346#ifdef FREEBSD
     
    15371544    tcr->vs_area->active = tcr->vs_area->high - node_size;
    15381545    tcr->save_vsp = (LispObj *)(tcr->vs_area->active);
     1546#ifndef ARM
    15391547    tcr->ts_area->active = tcr->ts_area->high;
    15401548    tcr->save_tsp = (LispObj *)(tcr->ts_area->active);
     1549#endif
    15411550    tcr->catch_top = 0;
    15421551    tcr->db_link = 0;
     
    18471856#ifdef X86
    18481857  lisp_global(SUBPRIMS_BASE) = (LispObj)((1<<16)+(5<<10));
    1849 #else
     1858#endif
     1859#ifdef PPC
    18501860  lisp_global(SUBPRIMS_BASE) = (LispObj)(5<<10);
    18511861#endif
     1862#ifdef ARM
     1863  lisp_global(SUBPRIMS_BASE) = (LispObj)(9<<12);
     1864#endif
     1865
    18521866  lisp_global(RET1VALN) = (LispObj)&ret1valn;
    18531867  lisp_global(LEXPR_RETURN) = (LispObj)&nvalret;
     
    19721986xMakeDataExecutable(void *start, unsigned long nbytes)
    19731987{
    1974 #ifndef X86
     1988#ifdef PPC
    19751989  extern void flush_cache_lines();
    19761990  natural ustart = (natural) start, base, end;
     
    19791993  end = (ustart + nbytes + cache_block_size - 1) & ~(cache_block_size-1);
    19801994  flush_cache_lines(base, (end-base)/cache_block_size, cache_block_size);
     1995#endif
     1996#ifdef ARM
     1997  extern void flush_cache_lines(void *, void *);
     1998  flush_cache_lines(start,((char *)start)+nbytes);
    19811999#endif
    19822000}
  • trunk/source/lisp-kernel/thread_manager.c

    r13869 r14119  
    13441344  a->owner = tcr;
    13451345  tcr->save_vsp = (LispObj *) a->active; 
     1346#ifndef ARM
    13461347  a = allocate_tstack_holding_area_lock(tstack_size);
     1348#endif
    13471349  UNLOCK(lisp_global(TCR_AREA_LOCK),tcr);
     1350#ifndef ARM
    13481351  tcr->ts_area = a;
    13491352  a->owner = tcr;
    13501353  tcr->save_tsp = (LispObj *) a->active;
     1354#endif
    13511355#ifdef X86
    13521356  tcr->next_tsp = tcr->save_tsp;
     
    13651369#endif
    13661370    (1 << MXCSR_PM_BIT);
     1371#endif
     1372#ifdef ARM
     1373  tcr->lisp_fpscr =
     1374    (1 << FPSCR_IOE_BIT) |
     1375    (1 << FPSCR_DZE_BIT) |
     1376    (1 << FPSCR_OFE_BIT);
    13671377#endif
    13681378  tcr->save_allocbase = tcr->save_allocptr = (void *) VOID_ALLOCPTR;
     
    14071417    vs = tcr->vs_area;
    14081418    tcr->vs_area = NULL;
     1419#ifndef ARM
    14091420    ts = tcr->ts_area;
    14101421    tcr->ts_area = NULL;
     1422#endif
    14111423    cs = tcr->cs_area;
    14121424    tcr->cs_area = NULL;
     
    14141426      condemn_area_holding_area_lock(vs);
    14151427    }
     1428#ifndef ARM
    14161429    if (ts) {
    14171430      condemn_area_holding_area_lock(ts);
    14181431    }
     1432#endif
    14191433    if (cs) {
    14201434      condemn_area_holding_area_lock(cs);
     
    14631477    a->active = a->high;
    14641478  }
     1479#ifndef ARM
    14651480  a = tcr->ts_area;
    14661481  if (a) {
    14671482    a->active = a->high;
    14681483  }
     1484#endif
    14691485  a = tcr->cs_area;
    14701486  if (a) {
     
    15161532  tcr->cs_area = a;
    15171533  a->owner = tcr;
     1534#ifdef ARM
     1535  tcr->last_lisp_frame = (natural)(a->high);
     1536#endif
    15181537  if (!(tcr->flags & (1<<TCR_FLAG_BIT_FOREIGN))) {
    15191538    tcr->cs_limit = (LispObj)ptr_to_lispobj(a->softlimit);
     
    19161935#endif
    19171936#ifdef X8632
     1937#define NSAVEREGS 0
     1938#endif
     1939#ifdef ARM
    19181940#define NSAVEREGS 0
    19191941#endif
     
    22492271  }
    22502272
     2273#ifndef ARM
    22512274  a = tcr->ts_area;
    22522275  if (a) {
    22532276    a->active = a->high;
    22542277  }
     2278#endif
    22552279
    22562280  a = tcr->cs_area;
  • trunk/source/lisp-kernel/x86-exceptions.c

    r13970 r14119  
    985985
    986986  if ((fulltag_of(cmain) == fulltag_misc) &&
    987              (header_subtag(header_of(cmain)) == subtag_macptr)) {
     987      (header_subtag(header_of(cmain)) == subtag_macptr)) {
    988988    xcf = create_exception_callback_frame(xp, tcr);
    989989    skip = callback_to_lisp(tcr, cmain, xp, xcf, SIGFPE, code, 0, 0);
     
    18601860#ifndef WINDOWS
    18611861void
    1862 install_signal_handler(int signo, void * handler, Boolean system)
     1862install_signal_handler(int signo, void * handler, Boolean system, Boolean on_altstack)
    18631863{
    18641864  struct sigaction sa;
     
    18731873    0 /* SA_RESTART */
    18741874#ifdef USE_SIGALTSTACK
    1875     | SA_ONSTACK
     1875    | on_altstack ? SA_ONSTACK : 0
    18761876#endif
    18771877    | SA_SIGINFO;
     
    20972097#endif
    20982098  ;
    2099   install_signal_handler(SIGILL, handler, true);
     2099  install_signal_handler(SIGILL, handler, true, true);
    21002100 
    2101   install_signal_handler(SIGBUS, handler, true);
    2102   install_signal_handler(SIGSEGV,handler, true);
    2103   install_signal_handler(SIGFPE, handler, true);
     2101  install_signal_handler(SIGBUS, handler, true, true);
     2102  install_signal_handler(SIGSEGV,handler, true, true);
     2103  install_signal_handler(SIGFPE, handler, true, true);
    21042104#endif
    21052105 
     
    21102110                         arbstack_interrupt_handler
    21112111#endif
    2112                          ,true);
     2112                         , true, true);
    21132113  signal(SIGPIPE, SIG_IGN);
    21142114}
     
    23042304  thread_kill_signal = SIG_KILL_THREAD;
    23052305
    2306   install_signal_handler(thread_suspend_signal, (void *)SUSPEND_RESUME_HANDLER, true);
    2307   install_signal_handler(thread_kill_signal, (void *)THREAD_KILL_HANDLER, true);
     2306  install_signal_handler(thread_suspend_signal, (void *)SUSPEND_RESUME_HANDLER, true, true);
     2307  install_signal_handler(thread_kill_signal, (void *)THREAD_KILL_HANDLER, true, true);
    23082308}
    23092309#endif
  • trunk/source/scripts/ccl

    r13416 r14119  
    2828              ppc*) OPENMCL_KERNEL=ppccl ;;
    2929              *86*) OPENMCL_KERNEL=lx86cl ;;
     30              *arm*) OPENMCL_KERNEL=armcl ;;
    3031           esac ;;
    3132    CYGWIN*)
  • trunk/source/xdump/xfasload.lisp

    r13279 r14119  
    10541054      ;; a function vector).  The code-vector in its 0th element should
    10551055      ;; report the appropriate error.
     1056      ;; On the ARM: make a two-element vector: entrypoint, code-vector.
    10561057      (let* ((udf-object (xload-make-gvector :simple-vector 1)))
    1057         (setf (xload-%svref udf-object 0) (xload-save-code-vector
    1058                                            (backend-xload-info-udf-code
    1059                                             *xload-target-backend*))))
     1058        (target-arch-case
     1059         (:arm
     1060          (setf (xload-%svref udf-object 0)
     1061                (+ (subprim-name->offset '.SPfix-nfn-entrypoint *target-backend*)
     1062                   #x40)))
     1063         (otherwise
     1064          (setf (xload-%svref udf-object 0)
     1065                (xload-save-code-vector
     1066                 (backend-xload-info-udf-code
     1067                  *xload-target-backend*))))))
    10601068      (let* ((udf-object (xload-make-gvector :simple-vector 1)))
    10611069        (setf (xload-%svref udf-object 0) (backend-xload-info-udf-code
Note: See TracChangeset for help on using the changeset viewer.