debug-dump.lisp 19 KB
Newer Older
wlott's avatar
wlott committed
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
;;; -*- Package: C; Log: C.Log -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the Spice Lisp project at
;;; Carnegie-Mellon University, and has been placed in the public domain.
;;; If you want to use this code or any part of Spice Lisp, please contact
;;; Scott Fahlman (FAHLMAN@CMUC). 
;;; **********************************************************************
;;;
;;;    This file contains stuff that creates debugger information from the
;;; compiler's internal data structures.
;;; 
;;; Written by Rob MacLachlan
;;;
(in-package 'c)

17
18
19
20
(defvar *byte-buffer*
  (make-array 10 :element-type '(unsigned-byte 8)
	      :fill-pointer 0  :adjustable t))

21
22
23
24

;;;; Debug blocks:

(deftype location-kind ()
ram's avatar
ram committed
25
26
  '(member :unknown-return :known-return :internal-error :non-local-exit
	   :block-start))
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50


;;; The Location-Info structure holds the information what we need about
;;; locations which code generation decided were "interesting".
;;;
(defstruct (location-info
	    (:constructor make-location-info (kind label vop)))
  ;;
  ;; The kind of location noted.
  (kind nil :type location-kind)
  ;;
  ;; The label pointing to the interesting code location.
  (label nil :type label)
  ;;
  ;; The VOP that emitted this location (for node, save-set, ir2-block, etc.)
  (vop nil :type vop))


;;; NOTE-DEBUG-LOCATION  --  Interface
;;;
;;;    Called during code generation in places where there is an "interesting"
;;; location: some place where we are likely to end up in the debugger, and
;;; thus want debug info.
;;;
51
(defun note-debug-location (vop label kind)
52
53
54
55
56
57
58
59
60
61
62
63
  (declare (type vop vop) (type label label) (type location-kind kind))
  (setf (ir2-block-locations (vop-block vop))
	(nconc (ir2-block-locations (vop-block vop))
	       (list (make-location-info kind label vop))))
  (undefined-value))


