0.pre7.75:
[sbcl.git] / src / compiler / debug-dump.lisp
1 ;;;; stuff that creates debugger information from the compiler's
2 ;;;; internal data structures
3
4 ;;;; This software is part of the SBCL system. See the README file for
5 ;;;; more information.
6 ;;;;
7 ;;;; This software is derived from the CMU CL system, which was
8 ;;;; written at Carnegie Mellon University and released into the
9 ;;;; public domain. The software is in the public domain and is
10 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
11 ;;;; files for more information.
12
13 (in-package "SB!C")
14
15 (deftype byte-buffer () '(vector (unsigned-byte 8)))
16 (defvar *byte-buffer*)
17 (declaim (type byte-buffer *byte-buffer*))
18 \f
19 ;;;; debug blocks
20
21 (deftype location-kind ()
22   '(member :unknown-return :known-return :internal-error :non-local-exit
23            :block-start :call-site :single-value-return :non-local-entry))
24
25 ;;; The LOCATION-INFO structure holds the information what we need
26 ;;; about locations which code generation decided were "interesting".
27 (defstruct (location-info
28             (:constructor make-location-info (kind label vop))
29             (:copier nil))
30   ;; The kind of location noted.
31   (kind nil :type location-kind)
32   ;; The label pointing to the interesting code location.
33   (label nil :type (or label index null))
34   ;; The VOP that emitted this location (for node, save-set, ir2-block, etc.)
35   (vop nil :type vop))
36
37 ;;; This is called during code generation in places where there is an
38 ;;; "interesting" location: someplace where we are likely to end up
39 ;;; in the debugger, and thus want debug info.
40 (defun note-debug-location (vop label kind)
41   (declare (type vop vop) (type (or label null) label)
42            (type location-kind kind))
43   (let ((location (make-location-info kind label vop)))
44     (setf (ir2-block-locations (vop-block vop))
45           (nconc (ir2-block-locations (vop-block vop))
46                  (list location)))
47     location))
48
49 #!-sb-fluid (declaim (inline ir2-block-physenv))
50 (defun ir2-block-physenv (2block)
51   (declare (type ir2-block 2block))
52   (block-physenv (ir2-block-block 2block)))
53
54 ;;; Given a local conflicts vector and an IR2 block to represent the
55 ;;; set of live TNs, and the VAR-LOCS hash-table representing the
56 ;;; variables dumped, compute a bit-vector representing the set of
57 ;;; live variables. If the TN is environment-live, we only mark it as
58 ;;; live when it is in scope at NODE.
59 (defun compute-live-vars (live node block var-locs vop)
60   (declare (type ir2-block block) (type local-tn-bit-vector live)
61            (type hash-table var-locs) (type node node)
62            (type (or vop null) vop))
63   (let ((res (make-array (logandc2 (+ (hash-table-count var-locs) 7) 7)
64                          :element-type 'bit
65                          :initial-element 0))
66         (spilled (gethash vop
67                           (ir2-component-spilled-vops
68                            (component-info *component-being-compiled*)))))
69     (do-live-tns (tn live block)
70       (let ((leaf (tn-leaf tn)))
71         (when (and (lambda-var-p leaf)
72                    (or (not (member (tn-kind tn)
73                                     '(:environment :debug-environment)))
74                        (rassoc leaf (lexenv-variables (node-lexenv node))))
75                    (or (null spilled)
76                        (not (member tn spilled))))
77           (let ((num (gethash leaf var-locs)))
78             (when num
79               (setf (sbit res num) 1))))))
80     res))
81
82 ;;; The PC for the location most recently dumped.
83 (defvar *previous-location*)
84 (declaim (type index *previous-location*))
85
86 ;;; Dump a compiled debug-location into *BYTE-BUFFER* that describes
87 ;;; the code/source map and live info. If true, VOP is the VOP
88 ;;; associated with this location, for use in determining whether TNs
89 ;;; are spilled.
90 (defun dump-1-location (node block kind tlf-num label live var-locs vop)
91   (declare (type node node) (type ir2-block block)
92            (type local-tn-bit-vector live)
93            (type (or label index) label)
94            (type location-kind kind) (type (or index null) tlf-num)
95            (type hash-table var-locs) (type (or vop null) vop))
96
97   (vector-push-extend
98    (dpb (position-or-lose kind *compiled-code-location-kinds*)
99         compiled-code-location-kind-byte
100         0)
101    *byte-buffer*)
102
103   (let ((loc (if (fixnump label) label (label-position label))))
104     (write-var-integer (- loc *previous-location*) *byte-buffer*)
105     (setq *previous-location* loc))
106
107   (let ((path (node-source-path node)))
108     (unless tlf-num
109       (write-var-integer (source-path-tlf-number path) *byte-buffer*))
110     (write-var-integer (source-path-form-number path) *byte-buffer*))
111
112   (write-packed-bit-vector (compute-live-vars live node block var-locs vop)
113                            *byte-buffer*)
114
115   (values))
116
117 ;;; Extract context info from a Location-Info structure and use it to
118 ;;; dump a compiled code-location.
119 (defun dump-location-from-info (loc tlf-num var-locs)
120   (declare (type location-info loc) (type (or index null) tlf-num)
121            (type hash-table var-locs))
122   (let ((vop (location-info-vop loc)))
123     (dump-1-location (vop-node vop)
124                      (vop-block vop)
125                      (location-info-kind loc)
126                      tlf-num
127                      (location-info-label loc)
128                      (vop-save-set vop)
129                      var-locs
130                      vop))
131   (values))
132
133 ;;; Scan all the blocks, determining if all locations are in the same
134 ;;; TLF, and returning it or NIL.
135 (defun find-tlf-number (fun)
136   (declare (type clambda fun))
137   (let ((res (source-path-tlf-number (node-source-path (lambda-bind fun)))))
138     (declare (type (or index null) res))
139     (do-physenv-ir2-blocks (2block (lambda-physenv fun))
140       (let ((block (ir2-block-block 2block)))
141         (when (eq (block-info block) 2block)
142           (unless (eql (source-path-tlf-number
143                         (node-source-path
144                          (continuation-next
145                           (block-start block))))
146                        res)
147             (setq res nil)))
148         
149         (dolist (loc (ir2-block-locations 2block))
150           (unless (eql (source-path-tlf-number
151                         (node-source-path
152                          (vop-node (location-info-vop loc))))
153                        res)
154             (setq res nil)))))
155     res))
156
157 ;;; Dump out the number of locations and the locations for Block.
158 (defun dump-block-locations (block locations tlf-num var-locs)
159   (declare (type cblock block) (list locations))
160   (if (and locations
161            (eq (location-info-kind (first locations))
162                :non-local-entry))
163       (write-var-integer (length locations) *byte-buffer*)
164       (let ((2block (block-info block)))
165         (write-var-integer (+ (length locations) 1) *byte-buffer*)
166         (dump-1-location (continuation-next (block-start block))
167                          2block :block-start tlf-num
168                          (ir2-block-%label 2block)
169                          (ir2-block-live-out 2block)
170                          var-locs
171                          nil)))
172   (dolist (loc locations)
173     (dump-location-from-info loc tlf-num var-locs))
174   (values))
175
176 ;;; Dump the successors of Block, being careful not to fly into space
177 ;;; on weird successors.
178 (defun dump-block-successors (block env)
179   (declare (type cblock block) (type physenv env))
180   (let* ((tail (component-tail (block-component block)))
181          (succ (block-succ block))
182          (valid-succ
183           (if (and succ
184                    (or (eq (car succ) tail)
185                        (not (eq (block-physenv (car succ)) env))))
186               ()
187               succ)))
188     (vector-push-extend
189      (dpb (length valid-succ) compiled-debug-block-nsucc-byte 0)
190      *byte-buffer*)
191     (let ((base (block-number
192                  (node-block
193                   (lambda-bind (physenv-function env))))))
194       (dolist (b valid-succ)
195         (write-var-integer
196          (the index (- (block-number b) base))
197          *byte-buffer*))))
198   (values))
199
200 ;;; Return a vector and an integer (or null) suitable for use as the
201 ;;; BLOCKS and TLF-NUMBER in FUN's DEBUG-FUN. This requires two
202 ;;; passes to compute:
203 ;;; -- Scan all blocks, dumping the header and successors followed
204 ;;;    by all the non-elsewhere locations.
205 ;;; -- Dump the elsewhere block header and all the elsewhere 
206 ;;;    locations (if any.)
207 (defun compute-debug-blocks (fun var-locs)
208   (declare (type clambda fun) (type hash-table var-locs))
209   (setf (fill-pointer *byte-buffer*) 0)
210   (let ((*previous-location* 0)
211         (tlf-num (find-tlf-number fun))
212         (env (lambda-physenv fun))
213         (prev-locs nil)
214         (prev-block nil))
215     (collect ((elsewhere))
216       (do-physenv-ir2-blocks (2block env)
217         (let ((block (ir2-block-block 2block)))
218           (when (eq (block-info block) 2block)
219             (when prev-block
220               (dump-block-locations prev-block prev-locs tlf-num var-locs))
221             (setq prev-block block  prev-locs ())
222             (dump-block-successors block env)))
223         
224         (collect ((here prev-locs))
225           (dolist (loc (ir2-block-locations 2block))
226             (if (label-elsewhere-p (location-info-label loc))
227                 (elsewhere loc)
228                 (here loc)))
229           (setq prev-locs (here))))
230
231       (dump-block-locations prev-block prev-locs tlf-num var-locs)
232
233       (when (elsewhere)
234         (vector-push-extend compiled-debug-block-elsewhere-p *byte-buffer*)
235         (write-var-integer (length (elsewhere)) *byte-buffer*)
236         (dolist (loc (elsewhere))
237           (dump-location-from-info loc tlf-num var-locs))))
238
239     (values (copy-seq *byte-buffer*) tlf-num)))
240 \f
241 ;;; Return a list of DEBUG-SOURCE structures containing information
242 ;;; derived from INFO. Unless :BYTE-COMPILE T was specified, we always
243 ;;; dump the Start-Positions, since it is too hard figure out whether
244 ;;; we need them or not.
245 (defun debug-source-for-info (info)
246   (declare (type source-info info))
247   (let* ((file-info (source-info-file-info info))
248          (res (make-debug-source
249                :from :file
250                :created (file-info-write-date file-info)
251                :compiled (source-info-start-time info)
252                :source-root (file-info-source-root file-info)
253                :start-positions (coerce-to-smallest-eltype
254                                  (file-info-positions file-info))))
255          (name (file-info-name file-info)))
256     (etypecase name
257       ((member :lisp)
258        (setf (debug-source-from res) name)
259        (setf (debug-source-name res)
260              (coerce (file-info-forms file-info) 'simple-vector)))
261       (pathname
262        (let* ((untruename (file-info-untruename file-info))
263               (dir (pathname-directory untruename)))
264          (setf (debug-source-name res)
265                (namestring
266                 (if (and dir (eq (first dir) :absolute))
267                     untruename
268                     name))))))
269     (list res)))
270
271
272 ;;; Given an arbitrary sequence, coerce it to an unsigned vector if
273 ;;; possible. Ordinarily we coerce it to the smallest specialized
274 ;;; vector we can. However, we also have a special hack for
275 ;;; cross-compiling at bootstrap time, when arbitrarily-specialized
276 ;;; vectors aren't fully supported: in that case, we coerce it only to
277 ;;; a vector whose element size is an integer multiple of output byte
278 ;;; size.
279 (defun coerce-to-smallest-eltype (seq)
280   (let ((maxoid #-sb-xc-host 0
281                 ;; An initial value of 255 prevents us from
282                 ;; specializing the array to anything smaller than
283                 ;; (UNSIGNED-BYTE 8), which keeps the cross-compiler's
284                 ;; portable specialized array output functions happy.
285                 #+sb-xc-host 255))
286     (flet ((frob (x)
287              (if (typep x 'unsigned-byte)
288                  (when (>= x maxoid)
289                    (setf maxoid x))
290                  (return-from coerce-to-smallest-eltype
291                    (coerce seq 'simple-vector)))))
292       (if (listp seq)
293           (dolist (i seq)
294             (frob i))
295           (dovector (i seq)
296             (frob i)))
297       (coerce seq `(simple-array (integer 0 ,maxoid) (*))))))
298 \f
299 ;;;; variables
300
301 ;;; Return a SC-OFFSET describing TN's location.
302 (defun tn-sc-offset (tn)
303   (declare (type tn tn))
304   (make-sc-offset (sc-number (tn-sc tn))
305                   (tn-offset tn)))
306
307 ;;; Dump info to represent Var's location being TN. ID is an integer
308 ;;; that makes Var's name unique in the function. Buffer is the vector
309 ;;; we stick the result in. If Minimal is true, we suppress name
310 ;;; dumping, and set the minimal flag.
311 ;;;
312 ;;; The debug-var is only marked as always-live if the TN is
313 ;;; environment live and is an argument. If a :debug-environment TN,
314 ;;; then we also exclude set variables, since the variable is not
315 ;;; guaranteed to be live everywhere in that case.
316 (defun dump-1-variable (fun var tn id minimal buffer)
317   (declare (type lambda-var var) (type (or tn null) tn) (type index id)
318            (type clambda fun))
319   (let* ((name (leaf-name var))
320          (save-tn (and tn (tn-save-tn tn)))
321          (kind (and tn (tn-kind tn)))
322          (flags 0))
323     (declare (type index flags))
324     (when minimal
325       (setq flags (logior flags compiled-debug-var-minimal-p))
326       (unless tn
327         (setq flags (logior flags compiled-debug-var-deleted-p))))
328     (when (and (or (eq kind :environment)
329                    (and (eq kind :debug-environment)
330                         (null (basic-var-sets var))))
331                (not (gethash tn (ir2-component-spilled-tns
332                                  (component-info *component-being-compiled*))))
333                (eq (lambda-var-home var) fun))
334       (setq flags (logior flags compiled-debug-var-environment-live)))
335     (when save-tn
336       (setq flags (logior flags compiled-debug-var-save-loc-p)))
337     (unless (or (zerop id) minimal)
338       (setq flags (logior flags compiled-debug-var-id-p)))
339     (vector-push-extend flags buffer)
340     (unless minimal
341       (vector-push-extend name buffer)
342       (unless (zerop id)
343         (vector-push-extend id buffer)))
344     (if tn
345         (vector-push-extend (tn-sc-offset tn) buffer)
346         (aver minimal))
347     (when save-tn
348       (vector-push-extend (tn-sc-offset save-tn) buffer)))
349   (values))
350
351 ;;; Return a vector suitable for use as the DEBUG-FUN-VARIABLES
352 ;;; of FUN. LEVEL is the current DEBUG-INFO quality. VAR-LOCS is a
353 ;;; hashtable in which we enter the translation from LAMBDA-VARS to
354 ;;; the relative position of that variable's location in the resulting
355 ;;; vector.
356 (defun compute-variables (fun level var-locs)
357   (declare (type clambda fun) (type hash-table var-locs))
358   (collect ((vars))
359     (labels ((frob-leaf (leaf tn gensym-p)
360                (let ((name (leaf-name leaf)))
361                  (when (and name (leaf-refs leaf) (tn-offset tn)
362                             (or gensym-p (symbol-package name)))
363                    (vars (cons leaf tn)))))
364              (frob-lambda (x gensym-p)
365                (dolist (leaf (lambda-vars x))
366                  (frob-leaf leaf (leaf-info leaf) gensym-p))))
367       (frob-lambda fun t)
368       (when (>= level 2)
369         (dolist (x (ir2-physenv-environment
370                     (physenv-info (lambda-physenv fun))))
371           (let ((thing (car x)))
372             (when (lambda-var-p thing)
373               (frob-leaf thing (cdr x) (= level 3)))))
374         
375         (dolist (let (lambda-lets fun))
376           (frob-lambda let (= level 3)))))
377
378     (let ((sorted (sort (vars) #'string<
379                         :key #'(lambda (x)
380                                  (symbol-name (leaf-name (car x))))))
381           (prev-name nil)
382           (id 0)
383           (i 0)
384           (buffer (make-array 0 :fill-pointer 0 :adjustable t)))
385       (declare (type (or simple-string null) prev-name)
386                (type index id i))
387       (dolist (x sorted)
388         (let* ((var (car x))
389                (name (symbol-name (leaf-name var))))
390           (cond ((and prev-name (string= prev-name name))
391                  (incf id))
392                 (t
393                  (setq id 0  prev-name name)))
394           (dump-1-variable fun var (cdr x) id nil buffer)
395           (setf (gethash var var-locs) i))
396         (incf i))
397       (coerce buffer 'simple-vector))))
398
399 ;;; Return a vector suitable for use as the DEBUG-FUN-VARIABLES of
400 ;;; FUN, representing the arguments to FUN in minimal variable format.
401 (defun compute-minimal-variables (fun)
402   (declare (type clambda fun))
403   (let ((buffer (make-array 0 :fill-pointer 0 :adjustable t)))
404     (dolist (var (lambda-vars fun))
405       (dump-1-variable fun var (leaf-info var) 0 t buffer))
406     (coerce buffer 'simple-vector)))
407
408 ;;; Return VAR's relative position in the function's variables (determined
409 ;;; from the VAR-LOCS hashtable).  If VAR is deleted, then return DELETED.
410 (defun debug-location-for (var var-locs)
411   (declare (type lambda-var var) (type hash-table var-locs))
412   (let ((res (gethash var var-locs)))
413     (cond (res)
414           (t
415            (aver (or (null (leaf-refs var))
416                      (not (tn-offset (leaf-info var)))))
417            'deleted))))
418 \f
419 ;;;; arguments/returns
420
421 ;;; Return a vector to be used as the
422 ;;; COMPILED-DEBUG-FUN-ARGUMENTS for Fun. If fun is the
423 ;;; MAIN-ENTRY for an optional dispatch, then look at the ARGLIST to
424 ;;; determine the syntax, otherwise pretend all arguments are fixed.
425 ;;;
426 ;;; ### This assumption breaks down in EPs other than the main-entry,
427 ;;; since they may or may not have supplied-p vars, etc.
428 (defun compute-arguments (fun var-locs)
429   (declare (type clambda fun) (type hash-table var-locs))
430   (collect ((res))
431     (let ((od (lambda-optional-dispatch fun)))
432       (if (and od (eq (optional-dispatch-main-entry od) fun))
433           (let ((actual-vars (lambda-vars fun))
434                 (saw-optional nil))
435             (dolist (arg (optional-dispatch-arglist od))
436               (let ((info (lambda-var-arg-info arg))
437                     (actual (pop actual-vars)))
438                 (cond (info
439                        (case (arg-info-kind info)
440                          (:keyword
441                           (res (arg-info-key info)))
442                          (:rest
443                           (res 'rest-arg))
444                          (:more-context
445                           (res 'more-arg))
446                          (:optional
447                           (unless saw-optional
448                             (res 'optional-args)
449                             (setq saw-optional t))))
450                        (res (debug-location-for actual var-locs))
451                        (when (arg-info-supplied-p info)
452                          (res 'supplied-p)
453                          (res (debug-location-for (pop actual-vars) var-locs))))
454                       (t
455                        (res (debug-location-for actual var-locs)))))))
456           (dolist (var (lambda-vars fun))
457             (res (debug-location-for var var-locs)))))
458
459     (coerce-to-smallest-eltype (res))))
460
461 ;;; Return a vector of SC offsets describing FUN's return locations.
462 ;;; (Must be known values return...)
463 (defun compute-debug-returns (fun)
464   (coerce-to-smallest-eltype
465    (mapcar #'(lambda (loc)
466                (tn-sc-offset loc))
467            (return-info-locations (tail-set-info (lambda-tail-set fun))))))
468 \f
469 ;;;; debug functions
470
471 ;;; Return a C-D-F structure with all the mandatory slots filled in.
472 (defun dfun-from-fun (fun)
473   (declare (type clambda fun))
474   (let* ((2env (physenv-info (lambda-physenv fun)))
475          (dispatch (lambda-optional-dispatch fun))
476          (main-p (and dispatch
477                       (eq fun (optional-dispatch-main-entry dispatch)))))
478     (make-compiled-debug-fun
479      :name (cond ((leaf-name fun))
480                  ((let ((ef (functional-entry-function fun)))
481                     (and ef (leaf-name ef))))
482                  ((and main-p (leaf-name dispatch)))
483                  (t
484                   (component-name
485                    (block-component (node-block (lambda-bind fun))))))
486      :kind (if main-p nil (functional-kind fun))
487      :return-pc (tn-sc-offset (ir2-physenv-return-pc 2env))
488      :old-fp (tn-sc-offset (ir2-physenv-old-fp 2env))
489      :start-pc (label-position (ir2-physenv-environment-start 2env))
490      :elsewhere-pc (label-position (ir2-physenv-elsewhere-start 2env)))))
491
492 ;;; Return a complete C-D-F structure for FUN. This involves
493 ;;; determining the DEBUG-INFO level and filling in optional slots as
494 ;;; appropriate.
495 (defun compute-1-debug-fun (fun var-locs)
496   (declare (type clambda fun) (type hash-table var-locs))
497   (let* ((dfun (dfun-from-fun fun))
498          (actual-level (policy (lambda-bind fun) debug))
499          (level (if #!+sb-dyncount *collect-dynamic-statistics*
500                     #!-sb-dyncount nil
501                     (max actual-level 2)
502                     actual-level)))
503     (cond ((zerop level))
504           ((and (<= level 1)
505                 (let ((od (lambda-optional-dispatch fun)))
506                   (or (not od)
507                       (not (eq (optional-dispatch-main-entry od) fun)))))
508            (setf (compiled-debug-fun-variables dfun)
509                  (compute-minimal-variables fun))
510            (setf (compiled-debug-fun-arguments dfun) :minimal))
511           (t
512            (setf (compiled-debug-fun-variables dfun)
513                  (compute-variables fun level var-locs))
514            (setf (compiled-debug-fun-arguments dfun)
515                  (compute-arguments fun var-locs))))
516
517     (when (>= level 2)
518       (multiple-value-bind (blocks tlf-num) (compute-debug-blocks fun var-locs)
519         (setf (compiled-debug-fun-tlf-number dfun) tlf-num)
520         (setf (compiled-debug-fun-blocks dfun) blocks)))
521
522     (if (external-entry-point-p fun)
523         (setf (compiled-debug-fun-returns dfun) :standard)
524         (let ((info (tail-set-info (lambda-tail-set fun))))
525           (when info
526             (cond ((eq (return-info-kind info) :unknown)
527                    (setf (compiled-debug-fun-returns dfun)
528                          :standard))
529                   ((/= level 0)
530                    (setf (compiled-debug-fun-returns dfun)
531                          (compute-debug-returns fun)))))))
532     dfun))
533 \f
534 ;;;; full component dumping
535
536 ;;; Compute the full form (simple-vector) function map.
537 (defun compute-debug-fun-map (sorted)
538   (declare (list sorted))
539   (let* ((len (1- (* (length sorted) 2)))
540          (funs-vec (make-array len)))
541     (do ((i -1 (+ i 2))
542          (sorted sorted (cdr sorted)))
543         ((= i len))
544       (declare (fixnum i))
545       (let ((dfun (car sorted)))
546         (unless (minusp i)
547           (setf (svref funs-vec i) (car dfun)))
548         (setf (svref funs-vec (1+ i)) (cdr dfun))))
549     funs-vec))
550
551 ;;; Return a DEBUG-INFO structure describing COMPONENT. This has to be
552 ;;; called after assembly so that source map information is available.
553 (defun debug-info-for-component (component)
554   (declare (type component component))
555   (collect ((dfuns))
556     (let ((var-locs (make-hash-table :test 'eq))
557           (*byte-buffer* (make-array 10
558                                      :element-type '(unsigned-byte 8)
559                                      :fill-pointer 0
560                                      :adjustable t)))
561       (dolist (fun (component-lambdas component))
562         (clrhash var-locs)
563         (dfuns (cons (label-position
564                       (block-label (node-block (lambda-bind fun))))
565                      (compute-1-debug-fun fun var-locs))))
566       (let* ((sorted (sort (dfuns) #'< :key #'car))
567              (fun-map (compute-debug-fun-map sorted)))
568         (make-compiled-debug-info :name (component-name component)
569                                   :fun-map fun-map)))))
570 \f
571 ;;; Write BITS out to BYTE-BUFFER in backend byte order. The length of
572 ;;; BITS must be evenly divisible by eight.
573 (defun write-packed-bit-vector (bits byte-buffer)
574   (declare (type simple-bit-vector bits) (type byte-buffer byte-buffer))
575   (multiple-value-bind (initial step done)
576       (ecase *backend-byte-order*
577         (:little-endian (values 0  1  8))
578         (:big-endian    (values 7 -1 -1)))
579     (let ((shift initial)
580           (byte 0))
581       (dotimes (i (length bits))
582         (let ((int (aref bits i)))
583           (setf byte (logior byte (ash int shift)))
584           (incf shift step))
585         (when (= shift done)
586           (vector-push-extend byte byte-buffer)
587           (setf shift initial
588                 byte 0)))
589       (unless (= shift initial)
590         (vector-push-extend byte byte-buffer))))
591   (values))