[Openmcl-cvs-notifications] r11373 - in /trunk/source: cocoa-ide/ compiler/ compiler/PPC/ compiler/X86/ level-0/ level-1/ lib/ library/ xdump/
gz at clozure.com
gz at clozure.com
Sun Nov 16 10:35:28 EST 2008
Author: gz
Date: Sun Nov 16 10:35:28 2008
New Revision: 11373
Log:
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 a=
ccessors CCL:SOURCE-NOTE-FILENAME, CCL:SOURCE-NOTE-START-POS, CCL:SOURCE-NO=
TE-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 reco=
rding was on at read-time. If the original file is still available, you ca=
n force missing source text to be read from the file at runtime via CCL:ENS=
URE-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 v=
ia CCL:FUNCTION-SOURCE-NOTE.
The recording behavior is controlled by the new variable CCL:*SAVE-SOURCE-L=
OCATIONS*:
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, f=
or 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 obj=
ects and defintions (the latter only if *record-source-file* is true). Thi=
s is the default.
PC to source mapping is controlled by the new variable CCL:*RECORD-PC-MAPPI=
NG*. If true (the default), functions store a compressed table mapping pc =
offsets to corresponding source locations. This can be retrieved by (CCL:F=
IND-SOURCE-NOTE-AT-PC function pc) which returns a source-note for the sour=
ce 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 function=
s that deal with filenames only. The plan is to make Slime, and our IDE, u=
se this eventually.
Known bug: most of this only works through the file compiler. Still need t=
o make it work with loading from source (not hard, just haven't gotten to i=
t yet).
This checkin incidentally includes bits and pieces of support for code cove=
rage, 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
Modified:
trunk/source/cocoa-ide/cocoa-listener.lisp
trunk/source/compiler/PPC/ppc-disassemble.lisp
trunk/source/compiler/PPC/ppc2.lisp
trunk/source/compiler/X86/x86-disassemble.lisp
trunk/source/compiler/X86/x862.lisp
trunk/source/compiler/lambda-list.lisp
trunk/source/compiler/nx-basic.lisp
trunk/source/compiler/nx.lisp
trunk/source/compiler/nx0.lisp
trunk/source/compiler/nx1.lisp
trunk/source/level-0/l0-init.lisp
trunk/source/level-0/nfasload.lisp
trunk/source/level-1/l1-boot-1.lisp
trunk/source/level-1/l1-boot-2.lisp
trunk/source/level-1/l1-files.lisp
trunk/source/level-1/l1-init.lisp
trunk/source/level-1/l1-reader.lisp
trunk/source/level-1/l1-readloop-lds.lisp
trunk/source/level-1/l1-utils.lisp
trunk/source/level-1/level-1.lisp
trunk/source/lib/ccl-export-syms.lisp
trunk/source/lib/macros.lisp
trunk/source/lib/misc.lisp
trunk/source/lib/nfcomp.lisp
trunk/source/lib/source-files.lisp
trunk/source/library/leaks.lisp
trunk/source/xdump/xfasload.lisp
Modified: trunk/source/cocoa-ide/cocoa-listener.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/cocoa-ide/cocoa-listener.lisp (original)
+++ trunk/source/cocoa-ide/cocoa-listener.lisp Sun Nov 16 10:35:28 2008
@@ -88,7 +88,8 @@
(setq cur-string val cur-string-pos 0))
(t
(destructuring-bind (string package-name pathname) val
- (let ((env (cons '(*loading-file-source-file*) (list pa=
thname))))
+ (let ((env (cons '(*loading-file-source-file* *loading-=
toplevel-location*)
+ (list pathname nil))))
(when package-name
(push '*package* (car env))
(push (ccl::pkg-arg package-name) (cdr env)))
Modified: trunk/source/compiler/PPC/ppc-disassemble.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/compiler/PPC/ppc-disassemble.lisp (original)
+++ trunk/source/compiler/PPC/ppc-disassemble.lisp Sun Nov 16 10:35:28 2008
@@ -364,14 +364,35 @@
(dolist (op parsed-operands (format stream ")"))
(format stream (if (and (consp op) (eq (car op) 'quote)) " ~s" " ~a"=
) op))))
=
-(defun print-ppc-instructions (stream instructions &optional for-lap backe=
nd)
+(defun print-ppc-instructions (stream function instructions &optional for-=
lap backend)
(declare (ignorable backend))
- (let* ((tab (if for-lap 6 2)))
+ (let* ((tab (if for-lap 6 2))
+ (previous-source-note nil))
+
+ (let ((source-note (function-source-note function)))
+ (when source-note
+ (format t ";; Source: ~S:~D-~D"
+ (source-note-filename source-note)
+ (source-note-start-pos source-note)
+ (source-note-end-pos source-note))
+ ;; Fetch text from file if don't already have it
+ (ensure-source-note-text source-note)))
+
(when for-lap =
(let* ((lap-function-name (car for-lap)))
(format stream "~&(~S ~S ~& (~S (~s) ~& (~s ~s ()" =
'nfunction lap-function-name 'lambda '&lap 'ppc-lap-functi=
on lap-function-name)))
+
(do-dll-nodes (i instructions)
+ (let ((source-note (find-source-note-at-pc function (instruction-ele=
ment-address i))))
+ (unless (eql (source-note-file-range source-note)
+ (source-note-file-range previous-source-note))
+ (setf previous-source-note source-note)
+ (let* ((source-text (source-note-text source-note))
+ (text (if source-text
+ (string-sans-most-whitespace source-text 100)
+ "#<no source text>")))
+ (format stream "~&~%;;; ~A" text))))
(etypecase i
(lap-label (format stream "~&~a " (lap-label-name i)))
(lap-instruction =
@@ -383,7 +404,8 @@
(let* ((backend (if target (find-backend target) *host-backend*))
(prefix-length (length (arch::target-code-vector-prefix (backend-=
target-arch backend))))
(*ppc-disassembly-backend* backend))
- (print-ppc-instructions stream (function-to-dll-header fn-vector prefi=
x-length)
+ (print-ppc-instructions stream fn-vector
+ (function-to-dll-header fn-vector prefix-lengt=
h)
(if for-lap (list (uvref fn-vector (- (uvsize =
fn-vector) 2)))))
(values)))
=
Modified: trunk/source/compiler/PPC/ppc2.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/compiler/PPC/ppc2.lisp (original)
+++ trunk/source/compiler/PPC/ppc2.lisp Sun Nov 16 10:35:28 2008
@@ -13,6 +13,8 @@
;;;
;;; The LLGPL is also available online at
;;; http://opensource.franz.com/preamble.html
+
+(in-package "CCL")
=
(eval-when (:compile-toplevel :execute)
(require "NXENV")
@@ -411,7 +413,6 @@
(*backend-fp-temps* ppc-temp-fp-regs)
(*available-backend-fp-temps* ppc-temp-fp-regs)
(bits 0)
- (debug-info nil)
(*logical-register-counter* -1)
(*backend-all-lregs* ())
(*ppc2-popj-labels* nil)
@@ -453,7 +454,7 @@
(with-dll-node-freelist (vinsns *vinsn-freelist*)
(unwind-protect
(progn
- (setq bits (ppc2-form vinsns (make-wired-lreg *ppc2-result-=
reg*) $backend-return (afunc-acode afunc)))
+ (setq bits (ppc2-toplevel-form vinsns (make-wired-lreg *ppc=
2-result-reg*) $backend-return (afunc-acode afunc)))
(dotimes (i (length *backend-immediates*))
(let ((imm (aref *backend-immediates* i)))
(when (ppc2-symbol-locative-p imm) (aset *backend-immed=
iates* i (car imm)))))
@@ -465,7 +466,8 @@
=
=
(with-dll-node-freelist (*lap-instructions* *lap-instructio=
n-freelist*)
- (let* ((*lap-labels* nil))
+ (let* ((*lap-labels* nil)
+ debug-info)
(ppc2-expand-vinsns vinsns) =
(if (logbitp $fbitnonnullenv (the fixnum (afunc-bits af=
unc)))
(setq bits (+ bits (ash 1 $lfbits-nonnullenv-bit))))
@@ -474,7 +476,7 @@
(setq debug-info (list* 'function-lambda-expression l=
ambda-form debug-info)))
(when *ppc2-recorded-symbols*
(setq debug-info (list* 'function-symbol-map *ppc2-re=
corded-symbols* debug-info)))
- (when *ppc2-emitted-source-notes*
+ (when (and (getf debug-info '%function-source-note) *pp=
c2-emitted-source-notes*)
(setq debug-info (list* 'pc-source-map *ppc2-emitted-=
source-notes* debug-info)))
(when debug-info
(setq bits (logior (ash 1 $lfbits-info-bit) bits))
@@ -565,7 +567,7 @@
(setf (%svref v i) ref-fun)))))))))
=
(defun ppc2-generate-pc-source-map (debug-info)
- (let* ((definition-source-note (getf debug-info 'function-source-note))
+ (let* ((definition-source-note (getf debug-info '%function-source-note))
(emitted-source-notes (getf debug-info 'pc-source-map))
(def-start (source-note-start-pos definition-source-note))
(n (length emitted-source-notes))
@@ -1056,23 +1058,59 @@
n))
=
=
-(defun ppc2-form (seg vreg xfer form &aux (note (acode-source-note form)))
- (flet ((main (seg vreg xfer form)
- (if (nx-null form)
- (ppc2-nil seg vreg xfer)
- (if (nx-t form)
- (ppc2-t seg vreg xfer)
- (let* ((op nil)
- (fn nil))
- (if (and (consp form)
- (setq fn (svref *ppc2-specials* (%ilogand #.oper=
ator-id-mask (setq op (acode-operator form))))))
- (if (and (null vreg)
- (%ilogbitp operator-acode-subforms-bit op)
- (%ilogbitp operator-assignment-free-bit op))
- (dolist (f (%cdr form) (ppc2-branch seg xfer nil))
- (ppc2-form seg nil nil f ))
- (apply fn seg vreg xfer (%cdr form)))
- (compiler-bug "ppc2-form ? ~s" form)))))))
+(defun ppc2-acode-operator-function (form)
+ (or (and (acode-p form)
+ (svref *ppc2-specials* (%ilogand #.operator-id-mask (acode-oper=
ator form))))
+ (compiler-bug "ppc2-form ? ~s" form)))
+
+(defmacro with-note ((form-var seg-var &rest other-vars) &body body)
+ (let* ((note (gensym "NOTE"))
+ (code-note (gensym "CODE-NOTE"))
+ (source-note (gensym "SOURCE-NOTE"))
+ (start (gensym "START"))
+ (end (gensym "END"))
+ (with-note-body (gensym "WITH-NOTE-BODY")))
+ `(flet ((,with-note-body (,form-var ,seg-var , at other-vars) , at body))
+ (let ((,note (acode-note ,form-var)))
+ (if ,note
+ (let* ((,code-note (and (code-note-p ,note) ,note))
+ (,source-note (if ,code-note
+ (code-note-source-note ,note)
+ ,note))
+ (,start (and ,source-note
+ (ppc2-emit-note ,seg-var :source-location-b=
egin ,source-note))))
+ (prog2
+ (when ,code-note
+ (with-ppc-local-vinsn-macros (,seg-var)
+ (ppc2-store-immediate ,seg-var ,code-note ppc::temp0)
+ (! misc-set-c-node ($ ppc::rzero) ($ ppc::temp0) 1)))
+ (,with-note-body ,form-var ,seg-var , at other-vars)
+ (when ,source-note
+ (let ((,end (ppc2-emit-note ,seg-var :source-location-end=
)))
+ (setf (vinsn-note-peer ,start) ,end
+ (vinsn-note-peer ,end) ,start)
+ (push ,start *ppc2-emitted-source-notes*)))))
+ (,with-note-body ,form-var ,seg-var , at other-vars))))))
+
+(defun ppc2-toplevel-form (seg vreg xfer form)
+ (let* ((code-note (acode-note form))
+ (args (if code-note `(,@(%cdr form) ,code-note) (%cdr form))))
+ (apply (ppc2-acode-operator-function form) seg vreg xfer args)))
+
+(defun ppc2-form (seg vreg xfer form)
+ (with-note (form seg vreg xfer)
+ (if (nx-null form)
+ (ppc2-nil seg vreg xfer)
+ (if (nx-t form)
+ (ppc2-t seg vreg xfer)
+ (let ((fn (ppc2-acode-operator-function form))
+ (op (acode-operator form)))
+ (if (and (null vreg)
+ (%ilogbitp operator-acode-subforms-bit op)
+ (%ilogbitp operator-assignment-free-bit op))
+ (dolist (f (%cdr form) (ppc2-branch seg xfer nil))
+ (ppc2-form seg nil nil f ))
+ (apply fn seg vreg xfer (%cdr form)))))))
(if note
(let* ((start (ppc2-emit-note seg :source-location-begin note))
(bits (main seg vreg xfer form))
@@ -1086,16 +1124,14 @@
;;; dest is a float reg - form is acode
(defun ppc2-form-float (seg freg xfer form)
(declare (ignore xfer))
- (when (or (nx-null form)(nx-t form))(compiler-bug "ppc2-form to freg ~s"=
form))
- (when (and (=3D (get-regspec-mode freg) hard-reg-class-fpr-mode-double)
- (ppc2-form-typep form 'double-float))
- ; kind of screwy - encoding the source type in the dest register spec
- (set-node-regspec-type-modes freg hard-reg-class-fpr-type-double))
- (let* ((fn nil))
- (if (and (consp form)
- (setq fn (svref *ppc2-specials* (%ilogand #.operator-id-mask =
(acode-operator form))))) =
- (apply fn seg freg nil (%cdr form))
- (compiler-bug "ppc2-form ? ~s" form))))
+ (with-note (form seg freg)
+ (when (or (nx-null form)(nx-t form))(compiler-bug "ppc2-form to freg ~=
s" form))
+ (when (and (=3D (get-regspec-mode freg) hard-reg-class-fpr-mode-double)
+ (ppc2-form-typep form 'double-float))
+ ; kind of screwy - encoding the so=
urce type in the dest register spec
+ (set-node-regspec-type-modes freg hard-reg-class-fpr-type-double))
+ (let* ((fn (ppc2-acode-operator-function form)))
+ (apply fn seg freg nil (%cdr form)))))
=
=
=
@@ -2218,6 +2254,14 @@
(when (and vreg val-reg) (<- val-reg))
(^))))
=
+
+(defun ppc2-code-coverage-entry (seg note)
+ (let* ((afunc *ppc2-cur-afunc*))
+ (setf (afunc-bits afunc) (%ilogior (afunc-bits afunc) (ash 1 $fbitccov=
erage)))
+ (with-x86-local-vinsn-macros (seg)
+ (let* ((ccreg ($ ppc::atemp0)))
+ (ppc2-store-immediate seg note ccreg)
+ (! misc-set-c-node ($ ppc::rzero) ccreg 1)))))
=
(defun ppc2-vset (seg vreg xfer type-keyword vector index value safe)
(with-ppc-local-vinsn-macros (seg)
@@ -3686,104 +3730,105 @@
(dolist (var vars)
(ppc2-seq-bind-var seg var (pop initforms))))
=
-(defun ppc2-dynamic-extent-form (seg curstack val)
- (when (acode-p val)
- (with-ppc-local-vinsn-macros (seg)
- (let* ((op (acode-operator val)))
- (cond ((eq op (%nx1-operator list))
- (let* ((*ppc2-vstack* *ppc2-vstack*)
- (*ppc2-top-vstack-lcell* *ppc2-top-vstack-lcell*))
- (ppc2-set-nargs seg (ppc2-formlist seg (%cadr val) nil))
- (ppc2-open-undo $undostkblk curstack)
- (! stack-cons-list))
- (setq val ppc::arg_z))
- ((eq op (%nx1-operator list*))
- (let* ((arglist (%cadr val))) =
- (let* ((*ppc2-vstack* *ppc2-vstack*)
- (*ppc2-top-vstack-lcell* *ppc2-top-vstack-lcell*))
- (ppc2-arglist seg arglist))
- (when (car arglist)
- (ppc2-set-nargs seg (length (%car arglist)))
- (! stack-cons-list*)
- (ppc2-open-undo $undostkblk curstack))
- (setq val ppc::arg_z)))
- ((eq op (%nx1-operator multiple-value-list))
- (ppc2-multiple-value-body seg (%cadr val))
- (ppc2-open-undo $undostkblk curstack)
- (! stack-cons-list)
- (setq val ppc::arg_z))
- ((eq op (%nx1-operator cons))
- (let* ((y ($ ppc::arg_y))
- (z ($ ppc::arg_z))
- (result ($ ppc::arg_z)))
- (ppc2-two-targeted-reg-forms seg (%cadr val) y (%caddr va=
l) z)
- (ppc2-open-undo $undostkblk )
- (! make-tsp-cons result y z) =
- (setq val result)))
- ((eq op (%nx1-operator %consmacptr%))
- (with-imm-target () (address :address)
- (ppc2-one-targeted-reg-form seg val address)
- (with-node-temps () (node)
- (! macptr->stack node address)
- (ppc2-open-undo $undostkblk)
- (setq val node))))
- ((eq op (%nx1-operator %new-ptr))
- (let* ((clear-form (caddr val))
- (cval (nx-constant-form-p clear-form)))
- (if cval
- (progn =
- (ppc2-one-targeted-reg-form seg (%cadr val) ($ ppc::a=
rg_z))
- (if (nx-null cval)
- (! make-stack-block)
- (! make-stack-block0)))
- (with-crf-target () crf
- (let ((stack-block-0-label (backend-get-next-label))
- (done-label (backend-get-next-label))
- (rval ($ ppc::arg_z))
- (rclear ($ ppc::arg_y)))
- (ppc2-two-targeted-reg-forms seg (%cadr val) rval c=
lear-form rclear)
- (! compare-to-nil crf rclear)
- (! cbranch-false (aref *backend-labels* stack-block=
-0-label) crf ppc::ppc-eq-bit)
- (! make-stack-block)
- (-> done-label)
- (@ stack-block-0-label)
- (! make-stack-block0)
- (@ done-label)))))
- (ppc2-open-undo $undostkblk)
- (setq val ($ ppc::arg_z)))
- ((eq op (%nx1-operator make-list))
- (ppc2-two-targeted-reg-forms seg (%cadr val) ($ ppc::arg_y)=
(%caddr val) ($ ppc::arg_z))
- (ppc2-open-undo $undostkblk curstack)
- (! make-stack-list)
- (setq val ppc::arg_z)) =
- ((eq op (%nx1-operator vector))
- (let* ((*ppc2-vstack* *ppc2-vstack*)
- (*ppc2-top-vstack-lcell* *ppc2-top-vstack-lcell*))
- (ppc2-set-nargs seg (ppc2-formlist seg (%cadr val) nil))
- (! make-stack-vector))
- (ppc2-open-undo $undostkblk)
- (setq val ppc::arg_z))
- ((eq op (%nx1-operator %gvector))
- (let* ((*ppc2-vstack* *ppc2-vstack*)
- (*ppc2-top-vstack-lcell* *ppc2-top-vstack-lcell*)
- (arglist (%cadr val)))
- (ppc2-set-nargs seg (ppc2-formlist seg (append (car argli=
st) (reverse (cadr arglist))) nil))
- (! make-stack-gvector))
- (ppc2-open-undo $undostkblk)
- (setq val ppc::arg_z)) =
- ((eq op (%nx1-operator closed-function)) =
- (setq val (ppc2-make-closure seg (cadr val) t))) ; can't er=
ror
- ((eq op (%nx1-operator %make-uvector))
- (destructuring-bind (element-count subtag &optional (init 0=
init-p)) (%cdr val)
- (if init-p
- (progn
- (ppc2-three-targeted-reg-forms seg element-count ($ p=
pc::arg_x) subtag ($ ppc::arg_y) init ($ ppc::arg_z))
- (! stack-misc-alloc-init))
- (progn
- (ppc2-two-targeted-reg-forms seg element-count ($ ppc=
::arg_y) subtag ($ ppc::arg_z))
- (! stack-misc-alloc)))
- (ppc2-open-undo $undostkblk)
- (setq val ($ ppc::arg_z))))))))
+(defun ppc2-dynamic-extent-form (seg curstack val &aux (form val))
+ (when (acode-p form)
+ (with-note (form seg curstack) ; note this rebinds form/seg/curstack s=
o can't setq
+ (with-ppc-local-vinsn-macros (seg)
+ (let* ((op (acode-operator form)))
+ (cond ((eq op (%nx1-operator list))
+ (let* ((*ppc2-vstack* *ppc2-vstack*)
+ (*ppc2-top-vstack-lcell* *ppc2-top-vstack-lcell*))
+ (ppc2-set-nargs seg (ppc2-formlist seg (%cadr form) nil))
+ (ppc2-open-undo $undostkblk curstack)
+ (! stack-cons-list))
+ (setq val ppc::arg_z))
+ ((eq op (%nx1-operator list*))
+ (let* ((arglist (%cadr form))) =
+ (let* ((*ppc2-vstack* *ppc2-vstack*)
+ (*ppc2-top-vstack-lcell* *ppc2-top-vstack-lcell*))
+ (ppc2-arglist seg arglist))
+ (when (car arglist)
+ (ppc2-set-nargs seg (length (%car arglist)))
+ (! stack-cons-list*)
+ (ppc2-open-undo $undostkblk curstack))
+ (setq val ppc::arg_z)))
+ ((eq op (%nx1-operator multiple-value-list))
+ (ppc2-multiple-value-body seg (%cadr form))
+ (ppc2-open-undo $undostkblk curstack)
+ (! stack-cons-list)
+ (setq val ppc::arg_z))
+ ((eq op (%nx1-operator cons))
+ (let* ((y ($ ppc::arg_y))
+ (z ($ ppc::arg_z))
+ (result ($ ppc::arg_z)))
+ (ppc2-two-targeted-reg-forms seg (%cadr form) y (%caddr form) z)
+ (ppc2-open-undo $undostkblk )
+ (! make-tsp-cons result y z) =
+ (setq val result)))
+ ((eq op (%nx1-operator %consmacptr%))
+ (with-imm-target () (address :address)
+ (ppc2-one-targeted-reg-form seg form address)
+ (with-node-temps () (node)
+ (! macptr->stack node address)
+ (ppc2-open-undo $undostkblk)
+ (setq val node))))
+ ((eq op (%nx1-operator %new-ptr))
+ (let* ((clear-form (caddr form))
+ (cval (nx-constant-form-p clear-form)))
+ (if cval
+ (progn =
+ (ppc2-one-targeted-reg-form seg (%cadr form) ($ ppc::arg_z))
+ (if (nx-null cval)
+ (! make-stack-block)
+ (! make-stack-block0)))
+ (with-crf-target () crf
+ (let ((stack-block-0-label (backend-get-next-label))
+ (done-label (backend-get-next-label))
+ (rval ($ ppc::arg_z))
+ (rclear ($ ppc::arg_y)))
+ (ppc2-two-targeted-reg-forms seg (%cadr form) rval clear-form rclear)
+ (! compare-to-nil crf rclear)
+ (! cbranch-false (aref *backend-labels* stack-block-0-label) crf ppc=
::ppc-eq-bit)
+ (! make-stack-block)
+ (-> done-label)
+ (@ stack-block-0-label)
+ (! make-stack-block0)
+ (@ done-label)))))
+ (ppc2-open-undo $undostkblk)
+ (setq val ($ ppc::arg_z)))
+ ((eq op (%nx1-operator make-list))
+ (ppc2-two-targeted-reg-forms seg (%cadr form) ($ ppc::arg_y) (%caddr fo=
rm) ($ ppc::arg_z))
+ (ppc2-open-undo $undostkblk curstack)
+ (! make-stack-list)
+ (setq val ppc::arg_z)) =
+ ((eq op (%nx1-operator vector))
+ (let* ((*ppc2-vstack* *ppc2-vstack*)
+ (*ppc2-top-vstack-lcell* *ppc2-top-vstack-lcell*))
+ (ppc2-set-nargs seg (ppc2-formlist seg (%cadr form) nil))
+ (! make-stack-vector))
+ (ppc2-open-undo $undostkblk)
+ (setq val ppc::arg_z))
+ ((eq op (%nx1-operator %gvector))
+ (let* ((*ppc2-vstack* *ppc2-vstack*)
+ (*ppc2-top-vstack-lcell* *ppc2-top-vstack-lcell*)
+ (arglist (%cadr form)))
+ (ppc2-set-nargs seg (ppc2-formlist seg (append (car arglist) (reverse=
(cadr arglist))) nil))
+ (! make-stack-gvector))
+ (ppc2-open-undo $undostkblk)
+ (setq val ppc::arg_z)) =
+ ((eq op (%nx1-operator closed-function)) =
+ (setq val (ppc2-make-closure seg (cadr form) t))) ; can't error
+ ((eq op (%nx1-operator %make-uvector))
+ (destructuring-bind (element-count subtag &optional (init 0 init-p)) (%=
cdr form)
+ (if init-p
+ (progn
+ (ppc2-three-targeted-reg-forms seg element-count ($ ppc::arg_x) subtag=
($ ppc::arg_y) init ($ ppc::arg_z))
+ (! stack-misc-alloc-init))
+ (progn
+ (ppc2-two-targeted-reg-forms seg element-count ($ ppc::arg_y) subtag =
($ ppc::arg_z))
+ (! stack-misc-alloc)))
+ (ppc2-open-undo $undostkblk)
+ (setq val ($ ppc::arg_z)))))))))
val)
=
(defun ppc2-addrspec-to-reg (seg addrspec reg)
@@ -5296,7 +5341,7 @@
(svset *ppc2-specials* (%ilogand #.operator-id-mask (%nx1-opera=
tor ,locative)) ,fun))))))
)
=
-(defppc2 ppc2-lambda lambda-list (seg vreg xfer req opt rest keys auxen bo=
dy p2decls)
+(defppc2 ppc2-lambda lambda-list (seg vreg xfer req opt rest keys auxen bo=
dy p2decls &optional code-note)
(with-ppc-local-vinsn-macros (seg vreg xfer)
(let* ((stack-consed-rest nil)
(lexprp (if (consp rest) (progn (setq rest (car rest)) t)))
@@ -5331,6 +5376,10 @@
(multiple-value-setq (pregs reglocatives) =
(ppc2-allocate-global-registers *ppc2-fcells* *ppc2-vcells* (afu=
nc-all-vars afunc) no-regs))
(@ (backend-get-next-label)) ; generic self-reference label, shoul=
d be label #1
+ (when keys ;; Ensure keyvect is the first immediate
+ (backend-immediate-index (%cadr (%cdddr keys))))
+ (when code-note
+ (ppc2-code-coverage-entry seg code-note))
(unless next-method-p
(setq method-var nil))
=
Modified: trunk/source/compiler/X86/x86-disassemble.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/compiler/X86/x86-disassemble.lisp (original)
+++ trunk/source/compiler/X86/x86-disassemble.lisp Sun Nov 16 10:35:28 2008
@@ -2722,16 +2722,28 @@
`(* ,usual)
usual)))
=
-
-(defun x86-print-disassembled-instruction (ds instruction seq)
+(defvar *previous-source-note*)
+
+(defun x86-print-disassembled-instruction (ds instruction seq function)
(let* ((addr (x86-di-address instruction))
- (entry (x86-ds-entry-point ds)))
+ (entry (x86-ds-entry-point ds))
+ (pc (- addr entry)))
+ (let ((source-note (find-source-note-at-pc function pc)))
+ (unless (eql (source-note-file-range source-note)
+ (source-note-file-range *previous-source-note*))
+ (setf *previous-source-note* source-note)
+ (let* ((source-text (source-note-text source-note))
+ (text (if source-text
+ (string-sans-most-whitespace source-text 100)
+ "#<no source text>")))
+ (format t "~&~%;;; ~A" text))))
(when (x86-di-labeled instruction)
- (format t "~&L~d~&" (- addr entry))
+ (format t "~&L~d~%" pc)
(setq seq 0))
+ (format t "~& [~D]~8T" pc)
(dolist (p (x86-di-prefixes instruction))
(format t "~& (~a)~%" p))
- (format t "~& (~a" (x86-di-mnemonic instruction))
+ (format t " (~a" (x86-di-mnemonic instruction))
(let* ((op0 (x86-di-op0 instruction))
(op1 (x86-di-op1 instruction))
(op2 (x86-di-op2 instruction)))
@@ -2742,14 +2754,24 @@
(when op2
(format t " ~a" (unparse-x86-lap-operand op2 ds))))))
(format t ")")
- (unless (zerop seq) ;(when (oddp seq)
- (format t "~50t;[~d]" (- addr entry)))
(format t "~%")
(1+ seq)))
=
-
-(defun x8664-disassemble-xfunction (xfunction &key (symbolic-names
- x8664::*x8664-sym=
bolic-register-names*) (collect-function #'x86-print-disassembled-instructi=
on))
+(defun x86-print-disassembled-function-header (function xfunction)
+ (declare (ignore xfunction))
+ (let ((source-note (function-source-note function)))
+ (when source-note
+ (format t ";; Source: ~S:~D-~D"
+ (source-note-filename source-note)
+ (source-note-start-pos source-note)
+ (source-note-end-pos source-note))
+ ;; Fetch source from file if don't already have it.
+ (ensure-source-note-text source-note))))
+
+(defun x8664-disassemble-xfunction (function xfunction
+ &key (symbolic-names x8664::*x8664-sym=
bolic-register-names*)
+ (collect-function #'x86-print-dis=
assembled-instruction)
+ (header-function #'x86-print-disa=
ssembled-function-header))
(check-type xfunction xfunction)
(check-type (uvref xfunction 0) (simple-array (unsigned-byte 8) (*)))
(let* ((ds (make-x86-disassembly-state
@@ -2767,13 +2789,23 @@
(let* ((lab (pop (x86-ds-pending-labels ds))))
(or (x86-dis-find-label lab blocks)
(x86-disassemble-new-block ds lab))))
- (let* ((seq 0))
+ (when (and blocks (let ((something-to-disassemble nil))
+ (do-dll-nodes (block blocks)
+ (do-dll-nodes (instruction (x86-dis-block-instru=
ctions block))
+ (setf something-to-disassemble t)))
+ something-to-disassemble))
+ (funcall header-function function xfunction))
+ (let* ((seq 0)
+ (*previous-source-note* nil))
+ (declare (special *previous-source-note*))
(do-dll-nodes (block blocks)
(do-dll-nodes (instruction (x86-dis-block-instructions block))
- (setq seq (funcall collect-function ds instruction seq)))))))
-
-(defun x8632-disassemble-xfunction (xfunction &key (symbolic-names
- x8632::*x8632-sym=
bolic-register-names*) (collect-function #'x86-print-disassembled-instructi=
on))
+ (setq seq (funcall collect-function ds instruction seq function)=
))))))
+
+(defun x8632-disassemble-xfunction (function xfunction
+ &key (symbolic-names x8632::*x8632-sym=
bolic-register-names*)
+ (collect-function #'x86-print-dis=
assembled-instruction)
+ (header-function #'x86-print-disa=
ssembled-function-header))
(check-type xfunction xfunction)
(check-type (uvref xfunction 0) (simple-array (unsigned-byte 8) (*)))
(let* ((ds (make-x86-disassembly-state
@@ -2791,14 +2823,23 @@
(let* ((lab (pop (x86-ds-pending-labels ds))))
(or (x86-dis-find-label lab blocks)
(x86-disassemble-new-block ds lab))))
- (let* ((seq 0))
+ (when (and blocks (let ((something-to-disassemble nil))
+ (do-dll-nodes (block blocks)
+ (do-dll-nodes (instruction (x86-dis-block-instru=
ctions block))
+ (setf something-to-disassemble t)))
+ something-to-disassemble))
+ (funcall header-function function xfunction))
+ (let* ((seq 0)
+ (*previous-source-note* nil))
+ (declare (special *previous-source-note*))
(do-dll-nodes (block blocks)
(do-dll-nodes (instruction (x86-dis-block-instructions block))
- (setq seq (funcall collect-function ds instruction seq)))))))
+ (setq seq (funcall collect-function ds instruction seq function)=
))))))
=
#+x8664-target
(defun x8664-xdisassemble (function
- &optional (collect-function #'x86-print-disasse=
mbled-instruction))
+ &optional (collect-function #'x86-print-disasse=
mbled-instruction)
+ (header-function #'x86-print-disassem=
bled-function-header))
(let* ((fv (%function-to-function-vector function))
(function-size-in-words (uvsize fv))
(code-words (%function-code-words function))
@@ -2813,13 +2854,16 @@
(do* ((k code-words (1+ k))
(j 1 (1+ j)))
((=3D k function-size-in-words)
- (x8664-disassemble-xfunction xfunction
- :collect-function collect-function))
+ (x8664-disassemble-xfunction function xfunction
+ :collect-function collect-function
+ :header-function header-function))
(declare (fixnum j k))
(setf (uvref xfunction j) (uvref fv k)))))
=
#+x8632-target
-(defun x8632-xdisassemble (function &optional (collect-function #'x86-prin=
t-disassembled-instruction ))
+(defun x8632-xdisassemble (function
+ &optional (collect-function #'x86-print-disasse=
mbled-instruction)
+ (header-function #'x86-print-disassem=
bled-function-header))
(let* ((fv (function-to-function-vector function))
(function-size-in-words (uvsize fv))
(code-words (%function-code-words function))
@@ -2834,7 +2878,9 @@
(do* ((k code-words (1+ k))
(j 1 (1+ j)))
((=3D k function-size-in-words)
- (x8632-disassemble-xfunction xfunction :collect-function collect=
-function))
+ (x8632-disassemble-xfunction function xfunction
+ :collect-function collect-function
+ :header-function header-function))
(declare (fixnum j k))
(setf (uvref xfunction j) (uvref fv k)))))
=
@@ -2842,7 +2888,8 @@
(collect ((instructions))
(#+x8632-target x8632-xdisassemble #+x8664-target x8664-xdisassemble
function
- #'(lambda (ds instruction seq)
+ #'(lambda (ds instruction seq function)
+ (declare (ignore function))
(collect ((insn))
(let* ((addr (x86-di-address instruction))
(entry (x86-ds-entry-point ds))
Modified: trunk/source/compiler/X86/x862.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/compiler/X86/x862.lisp (original)
+++ trunk/source/compiler/X86/x862.lisp Sun Nov 16 10:35:28 2008
@@ -607,7 +607,8 @@
(with-dll-node-freelist (vinsns *vinsn-freelist*)
(unwind-protect
(progn
- (setq bits (x862-form vinsns (make-wired-lreg *x862-result-=
reg*) $backend-return (afunc-acode afunc)))
+ (setq bits (x862-toplevel-form vinsns (make-wired-lreg *x86=
2-result-reg*)
+ $backend-return (afunc-acode=
afunc)))
(do* ((constants *x862-constant-alist* (cdr constants)))
((null constants))
(let* ((imm (caar constants)))
@@ -691,13 +692,15 @@
(if (logbitp $fbitnonnullenv (the fixnum (afunc-bits af=
unc)))
(setq bits (+ bits (ash 1 $lfbits-nonnullenv-bit))))
(setq debug-info (afunc-lfun-info afunc))
+ (when (logbitp $fbitccoverage (the fixnum (afunc-bits a=
func)))
+ (setq bits (+ bits (ash 1 $lfbits-code-coverage-bit))=
))
(when lambda-form
(setq debug-info
(list* 'function-lambda-expression lambda-form =
debug-info)))
- (when *x862-record-symbols*
+ (when *x862-recorded-symbols*
(setq debug-info
(list* 'function-symbol-map *x862-recorded-symb=
ols* debug-info)))
- (when (and (getf debug-info 'function-source-note) *x86=
2-emitted-source-notes*)
+ (when (and (getf debug-info '%function-source-note) *x8=
62-emitted-source-notes*)
(setq debug-info ;; Compressed be=
low
(list* 'pc-source-map *x862-emitted-source-note=
s* debug-info)))
(when debug-info
@@ -796,7 +799,7 @@
(setf (%svref v i) ref-fun)))))))))
=
(defun x862-generate-pc-source-map (debug-info)
- (let* ((definition-source-note (getf debug-info 'function-source-note))
+ (let* ((definition-source-note (getf debug-info '%function-source-note))
(emitted-source-notes (getf debug-info 'pc-source-map))
(def-start (source-note-start-pos definition-source-note))
(n (length emitted-source-notes))
@@ -1317,47 +1320,73 @@
(make-vcell-memory-spec n)
n))
=
-(defun x862-form (seg vreg xfer form &aux (note (acode-source-note form)))
- (flet ((main (seg vreg xfer form)
- (if (nx-null form)
- (x862-nil seg vreg xfer)
- (if (nx-t form)
- (x862-t seg vreg xfer)
- (let* ((op nil)
- (fn nil))
- (if (and (consp form)
- (setq fn (svref *x862-specials* (%ilogand #.oper=
ator-id-mask (setq op (acode-operator form))))))
- (if (and (null vreg)
- (%ilogbitp operator-acode-subforms-bit op)
- (%ilogbitp operator-assignment-free-bit op))
- (dolist (f (%cdr form) (x862-branch seg xfer))
- (x862-form seg nil nil f ))
- (apply fn seg vreg xfer (%cdr form)))
- (compiler-bug "x862-form ? ~s" form)))))))
- (if note
- (let* ((start (x862-emit-note seg :source-location-begin note))
- (bits (main seg vreg xfer form))
- (end (x862-emit-note seg :source-location-end)))
- (setf (vinsn-note-peer start) end
- (vinsn-note-peer end) start)
- (push start *x862-emitted-source-notes*)
- bits)
- (main seg vreg xfer form))))
+
+(defun x862-acode-operator-function (form)
+ (or (and (acode-p form)
+ (svref *x862-specials* (%ilogand #.operator-id-mask (acode-oper=
ator form))))
+ (compiler-bug "x862-form ? ~s" form)))
+
+(defmacro with-note ((form-var seg-var &rest other-vars) &body body)
+ (let* ((note (gensym "NOTE"))
+ (code-note (gensym "CODE-NOTE"))
+ (source-note (gensym "SOURCE-NOTE"))
+ (start (gensym "START"))
+ (end (gensym "END"))
+ (with-note-body (gensym "WITH-NOTE-BODY")))
+ `(flet ((,with-note-body (,form-var ,seg-var , at other-vars)
+ , at body))
+ (let ((,note (acode-note ,form-var)))
+ (if ,note
+ (let* ((,code-note (and (code-note-p ,note) ,note))
+ (,source-note (if ,code-note
+ (code-note-source-note ,note)
+ ,note))
+ (,start (and ,source-note
+ (x862-emit-note ,seg-var :source-location-b=
egin ,source-note))))
+ (prog2
+ (when ,code-note
+ (with-x86-local-vinsn-macros (,seg-var)
+ (x862-store-immediate ,seg-var ,code-note *x862-temp0=
*)
+ (! misc-set-immediate-c-node 0 *x862-temp0* 1)))
+ (,with-note-body ,form-var ,seg-var , at other-vars)
+ (when ,source-note
+ (let ((,end (x862-emit-note ,seg-var :source-location-end=
)))
+ (setf (vinsn-note-peer ,start) ,end
+ (vinsn-note-peer ,end) ,start)
+ (push ,start *x862-emitted-source-notes*)))))
+ (,with-note-body ,form-var ,seg-var , at other-vars))))))
+
+(defun x862-toplevel-form (seg vreg xfer form)
+ (let* ((code-note (acode-note form))
+ (args (if code-note `(,@(%cdr form) ,code-note) (%cdr form))))
+ (apply (x862-acode-operator-function form) seg vreg xfer args)))
+
+(defun x862-form (seg vreg xfer form)
+ (with-note (form seg vreg xfer)
+ (if (nx-null form)
+ (x862-nil seg vreg xfer)
+ (if (nx-t form)
+ (x862-t seg vreg xfer)
+ (let* ((fn (x862-acode-operator-function form)) ;; also typechecks
+ (op (acode-operator form)))
+ (if (and (null vreg)
+ (%ilogbitp operator-acode-subforms-bit op)
+ (%ilogbitp operator-assignment-free-bit op))
+ (dolist (f (%cdr form) (x862-branch seg xfer))
+ (x862-form seg nil nil f ))
+ (apply fn seg vreg xfer (%cdr form))))))))
=
;;; dest is a float reg - form is acode
(defun x862-form-float (seg freg xfer form)
(declare (ignore xfer))
- (when (or (nx-null form)(nx-t form))(compiler-bug "x862-form to freg ~s"=
form))
- (when (and (=3D (get-regspec-mode freg) hard-reg-class-fpr-mode-double)
- (x862-form-typep form 'double-float))
- ;; kind of screwy - encoding the source type in the dest register spec
- (set-node-regspec-type-modes freg hard-reg-class-fpr-type-double))
- (let* ((fn nil))
- (if (and (consp form)
- (setq fn (svref *x862-specials* (%ilogand #.operator-id-mask =
(acode-operator form))))) =
- (apply fn seg freg nil (%cdr form))
- (compiler-bug "x862-form ? ~s" form))))
-
+ (with-note (form seg freg)
+ (when (or (nx-null form)(nx-t form))(compiler-bug "x862-form to freg ~=
s" form))
+ (when (and (=3D (get-regspec-mode freg) hard-reg-class-fpr-mode-double)
+ (x862-form-typep form 'double-float))
+ ;; kind of screwy - encoding the source type in the dest register sp=
ec
+ (set-node-regspec-type-modes freg hard-reg-class-fpr-type-double))
+ (let* ((fn (x862-acode-operator-function form)))
+ (apply fn seg freg nil (%cdr form)))))
=
=
(defun x862-form-typep (form type)
@@ -2581,6 +2610,16 @@
(when (and vreg val-reg) (<- val-reg))
(^))))
=
+
+(defun x862-code-coverage-entry (seg note)
+ (let* ((afunc *x862-cur-afunc*))
+ (setf (afunc-bits afunc) (%ilogior (afunc-bits afunc) (ash 1 $fbitccove=
rage)))
+ (with-x86-local-vinsn-macros (seg)
+ (let* ((ccreg ($ x8664::arg_x)))
+ (! vpush-register ccreg)
+ (! ref-constant ccreg (x86-immediate-label note))
+ (! misc-set-immediate-c-node 0 ccreg 1)
+ (! vpop-register ccreg)))))
=
(defun x862-vset (seg vreg xfer type-keyword vector index value safe)
(with-x86-local-vinsn-macros (seg)
@@ -4308,118 +4347,119 @@
(or (=3D masked x8664::fulltag-nodeheader-0)
(=3D masked x8664::fulltag-nodeheader-1)))))))
=
-(defun x862-dynamic-extent-form (seg curstack val)
- (when (acode-p val)
- (with-x86-local-vinsn-macros (seg)
- (let* ((op (acode-operator val)))
- (cond ((eq op (%nx1-operator list))
- (let* ((*x862-vstack* *x862-vstack*)
- (*x862-top-vstack-lcell* *x862-top-vstack-lcell*))
- (x862-set-nargs seg (x862-formlist seg (%cadr val) nil))
- (x862-open-undo $undostkblk curstack)
- (! stack-cons-list))
- (setq val *x862-arg-z*))
- ((eq op (%nx1-operator list*))
- (let* ((arglist (%cadr val))) =
+(defun x862-dynamic-extent-form (seg curstack val &aux (form val))
+ (when (acode-p form)
+ (with-note (form seg curstack) ;; note this binds form/seg/curstack so=
can't be setq'd.
+ (with-x86-local-vinsn-macros (seg)
+ (let* ((op (acode-operator form)))
+ (cond ((eq op (%nx1-operator list))
(let* ((*x862-vstack* *x862-vstack*)
(*x862-top-vstack-lcell* *x862-top-vstack-lcell*))
- (x862-formlist seg (car arglist) (cadr arglist)))
- (when (car arglist)
- (x862-set-nargs seg (length (%car arglist)))
- (! stack-cons-list*)
- (x862-open-undo $undostkblk curstack))
- (setq val *x862-arg-z*)))
- ((eq op (%nx1-operator multiple-value-list))
- (x862-multiple-value-body seg (%cadr val))
- (x862-open-undo $undostkblk curstack)
- (! stack-cons-list)
- (setq val *x862-arg-z*))
- ((eq op (%nx1-operator cons))
- (let* ((y ($ *x862-arg-y*))
- (z ($ *x862-arg-z*))
- (result ($ *x862-arg-z*)))
- (x862-two-targeted-reg-forms seg (%cadr val) y (%caddr va=
l) z)
- (x862-open-undo $undostkblk )
- (! make-tsp-cons result y z) =
- (setq val result)))
- ((eq op (%nx1-operator %consmacptr%))
- (with-imm-target () (address :address)
- (x862-one-targeted-reg-form seg val address)
- (with-node-target () node
- (! macptr->stack node address)
- (x862-open-undo $undo-x86-c-frame)
- (setq val node))))
- ((eq op (%nx1-operator %new-ptr))
- (let* ((clear-form (caddr val))
- (cval (nx-constant-form-p clear-form)))
- (if cval
- (progn =
- (x862-one-targeted-reg-form seg (%cadr val) ($ *x862-=
arg-z*))
- (if (nx-null cval)
- (! make-stack-block)
- (! make-stack-block0)))
- (with-crf-target () crf
- (let ((stack-block-0-label (backend-get-next-label))
- (done-label (backend-get-next-label))
- (rval ($ *x862-arg-z*))
- (rclear ($ *x862-arg-y*)))
- (x862-two-targeted-reg-forms seg (%cadr val) rval c=
lear-form rclear)
- (! compare-to-nil crf rclear)
- (! cbranch-false (aref *backend-labels* stack-block=
-0-label) crf x86::x86-e-bits)
- (! make-stack-block)
- (-> done-label)
- (@ stack-block-0-label)
- (! make-stack-block0)
- (@ done-label)))))
- (x862-open-undo $undo-x86-c-frame)
- (setq val ($ *x862-arg-z*)))
- ((eq op (%nx1-operator make-list))
- (x862-two-targeted-reg-forms seg (%cadr val) ($ *x862-arg-y=
*) (%caddr val) ($ *x862-arg-z*))
- (x862-open-undo $undostkblk curstack)
- (! make-stack-list)
- (setq val *x862-arg-z*)) =
- ((eq op (%nx1-operator vector))
- (let* ((*x862-vstack* *x862-vstack*)
- (*x862-top-vstack-lcell* *x862-top-vstack-lcell*))
- (x862-set-nargs seg (x862-formlist seg (%cadr val) nil))
- (! make-stack-vector))
- (x862-open-undo $undostkblk)
- (setq val *x862-arg-z*))
- ((eq op (%nx1-operator %gvector))
- (let* ((*x862-vstack* *x862-vstack*)
- (*x862-top-vstack-lcell* *x862-top-vstack-lcell*)
- (arglist (%cadr val)))
- (x862-set-nargs seg (x862-formlist seg (append (car argli=
st) (reverse (cadr arglist))) nil))
- (! make-stack-gvector))
- (x862-open-undo $undostkblk)
- (setq val *x862-arg-z*)) =
- ((eq op (%nx1-operator closed-function)) =
- (setq val (x862-make-closure seg (cadr val) t))) ; can't er=
ror
- ((eq op (%nx1-operator %make-uvector))
- (destructuring-bind (element-count subtag &optional (init 0=
init-p)) (%cdr val)
- (let* ((fix-subtag (acode-fixnum-form-p subtag))
- (is-node (x862-target-is-node-subtag fix-subtag))
- (is-imm (x862-target-is-imm-subtag fix-subtag)))
- (when (or is-node is-imm)
- (if init-p
- (progn
- (x862-three-targeted-reg-forms seg element-count
- (target-arch-case
- (:x8632
- ($ x8632::temp1))
- (:x8664
- ($ x8664::arg_x)))
- subtag ($ *x862-arg-y*)
- init ($ *x862-arg-z*))
- (! stack-misc-alloc-init))
- (progn
- (x862-two-targeted-reg-forms seg element-count ($=
*x862-arg-y*) subtag ($ *x862-arg-z*))
- (! stack-misc-alloc)))
- (if is-node
- (x862-open-undo $undostkblk)
- (x862-open-undo $undo-x86-c-frame))
- (setq val ($ *x862-arg-z*))))))))))
- val)
+ (x862-set-nargs seg (x862-formlist seg (%cadr form) nil=
))
+ (x862-open-undo $undostkblk curstack)
+ (! stack-cons-list))
+ (setq val *x862-arg-z*))
+ ((eq op (%nx1-operator list*))
+ (let* ((arglist (%cadr form)))
+ (let* ((*x862-vstack* *x862-vstack*)
+ (*x862-top-vstack-lcell* *x862-top-vstack-lcell*=
))
+ (x862-formlist seg (car arglist) (cadr arglist)))
+ (when (car arglist)
+ (x862-set-nargs seg (length (%car arglist)))
+ (! stack-cons-list*)
+ (x862-open-undo $undostkblk curstack))
+ (setq val *x862-arg-z*)))
+ ((eq op (%nx1-operator multiple-value-list))
+ (x862-multiple-value-body seg (%cadr form))
+ (x862-open-undo $undostkblk curstack)
+ (! stack-cons-list)
+ (setq val *x862-arg-z*))
+ ((eq op (%nx1-operator cons))
+ (let* ((y ($ *x862-arg-y*))
+ (z ($ *x862-arg-z*))
+ (result ($ *x862-arg-z*)))
+ (x862-two-targeted-reg-forms seg (%cadr val) y (%caddr =
val) z)
+ (x862-open-undo $undostkblk )
+ (! make-tsp-cons result y z)
+ (setq val result)))
+ ((eq op (%nx1-operator %consmacptr%))
+ (with-imm-target () (address :address)
+ (x862-one-targeted-reg-form seg form address)
+ (with-node-target () node
+ (! macptr->stack node address)
+ (x862-open-undo $undo-x86-c-frame)
+ (setq val node))))
+ ((eq op (%nx1-operator %new-ptr))
+ (let* ((clear-form (caddr form))
+ (cval (nx-constant-form-p clear-form)))
+ (if cval
+ (progn =
+ (x862-one-targeted-reg-form seg (%cadr form) ($ *x=
862-arg-z*))
+ (if (nx-null cval)
+ (! make-stack-block)
+ (! make-stack-block0)))
+ (with-crf-target () crf
+ (let ((stack-block-0-label (backend-get-next-label=
))
+ (done-label (backend-get-next-label))
+ (rval ($ *x862-arg-z*))
+ (rclear ($ *x862-arg-y*)))
+ (x862-two-targeted-reg-forms seg (%cadr form) rv=
al clear-form rclear)
+ (! compare-to-nil crf rclear)
+ (! cbranch-false (aref *backend-labels* stack-bl=
ock-0-label) crf x86::x86-e-bits)
+ (! make-stack-block)
+ (-> done-label)
+ (@ stack-block-0-label)
+ (! make-stack-block0)
+ (@ done-label)))))
+ (x862-open-undo $undo-x86-c-frame)
+ (setq val ($ *x862-arg-z*)))
+ ((eq op (%nx1-operator make-list))
+ (x862-two-targeted-reg-forms seg (%cadr form) ($ *x862-a=
rg-y*) (%caddr form) ($ *x862-arg-z*))
+ (x862-open-undo $undostkblk curstack)
+ (! make-stack-list)
+ (setq val *x862-arg-z*)) =
+ ((eq op (%nx1-operator vector))
+ (let* ((*x862-vstack* *x862-vstack*)
+ (*x862-top-vstack-lcell* *x862-top-vstack-lcell*))
+ (x862-set-nargs seg (x862-formlist seg (%cadr form) ni=
l))
+ (! make-stack-vector))
+ (x862-open-undo $undostkblk)
+ (setq val *x862-arg-z*))
+ ((eq op (%nx1-operator %gvector))
+ (let* ((*x862-vstack* *x862-vstack*)
+ (*x862-top-vstack-lcell* *x862-top-vstack-lcell*)
+ (arglist (%cadr form)))
+ (x862-set-nargs seg (x862-formlist seg (append (car ar=
glist) (reverse (cadr arglist))) nil))
+ (! make-stack-gvector))
+ (x862-open-undo $undostkblk)
+ (setq val *x862-arg-z*)) =
+ ((eq op (%nx1-operator closed-function)) =
+ (setq val (x862-make-closure seg (cadr form) t))) ; can'=
t error
+ ((eq op (%nx1-operator %make-uvector))
+ (destructuring-bind (element-count subtag &optional (ini=
t 0 init-p)) (%cdr form)
+ (let* ((fix-subtag (acode-fixnum-form-p subtag))
+ (is-node (x862-target-is-node-subtag fix-subtag=
))
+ (is-imm (x862-target-is-imm-subtag fix-subtag)=
))
+ (when (or is-node is-imm)
+ (if init-p
+ (progn
+ (x862-three-targeted-reg-forms seg element-cou=
nt
+ (target-arch-ca=
se
+ (:x8632
+ ($ x8632::tem=
p1))
+ (:x8664
+ ($ x8664::arg=
_x)))
+ subtag ($ *x862=
-arg-y*)
+ init ($ *x862-a=
rg-z*))
+ (! stack-misc-alloc-init))
+ (progn
+ (x862-two-targeted-reg-forms seg element-count=
($ *x862-arg-y*) subtag ($ *x862-arg-z*))
+ (! stack-misc-alloc)))
+ (if is-node
+ (x862-open-undo $undostkblk)
+ (x862-open-undo $undo-x86-c-frame))
+ (setq val ($ *x862-arg-z*))))))))))
+ val))
=
(defun x862-addrspec-to-reg (seg addrspec reg)
(if (memory-spec-p addrspec)
@@ -5153,16 +5193,17 @@
;;; that register to RNIL.
;;; "XFER" is a compound destination.
(defun x862-conditional-form (seg xfer form)
- (let* ((uwf (acode-unwrapped-form-value form)))
- (if (nx-null uwf)
- (x862-branch seg (x862-cd-false xfer))
- (if (x86-constant-form-p uwf)
- (x862-branch seg (x862-cd-true xfer))
- (with-crf-target () crf
- (let* ((ea (x862-lexical-reference-ea form nil)))
- (if (and ea (memory-spec-p ea))
- (x862-compare-ea-to-nil seg crf xfer ea x86::x86-e-bits nil)
- (x862-form seg crf xfer form))))))))
+ (with-note (form seg xfer)
+ (let* ((uwf (acode-unwrapped-form-value form)))
+ (if (nx-null uwf)
+ (x862-branch seg (x862-cd-false xfer))
+ (if (x86-constant-form-p uwf)
+ (x862-branch seg (x862-cd-true xfer))
+ (with-crf-target () crf
+ (let* ((ea (x862-lexical-reference-ea form nil)))
+ (if (and ea (memory-spec-p ea))
+ (x862-compare-ea-to-nil seg crf xfer ea x86::x86-e-bits ni=
l)
+ (x862-form seg crf xfer form)))))))))
=
=
(defun x862-branch (seg xfer &optional cr-bit true-p)
@@ -6075,7 +6116,7 @@
(svset *x862-specials* (%ilogand #.operator-id-mask (%nx1-opera=
tor ,locative)) ,fun))))))
)
=
-(defx862 x862-lambda lambda-list (seg vreg xfer req opt rest keys auxen bo=
dy p2decls)
+(defx862 x862-lambda lambda-list (seg vreg xfer req opt rest keys auxen bo=
dy p2decls &optional code-note)
(with-x86-local-vinsn-macros (seg vreg xfer)
(let* ((stack-consed-rest nil)
(next-method-var-scope-info nil)
@@ -6113,6 +6154,10 @@
(@ (backend-get-next-label)) ; generic self-reference label, shoul=
d be label #1
(! establish-fn)
(@ (backend-get-next-label)) ; self-call label
+ (when keys ;; Ensure keyvect is the first immediate
+ (x86-immediate-label (%cadr (%cdddr keys))))
+ (when code-note
+ (x862-code-coverage-entry seg code-note))
(unless next-method-p
(setq method-var nil))
=
@@ -9000,34 +9045,35 @@
(if (or (eq typespec t)
(eq typespec '*))
(x862-form seg vreg xfer form)
- (let* ((ok (backend-get-next-label)))
- (x862-one-targeted-reg-form seg form ($ *x862-arg-y*))
- (x862-store-immediate seg typespec ($ *x862-arg-z*))
- (x862-store-immediate seg 'typep ($ *x862-fname*))
- (x862-set-nargs seg 2)
- (x862-vpush-register seg ($ *x862-arg-y*))
- (! call-known-symbol ($ *x862-arg-z*))
- (! compare-to-nil ($ *x862-arg-z*))
- (x862-vpop-register seg ($ *x862-arg-y*))
- (! cbranch-false (aref *backend-labels* ok) x86::x86-e-bits)
- (target-arch-case
- (:x8632
- (let* ((*x862-vstack* *x862-vstack*)
- (*x862-top-vstack-lcell* *x862-top-vstack-lcell*))
- (! reserve-outgoing-frame)
- (incf *x862-vstack* (* 2 *x862-target-node-size*))
- (! vpush-fixnum (ash $XWRONGTYPE *x862-target-fixnum-shift*))
- (x862-store-immediate seg typespec ($ *x862-arg-z*))
- (x862-set-nargs seg 3)
- (! ksignalerr)))
- (:x8664
- (x862-lri seg ($ x8664::arg_x) (ash $XWRONGTYPE *x862-target-fixnum=
-shift*))
- (x862-store-immediate seg typespec ($ *x862-arg-z*))
- (x862-set-nargs seg 3)
- (! ksignalerr)))
- (@ ok)
- (<- ($ *x862-arg-y*))
- (^)))))))
+ (with-note (form seg vreg xfer)
+ (let* ((ok (backend-get-next-label)))
+ (x862-one-targeted-reg-form seg form ($ *x862-arg-y*))
+ (x862-store-immediate seg typespec ($ *x862-arg-z*))
+ (x862-store-immediate seg 'typep ($ *x862-fname*))
+ (x862-set-nargs seg 2)
+ (x862-vpush-register seg ($ *x862-arg-y*))
+ (! call-known-symbol ($ *x862-arg-z*))
+ (! compare-to-nil ($ *x862-arg-z*))
+ (x862-vpop-register seg ($ *x862-arg-y*))
+ (! cbranch-false (aref *backend-labels* ok) x86::x86-e-bits)
+ (target-arch-case
+ (:x8632
+ (let* ((*x862-vstack* *x862-vstack*)
+ (*x862-top-vstack-lcell* *x862-top-vstack-lcell*))
+ (! reserve-outgoing-frame)
+ (incf *x862-vstack* (* 2 *x862-target-node-size*))
+ (! vpush-fixnum (ash $XWRONGTYPE *x862-target-fixnum-shi=
ft*))
+ (x862-store-immediate seg typespec ($ *x862-arg-z*))
+ (x862-set-nargs seg 3)
+ (! ksignalerr)))
+ (:x8664
+ (x862-lri seg ($ x8664::arg_x) (ash $XWRONGTYPE *x862-targ=
et-fixnum-shift*))
+ (x862-store-immediate seg typespec ($ *x862-arg-z*))
+ (x862-set-nargs seg 3)
+ (! ksignalerr)))
+ (@ ok)
+ (<- ($ *x862-arg-y*))
+ (^))))))))
=
=
=
Modified: trunk/source/compiler/lambda-list.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/compiler/lambda-list.lisp (original)
+++ trunk/source/compiler/lambda-list.lisp Sun Nov 16 10:35:28 2008
@@ -31,6 +31,9 @@
(let* ((index (%lfun-info-index fn)))
(if index (%svref (function-to-function-vector fn) index))))
=
+(defun function-source-note (fn)
+ (getf (%lfun-info fn) '%function-source-note))
+
(defun uncompile-function (fn)
(getf (%lfun-info fn) 'function-lambda-expression ))
=
@@ -38,7 +41,39 @@
(defun function-symbol-map (fn)
(getf (%lfun-info fn) 'function-symbol-map))
=
+(defun find-source-note-at-pc (fn pc)
+ ;(declare (values source-note start-pc end-pc))
+ (let* ((function-note (function-source-note fn))
+ (pc-source-map (getf (%lfun-info fn) 'pc-source-map))
+ (best-guess -1)
+ (best-length 0)
+ (len (length pc-source-map)))
+ (declare (fixnum best-guess best-length len))
+ (when (and function-note pc-source-map)
+ (do ((q 0 (+ q 4)))
+ ((=3D q len))
+ (declare (fixnum q))
+ (let* ((pc-start (aref pc-source-map q))
+ (pc-end (aref pc-source-map (%i+ q 1))))
+ (declare (fixnum pc-start pc-end))
+ (when (and (<=3D pc-start pc pc-end)
+ (or (eql best-guess -1)
+ (< (%i- pc-end pc-start) best-length)))
+ (setf best-guess q
+ best-length (- pc-end pc-start)))))
+ (unless (eql best-guess -1)
+ (values
+ (let ((def-pos (source-note-start-pos function-note)))
+ (make-source-note :source function-note
+ :filename (source-note-filename function-not=
e)
+ :start-pos (+ def-pos (aref pc-source-map (+=
best-guess 2)))
+ :end-pos (+ def-pos (aref pc-source-map (+ b=
est-guess 3)))))
+ (aref pc-source-map best-guess)
+ (aref pc-source-map (+ best-guess 1)))))))
+
;;; Lambda-list utilities
+
+
=
=
=
Modified: trunk/source/compiler/nx-basic.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/compiler/nx-basic.lisp (original)
+++ trunk/source/compiler/nx-basic.lisp Sun Nov 16 10:35:28 2008
@@ -36,9 +36,90 @@
=
(defvar *lisp-compiler-version* 666 "I lost count.")
=
+#-BOOTSTRAPPED (defvar *record-pc-mapping* nil) ;; defined in level-1
+
(defvar *nx-compile-time-types* nil)
(defvar *nx-proclaimed-types* nil)
(defvar *nx-method-warning-name* nil)
+
+(defvar *nx-current-code-note*)
+
+;; In lieu of a slot in acode. Don't reference this variable elsewhere be=
cause I'm
+;; hoping to make it go away.
+(defparameter *nx-acode-note-map* nil)
+
+(defun acode-note (acode &aux (hash *nx-acode-note-map*))
+ (and hash (gethash acode hash)))
+
+(defun (setf acode-note) (note acode)
+ (when note
+ (assert *nx-acode-note-map*)
+ (setf (gethash acode *nx-acode-note-map*) note)))
+
+
+(defun nx-source-note (form &aux (source-notes *nx-source-note-map*))
+ (when source-notes
+ (when (or (consp form) (vectorp form) (pathnamep form))
+ (let ((note (gethash form source-notes)))
+ (unless (listp note) note)))))
+
+(defstruct (code-note (:constructor %make-code-note))
+ ;; Code coverage state. This MUST be the first slot - see nx2-code-cove=
rage.
+ code-coverage
+ ;; The actual source form - useful for debugging, otherwise unused.
+ #+debug-code-notes form
+ ;; The source note of this form, or NIL if random code form (no file inf=
o,
+ ;; generated by macros or other source transform)
+ source-note
+ ;; the note that was being compiled when this note was emitted.
+ parent-note)
+
+(defun make-code-note (&key form source-note parent-note)
+ (declare (ignorable form))
+ (let ((note (%make-code-note
+ :source-note source-note
+ :parent-note parent-note)))
+ #+debug-code-notes
+ (when form
+ ;; Unfortunately, recording the macroexpanded form is problematic, s=
ince they
+ ;; can have references to non-dumpable forms, see e.g. loop.
+ (setf (code-note-form note)
+ (with-output-to-string (s) (let ((*print-circle* t)) (prin1 form s)))=
))
+ note))
+
+(defun nx-ensure-code-note (form &optional parent-note)
+ (let* ((parent-note (or parent-note *nx-current-code-note*))
+ (source-note (nx-source-note form)))
+ (unless (and source-note
+ ;; Look out for a case like a lambda macro that turns (la=
mbda ...)
+ ;; into (FUNCTION (lambda ...)) which then has (lambda ..=
.)
+ ;; as a child. Create a fresh note for the child, to avo=
id ambiguity.
+ ;; Another case is forms wrapping THE around themselves.
+ (neq source-note (code-note-source-note parent-note))
+ ;; Don't use source notes from a different toplevel form,=
which could
+ ;; happen due to inlining etc. The result then is that t=
he source note
+ ;; appears in multiple places, and shows partial coverage=
(from the
+ ;; other reference) in code that's never executed.
+ (loop for p =3D parent-note then (code-note-parent-note p)
+ when (null p)
+ return t
+ when (code-note-source-note p)
+ return (eq (loop for n =3D source-note then s
+ as s =3D (source-note-source n)
+ unless (source-note-p s) return =
n)
+ (loop for n =3D (code-note-source-note=
p) then s
+ as s =3D (source-note-source n)
+ unless (source-note-p s) return =
n))))
+ (setq source-note nil))
+ (make-code-note :form form :source-note source-note :parent-note paren=
t-note)))
+
+(defun nx-note-source-transformation (original new &aux (source-notes *nx-=
source-note-map*) sn)
+ (when (and source-notes
+ (setq sn (gethash original source-notes))
+ (not (gethash new source-notes)))
+ (setf (gethash new source-notes) sn)))
+
+
=
(defvar *nx1-alphatizers* (make-hash-table :size 180 :test #'eq))
=
Modified: trunk/source/compiler/nx.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/compiler/nx.lisp (original)
+++ trunk/source/compiler/nx.lisp Sun Nov 16 10:35:28 2008
@@ -151,36 +151,12 @@
=
(defparameter *load-time-eval-token* nil)
=
-(defparameter *nx-source-note-map* nil)
-
-(defun nx-source-note (form &aux (source-notes *nx-source-note-map*))
- (when source-notes (gethash form source-notes)))
- =
-(defun nx-note-source-transformation (original new &aux (source-notes *nx-=
source-note-map*) sn)
- (when (and source-notes
- (setq sn (gethash original source-notes))
- (not (gethash new source-notes)))
- (setf (gethash new source-notes) sn)))
-
(defparameter *nx-discard-xref-info-hook* nil)
=
-;; In lieu of a slot in acode. Don't reference this variable elsewhere be=
cause I'm
-;; hoping to make it go away.
-(defparameter *nx-acode-source-map* nil)
-
-(defun acode-source-note (acode &aux (hash *nx-acode-source-map*))
- (and hash (gethash acode hash)))
-
-(defun (setf acode-source) (form acode)
- ;; Could save the form, but right now only really care about the source =
note,
- ;; and this way don't have to keep looking it up in pass 2.
- (let ((note (nx-source-note form)))
- (when note
- (assert *nx-acode-source-map*)
- (setf (gethash acode *nx-acode-source-map*) note))))
-
(defun compile-named-function (def &key name env policy load-time-eval-tok=
en target
- function-note keep-lambda keep-symbols sou=
rce-notes)
+ function-note keep-lambda keep-symbols sou=
rce-notes
+ (record-pc-mapping *record-pc-mapping*)
+ (compile-code-coverage *compile-code-cover=
age*))
;; SOURCE-NOTES, if not nil, is a hash table mapping source forms to loc=
ations,
;; is used to produce and attach a pc/source map to the lfun, also to =
attach
;; source locations and pc/source maps to inner lfuns.
@@ -192,7 +168,13 @@
def
(let* ((*load-time-eval-token* load-time-eval-token)
(*nx-source-note-map* source-notes)
- (*nx-acode-source-map* (and source-notes (make-hash-table :test #'eq :s=
hared nil)))
+ (*nx-current-note* function-note)
+ (*record-pc-mapping* (and source-notes record-pc-mapping))
+ (*compile-code-coverage* (and source-notes compile-code-coverage=
))
+ (*nx-acode-note-map* (and (or record-pc-mapping compile-code-coverage)
+ (make-hash-table :test #'eq :shared ni=
l)))
+ (*nx-current-code-note* (and compile-code-coverage
+ (make-code-note :form def :source-n=
ote function-note)))
(env (new-lexical-environment env)))
(setf (lexenv.variables env) 'barrier)
(let* ((*target-backend* (or (if target (find-backend target)) *host-=
backend*))
@@ -203,8 +185,7 @@
nil =
env =
(or policy *default-compiler-policy*)
- *load-time-eval-token*
- function-note)))
+ *load-time-eval-token*)))
(if (afunc-lfun afunc)
afunc
(funcall (backend-p2-compile *target-backend*)
Modified: trunk/source/compiler/nx0.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/compiler/nx0.lisp (original)
+++ trunk/source/compiler/nx0.lisp Sun Nov 16 10:35:28 2008
@@ -33,6 +33,8 @@
(setf (afunc-bits v) 0)
v)
=
+(defvar *compile-code-coverage* nil "True to instrument for code coverage")
+
(defvar *nx-blocks* nil)
(defvar *nx-tags* nil)
(defvar *nx-parent-function* nil)
@@ -41,6 +43,8 @@
(defvar *nx-symbol-macros* nil)
(defvar *nx-inner-functions* nil)
(defvar *nx-cur-func-name* nil)
+(defvar *nx-current-note*)
+(defparameter *nx-source-note-map* nil) ;; there might be external refs, f=
rom macros.
(defvar *nx-form-type* t)
;(defvar *nx-proclaimed-inline* nil)
;(defvar *nx-proclaimed-inline* (make-hash-table :size 400 :test #'eq))
@@ -56,7 +60,6 @@
=
(defvar *nx1-operators* (make-hash-table :size 300 :test #'eq))
=
- =
=
; The compiler can (generally) use temporary vectors for VARs.
(defun nx-cons-var (name &optional (bits 0))
@@ -79,6 +82,11 @@
(defvar *nx-warnings* nil)
=
(defvar *nx1-compiler-special-forms* nil "Real special forms")
+
+(defmacro without-compiling-code-coverage (&body body)
+ "Disable code coverage in the lexical scope of the form"
+ `(compiler-let ((*nx-current-code-note* nil))
+ , at body))
=
(defparameter *nx-never-tail-call*
'(error cerror break warn type-error file-error
@@ -90,7 +98,6 @@
should never be tail-called.")
=
(defvar *cross-compiling* nil "bootstrapping")
-
=
=
(defparameter *nx-operator-result-types*
@@ -525,7 +532,8 @@
;; Use acode-unwrapped-form-value to reason about the value of a form at
;; compile time. To actually generate code, use acode-unwrapped-form.
(defun acode-unwrapped-form-value (form)
- ;; Currently no difference
+ ;; Currently no difference, but if had any operators like with-code-note,
+ ;; would unwrap them here.
(acode-unwrapped-form form))
=
; Strip off any type info or "punted" lexical references.
@@ -1086,7 +1094,8 @@
(containing-env nil)
(token nil))
(if (and (nx-declared-inline-p sym env)
- (not (gethash sym *nx1-alphatizers*)))
+ (not (gethash sym *nx1-alphatizers*))
+ (not *nx-current-code-note*))
(multiple-value-bind (info afunc) (unless global-only (nx-lexical-fi=
nfo sym env))
(if info (setq token afunc =
containing-env (afunc-environment afunc)
@@ -1294,8 +1303,7 @@
q
parent-env
(policy *default-compiler-policy*)
- load-time-eval-token
- function-note)
+ load-time-eval-token)
=
(if q
(setf (afunc-parent p) q))
@@ -1318,16 +1326,12 @@
`(:internal ,parent-name)))
name)))
=
- (when (or function-note
- (setq function-note (nx-source-note lambda-form))
- (setq function-note (and q (getf (afunc-lfun-info q) 'function=
-source-note))))
- (setf (afunc-lfun-info p)
- (list* 'function-source-note function-note (afunc-lfun-info p))))
-
(unless (lambda-expression-p lambda-form)
(nx-error "~S is not a valid lambda expression." lambda-form))
+
(let* ((*nx-current-function* p)
(*nx-parent-function* q)
+ (*nx-current-note* (or *nx-current-note* (nx-source-note lambda-f=
orm)))
(*nx-lexical-environment* (new-lexical-environment parent-env))
(*nx-load-time-eval-token* load-time-eval-token)
(*nx-all-vars* nil)
@@ -1351,6 +1355,11 @@
(setf (afunc-bits p) (logior (ash 1 $fbitnonnullenv) (the fixnum (af=
unc-bits p)))))
=
(setf (afunc-lambdaform p) lambda-form)
+
+ (when *nx-current-note*
+ (setf (afunc-lfun-info p)
+ (list* '%function-source-note *nx-current-note* (afunc-lfun-in=
fo p))))
+
(with-program-error-handler
(lambda (c)
(setf (afunc-acode p) (nx1-lambda '(&rest args) `(args ,(runtime-progra=
m-error-form c)) nil)))
@@ -1370,7 +1379,7 @@
(multiple-value-bind (body decls)
(with-program-error-handler (lambda (c) (runtime-program-error-form c=
))
(parse-body (%cddr lambda-form) *nx-lexical-environment* t))
- (setf (afunc-acode p) (nx1-lambda (%cadr lambda-form) body decls)))))
+ (setf (afunc-acode p) (nx1-lambda (%cadr lambda-form) body decls=
)))))
=
(nx1-transitively-punt-bindings *nx-punted-vars*)
(setf (afunc-blocks p) *nx-blocks*)
@@ -1445,15 +1454,18 @@
(%ilogior =
(%ilsl $fbitnextmethp 1)
(afunc-bits *nx-current-function*)))))
- (make-acode
- (%nx1-operator lambda-list) =
- req
- opt =
- (if lexpr (list rest) rest)
- keys
- auxen
- body
- *nx-new-p2decls*)))))
+ (let ((acode (make-acode
+ (%nx1-operator lambda-list) =
+ req
+ opt =
+ (if lexpr (list rest) rest)
+ keys
+ auxen
+ body
+ *nx-new-p2decls*)))
+ (when *nx-current-code-note*
+ (setf (acode-note acode) *nx-current-code-note*))
+ acode)))))
=
(defun nx-parse-simple-lambda-list (pending ll &aux
req
@@ -1655,23 +1667,26 @@
(nx1-transformed-form (nx-transform original env) env)))
=
(defun nx1-transformed-form (form env)
- (flet ((main (form env)
- (if (consp form)
- (nx1-combination form env)
- (let* ((symbolp (non-nil-symbol-p form))
- (constant-value (unless symbolp form))
- (constant-symbol-p nil))
- (if symbolp =
- (multiple-value-setq (constant-value constant-symbol-p) =
- (nx-transform-defined-constant form env)))
- (if (and symbolp (not constant-symbol-p))
- (nx1-symbol form env)
- (nx1-immediate (nx-unquote constant-value)))))))
- (if *nx-source-note-map*
- (let ((acode (main form env)))
- (setf (acode-source acode) form)
- acode)
- (main form env))))
+ (let* ((*nx-current-note* (or (nx-source-note form) *nx-current-note*))
+ (*nx-current-code-note* (and *nx-current-code-note*
+ (or (nx-ensure-code-note form *nx-c=
urrent-code-note*)
+ (compiler-bug "No source note f=
or ~s" form))))
+ (acode (if (consp form)
+ (nx1-combination form env)
+ (let* ((symbolp (non-nil-symbol-p form))
+ (constant-value (unless symbolp form))
+ (constant-symbol-p nil))
+ (if symbolp =
+ (multiple-value-setq (constant-value constant-symbol=
-p) =
+ (nx-transform-defined-constant form env)))
+ (if (and symbolp (not constant-symbol-p))
+ (nx1-symbol form env)
+ (nx1-immediate (nx-unquote constant-value)))))))
+ (cond (*nx-current-code-note*
+ (setf (acode-note acode) *nx-current-code-note*))
+ (*record-pc-mapping*
+ (setf (acode-note acode) (nx-source-note form))))
+ acode))
=
(defun nx1-prefer-areg (form env)
(nx1-form form env))
Modified: trunk/source/compiler/nx1.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/compiler/nx1.lisp (original)
+++ trunk/source/compiler/nx1.lisp Sun Nov 16 10:35:28 2008
@@ -1215,7 +1215,10 @@
(setf (afunc-blocks q) *nx-blocks*)
(setf (afunc-inner-functions q) (push p *nx-inner-functions*))
(setf (lexenv.lambda env) q)
- (nx1-compile-lambda name def p q env *nx-current-compiler-policy* *nx-lo=
ad-time-eval-token*)) ;returns p.
+ (if *nx-current-code-note*
+ (let* ((*nx-current-code-note* (nx-ensure-code-note def *nx-current-co=
de-note*)))
+ (nx1-compile-lambda name def p q env *nx-current-compiler-policy* *n=
x-load-time-eval-token*)) ;returns p.
+ (nx1-compile-lambda name def p q env *nx-current-compiler-policy* *nx-=
load-time-eval-token*)))
=
(defun nx1-afunc-ref (afunc)
(let ((op (if (afunc-inherited-vars afunc)
@@ -1647,7 +1650,7 @@
(setf (afunc-lambdaform func) expansion
(afunc-environment func) env)
(push (cons funcname expansion)
- bodies)))))
+ bodies)))))
(nx1-dynamic-extent-functions vars env)
(dolist (def bodies)
(nx1-compile-inner-function (car def) (cdr def) (setq func (pop =
funcs))))
Modified: trunk/source/level-0/l0-init.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/level-0/l0-init.lisp (original)
+++ trunk/source/level-0/l0-init.lisp Sun Nov 16 10:35:28 2008
@@ -157,6 +157,7 @@
(%symbol-bits x (%ilogior2 (%symbol-bits x) (ash 1 $sym_bit_special))))
=
(defparameter *loading-file-source-file* nil)
+(defparameter *loading-toplevel-location* nil)
=
(defvar *nx-speed* 1)
(defvar *nx-space* 1)
Modified: trunk/source/level-0/nfasload.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/level-0/nfasload.lisp (original)
+++ trunk/source/level-0/nfasload.lisp Sun Nov 16 10:35:28 2008
@@ -715,6 +715,10 @@
(let* ((source-file (%fasl-expr s)))
; (format t "~& source-file =3D ~s" source-file)
(setq *loading-file-source-file* source-file)))
+
+(deffaslop $fasl-toplevel-location (s)
+ (%cant-epush s)
+ (setq *loading-toplevel-location* (%fasl-expr s)))
=
(defvar *modules* nil)
=
Modified: trunk/source/level-1/l1-boot-1.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/level-1/l1-boot-1.lisp (original)
+++ trunk/source/level-1/l1-boot-1.lisp Sun Nov 16 10:35:28 2008
@@ -114,6 +114,7 @@
=
(catch :toplevel
(setq *loading-file-source-file* nil) ;Reset from last %fasload...
+ (setq *loading-toplevel-location* nil)
(init-logical-directories)
)
=
Modified: trunk/source/level-1/l1-boot-2.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/level-1/l1-boot-2.lisp (original)
+++ trunk/source/level-1/l1-boot-2.lisp Sun Nov 16 10:35:28 2008
@@ -26,8 +26,9 @@
(string name)
(namestring (backend-target-fasl-pathname
*target-backend*)))))
- `(let* ((*loading-file-source-file* *loading-file-source-file*))
- (%fasload ,namestring))))
+ `(let* ((*loading-file-source-file* *loading-file-source-fi=
le*)
+ (*loading-toplevel-location* *loading-toplevel-loca=
tion*))
+ (%fasload ,namestring))))
(bin-load (name)
(let* ((namestring
(concatenate 'simple-base-string
@@ -35,8 +36,9 @@
(string name)
(namestring (backend-target-fasl-pathname
*target-backend*)))))
- `(let* ((*loading-file-source-file* *loading-file-source-fi=
le*))
- (%fasload ,namestring)))))
+ `(let* ((*loading-file-source-file* *loading-file-source-fi=
le*)
+ (*loading-toplevel-location* *loading-toplevel-loca=
tion*))
+ (%fasload ,namestring)))))
=
=
(catch :toplevel
Modified: trunk/source/level-1/l1-files.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/level-1/l1-files.lisp (original)
+++ trunk/source/level-1/l1-files.lisp Sun Nov 16 10:35:28 2008
@@ -1235,7 +1235,8 @@
(*readtable* *readtable*)
(*loading-files* (cons file-name (specialv *loading-files*)))
;;reset by fasload to logical name stored in the file
- (*loading-file-source-file* (namestring source-file)))
+ (*loading-file-source-file* (namestring source-file))
+ (*loading-toplevel-location* nil))
(declare (special *loading-files* *loading-file-source-file*))
(when verbose
(format t "~&;Loading ~S..." *load-pathname*)
Modified: trunk/source/level-1/l1-init.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/level-1/l1-init.lisp (original)
+++ trunk/source/level-1/l1-init.lisp Sun Nov 16 10:35:28 2008
@@ -259,6 +259,16 @@
(defparameter *level-1-loaded* nil) ; set t by l1-boot
(defparameter *save-definitions* nil)
(defparameter *save-local-symbols* t)
+(defparameter *save-source-locations* :no-text
+ "Controls whether complete source locations is stored, both for definiti=
ons (names) and
+in function objects.
+
+If NIL we don't store any source location (other than the filename if *rec=
ord-source-file* is non-NIL).
+
+If T we store as much source location information as we have available.
+
+If :NO-TEXT we don't store a copy of the original source text.")
+(defparameter *record-pc-mapping* t)
=
(defvar *modules* nil
"This is a list of module names that have been loaded into Lisp so far.
Modified: trunk/source/level-1/l1-reader.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/level-1/l1-reader.lisp (original)
+++ trunk/source/level-1/l1-reader.lisp Sun Nov 16 10:35:28 2008
@@ -2512,11 +2512,11 @@
(values form
t
(and start-pos
- (make-source-note :form form
- :stream stream
- :start-pos (1- start-pos)
- :end-pos end-pos
- :subform-notes nested-source-note=
s))))))))
+ (record-source-note :form form
+ :stream stream
+ :start-pos (1- start-pos)
+ :end-pos end-pos
+ :subform-notes nested-source-no=
tes))))))))
=
#|
(defun %parse-expression-test (string)
@@ -2997,85 +2997,210 @@
=
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;=
;;;;;;
=
-(defstruct (source-note (:constructor %make-source-note))
+(defstruct (source-note (:conc-name "SOURCE-NOTE.") (:constructor %make-so=
urce-note))
;; For an inner source form, the source-note of the outer source form.
+ ;; For outer source note, octets
source
- file-name
+ filename
+ ;; start and end file positions (NOT characters positions)
file-range)
=
-(defun encode-file-range (start-pos end-pos)
- (let ((len (- end-pos start-pos)))
- (if (< len (ash 1 12))
- (+ (ash start-pos 12) len)
- (cons start-pos end-pos))))
+(defun make-source-note (&key filename start-pos end-pos source)
+ (%make-source-note :filename filename
+ :file-range (encode-file-range start-pos end-pos)
+ :source source))
+
+(defmethod print-object ((sn source-note) stream)
+ (print-unreadable-object (sn stream :type t :identity nil)
+ (let ((*print-length* (min (or *print-length* 3) 3)))
+ (format stream "~s:~s-~s ~s" (source-note-filename sn)
+ (source-note-start-pos sn) (source-note-end-pos sn)
+ (source-note.source sn)))))
+
+(defun source-note-filename (source)
+ (if (source-note-p source)
+ (source-note.filename source)
+ ;; else null or a pathname, as in record-source-file
+ source))
+
+(defun (setf source-note-filename) (filename source-note)
+ (setf (source-note.filename (require-type source-note 'source-note)) fil=
ename))
+
+;; Since source notes are optional, it simplifies a lot of code
+;; to have these accessors allow NIL.
+
+(defun source-note-source (source-note)
+ (when source-note
+ (source-note.source (require-type source-note 'source-note))))
+
+(defun source-note-file-range (source-note)
+ (when source-note
+ (source-note.file-range (require-type source-note 'source-note))))
=
(defun source-note-start-pos (source-note)
(let ((range (source-note-file-range source-note)))
(when range
- (if (consp range) (car range) (ash range -12)))))
+ (if (consp range) (car range) (ash range -14)))))
=
(defun source-note-end-pos (source-note)
(let ((range (source-note-file-range source-note)))
(when range
- (if (consp range) (cdr range) (+ (ash range -12) (logand range #xFFF=
))))))
+ (if (consp range) (cdr range) (+ (ash range -14) (logand range #x3FF=
F))))))
+
+(defun encode-file-range (start-pos end-pos)
+ (let ((len (- end-pos start-pos)))
+ (if (< len (ash 1 14))
+ (+ (ash start-pos 14) len)
+ (cons start-pos end-pos))))
+
+(defun source-note-text (source-note &optional start end)
+ (let* ((source (source-note-source source-note))
+ (start-pos (source-note-start-pos source-note))
+ (end-pos (source-note-end-pos source-note))
+ (start (or start start-pos))
+ (end (or end end-pos)))
+ (etypecase source
+ (source-note
+ (assert (<=3D (source-note-start-pos source) start end (source-no=
te-end-pos source)))
+ (source-note-text source start end))
+ ((simple-array (unsigned-byte 8) (*))
+ (decf start start-pos)
+ (decf end start-pos)
+ (assert (and (<=3D 0 start end (length source))))
+ (decode-string-from-octets source :start start :end end :external=
-format :utf-8))
+ (null source))))
=
(defvar *recording-source-streams* ())
=
-(defun make-source-note (&key form stream start-pos end-pos subform-notes)
+(defun record-source-note (&key form stream start-pos end-pos subform-note=
s)
(let ((recording (assq stream *recording-source-streams*)))
(when (and recording (not *read-suppress*))
(destructuring-bind (map file-name stream-offset) (cdr recording)
(let* ((prev (gethash form map))
- (note (%make-source-note :file-name file-name
- :file-range (encode-file-range
- (+ stream-offset star=
t-pos)
- (+ stream-offset end-=
pos)))))
+ (note (make-source-note :filename file-name
+ :start-pos (+ stream-offset start-p=
os)
+ :end-pos (+ stream-offset end-pos))=
))
(setf (gethash form map)
(cond ((null prev) note)
((consp prev) (cons note prev))
(t (list note prev))))
(loop for sub in subform-notes as subnote =3D (require-type sub =
'source-note)
do (when (source-note-source subnote) (error "Subnote ~s alrea=
dy owned?" subnote))
- do (setf (source-note-source subnote) note))
+ do (setf (source-note.source subnote) note))
note)))))
=
-(defmethod make-load-form ((note source-note) &optional env)
- (make-load-form-saving-slots note :environment env))
-
-(defun read-recording-source (stream &key eofval file-name start-offset ma=
p)
+(defun read-recording-source (stream &key eofval file-name start-offset ma=
p save-source-text)
"Read a top-level form, perhaps recording source locations.
If MAP is NIL, just reads a form as if by READ.
If MAP is non-NIL, returns a second value of a source-note object describi=
ng the form.
In addition, if MAP is a hash table, it gets filled with source-note's for=
all
non-atomic nested subforms."
+ (when (null start-offset) (setq start-offset 0))
(typecase map
(null (values (read-internal stream nil eofval nil) nil))
(hash-table
- (let* ((recording (list stream map file-name (or start-offset 0)))
- (*recording-source-streams* (cons recording *recording-source-=
streams*)))
- (declare (dynamic-extent recording *recording-source-streams*))
- (multiple-value-bind (form source-note) (read-internal stream nil e=
ofval nil)
- (when (and source-note (not (eq form eofval)))
- (assert (null (source-note-source source-note)))
- (loop for form being the hash-key using (hash-value note) of map
- do (cond ((eq note source-note) nil)
- ;; Remove entries with multiple source notes, wh=
ich can happen
- ;; for atoms. If we can't tell which instance w=
e mean, then we
- ;; don't have useful source info.
- ((listp note) (remhash form map))
- ((loop for p =3D note then (source-note-source p=
) while (source-note-p p)
- thereis (eq p source-note))
- ;; Flatten the backpointers so each subnote poi=
nts directly
- ;; to the toplevel note.
- (setf (source-note-source note) source-note)))))
- (values form source-note))))
+ (let* ((recording (list stream map file-name start-offset))
+ (*recording-source-streams* (cons recording *recording-sourc=
e-streams*)))
+ (declare (dynamic-extent recording *recording-source-streams*))
+ (multiple-value-bind (form source-note) (read-internal stream nil=
eofval nil)
+ (when (and source-note (not (eq form eofval)))
+ (assert (null (source-note-source source-note)))
+ (loop for form being the hash-key using (hash-value note) of =
map
+ do (cond ((eq note source-note) nil)
+ ;; Remove entries with multiple source notes, =
which can happen
+ ;; for atoms. If we can't tell which instance=
we mean, then we
+ ;; don't have useful source info.
+ ((listp note) (remhash form map))
+ ((loop for p =3D note then (source-note-source=
p) while (source-note-p p)
+ thereis (eq p source-note))
+ ;; Flatten the backpointers so each subnote p=
oints directly
+ ;; to the toplevel note.
+ (setf (source-note.source note) source-note))=
))
+ (when save-source-text
+ (setf (source-note.source source-note)
+ (fetch-octets-from-stream stream
+ (- (source-note-start-pos s=
ource-note)
+ start-offset)
+ (- (source-note-end-pos sou=
rce-note)
+ start-offset)))))
+ (values form source-note))))
(T
- (let* ((start (file-position stream))
- (form (read-internal stream nil eofval nil)))
- (values form (and (neq form eofval)
- (%make-source-note :file-name file-name
- :file-range (encode-file-range
- (+ (or start-offs=
et 0)
- start)
- (+ (or start-offs=
et 0)
- (file-position=
stream))))))))))
+ (let* ((start-pos (file-position stream))
+ (form (read-internal stream nil eofval nil))
+ (end-pos (and start-pos (neq form eofval) (file-position str=
eam)))
+ (source-note (and end-pos
+ (make-source-note :filename file-name
+ :start-pos (+ start-offs=
et start-pos)
+ :end-pos (+ start-offset=
end-pos)))))
+ (when (and source-note save-source-text)
+ (setf (source-note.source source-note) (fetch-octets-from-strea=
m stream start-pos end-pos)))
+ (values form source-note)))))
+
+(defun fetch-octets-from-stream (stream start-offset end-offset)
+ ;; We basically want to read the bytes between two positions, but there =
is no
+ ;; direct interface for that. So we let the stream decode and then we r=
e-encode.
+ ;; (Just as well, since otherwise we'd have to remember the file's encod=
ing).
+ (declare (fixnum start-offset))
+ (when (< start-offset end-offset)
+ (let* ((cur-pos (file-position stream))
+ (noctets (- end-offset start-offset))
+ (vec (make-array noctets :element-type '(unsigned-byte 8)))
+ (index 0))
+ (declare (type fixnum end-offset noctets index)
+ (type (simple-array (unsigned-byte 8) (*)) vec))
+ (macrolet ((out (code)
+ `(progn
+ (setf (aref vec index) ,code)
+ (when (eql (incf index) noctets) (return)))))
+ (file-position stream start-offset)
+ (loop
+ (let ((code (char-code (stream-read-char stream))))
+ (declare (fixnum code))
+ (cond ((< code #x80)
+ (out code))
+ ((< code #x800)
+ (out (logior #xc0 (ldb (byte 5 6) code)))
+ (out (logior #x80 (ldb (byte 6 0) code))))
+ ((< code #x10000)
+ (out (logior #xe0 (ldb (byte 4 12) code)))
+ (out (logior #x80 (ldb (byte 6 6) code)))
+ (out (logior #x80 (ldb (byte 6 0) code))))
+ (t
+ (out (logior #xf0 (ldb (byte 3 18) code)))
+ (out (logior #xe0 (ldb (byte 6 12) code)))
+ (out (logior #x80 (ldb (byte 6 6) code)))
+ (out (logior #x80 (ldb (byte 6 0) code))))))))
+ (file-position stream cur-pos)
+ vec)))
+
+(defun ensure-source-note-text (source-note &key (if-does-not-exist nil))
+ "Fetch source text from file if don't have it"
+ (setq if-does-not-exist (require-type if-does-not-exist '(member :error =
nil)))
+ (let ((source (source-note-source source-note))
+ (filename (source-note-filename source-note)))
+ (etypecase source
+ (null
+ (with-open-file (stream filename :if-does-not-exist if-does-not-e=
xist)
+ (when stream
+ (let ((start (source-note-start-pos source-note))
+ (end (source-note-end-pos source-note))
+ (len (file-length stream)))
+ (if (<=3D end len)
+ (setf (source-note.source source-note)
+ (fetch-octets-from-stream stream start end))
+ (when if-does-not-exist
+ (error 'simple-file-error :pathname filename
+ :error-type "File ~s changed since source info r=
ecorded")))))))
+ (source-note
+ (ensure-source-note-text source))
+ ((simple-array (unsigned-byte 8) (*))
+ source))))
+
+
+;; This can be called explicitly by macros that do more complicated transf=
orms
+(defun note-source-transformation (original new)
+ (nx-note-source-transformation original new))
+
+
+
+; end
Modified: trunk/source/level-1/l1-readloop-lds.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/level-1/l1-readloop-lds.lisp (original)
+++ trunk/source/level-1/l1-readloop-lds.lisp Sun Nov 16 10:35:28 2008
@@ -287,7 +287,8 @@
(print-listener-prompt stream =
t))))
(let* ((*break-level* break-level)
(*last-break-level* break-level)
- *loading-file-source-file*
+ (*loading-file-source-file* nil)
+ (*loading-toplevel-location* nil)
*in-read-loop*
*** ** * +++ ++ + /// // / -
(eof-value (cons nil nil))
Modified: trunk/source/level-1/l1-utils.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/level-1/l1-utils.lisp (original)
+++ trunk/source/level-1/l1-utils.lisp Sun Nov 16 10:35:28 2008
@@ -41,14 +41,15 @@
(setq *record-source-file* t)
=
(fset 'level-1-record-source-file
- (qlfun level-1-record-source-file (name def-type &optional (file-nam=
e *loading-file-source-file*))
+ (qlfun level-1-record-source-file (name def-type &optional (source (=
or *loading-toplevel-location*
+ =
*loading-file-source-file*)))
;; Level-0 puts stuff on plist of name. Once we're in level-1, na=
mes can
;; be more complicated than just a symbol, so just collect all cal=
ls until
;; the real record-source-file is loaded.
(when *record-source-file*
(unless (listp *record-source-file*)
(setq *record-source-file* nil))
- (push (list name def-type file-name) *record-source-file*))))
+ (push (list name def-type source) *record-source-file*))))
=
(fset 'record-source-file #'level-1-record-source-file)
=
@@ -650,8 +651,6 @@
(if (self-evaluating-p form) form
(report-bad-arg form '(satisfies constantp))))))
=
-;;; avoid hanging onto beezillions of pathnames
-(defvar *last-back-translated-name* nil)
(defvar *lfun-names*)
=
=
Modified: trunk/source/level-1/level-1.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/level-1/level-1.lisp (original)
+++ trunk/source/level-1/level-1.lisp Sun Nov 16 10:35:28 2008
@@ -97,6 +97,7 @@
;; Without this, forms from the -e command line parameter would run with
;; *loading-file-source-file* set to "l1-boot-3".
(setq *loading-file-source-file* nil)
+ (setq *loading-toplevel-location* nil)
)
=
(require "PREPARE-MCL-ENVIRONMENT")
Modified: trunk/source/lib/ccl-export-syms.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/lib/ccl-export-syms.lisp (original)
+++ trunk/source/lib/ccl-export-syms.lisp Sun Nov 16 10:35:28 2008
@@ -39,6 +39,20 @@
edit-definition
edit-definition-p
*loading-file-source-file*
+ find-definition-sources
+ define-definition-type
+ *save-source-locations*
+ function-source-note
+ source-note
+ source-note-p
+ source-note-filename
+ source-note-start-pos
+ source-note-end-pos
+ source-note-text
+ ensure-source-note-text
+ *record-pc-mapping*
+ find-source-note-at-pc
+
show-documentation
%set-toplevel
toplevel-loop
@@ -873,7 +887,9 @@
(unless (eq %lisp-system-fixups% T)
(while %lisp-system-fixups%
(let* ((fn.source (car %lisp-system-fixups%))
- (*loading-file-source-file* (cdr fn.source)))
+ (*loading-toplevel-location* (and (source-note-p (cdr fn.source=
)) (cdr fn.source)))
+ (*loading-file-source-file* (source-note-filename (cdr fn.sourc=
e)))
+ )
(funcall (car fn.source)))
(setq %lisp-system-fixups% (cdr %lisp-system-fixups%)))
(setq %lisp-system-fixups% T))
Modified: trunk/source/lib/macros.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/lib/macros.lisp (original)
+++ trunk/source/lib/macros.lisp Sun Nov 16 10:35:28 2008
@@ -1592,7 +1592,7 @@
`(let ((,fn #'(lambda () , at body)))
(if (eq %lisp-system-fixups% T)
(funcall ,fn)
- (push (cons ,fn *loading-file-source-file*) %lisp-system-fixups%))))
+ (push (cons ,fn (or *loading-toplevel-location* *loading-file-sourc=
e-file*)) %lisp-system-fixups%))))
=
(defmacro %incf-ptr (p &optional (by 1))
(if (symbolp p) ;once-only
Modified: trunk/source/lib/misc.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/lib/misc.lisp (original)
+++ trunk/source/lib/misc.lisp Sun Nov 16 10:35:28 2008
@@ -759,6 +759,22 @@
=
(%fhave 'df #'disassemble)
=
+(defun string-sans-most-whitespace (string &optional (max-length (length s=
tring)))
+ (with-output-to-string (sans-whitespace)
+ (loop
+ for count below max-length
+ for char across string
+ with just-saw-space =3D nil
+ if (member char '(#\Space #\Tab #\Newline #\Return #\Formfeed))
+ do (if just-saw-space
+ (decf count)
+ (write-char #\Space sans-whitespace))
+ and do (setf just-saw-space t)
+ else
+ do (setf just-saw-space nil)
+ and do (write-char char sans-whitespace))))
+
+
(defloadvar *use-cygwin-svn*
#+windows-target (not (null (getenv "CYGWIN")))
#-windows-target nil)
Modified: trunk/source/lib/nfcomp.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/lib/nfcomp.lisp (original)
+++ trunk/source/lib/nfcomp.lisp Sun Nov 16 10:35:28 2008
@@ -44,16 +44,24 @@
(require "X8664-ARCH")
) ;eval-when (:compile-toplevel :execute)
=
+; inited in l1-init, this is for when loading into a lisp that doesn't hav=
e it yet.
+#-BOOTSTRAPPED (eval-when (compile load eval)
+ (unless (boundp '*LOADING-TOPLEVEL-LOCATION*)
+ (declaim (special *loading-toplevel-location*))
+ (defparameter *save-source-locations* nil)))
+
;File compiler options. Not all of these need to be exported/documented, =
but
;they should be in the product just in case we need them for patches....
(defvar *fasl-save-local-symbols* t)
+(defvar *fasl-save-doc-strings* t)
+(defvar *fasl-save-definitions* nil)
+
(defvar *fasl-deferred-warnings* nil)
(defvar *fasl-non-style-warnings-signalled-p* nil)
(defvar *fasl-warnings-signalled-p* nil)
+
(defvar *compile-verbose* nil ; Might wind up getting called *compile-FILE=
-verbose*
"The default for the :VERBOSE argument to COMPILE-FILE.")
-(defvar *fasl-save-doc-strings* t)
-(defvar *fasl-save-definitions* nil)
(defvar *compile-file-pathname* nil
"The defaulted pathname of the file currently being compiled, or NIL if =
not
compiling.") ; pathname of src arg to COMPILE-FILE
@@ -124,11 +132,17 @@
(save-local-symbols *fasl-save-local-symbols*)
(save-doc-strings *fasl-save-doc-strings*)
(save-definitions *fasl-save-definitions*)
- (break-on-program-errors *fasl-break-on-program-e=
rrors*)
+ (save-source-locations *save-source-locations*)
(external-format :default)
- force)
- "Compile INPUT-FILE, producing a corresponding fasl file and returning
- its filename."
+ force
+ ;; src may be a temp file with a section of the r=
eal source,
+ ;; then this is the real source file name.
+ compile-file-original-truename
+ (compile-file-original-buffer-offset 0)
+ (break-on-program-errors (if compile-file-origina=
l-truename
+ t ;; really SLIME bei=
ng interactive...
+ *fasl-break-on-program=
-errors*)))
+ "Compile SRC, producing a corresponding fasl file and returning its file=
name."
(let* ((backend *target-backend*))
(when (and target-p (not (setq backend (find-backend target))))
(warn "Unknown :TARGET : ~S. Reverting to ~s ..." target *fasl-targ=
et*)
@@ -137,8 +151,9 @@
(restart-case
(return (%compile-file src output-file verbose print load features
save-local-symbols save-doc-strings save-d=
efinitions
- break-on-program-errors
- force backend external-format))
+ save-source-locations break-on-program-err=
ors
+ force backend external-format
+ compile-file-original-truename compile-fil=
e-original-buffer-offset))
(retry-compile-file ()
:report (lambda (stream) (format stream "Retry compiling ~s" src))
nil)
@@ -150,12 +165,11 @@
=
(defun %compile-file (src output-file verbose print load features
save-local-symbols save-doc-strings save-definit=
ions
- break-on-program-errors
+ save-source-locations break-on-program-errors
force target-backend external-format
- &aux orig-src)
-
- (setq orig-src (merge-pathnames src))
- (let* ((output-default-type (backend-target-fasl-pathname target-backend=
)))
+ compile-file-original-truename compile-file-orig=
inal-buffer-offset)
+ (let* ((orig-src (merge-pathnames src))
+ (output-default-type (backend-target-fasl-pathname target-backend=
)))
(setq src (fcomp-find-file orig-src))
(let* ((newtype (pathname-type src)))
(when (and newtype (not (pathname-type orig-src)))
@@ -184,6 +198,7 @@
(let* ((*features* (append (if (listp features) features (list featu=
res)) (setup-target-features target-backend *features*)))
(*fasl-deferred-warnings* nil) ; !!! WITH-COMPILATION-UNIT ...
(*fasl-save-local-symbols* save-local-symbols)
+ (*save-source-locations* save-source-locations)
(*fasl-save-doc-strings* save-doc-strings)
(*fasl-save-definitions* save-definitions)
(*fasl-break-on-program-errors* break-on-program-errors)
@@ -208,7 +223,10 @@
(rplacd (defenv.type defenv) *outstanding-deferred-warnings*)
(setf (defenv.defined defenv) (deferred-warnings.defs *outstan=
ding-deferred-warnings*))
=
- (setq forms (fcomp-file src orig-src lexenv))
+ (setq forms (fcomp-file src
+ (or compile-file-original-truename ori=
g-src)
+ compile-file-original-buffer-offset
+ lexenv))
=
(setf (deferred-warnings.warnings *outstanding-deferred-warnin=
gs*) =
(append *fasl-deferred-warnings* (deferred-warnings.warn=
ings *outstanding-deferred-warnings*)))
@@ -261,7 +279,11 @@
=
(defun %compile-time-eval (form env)
(declare (ignore env))
- (let* ((*target-backend* *host-backend*))
+ (let* ((*target-backend* *host-backend*)
+ (*loading-toplevel-location* (or (fcomp-source-note form)
+ *loading-toplevel-location*))
+ (lambda `(lambda () ,form)))
+ (fcomp-note-source-transformation form lambda)
;; The HANDLER-BIND here is supposed to note WARNINGs that're
;; signaled during (eval-when (:compile-toplevel) processing; this
;; in turn is supposed to satisfy a pedantic interpretation of the
@@ -275,7 +297,8 @@
(setq *fasl-non-style-warnings-signalled-p=
* t))
(signal c))))
(funcall (compile-named-function
- `(lambda () ,form)
+ lambda
+ :source-notes *fcomp-source-note-map*
:env *fasl-compile-time-env*
:policy *compile-time-evaluation-policy*)))))
=
@@ -345,6 +368,8 @@
(defvar *fcomp-eval-always-functions* nil) ; used by the LISP package
(defvar *fcomp-output-list*)
(defvar *fcomp-toplevel-forms*)
+(defvar *fcomp-source-note-map* nil)
+(defvar *fcomp-loading-toplevel-location*)
(defvar *fcomp-warnings-header*)
(defvar *fcomp-stream-position* nil)
(defvar *fcomp-previous-position* nil)
@@ -378,7 +403,7 @@
(getf *fcomp-print-handler-plist* 'include) '(nil . t))
=
=
-(defun fcomp-file (filename orig-file env) ; orig-file is back-translated
+(defun fcomp-file (filename orig-file orig-offset env) ; orig-file is bac=
k-translated
(let* ((*package* *package*)
(*compiling-file* filename)
(*nx-compile-time-types* *nx-compile-time-types*)
@@ -395,7 +420,7 @@
(*fcomp-indentation* 0)
(*fcomp-last-compile-print* (cons nil (cons nil nil))))
(push (list $fasl-platform (backend-target-platform *fasl-backend*)) *=
fcomp-output-list*)
- (fcomp-read-loop filename orig-file env :not-compile-time)
+ (fcomp-read-loop filename orig-file orig-offset env :not-compile-time)
(nreverse *fcomp-output-list*)))
=
(defun fcomp-find-file (file &aux path)
@@ -407,34 +432,32 @@
;;; orig-file is back-translated when from fcomp-file
;;; when from fcomp-include it's included filename merged with *compiling-=
file*
;;; which is not back translated
-(defun fcomp-read-loop (filename orig-file env processing-mode)
+(defun fcomp-read-loop (filename orig-file orig-offset env processing-mode)
(when *compile-verbose*
(format t "~&;~A ~S..."
(if (eq filename *compiling-file*) "Compiling" " Including")
filename))
(with-open-file (stream filename
- :element-type 'base-char
- :external-format *fcomp-external-format*)
- (let* ((old-file (and (neq filename *compiling-file*) *fasl-source-fil=
e*)) =
+ :element-type 'base-char
+ :external-format *fcomp-external-format*)
+ (let* ((old-file (and (neq filename *compiling-file*) *fasl-source-fil=
e*))
(*fasl-source-file* filename)
(*fcomp-toplevel-forms* nil)
(*fasl-eof-forms* nil)
- (*loading-file-source-file* (namestring orig-file)) ; why orig-=
file???
+ (*loading-file-source-file* (namestring orig-file))
+ (*fcomp-source-note-map* (and *save-source-locations*
+ (make-hash-table :test #'eq :shar=
ed nil)))
+ (*loading-toplevel-location* nil)
+ (*fcomp-loading-toplevel-location* nil)
(eofval (cons nil nil))
(read-package nil)
form)
- (declare (special *fasl-eof-forms* *fcomp-toplevel-forms* *fasl-sour=
ce-file*))
- ;;This should really be something like `(set-loading-source
- ;;,filename) but then couldn't compile level-1 with this... ->
- ;;In any case, change this to be a fasl opcode, so don't make an
- ;;lfun just to do this... There are other reasons - more
- ;;compelling ones than "fear of tiny lfuns" - for making this a
- ;;fasl opcode.
+
(fcomp-output-form $fasl-src env *loading-file-source-file*)
(let* ((*fcomp-previous-position* nil))
(loop
(let* ((*fcomp-stream-position* (file-position stream))
- (*nx-warnings* nil))
+ (*nx-warnings* nil)) ;; catch any warnings from :compile-=
toplevel forms
(unless (eq read-package *package*)
(fcomp-compile-toplevel-forms env)
(setq read-package *package*))
@@ -446,8 +469,21 @@
((error #'(lambda (c) ; we should distinguish read err=
ors from others?
(format *error-output* "~&Read error betwe=
en positions ~a and ~a in ~a." pos (file-position stream) filename)
(signal c))))
- (setq form (read stream nil eofval)))))
- (when (eq eofval form) (return))
+ (multiple-value-setq (form *loading-toplevel-location*)
+ (if *fcomp-source-note-map* ;; #-BOOTSTRAPPED
+ (read-recording-source stream
+ :eofval eofval
+ :file-name *loading-file-sour=
ce-file*
+ :start-offset orig-offset
+ :map *fcomp-source-note-map*
+ :save-source-text (neq *save-=
source-locations* :no-text))
+ (read-recording-source stream
+ :eofval eofval
+ :file-name *loading-file-sour=
ce-file*
+ :start-offset orig-offset))))=
))
+ (when (eq eofval form)
+ (require-type *loading-toplevel-location* 'null)
+ (return))
(fcomp-form form env processing-mode)
(fcomp-signal-or-defer-warnings *nx-warnings* env)
(setq *fcomp-previous-position* *fcomp-stream-position*))))
@@ -500,16 +536,16 @@
" (Compiletime)"
"")))))))
(fcomp-form-1 form env processing-mode)))
- =
+
(defun fcomp-form-1 (form env processing-mode &aux sym body)
(if (consp form) (setq sym (%car form) body (%cdr form)))
(case sym
(progn (fcomp-form-list body env processing-mode))
- (eval-when (fcomp-eval-when body env processing-mode))
- (compiler-let (fcomp-compiler-let body env processing-mode))
- (locally (fcomp-locally body env processing-mode))
- (macrolet (fcomp-macrolet body env processing-mode))
- (symbol-macrolet (fcomp-symbol-macrolet body env processing-mode))
+ (eval-when (fcomp-eval-when form env processing-mode))
+ (compiler-let (fcomp-compiler-let form env processing-mode))
+ (locally (fcomp-locally form env processing-mode))
+ (macrolet (fcomp-macrolet form env processing-mode))
+ (symbol-macrolet (fcomp-symbol-macrolet form env processing-mode))
((%include include) (fcomp-include form env processing-mode))
(t
;;Need to macroexpand to see if get more progn's/eval-when's and so s=
hould
@@ -518,17 +554,18 @@
;; Good advice, but the hard part is knowing which is which.
(cond =
((and (non-nil-symbol-p sym)
- (macro-function sym env) =
+ (macro-function sym env)
(not (compiler-macro-function sym env))
(not (eq sym '%defvar-init)) ; a macro that we want to speci=
al-case
- (multiple-value-bind (new win) (macroexpand-1 form env)
+ (multiple-value-bind (new win) (fcomp-macroexpand-1 form env)
(if win (setq form new))
win))
(fcomp-form form env processing-mode))
((and (not *fcomp-inside-eval-always*)
(memq sym *fcomp-eval-always-functions*))
- (let* ((*fcomp-inside-eval-always* t))
- (fcomp-form-1 `(eval-when (:execute :compile-toplevel :load-topl=
evel) ,form) env processing-mode)))
+ (let* ((*fcomp-inside-eval-always* t)
+ (new `(eval-when (:execute :compile-toplevel :load-toplevel=
) ,form)))
+ (fcomp-form-1 new env processing-mode)))
(t
(when (or (eq processing-mode :compile-time) (eq processing-mode :=
compile-time-too))
(%compile-time-eval form env))
@@ -547,25 +584,29 @@
(t (fcomp-random-toplevel-form form env)))))))))
=
(defun fcomp-form-list (forms env processing-mode)
- (dolist (form forms) (fcomp-form form env processing-mode)))
-
-(defun fcomp-compiler-let (form env processing-mode &aux vars varinits)
+ (let* ((outer *loading-toplevel-location*))
+ (dolist (form forms)
+ (setq *loading-toplevel-location* (or (fcomp-source-note form) outer=
))
+ (fcomp-form form env processing-mode))
+ (setq *loading-toplevel-location* outer)))
+
+(defun fcomp-compiler-let (form env processing-mode &aux vars varinits (bo=
dy (%cdr form)))
(fcomp-compile-toplevel-forms env)
- (dolist (pair (pop form))
+ (dolist (pair (car body))
(push (nx-pair-name pair) vars)
(push (%compile-time-eval (nx-pair-initform pair) env) varinits))
(progv (nreverse vars) (nreverse varinits)
- (fcomp-form-list form env processing-mode)
- (fcomp-compile-toplevel-forms env)))
-
-(defun fcomp-locally (body env processing-mode)
+ (fcomp-form-list (cdr body) env processing-mode)
+ (fcomp-compile-toplevel-forms env)))
+
+(defun fcomp-locally (form env processing-mode &aux (body (%cdr form)))
(fcomp-compile-toplevel-forms env)
(multiple-value-bind (body decls) (parse-body body env)
(let* ((env (augment-environment env :declare (decl-specs-from-declara=
tions decls))))
(fcomp-form-list body env processing-mode)
(fcomp-compile-toplevel-forms env))))
=
-(defun fcomp-macrolet (body env processing-mode)
+(defun fcomp-macrolet (form env processing-mode &aux (body (%cdr form)))
(fcomp-compile-toplevel-forms env)
(let ((outer-env (augment-environment env =
:macro
@@ -581,7 +622,7 @@
(fcomp-form-list body env processing-mode)
(fcomp-compile-toplevel-forms env)))))
=
-(defun fcomp-symbol-macrolet (body env processing-mode)
+(defun fcomp-symbol-macrolet (form env processing-mode &aux (body (%cdr fo=
rm)))
(fcomp-compile-toplevel-forms env)
(let* ((outer-env (augment-environment env :symbol-macro (car body))))
(multiple-value-bind (body decls) (parse-body (cdr body) env)
@@ -589,8 +630,8 @@
:declare (decl-specs-from-declarati=
ons decls))))
(fcomp-form-list body env processing-mode)
(fcomp-compile-toplevel-forms env)))))
- =
-(defun fcomp-eval-when (form env processing-mode &aux (eval-times (pop for=
m)))
+
+(defun fcomp-eval-when (form env processing-mode &aux (body (%cdr form)) (=
eval-times (pop body)))
(let* ((compile-time-too (eq processing-mode :compile-time-too))
(compile-time-only (eq processing-mode :compile-time))
(at-compile-time nil)
@@ -607,13 +648,13 @@
when eval-times *fasl-source-file*)))))
(fcomp-compile-toplevel-forms env) ; always flush the suckers
(cond (compile-time-only
- (if at-eval-time (fcomp-form-list form env :compile-time)))
+ (if at-eval-time (fcomp-form-list body env :compile-time)))
(at-load-time
- (fcomp-form-list form env (if (or at-compile-time (and at-eval-=
time compile-time-too))
+ (fcomp-form-list body env (if (or at-compile-time (and at-eval-=
time compile-time-too))
:compile-time-too
:not-compile-time)))
((or at-compile-time (and at-eval-time compile-time-too))
- (fcomp-form-list form env :compile-time))))
+ (fcomp-form-list body env :compile-time))))
(fcomp-compile-toplevel-forms env))
=
(defun fcomp-include (form env processing-mode &aux file)
@@ -626,7 +667,7 @@
(when *compile-print* (format t "~&~vTIncluding file ~A~%" *fcomp-inde=
ntation* actual))
(let ((*fcomp-indentation* (+ 4 *fcomp-indentation*))
(*package* *package*))
- (fcomp-read-loop (fcomp-find-file actual) actual env processing-mode)
+ (fcomp-read-loop (fcomp-find-file actual) actual 0 env processing-mo=
de)
(fcomp-output-form $fasl-src env *loading-file-source-file*))
(when *compile-print* (format t "~&~vTFinished included file ~A~%" *fc=
omp-indentation* actual))))
=
@@ -653,7 +694,7 @@
(setq doc nil))
(if (quoted-form-p sym)
(setq sym (%cadr sym)))
- (if (and (typep sym 'symbol) (or (quoted-form-p valform) (self-evalua=
ting-p valform)))
+ (if (and (typep sym 'symbol) (or (quoted-form-p valform) (self-evaluat=
ing-p valform)))
(fcomp-output-form $fasl-defconstant env sym (eval-constant valform)=
(eval-constant doc))
(fcomp-random-toplevel-form form env))))
=
@@ -663,8 +704,9 @@
(setq doc nil))
(if (quoted-form-p sym)
(setq sym (%cadr sym)))
- (let* ((fn (fcomp-function-arg valform env)))
- (if (and (typep sym 'symbol) (or fn (constantp valform)))
+ (let* ((sym-p (typep sym 'symbol))
+ (fn (and sym-p (fcomp-function-arg valform env))))
+ (if (and sym-p (or fn (constantp valform)))
(fcomp-output-form $fasl-defparameter env sym (or fn (eval-constan=
t valform)) (eval-constant doc))
(fcomp-random-toplevel-form form env)))))
=
@@ -685,10 +727,8 @@
(let* ((fn (if sym-p (fcomp-function-arg valform env))))
(if (and sym-p (or fn (constantp valform)))
(fcomp-output-form $fasl-defvar-init env sym (or fn (eval-cons=
tant valform)) (eval-constant doc))
- (fcomp-random-toplevel-form (macroexpand-1 form env) env)))))))
+ (fcomp-random-toplevel-form form env)))))))
=
-
-
(defun define-compile-time-macro (name lambda-expression env)
(let ((compile-time-defenv (definition-environment *fasl-compile-time-en=
v*))
(definition-env (definition-environment env)))
@@ -718,7 +758,7 @@
(defun fcomp-proclaim-type (type syms)
(dolist (sym syms)
(if (symbolp sym)
- (push (cons sym type) *nx-compile-time-types*)
+ (push (cons sym type) *nx-compile-time-types*)
(warn "~S isn't a symbol in ~S type declaration while compiling ~S."
sym type *fasl-source-file*))))
=
@@ -816,10 +856,25 @@
structrefs))))
(setf (defenv.structrefs defenv) structrefs)))))
=
-
+(defun fcomp-source-note (form &aux (notes *fcomp-source-note-map*))
+ (and notes (gethash form notes)))
+
+(defun fcomp-note-source-transformation (original new)
+ (let* ((*nx-source-note-map* *fcomp-source-note-map*))
+ (nx-note-source-transformation original new)))
+
+(defun fcomp-macroexpand-1 (form env)
+ (let* ((*nx-source-note-map* *fcomp-source-note-map*))
+ (multiple-value-bind (new win)
+ (macroexpand-1 form env)
+ (when win
+ (nx-note-source-transformation form new))
+ (values new win))))
=
(defun fcomp-transform (form env)
- (nx-transform form env))
+ (let* ((*nx-source-note-map* *fcomp-source-note-map*))
+ (nx-transform form env)))
+
=
(defun fcomp-random-toplevel-form (form env)
(unless (constantp form)
@@ -830,27 +885,36 @@
;;top-level compiles.
;;This assumes the form has been macroexpanded, or at least none of =
the
;;non-evaluated macro arguments could look like functions.
- (let (lfun (args (%cdr form)))
- (while args
- (multiple-value-bind (arg win) (fcomp-transform (%car args) env)
- (when (or (setq lfun (fcomp-function-arg arg env))
- win)
- (when lfun (setq arg `',lfun))
- (labels ((subst-l (new ptr list)
- (if (eq ptr list) (cons new (cdr list))
- (cons (car list) (subst-l new ptr (%cdr list)))=
)))
- (setq form (subst-l arg args form))))
- (setq args (%cdr args))))))
+ (let ((new-form (make-list (length form))))
+ (declare (dynamic-extent new-form))
+ (loop for arg in (%cdr form) for newptr on (%cdr new-form)
+ do (setf (%car newptr)
+ (multiple-value-bind (new win) (fcomp-transform arg=
env)
+ (let ((lfun (fcomp-function-arg new env)))
+ (when lfun
+ (setq new `',lfun win t)
+ (fcomp-note-source-transformation arg new)))
+ (if win new arg))))
+ (unless (every #'eq (%cdr form) (%cdr new-form))
+ (setf (%car new-form) (%car form))
+ (fcomp-note-source-transformation form (setq form (copy-list new=
-form))))))
+ (fcomp-ensure-source env)
(push form *fcomp-toplevel-forms*)))
=
(defun fcomp-function-arg (expr env)
(when (consp expr)
- (if (and (eq (%car expr) 'nfunction)
- (lambda-expression-p (cadr (%cdr expr))))
- (fcomp-named-function (%caddr expr) (%cadr expr) env)
- (if (and (eq (%car expr) 'function)
- (lambda-expression-p (car (%cdr expr))))
- (fcomp-named-function (%cadr expr) nil env)))))
+ (multiple-value-bind (lambda-expr name win)
+ (cond ((and (eq (%car expr) 'nfunction)
+ (lambda-expression-p (cadr (%cdr expr))))
+ (values (%caddr expr) (%cadr expr) t))
+ ((and (eq (%car expr) 'function)
+ (lambda-expression-p (car (%cdr expr))))
+ (values (%cadr expr) nil t)))
+ (when win
+ (fcomp-named-function lambda-expr name env
+ (or (fcomp-source-note expr)
+ (fcomp-source-note lambda-expr)
+ *loading-toplevel-location*))))))
=
(defun fcomp-compile-toplevel-forms (env)
(when *fcomp-toplevel-forms*
@@ -882,23 +946,34 @@
(setq *fcomp-toplevel-forms* (nreverse forms))
(fcomp-compile-toplevel-forms env))))))))
=
+(defun fcomp-ensure-source (env)
+ ;; if source location saving is off, both values are NIL, so this will d=
o nothing,
+ ;; don't need to check explicitly.
+ (unless (eq *fcomp-loading-toplevel-location* *loading-toplevel-location=
*)
+ (setq *fcomp-loading-toplevel-location* *loading-toplevel-location*)
+ (fcomp-output-form $fasl-toplevel-location env *loading-toplevel-locat=
ion*)))
+
(defun fcomp-output-form (opcode env &rest args)
+ (fcomp-ensure-source env)
(when *fcomp-toplevel-forms* (fcomp-compile-toplevel-forms env))
(push (cons opcode args) *fcomp-output-list*))
+
=
;;; Compile a lambda expression for the sole purpose of putting it in a fa=
sl
;;; file. The result will not be funcalled. This really shouldn't bother
;;; making an lfun, but it's simpler this way...
-(defun fcomp-named-function (def name env)
+(defun fcomp-named-function (def name env &optional source-note)
(let* ((env (new-lexical-environment env))
(*nx-break-on-program-errors* (not (memq *fasl-break-on-program-e=
rrors* '(nil :defer)))))
(multiple-value-bind (lfun warnings)
(compile-named-function def
:name name
:env env
+ :function-note source-note
:keep-lambda *fasl-save-definitions*
:keep-symbols *fasl-save-local-symbols*
:policy *default-file-compilation-policy*
+ :source-notes *fcomp-source-note-map*
:load-time-eval-token cfasl-load-time-eval=
-sym
:target *fasl-target*)
(fcomp-signal-or-defer-warnings warnings env)
@@ -961,7 +1036,7 @@
:rehash-threshold 0.9
:test 'eq
:shared nil))
- (*make-load-form-hash* (make-hash-table :test 'eq))
+ (*make-load-form-hash* (make-hash-table :test 'eq :shared nil))
(*fasdump-read-package* nil)
(*fasdump-global-offsets* nil)
(gsymbols nil))
@@ -1135,6 +1210,9 @@
(fasl-scan-form (%cdr list))))))
=
(defun fasl-scan-user-form (form)
+ (when (or (source-note-p form)
+ (code-note-p form))
+ (return-from fasl-scan-user-form (fasl-scan-gvector form)))
(multiple-value-bind (load-form init-form) (make-load-form form *fcomp-l=
oad-forms-environment*)
(labels ((simple-load-form (form)
(or (atom form)
Modified: trunk/source/lib/source-files.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/lib/source-files.lisp (original)
+++ trunk/source/lib/source-files.lisp Sun Nov 16 10:35:28 2008
@@ -547,11 +547,31 @@
unless (definition-same-p *method-definition-type* m name)
do (setq list (nconc (find-definition-sources m 'method)=
list))))))
;; Convert to old format, (type-or-name . file)
- (loop for ((dt . full-name) . files) in list
+ (loop for ((dt . full-name) . sources) in list
as spec =3D (if (eq full-name name) (definition-type-name dt) fu=
ll-name)
- nconc (mapcan (lambda (file) (when file (list (cons spec file)))=
) files))))
-
-
+ nconc (mapcan (lambda (s)
+ (when s (list (cons spec (source-note-filename s=
)))))
+ sources))))
+
+
+;; For ilisp.
+(defun %source-files (name)
+ (let ((type-list ())
+ (meth-list ()))
+ (loop for ((dt . full-name) . sources) in (find-definition-sources nam=
e t)
+ as files =3D (mapcan #'(lambda (s)
+ (and s (setq s (source-note-filename s)) =
(list s)))
+ sources)
+ when files
+ do (if (typep dt 'method-definition-type)
+ (dolist (file files)
+ (push (cons full-name file) meth-list))
+ (push (cons (definition-type-name dt) files) type-list)))
+ (when meth-list
+ (push (cons 'method meth-list) type-list))
+ type-list))
+
+;; For CVS slime as of 11/15/2008.
(defun get-source-files-with-types&classes (sym &optional (type t) classes=
qualifiers the-method)
(let* ((name (or the-method
(and (or (eq type 'method) classes qualifiers)
@@ -560,20 +580,9 @@
(get-source-files-with-types name type)))
=
=
-;; For ilisp.
-(defun %source-files (name)
- (let ((type-list ())
- (meth-list ()))
- (loop for ((dt . full-name) . files) in (find-definition-sources name =
t)
- do (if (typep dt 'method-definition-type)
- (dolist (file files)
- (push (cons full-name file) meth-list))
- (push (cons (definition-type-name dt) files) type-list)))
- (when meth-list
- (push (cons 'method meth-list) type-list))
- type-list))
-
-;;; For swank.
+#|
+;; For working-0711 versions of slime, but this doesn't actually work since
+;; source-note representations are not compatible
=
(defun find-definitions-for-name (name &optional (type-name t))
"Returns a list of (TYPE . DEFINITION-SOURCE) for all the known definiti=
ons of NAME."
@@ -590,6 +599,7 @@
(let* ((dt (car pair)))
(when (typep dt 'definition-type)
(setf (car pair) (definition-type-name dt)))))))
+|#
=
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;=
;;;;;;;;;;;;;;;;;;;;;
;;; record-source-file
@@ -622,7 +632,7 @@
specs))
(values name quals specs)))))))
=
-(defmethod record-definition-source ((dt definition-type) name file-name)
+(defmethod record-definition-source ((dt definition-type) name source)
(let* ((key (definition-base-name dt name))
(all (%source-file-entries key))
(e-loc nil)
@@ -632,17 +642,19 @@
(definition-same-p dt name (def-source-entry.name =
key entry)))
(setq e-files (def-source-entry.sources key entry))
(let ((old (flet ((same-file (x y)
+ (setq x (source-note-filename x))
+ (setq y (source-note-filename y))
(or (equal x y)
(and x
y
(equal
(or (probe-file x) (full-path=
name x))
(or (probe-file y) (full-path=
name y)))))))
- (member file-name e-files :test #'same-file))))
- (when (and old (neq file-name (car e-files))) ;; move to =
front
- (setq e-files (cons file-name (remove (car old) e-files=
:test #'eq)))))
+ (member source e-files :test #'same-file))))
+ (when (and old (neq source (car e-files))) ;; move to fro=
nt
+ (setq e-files (cons source (remove (car old) e-files :t=
est #'eq)))))
(return (setq e-loc ptr))))
- (unless (and e-files (eq file-name (car e-files)))
+ (unless (and e-files (eq source (car e-files)))
;; Never previously defined in this file
(when (and (car e-files) ; don't warn if last defined int=
eractively
*warn-if-redefine*
@@ -650,9 +662,9 @@
(warn "~A ~S previously defined in: ~A is now being redefined in: =
~A~%"
(definition-type-name dt)
name
- (car e-files)
- (or file-name "{No file}")))
- (setq e-files (cons file-name e-files)))
+ (source-note-filename (car e-files))
+ (or (source-note-filename source) "{No file}")))
+ (setq e-files (cons source e-files)))
(let ((entry (make-def-source-entry key dt name e-files)))
(if e-loc
(setf (car e-loc) entry)
@@ -660,30 +672,44 @@
(%set-source-file-entries key all))
name))
=
+;;; avoid hanging onto beezillions of pathnames
+(defparameter *last-back-translated-name* (cons nil nil))
+
;; Define the real record-source-file, which will be the last defn handled=
by the
;; bootstrapping record-source-file, so convert all queued up data right a=
fterwards.
-(progn
-
-(defun record-source-file (name def-type &optional (file-name *loading-fil=
e-source-file*))
- (when *record-source-file*
+(when (BOUNDP '*LOADING-TOPLEVEL-LOCATION*) ;; #-BOOTSTRAPPED
+
+(defun record-source-file (name def-type &optional (source (or *loading-to=
plevel-location*
+ *loading-fi=
le-source-file*)))
+ (when (and source *record-source-file*)
(with-lock-grabbed (*source-files-lock*)
- (when (and file-name (physical-pathname-p file-name))
- (setq file-name (namestring (back-translate-pathname file-name)))
- (cond ((equalp file-name *last-back-translated-name*)
- (setq file-name *last-back-translated-name*))
- (t (setq *last-back-translated-name* file-name))))
+ (let ((file-name (source-note-filename source)))
+ (unless (equalp file-name (car *last-back-translated-name*))
+ (setf (car *last-back-translated-name*) file-name)
+ (setf (cdr *last-back-translated-name*)
+ (if (physical-pathname-p file-name)
+ (namestring (back-translate-pathname file-name))
+ file-name)))
+ (setq file-name (cdr *last-back-translated-name*))
+ (if (source-note-p source)
+ (setf (source-note-filename source) file-name)
+ (setq source file-name)))
(when (eq def-type 't) (report-bad-arg def-type '(not (eql t))))
(record-definition-source (definition-type-instance def-type
:if-does-not-exist :create)
name
- file-name))))
+ source))))
=
;; Collect level-0 source file info
(do-all-symbols (s)
(let ((f (get s 'bootstrapping-source-files)))
(when f
- (setf (gethash s %source-files%) f)
+ (if (consp f)
+ (destructuring-bind ((type . source)) f
+ (when source (record-source-file s type source)))
+ (record-source-file s 'function f))
(remprop s 'bootstrapping-source-files))))
+
;; Collect level-1 source file info
(when (consp *record-source-file*)
(let ((list (nreverse (shiftf *record-source-file* t))))
Modified: trunk/source/library/leaks.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/library/leaks.lisp (original)
+++ trunk/source/library/leaks.lisp Sun Nov 16 10:35:28 2008
@@ -153,7 +153,7 @@
(setf (gethash (cdr cons) cons-refs) t)))
(loop for key being the hash-keys of found
when (or (and (consp key) (gethash key cons-refs))
- (and (consp key) (eq (car key) 'ccl::function-source-=
note))
+ (and (consp key) (eq (car key) 'ccl::%function-source=
-note))
(typep key 'ccl::hash-table-vector)
(when (and key
(typep key
Modified: trunk/source/xdump/xfasload.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/xdump/xfasload.lisp (original)
+++ trunk/source/xdump/xfasload.lisp Sun Nov 16 10:35:28 2008
@@ -1596,12 +1596,12 @@
=
=
(defun xload-record-source-file (symaddr indicator)
- ;; need to do something with *xload-loading-toplevel-location*
(when *xload-record-source-file-p*
(when (or (eq indicator 'function)
(eq indicator 'variable))
(let* ((keyaddr (xload-copy-symbol 'bootstrapping-source-files))
- (pathaddr (or *xload-loading-file-source-file*
+ (pathaddr (or *xload-loading-toplevel-location*
+ *xload-loading-file-source-file*
(if *loading-file-source-file*
(setq *xload-loading-file-source-file* (xload=
-save-string *loading-file-source-file*))))))
(when pathaddr
More information about the Openmcl-cvs-notifications
mailing list