/[cmucl]/src/compiler/debug-dump.lisp
ViewVC logotype

Diff of /src/compiler/debug-dump.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.14 by ram, Mon May 7 10:49:09 1990 UTC revision 1.15 by ram, Mon Jul 23 14:12:54 1990 UTC
# Line 61  Line 61 
61  (proclaim '(inline ir2-block-environment))  (proclaim '(inline ir2-block-environment))
62  (defun ir2-block-environment (2block)  (defun ir2-block-environment (2block)
63    (declare (type ir2-block 2block))    (declare (type ir2-block 2block))
64    (lambda-environment (block-lambda (ir2-block-block 2block))))    (block-environment (ir2-block-block 2block)))
65    
66    
67  ;;; COMPUTE-LIVE-VARS  --  Internal  ;;; COMPUTE-LIVE-VARS  --  Internal
68  ;;;  ;;;
69  ;;;    Given a local conflicts vector and an IR2 block to represent the set of  ;;;    Given a local conflicts vector and an IR2 block to represent the set of
70  ;;; live TNs, and the Var-Locs hashtable representing the variables dumped,  ;;; live TNs, and the Var-Locs hashtable representing the variables dumped,
71  ;;; compute a bit-vector representing the set of live variables.  ;;; compute a bit-vector representing the set of live variables.  If the TN is
72    ;;; environment-live, we only mark it as live when it is in scope at Node.
73  ;;;  ;;;
74  (defun compute-live-vars (live block var-locs)  (defun compute-live-vars (live node block var-locs)
75    (declare (type ir2-block block) (type local-tn-bit-vector live)    (declare (type ir2-block block) (type local-tn-bit-vector live)
76             (type hash-table var-locs))             (type hash-table var-locs) (type node node))
77    (let ((res (make-array (logandc2 (+ (hash-table-count var-locs) 7) 7)    (let ((res (make-array (logandc2 (+ (hash-table-count var-locs) 7) 7)
78                           :element-type 'bit                           :element-type 'bit
79                           :initial-element 0)))                           :initial-element 0)))
80      (do-live-tns (tn live block)      (do-live-tns (tn live block)
81        (let ((leaf (tn-leaf tn)))        (let ((leaf (tn-leaf tn)))
82          (when (lambda-var-p leaf)          (when (and (lambda-var-p leaf)
83                       (or (not (eq (tn-kind tn) :environment))
84                           (rassoc leaf (lexenv-variables (node-lexenv node)))))
85            (let ((num (gethash leaf var-locs)))            (let ((num (gethash leaf var-locs)))
86              (when num              (when num
87                (setf (sbit res num) 1))))))                (setf (sbit res num) 1))))))
# Line 109  Line 112 
112    (let ((loc (label-location label)))    (let ((loc (label-location label)))
113      (write-var-integer (- loc *previous-location*) *byte-buffer*)      (write-var-integer (- loc *previous-location*) *byte-buffer*)
114      (setq *previous-location* loc))      (setq *previous-location* loc))
115    
116      (let ((path (node-source-path node)))
117        (unless tlf-num
118          (write-var-integer (source-path-tlf-number path) *byte-buffer*))
119        (write-var-integer (source-path-form-number path) *byte-buffer*))
120    
121    (unless tlf-num    (write-packed-bit-vector (compute-live-vars live node block var-locs)
     (write-var-integer (node-tlf-number node) *byte-buffer*))  
   (write-var-integer (first (node-source-path node)) *byte-buffer*)  
   
   (write-packed-bit-vector (compute-live-vars live block var-locs)  
122                             *byte-buffer*)                             *byte-buffer*)
123    
124    (undefined-value))    (undefined-value))
# Line 146  Line 150 
150  ;;;  ;;;
151  (defun find-tlf-and-block-numbers (fun)  (defun find-tlf-and-block-numbers (fun)
152    (declare (type clambda fun))    (declare (type clambda fun))
153    (let ((res (node-tlf-number (lambda-bind fun)))    (let ((res (source-path-tlf-number (node-source-path (lambda-bind fun))))
154          (num 0))          (num 0))
155      (do-environment-ir2-blocks (2block (lambda-environment fun))      (do-environment-ir2-blocks (2block (lambda-environment fun))
156        (let ((block (ir2-block-block 2block)))        (let ((block (ir2-block-block 2block)))
157          (when (eq (block-info block) 2block)          (when (eq (block-info block) 2block)
158            (setf (block-flag block) num)            (setf (block-flag block) num)
159            (incf num)            (incf num)
160            (unless (eql (node-tlf-number (continuation-next (block-start block)))            (unless (eql (source-path-tlf-number
161                            (node-source-path
162                             (continuation-next
163                              (block-start block))))
164                         res)                         res)
165              (setq res nil)))              (setq res nil)))
166    
167          (dolist (loc (ir2-block-locations 2block))          (dolist (loc (ir2-block-locations 2block))
168            (unless (eql (node-tlf-number (vop-node (location-info-vop loc)))            (unless (eql (source-path-tlf-number
169                            (node-source-path
170                             (vop-node (location-info-vop loc))))
171                         res)                         res)
172              (setq res nil)))))              (setq res nil)))))
173      res))      res))
# Line 194  Line 203 
203           (valid-succ           (valid-succ
204            (if (and succ            (if (and succ
205                     (or (eq (car succ) tail)                     (or (eq (car succ) tail)
206                         (not (eq (lambda-environment (block-lambda (car succ)))                         (not (eq (block-environment (car succ)) env))))
                                 env))))  
207                ()                ()
208                succ)))                succ)))
209      (vector-push-extend      (vector-push-extend
# Line 277  Line 285 
285                         (setf (debug-source-from res) name)                         (setf (debug-source-from res) name)
286                         (when (eq name :lisp)                         (when (eq name :lisp)
287                           (setf (debug-source-name res)                           (setf (debug-source-name res)
288                                 (cadr (aref (file-info-forms x) 0))))))                                 (aref (file-info-forms x) 0)))))
289                  res))                  res))
290            (source-info-files info)))            (source-info-files info)))
291    
# Line 306  Line 314 
314          (coerce seq 'simple-vector))))          (coerce seq 'simple-vector))))
315    
316    
317  ;;;; Locations:  ;;;; Variables:
318    
319  ;;; TN-SC-OFFSET  --  Internal  ;;; TN-SC-OFFSET  --  Internal
320  ;;;  ;;;
# Line 324  Line 332 
332  ;;; makes Var's name unique in the function.  Buffer is the vector we stick the  ;;; makes Var's name unique in the function.  Buffer is the vector we stick the
333  ;;; result in.  ;;; result in.
334  ;;;  ;;;
335  (defun dump-1-variable (var tn id buffer)  (defun dump-1-variable (fun var tn id buffer)
336    (declare (type lambda-var var) (type tn tn) (type unsigned-byte id))    (declare (type lambda-var var) (type tn tn) (type unsigned-byte id)
337               (type clambda fun))
338    (let* ((name (leaf-name var))    (let* ((name (leaf-name var))
339           (package (symbol-package name))           (package (symbol-package name))
340           (package-p (and package (not (eq package *package*))))           (package-p (and package (not (eq package *package*))))
# Line 335  Line 344 
344        (setq flags (logior flags compiled-debug-variable-uninterned)))        (setq flags (logior flags compiled-debug-variable-uninterned)))
345      (when package-p      (when package-p
346        (setq flags (logior flags compiled-debug-variable-packaged)))        (setq flags (logior flags compiled-debug-variable-packaged)))
347      (when (eq (tn-kind tn) :environment)      (when (and (eq (tn-kind tn) :environment)
348                   (eq (lambda-var-home var) fun))
349        (setq flags (logior flags compiled-debug-variable-environment-live)))        (setq flags (logior flags compiled-debug-variable-environment-live)))
350      (when save-tn      (when save-tn
351        (setq flags (logior flags compiled-debug-variable-save-loc-p)))        (setq flags (logior flags compiled-debug-variable-save-loc-p)))
# Line 397  Line 407 
407                   (incf id))                   (incf id))
408                  (t                  (t
409                   (setq id 0  prev-name name)))                   (setq id 0  prev-name name)))
410            (dump-1-variable var (cdr x) id *byte-buffer*)            (dump-1-variable fun var (cdr x) id *byte-buffer*)
411            (setf (gethash var var-locs) i))            (setf (gethash var var-locs) i))
412          (incf i)))          (incf i)))
413    

Legend:
Removed from v.1.14  
changed lines
  Added in v.1.15

  ViewVC Help
Powered by ViewVC 1.1.5