[Openmcl-cvs-notifications] r11212 - in /trunk/source/compiler: PPC/ppc2.lisp X86/x862.lisp nx.lisp nx0.lisp nx1.lisp
gz at clozure.com
gz at clozure.com
Thu Oct 23 11:28:21 EDT 2008
Author: gz
Date: Thu Oct 23 11:28:21 2008
New Revision: 11212
Log:
Source location support in the compiler:
COMPILE-NAMED-FUNCTION takes a new SOURCE-NOTES arg, which should be nil or=
a hash table mapping source forms to source notes. In the latter case, th=
e compiler will do its best to track the source notes from the source all t=
he way through code generation, and create a pc/source map, storing it as t=
he 'pc-source-map property on the %lfun-info plist of the function and any =
inner functions. In addition, the compiler will store the source note of t=
he lambda form on the 'function-source-note property of the function and an=
y inner functions.
COMPILE-NAMED-FUNCTION also takes a new FUNCTION-NOTE arg which can be used=
to override the lambda source note indicated by SOURCE-NOTES.
Nothing actually passes in either of these arguments yet.
Also checking in some cases of acode-unwrapped-form -> acode-unwrapped-form=
-value, which have nothing to do with source locations but just help minimi=
ze diffs for easier merging.
Modified:
trunk/source/compiler/PPC/ppc2.lisp
trunk/source/compiler/X86/x862.lisp
trunk/source/compiler/nx.lisp
trunk/source/compiler/nx0.lisp
trunk/source/compiler/nx1.lisp
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 Thu Oct 23 11:28:21 2008
@@ -171,6 +171,7 @@
(defparameter *ppc2-inhibit-register-allocation* nil)
(defvar *ppc2-record-symbols* nil)
(defvar *ppc2-recorded-symbols* nil)
+(defvar *ppc2-emitted-source-notes* nil)
=
(defvar *ppc2-result-reg* ppc::arg_z)
=
@@ -410,6 +411,7 @@
(*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)
@@ -437,7 +439,8 @@
(*ppc2-entry-vsp-saved-p* nil)
(*ppc2-vcells* (ppc2-ensure-binding-indices-for-vcells (afunc-v=
cells afunc)))
(*ppc2-fcells* (afunc-fcells afunc))
- *ppc2-recorded-symbols*)
+ *ppc2-recorded-symbols*
+ (*ppc2-emitted-source-notes* '()))
(set-fill-pointer
*backend-labels*
(set-fill-pointer
@@ -466,18 +469,19 @@
(ppc2-expand-vinsns vinsns) =
(if (logbitp $fbitnonnullenv (the fixnum (afunc-bits af=
unc)))
(setq bits (+ bits (ash 1 $lfbits-nonnullenv-bit))))
- (let* ((function-debugging-info (afunc-lfun-info afunc)=
))
- (when (or function-debugging-info lambda-form *ppc2-r=
ecord-symbols*)
- (if lambda-form (setq function-debugging-info =
- (list* 'function-lambda-expre=
ssion lambda-form function-debugging-info)))
- (if *ppc2-record-symbols*
- (setq function-debugging-info (nconc (list 'funct=
ion-symbol-map *ppc2-recorded-symbols*)
- function-deb=
ugging-info)))
- (setq bits (logior (ash 1 $lfbits-info-bit) bits))
- (backend-new-immediate function-debugging-info)))
+ (setq debug-info (afunc-lfun-info afunc))
+ (when lambda-form
+ (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 debug-info
+ (setq bits (logior (ash 1 $lfbits-info-bit) bits))
+ (backend-new-immediate debug-info))
(if (or fname lambda-form *ppc2-recorded-symbols*)
(backend-new-immediate fname)
- (setq bits (logior (ash -1 $lfbits-noname-bit) bits))=
) =
+ (setq bits (logior (ash -1 $lfbits-noname-bit) bits)))
+
(unless (afunc-parent afunc)
(ppc2-fixup-fwd-refs afunc))
(setf (afunc-all-vars afunc) nil)
@@ -496,7 +500,10 @@
regsave-reg
regsave-addr
(if (and fname (symbolp fname)) (symbol-name f=
name)))))
- (ppc2-digest-symbols))))
+ (when (getf debug-info 'pc-source-map)
+ (setf (getf debug-info 'pc-source-map) (ppc2-generate=
-pc-source-map debug-info)))
+ (when (getf debug-info 'function-symbol-map)
+ (setf (getf debug-info 'function-symbol-map) (ppc2-di=
gest-symbols))))))
(backend-remove-labels))))
afunc))
=
@@ -556,8 +563,66 @@
(if (eq (%svref v i) ref)
(setf (%svref v i) ref-fun)))))))))
=
+(defun ppc2-generate-pc-source-map (debug-info)
+ (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))
+ (nvalid 0)
+ (max 0)
+ (pc-starts (make-array n))
+ (pc-ends (make-array n))
+ (text-starts (make-array n))
+ (text-ends (make-array n)))
+ (declare (fixnum n nvalid)
+ (dynamic-extent pc-starts pc-ends text-starts text-ends))
+ (dolist (start emitted-source-notes)
+ (let* ((pc-start (ppc2-vinsn-note-label-address start t))
+ (pc-end (ppc2-vinsn-note-label-address (vinsn-note-peer start=
) nil))
+ (source-note (aref (vinsn-note-info start) 0))
+ (text-start (- (source-note-start-pos source-note) def-start))
+ (text-end (- (source-note-end-pos source-note) def-start)))
+ (declare (fixnum pc-start pc-end text-start text-end))
+ (when (and (plusp pc-start)
+ (plusp pc-end)
+ (plusp text-start)
+ (plusp text-end))
+ (if (> pc-start max) (setq max pc-start))
+ (if (> pc-end max) (setq max pc-end))
+ (if (> text-start max) (setq max text-start))
+ (if (> text-end max) (setq max text-end))
+ (setf (svref pc-starts nvalid) pc-start
+ (svref pc-ends nvalid) pc-end
+ (svref text-starts nvalid) text-start
+ (svref text-ends nvalid) text-end)
+ (incf nvalid))))
+ (let* ((nentries (* nvalid 4))
+ (vec (cond ((< max #x100) (make-array nentries :element-type '(=
unsigned-byte 8)))
+ ((< max #x10000) (make-array nentries :element-type =
'(unsigned-byte 16)))
+ (t (make-array nentries :element-type '(unsigned-byt=
e 32))))))
+ (declare (fixnum nentries))
+ (do* ((i 0 (+ i 4))
+ (j 1 (+ j 4))
+ (k 2 (+ k 4))
+ (l 3 (+ l 4))
+ (idx 0 (1+ idx)))
+ ((=3D i nentries) vec)
+ (declare (fixnum i j k l idx))
+ (setf (aref vec i) (svref pc-starts idx)
+ (aref vec j) (svref pc-ends idx)
+ (aref vec k) (svref text-starts idx)
+ (aref vec l) (svref text-ends idx))))))
+
+(defun ppc2-vinsn-note-label-address (note &optional start-p sym)
+ (let* ((label (vinsn-note-label note))
+ (lap-label (if label (vinsn-label-info label))))
+ (if lap-label
+ (lap-label-address lap-label)
+ (compiler-bug "Missing or bad ~s label: ~s" =
+ (if start-p 'start 'end) sym))))
+
(defun ppc2-digest-symbols ()
- (if *ppc2-recorded-symbols*
+ (when *ppc2-recorded-symbols*
(let* ((symlist *ppc2-recorded-symbols*)
(len (length symlist))
(syms (make-array len))
@@ -567,22 +632,16 @@
(declare (fixnum i j))
(dolist (info symlist (progn (%rplaca symlist syms)
(%rplacd symlist ptrs)))
- (flet ((label-address (note start-p sym)
- (let* ((label (vinsn-note-label note))
- (lap-label (if label (vinsn-label-info label))))
- (if lap-label
- (lap-label-address lap-label)
- (compiler-bug "Missing or bad ~s label: ~s" =
- (if start-p 'start 'end) sym)))))
- (destructuring-bind (var sym startlab endlab) info
- (let* ((ea (var-ea var))
- (ea-val (ldb (byte 16 0) ea)))
- (setf (aref ptrs (incf i)) (if (memory-spec-p ea)
- (logior (ash ea-val 6) #o77)
- ea-val)))
- (setf (aref syms (incf j)) sym)
- (setf (aref ptrs (incf i)) (label-address startlab t sym))
- (setf (aref ptrs (incf i)) (label-address endlab nil sym))))))=
))
+ (destructuring-bind (var sym startlab endlab) info
+ (let* ((ea (var-ea var))
+ (ea-val (ldb (byte 16 0) ea)))
+ (setf (aref ptrs (incf i)) (if (memory-spec-p ea)
+ (logior (ash ea-val 6) #o77)
+ ea-val)))
+ (setf (aref syms (incf j)) sym)
+ (setf (aref ptrs (incf i)) (ppc2-vinsn-note-label-address startl=
ab t sym))
+ (setf (aref ptrs (incf i)) (ppc2-vinsn-note-label-address endlab=
nil sym))))
+ *ppc2-recorded-symbols*)))
=
(defun ppc2-decls (decls)
(if (fixnump decls)
@@ -996,22 +1055,32 @@
n))
=
=
-(defun ppc2-form (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 #.operator-id-m=
ask (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-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)))))))
+ (if note
+ (let* ((start (ppc2-emit-note seg :source-location-begin note))
+ (bits (main seg vreg xfer form))
+ (end (ppc2-emit-note seg :source-location-end)))
+ (setf (vinsn-note-peer start) end
+ (vinsn-note-peer end) start)
+ (push start *ppc2-emitted-source-notes*)
+ bits)
+ (main seg vreg xfer form))))
=
;;; dest is a float reg - form is acode
(defun ppc2-form-float (seg freg xfer form)
@@ -1249,7 +1318,7 @@
(cdar tagdata)))))))))
=
(defun ppc2-single-valued-form-p (form)
- (setq form (acode-unwrapped-form form))
+ (setq form (acode-unwrapped-form-value form))
(or (nx-null form)
(nx-t form)
(if (acode-p form)
@@ -2209,7 +2278,7 @@
(eq (ppc2-lexical-reference-p (%car reg-args)) =
rest))
(return nil))
(flet ((independent-of-all-values (form) =
- (setq form (acode-unwrapped-form form))
+ (setq form (acode-unwrapped-form-value form))
(or (ppc-constant-form-p form)
(let* ((lexref (ppc2-lexical-reference-p form)))
(and lexref =
@@ -2245,7 +2314,7 @@
(when spread-p
(destructuring-bind (stack-args reg-args) arglist
(when (and (null (cdr reg-args))
- (nx-null (acode-unwrapped-form (car reg-args))))
+ (nx-null (acode-unwrapped-form-value (car reg-args))))
(setq spread-p nil)
(let* ((nargs (length stack-args)))
(declare (fixnum nargs))
@@ -2333,7 +2402,7 @@
;;; Nargs =3D nil -> multiple-value case.
(defun ppc2-invoke-fn (seg fn nargs spread-p xfer)
(with-ppc-local-vinsn-macros (seg)
- (let* ((f-op (acode-unwrapped-form fn))
+ (let* ((f-op (acode-unwrapped-form-value fn))
(immp (and (consp f-op)
(eq (%car f-op) (%nx1-operator immediate))))
(symp (and immp (symbolp (%cadr f-op))))
@@ -2577,7 +2646,7 @@
=
=
(defun ppc2-immediate-function-p (f)
- (setq f (acode-unwrapped-form f))
+ (setq f (acode-unwrapped-form-value f))
(and (acode-p f)
(or (eq (%car f) (%nx1-operator immediate))
(eq (%car f) (%nx1-operator simple-function)))))
@@ -2606,7 +2675,7 @@
=
=
(defun ppc-side-effect-free-form-p (form)
- (when (consp (setq form (acode-unwrapped-form form)))
+ (when (consp (setq form (acode-unwrapped-form-value form)))
(or (ppc-constant-form-p form)
;(eq (acode-operator form) (%nx1-operator bound-special-ref))
(if (eq (acode-operator form) (%nx1-operator lexical-reference))
@@ -3291,7 +3360,7 @@
(^)))))
=
(defun ppc2-lexical-reference-ea (form &optional (no-closed-p t))
- (when (acode-p (setq form (acode-unwrapped-form form)))
+ (when (acode-p (setq form (acode-unwrapped-form-value form)))
(if (eq (acode-operator form) (%nx1-operator lexical-reference))
(let* ((addr (var-ea (%cadr form))))
(if (typep addr 'lreg)
@@ -3658,11 +3727,12 @@
(ppc2-open-undo $undostkblk)
(setq val node))))
((eq op (%nx1-operator %new-ptr))
- (let ((clear-form (caddr val)))
- (if (nx-constant-form-p clear-form)
+ (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 clear-form)
+ (if (nx-null cval)
(! make-stack-block)
(! make-stack-block0)))
(with-crf-target () crf
@@ -3685,7 +3755,7 @@
(ppc2-open-undo $undostkblk curstack)
(! make-stack-list)
(setq val ppc::arg_z)) =
- ((eq (%car val) (%nx1-operator vector))
+ ((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))
@@ -4320,7 +4390,7 @@
=
(defun ppc2-lexical-reference-p (form)
(when (acode-p form)
- (let ((op (acode-operator (setq form (acode-unwrapped-form form)))))
+ (let ((op (acode-operator (setq form (acode-unwrapped-form-value form)=
))))
(when (or (eq op (%nx1-operator lexical-reference))
(eq op (%nx1-operator inherited-arg)))
(%cadr form)))))
@@ -4479,7 +4549,7 @@
(defun ppc2-acode-needs-memoization (valform)
(if (ppc2-form-typep valform 'fixnum)
nil
- (let* ((val (acode-unwrapped-form valform)))
+ (let* ((val (acode-unwrapped-form-value valform)))
(if (or (eq val *nx-t*)
(eq val *nx-nil*)
(and (acode-p val)
@@ -4552,7 +4622,7 @@
;;; that register to RNIL.
;;; "XFER" is a compound destination.
(defun ppc2-conditional-form (seg xfer form)
- (let* ((uwf (acode-unwrapped-form form)))
+ (let* ((uwf (acode-unwrapped-form-value form)))
(if (nx-null uwf)
(ppc2-branch seg (ppc2-cd-false xfer) nil)
(if (ppc-constant-form-p uwf)
@@ -5054,15 +5124,16 @@
(defun ppc2-expand-note (note)
(let* ((lab (vinsn-note-label note)))
(case (vinsn-note-class note)
- ((:regsave :begin-variable-scope :end-variable-scope)
+ ((:regsave :begin-variable-scope :end-variable-scope
+ :source-location-begin :source-location-end)
(setf (vinsn-label-info lab) (emit-lap-label lab))))))
=
(defun ppc2-expand-vinsns (header)
(do-dll-nodes (v header)
(if (%vinsn-label-p v)
(let* ((id (vinsn-label-id v)))
- (if (typep id 'fixnum)
- (when (or t (vinsn-label-refs v))
+ (if (or (typep id 'fixnum) (null id))
+ (when (or t (vinsn-label-refs v) (null id))
(setf (vinsn-label-info v) (emit-lap-label v)))
(ppc2-expand-note id)))
(ppc2-expand-vinsn v)))
@@ -6161,9 +6232,9 @@
(^)))))
=
=
-(defppc2 ppc2-if if (seg vreg xfer testform true false)
- (if (nx-constant-form-p (acode-unwrapped-form testform))
- (ppc2-form seg vreg xfer (if (nx-null (acode-unwrapped-form testform))=
false true))
+(defppc2 ppc2-if if (seg vreg xfer testform true false &aux test-val)
+ (if (setq test-val (nx-constant-form-p (acode-unwrapped-form-value testf=
orm)))
+ (ppc2-form seg vreg xfer (if (nx-null test-val) false true))
(let* ((cstack *ppc2-cstack*)
(vstack *ppc2-vstack*)
(top-lcell *ppc2-top-vstack-lcell*)
@@ -9066,7 +9137,7 @@
=
(defppc2 ppc2-%double-float %double-float (seg vreg xfer arg)
(let* ((real (or (acode-fixnum-form-p arg)
- (let* ((form (acode-unwrapped-form arg)))
+ (let* ((form (acode-unwrapped-form-value arg)))
(if (and (acode-p form)
(eq (acode-operator form)
(%nx1-operator immediate))
@@ -9096,7 +9167,7 @@
=
(defppc2 ppc2-%single-float %single-float (seg vreg xfer arg)
(let* ((real (or (acode-fixnum-form-p arg)
- (let* ((form (acode-unwrapped-form arg)))
+ (let* ((form (acode-unwrapped-form-value arg)))
(if (and (acode-p form)
(eq (acode-operator form)
(%nx1-operator immediate))
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 Thu Oct 23 11:28:21 2008
@@ -199,6 +199,7 @@
(defparameter *x862-inhibit-register-allocation* nil)
(defvar *x862-record-symbols* nil)
(defvar *x862-recorded-symbols* nil)
+(defvar *x862-emitted-source-notes* nil)
=
(defvar *x862-result-reg* x8664::arg_z)
=
@@ -593,7 +594,8 @@
(*x862-entry-vsp-saved-p* nil)
(*x862-vcells* (x862-ensure-binding-indices-for-vcells (afunc-v=
cells afunc)))
(*x862-fcells* (afunc-fcells afunc))
- *x862-recorded-symbols*)
+ *x862-recorded-symbols*
+ (*x862-emitted-source-notes* '()))
(set-fill-pointer
*backend-labels*
(set-fill-pointer
@@ -688,15 +690,18 @@
=
(if (logbitp $fbitnonnullenv (the fixnum (afunc-bits af=
unc)))
(setq bits (+ bits (ash 1 $lfbits-nonnullenv-bit))))
- (let* ((function-debugging-info (afunc-lfun-info afunc)=
))
- (when (or function-debugging-info lambda-form *x862-r=
ecord-symbols*)
- (if lambda-form (setq function-debugging-info =
- (list* 'function-lambda-expre=
ssion lambda-form function-debugging-info)))
- (if *x862-record-symbols*
- (setq function-debugging-info (nconc (list 'funct=
ion-symbol-map *x862-recorded-symbols*)
- function-deb=
ugging-info)))
- (setq bits (logior (ash 1 $lfbits-info-bit) bits))
- (setq debug-info function-debugging-info)))
+ (setq debug-info (afunc-lfun-info afunc))
+ (when lambda-form
+ (setq debug-info
+ (list* 'function-lambda-expression lambda-form =
debug-info)))
+ (when *x862-record-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*)
+ (setq debug-info ;; Compressed be=
low
+ (list* 'pc-source-map *x862-emitted-source-note=
s* debug-info)))
+ (when debug-info
+ (setq bits (logior (ash 1 $lfbits-info-bit) bits)))
(unless (or fname lambda-form *x862-recorded-symbols*)
(setq bits (logior (ash 1 $lfbits-noname-bit) bits)))
(unless (afunc-parent afunc)
@@ -743,14 +748,19 @@
))
=
(x862-lap-process-regsave-info frag-list regsave-labe=
l regsave-mask regsave-addr)
+
+ (when (getf debug-info 'pc-source-map)
+ (setf (getf debug-info 'pc-source-map) (x862-genera=
te-pc-source-map debug-info)))
+ (when (getf debug-info 'function-symbol-map)
+ (setf (getf debug-info 'function-symbol-map) (x862-=
digest-symbols)))
+
(setf (afunc-lfun afunc)
#+x86-target
(if (eq *host-backend* *target-backend*)
(create-x86-function fname frag-list *x862-co=
nstant-alist* bits debug-info)
(cross-create-x86-function fname frag-list *x=
862-constant-alist* bits debug-info))
#-x86-target
- (cross-create-x86-function fname frag-list *x86=
2-constant-alist* bits debug-info)))
- (x862-digest-symbols)))))
+ (cross-create-x86-function fname frag-list *x86=
2-constant-alist* bits debug-info)))))))
(backend-remove-labels))))
afunc))
=
@@ -784,6 +794,56 @@
(declare (fixnum i))
(if (eq (%svref v i) ref)
(setf (%svref v i) ref-fun)))))))))
+
+(defun x862-generate-pc-source-map (debug-info)
+ (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))
+ (nvalid 0)
+ (max 0)
+ (pc-starts (make-array n))
+ (pc-ends (make-array n))
+ (text-starts (make-array n))
+ (text-ends (make-array n)))
+ (declare (fixnum n nvalid)
+ (dynamic-extent pc-starts pc-ends text-starts text-ends))
+ (dolist (start emitted-source-notes)
+ (let* ((pc-start (x862-vinsn-note-label-address start t))
+ (pc-end (x862-vinsn-note-label-address (vinsn-note-peer start=
) nil))
+ (source-note (aref (vinsn-note-info start) 0))
+ (text-start (- (source-note-start-pos source-note) def-start))
+ (text-end (- (source-note-end-pos source-note) def-start)))
+ (declare (fixnum pc-start pc-end text-start text-end))
+ (when (and (plusp pc-start)
+ (plusp pc-end)
+ (plusp text-start)
+ (plusp text-end))
+ (if (> pc-start max) (setq max pc-start))
+ (if (> pc-end max) (setq max pc-end))
+ (if (> text-start max) (setq max text-start))
+ (if (> text-end max) (setq max text-end))
+ (setf (svref pc-starts nvalid) pc-start
+ (svref pc-ends nvalid) pc-end
+ (svref text-starts nvalid) text-start
+ (svref text-ends nvalid) text-end)
+ (incf nvalid))))
+ (let* ((nentries (* nvalid 4))
+ (vec (cond ((< max #x100) (make-array nentries :element-type '(=
unsigned-byte 8)))
+ ((< max #x10000) (make-array nentries :element-type =
'(unsigned-byte 16)))
+ (t (make-array nentries :element-type '(unsigned-byt=
e 32))))))
+ (declare (fixnum nentries))
+ (do* ((i 0 (+ i 4))
+ (j 1 (+ j 4))
+ (k 2 (+ k 4))
+ (l 3 (+ l 4))
+ (idx 0 (1+ idx)))
+ ((=3D i nentries) vec)
+ (declare (fixnum i j k l idx))
+ (setf (aref vec i) (svref pc-starts idx)
+ (aref vec j) (svref pc-ends idx)
+ (aref vec k) (svref text-starts idx)
+ (aref vec l) (svref text-ends idx))))))
=
(defun x862-vinsn-note-label-address (note &optional start-p sym)
(-
@@ -1257,23 +1317,32 @@
(make-vcell-memory-spec n)
n))
=
-
-(defun x862-form (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 #.operator-id-m=
ask (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))))))
+(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))))
=
;;; dest is a float reg - form is acode
(defun x862-form-float (seg freg xfer form)
@@ -1551,7 +1620,7 @@
(cdar tagdata)))))))))
=
(defun x862-single-valued-form-p (form)
- (setq form (acode-unwrapped-form form))
+ (setq form (acode-unwrapped-form-value form))
(or (nx-null form)
(nx-t form)
(if (acode-p form)
@@ -2581,7 +2650,7 @@
(eq (x862-lexical-reference-p (%car reg-args)) =
rest))
(return nil))
(flet ((independent-of-all-values (form) =
- (setq form (acode-unwrapped-form form))
+ (setq form (acode-unwrapped-form-value form))
(or (x86-constant-form-p form)
(let* ((lexref (x862-lexical-reference-p form)))
(and lexref =
@@ -2617,7 +2686,7 @@
(when spread-p
(destructuring-bind (stack-args reg-args) arglist
(when (and (null (cdr reg-args))
- (nx-null (acode-unwrapped-form (car reg-args))))
+ (nx-null (acode-unwrapped-form-value (car reg-args))))
(setq spread-p nil)
(let* ((nargs (length stack-args)))
(declare (fixnum nargs))
@@ -2704,7 +2773,7 @@
;;; Nargs =3D nil -> multiple-value case.
(defun x862-invoke-fn (seg fn nargs spread-p xfer &optional mvpass-label)
(with-x86-local-vinsn-macros (seg)
- (let* ((f-op (acode-unwrapped-form fn))
+ (let* ((f-op (acode-unwrapped-form-value fn))
(immp (and (consp f-op)
(eq (%car f-op) (%nx1-operator immediate))))
(symp (and immp (symbolp (%cadr f-op))))
@@ -2957,7 +3026,7 @@
=
=
(defun x862-immediate-function-p (f)
- (setq f (acode-unwrapped-form f))
+ (setq f (acode-unwrapped-form-value f))
(and (acode-p f)
(or (eq (%car f) (%nx1-operator immediate))
(eq (%car f) (%nx1-operator simple-function)))))
@@ -2998,7 +3067,7 @@
=
=
(defun x86-side-effect-free-form-p (form)
- (when (consp (setq form (acode-unwrapped-form form)))
+ (when (consp (setq form (acode-unwrapped-form-value form)))
(or (x86-constant-form-p form)
;(eq (acode-operator form) (%nx1-operator bound-special-ref))
(if (eq (acode-operator form) (%nx1-operator lexical-reference))
@@ -3542,20 +3611,20 @@
arglist)
=
(defun x862-acode-operator-supports-u8 (form)
- (setq form (acode-unwrapped-form form))
+ (setq form (acode-unwrapped-form-value form))
(when (acode-p form)
(let* ((operator (acode-operator form)))
(if (member operator *x862-operator-supports-u8-target*)
(values operator (acode-operand 1 form))))))
=
(defun x862-acode-operator-supports-push (form)
- (setq form (acode-unwrapped-form form))
- (when (acode-p form)
- (if (or (eq form *nx-t*)
- (eq form *nx-nil*)
- (let* ((operator (acode-operator form)))
- (member operator *x862-operator-supports-push*)))
- form)))
+ (let ((value (acode-unwrapped-form-value form)))
+ (when (acode-p value)
+ (if (or (eq value *nx-t*)
+ (eq value *nx-nil*)
+ (let* ((operator (acode-operator value)))
+ (member operator *x862-operator-supports-push*)))
+ value))))
=
(defun x862-compare-u8 (seg vreg xfer form u8constant cr-bit true-p u8-ope=
rator)
(with-x86-local-vinsn-macros (seg vreg xfer)
@@ -3826,7 +3895,7 @@
(^)))))
=
(defun x862-lexical-reference-ea (form &optional (no-closed-p t))
- (when (acode-p (setq form (acode-unwrapped-form form)))
+ (when (acode-p (setq form (acode-unwrapped-form-value form)))
(if (eq (acode-operator form) (%nx1-operator lexical-reference))
(let* ((addr (var-ea (%cadr form))))
(if (typep addr 'lreg)
@@ -4268,26 +4337,27 @@
(x862-open-undo $undo-x86-c-frame)
(setq val node))))
((eq op (%nx1-operator %new-ptr))
- (let ((clear-form (caddr val)))
- (if (nx-constant-form-p clear-form)
+ (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 clear-form)
+ (if (nx-null cval)
(! make-stack-block)
(! make-stack-block0)))
(with-crf-target () crf
- (let ((stack-block-0-label (backend-ge=
t-next-label))
- (done-label (backend-get-next-la=
bel))
- (rval ($ *x862-arg-z*))
- (rclear ($ *x862-arg-y*)))
- (x862-two-targeted-reg-forms seg (%c=
adr val) rval clear-form rclear)
- (! compare-to-nil crf rclear)
- (! cbranch-false (aref *backend-labe=
ls* stack-block-0-label) crf x86::x86-e-bits)
- (! make-stack-block)
- (-> done-label)
- (@ stack-block-0-label)
- (! make-stack-block0)
- (@ done-label)))))
+ (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))
@@ -4295,7 +4365,7 @@
(x862-open-undo $undostkblk curstack)
(! make-stack-list)
(setq val *x862-arg-z*)) =
- ((eq (%car val) (%nx1-operator vector))
+ ((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))
@@ -4841,7 +4911,7 @@
=
(defun x862-lexical-reference-p (form)
(when (acode-p form)
- (let ((op (acode-operator (setq form (acode-unwrapped-form form)))))
+ (let ((op (acode-operator (setq form (acode-unwrapped-form-value form)=
))))
(when (or (eq op (%nx1-operator lexical-reference))
(eq op (%nx1-operator inherited-arg)))
(%cadr form)))))
@@ -4997,7 +5067,7 @@
(defun x862-acode-needs-memoization (valform)
(if (x862-form-typep valform 'fixnum)
nil
- (let* ((val (acode-unwrapped-form valform)))
+ (let* ((val (acode-unwrapped-form-value valform)))
(if (or (eq val *nx-t*)
(eq val *nx-nil*)
(and (acode-p val)
@@ -5070,7 +5140,7 @@
;;; that register to RNIL.
;;; "XFER" is a compound destination.
(defun x862-conditional-form (seg xfer form)
- (let* ((uwf (acode-unwrapped-form 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)
@@ -5580,7 +5650,8 @@
(defun x862-expand-note (frag-list note)
(let* ((lab (vinsn-note-label note)))
(case (vinsn-note-class note)
- ((:regsave :begin-variable-scope :end-variable-scope)
+ ((:regsave :begin-variable-scope :end-variable-scope
+ :source-location-begin :source-location-end)
(setf (vinsn-label-info lab) (emit-x86-lap-label frag-list lab))))))
=
(defun x86-emit-instruction-from-vinsn (opcode-template
@@ -5744,8 +5815,8 @@
(do-dll-nodes (v header)
(if (%vinsn-label-p v)
(let* ((id (vinsn-label-id v)))
- (if (typep id 'fixnum)
- (when (or t (vinsn-label-refs v))
+ (if (or (typep id 'fixnum) (null id))
+ (when (or t (vinsn-label-refs v) (null id))
(setf (vinsn-label-info v) (emit-x86-lap-label frag-list v)))
(x862-expand-note frag-list id)))
(x862-expand-vinsn v frag-list instruction immediate-operand uuo-f=
rag-list)))
@@ -6997,9 +7068,9 @@
(^)))))
=
=
-(defx862 x862-if if (seg vreg xfer testform true false)
- (if (nx-constant-form-p (acode-unwrapped-form testform))
- (x862-form seg vreg xfer (if (nx-null (acode-unwrapped-form testform))=
false true))
+(defx862 x862-if if (seg vreg xfer testform true false &aux test-val)
+ (if (setq test-val (nx-constant-form-p (acode-unwrapped-form-value testf=
orm)))
+ (x862-form seg vreg xfer (if (nx-null test-val) false true))
(let* ((cstack *x862-cstack*)
(vstack *x862-vstack*)
(top-lcell *x862-top-vstack-lcell*)
@@ -9970,7 +10041,7 @@
=
(defx862 x862-%double-float %double-float (seg vreg xfer arg)
(let* ((real (or (acode-fixnum-form-p arg)
- (let* ((form (acode-unwrapped-form arg)))
+ (let* ((form (acode-unwrapped-form-value arg)))
(if (and (acode-p form)
(eq (acode-operator form)
(%nx1-operator immediate))
@@ -10001,7 +10072,7 @@
=
(defx862 x862-%single-float %single-float (seg vreg xfer arg)
(let* ((real (or (acode-fixnum-form-p arg)
- (let* ((form (acode-unwrapped-form arg)))
+ (let* ((form (acode-unwrapped-form-value arg)))
(if (and (acode-p form)
(eq (acode-operator form)
(%nx1-operator immediate))
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 Thu Oct 23 11:28:21 2008
@@ -150,32 +150,68 @@
(setq init nil))))))
=
(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)
=
-(defun compile-named-function (def &key name env keep-lambda keep-symbols =
policy load-time-eval-token target)
+;; 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)
+ ;; 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.
+ ;; FUNCTION-NOTE, if not nil, is a note to attach to the function as the=
lfun
+ ;; source location in preference to whatever the source-notes table as=
signs to it.
(when (and name *nx-discard-xref-info-hook*)
(funcall *nx-discard-xref-info-hook* name))
(setq =
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)))
(env (new-lexical-environment env)))
(setf (lexenv.variables env) 'barrier)
- (let* ((*target-backend* (or (if target (find-backend target)) *hos=
t-backend*))
- (afunc (nx1-compile-lambda =
- name =
- def
- (make-afunc) =
- nil =
- env =
- (or policy *default-compiler-policy*)
- *load-time-eval-token*)))
- (if (afunc-lfun afunc)
- afunc
- (funcall (backend-p2-compile *target-backend*)
- afunc
- ;; will also bind *nx-lexical-environment*
- (if keep-lambda (if (lambda-expression-p keep-lambda) =
keep-lambda def))
- keep-symbols)))))
+ (let* ((*target-backend* (or (if target (find-backend target)) *host-=
backend*))
+ (afunc (nx1-compile-lambda =
+ name =
+ def
+ (make-afunc) =
+ nil =
+ env =
+ (or policy *default-compiler-policy*)
+ *load-time-eval-token*
+ function-note)))
+ (if (afunc-lfun afunc)
+ afunc
+ (funcall (backend-p2-compile *target-backend*)
+ afunc
+ ;; will also bind *nx-lexical-environment*
+ (if keep-lambda (if (lambda-expression-p keep-lambda) ke=
ep-lambda def))
+ keep-symbols)))))
(values (afunc-lfun def) (afunc-warnings def)))
=
(defparameter *compiler-whining-conditions*
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 Thu Oct 23 11:28:21 2008
@@ -1294,7 +1294,9 @@
q
parent-env
(policy *default-compiler-policy*)
- load-time-eval-token)
+ load-time-eval-token
+ function-note)
+
(if q
(setf (afunc-parent p) q))
=
@@ -1315,6 +1317,12 @@
`(:internal ,name ,parent-name)
`(: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))
@@ -1642,21 +1650,28 @@
(with-program-error-handler
(lambda (c)
(let ((replacement (runtime-program-error-form c)))
+ (nx-note-source-transformation original replacement)
(nx1-transformed-form (nx-transform replacement env) env)))
(nx1-transformed-form (nx-transform original env) env)))
=
(defun nx1-transformed-form (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))))))
+ (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))))
=
(defun nx1-prefer-areg (form env)
(nx1-form form env))
@@ -2104,11 +2119,14 @@
=
)
=
-(defun nx-transform (form &optional (environment *nx-lexical-environment*))
+(defun nx-transform (form &optional (environment *nx-lexical-environment*)=
(source-note-map *nx-source-note-map*))
(macrolet ((form-changed (form)
- (declare (ignore form))
- '(setq changed t)))
- (prog (sym transforms lexdefs changed enabled macro-function compiler-=
macro)
+ `(progn
+ (unless source (setq source (gethash ,form source-note-m=
ap)))
+ (setq changed t))))
+ (prog (sym transforms lexdefs changed enabled macro-function compiler-=
macro (source t))
+ (when source-note-map
+ (setq source (gethash form source-note-map)))
(go START)
LOOP
(form-changed form)
@@ -2131,7 +2149,7 @@
(progn
(setq form thing)
(go LOOP))
- (multiple-value-bind (newform win) (nx-transform thing enviro=
nment)
+ (multiple-value-bind (newform win) (nx-transform thing enviro=
nment source-note-map)
(when win
(form-changed newform)
(if (and (self-evaluating-p newform)
@@ -2152,7 +2170,7 @@
(unless macro-function
(let* ((win nil))
(when (and enabled (functionp (fboundp sym)))
- (multiple-value-setq (form win) (nx-transform-arglist form en=
vironment))
+ (multiple-value-setq (form win) (nx-transform-arglist form en=
vironment source-note-map))
(when win
(form-changed form)))))
(when (and enabled
@@ -2192,19 +2210,26 @@
(form-changed form)
(go START))
DONE
+ (when (and source (neq source t) (not (gethash form source-note-map=
)))
+ (unless (and (consp form)
+ (eq (%car form) 'the)
+ (eq source (gethash (caddr form) source-note-map)))
+ (unless (or (eq form (%unbound-marker))
+ (eq form (%slot-unbound-marker)))
+ (setf (gethash form source-note-map) source))))
(return (values form changed)))))
=
; Transform all of the arguments to the function call form.
; If any of them won, return a new call form (with the same operator as th=
e original), else return the original
; call form unchanged.
-(defun nx-transform-arglist (callform env)
+(defun nx-transform-arglist (callform env source-note-map)
(let* ((any-wins nil)
(transformed-call (cons (car callform) nil))
(ptr transformed-call)
(win nil))
(declare (type cons ptr))
(dolist (form (cdr callform) (if any-wins (values (copy-list transform=
ed-call) t) (values callform nil)))
- (multiple-value-setq (form win) (nx-transform form env))
+ (multiple-value-setq (form win) (nx-transform form env source-note-m=
ap))
(rplacd ptr (setq ptr (cons form nil)))
(if win (setq any-wins t)))))
=
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 Thu Oct 23 11:28:21 2008
@@ -1466,7 +1466,9 @@
(or (not (macro-function name *nx-lexical-environment*))
(nx-error "Can't funcall macro function ~s ." name)))
(and (consp name) =
- (or (eq (%car name) 'lambda)
+ (or (when (eq (%car name) 'lambda)
+ (nx-note-source-transformation func name)
+ t)
(setq name (nx-need-function-name name))))))
(nx1-form (cons name args)) ; This picks up call-next-method evil.
(nx1-call (nx1-form func) args nil t))))
@@ -1543,12 +1545,14 @@
(maybe-warn-about-nx1-alphatizer-binding funcname)
(multiple-value-bind (body decls)
(parse-body flet-function-body env)
- (let ((func (make-afunc)))
+ (let ((func (make-afunc))
+ (expansion `(lambda ,lambda-list
+ , at decls
+ (block ,(if (consp funcname) (%cadr func=
name) funcname)
+ , at body))))
+ (nx-note-source-transformation def expansion)
(setf (afunc-environment func) env
- (afunc-lambdaform func) `(lambda ,lambda-list
- , at decls
- (block ,(if (consp fu=
ncname) (%cadr funcname) funcname)
- , at body)))
+ (afunc-lambdaform func) expansion)
(push func funcs)
(when (and *nx-next-method-var*
(eq funcname 'call-next-method)
@@ -1639,6 +1643,7 @@
, at decls =
(block ,blockname
, at body))))
+ (nx-note-source-transformation def expansion)
(setf (afunc-lambdaform func) expansion
(afunc-environment func) env)
(push (cons funcname expansion)
More information about the Openmcl-cvs-notifications
mailing list