(when (and (lambda-var-p leaf)
(or (not (member (tn-kind tn)
'(:environment :debug-environment)))
- (rassoc leaf (lexenv-variables (node-lexenv node))))
+ (rassoc leaf (lexenv-vars (node-lexenv node))))
(or (null spilled)
(not (member tn spilled))))
(let ((num (gethash leaf var-locs)))
;;; 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)
+(defun dump-1-var (fun var tn id minimal buffer)
(declare (type lambda-var var) (type (or tn null) tn) (type index id)
(type clambda fun))
(let* ((name (leaf-debug-name var))
(vector-push-extend (tn-sc-offset save-tn) buffer)))
(values))
-;;; Return a vector suitable for use as the DEBUG-FUN-VARIABLES
+;;; Return a vector suitable for use as the DEBUG-FUN-VARS
;;; of FUN. LEVEL is the current DEBUG-INFO quality. VAR-LOCS is a
;;; hash table in which we enter the translation from LAMBDA-VARS to
;;; the relative position of that variable's location in the resulting
;;; vector.
-(defun compute-variables (fun level var-locs)
+(defun compute-vars (fun level var-locs)
(declare (type clambda fun) (type hash-table var-locs))
(collect ((vars))
(labels ((frob-leaf (leaf tn gensym-p)
(frob-lambda let (= level 3)))))
(let ((sorted (sort (vars) #'string<
- :key #'(lambda (x)
- (symbol-name (leaf-debug-name (car x))))))
+ :key (lambda (x)
+ (symbol-name (leaf-debug-name (car x))))))
(prev-name nil)
(id 0)
(i 0)
(incf id))
(t
(setq id 0 prev-name name)))
- (dump-1-variable fun var (cdr x) id nil buffer)
+ (dump-1-var fun var (cdr x) id nil buffer)
(setf (gethash var var-locs) i))
(incf i))
(coerce buffer 'simple-vector))))
-;;; Return a vector suitable for use as the DEBUG-FUN-VARIABLES of
+;;; Return a vector suitable for use as the DEBUG-FUN-VARS of
;;; FUN, representing the arguments to FUN in minimal variable format.
-(defun compute-minimal-variables (fun)
+(defun compute-minimal-vars (fun)
(declare (type clambda fun))
(let ((buffer (make-array 0 :fill-pointer 0 :adjustable t)))
(dolist (var (lambda-vars fun))
- (dump-1-variable fun var (leaf-info var) 0 t buffer))
+ (dump-1-var fun var (leaf-info var) 0 t buffer))
(coerce buffer 'simple-vector)))
;;; Return VAR's relative position in the function's variables (determined
\f
;;;; arguments/returns
-;;; Return a vector to be used as the
-;;; COMPILED-DEBUG-FUN-ARGUMENTS for Fun. If fun is the
-;;; MAIN-ENTRY for an optional dispatch, then look at the ARGLIST to
-;;; determine the syntax, otherwise pretend all arguments are fixed.
+;;; Return a vector to be used as the COMPILED-DEBUG-FUN-ARGS for FUN.
+;;; If FUN is the MAIN-ENTRY for an optional dispatch, then look at
+;;; the ARGLIST to determine the syntax, otherwise pretend all
+;;; arguments are fixed.
;;;
;;; ### This assumption breaks down in EPs other than the main-entry,
;;; since they may or may not have supplied-p vars, etc.
-(defun compute-arguments (fun var-locs)
+(defun compute-args (fun var-locs)
(declare (type clambda fun) (type hash-table var-locs))
(collect ((res))
(let ((od (lambda-optional-dispatch fun)))
;;; (Must be known values return...)
(defun compute-debug-returns (fun)
(coerce-to-smallest-eltype
- (mapcar #'(lambda (loc)
- (tn-sc-offset loc))
+ (mapcar (lambda (loc)
+ (tn-sc-offset loc))
(return-info-locations (tail-set-info (lambda-tail-set fun))))))
\f
;;;; debug functions
(let ((od (lambda-optional-dispatch fun)))
(or (not od)
(not (eq (optional-dispatch-main-entry od) fun)))))
- (setf (compiled-debug-fun-variables dfun)
- (compute-minimal-variables fun))
+ (setf (compiled-debug-fun-vars dfun)
+ (compute-minimal-vars fun))
(setf (compiled-debug-fun-arguments dfun) :minimal))
(t
- (setf (compiled-debug-fun-variables dfun)
- (compute-variables fun level var-locs))
+ (setf (compiled-debug-fun-vars dfun)
+ (compute-vars fun level var-locs))
(setf (compiled-debug-fun-arguments dfun)
- (compute-arguments fun var-locs))))
+ (compute-args fun var-locs))))
(when (>= level 2)
(multiple-value-bind (blocks tlf-num) (compute-debug-blocks fun var-locs)
(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 (lambda-block 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