(list location)))
location))
-#!-sb-fluid (declaim (inline ir2-block-environment))
-(defun ir2-block-environment (2block)
+#!-sb-fluid (declaim (inline ir2-block-physenv))
+(defun ir2-block-physenv (2block)
(declare (type ir2-block 2block))
- (block-environment (ir2-block-block 2block)))
+ (block-physenv (ir2-block-block 2block)))
;;; Given a local conflicts vector and an IR2 block to represent the
;;; set of live TNs, and the VAR-LOCS hash-table representing the
(declare (type clambda fun))
(let ((res (source-path-tlf-number (node-source-path (lambda-bind fun)))))
(declare (type (or index null) res))
- (do-environment-ir2-blocks (2block (lambda-environment fun))
+ (do-physenv-ir2-blocks (2block (lambda-physenv fun))
(let ((block (ir2-block-block 2block)))
(when (eq (block-info block) 2block)
(unless (eql (source-path-tlf-number
(dump-location-from-info loc tlf-num var-locs))
(values))
-;;; Dump the successors of Block, being careful not to fly into space on
-;;; weird successors.
+;;; Dump the successors of Block, being careful not to fly into space
+;;; on weird successors.
(defun dump-block-successors (block env)
- (declare (type cblock block) (type environment env))
+ (declare (type cblock block) (type physenv env))
(let* ((tail (component-tail (block-component block)))
(succ (block-succ block))
(valid-succ
(if (and succ
(or (eq (car succ) tail)
- (not (eq (block-environment (car succ)) env))))
+ (not (eq (block-physenv (car succ)) env))))
()
succ)))
(vector-push-extend
*byte-buffer*)
(let ((base (block-number
(node-block
- (lambda-bind (environment-function env))))))
+ (lambda-bind (physenv-function env))))))
(dolist (b valid-succ)
(write-var-integer
(the index (- (block-number b) base))
(values))
;;; Return a vector and an integer (or null) suitable for use as the
-;;; BLOCKS and TLF-NUMBER in Fun's debug-function. This requires two
+;;; BLOCKS and TLF-NUMBER in FUN's debug-function. This requires two
;;; passes to compute:
;;; -- Scan all blocks, dumping the header and successors followed
;;; by all the non-elsewhere locations.
(setf (fill-pointer *byte-buffer*) 0)
(let ((*previous-location* 0)
(tlf-num (find-tlf-number fun))
- (env (lambda-environment fun))
+ (env (lambda-physenv fun))
(prev-locs nil)
(prev-block nil))
(collect ((elsewhere))
- (do-environment-ir2-blocks (2block env)
+ (do-physenv-ir2-blocks (2block env)
(let ((block (ir2-block-block 2block)))
(when (eq (block-info block) 2block)
(when prev-block
;;; we need them or not.
(defun debug-source-for-info (info)
(declare (type source-info info))
- (assert (not (source-info-current-file info)))
- (mapcar #'(lambda (x)
- (let ((res (make-debug-source
- :from :file
- :created (file-info-write-date x)
- :compiled (source-info-start-time info)
- :source-root (file-info-source-root x)
- :start-positions
- (unless (eq *byte-compile* 't)
- (coerce-to-smallest-eltype
- (file-info-positions x)))))
- (name (file-info-name x)))
- (etypecase name
- ((member :lisp)
- (setf (debug-source-from res) name)
- (setf (debug-source-name res)
- (coerce (file-info-forms x) 'simple-vector)))
- (pathname
- (let* ((untruename (file-info-untruename x))
- (dir (pathname-directory untruename)))
- (setf (debug-source-name res)
- (namestring
- (if (and dir (eq (first dir) :absolute))
- untruename
- name))))))
- res))
- (source-info-files info)))
+ (let* ((file-info (source-info-file-info info))
+ (res (make-debug-source
+ :from :file
+ :created (file-info-write-date file-info)
+ :compiled (source-info-start-time info)
+ :source-root (file-info-source-root file-info)
+ :start-positions (coerce-to-smallest-eltype
+ (file-info-positions file-info))))
+ (name (file-info-name file-info)))
+ (etypecase name
+ ((member :lisp)
+ (setf (debug-source-from res) name)
+ (setf (debug-source-name res)
+ (coerce (file-info-forms file-info) 'simple-vector)))
+ (pathname
+ (let* ((untruename (file-info-untruename file-info))
+ (dir (pathname-directory untruename)))
+ (setf (debug-source-name res)
+ (namestring
+ (if (and dir (eq (first dir) :absolute))
+ untruename
+ name))))))
+ (list res)))
+
;;; Given an arbitrary sequence, coerce it to an unsigned vector if
;;; possible. Ordinarily we coerce it to the smallest specialized
;;; vector we can. However, we also have a special hack for
;;; cross-compiling at bootstrap time, when arbitrarily-specialized
-;;; aren't fully supported: in that case, we coerce it only to a
-;;; vector whose element size is an integer multiple of output byte
+;;; vectors aren't fully supported: in that case, we coerce it only to
+;;; a vector whose element size is an integer multiple of output byte
;;; size.
(defun coerce-to-smallest-eltype (seq)
(let ((maxoid #-sb-xc-host 0
- ;; An initial value value of 255 prevents us from
+ ;; An initial value of 255 prevents us from
;; specializing the array to anything smaller than
;; (UNSIGNED-BYTE 8), which keeps the cross-compiler's
;; portable specialized array output functions happy.
#+sb-xc-host 255))
(flet ((frob (x)
(if (typep x 'unsigned-byte)
- (when (>= x maxoid)
- (setf maxoid x))
- (return-from coerce-to-smallest-eltype
- (coerce seq 'simple-vector)))))
+ (when (>= x maxoid)
+ (setf maxoid x))
+ (return-from coerce-to-smallest-eltype
+ (coerce seq 'simple-vector)))))
(if (listp seq)
- (dolist (i seq)
- (frob i))
- (dovector (i seq)
- (frob i)))
+ (dolist (i seq)
+ (frob i))
+ (dovector (i seq)
+ (frob i)))
(coerce seq `(simple-array (integer 0 ,maxoid) (*))))))
\f
;;;; variables
(vector-push-extend id buffer)))
(if tn
(vector-push-extend (tn-sc-offset tn) buffer)
- (assert minimal))
+ (aver minimal))
(when save-tn
(vector-push-extend (tn-sc-offset save-tn) buffer)))
(values))
(frob-leaf leaf (leaf-info leaf) gensym-p))))
(frob-lambda fun t)
(when (>= level 2)
- (dolist (x (ir2-environment-environment
- (environment-info (lambda-environment fun))))
+ (dolist (x (ir2-physenv-environment
+ (physenv-info (lambda-physenv fun))))
(let ((thing (car x)))
(when (lambda-var-p thing)
(frob-leaf thing (cdr x) (= level 3)))))
(let ((res (gethash var var-locs)))
(cond (res)
(t
- (assert (or (null (leaf-refs var))
- (not (tn-offset (leaf-info var)))))
+ (aver (or (null (leaf-refs var))
+ (not (tn-offset (leaf-info var)))))
'deleted))))
\f
;;;; arguments/returns
(coerce-to-smallest-eltype (res))))
-;;; Return a vector of SC offsets describing Fun's return locations.
+;;; Return a vector of SC offsets describing FUN's return locations.
;;; (Must be known values return...)
(defun compute-debug-returns (fun)
(coerce-to-smallest-eltype
;;; Return a C-D-F structure with all the mandatory slots filled in.
(defun dfun-from-fun (fun)
(declare (type clambda fun))
- (let* ((2env (environment-info (lambda-environment fun)))
+ (let* ((2env (physenv-info (lambda-physenv fun)))
(dispatch (lambda-optional-dispatch fun))
(main-p (and dispatch
(eq fun (optional-dispatch-main-entry dispatch)))))
(make-compiled-debug-function
:name (cond ((leaf-name fun))
- ((let ((ef (functional-entry-function
- fun)))
+ ((let ((ef (functional-entry-function fun)))
(and ef (leaf-name ef))))
((and main-p (leaf-name dispatch)))
(t
(component-name
(block-component (node-block (lambda-bind fun))))))
:kind (if main-p nil (functional-kind fun))
- :return-pc (tn-sc-offset (ir2-environment-return-pc 2env))
- :old-fp (tn-sc-offset (ir2-environment-old-fp 2env))
- :start-pc (label-position (ir2-environment-environment-start 2env))
- :elsewhere-pc (label-position (ir2-environment-elsewhere-start 2env)))))
+ :return-pc (tn-sc-offset (ir2-physenv-return-pc 2env))
+ :old-fp (tn-sc-offset (ir2-physenv-old-fp 2env))
+ :start-pc (label-position (ir2-physenv-environment-start 2env))
+ :elsewhere-pc (label-position (ir2-physenv-elsewhere-start 2env)))))
;;; Return a complete C-D-F structure for Fun. This involves
;;; determining the DEBUG-INFO level and filling in optional slots as
minimal-debug-function-name-symbol)
(t
minimal-debug-function-name-packaged))))
- (assert (or (atom name) setf-p))
+ (aver (or (atom name) setf-p))
(let ((options 0))
(setf (ldb minimal-debug-function-name-style-byte options) name-rep)
(setf (ldb minimal-debug-function-kind-byte options)
projects / sbcl.git / blobdiff