Changeset 11373 for trunk/source/level-1


Ignore:
Timestamp:
Nov 16, 2008, 3:35:28 PM (11 years ago)
Author:
gz
Message:

Finish source location and pc -> source mapping support, from working-0711 but with some modifications.

Details:

Source location are recorded in CCL:SOURCE-NOTE's, which are objects with accessors CCL:SOURCE-NOTE-FILENAME, CCL:SOURCE-NOTE-START-POS, CCL:SOURCE-NOTE-END-POS and CCL:SOURCE-NOTE-TEXT. The start and end positions are file positions (not character positions). The text will be NIL unless text recording was on at read-time. If the original file is still available, you can force missing source text to be read from the file at runtime via CCL:ENSURE-SOURCE-NOTE-TEXT.

Source-note's are associated with definitions (via record-source-file) and also stored in function objects (including anonymous and nested functions). The former can be retrieved via CCL:FIND-DEFINITION-SOURCES, the latter via CCL:FUNCTION-SOURCE-NOTE.

The recording behavior is controlled by the new variable CCL:*SAVE-SOURCE-LOCATIONS*:

If NIL, don't store source-notes in function objects, and store only the filename for definitions (the latter only if *record-source-file* is true).
If T, store source-notes, including a copy of the original source text, for function objects and definitions (the latter only if *record-source-file* is true).
If :NO-TEXT, store source-notes, but without saved text, for function objects and defintions (the latter only if *record-source-file* is true). This is the default.

PC to source mapping is controlled by the new variable CCL:*RECORD-PC-MAPPING*. If true (the default), functions store a compressed table mapping pc offsets to corresponding source locations. This can be retrieved by (CCL:FIND-SOURCE-NOTE-AT-PC function pc) which returns a source-note for the source at offset pc in the function.

Currently the only thing that makes use of any of this is the disassembler. ILISP and current version of Slime still use backward-compatible functions that deal with filenames only. The plan is to make Slime, and our IDE, use this eventually.

