Changeset 13922


Ignore:
Timestamp:
Jul 5, 2010, 4:05:59 PM (9 years ago)
Author:
gb
Message:

More files from last commit.

arm-callback-support.lisp, arm-error-signal.lisp,
arm-trap-support.lisp,l1-boot-3.lisp: try to get basic stuff working
well enough to enable callbacks. Enable callbacks.

arm-backtrace.lisp: a little bit of platform-specific code and some
code from the PPC port, so that backtrace sort of works.

Location:
branches/arm
Files:
5 edited

Legend:

Unmodified
Added
Removed
  • branches/arm/level-1/arm-callback-support.lisp

    r13889 r13922  
    2626                 (byte 8 0)
    2727                 (arm-lap-word (mov r12 (:$ 0))))
    28             (%get-unsigned-byte p 4)
     28            (%get-unsigned-long p 4)
    2929            (dpb (ldb (byte 8 8) index)
    3030                 (byte 8 0)
     
    3232            (%get-unsigned-long p 8)
    3333            (arm-lap-word (ba .SPeabi-callback)))
    34             (ff-call (%kernel-import #.arm::kernel-import-makedataexecutable)
     34      (ff-call (%kernel-import #.arm::kernel-import-makedataexecutable)
    3535               :address p
    3636               :unsigned-fullword 12
  • branches/arm/level-1/arm-error-signal.lisp

    r13889 r13922  
    1616
    1717(in-package "CCL")
    18 
    19 (defcallback %xerr-disp ()
    20   )
     18(defparameter *arm-xtype-specifiers* (make-array 256 :initial-element nil))
     19
     20(macrolet ((init-arm-xtype-table (&rest pairs)
     21             (let* ((table (gensym)))
     22               (collect ((body))
     23                 (dolist (pair pairs)
     24                   (destructuring-bind (code . spec) pair
     25                     (body `(setf (svref ,table ,code) ',spec))))
     26                 `(let* ((,table *arm-xtype-specifiers*))
     27                   ,@(body))))))
     28  (init-arm-xtype-table
     29   (arm::tag-fixnum . fixnum)
     30   (arm::tag-list . list)
     31   (arm::xtype-integer . integer)
     32   (arm::xtype-s64 . (signed-byte 64))
     33   (arm::xtype-u64 . (unsigned-byte 64))
     34   (arm::xtype-s32 . (signed-byte 32))
     35   (arm::xtype-u32 . (unsigned-byte 32))
     36   (arm::xtype-s16 . (signed-byte 16))
     37   (arm::xtype-u16 . (unsigned-byte 16))
     38   (arm::xtype-s8  . (signed-byte 8))
     39   (arm::xtype-u8  . (unsigned-byte 8))
     40   (arm::xtype-bit . bit)
     41   (arm::xtype-rational . rational)
     42   (arm::xtype-real . real)
     43   (arm::xtype-number . number)
     44   (arm::xtype-char-code . (mod #x110000))
     45   (arm::xtype-unsigned-byte-24 . (unsigned-byte 24))
     46   (arm::xtype-array2d . (array * (* *)))
     47   (arm::xtype-array3d . (array * (* * *)))
     48   (arm::subtag-bignum . bignum)
     49   (arm::subtag-ratio . ratio)
     50   (arm::subtag-single-float . single-float)
     51   (arm::subtag-double-float . double-float)
     52   (arm::subtag-complex . complex)
     53   (arm::subtag-macptr . macptr)
     54   (arm::subtag-code-vector . code-vector)
     55   (arm::subtag-xcode-vector . xcode-vector)
     56   (arm::subtag-catch-frame . catch-frame)
     57   (arm::subtag-function . function)
     58   (arm::subtag-basic-stream . basic-stream)
     59   (arm::subtag-symbol . symbol)
     60   (arm::subtag-lock . lock)
     61   (arm::subtag-hash-vector . hash-vector)
     62   (arm::subtag-pool . pool)
     63   (arm::subtag-weak . population)
     64   (arm::subtag-package . package)
     65   (arm::subtag-slot-vector . slot-vector)
     66   (arm::subtag-instance . standard-object)
     67   (arm::subtag-struct . structure-object)
     68   (arm::subtag-istruct . istruct)      ;??
     69   (arm::subtag-value-cell . value-cell)
     70   (arm::subtag-xfunction . xfunction)
     71   (arm::subtag-arrayH . array-header)
     72   (arm::subtag-vectorH . vector-header)
     73   (arm::subtag-simple-vector . simple-vector)
     74   (arm::subtag-single-float-vector . (simple-array single-float (*)))
     75   (arm::subtag-u32-vector . (simple-array (unsigned-byte 32) (*)))
     76   (arm::subtag-s32-vector . (simple-array (signed-byte 32) (*)))
     77   (arm::subtag-fixnum-vector . (simple-array fixnum (*)))
     78   (arm::subtag-simple-base-string . simple-base-string)
     79   (arm::subtag-u8-vector . (simple-array (unsigned-byte 8) (*)))
     80   (arm::subtag-s8-vector . (simple-array (signed-byte 8) (*)))   
     81   (arm::subtag-u16-vector . (simple-array (unsigned-byte 16) (*)))
     82   (arm::subtag-double-float-vector . (simple-array double-float (*)))
     83   (arm::subtag-bit-vector . simple-bit-vector)))
     84
     85(defun xp-argument-list (xp)
     86  (let ((nargs (xp-gpr-lisp xp arm::nargs))     ; tagged as a fixnum (how convenient)
     87        (arg-x (xp-gpr-lisp xp arm::arg_x))
     88        (arg-y (xp-gpr-lisp xp arm::arg_y))
     89        (arg-z (xp-gpr-lisp xp arm::arg_z)))
     90    (cond ((eql nargs 0) nil)
     91          ((eql nargs 1) (list arg-z))
     92          ((eql nargs 2) (list arg-y arg-z))
     93          (t (let ((args (list arg-x arg-y arg-z)))
     94               (if (eql nargs 3)
     95                 args
     96                 (let ((vsp (xp-gpr-macptr xp arm::vsp)))
     97                   (dotimes (i (- nargs 3))
     98                     (push (%get-object vsp (* i target::node-size)) args))
     99                   args)))))))
     100
     101(defun handle-udf-call (xp frame-ptr)
     102  (let* ((args (xp-argument-list xp))
     103         (values (multiple-value-list
     104                  (%kernel-restart-internal
     105                   $xudfcall
     106                   (list (maybe-setf-name (xp-gpr-lisp xp arm::fname)) args)
     107                   frame-ptr)))
     108         (stack-argcnt (max 0 (- (length args) 3)))
     109         (vsp (%i+ (xp-gpr-lisp xp arm::vsp) stack-argcnt))
     110         (f #'(lambda (values) (apply #'values values))))
     111    (setf (xp-gpr-lisp xp arm::vsp) vsp
     112          (xp-gpr-lisp xp arm::nargs) 1
     113          (xp-gpr-lisp xp arm::arg_z) values
     114          (xp-gpr-lisp xp arm::nfn) f)
     115    ;; handle_uuo() (in the lisp kernel) will not bump the PC here.
     116    (setf (xp-gpr-lisp xp arm::pc) (uvref f 0))))
     117   
     118(defcallback %xerr-disp (:address xp
     119                                  :signed-fullword error-number
     120                                  :unsigned-fullword arg
     121                                  :unsigned-fullword fnreg
     122                                  :unsigned-fullword relative-pc)
     123  ;; We'll clearly need some sort of xcf/fake-stack-frame -like mechanism.
     124  (let* ((frame-ptr (%get-frame-ptr))
     125         (fn (unless (eql fnreg 0) (xp-gpr-lisp xp fnreg))))
     126    (with-error-reentry-detection
     127        (cond
     128          ((eql 0 error-number)         ; Hopefully a UUO.
     129           (if (/= (logand arg #x0ff000f0) #x07f000f0)
     130             (%error "Unknown non-UUO: #x~x" (list arg) frame-ptr)
     131             (let* ((condition (ldb (byte 4 28) arg))
     132                    (uuo (ldb (byte 28 0) arg))
     133                    (format (ldb (byte 4 0) uuo)))
     134               (declare (fixnum condition uuo format))
     135               (case format
     136                 ((2 10)                ; uuo-format-[c]error-lisptag
     137                  (%error (make-condition
     138                           'type-error
     139                           :datum (xp-gpr-lisp xp (ldb (byte 4 8) uuo))
     140                           :expected-type
     141                           (svref #(fixnum list uvector immediate)
     142                                  (ldb (byte 2 12) uuo)))
     143                          nil
     144                          frame-ptr))
     145                 ((3 11)
     146                  (%error (make-condition
     147                           'type-error
     148                           :datum (xp-gpr-lisp xp (ldb (byte 4 8) uuo))
     149                           :expected-type
     150                           (svref #(fixnum cons bogus immediate fixnum null uvector bogus)
     151                                  (ldb (byte 3 12) uuo)))
     152                          nil
     153                          frame-ptr))
     154                 ((4 12)
     155                  (%error (make-condition
     156                           'type-error
     157                           :datum (xp-gpr-lisp xp (ldb (byte 4 8) uuo))
     158                           :expected-type
     159                           (svref *arm-xtype-specifiers* (ldb (byte 8 12) uuo)))
     160                          nil
     161                          frame-ptr))
     162                 (8                     ;nullary error.  Only one, atm.
     163                  (case (ldb (byte 12 8) uuo)
     164                    (1                  ;why 1?
     165                     (let* ((condition-name
     166                             (cond ((eq condition arm::arm-cond-lo)
     167                                    'too-few-arguments)
     168                                   ((eq condition arm::arm-cond-hs)
     169                                    'too-many-arguments)
     170                                   (t
     171                                    ;;(assert condition arm::arm-cond-ne)
     172                                    (let* ((cpsr (xp-gpr-signed-long xp
     173                                                                     xp-cpsr-regno)))
     174                                      (if (logbitp 29 cpsr)
     175                                        'too-many-arguments
     176                                        'too-few-arguments))))))
     177                       (%error condition-name
     178                               (list :nargs (xp-gpr-lisp xp arm::nargs)
     179                                     :fn fn)
     180                               frame-ptr)))
     181                    (t
     182                     (%error "Unknown nullary UUO code ~d"
     183                             (list (ldb (byte 12 8) uuo))
     184                             frame-ptr))))
     185                 (9                     ;unary error
     186                  (let* ((code (ldb (byte 8 12) uuo))
     187                         (regno (ldb (byte 4 8) uuo))
     188                         (arg (xp-gpr-lisp xp regno)))
     189                    (case code
     190                      ((0 1)
     191                       (setf (xp-gpr-lisp xp regno)
     192                             (%kernel-restart-internal $xvunbnd
     193                                                       (list arg)
     194                                                       frame-ptr)))
     195                      (2
     196                       (%error (make-condition 'type-error
     197                                               :datum arg
     198                                               :expected-type '(or symbol function)
     199                                               :format-control
     200                                               "~S is not of type ~S, and can't be FUNCALLed or APPLYed")
     201                               nil frame-ptr))
     202                      (4
     203                       (%error (make-condition 'cant-throw-error
     204                                               :tag arg)
     205                               nil frame-ptr))
     206                      (5
     207                       (handle-udf-call xp frame-ptr))
     208                      (6
     209                       (%err-disp-internal $xfunbnd (list arg) frame-ptr))
     210                      (t
     211                       (error "Unknown unary UUO with code ~d." code)))))
     212                 (14
     213                  (let* ((reg-a (ldb (byte 4 8) uuo))
     214                         (arg-b (xp-gpr-lisp xp (ldb (byte 4 12) uuo)))
     215                         (arg-c (xp-gpr-lisp xp (ldb (byte 4 16) uuo))))
     216                    (setf (xp-gpr-lisp xp reg-a)
     217                          (%slot-unbound-trap arg-b arg-c frame-ptr))))
     218                 (15
     219                  (let* ((reg-a (ldb (byte 4 8) uuo))
     220                         (arga (xp-gpr-lisp xp reg-a))
     221                         (argb (xp-gpr-lisp xp (ldb (byte 4 12) uuo)))
     222                         (code (ldb (byte 4 16) uuo)))
     223                    (case code
     224                      ((0 1)            ;do we report these the same way?
     225                       (%error (%rsc-string $xarroob)
     226                               (list arga argb)
     227                               frame-ptr))
     228                      (4
     229                       (let* ((eep-or-fv (xp-gpr-lisp xp (ldb (byte 4 12) uuo)))
     230                              (dest-reg (ldb (byte 4 8) uuo)))
     231                         (etypecase eep-or-fv
     232                           (external-entry-point
     233                            (resolve-eep eep-or-fv)
     234                            (setf (xp-gpr-lisp xp dest-reg)
     235                                  (eep.address eep-or-fv)))
     236                           (foreign-variable
     237                            (resolve-foreign-variable eep-or-fv)
     238                            (setf (xp-gpr-lisp xp dest-reg)
     239                                  (fv.addr eep-or-fv))))))
     240                      (t
     241                       (error "Unknown code in binary UUO: ~d" code)))))
     242                 (t
     243                  (error "Unknown UUO, format ~d" format))))))
     244          (t
     245           (error "%errdisp callback: error-number = ~d, arg = #x~x, fnreg = ~d, rpc = ~d"
     246                  error-number arg fnreg relative-pc))))))
  • branches/arm/level-1/arm-trap-support.lisp

    r13903 r13922  
    3131    (setq register-number (require-type register-number '(integer -3 (18)))))
    3232  (the fixnum (* (the fixnum (+ register-number 3)) arm::node-size)))
     33(defconstant xp-cpsr-regno 16)
    3334)
    3435
     
    4445  (with-xp-registers-and-gpr-offset (xp register-number) (registers offset)
    4546    (values (%get-signed-long registers offset))))
    46 
    4747
    4848(defun xp-gpr-signed-doubleword (xp register-number)
     
    6060                     :signed-fullword fnreg
    6161                     :signed-fullword offset)
    62   (error "xcmain callback")
    63   )
     62  (cond ((eql signal 0) (cmain))
     63        ((or (eql signal #$SIGBUS)
     64             (eql signal #$SIGSEGV))
     65         (%error (make-condition 'invalid-memory-access
     66                                 :address arg
     67                                 :write-p (eql signal #$SIGBUS))
     68                 ()
     69                 (%get-frame-ptr)))
     70        (t
     71         (error "cmain callback: signal = ~d, arg = #x~x, fnreg = ~d, offset = ~d"
     72                signal arg fnreg offset))))
  • branches/arm/level-1/l1-boot-3.lisp

    r13897 r13922  
    2626)
    2727
    28 #+arm-target
    29 (eval-when (:compile-toplevel)
    30   (warn "Remember to reenable error callbacks."))
    3128(set-periodic-task-interval .33)
    32 #-arm-target (setq cmain xcmain)
    33 #-arm-target (setq %err-disp %xerr-disp)
     29(setq cmain xcmain)
     30(setq %err-disp %xerr-disp)
    3431
    3532;;;end of l1-boot-3.lisp
  • branches/arm/lib/arm-backtrace.lisp

    r13918 r13922  
    3232          (return t)))
    3333      (setq catch (next-catch catch)))))
     34
     35(defun %stack< (index1 index2 &optional context)
     36  (let* ((tcr (if context (bt.tcr context) (%current-tcr)))
     37         (cs-area (%fixnum-ref tcr target::tcr.cs-area)))
     38    (and (%ptr-in-area-p index1 cs-area)
     39         (%ptr-in-area-p index2 cs-area)
     40         (< (the fixnum index1) (the fixnum index2)))))
     41
     42(defun registers-used-by (lfun &optional at-pc)
     43  (declare (ignore lfun at-pc))
     44  (values nil nil))
     45
     46(defun exception-frame-p (f)
     47  (fake-stack-frame-p f))
     48
     49
     50;;; Used for printing only.
     51(defun index->address (p)
     52  (when (fake-stack-frame-p p)
     53    (setq p (%fake-stack-frame.sp p)))
     54  (ldb (byte  32 0)  (ash p arm::fixnumshift)))
     55
     56(defun %raw-frame-ref (cfp context idx bad)
     57  (declare (fixnum idx))
     58  (multiple-value-bind (frame base)
     59      (vsp-limits cfp context)
     60    (let* ((raw-size (- base frame)))
     61      (declare (fixnum frame base raw-size))
     62      (if (and (>= idx 0)
     63               (< idx raw-size))
     64        (let* ((addr (- (the fixnum (1- base))
     65                        idx)))
     66          (multiple-value-bind (db-count first-db last-db)
     67              (count-db-links-in-frame frame base context)
     68            (let* ((is-db-link
     69                    (unless (zerop db-count)
     70                      (do* ((last last-db (previous-db-link last first-db)))
     71                           ((null last))
     72                        (when (= addr last)                          (return t))))))
     73              (if is-db-link
     74                (oldest-binding-frame-value context addr)
     75                (%fixnum-ref addr)))))
     76        bad))))
     77
     78;;; Return two values: the vsp of p and the vsp of p's "parent" frame.
     79;;; The "parent" frame vsp might actually be the end of p's segment,
     80;;; if the real "parent" frame vsp is in another segment.
     81(defun vsp-limits (p context)
     82  (let* ((vsp (%frame-savevsp p))
     83         parent)
     84    (when (eql vsp 0)
     85      ; This frame is where the code continues after an unwind-protect cleanup form
     86      (setq vsp (%frame-savevsp (child-frame p context))))
     87    (flet ((grand-parent (frame)
     88             (let ((parent (parent-frame frame context)))
     89               (when (and parent (eq parent (%frame-backlink frame context)))
     90                 (let ((grand-parent (parent-frame parent context)))
     91                   (when (and grand-parent (eq grand-parent (%frame-backlink parent context)))
     92                     grand-parent))))))
     93      (declare (dynamic-extent #'grand-parent))
     94      (let* ((frame p)
     95             grand-parent)
     96        (loop
     97          (setq grand-parent (grand-parent frame))
     98          (when (or (null grand-parent) (not (eql 0 (%frame-savevsp grand-parent))))
     99            (return))
     100          (setq frame grand-parent))
     101        (setq parent (parent-frame frame context)))
     102      (let* ((parent-vsp (if parent (%frame-savevsp parent) vsp))
     103             (tcr (if context (bt.tcr context) (%current-tcr)))
     104             (vsp-area (%fixnum-ref tcr target::tcr.vs-area)))
     105        (if (eql 0 parent-vsp)
     106          (values vsp vsp)              ; p is the kernel frame pushed by an unwind-protect cleanup form
     107          (progn
     108            (unless vsp-area
     109              (error "~s is not a stack frame pointer for context ~s" p tcr))
     110            (unless (%ptr-in-area-p parent-vsp vsp-area)
     111              (setq parent-vsp (%fixnum-ref vsp-area target::area.high)))
     112            (values vsp parent-vsp)))))))
     113
     114(defun %frame-savevsp (p)
     115  (if (fake-stack-frame-p p)
     116    (%fake-stack-frame.vsp p)
     117    (%%frame-savevsp p)))
Note: See TracChangeset for help on using the changeset viewer.