Changeset 12792 for trunk/source/level-1


Ignore:
Timestamp:
Sep 9, 2009, 12:52:49 AM (10 years ago)
Author:
rme
Message:

Update xcmain callback to signal a write-to-watched-object error when
a memory fault is due to, well, a write to a watched object.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/level-1/x86-trap-support.lisp

    r11887 r12792  
    415415                       frame-ptr))))
    416416          ((= signal #$SIGSEGV)
    417            ;; Stack overflow.
    418            (let* ((on-tsp (not (eql 0 code))))
    419              (unwind-protect
    420                   (%error
    421                    (make-condition
    422                     'stack-overflow-condition
    423                     :format-control "Stack overflow on ~a stack."
    424                     :format-arguments (list
    425                                        (if on-tsp "temp" "value"))
    426                     )
    427                    nil frame-ptr)
    428                (ff-call (%kernel-import target::kernel-import-restore-soft-stack-limit)
    429                         :unsigned-fullword code
    430                         :void))))
     417           (cond
     418             ((or (= code 0) (= code 1))
     419              ;; Stack overflow.
     420              (let* ((on-tsp (= code 1)))
     421                (unwind-protect
     422                     (%error
     423                      (make-condition
     424                       'stack-overflow-condition
     425                       :format-control "Stack overflow on ~a stack."
     426                       :format-arguments (list (if on-tsp "temp" "value")))
     427                      nil frame-ptr)
     428                  (ff-call (%kernel-import target::kernel-import-restore-soft-stack-limit)
     429                           :unsigned-fullword code
     430                           :void))))
     431             ((= code 2)
     432              ;; Write to a watched object.
     433              (flet ((%int-to-object (i)
     434                       (rlet ((a :address))
     435                         (setf (%get-ptr a) (%int-to-ptr i))
     436                         (%get-object a 0))))
     437                (%error (make-condition
     438                         'write-to-watched-object
     439                         :object (%int-to-object addr))
     440                        nil frame-ptr)))))
    431441          ((= signal #+win32-target 10 #-win32-target #$SIGBUS)
    432442           (if (= code -1)
Note: See TracChangeset for help on using the changeset viewer.