Known bug: most of this only works through the file compiler. Still need to make it work with loading from source (not hard, just haven't gotten to it yet).

This checkin incidentally includes bits and pieces of support for code coverage, which is still
incomplete and untested. Ignore it.

The PPC version is untested. I need to check it in so I can move to a PPC for testing.

Sizes:

18387152 Nov 16 10:00 lx86cl64.image-no-loc-no-pc
19296464 Nov 16 10:11 lx86cl64.image-loc-no-text-no-pc
20517072 Nov 16 09:58 lx86cl64.image-loc-no-text-with-pc [default]
25514192 Nov 16 09:55 lx86cl64.image-loc-with-text-with-pc

Location:
trunk/source/level-1
Files:
8 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/level-1/l1-boot-1.lisp

    r10627 r11373  
    115115(catch :toplevel
    116116  (setq *loading-file-source-file* nil)  ;Reset from last %fasload...
     117  (setq *loading-toplevel-location* nil)
    117118  (init-logical-directories)
    118119  )
  • trunk/source/level-1/l1-boot-2.lisp

    r11368 r11373  
    2727                                  (namestring (backend-target-fasl-pathname
    2828                                               *target-backend*)))))
    29        `(let* ((*loading-file-source-file* *loading-file-source-file*))
    30                  (%fasload ,namestring))))
     29               `(let* ((*loading-file-source-file* *loading-file-source-file*)
     30                       (*loading-toplevel-location* *loading-toplevel-location*))
     31                  (%fasload ,namestring))))
    3132           (bin-load (name)
    3233             (let* ((namestring
     
    3637                                  (namestring (backend-target-fasl-pathname
    3738                                               *target-backend*)))))
    38                `(let* ((*loading-file-source-file* *loading-file-source-file*))
    39                  (%fasload ,namestring)))))
     39               `(let* ((*loading-file-source-file* *loading-file-source-file*)
     40                       (*loading-toplevel-location* *loading-toplevel-location*))
     41                  (%fasload ,namestring)))))
    4042
    4143
  • trunk/source/level-1/l1-files.lisp

    r11135 r11373  
    12361236           (*loading-files* (cons file-name (specialv *loading-files*)))
    12371237           ;;reset by fasload to logical name stored in the file
    1238            (*loading-file-source-file* (namestring source-file)))
     1238           (*loading-file-source-file* (namestring source-file))
     1239           (*loading-toplevel-location* nil))
    12391240      (declare (special *loading-files* *loading-file-source-file*))
    12401241      (when verbose
  • trunk/source/level-1/l1-init.lisp

    r11135 r11373  
    260260(defparameter *save-definitions* nil)
    261261(defparameter *save-local-symbols* t)
     262(defparameter *save-source-locations* :no-text
     263  "Controls whether complete source locations is stored, both for definitions (names) and
     264in function objects.
     265
     266If NIL we don't store any source location (other than the filename if *record-source-file* is non-NIL).
     267
     268If T we store as much source location information as we have available.
     269
     270If :NO-TEXT we don't store a copy of the original source text.")
     271(defparameter *record-pc-mapping* t)
    262272
    263273(defvar *modules* nil
  • trunk/source/level-1/l1-reader.lisp

    r11268 r11373  
    25132513                  t
    25142514                  (and start-pos
    2515                        (make-source-note :form form
    2516                                          :stream stream
    2517                                          :start-pos (1- start-pos)
    2518                                          :end-pos end-pos
    2519                                          :subform-notes nested-source-notes))))))))
     2515                       (record-source-note :form form
     2516                                           :stream stream
     2517                                           :start-pos (1- start-pos)
     2518                                           :end-pos end-pos
     2519                                           :subform-notes nested-source-notes))))))))
    25202520
    25212521#|
     
    29982998;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    29992999
    3000 (defstruct (source-note (:constructor %make-source-note))
     3000(defstruct (source-note (:conc-name "SOURCE-NOTE.") (:constructor %make-source-note))
    30013001  ;; For an inner source form, the source-note of the outer source form.
     3002  ;; For outer source note, octets
    30023003  source
    3003   file-name
     3004  filename
     3005  ;; start and end file positions (NOT characters positions)
    30043006  file-range)
    30053007
    3006 (defun encode-file-range (start-pos end-pos)
    3007   (let ((len (- end-pos start-pos)))
    3008     (if (< len (ash 1 12))
    3009       (+ (ash start-pos 12) len)
    3010       (cons start-pos end-pos))))
     3008(defun make-source-note (&key filename start-pos end-pos source)
     3009  (%make-source-note :filename filename
     3010                     :file-range (encode-file-range start-pos end-pos)
     3011                     :source source))
     3012
     3013(defmethod print-object ((sn source-note) stream)
     3014  (print-unreadable-object (sn stream :type t :identity nil)
     3015    (let ((*print-length* (min (or *print-length* 3) 3)))
     3016      (format stream "~s:~s-~s ~s" (source-note-filename sn)
     3017              (source-note-start-pos sn) (source-note-end-pos sn)
     3018              (source-note.source sn)))))
     3019
     3020(defun source-note-filename (source)
     3021  (if (source-note-p source)
     3022    (source-note.filename source)
     3023    ;;  else null or a pathname, as in record-source-file
     3024    source))
     3025
     3026(defun (setf source-note-filename) (filename source-note)
     3027  (setf (source-note.filename (require-type source-note 'source-note)) filename))
     3028
     3029;; Since source notes are optional, it simplifies a lot of code
     3030;; to have these accessors allow NIL.
     3031
     3032(defun source-note-source (source-note)
     3033  (when source-note
     3034    (source-note.source (require-type source-note 'source-note))))
     3035
     3036(defun source-note-file-range (source-note)
     3037  (when source-note
     3038    (source-note.file-range (require-type source-note 'source-note))))
    30113039
    30123040(defun source-note-start-pos (source-note)
    30133041  (let ((range (source-note-file-range source-note)))
    30143042    (when range
    3015       (if (consp range) (car range) (ash range -12)))))
     3043      (if (consp range) (car range) (ash range -14)))))
    30163044
    30173045(defun source-note-end-pos (source-note)
    30183046  (let ((range (source-note-file-range source-note)))
    30193047    (when range
    3020       (if (consp range) (cdr range) (+ (ash range -12) (logand range #xFFF))))))
     3048      (if (consp range) (cdr range) (+ (ash range -14) (logand range #x3FFF))))))
     3049
     3050(defun encode-file-range (start-pos end-pos)
     3051  (let ((len (- end-pos start-pos)))
     3052    (if (< len (ash 1 14))
     3053      (+ (ash start-pos 14) len)
     3054      (cons start-pos end-pos))))
     3055
     3056(defun source-note-text (source-note &optional start end)
     3057  (let* ((source (source-note-source source-note))
     3058         (start-pos (source-note-start-pos source-note))
     3059         (end-pos (source-note-end-pos source-note))
     3060         (start (or start start-pos))
     3061         (end (or end end-pos)))
     3062    (etypecase source
     3063      (source-note
     3064         (assert (<= (source-note-start-pos source) start end (source-note-end-pos source)))
     3065         (source-note-text source start end))
     3066      ((simple-array (unsigned-byte 8) (*))
     3067         (decf start start-pos)
     3068         (decf end start-pos)
     3069         (assert (and (<= 0 start end (length source))))
     3070         (decode-string-from-octets source :start start :end end :external-format :utf-8))
     3071      (null source))))
    30213072
    30223073(defvar *recording-source-streams* ())
    30233074
    3024 (defun make-source-note (&key form stream start-pos end-pos subform-notes)
     3075(defun record-source-note (&key form stream start-pos end-pos subform-notes)
    30253076  (let ((recording (assq stream *recording-source-streams*)))
    30263077    (when (and recording (not *read-suppress*))
    30273078      (destructuring-bind (map file-name stream-offset) (cdr recording)
    30283079        (let* ((prev (gethash form map))
    3029                (note (%make-source-note :file-name file-name
    3030                                         :file-range (encode-file-range
    3031                                                      (+ stream-offset start-pos)
    3032                                                      (+ stream-offset end-pos)))))
     3080               (note (make-source-note :filename file-name
     3081                                       :start-pos (+ stream-offset start-pos)
     3082                                       :end-pos (+ stream-offset end-pos))))
    30333083          (setf (gethash form map)
    30343084                (cond ((null prev) note)
     
    30373087          (loop for sub in subform-notes as subnote = (require-type sub 'source-note)
    30383088            do (when (source-note-source subnote) (error "Subnote ~s already owned?" subnote))
    3039             do (setf (source-note-source subnote) note))
     3089            do (setf (source-note.source subnote) note))
    30403090          note)))))
    30413091
    3042 (defmethod make-load-form ((note source-note) &optional env)
    3043   (make-load-form-saving-slots note :environment env))
    3044 
    3045 (defun read-recording-source (stream &key eofval file-name start-offset map)
     3092(defun read-recording-source (stream &key eofval file-name start-offset map save-source-text)
    30463093  "Read a top-level form, perhaps recording source locations.
    30473094If MAP is NIL, just reads a form as if by READ.
     
    30493096In addition, if MAP is a hash table, it gets filled with source-note's for all
    30503097non-atomic nested subforms."
     3098  (when (null start-offset) (setq start-offset 0))
    30513099  (typecase map
    30523100    (null (values (read-internal stream nil eofval nil) nil))
    30533101    (hash-table
    3054      (let* ((recording (list stream map file-name (or start-offset 0)))
    3055             (*recording-source-streams* (cons recording *recording-source-streams*)))
    3056        (declare (dynamic-extent recording *recording-source-streams*))
    3057        (multiple-value-bind (form source-note) (read-internal stream nil eofval nil)
    3058          (when (and source-note (not (eq form eofval)))
    3059            (assert (null (source-note-source source-note)))
    3060            (loop for form being the hash-key using (hash-value note) of map
    3061                  do (cond ((eq note source-note) nil)
    3062                           ;; Remove entries with multiple source notes, which can happen
    3063                           ;; for atoms.  If we can't tell which instance we mean, then we
    3064                           ;; don't have useful source info.
    3065                           ((listp note) (remhash form map))
    3066                           ((loop for p = note then (source-note-source p) while (source-note-p p)
    3067                                  thereis (eq p source-note))
    3068                            ;; Flatten the backpointers so each subnote points directly
    3069                            ;; to the toplevel note.
    3070                            (setf (source-note-source note) source-note)))))
    3071          (values form source-note))))
     3102       (let* ((recording (list stream map file-name start-offset))
     3103              (*recording-source-streams* (cons recording *recording-source-streams*)))
     3104         (declare (dynamic-extent recording *recording-source-streams*))
     3105         (multiple-value-bind (form source-note) (read-internal stream nil eofval nil)
     3106           (when (and source-note (not (eq form eofval)))
     3107             (assert (null (source-note-source source-note)))
     3108             (loop for form being the hash-key using (hash-value note) of map
     3109                   do (cond ((eq note source-note) nil)
     3110                            ;; Remove entries with multiple source notes, which can happen
     3111                            ;; for atoms.  If we can't tell which instance we mean, then we
     3112                            ;; don't have useful source info.
     3113                            ((listp note) (remhash form map))
     3114                            ((loop for p = note then (source-note-source p) while (source-note-p p)
     3115                                   thereis (eq p source-note))
     3116                             ;; Flatten the backpointers so each subnote points directly
     3117                             ;; to the toplevel note.
     3118                             (setf (source-note.source note) source-note))))
     3119             (when save-source-text
     3120               (setf (source-note.source source-note)
     3121                     (fetch-octets-from-stream stream
     3122                                               (- (source-note-start-pos source-note)
     3123                                                  start-offset)
     3124                                               (- (source-note-end-pos source-note)
     3125                                                  start-offset)))))
     3126           (values form source-note))))
    30723127    (T
    3073      (let* ((start (file-position stream))
    3074             (form (read-internal stream nil eofval nil)))
    3075        (values form (and (neq form eofval)
    3076                          (%make-source-note :file-name file-name
    3077                                             :file-range (encode-file-range
    3078                                                          (+ (or start-offset 0)
    3079                                                             start)
    3080                                                          (+ (or start-offset 0)
    3081                                                             (file-position stream))))))))))
     3128       (let* ((start-pos (file-position stream))
     3129              (form (read-internal stream nil eofval nil))
     3130              (end-pos (and start-pos (neq form eofval) (file-position stream)))
     3131              (source-note (and end-pos
     3132                                (make-source-note :filename file-name
     3133                                                  :start-pos (+ start-offset start-pos)
     3134                                                  :end-pos (+ start-offset end-pos)))))
     3135         (when (and source-note save-source-text)
     3136           (setf (source-note.source source-note) (fetch-octets-from-stream stream start-pos end-pos)))
     3137         (values form source-note)))))
     3138
     3139(defun fetch-octets-from-stream (stream start-offset end-offset)
     3140  ;; We basically want to read the bytes between two positions, but there is no
     3141  ;; direct interface for that.  So we let the stream decode and then we re-encode.
     3142  ;; (Just as well, since otherwise we'd have to remember the file's encoding).
     3143  (declare (fixnum start-offset))
     3144  (when (< start-offset end-offset)
     3145    (let* ((cur-pos (file-position stream))
     3146           (noctets (- end-offset start-offset))
     3147           (vec (make-array noctets :element-type '(unsigned-byte 8)))
     3148           (index 0))
     3149      (declare (type fixnum end-offset noctets index)
     3150               (type (simple-array (unsigned-byte 8) (*)) vec))
     3151      (macrolet ((out (code)
     3152                   `(progn
     3153                      (setf (aref vec index) ,code)
     3154                      (when (eql (incf index) noctets) (return)))))
     3155        (file-position stream start-offset)
     3156        (loop
     3157          (let ((code (char-code (stream-read-char stream))))
     3158            (declare (fixnum code))
     3159            (cond ((< code #x80)
     3160                   (out code))
     3161                  ((< code #x800)
     3162                   (out (logior #xc0 (ldb (byte 5 6) code)))
     3163                   (out (logior #x80 (ldb (byte 6 0) code))))
     3164                  ((< code #x10000)
     3165                   (out (logior #xe0 (ldb (byte 4 12) code)))
     3166                   (out (logior #x80 (ldb (byte 6 6) code)))
     3167                   (out (logior #x80 (ldb (byte 6 0) code))))
     3168                  (t
     3169                   (out (logior #xf0 (ldb (byte 3 18) code)))
     3170                   (out (logior #xe0 (ldb (byte 6 12) code)))
     3171                   (out (logior #x80 (ldb (byte 6 6) code)))
     3172                   (out (logior #x80 (ldb (byte 6 0) code))))))))
     3173      (file-position stream cur-pos)
     3174      vec)))
     3175
     3176(defun ensure-source-note-text (source-note &key (if-does-not-exist nil))
     3177  "Fetch source text from file if don't have it"
     3178  (setq if-does-not-exist (require-type if-does-not-exist '(member :error nil)))
     3179  (let ((source (source-note-source source-note))
     3180        (filename (source-note-filename source-note)))
     3181    (etypecase source
     3182      (null
     3183         (with-open-file (stream filename :if-does-not-exist if-does-not-exist)
     3184           (when stream
     3185             (let ((start (source-note-start-pos source-note))
     3186                   (end (source-note-end-pos source-note))
     3187                   (len (file-length stream)))
     3188               (if (<= end len)
     3189                 (setf (source-note.source source-note)
     3190                       (fetch-octets-from-stream stream start end))
     3191                 (when if-does-not-exist
     3192                   (error 'simple-file-error :pathname filename
     3193                          :error-type "File ~s changed since source info recorded")))))))
     3194      (source-note
     3195         (ensure-source-note-text source))
     3196      ((simple-array (unsigned-byte 8) (*))
     3197         source))))
     3198
     3199
     3200;; This can be called explicitly by macros that do more complicated transforms
     3201(defun note-source-transformation (original new)
     3202  (nx-note-source-transformation original new))
     3203
     3204
     3205
     3206; end
  • trunk/source/level-1/l1-readloop-lds.lisp

    r11124 r11373  
    288288  (let* ((*break-level* break-level)
    289289         (*last-break-level* break-level)
    290          *loading-file-source-file*
     290         (*loading-file-source-file* nil)
     291         (*loading-toplevel-location* nil)
    291292         *in-read-loop*
    292293         *** ** * +++ ++ + /// // / -
  • trunk/source/level-1/l1-utils.lisp

    r11204 r11373  
    4242
    4343(fset 'level-1-record-source-file
    44       (qlfun level-1-record-source-file (name def-type &optional (file-name *loading-file-source-file*))
     44      (qlfun level-1-record-source-file (name def-type &optional (source (or *loading-toplevel-location*
     45                                                                             *loading-file-source-file*)))
    4546        ;; Level-0 puts stuff on plist of name.  Once we're in level-1, names can
    4647        ;; be more complicated than just a symbol, so just collect all calls until
     
    4950          (unless (listp *record-source-file*)
    5051            (setq *record-source-file* nil))
    51           (push (list name def-type file-name) *record-source-file*))))
     52          (push (list name def-type source) *record-source-file*))))
    5253
    5354(fset 'record-source-file #'level-1-record-source-file)
     
    653654        (report-bad-arg form '(satisfies constantp))))))
    654655
    655 ;;; avoid hanging onto beezillions of pathnames
    656 (defvar *last-back-translated-name* nil)
    657656(defvar *lfun-names*)
    658657
  • trunk/source/level-1/level-1.lisp

    r11135 r11373  
    9898  ;; *loading-file-source-file* set to "l1-boot-3".
    9999  (setq *loading-file-source-file* nil)
     100  (setq *loading-toplevel-location* nil)
    100101  )
    101102
Note: See TracChangeset for help on using the changeset viewer.