#!-stack-grows-downward-not-upward
(and (sap< x (current-sp))
(sap<= control-stack-start x)
- (or (not aligned) (zerop (logand (sap-int x) sb!vm:fixnum-tag-mask))))
+ (or (not aligned) (zerop (logand (sap-int x)
+ (1- (ash 1 sb!vm:word-shift))))))
#!+stack-grows-downward-not-upward
(and (sap>= x (current-sp))
(sap> control-stack-end x)
- (or (not aligned) (zerop (logand (sap-int x) sb!vm:fixnum-tag-mask))))))
+ (or (not aligned) (zerop (logand (sap-int x)
+ (1- (ash 1 sb!vm:word-shift))))))))
(declaim (inline component-ptr-from-pc))
(sb!alien:define-alien-routine component-ptr-from-pc (system-area-pointer)
(pc system-area-pointer))
-#!+gencgc (declaim (inline valid-lisp-pointer-p))
-#!+gencgc
+(declaim (inline valid-lisp-pointer-p))
(sb!alien:define-alien-routine valid-lisp-pointer-p sb!alien:int
(pointer system-area-pointer))
(setf (frame-number frame) number)))
(defun find-saved-frame-down (fp up-frame)
- (multiple-value-bind (saved-fp saved-pc) (sb!c:find-saved-fp-and-pc fp)
+ (multiple-value-bind (saved-fp saved-pc)
+ (sb!alien-internals:find-saved-fp-and-pc fp)
(when saved-fp
(compute-calling-frame (descriptor-sap saved-fp)
(descriptor-sap saved-pc)
#!+alpha (* 2 n)))
(* os-context-t)))
+;;;; Perform the lookup which FOREIGN-SYMBOL-ADDRESS would do if the
+;;;; linkage table were disabled, i.e. always return the actual symbol
+;;;; address, not the linkage table trampoline, even if the symbol would
+;;;; ordinarily go through the linkage table. Important when
+;;;; SB-DYNAMIC-CORE is enabled and our caller assumes `name' to be a
+;;;; "static" symbol; a concept which doesn't exist in such builds.
+(defun true-foreign-symbol-address (name)
+ #!+linkage-table ;we have dlsym -- let's use it.
+ (find-dynamic-foreign-symbol-address name)
+ #!-linkage-table ;possibly no dlsym, but hence no indirection anyway.
+ (foreign-symbol-address))
+
+;;;; See above.
+(defun true-foreign-symbol-sap (name)
+ (int-sap (true-foreign-symbol-address name)))
+
#!+(or x86 x86-64)
(defun find-escaped-frame (frame-pointer)
(declare (type system-area-pointer frame-pointer))
(component-from-component-ptr component-ptr))))
(/noshow0 "got CODE")
(when (null code)
- (return (values code 0 context)))
+ ;; KLUDGE: Detect undefined functions by a range-check
+ ;; against the trampoline address and the following
+ ;; function in the runtime.
+ (if (< (true-foreign-symbol-address "undefined_tramp")
+ (sap-int (sb!vm:context-pc context))
+ (true-foreign-symbol-address #!+x86 "closure_tramp"
+ #!+x86-64 "alloc_tramp"))
+ (return (values :undefined-function 0 context))
+ (return (values code 0 context))))
(let* ((code-header-len (* (get-header-data code)
sb!vm:n-word-bytes))
(pc-offset
;;; (Such values can arise in registers on machines with conservative
;;; GC, and might also arise in debug variable locations when
;;; those variables are invalid.)
+;;;
+;;; NOTE: this function is not GC-safe in the slightest when creating
+;;; a pointer to an object in dynamic space. If a GC occurs between
+;;; the start of the call to VALID-LISP-POINTER-P and the end of
+;;; %MAKE-LISP-OBJ then the object could move before the boxed pointer
+;;; is constructed. This can happen on CHENEYGC if an asynchronous
+;;; interrupt occurs within the window. This can happen on GENCGC
+;;; under the same circumstances, but is more likely due to all GENCGC
+;;; platforms supporting threaded operation. This is somewhat
+;;; mitigated on x86oids due to the conservative stack and interrupt
+;;; context "scavenging" on such platforms, but there still may be a
+;;; vulnerable window.
(defun make-lisp-obj (val &optional (errorp t))
(if (or
;; fixnum
(= (logand val #xff) sb!vm:character-widetag)) ; char tag
;; unbound marker
(= val sb!vm:unbound-marker-widetag)
+ ;; undefined_tramp doesn't validate properly as a pointer, and
+ ;; the actual value can vary by backend (x86oids need not
+ ;; apply)
+ #!+(or alpha hppa mips ppc)
+ (= val (+ (- (foreign-symbol-address "undefined_tramp")
+ (* sb!vm:n-word-bytes sb!vm:simple-fun-code-offset))
+ sb!vm:fun-pointer-lowtag))
+ #!+sparc
+ (= val (foreign-symbol-address "undefined_tramp"))
;; pointer
- #!+gencgc
- (not (zerop (valid-lisp-pointer-p (int-sap val))))
- ;; FIXME: There is no fundamental reason not to use the above
- ;; function on other platforms as well, but I didn't have
- ;; others available while doing this. --NS 2007-06-21
- #!-gencgc
- (and (logbitp 0 val)
- (or (< sb!vm:read-only-space-start val
- (* sb!vm:*read-only-space-free-pointer*
- sb!vm:n-word-bytes))
- (< sb!vm:static-space-start val
- (* sb!vm:*static-space-free-pointer*
- sb!vm:n-word-bytes))
- (< (current-dynamic-space-start) val
- (sap-int (dynamic-space-free-pointer))))))
+ (not (zerop (valid-lisp-pointer-p (int-sap val)))))
(values (%make-lisp-obj val) t)
(if errorp
(error "~S is not a valid argument to ~S"
(nconc (subseq form 0 n)
(cons res (nthcdr (1+ n) form))))))))
(frob form path context))))
+
+;;; Given a code location, return the associated form-number
+;;; translations and the actual top level form.
+(defun get-toplevel-form (location)
+ (let ((d-source (code-location-debug-source location)))
+ (let* ((offset (code-location-toplevel-form-offset location))
+ (res
+ (cond ((debug-source-form d-source)
+ (debug-source-form d-source))
+ ((debug-source-namestring d-source)
+ (get-file-toplevel-form location))
+ (t (bug "Don't know how to use a DEBUG-SOURCE without ~
+ a namestring or a form.")))))
+ (values (form-number-translations res offset) res))))
+
+;;; To suppress the read-time evaluation #. macro during source read,
+;;; *READTABLE* is modified.
+;;;
+;;; FIXME: This breaks #+#.(cl:if ...) Maybe we need a SAFE-READ-EVAL, which
+;;; this code can use for side- effect free #. calls?
+;;;
+;;; FIXME: This also knows nothing of custom readtables. The assumption
+;;; is that the current readtable is a decent approximation for what
+;;; we want, but that's lossy.
+(defun safe-readtable ()
+ (let ((rt (copy-readtable)))
+ (set-dispatch-macro-character
+ #\# #\. (lambda (stream sub-char &rest rest)
+ (declare (ignore rest sub-char))
+ (let ((token (read stream t nil t)))
+ (format nil "#.~S" token)))
+ rt)
+ rt))
+
+;;; Locate the source file (if it still exists) and grab the top level
+;;; form. If the file is modified, we use the top level form offset
+;;; instead of the recorded character offset.
+(defun get-file-toplevel-form (location)
+ (let* ((d-source (code-location-debug-source location))
+ (tlf-offset (code-location-toplevel-form-offset location))
+ (local-tlf-offset (- tlf-offset
+ (debug-source-root-number d-source)))
+ (char-offset
+ (aref (or (sb!di:debug-source-start-positions d-source)
+ (error "no start positions map"))
+ local-tlf-offset))
+ (namestring (debug-source-namestring d-source)))
+ ;; FIXME: External format?
+ (with-open-file (f namestring :if-does-not-exist nil)
+ (unless f
+ (error "The source file no longer exists:~% ~A" namestring))
+ (format *debug-io* "~%; file: ~A~%" namestring)
+ (let ((*readtable* (safe-readtable)))
+ (cond ((eql (debug-source-created d-source) (file-write-date f))
+ (file-position f char-offset))
+ (t
+ (format *debug-io*
+ "~%; File has been modified since compilation:~%; ~A~@
+ ; Using form offset instead of character position.~%"
+ namestring)
+ (let ((*read-suppress* t))
+ (loop repeat local-tlf-offset
+ do (read f)))))
+ (read f)))))
\f
;;;; PREPROCESS-FOR-EVAL
;;; which GC is disabled, so that Lisp doesn't move objects around
;;; that C is pointing to.
(sb!alien:define-alien-routine "breakpoint_install" sb!alien:unsigned-int
- (code-obj sb!alien:unsigned-long)
+ (code-obj sb!alien:unsigned)
(pc-offset sb!alien:int))
;;; This removes the break instruction and replaces the original
;;; instruction. You must call this in a context in which GC is disabled
;;; so Lisp doesn't move objects around that C is pointing to.
(sb!alien:define-alien-routine "breakpoint_remove" sb!alien:void
- (code-obj sb!alien:unsigned-long)
+ (code-obj sb!alien:unsigned)
(pc-offset sb!alien:int)
(old-inst sb!alien:unsigned-int))
(without-gcing
;; These are really code labels, not variables: but this way we get
;; their addresses.
- (let* ((src-start (foreign-symbol-sap "fun_end_breakpoint_guts"))
- (src-end (foreign-symbol-sap "fun_end_breakpoint_end"))
- (trap-loc (foreign-symbol-sap "fun_end_breakpoint_trap"))
+ (let* ((src-start (true-foreign-symbol-sap "fun_end_breakpoint_guts"))
+ (src-end (true-foreign-symbol-sap "fun_end_breakpoint_end"))
+ (trap-loc (true-foreign-symbol-sap "fun_end_breakpoint_trap"))
(length (sap- src-end src-start))
(code-object
(sb!c:allocate-code-object (1+ bogus-lra-constants) length))
#!-(or x86 x86-64)
(let ((new-lra (make-lisp-obj (+ (sap-int dst-start)
sb!vm:other-pointer-lowtag))))
- #!-(or gencgc ppc)
- (progn
- ;; Set the offset from the LRA to the enclosing component.
- ;; This does not need to be done on GENCGC targets, as the
- ;; pointer validation done in MAKE-LISP-OBJ requires that it
- ;; already have been set before we get here. It does not
- ;; need to be done on CHENEYGC PPC as it's easier to use the
- ;; same fun_end_breakpoint_guts on both, including the LRA
- ;; header.
- (set-header-data
- new-lra
- (logandc2 (+ sb!vm:code-constants-offset bogus-lra-constants 1)
- 1))
- (sb!vm:sanctify-for-execution code-object))
+ ;; We used to set the header value of the LRA here to the
+ ;; offset from the enclosing component to the LRA header, but
+ ;; MAKE-LISP-OBJ actually checks the value before we get a
+ ;; chance to set it, so it's now done in arch-assem.S.
(values new-lra code-object (sap- trap-loc src-start))))))
\f
;;;; miscellaneous
projects / sbcl.git / blobdiff