;;; 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 physenv env))
+(defun dump-block-successors (block physenv)
+ (declare (type cblock block) (type physenv physenv))
(let* ((tail (component-tail (block-component block)))
(succ (block-succ block))
(valid-succ
(if (and succ
(or (eq (car succ) tail)
- (not (eq (block-physenv (car succ)) env))))
+ (not (eq (block-physenv (car succ)) physenv))))
()
succ)))
(vector-push-extend
*byte-buffer*)
(let ((base (block-number
(node-block
- (lambda-bind (physenv-function env))))))
+ (lambda-bind (physenv-lambda physenv))))))
(dolist (b valid-succ)
(write-var-integer
(the index (- (block-number b) base))
(setf (fill-pointer *byte-buffer*) 0)
(let ((*previous-location* 0)
(tlf-num (find-tlf-number fun))
- (env (lambda-physenv fun))
+ (physenv (lambda-physenv fun))
(prev-locs nil)
(prev-block nil))
(collect ((elsewhere))
- (do-physenv-ir2-blocks (2block env)
+ (do-physenv-ir2-blocks (2block physenv)
(let ((block (ir2-block-block 2block)))
(when (eq (block-info block) 2block)
(when prev-block
(dump-block-locations prev-block prev-locs tlf-num var-locs))
(setq prev-block block prev-locs ())
- (dump-block-successors block env)))
+ (dump-block-successors block physenv)))
(collect ((here prev-locs))
(dolist (loc (ir2-block-locations 2block))
(make-sc-offset (sc-number (tn-sc tn))
(tn-offset tn)))
-;;; Dump info to represent Var's location being TN. ID is an integer
-;;; that makes Var's name unique in the function. Buffer is the vector
-;;; we stick the result in. If Minimal is true, we suppress name
-;;; dumping, and set the minimal flag.
+;;; Dump info to represent VAR's location being TN. ID is an integer
+;;; that makes VAR's name unique in the function. BUFFER is the vector
+;;; we stick the result in. If MINIMAL, we suppress name dumping, and
+;;; set the minimal flag.
;;;
-;;; The debug-var is only marked as always-live if the TN is
-;;; environment live and is an argument. If a :debug-environment TN,
+;;; The DEBUG-VAR is only marked as always-live if the TN is
+;;; environment live and is an argument. If a :DEBUG-ENVIRONMENT TN,
;;; then we also exclude set variables, since the variable is not
;;; guaranteed to be live everywhere in that case.
(defun dump-1-variable (fun var tn id minimal buffer)
(frob-leaf leaf (leaf-info leaf) gensym-p))))
(frob-lambda fun t)
(when (>= level 2)
- (dolist (x (ir2-physenv-environment
- (physenv-info (lambda-physenv fun))))
+ (dolist (x (ir2-physenv-closure (physenv-info (lambda-physenv fun))))
(let ((thing (car x)))
(when (lambda-var-p thing)
(frob-leaf thing (cdr x) (= level 3)))))
(setf (compiled-debug-fun-tlf-number dfun) tlf-num)
(setf (compiled-debug-fun-blocks dfun) blocks)))
- (if (external-entry-point-p fun)
+ (if (xep-p fun)
(setf (compiled-debug-fun-returns dfun) :standard)
(let ((info (tail-set-info (lambda-tail-set fun))))
(when info
;;; called after assembly so that source map information is available.
(defun debug-info-for-component (component)
(declare (type component component))
- (collect ((dfuns))
- (let ((var-locs (make-hash-table :test 'eq))
- (*byte-buffer* (make-array 10
- :element-type '(unsigned-byte 8)
- :fill-pointer 0
- :adjustable t)))
- (dolist (fun (component-lambdas component))
- (clrhash var-locs)
- (dfuns (cons (label-position
- (block-label (node-block (lambda-bind fun))))
- (compute-1-debug-fun fun var-locs))))
- (let* ((sorted (sort (dfuns) #'< :key #'car))
- (fun-map (compute-debug-fun-map sorted)))
- (make-compiled-debug-info :name (component-name component)
- :fun-map fun-map)))))
+ (let ((dfuns nil)
+ (var-locs (make-hash-table :test 'eq))
+ (*byte-buffer* (make-array 10
+ :element-type '(unsigned-byte 8)
+ :fill-pointer 0
+ :adjustable t)))
+ (dolist (lambda (component-lambdas component))
+ (clrhash var-locs)
+ (push (cons (label-position (block-label (lambda-block lambda)))
+ (compute-1-debug-fun lambda var-locs))
+ dfuns))
+ (let* ((sorted (sort dfuns #'< :key #'car))
+ (fun-map (compute-debug-fun-map sorted)))
+ (make-compiled-debug-info :name (component-name component)
+ :fun-map fun-map))))
\f
;;; Write BITS out to BYTE-BUFFER in backend byte order. The length of
;;; BITS must be evenly divisible by eight.
(defun write-packed-bit-vector (bits byte-buffer)
(declare (type simple-bit-vector bits) (type byte-buffer byte-buffer))
+
+ ;; Enforce constraint from CMU-CL-era comment.
+ (aver (zerop (mod (length bits) 8)))
+
(multiple-value-bind (initial step done)
(ecase *backend-byte-order*
(:little-endian (values 0 1 8))
projects / sbcl.git / blobdiff