Changeset 11212


Ignore:
Timestamp:
Oct 23, 2008, 3:28:21 PM (11 years ago)
Author:
gz
Message:

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, the compiler will do its best to track the source notes from the source all the way through code generation, and create a pc/source map, storing it as the '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 the lambda form on the 'function-source-note property of the function and any 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 minimize diffs for easier merging.

Location:
trunk/source/compiler
Files:
5 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/compiler/PPC/ppc2.lisp

    r11146 r11212  
    172172(defvar *ppc2-record-symbols* nil)
    173173(defvar *ppc2-recorded-symbols* nil)
     174(defvar *ppc2-emitted-source-notes* nil)
    174175
    175176(defvar *ppc2-result-reg* ppc::arg_z)
     
    411412           (*available-backend-fp-temps* ppc-temp-fp-regs)
    412413           (bits 0)
     414           (debug-info nil)
    413415           (*logical-register-counter* -1)
    414416           (*backend-all-lregs* ())
     
    438440           (*ppc2-vcells* (ppc2-ensure-binding-indices-for-vcells (afunc-vcells afunc)))
    439441           (*ppc2-fcells* (afunc-fcells afunc))
    440            *ppc2-recorded-symbols*)
     442           *ppc2-recorded-symbols*
     443           (*ppc2-emitted-source-notes* '()))
    441444      (set-fill-pointer
    442445       *backend-labels*
     
    467470                   (if (logbitp $fbitnonnullenv (the fixnum (afunc-bits afunc)))
    468471                     (setq bits (+ bits (ash 1 $lfbits-nonnullenv-bit))))
    469                    (let* ((function-debugging-info (afunc-lfun-info afunc)))
    470                      (when (or function-debugging-info lambda-form *ppc2-record-symbols*)
    471                        (if lambda-form (setq function-debugging-info
    472                                              (list* 'function-lambda-expression lambda-form function-debugging-info)))
    473                        (if *ppc2-record-symbols*
    474                          (setq function-debugging-info (nconc (list 'function-symbol-map *ppc2-recorded-symbols*)
    475                                                               function-debugging-info)))
    476                        (setq bits (logior (ash 1 $lfbits-info-bit) bits))
    477                        (backend-new-immediate function-debugging-info)))
     472                   (setq debug-info (afunc-lfun-info afunc))
     473                   (when lambda-form
     474                     (setq debug-info (list* 'function-lambda-expression lambda-form debug-info)))
     475                   (when *ppc2-recorded-symbols*
     476                     (setq debug-info (list* 'function-symbol-map *ppc2-recorded-symbols* debug-info)))
     477
     478                   (when debug-info
     479                     (setq bits (logior (ash 1 $lfbits-info-bit) bits))
     480                     (backend-new-immediate debug-info))
    478481                   (if (or fname lambda-form *ppc2-recorded-symbols*)
    479482                     (backend-new-immediate fname)
    480                      (setq bits (logior (ash -1 $lfbits-noname-bit) bits)))                                     
     483                     (setq bits (logior (ash -1 $lfbits-noname-bit) bits)))
     484
    481485                   (unless (afunc-parent afunc)
    482486                     (ppc2-fixup-fwd-refs afunc))
     
    497501                            regsave-addr
    498502                            (if (and fname (symbolp fname)) (symbol-name fname)))))
    499                    (ppc2-digest-symbols))))
     503                   (when (getf debug-info 'pc-source-map)
     504                     (setf (getf debug-info 'pc-source-map) (ppc2-generate-pc-source-map debug-info)))
     505                   (when (getf debug-info 'function-symbol-map)
     506                     (setf (getf debug-info 'function-symbol-map) (ppc2-digest-symbols))))))
    500507          (backend-remove-labels))))
    501508    afunc))
     
    557564                (setf (%svref v i) ref-fun)))))))))
    558565
     566(defun ppc2-generate-pc-source-map (debug-info)
     567  (let* ((definition-source-note (getf debug-info 'function-source-note))
     568         (emitted-source-notes (getf debug-info 'pc-source-map))
     569         (def-start (source-note-start-pos definition-source-note))
     570         (n (length emitted-source-notes))
     571         (nvalid 0)
     572         (max 0)
     573         (pc-starts (make-array n))
     574         (pc-ends (make-array n))
     575         (text-starts (make-array n))
     576         (text-ends (make-array n)))
     577    (declare (fixnum n nvalid)
     578             (dynamic-extent pc-starts pc-ends text-starts text-ends))
     579    (dolist (start emitted-source-notes)
     580      (let* ((pc-start (ppc2-vinsn-note-label-address start t))
     581             (pc-end (ppc2-vinsn-note-label-address (vinsn-note-peer start) nil))
     582             (source-note (aref (vinsn-note-info start) 0))
     583             (text-start (- (source-note-start-pos source-note) def-start))
     584             (text-end (- (source-note-end-pos source-note) def-start)))
     585        (declare (fixnum pc-start pc-end text-start text-end))
     586        (when (and (plusp pc-start)
     587                   (plusp pc-end)
     588                   (plusp text-start)
     589                   (plusp text-end))
     590          (if (> pc-start max) (setq max pc-start))
     591          (if (> pc-end max) (setq max pc-end))
     592          (if (> text-start max) (setq max text-start))
     593          (if (> text-end max) (setq max text-end))
     594          (setf (svref pc-starts nvalid) pc-start
     595                (svref pc-ends nvalid) pc-end
     596                (svref text-starts nvalid) text-start
     597                (svref text-ends nvalid) text-end)
     598          (incf nvalid))))
     599    (let* ((nentries (* nvalid 4))
     600           (vec (cond ((< max #x100) (make-array nentries :element-type '(unsigned-byte 8)))
     601                      ((< max #x10000) (make-array nentries :element-type '(unsigned-byte 16)))
     602                      (t (make-array nentries :element-type '(unsigned-byte 32))))))
     603      (declare (fixnum nentries))
     604      (do* ((i 0 (+ i 4))
     605            (j 1 (+ j 4))
     606            (k 2 (+ k 4))
     607            (l 3 (+ l 4))
     608            (idx 0 (1+ idx)))
     609          ((= i nentries) vec)
     610        (declare (fixnum i j k l idx))
     611        (setf (aref vec i) (svref pc-starts idx)
     612              (aref vec j) (svref pc-ends idx)
     613              (aref vec k) (svref text-starts idx)
     614              (aref vec l) (svref text-ends idx))))))
     615
     616(defun ppc2-vinsn-note-label-address (note &optional start-p sym)
     617  (let* ((label (vinsn-note-label note))
     618         (lap-label (if label (vinsn-label-info label))))
     619    (if lap-label
     620      (lap-label-address lap-label)
     621      (compiler-bug "Missing or bad ~s label: ~s"
     622                    (if start-p 'start 'end) sym))))
     623
    559624(defun ppc2-digest-symbols ()
    560   (if *ppc2-recorded-symbols*
     625  (when *ppc2-recorded-symbols*
    561626    (let* ((symlist *ppc2-recorded-symbols*)
    562627           (len (length symlist))
     
    568633      (dolist (info symlist (progn (%rplaca symlist syms)
    569634                                   (%rplacd symlist ptrs)))
    570         (flet ((label-address (note start-p sym)
    571                  (let* ((label (vinsn-note-label note))
    572                         (lap-label (if label (vinsn-label-info label))))
    573                    (if lap-label
    574                      (lap-label-address lap-label)
    575                      (compiler-bug "Missing or bad ~s label: ~s"
    576                        (if start-p 'start 'end) sym)))))
    577           (destructuring-bind (var sym startlab endlab) info
    578             (let* ((ea (var-ea var))
    579                    (ea-val (ldb (byte 16 0) ea)))
    580               (setf (aref ptrs (incf i)) (if (memory-spec-p ea)
    581                                            (logior (ash ea-val 6) #o77)
    582                                            ea-val)))
    583             (setf (aref syms (incf j)) sym)
    584             (setf (aref ptrs (incf i)) (label-address startlab t sym))
    585             (setf (aref ptrs (incf i)) (label-address endlab nil sym))))))))
     635        (destructuring-bind (var sym startlab endlab) info
     636          (let* ((ea (var-ea var))
     637                 (ea-val (ldb (byte 16 0) ea)))
     638            (setf (aref ptrs (incf i)) (if (memory-spec-p ea)
     639                                         (logior (ash ea-val 6) #o77)
     640                                         ea-val)))
     641          (setf (aref syms (incf j)) sym)
     642          (setf (aref ptrs (incf i)) (ppc2-vinsn-note-label-address startlab t sym))
     643          (setf (aref ptrs (incf i)) (ppc2-vinsn-note-label-address endlab nil sym))))
     644      *ppc2-recorded-symbols*)))
    586645
    587646(defun ppc2-decls (decls)
     
    9971056
    9981057
    999 (defun ppc2-form (seg vreg xfer form)
    1000   (if (nx-null form)
    1001     (ppc2-nil seg vreg xfer)
    1002     (if (nx-t form)
    1003       (ppc2-t seg vreg xfer)
    1004       (let* ((op nil)
    1005              (fn nil))
    1006         (if (and (consp form)
    1007                  (setq fn (svref *ppc2-specials* (%ilogand #.operator-id-mask (setq op (acode-operator form))))))
    1008           (if (and (null vreg)
    1009                    (%ilogbitp operator-acode-subforms-bit op)
    1010                    (%ilogbitp operator-assignment-free-bit op))
    1011             (dolist (f (%cdr form) (ppc2-branch seg xfer nil))
    1012               (ppc2-form seg nil nil f ))
    1013             (apply fn seg vreg xfer (%cdr form)))
    1014           (compiler-bug "ppc2-form ? ~s" form))))))
     1058(defun ppc2-form (seg vreg xfer form &aux (note (acode-source-note form)))
     1059  (flet ((main (seg vreg xfer form)
     1060           (if (nx-null form)
     1061             (ppc2-nil seg vreg xfer)
     1062             (if (nx-t form)
     1063               (ppc2-t seg vreg xfer)
     1064               (let* ((op nil)
     1065                      (fn nil))
     1066                 (if (and (consp form)
     1067                          (setq fn (svref *ppc2-specials* (%ilogand #.operator-id-mask (setq op (acode-operator form))))))
     1068                   (if (and (null vreg)
     1069                            (%ilogbitp operator-acode-subforms-bit op)
     1070                            (%ilogbitp operator-assignment-free-bit op))
     1071                     (dolist (f (%cdr form) (ppc2-branch seg xfer nil))
     1072                       (ppc2-form seg nil nil f ))
     1073                     (apply fn seg vreg xfer (%cdr form)))
     1074                   (compiler-bug "ppc2-form ? ~s" form)))))))
     1075    (if note
     1076      (let* ((start (ppc2-emit-note seg :source-location-begin note))
     1077             (bits (main seg vreg xfer form))
     1078             (end (ppc2-emit-note seg :source-location-end)))
     1079        (setf (vinsn-note-peer start) end
     1080              (vinsn-note-peer end) start)
     1081        (push start *ppc2-emitted-source-notes*)
     1082        bits)
     1083      (main seg vreg xfer form))))
    10151084
    10161085;;; dest is a float reg - form is acode
     
    12501319
    12511320(defun ppc2-single-valued-form-p (form)
    1252   (setq form (acode-unwrapped-form form))
     1321  (setq form (acode-unwrapped-form-value form))
    12531322  (or (nx-null form)
    12541323      (nx-t form)
     
    22102279                (return nil))
    22112280              (flet ((independent-of-all-values (form)       
    2212                        (setq form (acode-unwrapped-form form))
     2281                       (setq form (acode-unwrapped-form-value form))
    22132282                       (or (ppc-constant-form-p form)
    22142283                           (let* ((lexref (ppc2-lexical-reference-p form)))
     
    22462315      (destructuring-bind (stack-args reg-args) arglist
    22472316        (when (and (null (cdr reg-args))
    2248                    (nx-null (acode-unwrapped-form (car reg-args))))
     2317                   (nx-null (acode-unwrapped-form-value (car reg-args))))
    22492318          (setq spread-p nil)
    22502319          (let* ((nargs (length stack-args)))
     
    23342403(defun ppc2-invoke-fn (seg fn nargs spread-p xfer)
    23352404  (with-ppc-local-vinsn-macros (seg)
    2336     (let* ((f-op (acode-unwrapped-form fn))
     2405    (let* ((f-op (acode-unwrapped-form-value fn))
    23372406           (immp (and (consp f-op)
    23382407                      (eq (%car f-op) (%nx1-operator immediate))))
     
    25782647
    25792648(defun ppc2-immediate-function-p (f)
    2580   (setq f (acode-unwrapped-form f))
     2649  (setq f (acode-unwrapped-form-value f))
    25812650  (and (acode-p f)
    25822651       (or (eq (%car f) (%nx1-operator immediate))
     
    26072676
    26082677(defun ppc-side-effect-free-form-p (form)
    2609   (when (consp (setq form (acode-unwrapped-form form)))
     2678  (when (consp (setq form (acode-unwrapped-form-value form)))
    26102679    (or (ppc-constant-form-p form)
    26112680        ;(eq (acode-operator form) (%nx1-operator bound-special-ref))
     
    32923361
    32933362(defun ppc2-lexical-reference-ea (form &optional (no-closed-p t))
    3294   (when (acode-p (setq form (acode-unwrapped-form form)))
     3363  (when (acode-p (setq form (acode-unwrapped-form-value form)))
    32953364    (if (eq (acode-operator form) (%nx1-operator lexical-reference))
    32963365      (let* ((addr (var-ea (%cadr form))))
     
    36593728                   (setq val node))))
    36603729              ((eq op (%nx1-operator %new-ptr))
    3661                (let ((clear-form (caddr val)))
    3662                  (if (nx-constant-form-p clear-form)
     3730               (let* ((clear-form (caddr val))
     3731                      (cval (nx-constant-form-p clear-form)))
     3732                 (if cval
    36633733                   (progn
    36643734                     (ppc2-one-targeted-reg-form seg (%cadr val) ($ ppc::arg_z))
    3665                      (if (nx-null clear-form)
     3735                     (if (nx-null cval)
    36663736                       (! make-stack-block)
    36673737                       (! make-stack-block0)))
     
    36863756               (! make-stack-list)
    36873757               (setq val ppc::arg_z))       
    3688               ((eq (%car val) (%nx1-operator vector))
     3758              ((eq op (%nx1-operator vector))
    36893759               (let* ((*ppc2-vstack* *ppc2-vstack*)
    36903760                      (*ppc2-top-vstack-lcell* *ppc2-top-vstack-lcell*))
     
    43214391(defun ppc2-lexical-reference-p (form)
    43224392  (when (acode-p form)
    4323     (let ((op (acode-operator (setq form (acode-unwrapped-form form)))))
     4393    (let ((op (acode-operator (setq form (acode-unwrapped-form-value form)))))
    43244394      (when (or (eq op (%nx1-operator lexical-reference))
    43254395                (eq op (%nx1-operator inherited-arg)))
     
    44804550  (if (ppc2-form-typep valform 'fixnum)
    44814551    nil
    4482     (let* ((val (acode-unwrapped-form valform)))
     4552    (let* ((val (acode-unwrapped-form-value valform)))
    44834553      (if (or (eq val *nx-t*)
    44844554              (eq val *nx-nil*)
     
    45534623;;; "XFER" is a compound destination.
    45544624(defun ppc2-conditional-form (seg xfer form)
    4555   (let* ((uwf (acode-unwrapped-form form)))
     4625  (let* ((uwf (acode-unwrapped-form-value form)))
    45564626    (if (nx-null uwf)
    45574627      (ppc2-branch seg (ppc2-cd-false xfer) nil)
     
    50555125  (let* ((lab (vinsn-note-label note)))
    50565126    (case (vinsn-note-class note)
    5057       ((:regsave :begin-variable-scope :end-variable-scope)
     5127      ((:regsave :begin-variable-scope :end-variable-scope
     5128        :source-location-begin :source-location-end)
    50585129       (setf (vinsn-label-info lab) (emit-lap-label lab))))))
    50595130
     
    50625133    (if (%vinsn-label-p v)
    50635134      (let* ((id (vinsn-label-id v)))
    5064         (if (typep id 'fixnum)
    5065           (when (or t (vinsn-label-refs v))
     5135        (if (or (typep id 'fixnum) (null id))
     5136          (when (or t (vinsn-label-refs v) (null id))
    50665137            (setf (vinsn-label-info v) (emit-lap-label v)))
    50675138          (ppc2-expand-note id)))
     
    61626233     
    61636234
    6164 (defppc2 ppc2-if if (seg vreg xfer testform true false)
    6165   (if (nx-constant-form-p (acode-unwrapped-form testform))
    6166     (ppc2-form seg vreg xfer (if (nx-null (acode-unwrapped-form testform)) false true))
     6235(defppc2 ppc2-if if (seg vreg xfer testform true false &aux test-val)
     6236  (if (setq test-val (nx-constant-form-p (acode-unwrapped-form-value testform)))
     6237    (ppc2-form seg vreg xfer (if (nx-null test-val) false true))
    61676238    (let* ((cstack *ppc2-cstack*)
    61686239           (vstack *ppc2-vstack*)
     
    90679138(defppc2 ppc2-%double-float %double-float (seg vreg xfer arg)
    90689139  (let* ((real (or (acode-fixnum-form-p arg)
    9069                    (let* ((form (acode-unwrapped-form arg)))
     9140                   (let* ((form (acode-unwrapped-form-value arg)))
    90709141                     (if (and (acode-p form)
    90719142                              (eq (acode-operator form)
     
    90979168(defppc2 ppc2-%single-float %single-float (seg vreg xfer arg)
    90989169  (let* ((real (or (acode-fixnum-form-p arg)
    9099                    (let* ((form (acode-unwrapped-form arg)))
     9170                   (let* ((form (acode-unwrapped-form-value arg)))
    91009171                     (if (and (acode-p form)
    91019172                              (eq (acode-operator form)
  • trunk/source/compiler/X86/x862.lisp

    r11208 r11212  
    200200(defvar *x862-record-symbols* nil)
    201201(defvar *x862-recorded-symbols* nil)
     202(defvar *x862-emitted-source-notes* nil)
    202203
    203204(defvar *x862-result-reg* x8664::arg_z)
     
    594595           (*x862-vcells* (x862-ensure-binding-indices-for-vcells (afunc-vcells afunc)))
    595596           (*x862-fcells* (afunc-fcells afunc))
    596            *x862-recorded-symbols*)
     597           *x862-recorded-symbols*
     598           (*x862-emitted-source-notes* '()))
    597599      (set-fill-pointer
    598600       *backend-labels*
     
    689691                   (if (logbitp $fbitnonnullenv (the fixnum (afunc-bits afunc)))
    690692                     (setq bits (+ bits (ash 1 $lfbits-nonnullenv-bit))))
    691                    (let* ((function-debugging-info (afunc-lfun-info afunc)))
    692                      (when (or function-debugging-info lambda-form *x862-record-symbols*)
    693                        (if lambda-form (setq function-debugging-info
    694                                              (list* 'function-lambda-expression lambda-form function-debugging-info)))
    695                        (if *x862-record-symbols*
    696                          (setq function-debugging-info (nconc (list 'function-symbol-map *x862-recorded-symbols*)
    697                                                               function-debugging-info)))
    698                        (setq bits (logior (ash 1 $lfbits-info-bit) bits))
    699                        (setq debug-info function-debugging-info)))
     693                   (setq debug-info (afunc-lfun-info afunc))
     694                   (when lambda-form
     695                     (setq debug-info
     696                           (list* 'function-lambda-expression lambda-form debug-info)))
     697                   (when *x862-record-symbols*
     698                     (setq debug-info
     699                           (list* 'function-symbol-map *x862-recorded-symbols* debug-info)))
     700                   (when (and (getf debug-info 'function-source-note) *x862-emitted-source-notes*)
     701                     (setq debug-info                     ;; Compressed below
     702                           (list* 'pc-source-map *x862-emitted-source-notes* debug-info)))
     703                   (when debug-info
     704                     (setq bits (logior (ash 1 $lfbits-info-bit) bits)))
    700705                   (unless (or fname lambda-form *x862-recorded-symbols*)
    701706                     (setq bits (logior (ash 1 $lfbits-noname-bit) bits)))
     
    744749
    745750                     (x862-lap-process-regsave-info frag-list regsave-label regsave-mask regsave-addr)
     751
     752                     (when (getf debug-info 'pc-source-map)
     753                       (setf (getf debug-info 'pc-source-map) (x862-generate-pc-source-map debug-info)))
     754                     (when (getf debug-info 'function-symbol-map)
     755                       (setf (getf debug-info 'function-symbol-map) (x862-digest-symbols)))
     756
    746757                     (setf (afunc-lfun afunc)
    747758                           #+x86-target
     
    750761                             (cross-create-x86-function fname frag-list *x862-constant-alist* bits debug-info))
    751762                           #-x86-target
    752                            (cross-create-x86-function fname frag-list *x862-constant-alist* bits debug-info)))
    753                    (x862-digest-symbols)))))
     763                           (cross-create-x86-function fname frag-list *x862-constant-alist* bits debug-info)))))))
    754764          (backend-remove-labels))))
    755765    afunc))
     
    785795              (if (eq (%svref v i) ref)
    786796                (setf (%svref v i) ref-fun)))))))))
     797
     798(defun x862-generate-pc-source-map (debug-info)
     799  (let* ((definition-source-note (getf debug-info 'function-source-note))
     800         (emitted-source-notes (getf debug-info 'pc-source-map))
     801         (def-start (source-note-start-pos definition-source-note))
     802         (n (length emitted-source-notes))
     803         (nvalid 0)
     804         (max 0)
     805         (pc-starts (make-array n))
     806         (pc-ends (make-array n))
     807         (text-starts (make-array n))
     808         (text-ends (make-array n)))
     809    (declare (fixnum n nvalid)
     810             (dynamic-extent pc-starts pc-ends text-starts text-ends))
     811    (dolist (start emitted-source-notes)
     812      (let* ((pc-start (x862-vinsn-note-label-address start t))
     813             (pc-end (x862-vinsn-note-label-address (vinsn-note-peer start) nil))
     814             (source-note (aref (vinsn-note-info start) 0))
     815             (text-start (- (source-note-start-pos source-note) def-start))
     816             (text-end (- (source-note-end-pos source-note) def-start)))
     817        (declare (fixnum pc-start pc-end text-start text-end))
     818        (when (and (plusp pc-start)
     819                   (plusp pc-end)
     820                   (plusp text-start)
     821                   (plusp text-end))
     822          (if (> pc-start max) (setq max pc-start))
     823          (if (> pc-end max) (setq max pc-end))
     824          (if (> text-start max) (setq max text-start))
     825          (if (> text-end max) (setq max text-end))
     826          (setf (svref pc-starts nvalid) pc-start
     827                (svref pc-ends nvalid) pc-end
     828                (svref text-starts nvalid) text-start
     829                (svref text-ends nvalid) text-end)
     830          (incf nvalid))))
     831    (let* ((nentries (* nvalid 4))
     832           (vec (cond ((< max #x100) (make-array nentries :element-type '(unsigned-byte 8)))
     833                      ((< max #x10000) (make-array nentries :element-type '(unsigned-byte 16)))
     834                      (t (make-array nentries :element-type '(unsigned-byte 32))))))
     835      (declare (fixnum nentries))
     836      (do* ((i 0 (+ i 4))
     837            (j 1 (+ j 4))
     838            (k 2 (+ k 4))
     839            (l 3 (+ l 4))
     840            (idx 0 (1+ idx)))
     841          ((= i nentries) vec)
     842        (declare (fixnum i j k l idx))
     843        (setf (aref vec i) (svref pc-starts idx)
     844              (aref vec j) (svref pc-ends idx)
     845              (aref vec k) (svref text-starts idx)
     846              (aref vec l) (svref text-ends idx))))))
    787847
    788848(defun x862-vinsn-note-label-address (note &optional start-p sym)
     
    12581318    n))
    12591319
    1260 
    1261 (defun x862-form (seg vreg xfer form)
    1262   (if (nx-null form)
    1263     (x862-nil seg vreg xfer)
    1264     (if (nx-t form)
    1265       (x862-t seg vreg xfer)
    1266       (let* ((op nil)
    1267              (fn nil))
    1268         (if (and (consp form)
    1269                  (setq fn (svref *x862-specials* (%ilogand #.operator-id-mask (setq op (acode-operator form))))))
    1270           (if (and (null vreg)
    1271                    (%ilogbitp operator-acode-subforms-bit op)
    1272                    (%ilogbitp operator-assignment-free-bit op))
    1273             (dolist (f (%cdr form) (x862-branch seg xfer))
    1274               (x862-form seg nil nil f ))
    1275             (apply fn seg vreg xfer (%cdr form)))
    1276           (compiler-bug "x862-form ? ~s" form))))))
     1320(defun x862-form (seg vreg xfer form &aux (note (acode-source-note form)))
     1321  (flet ((main (seg vreg xfer form)
     1322           (if (nx-null form)
     1323             (x862-nil seg vreg xfer)
     1324             (if (nx-t form)
     1325               (x862-t seg vreg xfer)
     1326               (let* ((op nil)
     1327                      (fn nil))
     1328                 (if (and (consp form)
     1329                          (setq fn (svref *x862-specials* (%ilogand #.operator-id-mask (setq op (acode-operator form))))))
     1330                   (if (and (null vreg)
     1331                            (%ilogbitp operator-acode-subforms-bit op)
     1332                            (%ilogbitp operator-assignment-free-bit op))
     1333                     (dolist (f (%cdr form) (x862-branch seg xfer))
     1334                       (x862-form seg nil nil f ))
     1335                     (apply fn seg vreg xfer (%cdr form)))
     1336                   (compiler-bug "x862-form ? ~s" form)))))))
     1337    (if note
     1338      (let* ((start (x862-emit-note seg :source-location-begin note))
     1339             (bits (main seg vreg xfer form))
     1340             (end (x862-emit-note seg :source-location-end)))
     1341        (setf (vinsn-note-peer start) end
     1342              (vinsn-note-peer end) start)
     1343        (push start *x862-emitted-source-notes*)
     1344        bits)
     1345      (main seg vreg xfer form))))
    12771346
    12781347;;; dest is a float reg - form is acode
     
    15521621
    15531622(defun x862-single-valued-form-p (form)
    1554   (setq form (acode-unwrapped-form form))
     1623  (setq form (acode-unwrapped-form-value form))
    15551624  (or (nx-null form)
    15561625      (nx-t form)
     
    25822651                (return nil))
    25832652              (flet ((independent-of-all-values (form)       
    2584                        (setq form (acode-unwrapped-form form))
     2653                       (setq form (acode-unwrapped-form-value form))
    25852654                       (or (x86-constant-form-p form)
    25862655                           (let* ((lexref (x862-lexical-reference-p form)))
     
    26182687      (destructuring-bind (stack-args reg-args) arglist
    26192688        (when (and (null (cdr reg-args))
    2620                    (nx-null (acode-unwrapped-form (car reg-args))))
     2689                   (nx-null (acode-unwrapped-form-value (car reg-args))))
    26212690          (setq spread-p nil)
    26222691          (let* ((nargs (length stack-args)))
     
    27052774(defun x862-invoke-fn (seg fn nargs spread-p xfer &optional mvpass-label)
    27062775  (with-x86-local-vinsn-macros (seg)
    2707     (let* ((f-op (acode-unwrapped-form fn))
     2776    (let* ((f-op (acode-unwrapped-form-value fn))
    27082777           (immp (and (consp f-op)
    27092778                      (eq (%car f-op) (%nx1-operator immediate))))
     
    29583027
    29593028(defun x862-immediate-function-p (f)
    2960   (setq f (acode-unwrapped-form f))
     3029  (setq f (acode-unwrapped-form-value f))
    29613030  (and (acode-p f)
    29623031       (or (eq (%car f) (%nx1-operator immediate))
     
    29993068
    30003069(defun x86-side-effect-free-form-p (form)
    3001   (when (consp (setq form (acode-unwrapped-form form)))
     3070  (when (consp (setq form (acode-unwrapped-form-value form)))
    30023071    (or (x86-constant-form-p form)
    30033072        ;(eq (acode-operator form) (%nx1-operator bound-special-ref))
     
    35433612
    35443613(defun x862-acode-operator-supports-u8 (form)
    3545   (setq form (acode-unwrapped-form form))
     3614  (setq form (acode-unwrapped-form-value form))
    35463615  (when (acode-p form)
    35473616    (let* ((operator (acode-operator form)))
     
    35503619
    35513620(defun x862-acode-operator-supports-push (form)
    3552   (setq form (acode-unwrapped-form form))
    3553   (when (acode-p form)
    3554     (if (or (eq form *nx-t*)
    3555             (eq form *nx-nil*)
    3556             (let* ((operator (acode-operator form)))
    3557               (member operator *x862-operator-supports-push*)))
    3558         form)))
     3621  (let ((value (acode-unwrapped-form-value form)))
     3622    (when (acode-p value)
     3623      (if (or (eq value *nx-t*)
     3624              (eq value *nx-nil*)
     3625              (let* ((operator (acode-operator value)))
     3626                (member operator *x862-operator-supports-push*)))
     3627        value))))
    35593628
    35603629(defun x862-compare-u8 (seg vreg xfer form u8constant cr-bit true-p u8-operator)
     
    38273896
    38283897(defun x862-lexical-reference-ea (form &optional (no-closed-p t))
    3829   (when (acode-p (setq form (acode-unwrapped-form form)))
     3898  (when (acode-p (setq form (acode-unwrapped-form-value form)))
    38303899    (if (eq (acode-operator form) (%nx1-operator lexical-reference))
    38313900      (let* ((addr (var-ea (%cadr form))))
     
    42694338                   (setq val node))))
    42704339              ((eq op (%nx1-operator %new-ptr))
    4271                (let ((clear-form (caddr val)))
    4272                  (if (nx-constant-form-p clear-form)
     4340               (let* ((clear-form (caddr val))
     4341                      (cval (nx-constant-form-p clear-form)))
     4342                 (if cval
    42734343                   (progn
    42744344                     (x862-one-targeted-reg-form seg (%cadr val) ($ *x862-arg-z*))
    4275                      (if (nx-null clear-form)
     4345                     (if (nx-null cval)
    42764346                       (! make-stack-block)
    42774347                       (! make-stack-block0)))
    42784348                   (with-crf-target () crf
    4279                                     (let ((stack-block-0-label (backend-get-next-label))
    4280                                           (done-label (backend-get-next-label))
    4281                                           (rval ($ *x862-arg-z*))
    4282                                           (rclear ($ *x862-arg-y*)))
    4283                                       (x862-two-targeted-reg-forms seg (%cadr val) rval clear-form rclear)
    4284                                       (! compare-to-nil crf rclear)
    4285                                       (! cbranch-false (aref *backend-labels* stack-block-0-label) crf x86::x86-e-bits)
    4286                                       (! make-stack-block)
    4287                                       (-> done-label)
    4288                                       (@ stack-block-0-label)
    4289                                       (! make-stack-block0)
    4290                                       (@ done-label)))))
     4349                     (let ((stack-block-0-label (backend-get-next-label))
     4350                           (done-label (backend-get-next-label))
     4351                           (rval ($ *x862-arg-z*))
     4352                           (rclear ($ *x862-arg-y*)))
     4353                       (x862-two-targeted-reg-forms seg (%cadr val) rval clear-form rclear)
     4354                       (! compare-to-nil crf rclear)
     4355                       (! cbranch-false (aref *backend-labels* stack-block-0-label) crf x86::x86-e-bits)
     4356                       (! make-stack-block)
     4357                       (-> done-label)
     4358                       (@ stack-block-0-label)
     4359                       (! make-stack-block0)
     4360                       (@ done-label)))))
    42914361               (x862-open-undo $undo-x86-c-frame)
    42924362               (setq val ($ *x862-arg-z*)))
     
    42964366               (! make-stack-list)
    42974367               (setq val *x862-arg-z*))       
    4298               ((eq (%car val) (%nx1-operator vector))
     4368              ((eq op (%nx1-operator vector))
    42994369               (let* ((*x862-vstack* *x862-vstack*)
    43004370                      (*x862-top-vstack-lcell* *x862-top-vstack-lcell*))
     
    48424912(defun x862-lexical-reference-p (form)
    48434913  (when (acode-p form)
    4844     (let ((op (acode-operator (setq form (acode-unwrapped-form form)))))
     4914    (let ((op (acode-operator (setq form (acode-unwrapped-form-value form)))))
    48454915      (when (or (eq op (%nx1-operator lexical-reference))
    48464916                (eq op (%nx1-operator inherited-arg)))
     
    49985068  (if (x862-form-typep valform 'fixnum)
    49995069    nil
    5000     (let* ((val (acode-unwrapped-form valform)))
     5070    (let* ((val (acode-unwrapped-form-value valform)))
    50015071      (if (or (eq val *nx-t*)
    50025072              (eq val *nx-nil*)
     
    50715141;;; "XFER" is a compound destination.
    50725142(defun x862-conditional-form (seg xfer form)
    5073   (let* ((uwf (acode-unwrapped-form form)))
     5143  (let* ((uwf (acode-unwrapped-form-value form)))
    50745144    (if (nx-null uwf)
    50755145      (x862-branch seg (x862-cd-false xfer))
     
    55815651  (let* ((lab (vinsn-note-label note)))
    55825652    (case (vinsn-note-class note)
    5583       ((:regsave :begin-variable-scope :end-variable-scope)
     5653      ((:regsave :begin-variable-scope :end-variable-scope
     5654        :source-location-begin :source-location-end)
    55845655       (setf (vinsn-label-info lab) (emit-x86-lap-label frag-list lab))))))
    55855656
     
    57455816      (if (%vinsn-label-p v)
    57465817        (let* ((id (vinsn-label-id v)))
    5747           (if (typep id 'fixnum)
    5748             (when (or t (vinsn-label-refs v))
     5818          (if (or (typep id 'fixnum) (null id))
     5819            (when (or t (vinsn-label-refs v) (null id))
    57495820              (setf (vinsn-label-info v) (emit-x86-lap-label frag-list v)))
    57505821            (x862-expand-note frag-list id)))
     
    69987069     
    69997070
    7000 (defx862 x862-if if (seg vreg xfer testform true false)
    7001   (if (nx-constant-form-p (acode-unwrapped-form testform))
    7002     (x862-form seg vreg xfer (if (nx-null (acode-unwrapped-form testform)) false true))
     7071(defx862 x862-if if (seg vreg xfer testform true false &aux test-val)
     7072  (if (setq test-val (nx-constant-form-p (acode-unwrapped-form-value testform)))
     7073    (x862-form seg vreg xfer (if (nx-null test-val) false true))
    70037074    (let* ((cstack *x862-cstack*)
    70047075           (vstack *x862-vstack*)
     
    997110042(defx862 x862-%double-float %double-float (seg vreg xfer arg)
    997210043  (let* ((real (or (acode-fixnum-form-p arg)
    9973                    (let* ((form (acode-unwrapped-form arg)))
     10044                   (let* ((form (acode-unwrapped-form-value arg)))
    997410045                     (if (and (acode-p form)
    997510046                              (eq (acode-operator form)
     
    1000210073(defx862 x862-%single-float %single-float (seg vreg xfer arg)
    1000310074  (let* ((real (or (acode-fixnum-form-p arg)
    10004                    (let* ((form (acode-unwrapped-form arg)))
     10075                   (let* ((form (acode-unwrapped-form-value arg)))
    1000510076                     (if (and (acode-p form)
    1000610077                              (eq (acode-operator form)
  • trunk/source/compiler/nx.lisp

    r11183 r11212  
    151151
    152152(defparameter *load-time-eval-token* nil)
     153
     154(defparameter *nx-source-note-map* nil)
     155
     156(defun nx-source-note (form &aux (source-notes *nx-source-note-map*))
     157  (when source-notes (gethash form source-notes)))
     158 
     159(defun nx-note-source-transformation (original new &aux (source-notes *nx-source-note-map*) sn)
     160  (when (and source-notes
     161             (setq sn (gethash original source-notes))
     162             (not (gethash new source-notes)))
     163    (setf (gethash new source-notes) sn)))
     164
    153165(defparameter *nx-discard-xref-info-hook* nil)
    154166
    155 (defun compile-named-function (def &key name env keep-lambda keep-symbols policy load-time-eval-token target)
     167;; In lieu of a slot in acode.  Don't reference this variable elsewhere because I'm
     168;; hoping to make it go away.
     169(defparameter *nx-acode-source-map* nil)
     170
     171(defun acode-source-note (acode &aux (hash *nx-acode-source-map*))
     172  (and hash (gethash acode hash)))
     173
     174(defun (setf acode-source) (form acode)
     175  ;; Could save the form, but right now only really care about the source note,
     176  ;; and this way don't have to keep looking it up in pass 2.
     177  (let ((note (nx-source-note form)))
     178    (when note
     179      (assert *nx-acode-source-map*)
     180      (setf (gethash acode *nx-acode-source-map*) note))))
     181
     182(defun compile-named-function (def &key name env policy load-time-eval-token target
     183                                function-note keep-lambda keep-symbols source-notes)
     184  ;; SOURCE-NOTES, if not nil, is a hash table mapping source forms to locations,
     185  ;;   is used to produce and attach a pc/source map to the lfun, also to attach
     186  ;;   source locations and pc/source maps to inner lfuns.
     187  ;; FUNCTION-NOTE, if not nil, is a note to attach to the function as the lfun
     188  ;;   source location in preference to whatever the source-notes table assigns to it.
    156189  (when (and name *nx-discard-xref-info-hook*)
    157190    (funcall *nx-discard-xref-info-hook* name))
     
    159192   def
    160193   (let* ((*load-time-eval-token* load-time-eval-token)
     194          (*nx-source-note-map* source-notes)
     195          (*nx-acode-source-map* (and source-notes (make-hash-table :test #'eq :shared nil)))
    161196          (env (new-lexical-environment env)))
    162197     (setf (lexenv.variables env) 'barrier)
    163        (let* ((*target-backend* (or (if target (find-backend target)) *host-backend*))
    164               (afunc (nx1-compile-lambda
    165                       name
    166                       def
    167                       (make-afunc)
    168                       nil
    169                       env
    170                       (or policy *default-compiler-policy*)
    171                       *load-time-eval-token*)))
    172          (if (afunc-lfun afunc)
    173            afunc
    174            (funcall (backend-p2-compile *target-backend*)
    175                     afunc
    176                     ;; will also bind *nx-lexical-environment*
    177                     (if keep-lambda (if (lambda-expression-p keep-lambda) keep-lambda def))
    178                     keep-symbols)))))
     198     (let* ((*target-backend* (or (if target (find-backend target)) *host-backend*))
     199            (afunc (nx1-compile-lambda
     200                    name
     201                    def
     202                    (make-afunc)
     203                    nil
     204                    env
     205                    (or policy *default-compiler-policy*)
     206                    *load-time-eval-token*
     207                    function-note)))
     208       (if (afunc-lfun afunc)
     209         afunc
     210         (funcall (backend-p2-compile *target-backend*)
     211                  afunc
     212                  ;; will also bind *nx-lexical-environment*
     213                  (if keep-lambda (if (lambda-expression-p keep-lambda) keep-lambda def))
     214                  keep-symbols)))))
    179215  (values (afunc-lfun def) (afunc-warnings def)))
    180216
  • trunk/source/compiler/nx0.lisp

    r11183 r11212  
    12951295                                 parent-env
    12961296                                 (policy *default-compiler-policy*)
    1297                                  load-time-eval-token)
     1297                                 load-time-eval-token
     1298                                 function-note)
     1299
    12981300  (if q
    12991301     (setf (afunc-parent p) q))
     
    13161318                `(:internal ,parent-name)))
    13171319            name)))
     1320
     1321  (when (or function-note
     1322            (setq function-note (nx-source-note lambda-form))
     1323            (setq function-note (and q (getf (afunc-lfun-info q) 'function-source-note))))
     1324    (setf (afunc-lfun-info p)
     1325          (list* 'function-source-note function-note (afunc-lfun-info p))))
    13181326
    13191327  (unless (lambda-expression-p lambda-form)
     
    16431651      (lambda (c)
    16441652        (let ((replacement (runtime-program-error-form c)))
     1653          (nx-note-source-transformation original replacement)
    16451654          (nx1-transformed-form (nx-transform replacement env) env)))
    16461655    (nx1-transformed-form (nx-transform original env) env)))
    16471656
    16481657(defun nx1-transformed-form (form env)
    1649   (if (consp form)
    1650     (nx1-combination form env)
    1651     (let* ((symbolp (non-nil-symbol-p form))
    1652            (constant-value (unless symbolp form))
    1653            (constant-symbol-p nil))
    1654       (if symbolp
    1655         (multiple-value-setq (constant-value constant-symbol-p)
    1656           (nx-transform-defined-constant form env)))
    1657       (if (and symbolp (not constant-symbol-p))
    1658         (nx1-symbol form env)
    1659         (nx1-immediate (nx-unquote constant-value))))))
     1658  (flet ((main (form env)
     1659           (if (consp form)
     1660             (nx1-combination form env)
     1661             (let* ((symbolp (non-nil-symbol-p form))
     1662                    (constant-value (unless symbolp form))
     1663                    (constant-symbol-p nil))
     1664               (if symbolp
     1665                 (multiple-value-setq (constant-value constant-symbol-p)
     1666                   (nx-transform-defined-constant form env)))
     1667               (if (and symbolp (not constant-symbol-p))
     1668                 (nx1-symbol form env)
     1669                 (nx1-immediate (nx-unquote constant-value)))))))
     1670    (if *nx-source-note-map*
     1671      (let ((acode (main form env)))
     1672        (setf (acode-source acode) form)
     1673        acode)
     1674      (main form env))))
    16601675
    16611676(defun nx1-prefer-areg (form env)
     
    21052120)
    21062121
    2107 (defun nx-transform (form &optional (environment *nx-lexical-environment*))
     2122(defun nx-transform (form &optional (environment *nx-lexical-environment*) (source-note-map *nx-source-note-map*))
    21082123  (macrolet ((form-changed (form)
    2109                (declare (ignore form))
    2110                '(setq changed t)))
    2111     (prog (sym transforms lexdefs changed enabled macro-function compiler-macro)
     2124               `(progn
     2125                  (unless source (setq source (gethash ,form source-note-map)))
     2126                  (setq changed t))))
     2127    (prog (sym transforms lexdefs changed enabled macro-function compiler-macro (source t))
     2128       (when source-note-map
     2129         (setq source (gethash form source-note-map)))
    21122130       (go START)
    21132131     LOOP
     
    21322150               (setq form thing)
    21332151               (go LOOP))
    2134              (multiple-value-bind (newform win) (nx-transform thing environment)
     2152             (multiple-value-bind (newform win) (nx-transform thing environment source-note-map)
    21352153               (when win
    21362154                 (form-changed newform)
     
    21532171         (let* ((win nil))
    21542172           (when (and enabled (functionp (fboundp sym)))
    2155              (multiple-value-setq (form win) (nx-transform-arglist form environment))
     2173             (multiple-value-setq (form win) (nx-transform-arglist form environment source-note-map))
    21562174             (when win
    21572175               (form-changed form)))))
     
    21932211         (go START))
    21942212     DONE
     2213       (when (and source (neq source t) (not (gethash form source-note-map)))
     2214         (unless (and (consp form)
     2215                      (eq (%car form) 'the)
     2216                      (eq source (gethash (caddr form) source-note-map)))
     2217           (unless (or (eq form (%unbound-marker))
     2218                       (eq form (%slot-unbound-marker)))
     2219             (setf (gethash form source-note-map) source))))
    21952220       (return (values form changed)))))
    21962221
     
    21982223; If any of them won, return a new call form (with the same operator as the original), else return the original
    21992224; call form unchanged.
    2200 (defun nx-transform-arglist (callform env)
     2225(defun nx-transform-arglist (callform env source-note-map)
    22012226  (let* ((any-wins nil)
    22022227         (transformed-call (cons (car callform) nil))
     
    22052230    (declare (type cons ptr))
    22062231    (dolist (form (cdr callform) (if any-wins (values (copy-list transformed-call) t) (values callform nil)))
    2207       (multiple-value-setq (form win) (nx-transform form env))
     2232      (multiple-value-setq (form win) (nx-transform form env source-note-map))
    22082233      (rplacd ptr (setq ptr (cons form nil)))
    22092234      (if win (setq any-wins t)))))
  • trunk/source/compiler/nx1.lisp

    r11183 r11212  
    14671467                    (nx-error "Can't funcall macro function ~s ." name)))
    14681468              (and (consp name)
    1469                    (or (eq (%car name) 'lambda)
     1469                   (or (when (eq (%car name) 'lambda)
     1470                         (nx-note-source-transformation func name)
     1471                         t)
    14701472                       (setq name (nx-need-function-name name))))))
    14711473      (nx1-form (cons name args))  ; This picks up call-next-method evil.
     
    15441546            (multiple-value-bind (body decls)
    15451547                                 (parse-body flet-function-body env)
    1546               (let ((func (make-afunc)))
     1548              (let ((func (make-afunc))
     1549                    (expansion `(lambda ,lambda-list
     1550                                  ,@decls
     1551                                  (block ,(if (consp funcname) (%cadr funcname) funcname)
     1552                                    ,@body))))
     1553                (nx-note-source-transformation def expansion)
    15471554                (setf (afunc-environment func) env
    1548                       (afunc-lambdaform func) `(lambda ,lambda-list
    1549                                                      ,@decls
    1550                                                      (block ,(if (consp funcname) (%cadr funcname) funcname)
    1551                                                        ,@body)))
     1555                      (afunc-lambdaform func) expansion)
    15521556                (push func funcs)
    15531557                (when (and *nx-next-method-var*
     
    16401644                                   (block ,blockname
    16411645                                     ,@body))))
     1646                (nx-note-source-transformation def expansion)
    16421647                (setf (afunc-lambdaform func) expansion
    16431648                      (afunc-environment func) env)
Note: See TracChangeset for help on using the changeset viewer.