;;; This maps SB!C::COMPILED-DEBUG-FUNs to
;;; COMPILED-DEBUG-FUNs, so we can get at cached stuff and not
;;; duplicate COMPILED-DEBUG-FUN structures.
-(defvar *compiled-debug-funs* (make-hash-table :test 'eq))
+(defvar *compiled-debug-funs* (make-hash-table :test 'eq :weakness :key))
;;; Make a COMPILED-DEBUG-FUN for a SB!C::COMPILER-DEBUG-FUN and its
;;; component. This maps the latter to the former in
;; valid value at this code-location. (unexported).
(%live-set :unparsed :type (or simple-bit-vector (member :unparsed)))
;; (unexported) To see SB!C::LOCATION-KIND, do
- ;; (SB!KERNEL:TYPE-EXPAND 'SB!C::LOCATION-KIND).
+ ;; (SB!KERNEL:TYPEXPAND 'SB!C::LOCATION-KIND).
(kind :unparsed :type (or (member :unparsed) sb!c::location-kind))
(step-info :unparsed :type (or (member :unparsed :foo) simple-string)))
\f
(defun fun-word-offset (fun) (fun-word-offset fun))
#!-sb-fluid (declaim (inline control-stack-pointer-valid-p))
-(defun control-stack-pointer-valid-p (x)
+(defun control-stack-pointer-valid-p (x &optional (aligned t))
(declare (type system-area-pointer x))
(let* (#!-stack-grows-downward-not-upward
(control-stack-start
#!-stack-grows-downward-not-upward
(and (sap< x (current-sp))
(sap<= control-stack-start x)
- (zerop (logand (sap-int x) sb!vm:fixnum-tag-mask)))
+ (or (not aligned) (zerop (logand (sap-int x) sb!vm:fixnum-tag-mask))))
#!+stack-grows-downward-not-upward
(and (sap>= x (current-sp))
(sap> control-stack-end x)
- (zerop (logand (sap-int x) sb!vm:fixnum-tag-mask)))))
+ (or (not aligned) (zerop (logand (sap-int x) sb!vm:fixnum-tag-mask))))))
(declaim (inline component-ptr-from-pc))
(sb!alien:define-alien-routine component-ptr-from-pc (system-area-pointer)
(pc system-area-pointer))
-#!+(or x86 x86-64)
+#!+gencgc
(sb!alien:define-alien-routine valid-lisp-pointer-p sb!alien:int
(pointer system-area-pointer))
(- (get-lisp-obj-address code)
sb!vm:other-pointer-lowtag)
code-header-len)))
-; (format t "c-lra-fpc ~A ~A ~A~%" pc code pc-offset)
+ ;;(format t "c-lra-fpc ~A ~A ~A~%" pc code pc-offset)
(values pc-offset code)))))
#!+(or x86 x86-64)
(declaim (maybe-inline x86-call-context))
(defun x86-call-context (fp)
(declare (type system-area-pointer fp))
- (labels ((fail ()
- (values nil
- (int-sap 0)
- (int-sap 0)))
- (handle (fp)
- (cond
- ((not (control-stack-pointer-valid-p fp))
- (fail))
- (t
- ;; Check the two possible frame pointers.
- (let ((lisp-ocfp (sap-ref-sap fp (- (* (1+ ocfp-save-offset)
- sb!vm::n-word-bytes))))
- (lisp-ra (sap-ref-sap fp (- (* (1+ return-pc-save-offset)
- sb!vm::n-word-bytes))))
- (c-ocfp (sap-ref-sap fp (* 0 sb!vm:n-word-bytes)))
- (c-ra (sap-ref-sap fp (* 1 sb!vm:n-word-bytes))))
- (cond ((and (sap> lisp-ocfp fp)
- (control-stack-pointer-valid-p lisp-ocfp)
- (ra-pointer-valid-p lisp-ra)
- (sap> c-ocfp fp)
- (control-stack-pointer-valid-p c-ocfp)
- (ra-pointer-valid-p c-ra))
- ;; Look forward another step to check their validity.
- (let ((lisp-ok (handle lisp-ocfp))
- (c-ok (handle c-ocfp)))
- (cond ((and lisp-ok c-ok)
- ;; Both still seem valid - choose the lisp frame.
- #!+freebsd
- (if (sap> lisp-ocfp c-ocfp)
- (values t lisp-ra lisp-ocfp)
- (values t c-ra c-ocfp))
- #!-freebsd
- (values t lisp-ra lisp-ocfp))
- (lisp-ok
- ;; The lisp convention is looking good.
- (values t lisp-ra lisp-ocfp))
- (c-ok
- ;; The C convention is looking good.
- (values t c-ra c-ocfp))
- (t
- ;; Neither seems right?
- (fail)))))
- ((and (sap> lisp-ocfp fp)
- (control-stack-pointer-valid-p lisp-ocfp)
- (ra-pointer-valid-p lisp-ra))
- ;; The lisp convention is looking good.
- (values t lisp-ra lisp-ocfp))
- ((and (sap> c-ocfp fp)
- (control-stack-pointer-valid-p c-ocfp)
- #!-linux (ra-pointer-valid-p c-ra))
- ;; The C convention is looking good.
- (values t c-ra c-ocfp))
- (t
- (fail))))))))
- (handle fp)))
+ (let ((ocfp (sap-ref-sap fp (sb!vm::frame-byte-offset ocfp-save-offset)))
+ (ra (sap-ref-sap fp (sb!vm::frame-byte-offset return-pc-save-offset))))
+ (if (and (control-stack-pointer-valid-p fp)
+ (sap> ocfp fp)
+ (control-stack-pointer-valid-p ocfp)
+ (ra-pointer-valid-p ra))
+ (values t ra ocfp)
+ (values nil (int-sap 0) (int-sap 0)))))
) ; #+x86 PROGN
\f
(#.ocfp-save-offset
(stack-ref pointer stack-slot))
(#.lra-save-offset
- (sap-ref-sap pointer (- (* (1+ stack-slot)
- sb!vm::n-word-bytes))))))))
+ (sap-ref-sap pointer (sb!vm::frame-byte-offset stack-slot)))))))
(defun (setf get-context-value) (value frame stack-slot loc)
(declare (type compiled-frame frame) (type unsigned-byte stack-slot)
(#.ocfp-save-offset
(setf (stack-ref pointer stack-slot) value))
(#.lra-save-offset
- (setf (sap-ref-sap pointer (- (* (1+ stack-slot)
- sb!vm::n-word-bytes))) value))))))
+ (setf (sap-ref-sap pointer (sb!vm::frame-byte-offset stack-slot))
+ value))))))
(defun foreign-function-backtrace-name (sap)
(let ((name (sap-foreign-symbol sap)))
;;; Return a DEBUG-FUN that represents debug information for FUN.
(defun fun-debug-fun (fun)
(declare (type function fun))
- (ecase (widetag-of fun)
- (#.sb!vm:closure-header-widetag
- (fun-debug-fun (%closure-fun fun)))
- (#.sb!vm:funcallable-instance-header-widetag
- (fun-debug-fun (funcallable-instance-fun fun)))
- (#.sb!vm:simple-fun-header-widetag
- (let* ((name (%simple-fun-name fun))
- (component (fun-code-header fun))
- (res (find-if
- (lambda (x)
- (and (sb!c::compiled-debug-fun-p x)
- (eq (sb!c::compiled-debug-fun-name x) name)
- (eq (sb!c::compiled-debug-fun-kind x) nil)))
- (sb!c::compiled-debug-info-fun-map
- (%code-debug-info component)))))
- (if res
- (make-compiled-debug-fun res component)
- ;; KLUDGE: comment from CMU CL:
- ;; This used to be the non-interpreted branch, but
- ;; William wrote it to return the debug-fun of fun's XEP
- ;; instead of fun's debug-fun. The above code does this
- ;; more correctly, but it doesn't get or eliminate all
- ;; appropriate cases. It mostly works, and probably
- ;; works for all named functions anyway.
- ;; -- WHN 20000120
- (debug-fun-from-pc component
- (* (- (fun-word-offset fun)
- (get-header-data component))
- sb!vm:n-word-bytes)))))))
+ (let ((simple-fun (%fun-fun fun)))
+ (let* ((name (%simple-fun-name simple-fun))
+ (component (fun-code-header simple-fun))
+ (res (find-if
+ (lambda (x)
+ (and (sb!c::compiled-debug-fun-p x)
+ (eq (sb!c::compiled-debug-fun-name x) name)
+ (eq (sb!c::compiled-debug-fun-kind x) nil)))
+ (sb!c::compiled-debug-info-fun-map
+ (%code-debug-info component)))))
+ (if res
+ (make-compiled-debug-fun res component)
+ ;; KLUDGE: comment from CMU CL:
+ ;; This used to be the non-interpreted branch, but
+ ;; William wrote it to return the debug-fun of fun's XEP
+ ;; instead of fun's debug-fun. The above code does this
+ ;; more correctly, but it doesn't get or eliminate all
+ ;; appropriate cases. It mostly works, and probably
+ ;; works for all named functions anyway.
+ ;; -- WHN 20000120
+ (debug-fun-from-pc component
+ (* (- (fun-word-offset simple-fun)
+ (get-header-data component))
+ sb!vm:n-word-bytes))))))
;;; Return the kind of the function, which is one of :OPTIONAL,
;;; :EXTERNAL, :TOPLEVEL, :CLEANUP, or NIL.
(without-package-locks
(setf (compiled-debug-var-symbol (svref vars i))
(intern (format nil "ARG-~V,'0D" width i)
- ;; KLUDGE: It's somewhat nasty to have a bare
- ;; package name string here. It would be
- ;; nicer to have #.(FIND-PACKAGE "SB!DEBUG")
- ;; instead, since then at least it would transform
- ;; correctly under package renaming and stuff.
- ;; However, genesis can't handle dumped packages..
- ;; -- WHN 20000129
- ;;
- ;; FIXME: Maybe this could be fixed by moving the
- ;; whole debug-int.lisp file to warm init? (after
- ;; which dumping a #.(FIND-PACKAGE ..) expression
- ;; would work fine) If this is possible, it would
- ;; probably be a good thing, since minimizing the
- ;; amount of stuff in cold init is basically good.
- (or (find-package "SB-DEBUG")
- (find-package "SB!DEBUG"))))))))
+ ;; The cross-compiler won't dump literal package
+ ;; references because the target package objects
+ ;; aren't created until partway through
+ ;; cold-init. In lieu of adding smarts to the
+ ;; build framework to handle this, we use an
+ ;; explicit load-time-value form.
+ (load-time-value (find-package "SB!DEBUG"))))))))
;;; Parse the packed representation of DEBUG-VARs from
;;; DEBUG-FUN's SB!C::COMPILED-DEBUG-FUN, returning a vector
;; unbound marker
(= val sb!vm:unbound-marker-widetag)
;; pointer
- #!+(or x86 x86-64)
+ #!+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
- #!-(or x86 x86-64)
+ #!-gencgc
(and (logbitp 0 val)
(or (< sb!vm:read-only-space-start val
(* sb!vm:*read-only-space-free-pointer*
,@body))
(stack-frame-offset (data-width offset)
#!+(or x86 x86-64)
- `(- (* (+ (sb!c:sc-offset-offset sc-offset) ,data-width ,offset)
- sb!vm:n-word-bytes))
+ `(sb!vm::frame-byte-offset (+ (sb!c:sc-offset-offset sc-offset)
+ (1- ,data-width)
+ ,offset))
#!-(or x86 x86-64)
(declare (ignore data-width))
#!-(or x86 x86-64)
,@body))
(stack-frame-offset (data-width offset)
#!+(or x86 x86-64)
- `(- (* (+ (sb!c:sc-offset-offset sc-offset) ,data-width ,offset)
- sb!vm:n-word-bytes))
+ `(sb!vm::frame-byte-offset (+ (sb!c:sc-offset-offset sc-offset)
+ (1- ,data-width)
+ ,offset))
#!-(or x86 x86-64)
(declare (ignore data-width))
#!-(or x86 x86-64)
(debug-signal 'frame-fun-mismatch
:code-location loc :form form :frame frame))
(funcall res frame))))))
+
+;;; EVAL-IN-FRAME
+
+(defun eval-in-frame (frame form)
+ (declare (type frame frame))
+ #!+sb-doc
+ "Evaluate FORM in the lexical context of FRAME's current code location,
+ returning the results of the evaluation."
+ (funcall (preprocess-for-eval form (frame-code-location frame)) frame))
\f
;;;; breakpoints
(sb!alien:sap-alien signal-context (* os-context-t))))
(cfp (int-sap (sb!vm:context-register scp sb!vm::cfp-offset))))
(compute-calling-frame cfp
- (sb!vm:context-pc scp)
+ ;; KLUDGE: This argument is ignored on
+ ;; x86oids in this scenario, but is
+ ;; declared to be a SAP.
+ #!+(or x86 x86-64) (sb!vm:context-pc scp)
+ #!-(or x86 x86-64) nil
nil)))
(defun handle-fun-end-breakpoint (offset component context)
#!-(or x86 x86-64)
(let ((new-lra (make-lisp-obj (+ (sap-int dst-start)
sb!vm:other-pointer-lowtag))))
- (set-header-data
- new-lra
- (logandc2 (+ sb!vm:code-constants-offset bogus-lra-constants 1)
- 1))
- (sb!vm:sanctify-for-execution code-object)
+ #!-(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))
(values new-lra code-object (sap- trap-loc src-start))))))
\f
;;;; miscellaneous
projects / sbcl.git / blobdiff