Changeset 11373


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
Files:
27 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/cocoa-ide/cocoa-listener.lisp

    r11307 r11373  
    8989                (t
    9090                 (destructuring-bind (string package-name pathname) val
    91                    (let ((env (cons '(*loading-file-source-file*) (list pathname))))
     91                   (let ((env (cons '(*loading-file-source-file* *loading-toplevel-location*)
     92                                    (list pathname nil))))
    9293                     (when package-name
    9394                       (push '*package* (car env))
  • trunk/source/compiler/PPC/ppc-disassemble.lisp

    r4103 r11373  
    365365      (format stream (if (and (consp op) (eq (car op) 'quote)) " ~s" " ~a") op))))
    366366
    367 (defun print-ppc-instructions (stream instructions &optional for-lap backend)
     367(defun print-ppc-instructions (stream function instructions &optional for-lap backend)
    368368  (declare (ignorable backend))
    369   (let* ((tab (if for-lap 6 2)))
     369  (let* ((tab (if for-lap 6 2))
     370         (previous-source-note nil))
     371
     372    (let ((source-note (function-source-note function)))
     373      (when source-note
     374        (format t ";; Source: ~S:~D-~D"
     375                (source-note-filename source-note)
     376                (source-note-start-pos source-note)
     377                (source-note-end-pos source-note))
     378        ;; Fetch text from file if don't already have it
     379        (ensure-source-note-text source-note)))
     380
    370381    (when for-lap
    371382      (let* ((lap-function-name (car for-lap)))
    372383        (format stream "~&(~S ~S ~&  (~S (~s) ~&    (~s ~s ()"
    373384                'nfunction lap-function-name 'lambda '&lap 'ppc-lap-function lap-function-name)))
     385
    374386    (do-dll-nodes (i instructions)
     387      (let ((source-note (find-source-note-at-pc function (instruction-element-address i))))
     388        (unless (eql (source-note-file-range source-note)
     389                     (source-note-file-range previous-source-note))
     390          (setf previous-source-note source-note)
     391          (let* ((source-text (source-note-text source-note))
     392                 (text (if source-text
     393                         (string-sans-most-whitespace source-text 100)
     394                         "#<no source text>")))
     395            (format stream "~&~%;;; ~A" text))))
    375396      (etypecase i
    376397        (lap-label (format stream "~&~a " (lap-label-name i)))
     
    384405         (prefix-length (length (arch::target-code-vector-prefix (backend-target-arch backend))))
    385406         (*ppc-disassembly-backend* backend))
    386     (print-ppc-instructions stream (function-to-dll-header fn-vector prefix-length)
     407    (print-ppc-instructions stream fn-vector
     408                            (function-to-dll-header fn-vector prefix-length)
    387409                            (if for-lap (list (uvref fn-vector (- (uvsize fn-vector) 2)))))
    388410    (values)))
  • trunk/source/compiler/PPC/ppc2.lisp

    r11318 r11373  
    1414;;;   The LLGPL is also available online at
    1515;;;   http://opensource.franz.com/preamble.html
     16
     17(in-package "CCL")
    1618
    1719(eval-when (:compile-toplevel :execute)
     
    412414           (*available-backend-fp-temps* ppc-temp-fp-regs)
    413415           (bits 0)
    414            (debug-info nil)
    415416           (*logical-register-counter* -1)
    416417           (*backend-all-lregs* ())
     
    454455        (unwind-protect
    455456             (progn
    456                (setq bits (ppc2-form vinsns (make-wired-lreg *ppc2-result-reg*) $backend-return (afunc-acode afunc)))
     457               (setq bits (ppc2-toplevel-form vinsns (make-wired-lreg *ppc2-result-reg*) $backend-return (afunc-acode afunc)))
    457458               (dotimes (i (length *backend-immediates*))
    458459                 (let ((imm (aref *backend-immediates* i)))
     
    466467           
    467468               (with-dll-node-freelist (*lap-instructions* *lap-instruction-freelist*)
    468                  (let* ((*lap-labels* nil))
     469                 (let* ((*lap-labels* nil)
     470                        debug-info)
    469471                   (ppc2-expand-vinsns vinsns)
    470472                   (if (logbitp $fbitnonnullenv (the fixnum (afunc-bits afunc)))
     
    475477                   (when *ppc2-recorded-symbols*
    476478                     (setq debug-info (list* 'function-symbol-map *ppc2-recorded-symbols* debug-info)))
    477                    (when *ppc2-emitted-source-notes*
     479                   (when (and (getf debug-info '%function-source-note) *ppc2-emitted-source-notes*)
    478480                     (setq debug-info (list* 'pc-source-map *ppc2-emitted-source-notes* debug-info)))
    479481                   (when debug-info
     
    566568
    567569(defun ppc2-generate-pc-source-map (debug-info)
    568   (let* ((definition-source-note (getf debug-info 'function-source-note))
     570  (let* ((definition-source-note (getf debug-info '%function-source-note))
    569571         (emitted-source-notes (getf debug-info 'pc-source-map))
    570572         (def-start (source-note-start-pos definition-source-note))
     
    10571059
    10581060
    1059 (defun ppc2-form (seg vreg xfer form &aux (note (acode-source-note form)))
    1060   (flet ((main (seg vreg xfer form)
    1061            (if (nx-null form)
    1062              (ppc2-nil seg vreg xfer)
    1063              (if (nx-t form)
    1064                (ppc2-t seg vreg xfer)
    1065                (let* ((op nil)
    1066                       (fn nil))
    1067                  (if (and (consp form)
    1068                           (setq fn (svref *ppc2-specials* (%ilogand #.operator-id-mask (setq op (acode-operator form))))))
    1069                    (if (and (null vreg)
    1070                             (%ilogbitp operator-acode-subforms-bit op)
    1071                             (%ilogbitp operator-assignment-free-bit op))
    1072                      (dolist (f (%cdr form) (ppc2-branch seg xfer nil))
    1073                        (ppc2-form seg nil nil f ))
    1074                      (apply fn seg vreg xfer (%cdr form)))
    1075                    (compiler-bug "ppc2-form ? ~s" form)))))))
     1061(defun ppc2-acode-operator-function (form)
     1062  (or (and (acode-p form)
     1063           (svref *ppc2-specials* (%ilogand #.operator-id-mask (acode-operator form))))
     1064      (compiler-bug "ppc2-form ? ~s" form)))
     1065
     1066(defmacro with-note ((form-var seg-var &rest other-vars) &body body)
     1067  (let* ((note (gensym "NOTE"))
     1068         (code-note (gensym "CODE-NOTE"))
     1069         (source-note (gensym "SOURCE-NOTE"))
     1070         (start (gensym "START"))
     1071         (end (gensym "END"))
     1072         (with-note-body (gensym "WITH-NOTE-BODY")))
     1073    `(flet ((,with-note-body (,form-var ,seg-var ,@other-vars) ,@body))
     1074       (let ((,note (acode-note ,form-var)))
     1075         (if ,note
     1076           (let* ((,code-note (and (code-note-p ,note) ,note))
     1077                  (,source-note (if ,code-note
     1078                                  (code-note-source-note ,note)
     1079                                  ,note))
     1080                  (,start (and ,source-note
     1081                               (ppc2-emit-note ,seg-var :source-location-begin ,source-note))))
     1082             (prog2
     1083                 (when ,code-note
     1084                   (with-ppc-local-vinsn-macros (,seg-var)
     1085                     (ppc2-store-immediate ,seg-var ,code-note ppc::temp0)
     1086                     (! misc-set-c-node ($ ppc::rzero) ($ ppc::temp0) 1)))
     1087                 (,with-note-body ,form-var ,seg-var ,@other-vars)
     1088               (when ,source-note
     1089                 (let ((,end (ppc2-emit-note ,seg-var :source-location-end)))
     1090                   (setf (vinsn-note-peer ,start) ,end
     1091                         (vinsn-note-peer ,end) ,start)
     1092                   (push ,start *ppc2-emitted-source-notes*)))))
     1093           (,with-note-body ,form-var ,seg-var ,@other-vars))))))
     1094
     1095(defun ppc2-toplevel-form (seg vreg xfer form)
     1096  (let* ((code-note (acode-note form))
     1097         (args (if code-note `(,@(%cdr form) ,code-note) (%cdr form))))
     1098    (apply (ppc2-acode-operator-function form) seg vreg xfer args)))
     1099
     1100(defun ppc2-form (seg vreg xfer form)
     1101  (with-note (form seg vreg xfer)
     1102    (if (nx-null form)
     1103      (ppc2-nil seg vreg xfer)
     1104      (if (nx-t form)
     1105        (ppc2-t seg vreg xfer)
     1106        (let ((fn (ppc2-acode-operator-function form))
     1107              (op (acode-operator form)))
     1108          (if (and (null vreg)
     1109                   (%ilogbitp operator-acode-subforms-bit op)
     1110                   (%ilogbitp operator-assignment-free-bit op))
     1111            (dolist (f (%cdr form) (ppc2-branch seg xfer nil))
     1112              (ppc2-form seg nil nil f ))
     1113            (apply fn seg vreg xfer (%cdr form)))))))
    10761114    (if note
    10771115      (let* ((start (ppc2-emit-note seg :source-location-begin note))
     
    10871125(defun ppc2-form-float (seg freg xfer form)
    10881126  (declare (ignore xfer))
    1089   (when (or (nx-null form)(nx-t form))(compiler-bug "ppc2-form to freg ~s" form))
    1090   (when (and (= (get-regspec-mode freg) hard-reg-class-fpr-mode-double)
    1091              (ppc2-form-typep form 'double-float))
    1092     ; kind of screwy - encoding the source type in the dest register spec
    1093     (set-node-regspec-type-modes freg hard-reg-class-fpr-type-double))
    1094   (let* ((fn nil))
    1095     (if (and (consp form)
    1096              (setq fn (svref *ppc2-specials* (%ilogand #.operator-id-mask (acode-operator form)))))     
    1097       (apply fn seg freg nil (%cdr form))
    1098       (compiler-bug "ppc2-form ? ~s" form))))
     1127  (with-note (form seg freg)
     1128    (when (or (nx-null form)(nx-t form))(compiler-bug "ppc2-form to freg ~s" form))
     1129    (when (and (= (get-regspec-mode freg) hard-reg-class-fpr-mode-double)
     1130               (ppc2-form-typep form 'double-float))
     1131                                        ; kind of screwy - encoding the source type in the dest register spec
     1132      (set-node-regspec-type-modes freg hard-reg-class-fpr-type-double))
     1133    (let* ((fn (ppc2-acode-operator-function form)))
     1134      (apply fn seg freg nil (%cdr form)))))
    10991135
    11001136
     
    22192255      (^))))
    22202256                   
     2257
     2258(defun ppc2-code-coverage-entry (seg note)
     2259  (let* ((afunc *ppc2-cur-afunc*))
     2260    (setf (afunc-bits afunc) (%ilogior (afunc-bits afunc) (ash 1 $fbitccoverage)))
     2261    (with-x86-local-vinsn-macros (seg)
     2262      (let* ((ccreg ($ ppc::atemp0)))
     2263        (ppc2-store-immediate seg note ccreg)
     2264        (! misc-set-c-node ($ ppc::rzero) ccreg 1)))))
    22212265
    22222266(defun ppc2-vset (seg vreg xfer type-keyword vector index value safe)
     
    36873731    (ppc2-seq-bind-var seg var (pop initforms))))
    36883732
    3689 (defun ppc2-dynamic-extent-form (seg curstack val)
    3690   (when (acode-p val)
    3691     (with-ppc-local-vinsn-macros (seg)
    3692       (let* ((op (acode-operator val)))
    3693         (cond ((eq op (%nx1-operator list))
    3694                (let* ((*ppc2-vstack* *ppc2-vstack*)
    3695                       (*ppc2-top-vstack-lcell* *ppc2-top-vstack-lcell*))
    3696                  (ppc2-set-nargs seg (ppc2-formlist seg (%cadr val) nil))
    3697                  (ppc2-open-undo $undostkblk curstack)
    3698                  (! stack-cons-list))
    3699                (setq val ppc::arg_z))
    3700               ((eq op (%nx1-operator list*))
    3701                (let* ((arglist (%cadr val)))                   
    3702                  (let* ((*ppc2-vstack* *ppc2-vstack*)
    3703                         (*ppc2-top-vstack-lcell* *ppc2-top-vstack-lcell*))
    3704                    (ppc2-arglist seg arglist))
    3705                  (when (car arglist)
    3706                    (ppc2-set-nargs seg (length (%car arglist)))
    3707                    (! stack-cons-list*)
    3708                    (ppc2-open-undo $undostkblk curstack))
    3709                  (setq val ppc::arg_z)))
    3710               ((eq op (%nx1-operator multiple-value-list))
    3711                (ppc2-multiple-value-body seg (%cadr val))
    3712                (ppc2-open-undo $undostkblk curstack)
    3713                (! stack-cons-list)
    3714                (setq val ppc::arg_z))
    3715               ((eq op (%nx1-operator cons))
    3716                (let* ((y ($ ppc::arg_y))
    3717                       (z ($ ppc::arg_z))
    3718                       (result ($ ppc::arg_z)))
    3719                  (ppc2-two-targeted-reg-forms seg (%cadr val) y (%caddr val) z)
    3720                  (ppc2-open-undo $undostkblk )
    3721                  (! make-tsp-cons result y z)
    3722                  (setq val result)))
    3723               ((eq op (%nx1-operator %consmacptr%))
    3724                (with-imm-target () (address :address)
    3725                  (ppc2-one-targeted-reg-form seg val address)
    3726                  (with-node-temps () (node)
    3727                    (! macptr->stack node address)
    3728                    (ppc2-open-undo $undostkblk)
    3729                    (setq val node))))
    3730               ((eq op (%nx1-operator %new-ptr))
    3731                (let* ((clear-form (caddr val))
    3732                       (cval (nx-constant-form-p clear-form)))
    3733                  (if cval
    3734                    (progn
    3735                      (ppc2-one-targeted-reg-form seg (%cadr val) ($ ppc::arg_z))
    3736                      (if (nx-null cval)
    3737                        (! make-stack-block)
    3738                        (! make-stack-block0)))
    3739                    (with-crf-target () crf
    3740                      (let ((stack-block-0-label (backend-get-next-label))
    3741                            (done-label (backend-get-next-label))
    3742                            (rval ($ ppc::arg_z))
    3743                            (rclear ($ ppc::arg_y)))
    3744                        (ppc2-two-targeted-reg-forms seg (%cadr val) rval clear-form rclear)
    3745                        (! compare-to-nil crf rclear)
    3746                        (! cbranch-false (aref *backend-labels* stack-block-0-label) crf ppc::ppc-eq-bit)
    3747                        (! make-stack-block)
    3748                        (-> done-label)
    3749                        (@ stack-block-0-label)
    3750                        (! make-stack-block0)
    3751                        (@ done-label)))))
    3752                (ppc2-open-undo $undostkblk)
    3753                (setq val ($ ppc::arg_z)))
    3754               ((eq op (%nx1-operator make-list))
    3755                (ppc2-two-targeted-reg-forms seg (%cadr val) ($ ppc::arg_y) (%caddr val) ($ ppc::arg_z))
    3756                (ppc2-open-undo $undostkblk curstack)
    3757                (! make-stack-list)
    3758                (setq val ppc::arg_z))       
    3759               ((eq op (%nx1-operator vector))
    3760                (let* ((*ppc2-vstack* *ppc2-vstack*)
    3761                       (*ppc2-top-vstack-lcell* *ppc2-top-vstack-lcell*))
    3762                  (ppc2-set-nargs seg (ppc2-formlist seg (%cadr val) nil))
    3763                  (! make-stack-vector))
    3764                (ppc2-open-undo $undostkblk)
    3765                (setq val ppc::arg_z))
    3766               ((eq op (%nx1-operator %gvector))
    3767                (let* ((*ppc2-vstack* *ppc2-vstack*)
    3768                       (*ppc2-top-vstack-lcell* *ppc2-top-vstack-lcell*)
    3769                       (arglist (%cadr val)))
    3770                  (ppc2-set-nargs seg (ppc2-formlist seg (append (car arglist) (reverse (cadr arglist))) nil))
    3771                  (! make-stack-gvector))
    3772                (ppc2-open-undo $undostkblk)
    3773                (setq val ppc::arg_z))
    3774               ((eq op (%nx1-operator closed-function))
    3775                (setq val (ppc2-make-closure seg (cadr val) t))) ; can't error
    3776               ((eq op (%nx1-operator %make-uvector))
    3777                (destructuring-bind (element-count subtag &optional (init 0 init-p)) (%cdr val)
    3778                  (if init-p
    3779                    (progn
    3780                      (ppc2-three-targeted-reg-forms seg element-count ($ ppc::arg_x) subtag ($ ppc::arg_y) init ($ ppc::arg_z))
    3781                      (! stack-misc-alloc-init))
    3782                    (progn
    3783                      (ppc2-two-targeted-reg-forms seg element-count ($ ppc::arg_y)  subtag ($ ppc::arg_z))
    3784                      (! stack-misc-alloc)))
    3785                  (ppc2-open-undo $undostkblk)
    3786                  (setq val ($ ppc::arg_z))))))))
     3733(defun ppc2-dynamic-extent-form (seg curstack val &aux (form val))
     3734  (when (acode-p form)
     3735    (with-note (form seg curstack) ; note this rebinds form/seg/curstack so can't setq
     3736      (with-ppc-local-vinsn-macros (seg)
     3737        (let* ((op (acode-operator form)))
     3738          (cond ((eq op (%nx1-operator list))
     3739                 (let* ((*ppc2-vstack* *ppc2-vstack*)
     3740                        (*ppc2-top-vstack-lcell* *ppc2-top-vstack-lcell*))
     3741                   (ppc2-set-nargs seg (ppc2-formlist seg (%cadr form) nil))
     3742                   (ppc2-open-undo $undostkblk curstack)
     3743                   (! stack-cons-list))
     3744                 (setq val ppc::arg_z))
     3745                ((eq op (%nx1-operator list*))
     3746                 (let* ((arglist (%cadr form)))                   
     3747                   (let* ((*ppc2-vstack* *ppc2-vstack*)
     3748                          (*ppc2-top-vstack-lcell* *ppc2-top-vstack-lcell*))
     3749                     (ppc2-arglist seg arglist))
     3750                   (when (car arglist)
     3751                     (ppc2-set-nargs seg (length (%car arglist)))
     3752                     (! stack-cons-list*)
     3753                     (ppc2-open-undo $undostkblk curstack))
     3754                   (setq val ppc::arg_z)))
     3755                ((eq op (%nx1-operator multiple-value-list))
     3756                 (ppc2-multiple-value-body seg (%cadr form))
     3757                 (ppc2-open-undo $undostkblk curstack)
     3758                 (! stack-cons-list)
     3759                 (setq val ppc::arg_z))
     3760                ((eq op (%nx1-operator cons))
     3761                 (let* ((y ($ ppc::arg_y))
     3762                        (z ($ ppc::arg_z))
     3763                        (result ($ ppc::arg_z)))
     3764                   (ppc2-two-targeted-reg-forms seg (%cadr form) y (%caddr form) z)
     3765                   (ppc2-open-undo $undostkblk )
     3766                   (! make-tsp-cons result y z)
     3767                   (setq val result)))
     3768                ((eq op (%nx1-operator %consmacptr%))
     3769                 (with-imm-target () (address :address)
     3770                   (ppc2-one-targeted-reg-form seg form address)
     3771                   (with-node-temps () (node)
     3772                     (! macptr->stack node address)
     3773                     (ppc2-open-undo $undostkblk)
     3774                     (setq val node))))
     3775                ((eq op (%nx1-operator %new-ptr))
     3776                 (let* ((clear-form (caddr form))
     3777                        (cval (nx-constant-form-p clear-form)))
     3778                   (if cval
     3779                       (progn
     3780                         (ppc2-one-targeted-reg-form seg (%cadr form) ($ ppc::arg_z))
     3781                         (if (nx-null cval)
     3782                             (! make-stack-block)
     3783                             (! make-stack-block0)))
     3784                       (with-crf-target () crf
     3785                         (let ((stack-block-0-label (backend-get-next-label))
     3786                               (done-label (backend-get-next-label))
     3787                               (rval ($ ppc::arg_z))
     3788                               (rclear ($ ppc::arg_y)))
     3789                           (ppc2-two-targeted-reg-forms seg (%cadr form) rval clear-form rclear)
     3790                           (! compare-to-nil crf rclear)
     3791                           (! cbranch-false (aref *backend-labels* stack-block-0-label) crf ppc::ppc-eq-bit)
     3792                           (! make-stack-block)
     3793                           (-> done-label)
     3794                           (@ stack-block-0-label)
     3795                           (! make-stack-block0)
     3796                           (@ done-label)))))
     3797                 (ppc2-open-undo $undostkblk)
     3798                 (setq val ($ ppc::arg_z)))
     3799                ((eq op (%nx1-operator make-list))
     3800                 (ppc2-two-targeted-reg-forms seg (%cadr form) ($ ppc::arg_y) (%caddr form) ($ ppc::arg_z))
     3801                 (ppc2-open-undo $undostkblk curstack)
     3802                 (! make-stack-list)
     3803                 (setq val ppc::arg_z))       
     3804                ((eq op (%nx1-operator vector))
     3805                 (let* ((*ppc2-vstack* *ppc2-vstack*)
     3806                        (*ppc2-top-vstack-lcell* *ppc2-top-vstack-lcell*))
     3807                   (ppc2-set-nargs seg (ppc2-formlist seg (%cadr form) nil))
     3808                   (! make-stack-vector))
     3809                 (ppc2-open-undo $undostkblk)
     3810                 (setq val ppc::arg_z))
     3811                ((eq op (%nx1-operator %gvector))
     3812                 (let* ((*ppc2-vstack* *ppc2-vstack*)
     3813                        (*ppc2-top-vstack-lcell* *ppc2-top-vstack-lcell*)
     3814                        (arglist (%cadr form)))
     3815                   (ppc2-set-nargs seg (ppc2-formlist seg (append (car arglist) (reverse (cadr arglist))) nil))
     3816                   (! make-stack-gvector))
     3817                 (ppc2-open-undo $undostkblk)
     3818                 (setq val ppc::arg_z))
     3819                ((eq op (%nx1-operator closed-function))
     3820                 (setq val (ppc2-make-closure seg (cadr form) t))) ; can't error
     3821                ((eq op (%nx1-operator %make-uvector))
     3822                 (destructuring-bind (element-count subtag &optional (init 0 init-p)) (%cdr form)
     3823                   (if init-p
     3824                       (progn
     3825                         (ppc2-three-targeted-reg-forms seg element-count ($ ppc::arg_x) subtag ($ ppc::arg_y) init ($ ppc::arg_z))
     3826                         (! stack-misc-alloc-init))
     3827                       (progn
     3828                         (ppc2-two-targeted-reg-forms seg element-count ($ ppc::arg_y)  subtag ($ ppc::arg_z))
     3829                         (! stack-misc-alloc)))
     3830                   (ppc2-open-undo $undostkblk)
     3831                   (setq val ($ ppc::arg_z)))))))))
    37873832  val)
    37883833
     
    52975342)
    52985343 
    5299 (defppc2 ppc2-lambda lambda-list (seg vreg xfer req opt rest keys auxen body p2decls)
     5344(defppc2 ppc2-lambda lambda-list (seg vreg xfer req opt rest keys auxen body p2decls &optional code-note)
    53005345  (with-ppc-local-vinsn-macros (seg vreg xfer)
    53015346    (let* ((stack-consed-rest nil)
     
    53325377          (ppc2-allocate-global-registers *ppc2-fcells* *ppc2-vcells* (afunc-all-vars afunc) no-regs))
    53335378        (@ (backend-get-next-label)) ; generic self-reference label, should be label #1
     5379        (when keys ;; Ensure keyvect is the first immediate
     5380          (backend-immediate-index (%cadr (%cdddr keys))))
     5381        (when code-note
     5382          (ppc2-code-coverage-entry seg code-note))
    53345383        (unless next-method-p
    53355384          (setq method-var nil))
  • trunk/source/compiler/X86/x86-disassemble.lisp

    r11266 r11373  
    27232723      usual)))
    27242724
    2725 
    2726 (defun x86-print-disassembled-instruction (ds instruction seq)
     2725(defvar *previous-source-note*)
     2726
     2727(defun x86-print-disassembled-instruction (ds instruction seq function)
    27272728  (let* ((addr (x86-di-address instruction))
    2728          (entry (x86-ds-entry-point ds)))
     2729         (entry (x86-ds-entry-point ds))
     2730         (pc (- addr entry)))
     2731    (let ((source-note (find-source-note-at-pc function pc)))
     2732      (unless (eql (source-note-file-range source-note)
     2733                   (source-note-file-range *previous-source-note*))
     2734        (setf *previous-source-note* source-note)
     2735        (let* ((source-text (source-note-text source-note))
     2736               (text (if source-text
     2737                       (string-sans-most-whitespace source-text 100)
     2738                       "#<no source text>")))
     2739          (format t "~&~%;;; ~A" text))))
    27292740    (when (x86-di-labeled instruction)
    2730       (format t "~&L~d~&" (- addr entry))
     2741      (format t "~&L~d~%" pc)
    27312742      (setq seq 0))
     2743    (format t "~&  [~D]~8T" pc)
    27322744    (dolist (p (x86-di-prefixes instruction))
    27332745      (format t "~&  (~a)~%" p))
    2734     (format t "~&  (~a" (x86-di-mnemonic instruction))
     2746    (format t "  (~a" (x86-di-mnemonic instruction))
    27352747    (let* ((op0 (x86-di-op0 instruction))
    27362748           (op1 (x86-di-op1 instruction))
     
    27432755            (format t " ~a" (unparse-x86-lap-operand op2 ds))))))
    27442756    (format t ")")
    2745     (unless (zerop seq) ;(when (oddp seq)
    2746       (format t "~50t;[~d]" (- addr entry)))
    27472757    (format t "~%")
    27482758    (1+ seq)))
    27492759
    2750 
    2751 (defun x8664-disassemble-xfunction (xfunction &key (symbolic-names
    2752                                                          x8664::*x8664-symbolic-register-names*) (collect-function #'x86-print-disassembled-instruction))
     2760(defun x86-print-disassembled-function-header (function xfunction)
     2761  (declare (ignore xfunction))
     2762  (let ((source-note (function-source-note function)))
     2763    (when source-note
     2764      (format t ";; Source: ~S:~D-~D"
     2765              (source-note-filename source-note)
     2766              (source-note-start-pos source-note)
     2767              (source-note-end-pos source-note))
     2768      ;; Fetch source from file if don't already have it.
     2769      (ensure-source-note-text source-note))))
     2770
     2771(defun x8664-disassemble-xfunction (function xfunction
     2772                                    &key (symbolic-names x8664::*x8664-symbolic-register-names*)
     2773                                         (collect-function #'x86-print-disassembled-instruction)
     2774                                         (header-function #'x86-print-disassembled-function-header))
    27532775  (check-type xfunction xfunction)
    27542776  (check-type (uvref xfunction 0) (simple-array (unsigned-byte 8) (*)))
     
    27682790        (or (x86-dis-find-label lab blocks)
    27692791            (x86-disassemble-new-block ds lab))))
    2770     (let* ((seq 0))
     2792    (when (and blocks (let ((something-to-disassemble nil))
     2793                        (do-dll-nodes (block blocks)
     2794                          (do-dll-nodes (instruction (x86-dis-block-instructions block))
     2795                            (setf something-to-disassemble t)))
     2796                        something-to-disassemble))
     2797      (funcall header-function function xfunction))
     2798    (let* ((seq 0)
     2799           (*previous-source-note* nil))
     2800      (declare (special *previous-source-note*))
    27712801      (do-dll-nodes (block blocks)
    27722802        (do-dll-nodes (instruction (x86-dis-block-instructions block))
    2773           (setq seq (funcall collect-function ds instruction seq)))))))
    2774 
    2775 (defun x8632-disassemble-xfunction (xfunction &key (symbolic-names
    2776                                                          x8632::*x8632-symbolic-register-names*) (collect-function #'x86-print-disassembled-instruction))
     2803          (setq seq (funcall collect-function ds instruction seq function)))))))
     2804
     2805(defun x8632-disassemble-xfunction (function xfunction
     2806                                    &key (symbolic-names x8632::*x8632-symbolic-register-names*)
     2807                                         (collect-function #'x86-print-disassembled-instruction)
     2808                                         (header-function #'x86-print-disassembled-function-header))
    27772809  (check-type xfunction xfunction)
    27782810  (check-type (uvref xfunction 0) (simple-array (unsigned-byte 8) (*)))
     
    27922824        (or (x86-dis-find-label lab blocks)
    27932825            (x86-disassemble-new-block ds lab))))
    2794     (let* ((seq 0))
     2826    (when (and blocks (let ((something-to-disassemble nil))
     2827                        (do-dll-nodes (block blocks)
     2828                          (do-dll-nodes (instruction (x86-dis-block-instructions block))
     2829                            (setf something-to-disassemble t)))
     2830                        something-to-disassemble))
     2831      (funcall header-function function xfunction))
     2832    (let* ((seq 0)
     2833           (*previous-source-note* nil))
     2834      (declare (special *previous-source-note*))
    27952835      (do-dll-nodes (block blocks)
    27962836        (do-dll-nodes (instruction (x86-dis-block-instructions block))
    2797           (setq seq (funcall collect-function ds instruction seq)))))))
     2837          (setq seq (funcall collect-function ds instruction seq function)))))))
    27982838
    27992839#+x8664-target
    28002840(defun x8664-xdisassemble (function
    2801                            &optional (collect-function #'x86-print-disassembled-instruction))
     2841                           &optional (collect-function #'x86-print-disassembled-instruction)
     2842                                     (header-function #'x86-print-disassembled-function-header))
    28022843  (let* ((fv (%function-to-function-vector function))
    28032844         (function-size-in-words (uvsize fv))
     
    28142855          (j 1 (1+ j)))
    28152856         ((= k function-size-in-words)
    2816           (x8664-disassemble-xfunction xfunction
    2817                                        :collect-function collect-function))
     2857          (x8664-disassemble-xfunction function xfunction
     2858                                       :collect-function collect-function
     2859                                       :header-function header-function))
    28182860      (declare (fixnum j k))
    28192861      (setf (uvref xfunction j) (uvref fv k)))))
    28202862
    28212863#+x8632-target
    2822 (defun x8632-xdisassemble (function &optional (collect-function #'x86-print-disassembled-instruction ))
     2864(defun x8632-xdisassemble (function
     2865                           &optional (collect-function #'x86-print-disassembled-instruction)
     2866                                     (header-function #'x86-print-disassembled-function-header))
    28232867  (let* ((fv (function-to-function-vector function))
    28242868         (function-size-in-words (uvsize fv))
     
    28352879          (j 1 (1+ j)))
    28362880         ((= k function-size-in-words)
    2837           (x8632-disassemble-xfunction xfunction :collect-function collect-function))
     2881          (x8632-disassemble-xfunction function xfunction
     2882                                       :collect-function collect-function
     2883                                       :header-function header-function))
    28382884      (declare (fixnum j k))
    28392885      (setf (uvref xfunction j) (uvref fv k)))))
     
    28432889    (#+x8632-target x8632-xdisassemble #+x8664-target x8664-xdisassemble
    28442890     function
    2845      #'(lambda (ds instruction seq)
     2891     #'(lambda (ds instruction seq function)
     2892         (declare (ignore function))
    28462893         (collect ((insn))
    28472894           (let* ((addr (x86-di-address instruction))
  • trunk/source/compiler/X86/x862.lisp

    r11359 r11373  
    608608        (unwind-protect
    609609             (progn
    610                (setq bits (x862-form vinsns (make-wired-lreg *x862-result-reg*) $backend-return (afunc-acode afunc)))
     610               (setq bits (x862-toplevel-form vinsns (make-wired-lreg *x862-result-reg*)
     611                                              $backend-return (afunc-acode afunc)))
    611612               (do* ((constants *x862-constant-alist* (cdr constants)))
    612613                    ((null constants))
     
    692693                     (setq bits (+ bits (ash 1 $lfbits-nonnullenv-bit))))
    693694                   (setq debug-info (afunc-lfun-info afunc))
     695                   (when (logbitp $fbitccoverage (the fixnum (afunc-bits afunc)))
     696                     (setq bits (+ bits (ash 1 $lfbits-code-coverage-bit))))
    694697                   (when lambda-form
    695698                     (setq debug-info
    696699                           (list* 'function-lambda-expression lambda-form debug-info)))
    697                    (when *x862-record-symbols*
     700                   (when *x862-recorded-symbols*
    698701                     (setq debug-info
    699702                           (list* 'function-symbol-map *x862-recorded-symbols* debug-info)))
    700                    (when (and (getf debug-info 'function-source-note) *x862-emitted-source-notes*)
     703                   (when (and (getf debug-info '%function-source-note) *x862-emitted-source-notes*)
    701704                     (setq debug-info                     ;; Compressed below
    702705                           (list* 'pc-source-map *x862-emitted-source-notes* debug-info)))
     
    797800
    798801(defun x862-generate-pc-source-map (debug-info)
    799   (let* ((definition-source-note (getf debug-info 'function-source-note))
     802  (let* ((definition-source-note (getf debug-info '%function-source-note))
    800803         (emitted-source-notes (getf debug-info 'pc-source-map))
    801804         (def-start (source-note-start-pos definition-source-note))
     
    13181321    n))
    13191322
    1320 (defun x862-form (seg vreg xfer form &aux (note (acode-source-note form)))
    1321   (flet ((main (seg vreg xfer form)
    1322            (if (nx-null form)
    1323              (x862-nil seg vreg xfer)
    1324              (if (nx-t form)
    1325                (x862-t seg vreg xfer)
    1326                (let* ((op nil)
    1327                       (fn nil))
    1328                  (if (and (consp form)
    1329                           (setq fn (svref *x862-specials* (%ilogand #.operator-id-mask (setq op (acode-operator form))))))
    1330                    (if (and (null vreg)
    1331                             (%ilogbitp operator-acode-subforms-bit op)
    1332                             (%ilogbitp operator-assignment-free-bit op))
    1333                      (dolist (f (%cdr form) (x862-branch seg xfer))
    1334                        (x862-form seg nil nil f ))
    1335                      (apply fn seg vreg xfer (%cdr form)))
    1336                    (compiler-bug "x862-form ? ~s" form)))))))
    1337     (if note
    1338       (let* ((start (x862-emit-note seg :source-location-begin note))
    1339              (bits (main seg vreg xfer form))
    1340              (end (x862-emit-note seg :source-location-end)))
    1341         (setf (vinsn-note-peer start) end
    1342               (vinsn-note-peer end) start)
    1343         (push start *x862-emitted-source-notes*)
    1344         bits)
    1345       (main seg vreg xfer form))))
     1323
     1324(defun x862-acode-operator-function (form)
     1325  (or (and (acode-p form)
     1326           (svref *x862-specials* (%ilogand #.operator-id-mask (acode-operator form))))
     1327      (compiler-bug "x862-form ? ~s" form)))
     1328
     1329(defmacro with-note ((form-var seg-var &rest other-vars) &body body)
     1330  (let* ((note (gensym "NOTE"))
     1331         (code-note (gensym "CODE-NOTE"))
     1332         (source-note (gensym "SOURCE-NOTE"))
     1333         (start (gensym "START"))
     1334         (end (gensym "END"))
     1335         (with-note-body (gensym "WITH-NOTE-BODY")))
     1336    `(flet ((,with-note-body (,form-var ,seg-var ,@other-vars)
     1337              ,@body))
     1338       (let ((,note (acode-note ,form-var)))
     1339         (if ,note
     1340           (let* ((,code-note (and (code-note-p ,note) ,note))
     1341                  (,source-note (if ,code-note
     1342                                  (code-note-source-note ,note)
     1343                                  ,note))
     1344                  (,start (and ,source-note
     1345                               (x862-emit-note ,seg-var :source-location-begin ,source-note))))
     1346             (prog2
     1347                 (when ,code-note
     1348                   (with-x86-local-vinsn-macros (,seg-var)
     1349                     (x862-store-immediate ,seg-var ,code-note *x862-temp0*)
     1350                     (! misc-set-immediate-c-node 0 *x862-temp0* 1)))
     1351                 (,with-note-body ,form-var ,seg-var ,@other-vars)
     1352               (when ,source-note
     1353                 (let ((,end (x862-emit-note ,seg-var :source-location-end)))
     1354                   (setf (vinsn-note-peer ,start) ,end
     1355                         (vinsn-note-peer ,end) ,start)
     1356                   (push ,start *x862-emitted-source-notes*)))))
     1357           (,with-note-body ,form-var ,seg-var ,@other-vars))))))
     1358
     1359(defun x862-toplevel-form (seg vreg xfer form)
     1360  (let* ((code-note (acode-note form))
     1361         (args (if code-note `(,@(%cdr form) ,code-note) (%cdr form))))
     1362    (apply (x862-acode-operator-function form) seg vreg xfer args)))
     1363
     1364(defun x862-form (seg vreg xfer form)
     1365  (with-note (form seg vreg xfer)
     1366    (if (nx-null form)
     1367      (x862-nil seg vreg xfer)
     1368      (if (nx-t form)
     1369        (x862-t seg vreg xfer)
     1370        (let* ((fn (x862-acode-operator-function form)) ;; also typechecks
     1371               (op (acode-operator form)))
     1372          (if (and (null vreg)
     1373                   (%ilogbitp operator-acode-subforms-bit op)
     1374                   (%ilogbitp operator-assignment-free-bit op))
     1375            (dolist (f (%cdr form) (x862-branch seg xfer))
     1376              (x862-form seg nil nil f ))
     1377            (apply fn seg vreg xfer (%cdr form))))))))
    13461378
    13471379;;; dest is a float reg - form is acode
    13481380(defun x862-form-float (seg freg xfer form)
    13491381  (declare (ignore xfer))
    1350   (when (or (nx-null form)(nx-t form))(compiler-bug "x862-form to freg ~s" form))
    1351   (when (and (= (get-regspec-mode freg) hard-reg-class-fpr-mode-double)
    1352              (x862-form-typep form 'double-float))
    1353     ;; kind of screwy - encoding the source type in the dest register spec
    1354     (set-node-regspec-type-modes freg hard-reg-class-fpr-type-double))
    1355   (let* ((fn nil))
    1356     (if (and (consp form)
    1357              (setq fn (svref *x862-specials* (%ilogand #.operator-id-mask (acode-operator form)))))     
    1358       (apply fn seg freg nil (%cdr form))
    1359       (compiler-bug "x862-form ? ~s" form))))
    1360 
     1382  (with-note (form seg freg)
     1383    (when (or (nx-null form)(nx-t form))(compiler-bug "x862-form to freg ~s" form))
     1384    (when (and (= (get-regspec-mode freg) hard-reg-class-fpr-mode-double)
     1385               (x862-form-typep form 'double-float))
     1386      ;; kind of screwy - encoding the source type in the dest register spec
     1387      (set-node-regspec-type-modes freg hard-reg-class-fpr-type-double))
     1388    (let* ((fn (x862-acode-operator-function form)))
     1389      (apply fn seg freg nil (%cdr form)))))
    13611390
    13621391
     
    25822611      (^))))
    25832612
     2613
     2614(defun x862-code-coverage-entry (seg note)
     2615 (let* ((afunc *x862-cur-afunc*))
     2616   (setf (afunc-bits afunc) (%ilogior (afunc-bits afunc) (ash 1 $fbitccoverage)))
     2617   (with-x86-local-vinsn-macros (seg)
     2618     (let* ((ccreg ($ x8664::arg_x)))
     2619       (! vpush-register ccreg)
     2620       (! ref-constant ccreg (x86-immediate-label note))
     2621       (! misc-set-immediate-c-node 0 ccreg 1)
     2622       (! vpop-register ccreg)))))
    25842623
    25852624(defun x862-vset (seg vreg xfer type-keyword vector index value safe)
     
    43094348            (= masked x8664::fulltag-nodeheader-1)))))))
    43104349
    4311 (defun x862-dynamic-extent-form (seg curstack val)
    4312   (when (acode-p val)
    4313     (with-x86-local-vinsn-macros (seg)
    4314       (let* ((op (acode-operator val)))
    4315         (cond ((eq op (%nx1-operator list))
    4316                (let* ((*x862-vstack* *x862-vstack*)
    4317                       (*x862-top-vstack-lcell* *x862-top-vstack-lcell*))
    4318                  (x862-set-nargs seg (x862-formlist seg (%cadr val) nil))
    4319                  (x862-open-undo $undostkblk curstack)
    4320                  (! stack-cons-list))
    4321                (setq val *x862-arg-z*))
    4322               ((eq op (%nx1-operator list*))
    4323                (let* ((arglist (%cadr val)))                   
     4350(defun x862-dynamic-extent-form (seg curstack val &aux (form val))
     4351  (when (acode-p form)
     4352    (with-note (form seg curstack) ;; note this binds form/seg/curstack so can't be setq'd.
     4353      (with-x86-local-vinsn-macros (seg)
     4354        (let* ((op (acode-operator form)))
     4355          (cond ((eq op (%nx1-operator list))
    43244356                 (let* ((*x862-vstack* *x862-vstack*)
    43254357                        (*x862-top-vstack-lcell* *x862-top-vstack-lcell*))
    4326                    (x862-formlist seg (car arglist) (cadr arglist)))
    4327                  (when (car arglist)
    4328                    (x862-set-nargs seg (length (%car arglist)))
    4329                    (! stack-cons-list*)
    4330                    (x862-open-undo $undostkblk curstack))
    4331                  (setq val *x862-arg-z*)))
    4332               ((eq op (%nx1-operator multiple-value-list))
    4333                (x862-multiple-value-body seg (%cadr val))
    4334                (x862-open-undo $undostkblk curstack)
    4335                (! stack-cons-list)
    4336                (setq val *x862-arg-z*))
    4337               ((eq op (%nx1-operator cons))
    4338                (let* ((y ($ *x862-arg-y*))
    4339                       (z ($ *x862-arg-z*))
    4340                       (result ($ *x862-arg-z*)))
    4341                  (x862-two-targeted-reg-forms seg (%cadr val) y (%caddr val) z)
    4342                  (x862-open-undo $undostkblk )
    4343                  (! make-tsp-cons result y z)
    4344                  (setq val result)))
    4345               ((eq op (%nx1-operator %consmacptr%))
    4346                (with-imm-target () (address :address)
    4347                  (x862-one-targeted-reg-form seg val address)
    4348                  (with-node-target () node
    4349                    (! macptr->stack node address)
    4350                    (x862-open-undo $undo-x86-c-frame)
    4351                    (setq val node))))
    4352               ((eq op (%nx1-operator %new-ptr))
    4353                (let* ((clear-form (caddr val))
    4354                       (cval (nx-constant-form-p clear-form)))
    4355                  (if cval
    4356                    (progn
    4357                      (x862-one-targeted-reg-form seg (%cadr val) ($ *x862-arg-z*))
    4358                      (if (nx-null cval)
    4359                        (! make-stack-block)
    4360                        (! make-stack-block0)))
    4361                    (with-crf-target () crf
    4362                      (let ((stack-block-0-label (backend-get-next-label))
    4363                            (done-label (backend-get-next-label))
    4364                            (rval ($ *x862-arg-z*))
    4365                            (rclear ($ *x862-arg-y*)))
    4366                        (x862-two-targeted-reg-forms seg (%cadr val) rval clear-form rclear)
    4367                        (! compare-to-nil crf rclear)
    4368                        (! cbranch-false (aref *backend-labels* stack-block-0-label) crf x86::x86-e-bits)
    4369                        (! make-stack-block)
    4370                        (-> done-label)
    4371                        (@ stack-block-0-label)
    4372                        (! make-stack-block0)
    4373                        (@ done-label)))))
    4374                (x862-open-undo $undo-x86-c-frame)
    4375                (setq val ($ *x862-arg-z*)))
    4376               ((eq op (%nx1-operator make-list))
    4377                (x862-two-targeted-reg-forms seg (%cadr val) ($ *x862-arg-y*) (%caddr val) ($ *x862-arg-z*))
    4378                (x862-open-undo $undostkblk curstack)
    4379                (! make-stack-list)
    4380                (setq val *x862-arg-z*))       
    4381               ((eq op (%nx1-operator vector))
    4382                (let* ((*x862-vstack* *x862-vstack*)
    4383                       (*x862-top-vstack-lcell* *x862-top-vstack-lcell*))
    4384                  (x862-set-nargs seg (x862-formlist seg (%cadr val) nil))
    4385                  (! make-stack-vector))
    4386                (x862-open-undo $undostkblk)
    4387                (setq val *x862-arg-z*))
    4388               ((eq op (%nx1-operator %gvector))
    4389                (let* ((*x862-vstack* *x862-vstack*)
    4390                       (*x862-top-vstack-lcell* *x862-top-vstack-lcell*)
    4391                       (arglist (%cadr val)))
    4392                  (x862-set-nargs seg (x862-formlist seg (append (car arglist) (reverse (cadr arglist))) nil))
    4393                  (! make-stack-gvector))
    4394                (x862-open-undo $undostkblk)
    4395                (setq val *x862-arg-z*))
    4396               ((eq op (%nx1-operator closed-function))
    4397                (setq val (x862-make-closure seg (cadr val) t))) ; can't error
    4398               ((eq op (%nx1-operator %make-uvector))
    4399                (destructuring-bind (element-count subtag &optional (init 0 init-p)) (%cdr val)
    4400                  (let* ((fix-subtag (acode-fixnum-form-p subtag))
    4401                         (is-node (x862-target-is-node-subtag fix-subtag))
    4402                         (is-imm  (x862-target-is-imm-subtag fix-subtag)))
    4403                    (when (or is-node is-imm)
    4404                      (if init-p
    4405                        (progn
    4406                          (x862-three-targeted-reg-forms seg element-count
    4407                                                         (target-arch-case
    4408                                                          (:x8632
    4409                                                           ($ x8632::temp1))
    4410                                                          (:x8664
    4411                                                           ($ x8664::arg_x)))
    4412                                                         subtag ($ *x862-arg-y*)
    4413                                                         init ($ *x862-arg-z*))
    4414                          (! stack-misc-alloc-init))
    4415                        (progn
    4416                          (x862-two-targeted-reg-forms seg element-count ($ *x862-arg-y*)  subtag ($ *x862-arg-z*))
    4417                          (! stack-misc-alloc)))
    4418                      (if is-node
    4419                        (x862-open-undo $undostkblk)
    4420                        (x862-open-undo $undo-x86-c-frame))
    4421                      (setq val ($ *x862-arg-z*))))))))))
    4422   val)
     4358                   (x862-set-nargs seg (x862-formlist seg (%cadr form) nil))
     4359                   (x862-open-undo $undostkblk curstack)
     4360                   (! stack-cons-list))
     4361                 (setq val *x862-arg-z*))
     4362                ((eq op (%nx1-operator list*))
     4363                 (let* ((arglist (%cadr form)))
     4364                   (let* ((*x862-vstack* *x862-vstack*)
     4365                          (*x862-top-vstack-lcell* *x862-top-vstack-lcell*))
     4366                     (x862-formlist seg (car arglist) (cadr arglist)))
     4367                   (when (car arglist)
     4368                     (x862-set-nargs seg (length (%car arglist)))
     4369                     (! stack-cons-list*)
     4370                     (x862-open-undo $undostkblk curstack))
     4371                   (setq val *x862-arg-z*)))
     4372                ((eq op (%nx1-operator multiple-value-list))
     4373                 (x862-multiple-value-body seg (%cadr form))
     4374                 (x862-open-undo $undostkblk curstack)
     4375                 (! stack-cons-list)
     4376                 (setq val *x862-arg-z*))
     4377                ((eq op (%nx1-operator cons))
     4378                 (let* ((y ($ *x862-arg-y*))
     4379                        (z ($ *x862-arg-z*))
     4380                        (result ($ *x862-arg-z*)))
     4381                   (x862-two-targeted-reg-forms seg (%cadr val) y (%caddr val) z)
     4382                   (x862-open-undo $undostkblk )
     4383                   (! make-tsp-cons result y z)
     4384                   (setq val result)))
     4385                 ((eq op (%nx1-operator %consmacptr%))
     4386                  (with-imm-target () (address :address)
     4387                    (x862-one-targeted-reg-form seg form address)
     4388                    (with-node-target () node
     4389                      (! macptr->stack node address)
     4390                      (x862-open-undo $undo-x86-c-frame)
     4391                      (setq val node))))
     4392                 ((eq op (%nx1-operator %new-ptr))
     4393                  (let* ((clear-form (caddr form))
     4394                         (cval (nx-constant-form-p clear-form)))
     4395                    (if cval
     4396                      (progn
     4397                        (x862-one-targeted-reg-form seg (%cadr form) ($ *x862-arg-z*))
     4398                        (if (nx-null cval)
     4399                          (! make-stack-block)
     4400                          (! make-stack-block0)))
     4401                      (with-crf-target () crf
     4402                        (let ((stack-block-0-label (backend-get-next-label))
     4403                              (done-label (backend-get-next-label))
     4404                              (rval ($ *x862-arg-z*))
     4405                              (rclear ($ *x862-arg-y*)))
     4406                          (x862-two-targeted-reg-forms seg (%cadr form) rval clear-form rclear)
     4407                          (! compare-to-nil crf rclear)
     4408                          (! cbranch-false (aref *backend-labels* stack-block-0-label) crf x86::x86-e-bits)
     4409                          (! make-stack-block)
     4410                          (-> done-label)
     4411                          (@ stack-block-0-label)
     4412                          (! make-stack-block0)
     4413                          (@ done-label)))))
     4414                  (x862-open-undo $undo-x86-c-frame)
     4415                  (setq val ($ *x862-arg-z*)))
     4416                 ((eq op (%nx1-operator make-list))
     4417                  (x862-two-targeted-reg-forms seg (%cadr form) ($ *x862-arg-y*) (%caddr form) ($ *x862-arg-z*))
     4418                  (x862-open-undo $undostkblk curstack)
     4419                  (! make-stack-list)
     4420                  (setq val *x862-arg-z*))       
     4421                 ((eq op (%nx1-operator vector))
     4422                  (let* ((*x862-vstack* *x862-vstack*)
     4423                         (*x862-top-vstack-lcell* *x862-top-vstack-lcell*))
     4424                    (x862-set-nargs seg (x862-formlist seg (%cadr form) nil))
     4425                    (! make-stack-vector))
     4426                  (x862-open-undo $undostkblk)
     4427                  (setq val *x862-arg-z*))
     4428                 ((eq op (%nx1-operator %gvector))
     4429                  (let* ((*x862-vstack* *x862-vstack*)
     4430                         (*x862-top-vstack-lcell* *x862-top-vstack-lcell*)
     4431                         (arglist (%cadr form)))
     4432                    (x862-set-nargs seg (x862-formlist seg (append (car arglist) (reverse (cadr arglist))) nil))
     4433                    (! make-stack-gvector))
     4434                  (x862-open-undo $undostkblk)
     4435                  (setq val *x862-arg-z*))
     4436                 ((eq op (%nx1-operator closed-function))
     4437                  (setq val (x862-make-closure seg (cadr form) t))) ; can't error
     4438                 ((eq op (%nx1-operator %make-uvector))
     4439                  (destructuring-bind (element-count subtag &optional (init 0 init-p)) (%cdr form)
     4440                    (let* ((fix-subtag (acode-fixnum-form-p subtag))
     4441                           (is-node (x862-target-is-node-subtag fix-subtag))
     4442                           (is-imm  (x862-target-is-imm-subtag fix-subtag)))
     4443                      (when (or is-node is-imm)
     4444                        (if init-p
     4445                          (progn
     4446                            (x862-three-targeted-reg-forms seg element-count
     4447                                                           (target-arch-case
     4448                                                            (:x8632
     4449                                                             ($ x8632::temp1))
     4450                                                            (:x8664
     4451                                                             ($ x8664::arg_x)))
     4452                                                           subtag ($ *x862-arg-y*)
     4453                                                           init ($ *x862-arg-z*))
     4454                            (! stack-misc-alloc-init))
     4455                          (progn
     4456                            (x862-two-targeted-reg-forms seg element-count ($ *x862-arg-y*)  subtag ($ *x862-arg-z*))
     4457                            (! stack-misc-alloc)))
     4458                        (if is-node
     4459                          (x862-open-undo $undostkblk)
     4460                          (x862-open-undo $undo-x86-c-frame))
     4461                        (setq val ($ *x862-arg-z*))))))))))
     4462      val))
    44234463
    44244464(defun x862-addrspec-to-reg (seg addrspec reg)
     
    51545194;;; "XFER" is a compound destination.
    51555195(defun x862-conditional-form (seg xfer form)
    5156   (let* ((uwf (acode-unwrapped-form-value form)))
    5157     (if (nx-null uwf)
    5158       (x862-branch seg (x862-cd-false xfer))
    5159       (if (x86-constant-form-p uwf)
    5160         (x862-branch seg (x862-cd-true xfer))
    5161         (with-crf-target () crf
    5162           (let* ((ea (x862-lexical-reference-ea form nil)))
    5163             (if (and ea (memory-spec-p ea))
    5164               (x862-compare-ea-to-nil seg crf xfer ea x86::x86-e-bits nil)
    5165               (x862-form seg crf xfer form))))))))
     5196  (with-note (form seg xfer)
     5197    (let* ((uwf (acode-unwrapped-form-value form)))
     5198      (if (nx-null uwf)
     5199        (x862-branch seg (x862-cd-false xfer))
     5200        (if (x86-constant-form-p uwf)
     5201          (x862-branch seg (x862-cd-true xfer))
     5202          (with-crf-target () crf
     5203            (let* ((ea (x862-lexical-reference-ea form nil)))
     5204              (if (and ea (memory-spec-p ea))
     5205                (x862-compare-ea-to-nil seg crf xfer ea x86::x86-e-bits nil)
     5206                (x862-form seg crf xfer form)))))))))
    51665207
    51675208     
     
    60766117)
    60776118 
    6078 (defx862 x862-lambda lambda-list (seg vreg xfer req opt rest keys auxen body p2decls)
     6119(defx862 x862-lambda lambda-list (seg vreg xfer req opt rest keys auxen body p2decls &optional code-note)
    60796120  (with-x86-local-vinsn-macros (seg vreg xfer)
    60806121    (let* ((stack-consed-rest nil)
     
    61146155        (! establish-fn)
    61156156        (@ (backend-get-next-label))    ; self-call label
     6157        (when keys ;; Ensure keyvect is the first immediate
     6158          (x86-immediate-label (%cadr (%cdddr keys))))
     6159        (when code-note
     6160          (x862-code-coverage-entry seg code-note))
    61166161        (unless next-method-p
    61176162          (setq method-var nil))
     
    90019046                (eq typespec '*))
    90029047          (x862-form seg vreg xfer form)
    9003           (let* ((ok (backend-get-next-label)))
    9004             (x862-one-targeted-reg-form seg form ($ *x862-arg-y*))
    9005             (x862-store-immediate seg typespec ($ *x862-arg-z*))
    9006             (x862-store-immediate seg 'typep ($ *x862-fname*))
    9007             (x862-set-nargs seg 2)
    9008             (x862-vpush-register seg ($ *x862-arg-y*))
    9009             (! call-known-symbol ($ *x862-arg-z*))
    9010             (! compare-to-nil ($ *x862-arg-z*))
    9011             (x862-vpop-register seg ($ *x862-arg-y*))
    9012             (! cbranch-false (aref *backend-labels* ok) x86::x86-e-bits)
    9013             (target-arch-case
    9014              (:x8632
    9015               (let* ((*x862-vstack* *x862-vstack*)
    9016                      (*x862-top-vstack-lcell* *x862-top-vstack-lcell*))
    9017                 (! reserve-outgoing-frame)
    9018                 (incf *x862-vstack* (* 2 *x862-target-node-size*))
    9019                 (! vpush-fixnum (ash $XWRONGTYPE *x862-target-fixnum-shift*))
    9020                 (x862-store-immediate seg typespec ($ *x862-arg-z*))
    9021                 (x862-set-nargs seg 3)
    9022                 (! ksignalerr)))
    9023              (:x8664
    9024               (x862-lri seg ($ x8664::arg_x) (ash $XWRONGTYPE *x862-target-fixnum-shift*))
    9025               (x862-store-immediate seg typespec ($ *x862-arg-z*))
    9026               (x862-set-nargs seg 3)
    9027               (! ksignalerr)))
    9028             (@ ok)
    9029             (<- ($ *x862-arg-y*))
    9030             (^)))))))
     9048          (with-note (form seg vreg xfer)
     9049            (let* ((ok (backend-get-next-label)))
     9050              (x862-one-targeted-reg-form seg form ($ *x862-arg-y*))
     9051              (x862-store-immediate seg typespec ($ *x862-arg-z*))
     9052              (x862-store-immediate seg 'typep ($ *x862-fname*))
     9053              (x862-set-nargs seg 2)
     9054              (x862-vpush-register seg ($ *x862-arg-y*))
     9055              (! call-known-symbol ($ *x862-arg-z*))
     9056              (! compare-to-nil ($ *x862-arg-z*))
     9057              (x862-vpop-register seg ($ *x862-arg-y*))
     9058              (! cbranch-false (aref *backend-labels* ok) x86::x86-e-bits)
     9059              (target-arch-case
     9060               (:x8632
     9061                (let* ((*x862-vstack* *x862-vstack*)
     9062                       (*x862-top-vstack-lcell* *x862-top-vstack-lcell*))
     9063                  (! reserve-outgoing-frame)
     9064                  (incf *x862-vstack* (* 2 *x862-target-node-size*))
     9065                  (! vpush-fixnum (ash $XWRONGTYPE *x862-target-fixnum-shift*))
     9066                  (x862-store-immediate seg typespec ($ *x862-arg-z*))
     9067                  (x862-set-nargs seg 3)
     9068                  (! ksignalerr)))
     9069               (:x8664
     9070                (x862-lri seg ($ x8664::arg_x) (ash $XWRONGTYPE *x862-target-fixnum-shift*))
     9071                (x862-store-immediate seg typespec ($ *x862-arg-z*))
     9072                (x862-set-nargs seg 3)
     9073                (! ksignalerr)))
     9074              (@ ok)
     9075              (<- ($ *x862-arg-y*))
     9076              (^))))))))
    90319077         
    90329078         
  • trunk/source/compiler/lambda-list.lisp

    r11183 r11373  
    3232    (if index (%svref (function-to-function-vector fn) index))))
    3333
     34(defun function-source-note (fn)
     35  (getf (%lfun-info fn) '%function-source-note))
     36
    3437(defun uncompile-function (fn)
    3538  (getf (%lfun-info fn) 'function-lambda-expression ))
     
    3942  (getf (%lfun-info fn) 'function-symbol-map))
    4043
     44(defun find-source-note-at-pc (fn pc)
     45  ;(declare (values source-note start-pc end-pc))
     46  (let* ((function-note (function-source-note fn))
     47         (pc-source-map (getf (%lfun-info fn) 'pc-source-map))
     48         (best-guess -1)
     49         (best-length 0)
     50         (len (length pc-source-map)))
     51    (declare (fixnum best-guess best-length len))
     52    (when (and function-note pc-source-map)
     53      (do ((q 0 (+ q 4)))
     54          ((= q len))
     55        (declare (fixnum q))
     56        (let* ((pc-start (aref pc-source-map q))
     57               (pc-end (aref pc-source-map (%i+ q 1))))
     58          (declare (fixnum pc-start pc-end))
     59          (when (and (<= pc-start pc pc-end)
     60                     (or (eql best-guess -1)
     61                         (< (%i- pc-end pc-start) best-length)))
     62            (setf best-guess q
     63                  best-length (- pc-end pc-start)))))
     64      (unless (eql best-guess -1)
     65        (values
     66          (let ((def-pos (source-note-start-pos function-note)))
     67            (make-source-note :source function-note
     68                              :filename (source-note-filename function-note)
     69                              :start-pos (+ def-pos (aref pc-source-map (+ best-guess 2)))
     70                              :end-pos (+ def-pos (aref pc-source-map (+ best-guess 3)))))
     71          (aref pc-source-map best-guess)
     72          (aref pc-source-map (+ best-guess 1)))))))
     73
    4174;;; Lambda-list utilities
     75
     76
    4277
    4378
  • trunk/source/compiler/nx-basic.lisp

    r11183 r11373  
    3737(defvar *lisp-compiler-version* 666 "I lost count.")
    3838
     39#-BOOTSTRAPPED (defvar *record-pc-mapping* nil) ;; defined in level-1
     40
    3941(defvar *nx-compile-time-types* nil)
    4042(defvar *nx-proclaimed-types* nil)
    4143(defvar *nx-method-warning-name* nil)
     44
     45(defvar *nx-current-code-note*)
     46
     47;; In lieu of a slot in acode.  Don't reference this variable elsewhere because I'm
     48;; hoping to make it go away.
     49(defparameter *nx-acode-note-map* nil)
     50
     51(defun acode-note (acode &aux (hash *nx-acode-note-map*))
     52  (and hash (gethash acode hash)))
     53
     54(defun (setf acode-note) (note acode)
     55  (when note
     56    (assert *nx-acode-note-map*)
     57    (setf (gethash acode *nx-acode-note-map*) note)))
     58
     59
     60(defun nx-source-note (form &aux (source-notes *nx-source-note-map*))
     61  (when source-notes
     62    (when (or (consp form) (vectorp form) (pathnamep form))
     63      (let ((note (gethash form source-notes)))
     64        (unless (listp note) note)))))
     65
     66(defstruct (code-note (:constructor %make-code-note))
     67  ;; Code coverage state.  This MUST be the first slot - see nx2-code-coverage.
     68  code-coverage
     69  ;; The actual source form - useful for debugging, otherwise unused.
     70  #+debug-code-notes form
     71  ;; The source note of this form, or NIL if random code form (no file info,
     72  ;; generated by macros or other source transform)
     73  source-note
     74  ;; the note that was being compiled when this note was emitted.
     75  parent-note)
     76
     77(defun make-code-note (&key form source-note parent-note)
     78  (declare (ignorable form))
     79  (let ((note (%make-code-note
     80               :source-note source-note
     81               :parent-note parent-note)))
     82    #+debug-code-notes
     83    (when form
     84      ;; Unfortunately, recording the macroexpanded form is problematic, since they
     85      ;; can have references to non-dumpable forms, see e.g. loop.
     86      (setf (code-note-form note)
     87            (with-output-to-string (s) (let ((*print-circle* t)) (prin1 form s)))))
     88    note))
     89
     90(defun nx-ensure-code-note (form &optional parent-note)
     91  (let* ((parent-note (or parent-note *nx-current-code-note*))
     92         (source-note (nx-source-note form)))
     93    (unless (and source-note
     94                 ;; Look out for a case like a lambda macro that turns (lambda ...)
     95                 ;; into (FUNCTION (lambda ...)) which then has (lambda ...)
     96                 ;; as a child.  Create a fresh note for the child, to avoid ambiguity.
     97                 ;; Another case is forms wrapping THE around themselves.
     98                 (neq source-note (code-note-source-note parent-note))
     99                 ;; Don't use source notes from a different toplevel form, which could
     100                 ;; happen due to inlining etc.  The result then is that the source note
     101                 ;; appears in multiple places, and shows partial coverage (from the
     102                 ;; other reference) in code that's never executed.
     103                 (loop for p = parent-note then (code-note-parent-note p)
     104                       when (null p)
     105                         return t
     106                       when (code-note-source-note p)
     107                         return (eq (loop for n = source-note then s
     108                                          as s = (source-note-source n)
     109                                          unless (source-note-p s) return n)
     110                                    (loop for n = (code-note-source-note p) then s
     111                                          as s = (source-note-source n)
     112                                          unless (source-note-p s) return n))))
     113      (setq source-note nil))
     114    (make-code-note :form form :source-note source-note :parent-note parent-note)))
     115
     116(defun nx-note-source-transformation (original new &aux (source-notes *nx-source-note-map*) sn)
     117  (when (and source-notes
     118             (setq sn (gethash original source-notes))
     119             (not (gethash new source-notes)))
     120    (setf (gethash new source-notes) sn)))
     121
     122
    42123
    43124(defvar *nx1-alphatizers* (make-hash-table :size 180 :test #'eq))
  • trunk/source/compiler/nx.lisp

    r11212 r11373  
    152152(defparameter *load-time-eval-token* nil)
    153153
    154 (defparameter *nx-source-note-map* nil)
    155 
    156 (defun nx-source-note (form &aux (source-notes *nx-source-note-map*))
    157   (when source-notes (gethash form source-notes)))
    158  
    159 (defun nx-note-source-transformation (original new &aux (source-notes *nx-source-note-map*) sn)
    160   (when (and source-notes
    161              (setq sn (gethash original source-notes))
    162              (not (gethash new source-notes)))
    163     (setf (gethash new source-notes) sn)))
    164 
    165154(defparameter *nx-discard-xref-info-hook* nil)
    166155
    167 ;; In lieu of a slot in acode.  Don't reference this variable elsewhere because I'm
    168 ;; hoping to make it go away.
    169 (defparameter *nx-acode-source-map* nil)
    170 
    171 (defun acode-source-note (acode &aux (hash *nx-acode-source-map*))
    172   (and hash (gethash acode hash)))
    173 
    174 (defun (setf acode-source) (form acode)
    175   ;; Could save the form, but right now only really care about the source note,
    176   ;; and this way don't have to keep looking it up in pass 2.
    177   (let ((note (nx-source-note form)))
    178     (when note
    179       (assert *nx-acode-source-map*)
    180       (setf (gethash acode *nx-acode-source-map*) note))))
    181 
    182156(defun compile-named-function (def &key name env policy load-time-eval-token target
    183                                 function-note keep-lambda keep-symbols source-notes)
     157                                function-note keep-lambda keep-symbols source-notes
     158                                (record-pc-mapping *record-pc-mapping*)
     159                                (compile-code-coverage *compile-code-coverage*))
    184160  ;; SOURCE-NOTES, if not nil, is a hash table mapping source forms to locations,
    185161  ;;   is used to produce and attach a pc/source map to the lfun, also to attach
     
    193169   (let* ((*load-time-eval-token* load-time-eval-token)
    194170          (*nx-source-note-map* source-notes)
    195           (*nx-acode-source-map* (and source-notes (make-hash-table :test #'eq :shared nil)))
     171          (*nx-current-note* function-note)
     172          (*record-pc-mapping* (and source-notes record-pc-mapping))
     173          (*compile-code-coverage* (and source-notes compile-code-coverage))
     174          (*nx-acode-note-map* (and (or record-pc-mapping compile-code-coverage)
     175                                    (make-hash-table :test #'eq :shared nil)))
     176          (*nx-current-code-note* (and compile-code-coverage
     177                                       (make-code-note :form def :source-note function-note)))
    196178          (env (new-lexical-environment env)))
    197179     (setf (lexenv.variables env) 'barrier)
     
    204186                    env
    205187                    (or policy *default-compiler-policy*)
    206                     *load-time-eval-token*
    207                     function-note)))
     188                    *load-time-eval-token*)))
    208189       (if (afunc-lfun afunc)
    209190         afunc
  • trunk/source/compiler/nx0.lisp

    r11362 r11373  
    3434  v)
    3535
     36(defvar *compile-code-coverage* nil "True to instrument for code coverage")
     37
    3638(defvar *nx-blocks* nil)
    3739(defvar *nx-tags* nil)
     
    4244(defvar *nx-inner-functions* nil)
    4345(defvar *nx-cur-func-name* nil)
     46(defvar *nx-current-note*)
     47(defparameter *nx-source-note-map* nil) ;; there might be external refs, from macros.
    4448(defvar *nx-form-type* t)
    4549;(defvar *nx-proclaimed-inline* nil)
     
    5761(defvar *nx1-operators* (make-hash-table :size 300 :test #'eq))
    5862
    59                                          
    6063
    6164; The compiler can (generally) use temporary vectors for VARs.
     
    8083
    8184(defvar *nx1-compiler-special-forms* nil "Real special forms")
     85
     86(defmacro without-compiling-code-coverage (&body body)
     87  "Disable code coverage in the lexical scope of the form"
     88  `(compiler-let ((*nx-current-code-note* nil))
     89     ,@body))
    8290
    8391(defparameter *nx-never-tail-call*
     
    9199
    92100(defvar *cross-compiling* nil "bootstrapping")
    93 
    94101
    95102
     
    526533;; compile time.   To actually generate code, use acode-unwrapped-form.
    527534(defun acode-unwrapped-form-value (form)
    528   ;; Currently no difference
     535  ;; Currently no difference, but if had any operators like with-code-note,
     536  ;; would unwrap them here.
    529537  (acode-unwrapped-form form))
    530538
     
    10871095         (token nil))
    10881096    (if (and (nx-declared-inline-p sym env)
    1089              (not (gethash sym *nx1-alphatizers*)))
     1097             (not (gethash sym *nx1-alphatizers*))
     1098             (not *nx-current-code-note*))
    10901099      (multiple-value-bind (info afunc) (unless global-only (nx-lexical-finfo sym env))
    10911100        (if info (setq token afunc
     
    12951304                                 parent-env
    12961305                                 (policy *default-compiler-policy*)
    1297                                  load-time-eval-token
    1298                                  function-note)
     1306                                 load-time-eval-token)
    12991307
    13001308  (if q
     
    13191327            name)))
    13201328
    1321   (when (or function-note
    1322             (setq function-note (nx-source-note lambda-form))
    1323             (setq function-note (and q (getf (afunc-lfun-info q) 'function-source-note))))
    1324     (setf (afunc-lfun-info p)
    1325           (list* 'function-source-note function-note (afunc-lfun-info p))))
    1326 
    13271329  (unless (lambda-expression-p lambda-form)
    13281330    (nx-error "~S is not a valid lambda expression." lambda-form))
     1331
    13291332  (let* ((*nx-current-function* p)
    13301333         (*nx-parent-function* q)
     1334         (*nx-current-note* (or *nx-current-note* (nx-source-note lambda-form)))
    13311335         (*nx-lexical-environment* (new-lexical-environment parent-env))
    13321336         (*nx-load-time-eval-token* load-time-eval-token)
     
    13521356
    13531357    (setf (afunc-lambdaform p) lambda-form)
     1358
     1359    (when *nx-current-note*
     1360      (setf (afunc-lfun-info p)
     1361            (list* '%function-source-note *nx-current-note* (afunc-lfun-info p))))
     1362
    13541363    (with-program-error-handler
    13551364        (lambda (c)
     
    13711380            (with-program-error-handler (lambda (c) (runtime-program-error-form c))
    13721381              (parse-body (%cddr lambda-form) *nx-lexical-environment* t))
    1373           (setf (afunc-acode p) (nx1-lambda (%cadr lambda-form) body decls)))))
     1382          (setf (afunc-acode p) (nx1-lambda (%cadr lambda-form) body decls)))))
    13741383
    13751384    (nx1-transitively-punt-bindings *nx-punted-vars*)
     
    14461455                   (%ilsl $fbitnextmethp 1)
    14471456                   (afunc-bits *nx-current-function*)))))
    1448         (make-acode
    1449          (%nx1-operator lambda-list)
    1450          req
    1451          opt
    1452          (if lexpr (list rest) rest)
    1453          keys
    1454          auxen
    1455          body
    1456          *nx-new-p2decls*)))))
     1457        (let ((acode (make-acode
     1458                      (%nx1-operator lambda-list)
     1459                      req
     1460                      opt
     1461                      (if lexpr (list rest) rest)
     1462                      keys
     1463                      auxen
     1464                      body
     1465                      *nx-new-p2decls*)))
     1466          (when *nx-current-code-note*
     1467            (setf (acode-note acode) *nx-current-code-note*))
     1468          acode)))))
    14571469
    14581470(defun nx-parse-simple-lambda-list (pending ll &aux
     
    16561668
    16571669(defun nx1-transformed-form (form env)
    1658   (flet ((main (form env)
    1659            (if (consp form)
    1660              (nx1-combination form env)
    1661              (let* ((symbolp (non-nil-symbol-p form))
    1662                     (constant-value (unless symbolp form))
    1663                     (constant-symbol-p nil))
    1664                (if symbolp
    1665                  (multiple-value-setq (constant-value constant-symbol-p)
    1666                    (nx-transform-defined-constant form env)))
    1667                (if (and symbolp (not constant-symbol-p))
    1668                  (nx1-symbol form env)
    1669                  (nx1-immediate (nx-unquote constant-value)))))))
    1670     (if *nx-source-note-map*
    1671       (let ((acode (main form env)))
    1672         (setf (acode-source acode) form)
    1673         acode)
    1674       (main form env))))
     1670  (let* ((*nx-current-note* (or (nx-source-note form) *nx-current-note*))
     1671         (*nx-current-code-note*  (and *nx-current-code-note*
     1672                                       (or (nx-ensure-code-note form *nx-current-code-note*)
     1673                                           (compiler-bug "No source note for ~s" form))))
     1674         (acode (if (consp form)
     1675                  (nx1-combination form env)
     1676                  (let* ((symbolp (non-nil-symbol-p form))
     1677                         (constant-value (unless symbolp form))
     1678                         (constant-symbol-p nil))
     1679                    (if symbolp
     1680                      (multiple-value-setq (constant-value constant-symbol-p)
     1681                        (nx-transform-defined-constant form env)))
     1682                    (if (and symbolp (not constant-symbol-p))
     1683                      (nx1-symbol form env)
     1684                      (nx1-immediate (nx-unquote constant-value)))))))
     1685    (cond (*nx-current-code-note*
     1686           (setf (acode-note acode) *nx-current-code-note*))
     1687          (*record-pc-mapping*
     1688           (setf (acode-note acode) (nx-source-note form))))
     1689    acode))
    16751690
    16761691(defun nx1-prefer-areg (form env)
  • trunk/source/compiler/nx1.lisp

    r11325 r11373  
    12161216  (setf (afunc-inner-functions q) (push p *nx-inner-functions*))
    12171217  (setf (lexenv.lambda env) q)
    1218   (nx1-compile-lambda name def p q env *nx-current-compiler-policy* *nx-load-time-eval-token*)) ;returns p.
     1218  (if *nx-current-code-note*
     1219    (let* ((*nx-current-code-note* (nx-ensure-code-note def *nx-current-code-note*)))
     1220      (nx1-compile-lambda name def p q env *nx-current-compiler-policy* *nx-load-time-eval-token*)) ;returns p.
     1221    (nx1-compile-lambda name def p q env *nx-current-compiler-policy* *nx-load-time-eval-token*)))
    12191222
    12201223(defun nx1-afunc-ref (afunc)
     
    16481651                      (afunc-environment func) env)
    16491652                (push (cons funcname expansion)
    1650                             bodies)))))
     1653                      bodies)))))
    16511654        (nx1-dynamic-extent-functions vars env)
    16521655        (dolist (def bodies)
  • trunk/source/level-0/l0-init.lisp

    r11321 r11373  
    158158
    159159(defparameter *loading-file-source-file* nil)
     160(defparameter *loading-toplevel-location* nil)
    160161
    161162(defvar *nx-speed* 1)
  • trunk/source/level-0/nfasload.lisp

    r10811 r11373  
    716716    ; (format t "~& source-file = ~s" source-file)
    717717    (setq *loading-file-source-file* source-file)))
     718
     719(deffaslop $fasl-toplevel-location (s)
     720  (%cant-epush s)
     721  (setq *loading-toplevel-location* (%fasl-expr s)))
    718722
    719723(defvar *modules* nil)
  • 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
  • trunk/source/lib/ccl-export-syms.lisp

    r11206 r11373  
    4040     edit-definition-p
    4141     *loading-file-source-file*
     42     find-definition-sources
     43     define-definition-type
     44     *save-source-locations*
     45     function-source-note
     46     source-note
     47     source-note-p
     48     source-note-filename
     49     source-note-start-pos
     50     source-note-end-pos
     51     source-note-text
     52     ensure-source-note-text
     53     *record-pc-mapping*
     54     find-source-note-at-pc
     55
    4256     show-documentation
    4357     %set-toplevel
     
    874888  (while %lisp-system-fixups%
    875889    (let* ((fn.source (car %lisp-system-fixups%))
    876            (*loading-file-source-file* (cdr fn.source)))
     890           (*loading-toplevel-location* (and (source-note-p (cdr fn.source)) (cdr fn.source)))
     891           (*loading-file-source-file* (source-note-filename (cdr fn.source)))
     892           )
    877893      (funcall (car fn.source)))
    878894    (setq %lisp-system-fixups% (cdr %lisp-system-fixups%)))
  • trunk/source/lib/macros.lisp

    r11285 r11373  
    15931593     (if (eq %lisp-system-fixups% T)
    15941594       (funcall ,fn)
    1595        (push (cons ,fn *loading-file-source-file*) %lisp-system-fixups%))))
     1595       (push (cons ,fn (or *loading-toplevel-location* *loading-file-source-file*)) %lisp-system-fixups%))))
    15961596
    15971597(defmacro %incf-ptr (p &optional (by 1))
  • trunk/source/lib/misc.lisp

    r11078 r11373  
    760760(%fhave 'df #'disassemble)
    761761
     762(defun string-sans-most-whitespace (string &optional (max-length (length string)))
     763  (with-output-to-string (sans-whitespace)
     764    (loop
     765      for count below max-length
     766      for char across string
     767      with just-saw-space = nil
     768      if (member char '(#\Space #\Tab #\Newline #\Return #\Formfeed))
     769        do (if just-saw-space
     770               (decf count)
     771               (write-char #\Space sans-whitespace))
     772        and do (setf just-saw-space t)
     773      else
     774        do (setf just-saw-space nil)
     775        and do (write-char char sans-whitespace))))
     776
     777
    762778(defloadvar *use-cygwin-svn*
    763779    #+windows-target (not (null (getenv "CYGWIN")))
  • trunk/source/lib/nfcomp.lisp

    r11183 r11373  
    4545) ;eval-when (:compile-toplevel :execute)
    4646
     47; inited in l1-init, this is for when loading into a lisp that doesn't have it yet.
     48#-BOOTSTRAPPED (eval-when (compile load eval)
     49                 (unless (boundp '*LOADING-TOPLEVEL-LOCATION*)
     50                   (declaim (special *loading-toplevel-location*))
     51                   (defparameter *save-source-locations* nil)))
     52
    4753;File compiler options.  Not all of these need to be exported/documented, but
    4854;they should be in the product just in case we need them for patches....
    4955(defvar *fasl-save-local-symbols* t)
     56(defvar *fasl-save-doc-strings*  t)
     57(defvar *fasl-save-definitions* nil)
     58
    5059(defvar *fasl-deferred-warnings* nil)
    5160(defvar *fasl-non-style-warnings-signalled-p* nil)
    5261(defvar *fasl-warnings-signalled-p* nil)
     62
    5363(defvar *compile-verbose* nil ; Might wind up getting called *compile-FILE-verbose*
    5464  "The default for the :VERBOSE argument to COMPILE-FILE.")
    55 (defvar *fasl-save-doc-strings*  t)
    56 (defvar *fasl-save-definitions* nil)
    5765(defvar *compile-file-pathname* nil
    5866  "The defaulted pathname of the file currently being compiled, or NIL if not
     
    125133                         (save-doc-strings *fasl-save-doc-strings*)
    126134                         (save-definitions *fasl-save-definitions*)
    127                          (break-on-program-errors *fasl-break-on-program-errors*)
     135                         (save-source-locations *save-source-locations*)
    128136                         (external-format :default)
    129                          force)
    130   "Compile INPUT-FILE, producing a corresponding fasl file and returning
    131    its filename."
     137                         force
     138                         ;; src may be a temp file with a section of the real source,
     139                         ;; then this is the real source file name.
     140                         compile-file-original-truename
     141                         (compile-file-original-buffer-offset 0)
     142                         (break-on-program-errors (if compile-file-original-truename
     143                                                    t  ;; really SLIME being interactive...
     144                                                    *fasl-break-on-program-errors*)))
     145  "Compile SRC, producing a corresponding fasl file and returning its filename."
    132146  (let* ((backend *target-backend*))
    133147    (when (and target-p (not (setq backend (find-backend target))))
     
    138152         (return (%compile-file src output-file verbose print load features
    139153                                save-local-symbols save-doc-strings save-definitions
    140                                 break-on-program-errors
    141                                 force backend external-format))
     154                                save-source-locations break-on-program-errors
     155                                force backend external-format
     156                                compile-file-original-truename compile-file-original-buffer-offset))
    142157         (retry-compile-file ()
    143158                             :report (lambda (stream) (format stream "Retry compiling ~s" src))
     
    151166(defun %compile-file (src output-file verbose print load features
    152167                          save-local-symbols save-doc-strings save-definitions
    153                           break-on-program-errors
     168                          save-source-locations break-on-program-errors
    154169                          force target-backend external-format
    155                           &aux orig-src)
    156 
    157   (setq orig-src (merge-pathnames src))
    158   (let* ((output-default-type (backend-target-fasl-pathname target-backend)))
     170                          compile-file-original-truename compile-file-original-buffer-offset)
     171  (let* ((orig-src (merge-pathnames src))
     172         (output-default-type (backend-target-fasl-pathname target-backend)))
    159173    (setq src (fcomp-find-file orig-src))
    160174    (let* ((newtype (pathname-type src)))
     
    185199             (*fasl-deferred-warnings* nil) ; !!! WITH-COMPILATION-UNIT ...
    186200             (*fasl-save-local-symbols* save-local-symbols)
     201             (*save-source-locations* save-source-locations)
    187202             (*fasl-save-doc-strings* save-doc-strings)
    188203             (*fasl-save-definitions* save-definitions)
     
    209224            (setf (defenv.defined defenv) (deferred-warnings.defs *outstanding-deferred-warnings*))
    210225
    211             (setq forms (fcomp-file src orig-src lexenv))
     226            (setq forms (fcomp-file src
     227                                    (or compile-file-original-truename orig-src)
     228                                    compile-file-original-buffer-offset
     229                                    lexenv))
    212230
    213231            (setf (deferred-warnings.warnings *outstanding-deferred-warnings*)
     
    262280(defun %compile-time-eval (form env)
    263281  (declare (ignore env))
    264   (let* ((*target-backend* *host-backend*))
     282  (let* ((*target-backend* *host-backend*)
     283         (*loading-toplevel-location* (or (fcomp-source-note form)
     284                                          *loading-toplevel-location*))
     285         (lambda `(lambda () ,form)))
     286    (fcomp-note-source-transformation form lambda)
    265287    ;; The HANDLER-BIND here is supposed to note WARNINGs that're
    266288    ;; signaled during (eval-when (:compile-toplevel) processing; this
     
    276298                              (signal c))))
    277299      (funcall (compile-named-function
    278                 `(lambda () ,form)
     300                lambda
     301                :source-notes *fcomp-source-note-map*
    279302                :env *fasl-compile-time-env*
    280303                :policy *compile-time-evaluation-policy*)))))
     
    346369(defvar *fcomp-output-list*)
    347370(defvar *fcomp-toplevel-forms*)
     371(defvar *fcomp-source-note-map* nil)
     372(defvar *fcomp-loading-toplevel-location*)
    348373(defvar *fcomp-warnings-header*)
    349374(defvar *fcomp-stream-position* nil)
     
    379404
    380405
    381 (defun fcomp-file (filename orig-file env)  ; orig-file is back-translated
     406(defun fcomp-file (filename orig-file orig-offset env)  ; orig-file is back-translated
    382407  (let* ((*package* *package*)
    383408         (*compiling-file* filename)
     
    396421         (*fcomp-last-compile-print* (cons nil (cons nil nil))))
    397422    (push (list $fasl-platform (backend-target-platform *fasl-backend*)) *fcomp-output-list*)
    398     (fcomp-read-loop filename orig-file env :not-compile-time)
     423    (fcomp-read-loop filename orig-file orig-offset env :not-compile-time)
    399424    (nreverse *fcomp-output-list*)))
    400425
     
    408433;;; when from fcomp-include it's included filename merged with *compiling-file*
    409434;;; which is not back translated
    410 (defun fcomp-read-loop (filename orig-file env processing-mode)
     435(defun fcomp-read-loop (filename orig-file orig-offset env processing-mode)
    411436  (when *compile-verbose*
    412437    (format t "~&;~A ~S..."
     
    414439            filename))
    415440  (with-open-file (stream filename
    416                           :element-type 'base-char
    417                           :external-format *fcomp-external-format*)
    418     (let* ((old-file (and (neq filename *compiling-file*) *fasl-source-file*))           
     441                          :element-type 'base-char
     442                          :external-format *fcomp-external-format*)
     443    (let* ((old-file (and (neq filename *compiling-file*) *fasl-source-file*))
    419444           (*fasl-source-file* filename)
    420445           (*fcomp-toplevel-forms* nil)
    421446           (*fasl-eof-forms* nil)
    422            (*loading-file-source-file* (namestring orig-file)) ; why orig-file???
     447           (*loading-file-source-file* (namestring orig-file))
     448           (*fcomp-source-note-map* (and *save-source-locations*
     449                                         (make-hash-table :test #'eq :shared nil)))
     450           (*loading-toplevel-location* nil)
     451           (*fcomp-loading-toplevel-location* nil)
    423452           (eofval (cons nil nil))
    424453           (read-package nil)
    425454           form)
    426       (declare (special *fasl-eof-forms* *fcomp-toplevel-forms* *fasl-source-file*))
    427       ;;This should really be something like `(set-loading-source
    428       ;;,filename) but then couldn't compile level-1 with this...  ->
    429       ;;In any case, change this to be a fasl opcode, so don't make an
    430       ;;lfun just to do this...  There are other reasons - more
    431       ;;compelling ones than "fear of tiny lfuns" - for making this a
    432       ;;fasl opcode.
     455
    433456      (fcomp-output-form $fasl-src env *loading-file-source-file*)
    434457      (let* ((*fcomp-previous-position* nil))
    435458        (loop
    436459          (let* ((*fcomp-stream-position* (file-position stream))
    437                  (*nx-warnings* nil))
     460                 (*nx-warnings* nil)) ;; catch any warnings from :compile-toplevel forms
    438461            (unless (eq read-package *package*)
    439462              (fcomp-compile-toplevel-forms env)
     
    447470                                (format *error-output* "~&Read error between positions ~a and ~a in ~a." pos (file-position stream) filename)
    448471                                (signal c))))
    449                   (setq form (read stream nil eofval)))))
    450             (when (eq eofval form) (return))
     472                  (multiple-value-setq (form *loading-toplevel-location*)
     473                    (if *fcomp-source-note-map* ;; #-BOOTSTRAPPED
     474                      (read-recording-source stream
     475                                             :eofval eofval
     476                                             :file-name *loading-file-source-file*
     477                                             :start-offset orig-offset
     478                                             :map *fcomp-source-note-map*
     479                                             :save-source-text (neq *save-source-locations* :no-text))
     480                      (read-recording-source stream
     481                                             :eofval eofval
     482                                             :file-name *loading-file-source-file*
     483                                             :start-offset orig-offset))))))
     484            (when (eq eofval form)
     485              (require-type *loading-toplevel-location* 'null)
     486              (return))
    451487            (fcomp-form form env processing-mode)
    452488            (fcomp-signal-or-defer-warnings *nx-warnings* env)
     
    501537                             "")))))))
    502538    (fcomp-form-1 form env processing-mode)))
    503            
     539
    504540(defun fcomp-form-1 (form env processing-mode &aux sym body)
    505541  (if (consp form) (setq sym (%car form) body (%cdr form)))
    506542  (case sym
    507543    (progn (fcomp-form-list body env processing-mode))
    508     (eval-when (fcomp-eval-when body env processing-mode))
    509     (compiler-let (fcomp-compiler-let body env processing-mode))
    510     (locally (fcomp-locally body env processing-mode))
    511     (macrolet (fcomp-macrolet body env processing-mode))
    512     (symbol-macrolet (fcomp-symbol-macrolet body env processing-mode))
     544    (eval-when (fcomp-eval-when form env processing-mode))
     545    (compiler-let (fcomp-compiler-let form env processing-mode))
     546    (locally (fcomp-locally form env processing-mode))
     547    (macrolet (fcomp-macrolet form env processing-mode))
     548    (symbol-macrolet (fcomp-symbol-macrolet form env processing-mode))
    513549    ((%include include) (fcomp-include form env processing-mode))
    514550    (t
     
    519555     (cond
    520556       ((and (non-nil-symbol-p sym)
    521              (macro-function sym env)           
     557             (macro-function sym env)
    522558             (not (compiler-macro-function sym env))
    523559             (not (eq sym '%defvar-init)) ;  a macro that we want to special-case
    524              (multiple-value-bind (new win) (macroexpand-1 form env)
     560             (multiple-value-bind (new win) (fcomp-macroexpand-1 form env)
    525561               (if win (setq form new))
    526562               win))
     
    528564       ((and (not *fcomp-inside-eval-always*)
    529565             (memq sym *fcomp-eval-always-functions*))
    530         (let* ((*fcomp-inside-eval-always* t))
    531           (fcomp-form-1 `(eval-when (:execute :compile-toplevel :load-toplevel) ,form) env processing-mode)))
     566        (let* ((*fcomp-inside-eval-always* t)
     567               (new `(eval-when (:execute :compile-toplevel :load-toplevel) ,form)))
     568          (fcomp-form-1 new env processing-mode)))
    532569       (t
    533570        (when (or (eq processing-mode :compile-time) (eq processing-mode :compile-time-too))
     
    548585
    549586(defun fcomp-form-list (forms env processing-mode)
    550   (dolist (form forms) (fcomp-form form env processing-mode)))
    551 
    552 (defun fcomp-compiler-let (form env processing-mode &aux vars varinits)
     587  (let* ((outer *loading-toplevel-location*))
     588    (dolist (form forms)
     589      (setq *loading-toplevel-location* (or (fcomp-source-note form) outer))
     590      (fcomp-form form env processing-mode))
     591    (setq *loading-toplevel-location* outer)))
     592
     593(defun fcomp-compiler-let (form env processing-mode &aux vars varinits (body (%cdr form)))
    553594  (fcomp-compile-toplevel-forms env)
    554   (dolist (pair (pop form))
     595  (dolist (pair (car body))
    555596    (push (nx-pair-name pair) vars)
    556597    (push (%compile-time-eval (nx-pair-initform pair) env) varinits))
    557598  (progv (nreverse vars) (nreverse varinits)
    558                  (fcomp-form-list form env processing-mode)
    559                  (fcomp-compile-toplevel-forms env)))
    560 
    561 (defun fcomp-locally (body env processing-mode)
     599    (fcomp-form-list (cdr body) env processing-mode)
     600    (fcomp-compile-toplevel-forms env)))
     601
     602(defun fcomp-locally (form env processing-mode &aux (body (%cdr form)))
    562603  (fcomp-compile-toplevel-forms env)
    563604  (multiple-value-bind (body decls) (parse-body body env)
     
    566607      (fcomp-compile-toplevel-forms env))))
    567608
    568 (defun fcomp-macrolet (body env processing-mode)
     609(defun fcomp-macrolet (form env processing-mode &aux (body (%cdr form)))
    569610  (fcomp-compile-toplevel-forms env)
    570611  (let ((outer-env (augment-environment env
     
    582623        (fcomp-compile-toplevel-forms env)))))
    583624
    584 (defun fcomp-symbol-macrolet (body env processing-mode)
     625(defun fcomp-symbol-macrolet (form env processing-mode &aux (body (%cdr form)))
    585626  (fcomp-compile-toplevel-forms env)
    586627  (let* ((outer-env (augment-environment env :symbol-macro (car body))))
     
    590631        (fcomp-form-list body env processing-mode)
    591632        (fcomp-compile-toplevel-forms env)))))
    592                                                                
    593 (defun fcomp-eval-when (form env processing-mode &aux (eval-times (pop form)))
     633
     634(defun fcomp-eval-when (form env processing-mode &aux (body (%cdr form)) (eval-times (pop body)))
    594635  (let* ((compile-time-too  (eq processing-mode :compile-time-too))
    595636         (compile-time-only (eq processing-mode :compile-time))
     
    608649    (fcomp-compile-toplevel-forms env)        ; always flush the suckers
    609650    (cond (compile-time-only
    610            (if at-eval-time (fcomp-form-list form env :compile-time)))
     651           (if at-eval-time (fcomp-form-list body env :compile-time)))
    611652          (at-load-time
    612            (fcomp-form-list form env (if (or at-compile-time (and at-eval-time compile-time-too))
     653           (fcomp-form-list body env (if (or at-compile-time (and at-eval-time compile-time-too))
    613654                                       :compile-time-too
    614655                                       :not-compile-time)))
    615656          ((or at-compile-time (and at-eval-time compile-time-too))
    616            (fcomp-form-list form env :compile-time))))
     657           (fcomp-form-list body env :compile-time))))
    617658  (fcomp-compile-toplevel-forms env))
    618659
     
    627668    (let ((*fcomp-indentation* (+ 4 *fcomp-indentation*))
    628669          (*package* *package*))
    629       (fcomp-read-loop (fcomp-find-file actual) actual env processing-mode)
     670      (fcomp-read-loop (fcomp-find-file actual) actual 0 env processing-mode)
    630671      (fcomp-output-form $fasl-src env *loading-file-source-file*))
    631672    (when *compile-print* (format t "~&~vTFinished included file ~A~%" *fcomp-indentation* actual))))
     
    654695    (if (quoted-form-p sym)
    655696      (setq sym (%cadr sym)))
    656     (if (and (typep sym 'symbol) (or  (quoted-form-p valform) (self-evaluating-p valform)))
     697    (if (and (typep sym 'symbol) (or (quoted-form-p valform) (self-evaluating-p valform)))
    657698      (fcomp-output-form $fasl-defconstant env sym (eval-constant valform) (eval-constant doc))
    658699      (fcomp-random-toplevel-form form env))))
     
    664705    (if (quoted-form-p sym)
    665706      (setq sym (%cadr sym)))
    666     (let* ((fn (fcomp-function-arg valform env)))
    667       (if (and (typep sym 'symbol) (or fn (constantp valform)))
     707    (let* ((sym-p (typep sym 'symbol))
     708           (fn (and sym-p (fcomp-function-arg valform env))))
     709      (if (and sym-p (or fn (constantp valform)))
    668710        (fcomp-output-form $fasl-defparameter env sym (or fn (eval-constant valform)) (eval-constant doc))
    669711        (fcomp-random-toplevel-form form env)))))
     
    686728          (if (and sym-p (or fn (constantp valform)))
    687729            (fcomp-output-form $fasl-defvar-init env sym (or fn (eval-constant valform)) (eval-constant doc))
    688             (fcomp-random-toplevel-form (macroexpand-1 form env) env)))))))
     730            (fcomp-random-toplevel-form form env)))))))
    689731     
    690 
    691 
    692732(defun define-compile-time-macro (name lambda-expression env)
    693733  (let ((compile-time-defenv (definition-environment *fasl-compile-time-env*))
     
    719759  (dolist (sym syms)
    720760    (if (symbolp sym)
    721     (push (cons sym type) *nx-compile-time-types*)
     761      (push (cons sym type) *nx-compile-time-types*)
    722762      (warn "~S isn't a symbol in ~S type declaration while compiling ~S."
    723763            sym type *fasl-source-file*))))
     
    817857        (setf (defenv.structrefs defenv) structrefs)))))
    818858
    819 
     859(defun fcomp-source-note (form &aux (notes *fcomp-source-note-map*))
     860  (and notes (gethash form notes)))
     861
     862(defun fcomp-note-source-transformation (original new)
     863  (let* ((*nx-source-note-map* *fcomp-source-note-map*))
     864    (nx-note-source-transformation original new)))
     865
     866(defun fcomp-macroexpand-1 (form env)
     867  (let* ((*nx-source-note-map* *fcomp-source-note-map*))
     868    (multiple-value-bind (new win)
     869        (macroexpand-1 form env)
     870      (when win
     871        (nx-note-source-transformation form new))
     872      (values new win))))
    820873
    821874(defun fcomp-transform (form env)
    822   (nx-transform form env))
     875  (let* ((*nx-source-note-map* *fcomp-source-note-map*))
     876    (nx-transform form env)))
     877
    823878
    824879(defun fcomp-random-toplevel-form (form env)
     
    831886      ;;This assumes the form has been macroexpanded, or at least none of the
    832887      ;;non-evaluated macro arguments could look like functions.
    833       (let (lfun (args (%cdr form)))
    834         (while args
    835           (multiple-value-bind (arg win) (fcomp-transform (%car args) env)
    836             (when (or (setq lfun (fcomp-function-arg arg env))
    837                       win)
    838               (when lfun (setq arg `',lfun))
    839               (labels ((subst-l (new ptr list)
    840                          (if (eq ptr list) (cons new (cdr list))
    841                            (cons (car list) (subst-l new ptr (%cdr list))))))
    842                 (setq form (subst-l arg args form))))
    843             (setq args (%cdr args))))))
     888      (let ((new-form (make-list (length form))))
     889        (declare (dynamic-extent new-form))
     890        (loop for arg in (%cdr form) for newptr on (%cdr new-form)
     891              do (setf (%car newptr)
     892                       (multiple-value-bind (new win) (fcomp-transform arg env)
     893                         (let ((lfun (fcomp-function-arg new env)))
     894                           (when lfun
     895                             (setq new `',lfun win t)
     896                             (fcomp-note-source-transformation arg new)))
     897                         (if win new arg))))
     898        (unless (every #'eq (%cdr form) (%cdr new-form))
     899          (setf (%car new-form) (%car form))
     900          (fcomp-note-source-transformation form (setq form (copy-list new-form))))))
     901    (fcomp-ensure-source env)
    844902    (push form *fcomp-toplevel-forms*)))
    845903
    846904(defun fcomp-function-arg (expr env)
    847905  (when (consp expr)
    848     (if (and (eq (%car expr) 'nfunction)
    849              (lambda-expression-p (cadr (%cdr expr))))
    850       (fcomp-named-function (%caddr expr) (%cadr expr) env)
    851       (if (and (eq (%car expr) 'function)
    852                (lambda-expression-p (car (%cdr expr))))
    853         (fcomp-named-function (%cadr expr) nil env)))))
     906    (multiple-value-bind (lambda-expr name win)
     907        (cond ((and (eq (%car expr) 'nfunction)
     908                    (lambda-expression-p (cadr (%cdr expr))))
     909               (values (%caddr expr) (%cadr expr) t))
     910              ((and (eq (%car expr) 'function)
     911                    (lambda-expression-p (car (%cdr expr))))
     912               (values (%cadr expr) nil t)))
     913      (when win
     914        (fcomp-named-function lambda-expr name env
     915                              (or (fcomp-source-note expr)
     916                                  (fcomp-source-note lambda-expr)
     917                                  *loading-toplevel-location*))))))
    854918
    855919(defun fcomp-compile-toplevel-forms (env)
     
    883947              (fcomp-compile-toplevel-forms env))))))))
    884948
     949(defun fcomp-ensure-source (env)
     950  ;; if source location saving is off, both values are NIL, so this will do nothing,
     951  ;; don't need to check explicitly.
     952  (unless (eq *fcomp-loading-toplevel-location* *loading-toplevel-location*)
     953    (setq *fcomp-loading-toplevel-location* *loading-toplevel-location*)
     954    (fcomp-output-form $fasl-toplevel-location env *loading-toplevel-location*)))
     955
    885956(defun fcomp-output-form (opcode env &rest args)
     957  (fcomp-ensure-source env)
    886958  (when *fcomp-toplevel-forms* (fcomp-compile-toplevel-forms env))
    887959  (push (cons opcode args) *fcomp-output-list*))
     960
    888961
    889962;;; Compile a lambda expression for the sole purpose of putting it in a fasl
    890963;;; file.  The result will not be funcalled.  This really shouldn't bother
    891964;;; making an lfun, but it's simpler this way...
    892 (defun fcomp-named-function (def name env)
     965(defun fcomp-named-function (def name env &optional source-note)
    893966  (let* ((env (new-lexical-environment env))
    894967         (*nx-break-on-program-errors* (not (memq *fasl-break-on-program-errors* '(nil :defer)))))
     
    897970                                :name name
    898971                                :env env
     972                                :function-note source-note
    899973                                :keep-lambda *fasl-save-definitions*
    900974                                :keep-symbols *fasl-save-local-symbols*
    901975                                :policy *default-file-compilation-policy*
     976                                :source-notes *fcomp-source-note-map*
    902977                                :load-time-eval-token cfasl-load-time-eval-sym
    903978                                :target *fasl-target*)
     
    9621037                                          :test 'eq
    9631038                                          :shared nil))
    964          (*make-load-form-hash* (make-hash-table :test 'eq))
     1039         (*make-load-form-hash* (make-hash-table :test 'eq :shared nil))
    9651040         (*fasdump-read-package* nil)
    9661041         (*fasdump-global-offsets* nil)
     
    11361211
    11371212(defun fasl-scan-user-form (form)
     1213  (when (or (source-note-p form)
     1214            (code-note-p form))
     1215    (return-from fasl-scan-user-form (fasl-scan-gvector form)))
    11381216  (multiple-value-bind (load-form init-form) (make-load-form form *fcomp-load-forms-environment*)
    11391217    (labels ((simple-load-form (form)
  • trunk/source/lib/source-files.lisp

    r11183 r11373  
    548548                  do (setq list (nconc (find-definition-sources m 'method) list))))))
    549549    ;; Convert to old format, (type-or-name . file)
    550     (loop for ((dt . full-name) . files) in list
     550    (loop for ((dt . full-name) . sources) in list
    551551          as spec = (if (eq full-name name) (definition-type-name dt) full-name)
    552           nconc (mapcan (lambda (file) (when file (list (cons spec file)))) files))))
    553 
    554 
     552          nconc (mapcan (lambda (s)
     553                          (when s (list (cons spec (source-note-filename s)))))
     554                        sources))))
     555
     556
     557;; For ilisp.
     558(defun %source-files (name)
     559  (let ((type-list ())
     560        (meth-list ()))
     561    (loop for ((dt . full-name) . sources) in (find-definition-sources name t)
     562          as files = (mapcan #'(lambda (s)
     563                                 (and s (setq s (source-note-filename s)) (list s)))
     564                             sources)
     565          when files
     566            do (if (typep dt 'method-definition-type)
     567                 (dolist (file files)
     568                   (push (cons full-name file) meth-list))
     569                 (push (cons (definition-type-name dt) files) type-list)))
     570    (when meth-list
     571      (push (cons 'method meth-list) type-list))
     572    type-list))
     573
     574;; For CVS slime as of 11/15/2008.
    555575(defun get-source-files-with-types&classes (sym &optional (type t) classes qualifiers the-method)
    556576  (let* ((name (or the-method
     
    561581
    562582
    563 ;; For ilisp.
    564 (defun %source-files (name)
    565   (let ((type-list ())
    566         (meth-list ()))
    567     (loop for ((dt . full-name) . files) in (find-definition-sources name t)
    568           do (if (typep dt 'method-definition-type)
    569                (dolist (file files)
    570                  (push (cons full-name file) meth-list))
    571                (push (cons (definition-type-name dt) files) type-list)))
    572     (when meth-list
    573       (push (cons 'method meth-list) type-list))
    574     type-list))
    575 
    576 ;;; For swank.
     583#|
     584;; For working-0711 versions of slime, but this doesn't actually work since
     585;; source-note representations are not compatible
    577586
    578587(defun find-definitions-for-name (name &optional (type-name t))
     
    591600        (when (typep dt 'definition-type)
    592601          (setf (car pair) (definition-type-name dt)))))))
     602|#
    593603
    594604;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     
    623633            (values name quals specs)))))))
    624634
    625 (defmethod record-definition-source ((dt definition-type) name file-name)
     635(defmethod record-definition-source ((dt definition-type) name source)
    626636  (let* ((key (definition-base-name dt name))
    627637         (all (%source-file-entries key))
     
    633643               (setq e-files (def-source-entry.sources key entry))
    634644               (let ((old (flet ((same-file (x y)
     645                                   (setq x (source-note-filename x))
     646                                   (setq y (source-note-filename y))
    635647                                   (or (equal x y)
    636648                                       (and x
     
    639651                                             (or (probe-file x) (full-pathname x))
    640652                                             (or (probe-file y) (full-pathname y)))))))
    641                             (member file-name e-files :test #'same-file))))
    642                  (when (and old (neq file-name (car e-files))) ;; move to front
    643                    (setq e-files (cons file-name (remove (car old) e-files :test #'eq)))))
     653                            (member source e-files :test #'same-file))))
     654                 (when (and old (neq source (car e-files))) ;; move to front
     655                   (setq e-files (cons source (remove (car old) e-files :test #'eq)))))
    644656               (return (setq e-loc ptr))))
    645     (unless (and e-files (eq file-name (car e-files)))
     657    (unless (and e-files (eq source (car e-files)))
    646658      ;; Never previously defined in this file
    647659      (when (and (car e-files)            ; don't warn if last defined interactively
     
    651663              (definition-type-name dt)
    652664              name
    653               (car e-files)
    654               (or file-name "{No file}")))
    655       (setq e-files (cons file-name e-files)))
     665              (source-note-filename (car e-files))
     666              (or (source-note-filename source) "{No file}")))
     667      (setq e-files (cons source e-files)))
    656668    (let ((entry (make-def-source-entry key dt name e-files)))
    657669      (if e-loc
     
    661673    name))
    662674
     675;;; avoid hanging onto beezillions of pathnames
     676(defparameter *last-back-translated-name* (cons nil nil))
     677
    663678;; Define the real record-source-file, which will be the last defn handled by the
    664679;; bootstrapping record-source-file, so convert all queued up data right afterwards.
    665 (progn
    666 
    667 (defun record-source-file (name def-type &optional (file-name *loading-file-source-file*))
    668   (when *record-source-file*
     680(when (BOUNDP '*LOADING-TOPLEVEL-LOCATION*) ;; #-BOOTSTRAPPED
     681
     682(defun record-source-file (name def-type &optional (source (or *loading-toplevel-location*
     683                                                               *loading-file-source-file*)))
     684  (when (and source *record-source-file*)
    669685    (with-lock-grabbed (*source-files-lock*)
    670       (when (and file-name (physical-pathname-p file-name))
    671         (setq file-name (namestring (back-translate-pathname file-name)))
    672         (cond ((equalp file-name *last-back-translated-name*)
    673                (setq file-name *last-back-translated-name*))
    674               (t (setq *last-back-translated-name* file-name))))
     686      (let ((file-name (source-note-filename source)))
     687        (unless (equalp file-name (car *last-back-translated-name*))
     688          (setf (car *last-back-translated-name*) file-name)
     689          (setf (cdr *last-back-translated-name*)
     690                (if (physical-pathname-p file-name)
     691                  (namestring (back-translate-pathname file-name))
     692                  file-name)))
     693        (setq file-name (cdr *last-back-translated-name*))
     694        (if (source-note-p source)
     695          (setf (source-note-filename source) file-name)
     696          (setq source file-name)))
    675697      (when (eq def-type 't) (report-bad-arg def-type '(not (eql t))))
    676698      (record-definition-source (definition-type-instance def-type
    677699                                    :if-does-not-exist :create)
    678700                                name
    679                                 file-name))))
     701                                source))))
    680702
    681703;; Collect level-0 source file info
     
    683705  (let ((f (get s 'bootstrapping-source-files)))
    684706    (when f
    685       (setf (gethash s %source-files%) f)
     707      (if (consp f)
     708        (destructuring-bind ((type . source)) f
     709          (when source (record-source-file s type source)))
     710        (record-source-file s 'function f))
    686711      (remprop s 'bootstrapping-source-files))))
     712
    687713;; Collect level-1 source file info
    688714(when (consp *record-source-file*)
  • trunk/source/library/leaks.lisp

    r11180 r11373  
    154154      (loop for key being the hash-keys of found
    155155            when (or (and (consp key) (gethash key cons-refs))
    156                      (and (consp key) (eq (car key) 'ccl::function-source-note))
     156                     (and (consp key) (eq (car key) 'ccl::%function-source-note))
    157157                     (typep key 'ccl::hash-table-vector)
    158158                     (when (and key
  • trunk/source/xdump/xfasload.lisp

    r11135 r11373  
    15981598
    15991599(defun xload-record-source-file (symaddr indicator)
    1600   ;; need to do something with *xload-loading-toplevel-location*
    16011600  (when *xload-record-source-file-p*
    16021601    (when (or (eq indicator 'function)
    16031602              (eq indicator 'variable))
    16041603      (let* ((keyaddr (xload-copy-symbol 'bootstrapping-source-files))
    1605              (pathaddr (or *xload-loading-file-source-file*
     1604             (pathaddr (or *xload-loading-toplevel-location*
     1605                           *xload-loading-file-source-file*
    16061606                           (if *loading-file-source-file*
    16071607                             (setq *xload-loading-file-source-file* (xload-save-string *loading-file-source-file*))))))
Note: See TracChangeset for help on using the changeset viewer.