Ignore:
Timestamp:
Feb 4, 2008, 7:03:04 PM (13 years ago)
Author:
wws
Message:

Marco's source-tracking-0801 branch passes tests on the customer system. Merge it here.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/working-0711/ccl/compiler/X86/x862.lisp

    r8019 r8421  
    175175(defvar *x862-record-symbols* nil)
    176176(defvar *x862-recorded-symbols* nil)
     177(defvar *x862-emitted-source-notes* '()
     178  "List of all the :source-location-begin notes we've emitted during this compile.")
     179(defvar *definition-source-note* nil
     180  "Represents the current 'toplevel' source note. Exists mainly so that (progn (defun a ..) (defun b
     181  ..)) can do the 'right' thing.")
    177182
    178183(defvar *x862-result-reg* x8664::arg_z)
     
    427432    0
    428433    (min (- (ash ea (- x8664::word-shift)) count) #xff)))
    429 
    430 
    431434(defun x862-compile (afunc &optional lambda-form *x862-record-symbols*)
    432435  (progn
     
    434437      (unless (afunc-lfun a)
    435438        (x862-compile a
    436                       (if lambda-form
    437                         (afunc-lambdaform a))
     439                      (if lambda-form (afunc-lambdaform a))
    438440                      *x862-record-symbols*))) ; always compile inner guys
    439441    (let* ((*x862-cur-afunc* afunc)
     
    504506           (*x862-vcells* (x862-ensure-binding-indices-for-vcells (afunc-vcells afunc)))
    505507           (*x862-fcells* (afunc-fcells afunc))
    506            *x862-recorded-symbols*)
     508           *x862-recorded-symbols*
     509           (*x862-emitted-source-notes* '()))
    507510      (set-fill-pointer
    508511       *backend-labels*
     
    530533               (with-dll-node-freelist ((frag-list make-frag-list) *frag-freelist*)
    531534                 (with-dll-node-freelist ((uuo-frag-list make-frag-list) *frag-freelist*)
    532                  (let* ((*x86-lap-labels* nil)
    533                         (instruction (x86::make-x86-instruction))
    534                         (end-code-tag (gensym))
    535                         debug-info)
    536                    (make-x86-lap-label end-code-tag)
    537                    (x86-lap-directive frag-list :long `(ash (+ (- (:^ ,end-code-tag ) 8)
    538                                                              *x86-lap-entry-offset*) -3))
    539                    (x86-lap-directive frag-list :byte 0) ;regsave PC
    540                    (x86-lap-directive frag-list :byte 0) ;regsave ea
    541                    (x86-lap-directive frag-list :byte 0) ;regsave mask
    542 
    543                    (x862-expand-vinsns vinsns frag-list instruction uuo-frag-list)
    544                    (when (or *x862-double-float-constant-alist*
    545                              *x862-single-float-constant-alist*)
     535                   (let* ((*x86-lap-labels* nil)
     536                          (instruction (x86::make-x86-instruction))
     537                          (end-code-tag (gensym))
     538                          debug-info)
     539                     (make-x86-lap-label end-code-tag)
     540                     (x86-lap-directive frag-list :long `(ash (+ (- (:^ ,end-code-tag ) 8)
     541                                                                 *x86-lap-entry-offset*)
     542                                                              -3))
     543                     (x86-lap-directive frag-list :byte 0) ;regsave PC
     544                     (x86-lap-directive frag-list :byte 0) ;regsave ea
     545                     (x86-lap-directive frag-list :byte 0) ;regsave mask
     546
     547                     (x862-expand-vinsns vinsns frag-list instruction uuo-frag-list)
     548                     (when (or *x862-double-float-constant-alist*
     549                               *x862-single-float-constant-alist*)
     550                       (x86-lap-directive frag-list :align 3)
     551                       (dolist (double-pair *x862-double-float-constant-alist*)
     552                         (destructuring-bind (dfloat . lab) double-pair
     553                           (setf (vinsn-label-info lab) (emit-x86-lap-label frag-list lab))
     554                           (multiple-value-bind (high low)
     555                               (x862-double-float-bits dfloat)
     556                             (x86-lap-directive frag-list :long low)
     557                             (x86-lap-directive frag-list :long high))))
     558                       (dolist (single-pair *x862-single-float-constant-alist*)
     559                         (destructuring-bind (sfloat . lab) single-pair
     560                           (setf (vinsn-label-info lab) (emit-x86-lap-label frag-list lab))
     561                           (let* ((val (single-float-bits sfloat)))
     562                             (x86-lap-directive frag-list :long val)))))
    546563                     (x86-lap-directive frag-list :align 3)
    547                      (dolist (double-pair *x862-double-float-constant-alist*)
    548                        (destructuring-bind (dfloat . lab) double-pair
    549                          (setf (vinsn-label-info lab) (emit-x86-lap-label frag-list lab))
    550                          (multiple-value-bind (high low)
    551                              (x862-double-float-bits dfloat)
    552                            (x86-lap-directive frag-list :long low)
    553                            (x86-lap-directive frag-list :long high))))
    554                      (dolist (single-pair *x862-single-float-constant-alist*)
    555                        (destructuring-bind (sfloat . lab) single-pair
    556                          (setf (vinsn-label-info lab) (emit-x86-lap-label frag-list lab))
    557                          (let* ((val (single-float-bits sfloat)))
    558                            (x86-lap-directive frag-list :long val)))))
    559                    (x86-lap-directive frag-list :align 3)
    560                    (x86-lap-directive frag-list :quad x8664::function-boundary-marker)
    561                    (emit-x86-lap-label frag-list end-code-tag)
    562                    (dolist (c (reverse *x862-constant-alist*))
    563                      (let* ((vinsn-label (cdr c)))
    564                        (or (vinsn-label-info vinsn-label)
    565                            (setf (vinsn-label-info vinsn-label)
    566                                  (find-or-create-x86-lap-label
    567                                   vinsn-label)))
    568                        (emit-x86-lap-label frag-list vinsn-label)
    569                        (x86-lap-directive frag-list :quad 0)))
     564                     (x86-lap-directive frag-list :quad x8664::function-boundary-marker)
     565                     (emit-x86-lap-label frag-list end-code-tag)
     566                     (dolist (c (reverse *x862-constant-alist*))
     567                       (let* ((vinsn-label (cdr c)))
     568                         (or (vinsn-label-info vinsn-label)
     569                             (setf (vinsn-label-info vinsn-label)
     570                                   (find-or-create-x86-lap-label
     571                                    vinsn-label)))
     572                         (emit-x86-lap-label frag-list vinsn-label)
     573                         (x86-lap-directive frag-list :quad 1)))
    570574                 
    571                    (if (logbitp $fbitnonnullenv (the fixnum (afunc-bits afunc)))
    572                      (setq bits (+ bits (ash 1 $lfbits-nonnullenv-bit))))
    573                    (let* ((function-debugging-info (afunc-lfun-info afunc)))
    574                      (when (or function-debugging-info lambda-form *x862-record-symbols*)
    575                        (if lambda-form (setq function-debugging-info
    576                                              (list* 'function-lambda-expression lambda-form function-debugging-info)))
    577                        (if *x862-record-symbols*
    578                          (setq function-debugging-info (nconc (list 'function-symbol-map *x862-recorded-symbols*)
    579                                                               function-debugging-info)))
    580                        (setq bits (logior (ash 1 $lfbits-symmap-bit) bits))
    581                        (setq debug-info function-debugging-info)))
    582                    (unless (or fname lambda-form *x862-recorded-symbols*)
    583                      (setq bits (logior (ash 1 $lfbits-noname-bit) bits)))
    584                    (unless (afunc-parent afunc)
    585                      (x862-fixup-fwd-refs afunc))
    586                    (setf (afunc-all-vars afunc) nil)
    587                    (setf (afunc-argsword afunc) bits)
    588                    (let* ((regsave-label (if (typep *x862-compiler-register-save-label* 'vinsn-note)
    589                                            (vinsn-label-info (vinsn-note-label *x862-compiler-register-save-label*))))
    590                           (regsave-mask (if regsave-label (x862-register-mask-byte
    591                                                            *x862-register-restore-count*)))
    592                           (regsave-addr (if regsave-label (x862-encode-register-save-ea
    593                                                            *x862-register-restore-ea*
    594                                                            *x862-register-restore-count*))))
    595                      (when debug-info
    596                        (x86-lap-directive frag-list :quad 0))
    597                      (when fname
    598                        (x86-lap-directive frag-list :quad 0))
    599                      (x86-lap-directive frag-list :quad 0)
    600                      (relax-frag-list frag-list)
    601                      (apply-relocs frag-list)
    602                      (fill-for-alignment frag-list)
    603                      (x862-lap-process-regsave-info frag-list regsave-label regsave-mask regsave-addr)
    604                      (setf (afunc-lfun afunc)
    605                            #+x86-target
    606                            (if (eq *host-backend* *target-backend*)
    607                              (create-x86-function fname frag-list *x862-constant-alist* bits debug-info)
     575                     (if (logbitp $fbitnonnullenv (the fixnum (afunc-bits afunc)))
     576                       (setq bits (+ bits (ash 1 $lfbits-nonnullenv-bit))))
     577                     (unless (afunc-parent afunc)
     578                       (x862-fixup-fwd-refs afunc))
     579                     (setf (afunc-all-vars afunc) nil)
     580                     (let* ((regsave-label (if (typep *x862-compiler-register-save-label* 'vinsn-note)
     581                                             (vinsn-label-info (vinsn-note-label *x862-compiler-register-save-label*))))
     582                            (regsave-mask (if regsave-label (x862-register-mask-byte
     583                                                             *x862-register-restore-count*)))
     584                            (regsave-addr (if regsave-label (x862-encode-register-save-ea
     585                                                             *x862-register-restore-ea*
     586                                                             *x862-register-restore-count*))))
     587
     588                       
     589                       (when (or (afunc-lfun-info afunc)
     590                                 lambda-form
     591                                 (and *compiler-record-source* *definition-source-note*)
     592                                 *x862-recorded-symbols*
     593                                 (and *compiler-record-source* *x862-emitted-source-notes* *definition-source-note*))
     594                         (x86-lap-directive frag-list :quad 0))
     595                       (when fname
     596                         (x86-lap-directive frag-list :quad 0))
     597                       (x86-lap-directive frag-list :quad 0)
     598                       (relax-frag-list frag-list)
     599                       (apply-relocs frag-list)
     600                       (fill-for-alignment frag-list)
     601                       (x862-lap-process-regsave-info frag-list regsave-label regsave-mask regsave-addr)
     602                       (setf debug-info
     603                             (nconc (copy-list (afunc-lfun-info afunc))
     604                                    (when lambda-form
     605                                      (list 'function-debugging-info lambda-form))
     606                                    (when (and *compiler-record-source* *definition-source-note*)
     607                                      (list 'function-source-note
     608                                            (source-note-to-list *definition-source-note* :form nil :children nil)))
     609                                    (when *x862-recorded-symbols*
     610                                      (list 'function-symbol-map *x862-recorded-symbols*))
     611                                    (when (and *compiler-record-source*
     612                                               *x862-emitted-source-notes*
     613                                               *definition-source-note*)
     614                                      (list 'pc-source-map
     615                                            (x862-generate-pc-source-map *definition-source-note*
     616                                                                         *x862-emitted-source-notes*)))))
     617                       (when debug-info
     618                         (setq bits (logior (ash 1 $lfbits-info-bit) bits)))
     619                       (unless (or fname lambda-form *x862-recorded-symbols*)
     620                         (setq bits (logior (ash 1 $lfbits-noname-bit) bits)))
     621                       (setf (afunc-argsword afunc) bits)
     622                       (setf (afunc-lfun afunc)
     623                             #+x86-target
     624                             (if (eq *host-backend* *target-backend*)
     625                               (create-x86-function       fname frag-list *x862-constant-alist* bits debug-info)
     626                               (cross-create-x86-function fname frag-list *x862-constant-alist* bits debug-info))
     627                             #-x86-target
    608628                             (cross-create-x86-function fname frag-list *x862-constant-alist* bits debug-info))
    609                            #-x86-target
    610                            (cross-create-x86-function fname frag-list *x862-constant-alist* bits debug-info)))
    611                    (x862-digest-symbols)))))
     629                       (x862-digest-symbols))))))
    612630          (backend-remove-labels))))
    613631    afunc))
    614 
    615 
    616      
    617632   
    618633(defun x862-make-stack (size &optional (subtype target::subtag-s16-vector))
     
    644659                (setf (%svref v i) ref-fun)))))))))
    645660
     661(defun x862-generate-pc-source-map (definition-source-note emitted-source-notes)
     662  (when *compiler-record-source*
     663    (let ((def-start (source-note-start definition-source-note)))
     664      (mapcar (lambda (start)
     665                (list :pc-range (cons (x862-vinsn-note-label-address
     666                                       start
     667                                       t)
     668                                      (x862-vinsn-note-label-address
     669                                       (vinsn-note-peer start)
     670                                       nil))
     671                      :source-text-range (cons (- (source-note-start (aref (vinsn-note-info start) 0))
     672                                                  def-start)
     673                                               (- (source-note-end (aref (vinsn-note-info start) 0))
     674                                                  def-start))))
     675              emitted-source-notes))))
     676
     677(defun x862-vinsn-note-label-address (note &optional start-p sym)
     678  (-
     679   (let* ((label (vinsn-note-label note))
     680          (lap-label (if label (vinsn-label-info label))))
     681     (if lap-label
     682         (x86-lap-label-address lap-label)
     683         (compiler-bug "Missing or bad ~s label~@[: ~s~]"
     684                       (if start-p 'start 'end)
     685                       sym)))
     686   x8664::fulltag-function))
     687
    646688(defun x862-digest-symbols ()
    647689  (if *x862-recorded-symbols*
    648     (let* ((symlist *x862-recorded-symbols*)
    649            (len (length symlist))
    650            (syms (make-array len))
    651            (ptrs (make-array (%i+  (%i+ len len) len)))
    652            (i -1)
    653            (j -1))
    654       (declare (fixnum i j))
    655       (dolist (info symlist (progn (%rplaca symlist syms)
    656                                    (%rplacd symlist ptrs)))
    657         (flet ((label-address (note start-p sym)
    658                  (-
    659                   (let* ((label (vinsn-note-label note))
    660                          (lap-label (if label (vinsn-label-info label))))
    661                     (if lap-label
    662                       (x86-lap-label-address lap-label)
    663                       (compiler-bug "Missing or bad ~s label: ~s"
    664                                     (if start-p 'start 'end) sym)))
    665                   x8664::fulltag-function)))
     690      (let* ((symlist *x862-recorded-symbols*)
     691             (len (length symlist))
     692             (syms (make-array len))
     693             (ptrs (make-array (%i+  (%i+ len len) len)))
     694             (i -1)
     695             (j -1))
     696        (declare (fixnum i j))
     697        (dolist (info symlist (progn (%rplaca symlist syms)
     698                                     (%rplacd symlist ptrs)))
    666699          (destructuring-bind (var sym startlab endlab) info
    667700            (let* ((ea (var-ea var))
    668701                   (ea-val (ldb (byte 16 0) ea)))
    669702              (setf (aref ptrs (incf i)) (if (memory-spec-p ea)
    670                                            (logior (ash ea-val 6) #o77)
    671                                            ea-val)))
     703                                             (logior (ash ea-val 6) #o77)
     704                                             ea-val)))
    672705            (setf (aref syms (incf j)) sym)
    673             (setf (aref ptrs (incf i)) (label-address startlab t sym))
    674             (setf (aref ptrs (incf i)) (label-address endlab nil sym))))))))
     706            (setf (aref ptrs (incf i)) (x862-vinsn-note-label-address startlab t sym))
     707            (setf (aref ptrs (incf i)) (x862-vinsn-note-label-address endlab nil sym))))
     708        *x862-recorded-symbols*)))
    675709
    676710(defun x862-decls (decls)
     
    10881122    n))
    10891123
     1124(defun x862-emit-source-note (seg class nx1-form)
     1125  (check-type class (member :source-location-begin :source-location-end))
     1126  (when (nx1-source-note nx1-form)
     1127    (x862-emit-note seg class (nx1-source-note nx1-form))))
     1128
     1129(defmacro x862-wrap-in-source-notes ((seg form) &body body)
     1130  (let ((x862-wrap-in-source-notes-body (gensym "X862-WRAP-IN-SOURCE-NOTES-BODY-")))
     1131    `(flet ((,x862-wrap-in-source-notes-body () ,@body))
     1132       (call-with-x862-wrap-in-source-notes ,seg ,form #',x862-wrap-in-source-notes-body))))
     1133
     1134(defun call-with-x862-wrap-in-source-notes (seg form thunk)
     1135  (let (start end)
     1136    (setf start (x862-emit-source-note seg :source-location-begin form))
     1137    (multiple-value-prog1
     1138        (funcall thunk)
     1139      (setf end (x862-emit-source-note seg :source-location-end form))
     1140      (when (and start end)
     1141        (setf (vinsn-note-peer start) end
     1142              (vinsn-note-peer end) start
     1143              *x862-emitted-source-notes* (cons start *x862-emitted-source-notes*))))))
    10901144
    10911145(defun x862-form (seg vreg xfer form)
    1092   (if (nx-null form)
    1093     (x862-nil seg vreg xfer)
    1094     (if (nx-t form)
    1095       (x862-t seg vreg xfer)
    1096       (let* ((op nil)
    1097              (fn nil))
    1098         (if (and (consp form)
    1099                  (setq fn (svref *x862-specials* (%ilogand #.operator-id-mask (setq op (acode-operator form))))))
    1100           (if (and (null vreg)
    1101                    (%ilogbitp operator-acode-subforms-bit op)
    1102                    (%ilogbitp operator-assignment-free-bit op))
    1103             (dolist (f (%cdr form) (x862-branch seg xfer))
    1104               (x862-form seg nil nil f ))
    1105             (apply fn seg vreg xfer (%cdr form)))
    1106           (compiler-bug "x862-form ? ~s" form))))))
     1146  (x862-wrap-in-source-notes (seg form)
     1147     (if (nx-null form)
     1148         (x862-nil seg vreg xfer)
     1149         (if (nx-t form)
     1150             (x862-t seg vreg xfer)
     1151             (let* ((op nil)
     1152                    (fn nil))
     1153               (if (and (consp form)
     1154                        (setq fn (svref *x862-specials* (%ilogand #.operator-id-mask (setq op (acode-operator form))))))
     1155                   (if (and (null vreg)
     1156                            (%ilogbitp operator-acode-subforms-bit op)
     1157                            (%ilogbitp operator-assignment-free-bit op))
     1158                       (dolist (f (%cdr form) (x862-branch seg xfer))
     1159                         (x862-form seg nil nil f ))
     1160                       (apply fn seg vreg xfer (%cdr form)))
     1161                   (compiler-bug "x862-form ? ~s" form)))))))
    11071162
    11081163;;; dest is a float reg - form is acode
     
    50795134  (let* ((lab (vinsn-note-label note)))
    50805135    (case (vinsn-note-class note)
    5081       ((:regsave :begin-variable-scope :end-variable-scope)
     5136      ((:regsave :begin-variable-scope :end-variable-scope
     5137        :source-location-begin :source-location-end)
    50825138       (setf (vinsn-label-info lab) (emit-x86-lap-label frag-list lab))))))
    50835139
     
    91079163                         *target-ftd*)))
    91089164    (multiple-value-bind (xlfun warnings)
    9109         (compile-named-function def nil
    9110                                 nil
    9111                                 nil
    9112                                 nil
    9113                                 nil
    9114                                 nil
    9115                                 target)
     9165        (compile-named-function def :target target)
    91169166      (signal-or-defer-warnings warnings nil)
    91179167      (when disassemble
Note: See TracChangeset for help on using the changeset viewer.