src/code/debug-var-io.lisp

   1 ;;;; variable-length encoding and other i/o tricks for the debugger
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; This software is derived from the CMU CL system, which was
   7 ;;;; written at Carnegie Mellon University and released into the
   8 ;;;; public domain. The software is in the public domain and is
   9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  10 ;;;; files for more information.
  11
  12 (in-package "SB!C")
  13 \f
  14 ;;;; reading variable length integers
  15 ;;;;
  16 ;;;; The debug info representation makes extensive use of 32-bit
  17 ;;;; integers encoded in an octet vector using between one and five
  18 ;;;; octets. Each octet
  19 ;;;;
  20 ;;;;   miiiiiii
  21 ;;;;
  22 ;;;; encodes 7 bits of the integer (i) while the final bit indicates
  23 ;;;; whether more (m) octets follow. For example:
  24 ;;;;
  25 ;;;;   #x88888888 => 10001000 10010001 10100010 11000100 00001000
  26
  27 ;;; Given an octet-vector SOURCE and an initial offset START, read a
  28 ;;; variable length integer and return two values 1) the integer 2)
  29 ;;; the new offset
  30 (defun var-integer-decoding-error (source start offset)
  31   (error "~@<Improperly terminated variable-length integer in ~S at ~
  32           ~D (starting at ~D).~@:>"
  33          source offset start))
  34
  35 (macrolet
  36     ((define-read-var-integer (function-name macro-name source-type accessor)
  37        `(progn
  38           (declaim (ftype (function (,source-type index)
  39                                     (values (unsigned-byte 32) index))
  40                           ,function-name))
  41           (defun ,function-name (source start)
  42             (loop
  43                for offset :of-type index              from start  ; position in buffer
  44                for k      :of-type (integer 0 28)     from 0 by 7 ; position in integer
  45                for octet                              =    (,accessor source offset)
  46                for finalp                             =    (not (logbitp 7 octet))
  47                for accum  :of-type (unsigned-byte 36) =    (mask-field (byte 7 0) octet)
  48                                                       then (dpb octet (byte 7 k) accum)
  49                when (and (= k 28) (not (zerop (ldb (byte 4 4) octet))))
  50                do (var-integer-decoding-error source start offset)
  51                when finalp return (values accum (1+ offset))))
  52
  53           (defmacro ,macro-name (vector index)
  54             `(multiple-value-bind (value new-index)
  55                  (,',function-name ,vector ,index)
  56                (setf ,index new-index)
  57                value)))))
  58
  59   (define-read-var-integer read-var-integer read-var-integerf
  60     (array (unsigned-byte 8) 1) aref)
  61
  62   #-sb-xc-host
  63   (define-read-var-integer sap-read-var-integer sap-read-var-integerf
  64     system-area-pointer sap-ref-8))
  65
  66 ;;; Take an adjustable vector VECTOR with a fill pointer and push the
  67 ;;; variable length representation of VALUE on the end.
  68 (declaim (ftype (sfunction ((unsigned-byte 32) (array (unsigned-byte 8) 1)) (integer 0 5))
  69                 write-var-integer))
  70 (defun write-var-integer (value vector)
  71   (loop
  72      for v      :of-type (unsigned-byte 32) = value then (ash v -7)
  73      for v-next :of-type (unsigned-byte 32) = (ash v -7)
  74      for i                                  from 0
  75      until (and (plusp i) (zerop v))
  76      do (vector-push-extend (dpb (if (zerop v-next) 0 1) (byte 1 7)
  77                                  (ldb (byte 7 0) v))
  78                             vector)
  79      finally (return i)))
  80
  81 \f
  82 ;;;; packed strings
  83 ;;;;
  84 ;;;; A packed string is a variable length integer length followed by
  85 ;;;; the character codes.
  86
  87 ;;; Read a packed string from VEC starting at INDEX, advancing INDEX.
  88 (defmacro read-var-string (vec index)
  89   (once-only ((len `(read-var-integerf ,vec ,index)))
  90     (once-only ((res `(make-string ,len)))
  91       `(progn
  92          (loop for i from 0 below ,len
  93                do (setf (aref ,res i)
  94                         (code-char (read-var-integerf ,vec ,index))))
  95          ,res))))
  96
  97 ;;; Write STRING into VEC (adjustable, with fill-pointer) represented
  98 ;;; as the length (in a var-length integer) followed by the codes of
  99 ;;; the characters.
 100 (defun write-var-string (string vec)
 101   (declare (simple-string string))
 102   (let ((len (length string)))
 103     (write-var-integer len vec)
 104     (dotimes (i len)
 105       (write-var-integer (char-code (schar string i)) vec)))
 106   (values))
 107 \f
 108 ;;;; packed bit vectors
 109
 110 ;;; Read the specified number of BYTES out of VEC at INDEX and convert
 111 ;;; them to a BIT-VECTOR. INDEX is incremented.
 112 (defmacro read-packed-bit-vector (bytes vec index)
 113   (once-only ((n-bytes bytes))
 114     (once-only ((n-res `(make-array (* ,n-bytes 8) :element-type 'bit)))
 115       `(progn
 116          (%byte-blt ,vec ,index ,n-res 0 ,n-bytes)
 117          (incf ,index ,n-bytes)
 118          ,n-res))))
 119
 120 ;;; Code fixup locations are stored as varints even more densely than
 121 ;;; would be an array of unsigned-byte. The backing storage is an integer
 122 ;;; (typically a bignum, but a fixnum will do),
 123 ;;; and each value represents the difference from the preceding value.
 124
 125 ;;; Somebody should try changing the x86 code to use this representation
 126 ;;; and profile that to see if it makes performance worse.
 127 ;;; x86-64 does not care about speed here, because GC is unaffected
 128 ;;; except when saving a core.
 129
 130 ;;; XXX: Maybe rename this if we use it to pack debug-fun-ish things.
 131 (defun pack-code-fixup-locs (list)
 132   ;; Estimate the length
 133   (let ((bytes (make-array (* 2 (length list)) :fill-pointer 0 :adjustable t
 134                            :element-type '(unsigned-byte 8)))
 135         (prev 0))
 136     (dolist (x list)
 137       (aver (> x prev)) ; the incoming list must be sorted
 138       (write-var-integer (- x prev) bytes)
 139       (setq prev x))
 140     ;; Pack into a single integer
 141     (let ((result 0) (shift 0))
 142       (dovector (byte bytes)
 143         (setf result (logior result (ash byte shift))
 144               shift (+ shift 8)))
 145       (aver (equal (unpack-code-fixup-locs result) list))
 146       result)))
 147
 148 (defmacro do-packed-varints ((loc locs) &body body)
 149   (with-unique-names (integer byte bytepos shift acc prev)
 150     `(let ((,integer ,locs)
 151            (,bytepos 0)
 152            (,shift 0)
 153            (,acc 0)
 154            (,prev 0))
 155        (loop
 156         (let ((,byte (ldb (byte 8 ,bytepos) ,integer)))
 157           (incf ,bytepos 8)
 158           (setf ,acc (logior ,acc (ash (logand ,byte #x7f) ,shift)))
 159           (cond ((logtest ,byte #x80) (incf ,shift 7))
 160                 ;; No offset can be zero, so this is the delimiter
 161                 ((zerop ,acc) (return))
 162                 (t
 163                  (let ((,loc (+ ,prev ,acc))) ,@body (setq ,prev ,loc))
 164                  (setq ,acc 0 ,shift 0))))))))
 165
 166 (defun unpack-code-fixup-locs (packed-integer)
 167   (collect ((locs))
 168     (do-packed-varints (loc packed-integer) (locs loc))
 169     (locs)))