;;; IR2-BLOCK-ENVIRONMENT  --  Interface
;;;
(proclaim '(inline ir2-block-environment))
(defun ir2-block-environment (2block)
  (declare (type ir2-block 2block))
64
  (block-environment (ir2-block-block 2block)))
65
66
67
68
69
70


;;; COMPUTE-LIVE-VARS  --  Internal
;;;
;;;    Given a local conflicts vector and an IR2 block to represent the set of
;;; live TNs, and the Var-Locs hashtable representing the variables dumped,
71
72
;;; compute a bit-vector representing the set of live variables.  If the TN is
;;; environment-live, we only mark it as live when it is in scope at Node.
73
;;;
74
(defun compute-live-vars (live node block var-locs vop)
75
  (declare (type ir2-block block) (type local-tn-bit-vector live)
76
77
	   (type hash-table var-locs) (type node node)
	   (type (or vop null) vop))
78
  (let ((res (make-array (logandc2 (+ (hash-table-count var-locs) 7) 7)
79
			 :element-type 'bit
80
81
82
83
			 :initial-element 0))
	(spilled (gethash vop
			  (ir2-component-spilled-vops
			   (component-info *compile-component*)))))
84
85
    (do-live-tns (tn live block)
      (let ((leaf (tn-leaf tn)))
86
	(when (and (lambda-var-p leaf)
87
88
		   (or (not (member (tn-kind tn)
				    '(:environment :debug-environment)))
89
90
91
		       (rassoc leaf (lexenv-variables (node-lexenv node))))
		   (or (null spilled)
		       (not (member tn spilled))))
92
93
	  (let ((num (gethash leaf var-locs)))
	    (when num
ram's avatar
ram committed
94
95
	      (setf (sbit res num) 1))))))
    res))
96
97
98
99
100


;;; The PC for the location most recently dumped.
;;;
(defvar *previous-location*)
101
(proclaim '(type index *previous-location*))
102
103
104
105

;;; DUMP-1-LOCATION  --  Internal
;;;
;;;    Dump a compiled debug-location into *BYTE-BUFFER* that describes the
106
107
;;; code/source map and live info.  If true, VOP is the VOP associated with
;;; this location, for use in determining whether TNs are spilled.
108
;;;
109
(defun dump-1-location (node block kind tlf-num label live var-locs vop)
110
111
  (declare (type node node) (type ir2-block block)
	   (type local-tn-bit-vector live) (type label label)
ram's avatar
ram committed
112
	   (type location-kind kind) (type (or index null) tlf-num)
113
	   (type hash-table var-locs) (type (or vop null) vop))
114
115
  
  (vector-push-extend
116
117
118
   (dpb (position kind compiled-code-location-kinds)
	compiled-code-location-kind-byte
	0)
119
120
   *byte-buffer*)
  
wlott's avatar
wlott committed
121
  (let ((loc (label-position label)))
122
123
    (write-var-integer (- loc *previous-location*) *byte-buffer*)
    (setq *previous-location* loc))
124
125
126
127
128

  (let ((path (node-source-path node)))
    (unless tlf-num
      (write-var-integer (source-path-tlf-number path) *byte-buffer*))
    (write-var-integer (source-path-form-number path) *byte-buffer*))
129
  
130
  (write-packed-bit-vector (compute-live-vars live node block var-locs vop)
131
132
133
134
135
136
137
138
139
140
			   *byte-buffer*)
  
  (undefined-value))


;;; DUMP-LOCATION-FROM-INFO  --  Internal
;;;
;;;    Extract context info from a Location-Info structure and use it to dump a
;;; compiled code-location.
;;;
ram's avatar
ram committed
141
142
143
(defun dump-location-from-info (loc tlf-num var-locs)
  (declare (type location-info loc) (type (or index null) tlf-num)
	   (type hash-table var-locs))
144
145
146
147
148
149
150
  (let ((vop (location-info-vop loc)))
    (dump-1-location (vop-node vop)
		     (vop-block vop)
		     (location-info-kind loc)
		     tlf-num
		     (location-info-label loc)
		     (vop-save-set vop)
151
152
		     var-locs
		     vop))
153
154
155
  (undefined-value))


156
157
158
159
160
161
162
;;; FIND-TLF-AND-BLOCK-NUMBERS  --  Internal
;;;
;;;    Scan all the blocks, caching the block numbering in the BLOCK-FLAG and
;;; determining if all locations are in the same TLF.
;;;
(defun find-tlf-and-block-numbers (fun)
  (declare (type clambda fun))
163
  (let ((res (source-path-tlf-number (node-source-path (lambda-bind fun))))
164
	(num 0))
165
    (declare (type index num) (type (or index null) res))
166
167
168
169
170
    (do-environment-ir2-blocks (2block (lambda-environment fun))
      (let ((block (ir2-block-block 2block)))
	(when (eq (block-info block) 2block)
	  (setf (block-flag block) num)
	  (incf num)
171
172
173
174
	  (unless (eql (source-path-tlf-number
			(node-source-path
			 (continuation-next
			  (block-start block))))
175
176
177
178
		       res)
	    (setq res nil)))
	
	(dolist (loc (ir2-block-locations 2block))
179
180
181
	  (unless (eql (source-path-tlf-number
			(node-source-path
			 (vop-node (location-info-vop loc))))
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
		       res)
	    (setq res nil)))))
    res))


;;; DUMP-BLOCK-LOCATIONS  --  Internal
;;;
;;;    Dump out the number of locations and the locations for Block.
;;;
(defun dump-block-locations (block locations tlf-num var-locs)
  (declare (type cblock block) (list locations))
  (write-var-integer (1+ (length locations)) *byte-buffer*)
  (let ((2block (block-info block)))
    (dump-1-location (continuation-next (block-start block))
		     2block :block-start tlf-num
		     (ir2-block-%label 2block)
		     (ir2-block-live-out 2block)
199
200
		     var-locs
		     nil))
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
  (dolist (loc locations)
    (dump-location-from-info loc tlf-num var-locs))
  (undefined-value))


;;; DUMP-BLOCK-SUCCESSORS  --  Internal
;;;
;;;    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))
  (let* ((tail (component-tail (block-component block)))
	 (succ (block-succ block))
	 (valid-succ
	  (if (and succ
		   (or (eq (car succ) tail)
218
		       (not (eq (block-environment (car succ)) env))))
219
220
221
222
223
224
225
226
227
228
	      ()
	      succ)))
    (vector-push-extend
     (dpb (length valid-succ) compiled-debug-block-nsucc-byte 0)
     *byte-buffer*)
    (dolist (b valid-succ)
      (write-var-integer (block-flag b) *byte-buffer*)))
  (undefined-value))


229
230
231
232
233
234
235
;;; COMPUTE-DEBUG-BLOCKS  --  Internal
;;;
;;;    Return a vector and an integer (or null) suitable for use as the BLOCKS
;;; and TLF-NUMBER in Fun's debug-function.  This requires three passes to
;;; compute:
;;; -- Scan all blocks, dumping the header and successors followed by all the
;;;    non-elsewhere locations.
236
237
;;; -- Dump the elsewhere block header and all the elsewhere locations (if
;;;    any.)
238
239
240
241
242
;;;
(defun compute-debug-blocks (fun var-locs)
  (declare (type clambda fun) (type hash-table var-locs))
  (setf (fill-pointer *byte-buffer*) 0)
  (let ((*previous-location* 0)
243
244
245
246
247
248
	(tlf-num (find-tlf-and-block-numbers fun))
	(env (lambda-environment fun))
	(prev-locs nil)
	(prev-block nil))
    (collect ((elsewhere))
      (do-environment-ir2-blocks (2block env)
249
250
	(let ((block (ir2-block-block 2block)))
	  (when (eq (block-info block) 2block)
251
252
253
254
255
256
	    (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)))
	
	(collect ((here prev-locs))
257
	  (dolist (loc (ir2-block-locations 2block))
258
259
260
261
	    (if (label-elsewhere-p (location-info-label loc))
		(elsewhere loc)
		(here loc)))
	  (setq prev-locs (here))))
262

263
      (dump-block-locations prev-block prev-locs tlf-num var-locs)
264
265
266
267
268
269

      (when (elsewhere)
	(vector-push-extend compiled-debug-block-elsewhere-p *byte-buffer*)
	(write-var-integer (length (elsewhere)) *byte-buffer*)
	(dolist (loc (elsewhere))
	  (dump-location-from-info loc tlf-num var-locs))))
270
271
272
273

    (values (copy-seq *byte-buffer*) tlf-num)))


wlott's avatar
wlott committed
274
275
276
;;; DEBUG-SOURCE-FOR-INFO  --  Interface
;;;
;;;    Return a list of DEBUG-SOURCE structures containing information derived
277
278
;;; from Info.  We always dump the Start-Positions, since it is too hard
;;; figure out whether we need them or not.
wlott's avatar
wlott committed
279
280
281
282
283
284
285
286
;;;
(defun debug-source-for-info (info)
  (declare (type source-info info))
  (assert (not (source-info-current-file info)))
  (mapcar #'(lambda (x)
	      (let ((name (file-info-name x))
		    (res (make-debug-source
			  :from :file
287
			  :comment (file-info-comment x)
wlott's avatar
wlott committed
288
289
290
			  :created (file-info-write-date x)
			  :compiled (source-info-start-time info)
			  :source-root (file-info-source-root x)
ram's avatar
ram committed
291
			  :start-positions
292
293
			  (coerce-to-smallest-eltype
			   (file-info-positions x)))))
wlott's avatar
wlott committed
294
295
296
297
		(cond ((pathnamep name)
		       (setf (debug-source-name res) name))
		      (t
		       (setf (debug-source-from res) name)
298
299
		       (setf (debug-source-name res)
			     (coerce (file-info-forms x) 'simple-vector))))
wlott's avatar
wlott committed
300
301
302
303
		res))
	  (source-info-files info)))


304
305
306
307
308
309
;;; COERCE-TO-SMALLEST-ELTYPE  --  Internal
;;;
;;;    Given an arbirtary sequence, coerce it to an unsigned vector if
;;; possible.
;;;
(defun coerce-to-smallest-eltype (seq)
310
  (declare (type sequence seq))
311
  (let ((max 0))
312
    (declare (type (or index null) max))
313
    (macrolet ((frob ()
314
		 '(if (and (typep val 'index) max)
315
316
317
318
		      (when (> val max)
			(setq max val))
		      (setq max nil))))
      (if (listp seq)
ram's avatar
ram committed
319
	  (dolist (val seq)
320
321
322
323
324
325
	    (frob))
	  (dotimes (i (length seq))
	    (let ((val (aref seq i)))
	      (frob)))))
    
    (if max
326
	(coerce seq `(simple-array (integer 0 ,max)))
327
328
329
	(coerce seq 'simple-vector))))


330
;;;; Variables:
331

332
333
334
335
336
337
338
339
340
341
;;; TN-SC-OFFSET  --  Internal
;;;
;;;    Return a SC-OFFSET describing TN's location.
;;;
(defun tn-sc-offset (tn)
  (declare (type tn tn))
  (make-sc-offset (sc-number (tn-sc tn))
		  (tn-offset tn)))


342
;;; DUMP-1-VARIABLE  --  Internal
343
344
345
346
;;;
;;;    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.
wlott's avatar
wlott committed
347
;;;
348
349
350
351
352
;;;    The debug-variable 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 guranteed to be live
;;; everywhere in that case.
;;;
353
(defun dump-1-variable (fun var tn id buffer)
354
  (declare (type lambda-var var) (type tn tn) (type index id)
355
	   (type clambda fun))
356
357
358
359
  (let* ((name (leaf-name var))
	 (package (symbol-package name))
	 (package-p (and package (not (eq package *package*))))
	 (save-tn (tn-save-tn tn))
360
	 (kind (tn-kind tn))
361
	 (flags 0))
362
    (declare (type index flags))
363
    (unless package
364
      (setq flags (logior flags compiled-debug-variable-uninterned)))
365
    (when package-p
366
      (setq flags (logior flags compiled-debug-variable-packaged)))
367
368
369
    (when (and (or (eq kind :environment)
		   (and (eq kind :debug-environment)
			(null (basic-var-sets var))))
370
371
	       (not (gethash tn (ir2-component-spilled-tns
				 (component-info *compile-component*))))
372
	       (eq (lambda-var-home var) fun))
373
      (setq flags (logior flags compiled-debug-variable-environment-live)))
374
    (when save-tn
375
      (setq flags (logior flags compiled-debug-variable-save-loc-p)))
376
    (unless (zerop id)
377
      (setq flags (logior flags compiled-debug-variable-id-p)))
378
379
380
381
382
383
384
385
386
387
    (vector-push-extend flags buffer)
    (write-var-string (symbol-name name) buffer)
    (when package-p
      (write-var-string (package-name package) buffer))
    (unless (zerop id)
      (write-var-integer id buffer))
    (write-var-integer (tn-sc-offset tn) buffer)
    (when save-tn
      (write-var-integer (tn-sc-offset save-tn) buffer)))
  (undefined-value))
wlott's avatar
wlott committed
388
389
390
391
392


;;; COMPUTE-VARIABLES  --  Internal
;;;
;;;    Return a vector suitable for use as the DEBUG-FUNCTION-VARIABLES of Fun.
393
394
395
;;; Level is the current DEBUG-INFO quality.  Var-Locs is a hashtable in which
;;; we enter the translation from LAMBDA-VARS to the relative position of that
;;; variable's location in the resulting vector.
wlott's avatar
wlott committed
396
;;;
397
(defun compute-variables (fun level var-locs)
wlott's avatar
wlott committed
398
  (declare (type clambda fun) (type hash-table var-locs))
399
400
  (collect ((vars))
    (labels ((frob-leaf (leaf tn gensym-p)
wlott's avatar
wlott committed
401
	       (let ((name (leaf-name leaf)))
402
		 (when (and name (leaf-refs leaf) (tn-offset tn)
403
404
405
406
407
408
409
410
411
412
413
414
415
416
			    (or gensym-p (symbol-package name)))
		   (vars (cons leaf tn)))))
	     (frob-lambda (x gensym-p)
	       (dolist (leaf (lambda-vars x))
		 (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))))
	  (let ((thing (car x)))
	    (when (lambda-var-p thing)
	      (frob-leaf thing (cdr x) (= level 3)))))
	
	(dolist (let (lambda-lets fun))
ram's avatar
ram committed
417
	  (frob-lambda let (= level 3)))))
wlott's avatar
wlott committed
418
    
419
420
421
422
423
424
425
    (setf (fill-pointer *byte-buffer*) 0)
    (let ((sorted (sort (vars) #'string<
			:key #'(lambda (x)
				 (symbol-name (leaf-name (car x))))))
	  (prev-name nil)
	  (id 0)
	  (i 0))
426
427
      (declare (type (or simple-string null) prev-name)
	       (type index id i))
428
429
430
431
432
433
434
      (dolist (x sorted)
	(let* ((var (car x))
	       (name (symbol-name (leaf-name var))))
	  (cond ((and prev-name (string= prev-name name))
		 (incf id))
		(t
		 (setq id 0  prev-name name)))
435
	  (dump-1-variable fun var (cdr x) id *byte-buffer*)
436
	  (setf (gethash var var-locs) i))
437
438
439
440
441
442
443
444
	(incf i)))

    (copy-seq *byte-buffer*)))


;;; DEBUG-LOCATION-FOR  --  Internal
;;;
;;;    Return Var's relative position in the function's variables (determined
445
;;; from the Var-Locs hashtable.)  If Var is deleted, the return DELETED.
446
447
;;;
(defun debug-location-for (var var-locs)
ram's avatar
ram committed
448
  (declare (type lambda-var var) (type hash-table var-locs))
449
  (let ((res (gethash var var-locs)))
450
451
    (cond (res)
	  (t
452
453
	   (assert (or (null (leaf-refs var))
		       (not (tn-offset (leaf-info var)))))
454
	   'deleted))))
wlott's avatar
wlott committed
455

456
457

;;;; Arguments/returns:
wlott's avatar
wlott committed
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472

;;; COMPUTE-ARGUMENTS  --  Internal
;;;
;;;    Return a vector to be used as the COMPILED-DEBUG-FUNCTION-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.
;;;
;;; ### 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)
  (declare (type clambda fun) (type hash-table var-locs))
  (collect ((res))
    (let ((od (lambda-optional-dispatch fun)))
      (if (and od (eq (optional-dispatch-main-entry od) fun))
473
474
	  (let ((actual-vars (lambda-vars fun))
		(saw-optional nil))
wlott's avatar
wlott committed
475
476
477
478
479
480
481
482
	    (dolist (arg (optional-dispatch-arglist od))
	      (let ((info (lambda-var-arg-info arg))
		    (actual (pop actual-vars)))
		(cond (info
		       (case (arg-info-kind info)
			 (:keyword
			  (res (arg-info-keyword info)))
			 (:rest
483
484
485
486
487
			  (res 'rest-arg))
			 (:optional
			  (unless saw-optional
			    (res 'optional-args)
			    (setq saw-optional t))))
wlott's avatar
wlott committed
488
489
490
491
492
493
494
495
496
		       (res (debug-location-for actual var-locs))
		       (when (arg-info-supplied-p info)
			 (res 'supplied-p)
			 (res (debug-location-for (pop actual-vars) var-locs))))
		      (t
		       (res (debug-location-for actual var-locs)))))))
	  (dolist (var (lambda-vars fun))
	    (res (debug-location-for var var-locs)))))

497
    (coerce-to-smallest-eltype (res))))
wlott's avatar
wlott committed
498
499
500
501


;;; COMPUTE-DEBUG-RETURNS  --  Internal
;;;
502
503
;;;    Return a vector of SC offsets describing Fun's return locations.  (Must
;;; be known values return...)
wlott's avatar
wlott committed
504
505
;;;
(defun compute-debug-returns (fun)
506
507
508
509
  (coerce-to-smallest-eltype 
   (mapcar #'(lambda (loc)
	       (tn-sc-offset loc))
	   (return-info-locations (tail-set-info (lambda-tail-set fun))))))
wlott's avatar
wlott committed
510

511

wlott's avatar
wlott committed
512
513
514
515
516
517
;;; DEBUG-INFO-FOR-COMPONENT  --  Interface
;;;
;;; Return a debug-info structure describing component.  This has to be called
;;; at some particular time (after assembly) so that source map information is
;;; available.
;;; 
wlott's avatar
wlott committed
518
519
(defun debug-info-for-component (component)
  (declare (type component component))
520
  (let ((res (make-compiled-debug-info :name (component-name component)
521
				       :package (package-name *package*))))
wlott's avatar
wlott committed
522
523
524
525
    (collect ((dfuns))
      (let ((var-locs (make-hash-table :test #'eq)))
	(dolist (fun (component-lambdas component))
	  (clrhash var-locs)
526
	  (let* ((2env (environment-info (lambda-environment fun)))
527
528
		 (dispatch (lambda-optional-dispatch fun))
		 (main-p (and dispatch
529
			      (eq fun (optional-dispatch-main-entry dispatch))))
530
531
		 (dfun (make-compiled-debug-function
			:name (cond ((leaf-name fun))
532
533
				    ((let ((ef (functional-entry-function
						fun)))
534
				       (and ef (leaf-name ef))))
535
				    ((and main-p (leaf-name dispatch)))
536
537
				    (t
				     (component-name component)))
538
			:kind (if main-p nil (functional-kind fun))
539
540
			:return-pc (tn-sc-offset
				    (ir2-environment-return-pc 2env))
541
542
			:old-fp (tn-sc-offset
				 (ir2-environment-old-fp 2env))
wlott's avatar
wlott committed
543
			:start-pc (label-position
544
545
546
				   (ir2-environment-environment-start 2env))

			:elsewhere-pc
wlott's avatar
wlott committed
547
			(label-position
548
549
550
551
552
			 (ir2-environment-elsewhere-start 2env))))
		 (level (cookie-debug
			 (lexenv-cookie
			  (node-lexenv
			   (lambda-bind fun))))))
wlott's avatar
wlott committed
553
	    
554
	    (when (>= level 1)
wlott's avatar
wlott committed
555
	      (setf (compiled-debug-function-variables dfun)
556
		    (compute-variables fun level var-locs)))
wlott's avatar
wlott committed
557

558
	    (unless (= level 0)
wlott's avatar
wlott committed
559
560
561
	      (setf (compiled-debug-function-arguments dfun)
		    (compute-arguments fun var-locs)))

562
563
	    (when (>= level 2)
	      (multiple-value-bind (blocks tlf-num)
ram's avatar
ram committed
564
				   (compute-debug-blocks fun var-locs)
565
566
		(setf (compiled-debug-function-tlf-number dfun) tlf-num)
		(setf (compiled-debug-function-blocks dfun) blocks)))
567

wlott's avatar
wlott committed
568
569
570
571
572
573
	    (let ((tails (lambda-tail-set fun)))
	      (when tails
		(let ((info (tail-set-info tails)))
		  (cond ((eq (return-info-kind info) :unknown)
			 (setf (compiled-debug-function-returns dfun)
			       :standard))
574
			((/= level 0)
wlott's avatar
wlott committed
575
576
577
			 (setf (compiled-debug-function-returns dfun)
			       (compute-debug-returns fun)))))))

wlott's avatar
wlott committed
578
	    (dfuns (cons (label-position
wlott's avatar
wlott committed
579
580
581
582
583
584
585
586
587
588
589
			  (block-label
			   (node-block
			    (lambda-bind fun))))
			 dfun)))))

      (let* ((sorted (sort (dfuns) #'< :key #'car))
	     (len (1- (* (length sorted) 2)))
	     (funs-vec (make-array len)))
	(do ((i -1 (+ i 2))
	     (sorted sorted (cdr sorted)))
	    ((= i len))
590
	  (declare (fixnum i))
wlott's avatar
wlott committed
591
592
593
594
595
596
597
	  (let ((dfun (car sorted)))
	    (unless (minusp i)
	      (setf (svref funs-vec i) (car dfun)))
	    (setf (svref funs-vec (1+ i)) (cdr dfun))))
	(setf (compiled-debug-info-function-map res) funs-vec)))

    res))