Changeset 13968 for branches


Ignore:
Timestamp:
Jul 16, 2010, 4:15:38 AM (14 years ago)
Author:
Gary Byers
Message:

Fix bogosity in _SPcall_closure.
Start checking for FP exceptions (need to do this in software); compiler
generates checks unless unsafe. (Should maybe use a new policy hook for
this.)
Adapt PPC fake-stack-frame code to make backtrace/error reporting better.

Location:
branches/arm
Files:
16 edited

Legend:

Unmodified
Added
Removed

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

    r13962 r13968  
    838838  prev                                  ; in doubly-linked list
    839839  next                                  ; in doubly-linked list
    840   lisp-fpscr-high
    841   lisp-fpscr-low
     840  lisp-fpscr
     841  pad
    842842  db-link                               ; special binding chain head
    843843  catch-top                             ; top catch frame
    … …  
    13791379  al)
    13801380
     1381;;; FPSCR exception bits
     1382(defconstant ioc 0)                     ;invalid operation
     1383(defconstant dzc 1)                     ;division by 0
     1384(defconstant ofc 2)                     ;overflow
     1385(defconstant ufc 3)                     ;underflow
     1386(defconstant ixc 4)                     ;inexact
     1387
     1388(defconstant ioe 8)                     ;invalid operation enable
     1389(defconstant dze 9)                     ;division by 0 enable
     1390(defconstant ofe 10)                    ;overflow enable
     1391(defconstant ufe 11)                    ;underflow enable
     1392(defconstant ixe 12)                    ;inexact enable
     1393
    13811394;;; A function's entrypoint should initially reference .SPfix-nfn-entrypoint,
    13821395;;; which will set it to a locative to the function's code-vector.

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

    r13957 r13968  
    521521   (define-arm-instruction strd  (:rde :mem8)
    522522     #x000000f0
    523      #x0e4000f0
     523     #x0e1000f0
    524524     ())
    525525

  • branches/arm/compiler/ARM/arm-backend.lisp

    r13962 r13968  
    319319
    320320
    321 (defmacro with-fake-stack-frame ((var sp next-sp fn lr vsp xp) &body body)
    322   `(let* ((,var (ccl::%istruct 'arm::fake-stack-frame ,sp ,next-sp ,fn ,lr ,vsp ,xp)))
    323     (declare (dynamic-extent ,var) (ignorable ,var))
    324     ,@body))
     321(defmacro make-fake-stack-frame (sp next-sp fn lr vsp xp)
     322  `(ccl::%istruct 'arm::fake-stack-frame ,sp ,next-sp ,fn ,lr ,vsp ,xp))
    325323
    326324(require "ARM-VINSNS")

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

    r13962 r13968  
    12431243  (fsitod dest temp))
    12441244
     1245
    12451246(define-arm-vinsn (fixnum->single :predicatable)
    12461247    (((dest :single-float))
    … …  
    12511252  (fsitos dest dest))
    12521253
     1254(define-arm-vinsn (fixnum->single-safe :call :subprim-call)
     1255    (((dest :single-float))
     1256     ((src :lisp))
     1257     ((imm :s32)))
     1258  (mov imm (:asr src (:$ arm::fixnumshift)))
     1259  (fmsr dest imm)
     1260  (fsitos dest dest)
     1261  (bl .SPcheck-fpu-exception))
    12531262
    12541263(define-arm-vinsn (shift-left-variable-word :predicatable)
    … …  
    14471456             
    14481457
    1449 (define-arm-vinsn double-float+-2 (((result :double-float))
    1450                                    ((x :double-float)
    1451                                     (y :double-float)))
     1458(define-arm-vinsn (double-float+-2 :predicatable)
     1459    (((result :double-float))
     1460     ((x :double-float)
     1461      (y :double-float)))
    14521462  (faddd result x y))
    14531463
    1454 (define-arm-vinsn double-float--2 (((result :double-float))
    1455                                    ((x :double-float)
    1456                                     (y :double-float)))
     1464(define-arm-vinsn (double-float+-2-safe :call :subprim-call)
     1465    (((result :double-float))
     1466     ((x :double-float)
     1467      (y :double-float)))
     1468  (faddd result x y)
     1469  (bl .SPcheck-fpu-exception))
     1470
     1471(define-arm-vinsn (double-float--2 :predicatable)
     1472    (((result :double-float))
     1473     ((x :double-float)
     1474      (y :double-float)))
    14571475  (fsubd result x y))
    14581476
    1459 (define-arm-vinsn double-float*-2 (((result :double-float))
    1460                                    ((x :double-float)
    1461                                     (y :double-float)))
     1477(define-arm-vinsn (double-float-2-safe :call :subprim-call)
     1478    (((result :double-float))
     1479     ((x :double-float)
     1480      (y :double-float)))
     1481  (fsubd result x y)
     1482  (bl .SPcheck-fpu-exception))
     1483
     1484(define-arm-vinsn (double-float*-2 :predicatable)
     1485    (((result :double-float))
     1486     ((x :double-float)
     1487      (y :double-float)))
    14621488  (fmuld result x y))
    14631489
    1464 (define-arm-vinsn double-float/-2 (((result :double-float))
    1465                                    ((x :double-float)
    1466                                     (y :double-float)))
     1490(define-arm-vinsn (double-float*-2-safe :call :subprim-call)
     1491    (((result :double-float))
     1492     ((x :double-float)
     1493      (y :double-float)))
     1494  (fmuld result x y)
     1495  (bl .SPcheck-fpu-exception))
     1496
     1497(define-arm-vinsn (double-float/-2-safe :predicatable)
     1498    (((result :double-float))
     1499     ((x :double-float)
     1500      (y :double-float)))
    14671501  (fdivd result x y))
     1502
     1503(define-arm-vinsn (double-float/-2-safe :call :subprim-call)
     1504    (((result :double-float))
     1505     ((x :double-float)
     1506      (y :double-float)))
     1507  (fdivd result x y)
     1508  (bl .SPcheck-fpu-exception))
    14681509
    14691510
    … …  
    14751516  (fmstat))
    14761517
    1477 (define-arm-vinsn single-float+-2 (((result :single-float))
    1478                                    ((x :single-float)
    1479                                     (y :single-float))
    1480                                    ())
     1518(define-arm-vinsn (single-float+-2 :predicatable)
     1519    (((result :single-float))
     1520     ((x :single-float)
     1521      (y :single-float))
     1522     ())
    14811523  (fadds result x y))
    14821524
    1483 (define-arm-vinsn single-float--2 (((result :single-float))
    1484                                    ((x :single-float)
    1485                                     (y :single-float)))
     1525(define-arm-vinsn (single-float+-2-safe :call :subprim-call)
     1526    (((result :single-float))
     1527     ((x :single-float)
     1528      (y :single-float))
     1529     ())
     1530  (fadds result x y)
     1531  (bl .SPcheck-fpu-exception))
     1532
     1533(define-arm-vinsn (single-float--2 :predicatable)
     1534    (((result :single-float))
     1535     ((x :single-float)
     1536      (y :single-float)))
    14861537  (fsubs result x y))
    14871538
    1488 (define-arm-vinsn single-float*-2 (((result :single-float))
    1489                                    ((x :single-float)
    1490                                     (y :single-float)))
     1539(define-arm-vinsn (single-float--2-safe :call :subprim-call)
     1540    (((result :single-float))
     1541     ((x :single-float)
     1542      (y :single-float)))
     1543  (fsubs result x y)
     1544  (bl .SPcheck-fpu-exception))
     1545
     1546(define-arm-vinsn (single-float*-2 :predicatable)
     1547    (((result :single-float))
     1548     ((x :single-float)
     1549      (y :single-float)))
    14911550  (fmuls result x y))
    14921551
    1493 (define-arm-vinsn single-float/-2 (((result :single-float))
    1494                                    ((x :single-float)
    1495                                     (y :single-float)))
     1552(define-arm-vinsn (single-float*-2-safe :call :subprim-call)
     1553    (((result :single-float))
     1554     ((x :single-float)
     1555      (y :single-float)))
     1556  (fmuls result x y)
     1557  (bl .SPcheck-fpu-exception))
     1558
     1559(define-arm-vinsn (single-float/-2 :predicatable)
     1560    (((result :single-float))
     1561     ((x :single-float)
     1562      (y :single-float)))
    14961563  (fdivs result x y))
    14971564
    1498 
     1565(define-arm-vinsn (single-float/-2-safe :call :subprim-call)
     1566    (((result :single-float))
     1567     ((x :single-float)
     1568      (y :single-float)))
     1569  (fdivs result x y)
     1570  (bl .SPcheck-fpu-exception))
    14991571
    15001572

  • branches/arm/compiler/ARM/arm2.lisp

    r13955 r13968  
    4747          (*arm2-open-code-inline* *arm2-open-code-inline*)
    4848          (*arm2-trust-declarations* *arm2-trust-declarations*)
    49           (*arm2-full-safety* *arm2-full-safety*))
     49          (*arm2-full-safety* *arm2-full-safety*)
     50          (*arm2-float-safety* *arm2-float-safety*))
    5051     (arm2-decls ,declsform)
    5152     ,@body))
    … …  
    155156(defvar *arm2-reckless* nil)
    156157(defvar *arm2-full-safety* nil)
     158(defvar *arm2-float-safety* nil)
    157159(defvar *arm2-trust-declarations* nil)
    158160(defvar *arm2-entry-vstack* nil)
    … …  
    403405           (*arm2-reckless* nil)
    404406           (*arm2-full-safety* nil)
     407           (*arm2-float-safety* nil)
    405408           (*arm2-trust-declarations* t)
    406409           (*arm2-entry-vstack* nil)
    … …  
    665668            *arm2-full-safety* (neq 0 (%ilogand2 $decl_full_safety decls))
    666669            *arm2-reckless* (neq 0 (%ilogand2 $decl_unsafe decls))
     670            *arm2-float-safety* (not *arm2-reckless*)
    667671            *arm2-trust-declarations* (neq 0 (%ilogand2 $decl_trustdecls decls))))))
    668672
    … …  
    67356739 
    67366740(eval-when (:compile-toplevel :execute)
    6737   (defmacro defarm2-df-op (fname opname vinsn)
     6741  (defmacro defarm2-df-op (fname opname vinsn safe-vinsn)
    67386742    `(defarm2 ,fname ,opname (seg vreg xfer f0 f1)
    67396743       (if (null vreg)
    … …  
    67456749             (multiple-value-bind (r1 r2) (arm2-two-untargeted-reg-forms seg f0 r1 f1 r2)
    67466750               (if (= (hard-regspec-class vreg) hard-reg-class-fpr)
    6747                  (! ,vinsn vreg r1 r2)
     6751                 (if *arm2-float-safety*
     6752                     (! ,safe-vinsn vreg r1 r2)
     6753                     (! ,vinsn vreg r1 r2))
    67486754                 (with-fp-target (r1 r2) (result :double-float)
    6749                    (! ,vinsn result r1 r2)
     6755                   (if *arm2-float-safety*
     6756                     (! ,safe-vinsn result r1 r2)
     6757                     (! ,vinsn result r1 r2))
    67506758                   (ensuring-node-target (target vreg)
    67516759                     (arm2-copy-register seg target result))))
    67526760               (^)))))))
    67536761 
    6754   (defmacro defarm2-sf-op (fname opname vinsn)
     6762  (defmacro defarm2-sf-op (fname opname vinsn safe-vinsn)
    67556763    `(defarm2 ,fname ,opname (seg vreg xfer f0 f1)
    67566764       (if (null vreg)
    … …  
    67626770             (multiple-value-bind (r1 r2) (arm2-two-untargeted-reg-forms seg f0 r1 f1 r2)
    67636771               (if (= (hard-regspec-class vreg) hard-reg-class-fpr)
    6764                  (! ,vinsn vreg r1 r2)
     6772                 (if *arm2-float-safety*
     6773                   (! ,safe-vinsn vreg r1 r2)
     6774                   (! ,vinsn vreg r1 r2))
    67656775                 (with-fp-target (r1 r2) (result :single-float)
    6766                    (! ,vinsn result r1 r2)
     6776                   (if *arm2-float-safety*
     6777                     (! ,safe-vinsn result r1 r2)
     6778                     (! ,vinsn result r1 r2))
    67676779                   (ensuring-node-target (target vreg)
    67686780                     (arm2-copy-register seg target result))))
    … …  
    67706782)
    67716783
    6772 (defarm2-df-op arm2-%double-float+-2 %double-float+-2 double-float+-2)
    6773 (defarm2-df-op arm2-%double-float--2 %double-float--2 double-float--2)
    6774 (defarm2-df-op arm2-%double-float*-2 %double-float*-2 double-float*-2)
    6775 (defarm2-df-op arm2-%double-float/-2 %double-float/-2 double-float/-2)
    6776 
    6777 (defarm2-sf-op arm2-%short-float+-2 %short-float+-2 single-float+-2)
    6778 (defarm2-sf-op arm2-%short-float--2 %short-float--2 single-float--2)
    6779 (defarm2-sf-op arm2-%short-float*-2 %short-float*-2 single-float*-2)
    6780 (defarm2-sf-op arm2-%short-float/-2 %short-float/-2 single-float/-2)
     6784(defarm2-df-op arm2-%double-float+-2 %double-float+-2 double-float+-2 double-float+-2-safe)
     6785(defarm2-df-op arm2-%double-float--2 %double-float--2 double-float--2 double-float-2-safe)
     6786(defarm2-df-op arm2-%double-float*-2 %double-float*-2 double-float*-2 double-float*-2-safe)
     6787(defarm2-df-op arm2-%double-float/-2 %double-float/-2 double-float/-2 double-float/-2-safe)
     6788
     6789(defarm2-sf-op arm2-%short-float+-2 %short-float+-2 single-float+-2 single-float+-2-safe)
     6790(defarm2-sf-op arm2-%short-float--2 %short-float--2 single-float--2 single-float--2-safe)
     6791(defarm2-sf-op arm2-%short-float*-2 %short-float*-2 single-float*-2 single-float*-2-safe)
     6792(defarm2-sf-op arm2-%short-float/-2 %short-float/-2 single-float/-2 single-float/-2-safe)
    67816793
    67826794(defun arm2-get-float (seg vreg xfer ptr offset double-p fp-reg)
    … …  
    85138525                  *arm2-reckless*)
    85148526        (! trap-unless-fixnum r))
    8515       (! fixnum->single dreg r)
     8527      (if *arm2-float-safety*
     8528        (! fixnum->single-safe dreg r)
     8529        (! fixnum->single dreg r))
    85168530      (<- dreg)
    85178531      (^))))

  • branches/arm/level-0/ARM/arm-bignum.lisp

    r13944 r13968  
    11261126    (set-nargs 2)
    11271127    (ba .SPnvalret)))
     1128
     1129;;; For TRUNCATE-BY-FIXNUM et al.
     1130;;; Doesn't store quotient: just returns rem in 2 halves.
     1131(defarmlapfunction %floor-loop-no-quo ((x arg_x) (yhi arg_y) (ylo arg_z))
     1132  (let ((len temp1))
     1133    (build-lisp-frame)
     1134    (vector-length len x imm0)
     1135    (mov imm2 (:$ 0))
     1136    (b @next)
     1137    @loop
     1138    (add imm0 len (:$ arm::misc-data-offset))
     1139    (ldr imm0 (:@ x imm0))
     1140    (mov imm1 imm2)
     1141    (compose-digit imm2 yhi ylo)
     1142    (bl .SPudiv64by32)
     1143    @next
     1144    (subs len len '1)
     1145    (bge @loop)
     1146    (digit-h yhi imm2)
     1147    (digit-l ylo imm2)
     1148    (vpush1 yhi)
     1149    (vpush1 ylo)
     1150    (set-nargs 2)
     1151    (ba .SPnvalret)))
     1152   
     1153   
     1154
    11281155   
    11291156   

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

    r13926 r13968  
    5757
    5858(defarmlapfunction %fixnum-ref ((fixnum arg_y) #| &optional |# (offset arg_z))
     59  (:arglist fixnum &optional offset)
    5960  (check-nargs 1 2)
    6061  (cmp nargs '1)
    … …  
    6768
    6869(defarmlapfunction %fixnum-ref-natural ((fixnum arg_y) #| &optional |# (offset arg_z))
     70  (:arglist fixnum &optional offset)
    6971  (check-nargs 1 2)
    7072  (cmp nargs '1)
    … …  
    261263  (bx lr))
    262264
    263 
     265(defarmlapfunction %dnode-address-of ((x arg_z))
     266  (check-nargs 1)
     267  (bic arg_z x (:$ arm::fulltagmask))
     268  (bx lr))
    264269
    265270(defarmlapfunction %save-standard-binding-list ((bindings arg_z))

  • branches/arm/level-0/ARM/arm-float.lisp

    r13941 r13968  
    276276  (declare (ignore operation op0 fp-status)))
    277277
    278 (defun get-fpu-mode (mode) nil)
    279 
    280 (defun set-fpu-mode (mode value) nil)
    281 
    282 
    283 
     278(defvar *rounding-mode-alist*
     279  '((:nearest . 0) (:positive . 1) (:negative . 2) (:zero . 3)))
     280
     281(defun get-fpu-mode (&optional (mode nil mode-p))
     282  (let* ((flags (%get-fpscr-control)))
     283    (declare (fixnum flags))
     284    (let* ((rounding-mode
     285            (car (nth (ldb (byte 2 22) flags) *rounding-mode-alist*)))
     286           (overflow (logbitp arm::ofe flags))
     287           (underflow (logbitp arm::ufe flags))
     288           (division-by-zero (logbitp arm::dze flags))
     289           (invalid (logbitp arm::ioe flags))
     290           (inexact (logbitp arm::ixe flags)))
     291    (if mode-p
     292      (ecase mode
     293        (:rounding-mode rounding-mode)
     294        (:overflow overflow)
     295        (:underflow underflow)
     296        (:division-by-zero division-by-zero)
     297        (:invalid invalid)
     298        (:inexact inexact))
     299      `(:rounding-mode ,rounding-mode
     300        :overflow ,overflow
     301        :underflow ,underflow
     302        :division-by-zero ,division-by-zero
     303        :invalid ,invalid
     304        :inexact ,inexact)))))
     305
     306;;; did we document this?
     307(defun set-fpu-mode (&key (rounding-mode :nearest rounding-p)
     308                          (overflow t overflow-p)
     309                          (underflow t underflow-p)
     310                          (division-by-zero t zero-p)
     311                          (invalid t invalid-p)
     312                          (inexact t inexact-p))
     313  (let* ((current (%get-fpscr-control))
     314         (new current))
     315    (declare (fixnum current new))
     316    (when rounding-p
     317      (let* ((rc-bits (or
     318                       (cdr (assoc rounding-mode *rounding-mode-alist*))
     319                       (error "Unknown rounding mode: ~s" rounding-mode))))
     320        (declare (fixnum rc-bits))
     321        (setq new (dpb rc-bits (byte 2 22) new))))
     322    (when invalid-p
     323      (if invalid
     324        (bitclrf arm::ioe new)
     325        (bitsetf arm::ioe new)))
     326    (when overflow-p
     327      (if overflow
     328        (bitclrf arm::ofe new)
     329        (bitsetf arm::ofe new)))
     330    (when underflow-p
     331      (if underflow
     332        (bitclrf arm::ufe new)
     333        (bitsetf arm::ufe new)))
     334    (when zero-p
     335      (if division-by-zero
     336        (bitclrf arm::dze new)
     337        (bitsetf arm::dze new)))
     338    (when inexact-p
     339      (if inexact
     340        (bitclrf arm::ixe new)
     341        (bitsetf arm::ixe new)))
     342    (unless (= current new)
     343      (%set-fpscr-control new))
     344    (%get-fpscr)))
     345
     346
     347
     348;;; Manipulating the FPSCR.  Keeping FP exception enable bits in
     349;;; the FPSCR doesn't do us a whole lot of good; the NEON doesn't
     350;;; support traps on FP exceptions, and some OSes (the World's
     351;;; Most Advanced, in particular) reboot when a process gets an
     352;;; enabled trapping FP exception on older hardware.
     353;;; So: we keep the (logical) enabled exception mask in tcr.lisp-fpscr,
     354;;; and just store the rounding mode in the hardware FPSCR.
     355
     356(defarmlapfunction %get-fpscr-control ()
     357  (fmrx imm0 :fpscr)
     358  (ldr imm1 (:@ rcontext (:$ arm::tcr.lisp-fpscr)))
     359  (and imm0 imm0 (:$ (ash 3 22)))       ;rounding mode
     360  (and imm1 imm1 (:$ #xff00))
     361  (orr imm0 imm0 imm1)
     362  (box-fixnum arg_z imm0)
     363  (bx lr))
     364
     365;;; Get the cumulative exception status bits out of the FPSCR.
     366(defarmlapfunction %get-fpscr-status ()
     367  (fmrx imm0 :fpscr)
     368  (and imm0 imm0 (:$ #xff))
     369  (box-fixnum arg_z imm0)
     370  (bx lr))
     371
     372;;; Set (clear, usually) the cumulative exception status bits in the FPSCR.
     373(defarmlapfunction %set-fpscr-status ((new arg_z))
     374  (fmrx imm1 :fpscr)
     375  (unbox-fixnum imm0 new)
     376  (and imm0 imm0 (:$ #xff))
     377  (bic imm1 imm1 (:$ #xff))
     378  (orr imm0 imm0 imm1)
     379  (fmxr :fpscr imm0)
     380  (bx lr))
     381
     382;;; Set the rounding mode directly in the FPSCR, and the exception enable
     383;;; bits in tcr.lisp-fpscr.
     384(defarmlapfunction %set-fpscr-control ((new arg_z))
     385  (unbox-fixnum imm0 new)
     386  (and imm1 imm0 (:$ #xff00))
     387  (str imm1 (:@ rcontext (:$ arm::tcr.lisp-fpscr)))
     388  (fmrx imm1 :fpscr)
     389  (bic imm1 imm1 (:$ (ash 3 22)))
     390  (and imm0 imm0 (:$ (ash 3 22)))
     391  (orr imm0 imm1 imm0)
     392  (fmxr :fpscr imm0)
     393  (bx lr))
     394
     395(defarmlapfunction %get-fpscr ()
     396  (fmrx imm0 :fpscr)
     397  (bic imm0 imm0 (:$ #xff00))
     398  (ldr imm1 (:@ rcontext (:$ arm::tcr.lisp-fpscr)))
     399  (and imm1 imm1 (:$ #xff00))
     400  (orr imm0 imm1 imm0)
     401  (mov imm0 (:lsl imm0 (:$ 4)))
     402  (mov arg_z (:lsr imm0 (:$ (- 4 arm::fixnumshift))))
     403  (bx lr))
     404
     405 
    284406#+notyet
    285407(progn
    286 ; Manipulating the FPSCR.
    287 ; This  returns the bottom 8 bits of the FPSCR
    288 (defarmlapfunction %get-fpscr-control ()
    289   (mffs fp0)
    290   (stfd fp0 arm::tcr.lisp-fpscr-high arm::rcontext)
    291   (lbz imm0 (+ arm::tcr.lisp-fpscr-high 7) arm::rcontext)
    292   (box-fixnum arg_z imm0)
    293   (bx lr))
    294 
    295 ; Returns the high 24 bits of the FPSCR
    296 (defarmlapfunction %get-fpscr-status ()
    297   (mffs fp0)
    298   (stfd fp0 arm::tcr.lisp-fpscr-high arm::rcontext)
    299   (ldr imm0 (:@ tsp (:$ arm::tcr.lisp-fpscr-low)))
    300   (clrrwi imm0 imm0 8)
    301   (srwi arg_z imm0 (- 8 arm::fixnumshift))
    302   (bx lr))
    303 
    304 ; Set the high 24 bits of the FPSCR; leave the low 8 unchanged
    305 (defarmlapfunction %set-fpscr-status ((new arg_z))
    306   (slwi imm0 new (- 8 arm::fixnumshift))
    307   (stw imm0 arm::tcr.lisp-fpscr-low arm::rcontext)
    308   (lfd fp0 arm::tcr.lisp-fpscr-high arm::rcontext)
    309   (mtfsf #xfc fp0)                      ; set status fields [0-5]
    310   (bx lr))
    311 
    312 ; Set the low 8 bits of the FPSCR.  Zero the upper 24 bits
    313 (defarmlapfunction %set-fpscr-control ((new arg_z))
    314   (unbox-fixnum imm0 new)
    315   (clrlwi imm0 imm0 24)                 ; ensure that "status" fields are clear
    316   (stw imm0 arm::tcr.lisp-fpscr-low arm::rcontext)
    317   (lfd fp0 arm::tcr.lisp-fpscr-high arm::rcontext)
    318   (mtfsf #xff fp0)                      ; set all fields [0-7]
    319   (bx lr))
    320 
    321 
    322 
    323  
    324408
    325409; See if the binary double-float operation OP set any enabled

  • branches/arm/level-1/arm-error-signal.lisp

    r13922 r13968  
    121121                                  :unsigned-fullword fnreg
    122122                                  :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))
     123  (let* ((fn (unless (eql 0 fnreg) (xp-gpr-lisp xp fnreg))))
     124    (with-xp-stack-frames (xp fn frame-ptr)
     125      (with-error-reentry-detection
     126          (cond
     127            ((eql 0 error-number)       ; Hopefully a UUO.
     128             (if (/= (logand arg #x0ff000f0) #x07f000f0)
     129               (%error "Unknown non-UUO: #x~x" (list arg) frame-ptr)
     130               (let* ((condition (ldb (byte 4 28) arg))
     131                      (uuo (ldb (byte 28 0) arg))
     132                      (format (ldb (byte 4 0) uuo)))
     133                 (declare (fixnum condition uuo format))
     134                 (case format
     135                   ((2 10)              ; uuo-format-[c]error-lisptag
     136                    (%error (make-condition
     137                             'type-error
     138                             :datum (xp-gpr-lisp xp (ldb (byte 4 8) uuo))
     139                             :expected-type
     140                             (svref #(fixnum list uvector immediate)
     141                                    (ldb (byte 2 12) uuo)))
     142                            nil
     143                            frame-ptr))
     144                   ((3 11)
     145                    (%error (make-condition
     146                             'type-error
     147                             :datum (xp-gpr-lisp xp (ldb (byte 4 8) uuo))
     148                             :expected-type
     149                             (svref #(fixnum cons bogus immediate fixnum null uvector bogus)
     150                                    (ldb (byte 3 12) uuo)))
     151                            nil
     152                            frame-ptr))
     153                   ((4 12)
     154                    (%error (make-condition
     155                             'type-error
     156                             :datum (xp-gpr-lisp xp (ldb (byte 4 8) uuo))
     157                             :expected-type
     158                             (svref *arm-xtype-specifiers* (ldb (byte 8 12) uuo)))
     159                            nil
     160                            frame-ptr))
     161                   (8                   ;nullary error.  Only one, atm.
     162                    (case (ldb (byte 12 8) uuo)
     163                      (1                ;why 1?
     164                       (let* ((condition-name
     165                               (cond ((eq condition arm::arm-cond-lo)
     166                                      'too-few-arguments)
     167                                     ((eq condition arm::arm-cond-hs)
     168                                      'too-many-arguments)
     169                                     (t
     170                                      ;;(assert condition arm::arm-cond-ne)
     171                                      (let* ((cpsr (xp-gpr-signed-long xp
     172                                                                       xp-cpsr-regno)))
     173                                        (if (logbitp 29 cpsr)
     174                                          'too-many-arguments
     175                                          'too-few-arguments))))))
     176                         (%error condition-name
     177                                 (list :nargs (xp-gpr-lisp xp arm::nargs)
     178                                       :fn fn)
     179                                 frame-ptr)))
    210180                      (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))))))
     181                       (%error "Unknown nullary UUO code ~d"
     182                               (list (ldb (byte 12 8) uuo))
     183                               frame-ptr))))
     184                   (9                   ;unary error
     185                    (let* ((code (ldb (byte 8 12) uuo))
     186                           (regno (ldb (byte 4 8) uuo))
     187                           (arg (xp-gpr-lisp xp regno)))
     188                      (case code
     189                        ((0 1)
     190                         (setf (xp-gpr-lisp xp regno)
     191                               (%kernel-restart-internal $xvunbnd
     192                                                         (list arg)
     193                                                         frame-ptr)))
     194                        (2
     195                         (%error (make-condition 'type-error
     196                                                 :datum arg
     197                                                 :expected-type '(or symbol function)
     198                                                 :format-control
     199                                                 "~S is not of type ~S, and can't be FUNCALLed or APPLYed")
     200                                 nil frame-ptr))
     201                        (4
     202                         (%error (make-condition 'cant-throw-error
     203                                                 :tag arg)
     204                                 nil frame-ptr))
     205                        (5
     206                         (handle-udf-call xp frame-ptr))
     207                        (6
     208                         (%err-disp-internal $xfunbnd (list arg) frame-ptr))
     209                        (t
     210                         (error "Unknown unary UUO with code ~d." code)))))
     211                   (14
     212                    (let* ((reg-a (ldb (byte 4 8) uuo))
     213                           (arg-b (xp-gpr-lisp xp (ldb (byte 4 12) uuo)))
     214                           (arg-c (xp-gpr-lisp xp (ldb (byte 4 16) uuo))))
     215                      (setf (xp-gpr-lisp xp reg-a)
     216                            (%slot-unbound-trap arg-b arg-c frame-ptr))))
     217                   (15
     218                    (let* ((reg-a (ldb (byte 4 8) uuo))
     219                           (arga (xp-gpr-lisp xp reg-a))
     220                           (argb (xp-gpr-lisp xp (ldb (byte 4 12) uuo)))
     221                           (code (ldb (byte 4 16) uuo)))
     222                      (case code
     223                        ((0 1)          ;do we report these the same way?
     224                         (%error (%rsc-string $xarroob)
     225                                 (list arga argb)
     226                                 frame-ptr))
     227                        (4
     228                         (let* ((eep-or-fv (xp-gpr-lisp xp (ldb (byte 4 12) uuo)))
     229                                (dest-reg (ldb (byte 4 8) uuo)))
     230                           (etypecase eep-or-fv
     231                             (external-entry-point
     232                              (resolve-eep eep-or-fv)
     233                              (setf (xp-gpr-lisp xp dest-reg)
     234                                    (eep.address eep-or-fv)))
     235                             (foreign-variable
     236                              (resolve-foreign-variable eep-or-fv)
     237                              (setf (xp-gpr-lisp xp dest-reg)
     238                                    (fv.addr eep-or-fv))))))
     239                        (t
     240                         (error "Unknown code in binary UUO: ~d" code)))))
     241                   (t
     242                    (error "Unknown UUO, format ~d" format))))))
     243            (t
     244             (error "%errdisp callback: error-number = ~d, arg = #x~x, fnreg = ~d, rpc = ~d"
     245                    error-number arg fnreg relative-pc)))))))

  • branches/arm/level-1/arm-threads-utils.lisp

    r13962 r13968  
    3333  (and (typep x 'fixnum)
    3434       (evenp x)
    35        (eql (%fixnum-ref-natural x)
     35       (eql (%fixnum-ref-natural x 0)
    3636            (logior (ash (ash (- arm::fake-stack-frame.size arm::node-size)
    3737                              (- arm::word-shift))
    3838                         arm::num-subtag-bits)
    3939                    arm::subtag-istruct))
    40        (eq (%fixnum-ref-natural x arm::node-size)
    41            'arm::fake-stack-frame)))
     40       (let* ((type (%fixnum-ref x arm::node-size)))
     41         (and (consp type)
     42              (eq (car type) 'arm::fake-stack-frame)))))
    4243
    4344

  • branches/arm/level-1/arm-trap-support.lisp

    r13922 r13968  
    5555    (values (%get-ptr registers offset))))
    5656
     57(defun return-address-offset (xp fn machine-state-offset)
     58  (with-macptrs ((regs (pref xp #+linuxarm-target :ucontext.uc_mcontext)))
     59    (if (functionp fn)
     60      (or (%code-vector-pc (uvref fn 0) (%inc-ptr regs machine-state-offset))
     61           (%get-ptr regs machine-state-offset))
     62      (%get-ptr regs machine-state-offset))))
     63
     64(defconstant lr-offset-in-register-context
     65  #+linuxarm-target (get-field-offset :sigcontext.arm_pc))
     66
     67(defconstant pc-offset-in-register-context
     68  #+linuxarm-target (get-field-offset :sigcontext.arm_pc))
     69
     70(defun funcall-with-xp-stack-frames (xp trap-function thunk)
     71  (cond ((null trap-function)
     72         ; Maybe inside a subprim from a lisp function
     73         (let* ((fn (xp-gpr-lisp xp arm::fn))
     74                (lr (return-address-offset
     75                     xp fn lr-offset-in-register-context)))
     76           (if (fixnump lr)
     77             (let* ((sp (xp-gpr-lisp xp arm::sp))
     78                    (vsp (xp-gpr-lisp xp arm::vsp))
     79                    (frame (make-fake-stack-frame sp sp fn lr vsp xp)))
     80               (declare (dynamic-extent frame))
     81               (funcall thunk (%dnode-address-of frame)))
     82             (funcall thunk (xp-gpr-lisp xp arm::sp)))))
     83        ((eq trap-function (xp-gpr-lisp xp arm::fn))
     84         (let* ((sp (xp-gpr-lisp xp arm::sp))
     85                (fn trap-function)
     86                (lr (return-address-offset
     87                     xp fn pc-offset-in-register-context))
     88                (vsp (xp-gpr-lisp xp arm::vsp))
     89                (frame (make-fake-stack-frame sp sp fn lr vsp xp)))
     90           (declare (dynamic-extent frame))
     91           (funcall thunk (%dnode-address-of frame))))
     92        ((eq trap-function (xp-gpr-lisp xp arm::nfn))
     93         (let* ((sp (xp-gpr-lisp xp arm::sp))
     94                (fn (xp-gpr-lisp xp arm::fn))
     95                (lr (return-address-offset
     96                     xp fn lr-offset-in-register-context))
     97                (vsp (xp-gpr-lisp xp arm::vsp))
     98                (lr-frame (make-fake-stack-frame sp sp fn lr vsp xp))
     99                (pc-fn trap-function)
     100                (pc-lr (return-address-offset
     101                        xp pc-fn pc-offset-in-register-context))
     102                (pc-frame (make-fake-stack-frame sp (%dnode-address-of lr-frame) pc-fn pc-lr vsp xp)))
     103           (declare (dynamic-extent lr-frame pc-frame))
     104           (funcall thunk (%dnode-address-of pc-frame))))
     105        (t (funcall thunk (xp-gpr-lisp xp arm::sp)))))
     106
    57107(defcallback xcmain (:address xp
    58                      :signed-fullword signal
    59                      :signed-fullword arg
    60                      :signed-fullword fnreg
    61                      :signed-fullword offset)
    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))))
     108                              :signed-fullword signal
     109                              :signed-fullword arg
     110                              :signed-fullword fnreg
     111                              :signed-fullword offset)
     112  (with-xp-stack-frames (xp (unless (eql 0 fnreg) (xp-gpr-lisp xp fnreg)) frame-ptr)
     113    (cond ((eql signal 0) (cmain))
     114          ((or (eql signal #$SIGBUS)
     115               (eql signal #$SIGSEGV))
     116           (%error (make-condition 'invalid-memory-access
     117                                   :address arg
     118                                   :write-p (eql signal #$SIGBUS))
     119                   ()
     120                   frame-ptr))
     121          (t
     122           (error "cmain callback: signal = ~d, arg = #x~x, fnreg = ~d, offset = ~d"
     123                  signal arg fnreg offset)))))

  • branches/arm/lib/arm-backtrace.lisp

    r13962 r13968  
    1818
    1919(defun cfp-lfun (p)
    20   (if (and (typep p 'fixnum)
    21            (lisp-frame-p p nil))
    22     (%cfp-lfun p)))
     20  (if (fake-stack-frame-p p)
     21    (let* ((fn (%fixnum-ref p arm::fake-stack-frame.fn))
     22           (lr (%fixnum-ref p arm::fake-stack-frame.lr)))
     23      (if (and (typep fn 'function)
     24               (typep lr 'fixnum))
     25        (values fn lr)
     26        (values nil nil)))
     27    (if (and (typep p 'fixnum)
     28             (lisp-frame-p p nil))
     29      (%cfp-lfun p))))
    2330
    2431(defun catch-csp-p (p context)

  • branches/arm/lisp-kernel/arm-constants.h

    r13948 r13968  
    280280  struct tcr *next;
    281281  struct tcr *prev;
    282   union {
    283     double d;
    284     struct {unsigned h, l;} words;
    285   } lisp_fpscr;                 /* lisp thread's fpscr (in low word) */
     282  unsigned lisp_fpscr;
     283  unsigned pad;
    286284  special_binding *db_link;     /* special binding chain head */
    287285  LispObj catch_top;            /* top catch frame */
    … …  
    340338
    341339#define TCR_FLAG_BIT_ALLOCPTR_FOREIGN (fixnumshift+8)
     340
     341/* FPSCR exception enable bits */
     342#define FPSCR_IOE_BIT 8                     /* invalid operation enable */
     343#define FPSCR_DZE_BIT 9                     /* division by 0 enable */
     344#define FPSCR_OFE_BIT 10                    /* overflow enable */
     345#define FPSCR_UFE_BIT 11                    /* underflow enable */
     346#define FPSCR_IXE_BIT 12                    /* inexact enable */

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

    r13948 r13968  
    588588         _node(next)            /* in doubly-linked list */
    589589         _node(lisp_fpscr)      /* lisp thread's fpscr (in low word) */
    590          _node(lisp_fpscr_low)
     590         _node(pad)
    591591         _node(db_link)         /* special binding chain head */
    592592         _node(catch_top)       /* top catch frame */

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

    r13958 r13968  
    12021202
    12031203_spentry(check_fpu_exception)
     1204        __(fmrx imm0,fpscr)
     1205        __(mov imm2,imm0)
     1206        __(ldr imm1,[rcontext,#tcr.lisp_fpscr])
     1207        __(ands imm0,imm0,imm1,lsr #8)
     1208        __(bxeq lr)
     1209        __(bic imm2,imm2,#0xff)
     1210        __(fmxr fpscr,imm2)
     1211        /* Need to figure out how to signal this ; not clear that
     1212           vfp state is in ucontext.  For now ... */
     1213        __(uuo_debug_trap(al))
     1214        __(bx lr)
    12041215
    12051216_spentry(discard_stack_object)
    … …  
    13231334        __(mov imm1,#0)
    13241335local_label(copy_already_loop):
    1325         __(ldr arg_x,[vsp,imm1])
    1326         __(str arg_x,[arg_y,imm1])
     1336        __(ldr arg_x,[arg_y,imm1])
     1337        __(str arg_x,[vsp,imm1])
    13271338        __(add imm1,imm1,#fixnumone)
    1328         __(cmp imm1,imm0)
     1339        __(cmp imm1,nargs)
    13291340        __(bne local_label(copy_already_loop))
    13301341        __(mov imm1,#misc_data_offset+(3<<fixnumshift))

  • branches/arm/lisp-kernel/thread_manager.c

    r13921 r13968  
    13671367#endif
    13681368    (1 << MXCSR_PM_BIT);
     1369#endif
     1370#ifdef ARM
     1371  tcr->lisp_fpscr =
     1372    (1 << FPSCR_IOE_BIT) |
     1373    (1 << FPSCR_DZE_BIT) |
     1374    (1 << FPSCR_OFE_BIT);
    13691375#endif
    13701376  tcr->save_allocbase = tcr->save_allocptr = (void *) VOID_ALLOCPTR;
Note: See TracChangeset for help on using the changeset viewer.