Changeset 15916


Ignore:
Timestamp:
Sep 29, 2013, 3:35:37 AM (8 years ago)
Author:
gb
Message:

Start to bootstrap vinsn changes.

Location:
branches/acode-rewrite/source/compiler
Files:
3 edited

Legend:

Unmodified
Added
Removed
  • branches/acode-rewrite/source/compiler/X86/x862.lisp

    r15913 r15916  
    154154(defvar *x862-register-restore-count* 0)
    155155(defvar *x862-register-restore-ea* nil)
    156 (defvar *x862-compiler-register-save-label* nil)
     156(defvar *x862-compiler-register-save-note* nil)
    157157(defvar *x862-valid-register-annotations* 0)
    158158(defvar *x862-register-annotation-types* nil)
     
    512512           (*x862-open-code-inline* nil)
    513513           (*x862-register-restore-count* nil)
    514            (*x862-compiler-register-save-label* nil)
     514           (*x862-compiler-register-save-note* nil)
    515515           (*x862-valid-register-annotations* 0)
    516516           (*x862-register-ea-annotations* (x862-make-stack 16))
     
    750750                   (setf (afunc-all-vars afunc) nil)
    751751                   (setf (afunc-argsword afunc) bits)
    752                    (let* ((regsave-label (if (typep *x862-compiler-register-save-label* 'vinsn-note)
    753                                            (vinsn-label-info (vinsn-note-label *x862-compiler-register-save-label*))))
     752                   (let* ((regsave-label (if (typep *x862-compiler-register-save-note* 'vinsn-note)
     753                                           (vinsn-note-address *x862-compiler-register-save-note*)))
    754754                          (regsave-mask (if regsave-label (x862-register-mask-byte
    755755                                                           *x862-register-restore-count*)))
     
    959959(defun x862-vinsn-note-label-address (note &optional start-p sym)
    960960  (-
    961    (let* ((label (vinsn-note-label note))
    962           (lap-label (if label (vinsn-label-info label))))
     961   (let* ((lap-label (vinsn-note-address note)))
    963962     (if lap-label
    964963       (x86-lap-label-address lap-label)
     
    10191018   (:x8664
    10201019    (when (> n 0)
    1021       (setq *x862-compiler-register-save-label* (x862-emit-note seg :regsave))
     1020      (setq *x862-compiler-register-save-note* (enqueue-vinsn-note seg :regsave))
    10221021      (with-x86-local-vinsn-macros (seg)
    10231022        (let* ((mask x8664-nonvolatile-node-regs))
     
    12991298      (compiler-bug "x862-form ? ~s" form)))
    13001299
    1301 (defmacro with-note ((form-var seg-var) &body body)
     1300(defmacro x86-with-note ((form-var seg-var) &body body)
    13021301  (let* ((note (gensym "NOTE"))
    13031302         (code-note (gensym "CODE-NOTE"))
    13041303         (source-note (gensym "SOURCE-NOTE"))
    1305          (start (gensym "START"))
    1306          (end (gensym "END")))
     1304         (start (gensym "START")))
    13071305    `(let* ((,note (acode-note ,form-var))
    13081306            (,code-note (and ,note (code-note-p ,note) ,note))           
     
    13111309                            ,note))
    13121310            (,start (and ,source-note
    1313                          (x862-emit-note ,seg-var :source-location-begin ,source-note))))
     1311                         (enqueue-vinsn-note ,seg-var :source-location-begin ,source-note))))
    13141312      #+debug-code-notes (require-type ,note '(or null code-note source-note))
    13151313      (when ,code-note
     
    13211319            ,@body)
    13221320        (when ,source-note
    1323           (let ((,end (x862-emit-note ,seg-var :source-location-end)))
    1324             (setf (vinsn-note-peer ,start) ,end
    1325                   (vinsn-note-peer ,end) ,start)
    1326             (push ,start *x862-emitted-source-notes*)))))))
     1321          (close-vinsn-note ,seg-var ,start))))))
    13271322
    13281323(defun x862-toplevel-form (seg vreg xfer form)
     
    13351330  (when (eq vreg :push)
    13361331    (x862-regmap-note-store nil *x862-vstack*))
    1337   (with-note (form seg)
     1332  (x86-with-note (form seg)
    13381333    (if (nx-null form)
    13391334      (x862-nil seg vreg xfer)
     
    13541349(defun x862-form-float (seg freg xfer form)
    13551350  (declare (ignore xfer))
    1356   (with-note (form seg)
     1351  (x86-with-note (form seg)
    13571352    (when (or (nx-null form)(nx-t form))(compiler-bug "x862-form to freg ~s" form))
    13581353    (when (and (= (get-regspec-mode freg) hard-reg-class-fpr-mode-double)
     
    14271422
    14281423
    1429 ;;; Emit a note at the end of the segment.
    1430 (defun x862-emit-note (seg class &rest info)
    1431   (declare (dynamic-extent info))
    1432   (let* ((note (make-vinsn-note class info)))
    1433     (append-dll-node (vinsn-note-label note) seg)
    1434     note))
    1435 
    1436 ;;; Emit a note immediately before the target vinsn.
    1437 (defun x86-prepend-note (vinsn class &rest info)
    1438   (declare (dynamic-extent info))
    1439   (let* ((note (make-vinsn-note class info)))
    1440     (insert-dll-node-before (vinsn-note-label note) vinsn)
    1441     note))
    1442 
    1443 (defun x862-close-note (seg note)
    1444   (let* ((end (close-vinsn-note note)))
    1445     (append-dll-node (vinsn-note-label end) seg)
    1446     end))
    14471424
    14481425(defun x862-register-for-frame-offset (offset &optional suggested)
     
    46874664    ;; this will do source note processing even if don't emit anything here,
    46884665    ;; which is a bit wasteful but not incorrect.
    4689     (with-note (form seg)
     4666    (x86-with-note (form seg)
    46904667      (with-x86-local-vinsn-macros (seg)
    46914668        (let* ((op (acode-operator form))
     
    49244901  (setf (var-ea var) ea)
    49254902  (when (and *x862-record-symbols* (or (typep ea 'lreg) (typep ea 'fixnum)))
    4926     (let* ((start (x862-emit-note seg :begin-variable-scope)))
    4927       (push (list var (var-name var) start (close-vinsn-note start))
     4903    (let* ((start (enqueue-vinsn-note seg :begin-variable-scope var)))
     4904      (push (list var (var-name var) start nil)
    49284905            *x862-recorded-symbols*)))
    49294906  ea)
     
    49344911               (or (logbitp $vbitspecial bits)
    49354912                   (not (logbitp $vbitpunted bits))))
    4936       (let ((endnote (%car (%cdddr (assq var *x862-recorded-symbols*)))))
    4937         (unless endnote (compiler-bug "x862-close-var for ~s" (var-name var)))
    4938         (setf (vinsn-note-class endnote) :end-variable-scope)
    4939         (append-dll-node (vinsn-note-label endnote) seg)))))
     4913      (let* ((info (%cdr (assq var *x862-recorded-symbols*))))
     4914        (unless info (compiler-bug "x862-close-var for ~s" (var-name var)))
     4915        (setf (caddr info) (close-vinsn-note seg (cadr info)))))))
    49404916
    49414917(defun x862-load-ea-p (ea)
     
    55465522  (let* ((uwf (acode-unwrapped-form-value form)))
    55475523    (if (x86-constant-form-p uwf)
    5548       (with-note (form seg)
     5524      (x86-with-note (form seg)
    55495525        (if (nx-null uwf)
    55505526          (x862-branch seg (x862-cd-false xfer))
     
    55535529        (let* ((ea (x862-lexical-reference-ea form nil)))
    55545530          (if (and ea (memory-spec-p ea))
    5555             (with-note (form seg)
     5531            (x86-with-note (form seg)
    55565532              (x862-compare-ea-to-nil seg crf xfer ea x86::x86-e-bits nil))
    55575533            (x862-form seg crf xfer form)))))))
     
    56765652                  (let* ((last-vinsn (last-vinsn seg so-far))
    56775653                         (unconditional (and last-vinsn (eq last-vinsn (last-vinsn-unless-label seg))))
    5678                          (vinsn-name (and last-vinsn (vinsn-template-name (vinsn-template last-vinsn))))
     5654                         (template (and last-vinsn (vinsn-template last-vinsn)))
     5655                         (vinsn-name (and last-vinsn (vinsn-template-name template)))
    56795656                         (constant-valued (member vinsn-name
    56805657                                                  '(load-nil load-t lri lriu ref-constant))))
     
    56885665                               (insert-dll-node-after adjust last-vinsn)
    56895666                               (insert-dll-node-after jump adjust)
    5690                                (remove-dll-node last-vinsn)
     5667                               (elide-vinsn last-vinsn)
    56915668                               (setq handled-crf unconditional)))))))
    56925669                (unless handled-crf
     
    60195996(defun x862-mv-p (cd)
    60205997  (or (eq cd $backend-return) (x862-mvpass-p cd)))
    6021 
    6022 (defun x862-expand-note (frag-list note)
    6023   (let* ((lab (vinsn-note-label note)))
    6024     (case (vinsn-note-class note)
    6025       ((:regsave :begin-variable-scope :end-variable-scope
    6026         :source-location-begin :source-location-end)
    6027        (setf (vinsn-label-info lab) (emit-x86-lap-label frag-list lab))))))
    60285998
    60295999(defun x86-emit-instruction-from-vinsn (opcode-template
     
    61906160          (if (or (typep id 'fixnum) (null id))
    61916161            (when (or t (vinsn-label-refs v) (null id))
    6192               (setf (vinsn-label-info v) (emit-x86-lap-label frag-list v)))
    6193             (x862-expand-note frag-list id)))
     6162              (setf (vinsn-label-info v) (emit-x86-lap-label frag-list v)))))
    61946163        (x862-expand-vinsn v frag-list instruction immediate-operand uuo-frag-list)))
    61956164    (when uuo-frag-list
     
    62196188         (main-frag-list frag-list)
    62206189         (vp (vinsn-variable-parts vinsn))
    6221          (nvp (vinsn-template-nvp template))
    6222          (unique-labels ()))
     6190         (nvp (if template (vinsn-template-nvp template) 0))
     6191         (unique-labels ())
     6192         (notes (vinsn-notes vinsn)))
    62236193    (declare (fixnum nvp))
    62246194    (dotimes (i nvp)
    62256195      (let* ((val (svref vp i)))
    62266196        (when (typep val 'lreg)
    6227           (setf (svref vp i) (lreg-value val)))))                       
    6228     (dolist (name (vinsn-template-local-labels template))
    6229       (let* ((unique (cons name nil)))
    6230         (push unique unique-labels)
    6231         (make-x86-lap-label unique)))
     6197          (setf (svref vp i) (lreg-value val)))))
     6198    (when template
     6199      (dolist (name (vinsn-template-local-labels template))
     6200        (let* ((unique (cons name nil)))
     6201          (push unique unique-labels)
     6202          (make-x86-lap-label unique))))
    62326203    (labels ((parse-operand-form (valform &optional for-pred)
    62336204               (cond ((typep valform 'keyword)
     
    63046275                  (frag-list-push-byte frag-list 0))
    63056276                 ((:uuo :uuo-section)
    6306                       (if uuo-frag-list
    6307                         (progn
    6308                           (setq frag-list uuo-frag-list)
    6309                           (finish-frag-for-align frag-list 2))
    6310                         (compiler-bug "No frag-list for :uuo")))
     6277                  (if uuo-frag-list
     6278                    (progn
     6279                      (setq frag-list uuo-frag-list)
     6280                      (finish-frag-for-align frag-list 2))
     6281                    (compiler-bug "No frag-list for :uuo")))
    63116282                 ((:main :main-section)
    63126283                  (setq frag-list main-frag-list))
    63136284                 (t
    63146285                  (destructuring-bind (directive arg) f
    6315                      (setq arg (parse-operand-form arg))
    6316                      (let* ((exp (parse-x86-lap-expression arg))
    6317                             (constantp (or (not (x86-lap-expression-p exp))
    6318                                            (constant-x86-lap-expression-p exp))))
    6319                        (if constantp
    6320                          (let* ((val (x86-lap-expression-value exp)))
    6321                            (ecase directive
    6322                              (:byte (frag-list-push-byte frag-list val))
    6323                              (:short (frag-list-push-16 frag-list val))
    6324                              (:long (frag-list-push-32 frag-list val))
    6325                              (:quad (frag-list-push-64 frag-list val))
    6326                              (:align (finish-frag-for-align frag-list val))
    6327                              (:talign (finish-frag-for-talign frag-list val))))
    6328                          (let* ((pos (frag-list-position frag-list))
    6329                                 (frag (frag-list-current frag-list))
    6330                                 (reloctype nil))
    6331                            (ecase directive
    6332                              (:byte (frag-list-push-byte frag-list 0)
    6333                                     (setq reloctype :expr8))
    6334                              (:short (frag-list-push-16 frag-list 0)
    6335                                      (setq reloctype :expr16))
    6336                              (:long (frag-list-push-32 frag-list 0)
    6337                                     (setq reloctype :expr32))
    6338                              (:quad (frag-list-push-64 frag-list 0)
    6339                                     (setq reloctype :expr64))
    6340                              ((:align :talign) (compiler-bug "~s expression ~s not constant" directive arg)))
    6341                            (when reloctype
    6342                              (push
    6343                               (make-reloc :type reloctype
    6344                                           :arg exp
    6345                                           :pos pos
    6346                                           :frag frag)
    6347                               (frag-relocs frag))))))))))
     6286                    (setq arg (parse-operand-form arg))
     6287                    (let* ((exp (parse-x86-lap-expression arg))
     6288                           (constantp (or (not (x86-lap-expression-p exp))
     6289                                          (constant-x86-lap-expression-p exp))))
     6290                      (if constantp
     6291                        (let* ((val (x86-lap-expression-value exp)))
     6292                          (ecase directive
     6293                            (:byte (frag-list-push-byte frag-list val))
     6294                            (:short (frag-list-push-16 frag-list val))
     6295                            (:long (frag-list-push-32 frag-list val))
     6296                            (:quad (frag-list-push-64 frag-list val))
     6297                            (:align (finish-frag-for-align frag-list val))
     6298                            (:talign (finish-frag-for-talign frag-list val))))
     6299                        (let* ((pos (frag-list-position frag-list))
     6300                               (frag (frag-list-current frag-list))
     6301                               (reloctype nil))
     6302                          (ecase directive
     6303                            (:byte (frag-list-push-byte frag-list 0)
     6304                                   (setq reloctype :expr8))
     6305                            (:short (frag-list-push-16 frag-list 0)
     6306                                    (setq reloctype :expr16))
     6307                            (:long (frag-list-push-32 frag-list 0)
     6308                                   (setq reloctype :expr32))
     6309                            (:quad (frag-list-push-64 frag-list 0)
     6310                                   (setq reloctype :expr64))
     6311                            ((:align :talign) (compiler-bug "~s expression ~s not constant" directive arg)))
     6312                          (when reloctype
     6313                            (push
     6314                             (make-reloc :type reloctype
     6315                                         :arg exp
     6316                                         :pos pos
     6317                                         :frag frag)
     6318                             (frag-relocs frag))))))))))
    63486319                   
    63496320             (expand-form (f)
     
    63616332      (declare (dynamic-extent #'expand-form #'parse-operand-form #'expand-insn-form #'eval-predicate))
    63626333      ;;(format t "~& vinsn = ~s" vinsn)
    6363       (dolist (form (vinsn-template-body template))
    6364         ;;(format t "~&form = ~s" form)
    6365         (expand-form form ))
     6334      (when notes
     6335        (let* ((lab ()))
     6336          (dolist (note notes)
     6337            (unless (eq :close (vinsn-note-class note))
     6338              (when (eq :source-location-begin
     6339                        (vinsn-note-class note))
     6340                (push note *x862-emitted-source-notes*))
     6341              (when (null lab)
     6342                (setq lab (make-x86-lap-label note))
     6343                (emit-x86-lap-label frag-list note))
     6344              (setf (vinsn-note-address note) lab)))))
     6345      (when template
     6346        (dolist (form (vinsn-template-body template))
     6347          ;;(format t "~&form = ~s" form)
     6348          (expand-form form )))
     6349      (when notes
     6350        (let* ((lab ()))
     6351          (dolist (note notes)
     6352            (when (eq :close (vinsn-note-class note))
     6353              (when (null lab)
     6354                (setq lab (make-x86-lap-label note))
     6355                (emit-x86-lap-label frag-list note))
     6356              (setf (vinsn-note-address note) lab)))))
    63666357      (setf (vinsn-variable-parts vinsn) nil)
    63676358      (when vp
     
    95839574                    (eq typespec '*))
    95849575              (x862-form seg vreg xfer form)
    9585               (with-note (form seg)
     9576              (x86-with-note (form seg)
    95869577                (let* ((ok (backend-get-next-label)))
    95879578                  (if (and (symbolp typespec) (non-nil-symbolp (type-predicate typespec)))
  • branches/acode-rewrite/source/compiler/dll-node.lisp

    r15854 r15916  
    2828            (:include dll-node)
    2929            (:constructor %make-dll-header))
     30  info
    3031)
    3132
     
    3536
    3637(defun init-dll-header (h)
    37   (setf (dll-header-first h) h
     38  (setf (dll-header-info h) nil
     39        (dll-header-first h) h
    3840        (dll-header-last h) h))
    3941
  • branches/acode-rewrite/source/compiler/vinsn.lisp

    r15606 r15916  
    5656  (make-load-form-saving-slots v :environment env))
    5757
     58(defstatic *empty-vinsn-template* (make-vinsn-template))
    5859
    5960(defun get-vinsn-template-cell (name templates)
     
    7980  (gprs-read 0)
    8081  (fprs-read 0)
     82  (notes ())
    8183)
    8284
     
    102104              (vinsn-fprs-set vinsn) 0
    103105              (vinsn-gprs-read vinsn) 0
    104               (vinsn-fprs-read vinsn) 0)
     106              (vinsn-fprs-read vinsn) 0
     107              (vinsn-notes vinsn) nil)
     108       
    105109        vinsn)
    106110      (%make-vinsn template))))
     
    148152            (:constructor %make-vinsn-note)
    149153            (:print-function print-vinsn-note))
    150   (label (make-vinsn-label nil))
     154  (address nil)                           ; lap label
    151155  (peer nil :type (or null vinsn-note))
    152156  (class nil)
    153157  (info nil :type (or null simple-vector)))
     158
     159
    154160
    155161
     
    162168 
    163169(defun make-vinsn-note (class info)
    164   (let* ((n (%make-vinsn-note :class class :info (if info (apply #'vector info))))
    165          (lab (vinsn-note-label n)))
    166     (setf (vinsn-label-id lab) n)
    167     n))
    168 
    169 (defun close-vinsn-note (n)
    170   (let* ((end (%make-vinsn-note :peer n)))
    171     (setf (vinsn-label-id (vinsn-note-label end)) end
    172           (vinsn-note-peer end) n
    173           (vinsn-note-peer n) end)
    174     end))
     170  (%make-vinsn-note :class class :info (if info (apply #'vector info))))
     171
     172(defun enqueue-vinsn-note (seg class &rest info)
     173  (let* ((note (make-vinsn-note class info)))
     174    (push note (dll-header-info seg))
     175    note))
     176
     177(defun close-vinsn-note (seg n)
     178  (let* ((vinsn (last-vinsn seg)))
     179    (unless vinsn
     180      (nx-error "No last vinsn in ~s." seg))
     181    (let* ((end (%make-vinsn-note :peer n :class :close)))
     182      #+debug
     183      (format t "~& adding note ~s to vinsn ~s, closing ~s" end vinsn n)
     184      (push end (vinsn-notes vinsn))     
     185      (setf (vinsn-note-peer n) end))))
     186
    175187       
    176188
     
    240252        (format stream "~A~{ ~A~}" opname args))
    241253      (let* ((annotation (vinsn-annotation v)))
    242         (when annotation
    243           (format stream " ||~a|| " annotation))))))
     254        (when annotation
     255          (format stream " ||~a|| " annotation))))))
    244256
    245257(eval-when (:compile-toplevel :load-toplevel :execute)
     
    297309   nil))
    298310
     311(defun distribute-vinsn-notes (notes pred succ)
     312  (or (null notes)
     313      (and (dolist (note notes t)
     314             (unless (if (eq :close (vinsn-note-class note))
     315                       (typep pred 'vinsn)
     316                       (typep succ 'vinsn))
     317               (return nil)))
     318           (dolist (note notes t)
     319             (if (eq :close (vinsn-note-class note))
     320               (push note (vinsn-notes pred))
     321               (push note (vinsn-notes succ)))))))
     322
    299323(defun elide-vinsn (vinsn)
    300   (let* ((nvp (vinsn-template-nvp (vinsn-template vinsn)))
    301          (vp (vinsn-variable-parts vinsn)))
    302     (dotimes (i nvp)
    303       (let* ((v (svref vp i)))
    304         (when (typep v 'lreg)
    305           (setf (lreg-defs v) (delete vinsn (lreg-defs v)))
    306           (setf (lreg-refs v) (delete vinsn (lreg-refs v))))))
    307     (free-varparts-vector vp)
    308     (remove-dll-node vinsn)))
     324  (let* ((template (vinsn-template vinsn))
     325             (nvp (vinsn-template-nvp template))
     326             (vp (vinsn-variable-parts vinsn)))
     327        (dotimes (i nvp)
     328          (let* ((v (svref vp i)))
     329            (when (typep v 'lreg)
     330              (setf (lreg-defs v) (delete vinsn (lreg-defs v)))
     331              (setf (lreg-refs v) (delete vinsn (lreg-refs v))))))
     332        (free-varparts-vector vp)
     333        (setf (vinsn-variable-parts vinsn) nil)
     334        (if (distribute-vinsn-notes (vinsn-notes vinsn) (vinsn-pred vinsn) (vinsn-succ vinsn))
     335          (remove-dll-node vinsn)
     336          (setf (vinsn-template vinsn) *empty-vinsn-template*))))
    309337   
    310338(defun encode-vinsn-attributes (attribute-list)
     
    482510
    483511(defun %emit-vinsn (vlist name vinsn-table &rest vregs)
    484   (append-dll-node (select-vinsn name vinsn-table vregs) vlist))
     512  (let* ((vinsn (select-vinsn name vinsn-table vregs))
     513         (notes (dll-header-info vlist)))
     514    (when notes
     515      (dolist (note notes (setf (dll-header-info vlist) nil))
     516        (push note (vinsn-notes vinsn))))
     517    (append-dll-node vinsn vlist)))
    485518
    486519(defun varpart-matches-reg (varpart-value class regval spec)
     
    789822                 (setq eliding nil))))
    790823           (cond (eliding
    791                     (setq won t)
    792                     (let* ((operands (vinsn-variable-parts element)))
    793                       (dotimes (i (length operands) (elide-vinsn element))
    794                         (let* ((op (svref operands i)))
    795                           (when (typep op 'vinsn-label)
    796                             (setf (vinsn-label-refs op)
    797                                   (delete element (vinsn-label-refs op))))))))
    798                    (t (setq eliding (vinsn-attribute-p element :jump))))))))))
     824                  (setq won t)
     825                  (let* ((operands (vinsn-variable-parts element)))
     826                    (dotimes (i (length operands) (elide-vinsn element))
     827                      (let* ((op (svref operands i)))
     828                        (when (typep op 'vinsn-label)
     829                          (setf (vinsn-label-refs op)
     830                                (delete element (vinsn-label-refs op))))))))
     831                 (t (setq eliding (vinsn-attribute-p element :jump))))))))))
    799832         
    800833
Note: See TracChangeset for help on using the changeset viewer.