Changeset 15901


Ignore:
Timestamp:
Sep 18, 2013, 11:59:33 AM (8 years ago)
Author:
gb
Message:

Use an ACODE istruct to represent an acode node; such an istruct
has OPERATOR, OPERANDS, ASSERTED-TYPE, and INFO fields. (This
allows us to avoid using a hash table to map between ACODE forms
and code-/source-notes, and that in turn makes it easier to do
certain transforms and optimizations on acode.

For this to be viable, we have to be much more rigorous than we
have been about using accessors (ACODE-OPERATOR, etc.) instead
of [%]CAR/[%]CDR chains and about using MAKE-ACODE rather than
CONS/LIST. Catch enough of this in the frontend and X86 backend
so that the compiler can bootstrap itself on X86.

The acode accessor macros expand into calls to functions that
do some extra typechecking; this catches some errors at this
point but the plan is to remove these training wheels in the
near future.

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

Legend:

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

    r15898 r15901  
    419419
    420420(defun acode-condition-to-x86-cr-bit (cond)
    421   (condition-to-x86-cr-bit (cadr cond)))
     421  (condition-to-x86-cr-bit (car (acode-operands cond))))
    422422
    423423(defun condition-to-x86-cr-bit (cond)
     
    13061306         (end (gensym "END")))
    13071307    `(let* ((,note (acode-note ,form-var))
    1308             (,code-note (and (code-note-p ,note) ,note))
     1308            (,code-note (and ,note (code-note-p ,note) ,note))           
    13091309            (,source-note (if ,code-note
    13101310                            (code-note-source-note ,note)
     
    13281328(defun x862-toplevel-form (seg vreg xfer form)
    13291329  (let* ((code-note (acode-note form))
    1330          (args (if code-note `(,@(%cdr form) ,code-note) (%cdr form))))
     1330         (args (if code-note `(,@(acode-operands form) ,code-note) (acode-operands form))))
    13311331    (apply (x862-acode-operator-function form) seg vreg xfer args)))
    13321332
     
    13451345                   (%ilogbitp operator-acode-subforms-bit op)
    13461346                   (%ilogbitp operator-assignment-free-bit op))
    1347             (dolist (f (%cdr form) (x862-branch seg xfer))
     1347            (dolist (f (acode-operands form) (x862-branch seg xfer))
    13481348              (x862-form seg nil nil f ))
    1349             (apply fn seg vreg xfer (%cdr form))))))))
     1349            (apply fn seg vreg xfer (acode-operands form))))))))
    13501350
    13511351;;; dest is a float reg - form is acode
     
    13591359      (set-node-regspec-type-modes freg hard-reg-class-fpr-type-double))
    13601360    (let* ((fn (x862-acode-operator-function form)))
    1361       (apply fn seg freg nil (%cdr form)))))
     1361      (apply fn seg freg nil (acode-operands form)))))
    13621362
    13631363
     
    14791479               (let* ((op (acode-operator form)))
    14801480                 (if (eql op (%nx1-operator immediate))
    1481                    (x862-register-constant-p (cadr form)))))))
     1481                   (x862-register-constant-p (car (acode-operands form))))))))
    14821482          ((eql (hard-regspec-class hint) hard-reg-class-fpr)
    14831483           (when var
     
    16391639    (while (and (acode-p form) (or (eq (acode-operator form) (%nx1-operator progn))
    16401640                                   (eq (acode-operator form) (%nx1-operator local-tagbody))))
    1641       (setq form (caadr form)))
     1641      (setq form (caar (acode-operands form))))
    16421642    (when (acode-p form)
    16431643      (let ((op (acode-operator form)))
    16441644        (if (and (eq op (%nx1-operator local-go))
    1645                  (x862-equal-encodings-p (%caddr (%cadr form)) current-stack))
    1646           (%cadr (%cadr form))
     1645                 (x862-equal-encodings-p (caddr (car (acode-operands form))) current-stack))
     1646          (%cadr (car (acode-operands form)))
    16471647          (if (and (eq op (%nx1-operator local-return-from))
    1648                    (nx-null (caddr form)))
    1649             (let ((tagdata (car (cadr form))))
     1648                   (nx-null (cadr (acode-operands form))))
     1649            (let ((tagdata (car (car (acode-operands form)))))
    16501650              (and (x862-equal-encodings-p (cdr tagdata) current-stack)
    16511651                   (null (caar tagdata))
     
    16611661          (or (%ilogbitp operator-single-valued-bit op)
    16621662              (and (eql op (%nx1-operator values))
    1663                    (let ((values (cadr form)))
     1663                   (let ((values (car (acode-operands form))))
    16641664                     (and values (null (cdr values)))))
    16651665              nil                       ; Learn about functions someday
     
    28302830                 (acode-p fn)
    28312831                 (eq (acode-operator fn) (%nx1-operator immediate))
    2832                  (symbolp (cadr fn)))
    2833         (setq fn (x862-tail-call-alias fn (%cadr fn) arglist)))
     2832                 (symbolp (car (acode-operands fn))))
     2833        (setq fn (x862-tail-call-alias fn (car (acode-operands fn)) arglist)))
    28342834     
    28352835      (if (and (eq xfer $backend-return) (not (x862-tailcallok xfer)))
     
    33883388                    (if (and (acode-p form)
    33893389                             (eq (acode-operator form) (%nx1-operator immediate))
    3390                              (setq reg (x862-register-constant-p (cadr form))))
     3390                             (setq reg (x862-register-constant-p (car (acode-operands form)))))
    33913391                      reg
    33923392                      (x862-one-untargeted-lreg-form seg form target))))))
     
    39763976    (let* ((operator (acode-operator form)))
    39773977      (if (member operator *x862-operator-supports-u8-target*)
    3978         (values operator (acode-operand 1 form))))))
     3978        (values operator (car (acode-operands form)))))))
    39793979
    39803980(defun x862-acode-operator-supports-push (form)
     
    42754275  (when (acode-p (setq form (acode-unwrapped-form-value form)))
    42764276    (if (eq (acode-operator form) (%nx1-operator lexical-reference))
    4277       (let* ((addr (var-ea (%cadr form))))
     4277      (let* ((addr (var-ea (car (acode-operands form)))))
    42784278        (if (typep addr 'lreg)
    42794279          addr
     
    46874687    (with-note (form seg)
    46884688      (with-x86-local-vinsn-macros (seg)
    4689         (let* ((op (acode-operator form)))
     4689        (let* ((op (acode-operator form))
     4690               (operands (acode-operands form)))
    46904691          (cond ((eq op (%nx1-operator list))
    46914692                 (let* ((*x862-vstack* *x862-vstack*)
    46924693                        (*x862-top-vstack-lcell* *x862-top-vstack-lcell*))
    4693                    (x862-set-nargs seg (x862-formlist seg (%cadr form) nil))
     4694                   (x862-set-nargs seg (x862-formlist seg (car operands) nil))
    46944695                   (x862-open-undo $undostkblk curstack)
    46954696                   (! stack-cons-list))
    46964697                 (setq val *x862-arg-z*))
    46974698                ((eq op (%nx1-operator list*))
    4698                  (let* ((arglist (%cadr form)))
     4699                 (let* ((arglist (car operands)))
    46994700                   (let* ((*x862-vstack* *x862-vstack*)
    47004701                          (*x862-top-vstack-lcell* *x862-top-vstack-lcell*))
     
    47064707                   (setq val *x862-arg-z*)))
    47074708                ((eq op (%nx1-operator multiple-value-list))
    4708                  (x862-multiple-value-body seg (%cadr form))
     4709                 (x862-multiple-value-body seg (car operands))
    47094710                 (x862-open-undo $undostkblk curstack)
    47104711                 (! stack-cons-list)
     
    47144715                        (z ($ *x862-arg-z*))
    47154716                        (result ($ *x862-arg-z*)))
    4716                    (x862-two-targeted-reg-forms seg (%cadr val) y (%caddr val) z)
     4717                   (x862-two-targeted-reg-forms seg (car operands) y (cadr operands) z)
    47174718                   (x862-open-undo $undostkblk )
    47184719                   (! make-tsp-cons result y z)
     
    47264727                     (setq val node))))
    47274728                ((eq op (%nx1-operator %new-ptr))
    4728                  (let* ((clear-form (caddr form))
     4729                 (let* ((clear-form (cadr operands))
    47294730                        (cval (nx2-constant-form-value clear-form)))
    47304731                   (if cval
    47314732                     (progn
    4732                        (x862-one-targeted-reg-form seg (%cadr form) ($ *x862-arg-z*))
     4733                       (x862-one-targeted-reg-form seg (car operands) ($ *x862-arg-z*))
    47334734                       (if (nx-null cval)
    47344735                         (! make-stack-block)
     
    47394740                             (rval ($ *x862-arg-z*))
    47404741                             (rclear ($ *x862-arg-y*)))
    4741                          (x862-two-targeted-reg-forms seg (%cadr form) rval clear-form rclear)
     4742                         (x862-two-targeted-reg-forms seg (car operands) rval clear-form rclear)
    47424743                         (! compare-to-nil crf rclear)
    47434744                         (! cbranch-false (aref *backend-labels* stack-block-0-label) crf x86::x86-e-bits)
     
    47504751                 (setq val ($ *x862-arg-z*)))
    47514752                ((eq op (%nx1-operator make-list))
    4752                  (x862-two-targeted-reg-forms seg (%cadr form) ($ *x862-arg-y*) (%caddr form) ($ *x862-arg-z*))
     4753                 (x862-two-targeted-reg-forms seg (car operands) ($ *x862-arg-y*) (cadr operands) ($ *x862-arg-z*))
    47534754                 (x862-open-undo $undostkblk curstack)
    47544755                 (! make-stack-list)
     
    47574758                 (let* ((*x862-vstack* *x862-vstack*)
    47584759                        (*x862-top-vstack-lcell* *x862-top-vstack-lcell*))
    4759                    (x862-set-nargs seg (x862-formlist seg (%cadr form) nil))
     4760                   (x862-set-nargs seg (x862-formlist seg (car operands) nil))
    47604761                   (! make-stack-vector))
    47614762                 (x862-open-undo $undostkblk)
     
    47644765                 (let* ((*x862-vstack* *x862-vstack*)
    47654766                        (*x862-top-vstack-lcell* *x862-top-vstack-lcell*)
    4766                         (arglist (%cadr form)))
     4767                        (arglist (car operands)))
    47674768                   (x862-set-nargs seg (x862-formlist seg (append (car arglist) (reverse (cadr arglist))) nil))
    47684769                   (! make-stack-gvector))
     
    47704771                 (setq val *x862-arg-z*))
    47714772                ((eq op (%nx1-operator closed-function))
    4772                  (setq val (x862-make-closure seg (cadr form) t))) ; can't error
     4773                 (setq val (x862-make-closure seg (car operands) t))) ; can't error
    47734774                ((eq op (%nx1-operator %make-uvector))
    4774                  (destructuring-bind (element-count subtag &optional (init 0 init-p)) (%cdr form)
     4775                 (destructuring-bind (element-count subtag &optional (init 0 init-p)) operands
    47754776                   (let* ((fix-subtag (acode-fixnum-form-p subtag))
    47764777                          (is-node (x862-target-is-node-subtag fix-subtag))
     
    49484949                                      (eq (acode-operator value) (%nx1-operator bound-special-ref))
    49494950                                      (eq (acode-operator value) (%nx1-operator special-ref)))
    4950                                      (eq (cadr value) sym)))))
     4951                                     (eq (car (acode-operands value)) sym)))))
    49514952      (cond ((eq sym '*interrupt-level*)
    49524953             (let* ((fixval (acode-fixnum-form-p value)))
     
    52985299  (and
    52995300   (consp untyped-form)
    5300    (not (eq (setq op (%car untyped-form)) (%nx1-operator call)))
     5301   (not (eq (setq op (acode-operator untyped-form)) (%nx1-operator call)))
    53015302   (or
    53025303    (nx-null untyped-form)
     
    72187219
    72197220(defx862 x862-numcmp numcmp (seg vreg xfer cc form1 form2)
    7220   (let* ((name (ecase (cadr cc)
     7221  (let* ((name (ecase (car (acode-operands cc))
    72217222                 (:eq '=-2)
    72227223                 (:ne '/=-2)
     
    74667467    (dolist (form body)
    74677468      (if (eq (acode-operator form) tagop)
    7468         (let ((tag (cddr form)))
    7469           (when (cddr tag) (! align-loop-head))
     7469        (let ((tag (cdar (acode-operands form))))
     7470           (when (cddr tag) (! align-loop-head))
    74707471          (@ (car tag)))
    74717472        (x862-form seg nil nil form)))
     
    74767477             (acode-p fn)
    74777478             (eq (acode-operator fn) (%nx1-operator immediate)))
    7478     (let* ((name (cadr fn)))
     7479    (let* ((name (car (acode-operands fn))))
    74797480      (when (memq name *warn-if-function-result-ignored*)
    74807481        (p2-whine *x862-cur-afunc*  :result-ignored name))))
     
    75607561
    75617562(defx862 x862-lexical-function-call lexical-function-call (seg vreg xfer afunc arglist &optional spread-p)
    7562   (x862-call-fn seg vreg xfer (list (%nx1-operator simple-function) afunc)
     7563  (x862-call-fn seg vreg xfer (make-acode (%nx1-operator simple-function) afunc)
    75637564                (x862-augment-arglist afunc arglist (if spread-p 1 *x862-target-num-arg-regs*))
    75647565                spread-p))
  • branches/acode-rewrite/source/compiler/acode-rewrite.lisp

    r15898 r15901  
    4848          (dolist (operator operator-list)
    4949            (let-body `(setf (svref *acode-rewrite-functions* (logand operator-id-mask (%nx1-operator ,operator))) fun)))
     50          (let* ((operands (gensym "OPERANDS")))
    5051            (multiple-value-bind (bindings binding-decls)
    51                 (%destructure-lambda-list lambda-list whole-var nil nil
    52                                           :cdr-p t
     52                (%destructure-lambda-list lambda-list operands nil nil
     53                                          :cdr-p nil
    5354                                          :whole-p nil
    5455                                          :use-whole-var t
    5556                                          :default-initial-value nil)
    5657             
    57         `(let* ((fun (nfunction ,name
    58                                 (lambda (,whole-var &optional (,type-name t))
    59                                   (declare (ignorable ,type-name))
    60                                   (block ,name
    61                                     (let* ,(nreverse bindings)
    62                                       ,@(when binding-decls `((declare ,@binding-decls)))
    63                                       ,@decls
    64                                       ,@body))))))
    65           ,@(let-body))))))))
     58              `(let* ((fun (nfunction ,name
     59                                      (lambda (,whole-var &optional (,type-name t))
     60                                        (declare (ignorable ,type-name))
     61                                        (block ,name
     62                                          (let* ((,operands (acode-operands ,whole-var))
     63                                                 ,@(nreverse bindings))
     64                                            ,@(when binding-decls `((declare ,@binding-decls)))
     65                                            ,@decls
     66                                            ,@body))))))
     67          ,@(let-body)))))))))
    6668
    6769
     
    8688(defun acode-rewrite-as-constant-ref (form constant)
    8789  (case constant
    88     (nil (setf (car form) (%nx1-operator nil)
    89                          (cdr form) nil))
    90     ((t) (setf (car form) (%nx1-operator t)
    91                (cdr form) nil))
     90    (nil (setf (acode-operator form) (%nx1-operator nil)
     91               (acode-operands form) nil))
     92    ((t) (setf (acode-operator form) (%nx1-operator t)
     93               (acode-operands form) nil))
    9294    (t
    93      (setf (car form) (if (nx1-target-fixnump constant)
     95     (setf (acode-operator form) (if (nx1-target-fixnump constant)
    9496                     (%nx1-operator fixnum)
    9597                     (%nx1-operator immediate))
    96            (cadr form) constant
    97            (cddr form) nil)))
     98           (car (acode-operands form)) constant
     99           (cdr (acode-operands form)) nil)))
    98100  t)
    99101 
     
    291293                 (new-vars var)
    292294                 (new-vals val))))))
    293     (setf (cadr w) (new-vars)
    294           (caddr w) (new-vals))
     295    (setf (car (acode-operands w)) (new-vars)
     296          (cadr (acode-operands w)) (new-vals))
    295297    (with-acode-declarations p2decls (rewrite-acode-form body asserted-type))))
    296298   
     
    321323          (let* ((val (%svref cv cidx)))
    322324            (case val
    323               (nil (setf (car w) (%nx1-operator nil)
    324                          (cdr w) nil))
    325               ((t) (setf (car w) (%nx1-operator t)
    326                          (cdr w) nil))
     325              (nil (setf (acode-operator w) (%nx1-operator nil)
     326                         (acode-operands w) nil))
     327              ((t) (setf (acode-operator w) (%nx1-operator t)
     328                         (acode-operands w) nil))
    327329              (t
    328                (setf (car w) (if (nx1-target-fixnump val)
    329                                (%nx1-operator fixnum)
    330                                (%nx1-operator immediate))
    331                      (cadr w) val
    332                      (cddr w) nil)))
     330               (setf (acode-operator w) (if (nx1-target-fixnump val)
     331                                          (%nx1-operator fixnum)
     332                                          (%nx1-operator immediate))
     333                     (acode-operands w) (cons val nil))))
    333334            t))))))
    334335
     
    361362             (ccode (cadr cc))
    362363             (val (if (eq ccode :eq) (not (not consp)) (not consp))))
    363         (setf (car w) (if val (%nx1-operator t) (%nx1-operator nil))
    364               (cdr w) nil)))))
     364        (setf (acode-operator w) (if val (%nx1-operator t) (%nx1-operator nil))
     365              (acode-operands w) nil)))))
    365366
    366367
     
    686687
    687688(def-acode-rewrite acode-rewrite-numcmp numcmp asserted-type (&whole w cc num1 num2)
    688   (let* ((ccval (cadr cc))
     689  (let* ((ccval (car (acode-operands cc)))
    689690         (fn (case ccval
    690691               (:lt '<)
  • branches/acode-rewrite/source/compiler/nx-basic.lisp

    r15800 r15901  
    6565
    6666
    67 ;; In lieu of a slot in acode.  Don't reference this variable elsewhere because I'm
    68 ;; hoping to make it go away.
    69 (defparameter *nx-acode-note-map* nil)
    70 
    71 (defun acode-note (acode &aux (hash *nx-acode-note-map*))
    72   (and hash (gethash acode hash)))
     67;;; the acode.info slot of an acode node might be used as
     68;;; a plist someday.
     69(defun acode-note (acode)
     70  (acode.info acode))
    7371
    7472(defun (setf acode-note) (note acode)
    7573  (when note
    76     (assert *nx-acode-note-map*)
    7774    ;; Only record if have a unique key
    78     (unless (or (atom acode)
    79                 (nx-null acode)
     75    (unless (or (nx-null acode)
    8076                (nx-t acode))
    81       (setf (gethash acode *nx-acode-note-map*) note))))
     77      (setf (acode.info acode) note))))
    8278
    8379
  • branches/acode-rewrite/source/compiler/nx.lisp

    r15805 r15901  
    240240          (*record-pc-mapping* (and source-notes record-pc-mapping))
    241241          (*compile-code-coverage* (and source-notes compile-code-coverage))
    242           (*nx-acode-note-map* (and (or *record-pc-mapping* *compile-code-coverage*)
    243                                     (make-hash-table :test #'eq :shared nil)))
    244242          (*nx-current-code-note* (and *compile-code-coverage*
    245243                                       (make-code-note :form def :source-note function-note)))
  • branches/acode-rewrite/source/compiler/nx0.lisp

    r15898 r15901  
    6969(defvar *nx-lambdalist* (make-symbol "lambdalist"))
    7070
     71 
     72
     73 
    7174(defmacro make-nx-nil () `(make-acode ,(%nx1-operator nil)))
    7275(defmacro make-nx-t () `(make-acode ,(%nx1-operator t)))
     76
     77
     78(defmethod print-object ((a acode) stream)
     79  (print-unreadable-object (a stream :type t)
     80    (format stream "~a ~s" (string-downcase (acode-operator-name (acode-operator a))) (acode-operands a))))
    7381
    7482(defun %nx-null (x)
     
    408416       (if optype
    409417         (subtypep optype (nx-target-type type))
    410          (if opval-p (typep (%cadr form) (nx-target-type type))))))))
     418         (if opval-p (typep (car (acode-operands form)) (nx-target-type type))))))))
    411419
    412420(defun nx-acode-form-type (form env)
     
    434442        (dolist (operator operator-list)
    435443          (let-body `(setf (svref *acode-simple-type-inferrers*  (logand operator-id-mask (%nx1-operator ,operator))) fun)))
    436         (multiple-value-bind (bindings binding-decls)
    437             (%destructure-lambda-list lambda-list whole-var nil nil
    438                                       :cdr-p t
    439                                       :whole-p nil
    440                                       :use-whole-var t
    441                                       :default-initial-value nil)
     444        (let* ((operands (gensym "OPERANDS")))
     445          (multiple-value-bind (bindings binding-decls)
     446
     447              (%destructure-lambda-list lambda-list operands nil nil
     448                                        :cdr-p nil
     449                                        :whole-p nil
     450                                        :use-whole-var t
     451                                        :default-initial-value nil)
    442452             
    443           `(let* ((fun (nfunction ,name
    444                                   (lambda (,whole-var &optional (,trust-decls t))
    445                                     (declare (ignorable ,trust-decls))
    446                                     (block ,name
    447                                       (let* ,(nreverse bindings)
    448                                         ,@(when binding-decls `((declare ,@binding-decls)))
    449                                         ,@decls
    450                                         ,@body))))))
    451             ,@(let-body)))))))
     453            `(let* ((fun (nfunction ,name
     454                                    (lambda (,whole-var &optional (,trust-decls t))
     455                                      (declare (ignorable ,trust-decls))
     456                                      (block ,name
     457                                        (let* ((,operands (acode-operands ,whole-var))
     458                                               ,@(nreverse bindings))
     459                                          ,@(when binding-decls `((declare ,@binding-decls)))
     460                                          ,@decls
     461                                          ,@body))))))
     462              ,@(let-body))))))))
    452463
    453464(defun acode-assert-type (form typespec)
    454   (let* ((new (cons typespec (cons (cons (%car form) (%cdr form)) nil))))
    455     (setf (%car form) (%nx1-operator type-asserted-form)
    456           (%cdr form) new)
    457     typespec))
     465  (setf (acode.asserted-type form)
     466        (nx-target-type typespec)))
    458467
    459468(def-simple-type-infer infer-fixnum fixnum trust-decls (val)
     
    524533  (if (not (acode-p form))
    525534    t
    526     (let* ((op (acode-operator form))
    527            (op-id (logand  op operator-id-mask))
    528            (type (svref *acode-operator-types* op-id)))
    529       (declare (fixnum op op-id))
    530       (if (not (eq type :infer))
    531         (nx-target-type type)
    532         (if (eql op (%nx1-operator type-asserted-form))
    533           (nx-target-type (%cadr form))
    534           (let* ((fn (svref *acode-simple-type-inferrers* op-id)))
    535             (if fn
    536               (let* ((inferred (nx-target-type (funcall fn form trust-decls))))
    537                 (when (eql (acode-operator form) op-id)
    538                   (acode-assert-type form inferred))
    539                 inferred)
    540               t)))))))
    541 
    542 #||
    543 (let* ((typespec
    544         (if (nx-null form)
    545           'null
    546           (if (nx-t form)
    547             'boolean
    548             (nx-target-type
    549              (if (acode-p form)
    550                (let* ((op (acode-operator form)))
    551                  (if (eq op (%nx1-operator fixnum))
    552                    (let* ((val (cadr form)))
    553                      `(integer ,val ,val))
    554                    (if (eq op (%nx1-operator immediate))
    555                      (type-of (%cadr form))
    556                      (and trust-decls
    557                           (if (eq op (%nx1-operator type-asserted-form))
    558                             (progn
    559                               (setq assert nil)
    560                               (%cadr form))
    561                             (if (eq op (%nx1-operator typed-form))
    562                               (destructuring-bind (type subform &optional check) (%cdr form)                                 
    563                                 (when (and assert (null check))
    564                                   (setf (%car form) (%nx1-operator type-asserted-form)
    565                                         (%cadr form)
    566                                         (type-specifier
    567                                          (specifier-type `(and ,type ,(acode-form-type subform trust-decls assert))))
    568                                         assert nil))
    569                                 (%cadr form))
    570                               (if (eq op (%nx1-operator lexical-reference))
    571                                 (locally (declare (special *nx-in-frontend*))
    572                                   (if *nx-in-frontend*
    573                                     (setq assert nil)
    574                                     (let* ((var (cadr form))
    575                                            (bits (nx-var-bits var))
    576                                            (punted (logbitp $vbitpunted bits)))
    577                                       (if (or punted
    578                                               (eql 0 (nx-var-root-nsetqs var)))
    579                                         (var-inittype var)))))
    580                                 (if (or (eq op (%nx1-operator %aref1))
    581                                         (eq op (%nx1-operator simple-typed-aref2))
    582                                         (eq op (%nx1-operator general-aref2))
    583                                         (eq op (%nx1-operator simple-typed-aref3))
    584                                         (eq op (%nx1-operator general-aref3)))
    585                                   (let* ((atype (acode-form-type (cadr form) t))
    586                                          (actype (if atype (specifier-type atype))))
    587                                     (if (typep actype 'array-ctype)
    588                                       (type-specifier (array-ctype-specialized-element-type
    589                                                        actype))))
    590                                   (if (member op *numeric-acode-ops*)
    591                                     (multiple-value-bind (f1 f2)
    592                                         (nx-binop-numeric-contagion (cadr form)
    593                                                                     (caddr form)
    594                                                                     trust-decls)
    595                                       (if (and (acode-form-typep f1 'real trust-decls)
    596                                                (acode-form-typep f2 'real trust-decls))
    597 
    598                                         (if (or (acode-form-typep f1 'double-float trust-decls)
    599                                                 (acode-form-typep f2 'double-float trust-decls))
    600                                           'double-float
    601                                           (if (or (acode-form-typep f1 'single-float trust-decls)
    602                                                   (acode-form-typep f2 'single-float trust-decls))
    603                                             'single-float
    604                                             'float))))
    605                                     (cdr (assq op *nx-operator-result-types*)))))))))))))))))
    606   (if (or (null typespec) (eq typespec '*)) (setq typespec t))
    607   (when (and (acode-p form) (typep (acode-operator form) 'fixnum) assert)
    608     (let* ((new (cons typespec (cons (cons (%car form) (%cdr form)) nil))))
    609       (setf (%car form) (%nx1-operator type-asserted-form)
    610             (%cdr form) new)))
    611   typespec)
    612 ||#
     535    (or (acode.asserted-type form)
     536        (acode-assert-type
     537         form
     538         (nx-target-type
     539          (let* ((op (acode-operator form))
     540                 (op-id (logand  op operator-id-mask))
     541                 (type (svref *acode-operator-types* op-id)))
     542            (declare (fixnum op op-id))
     543            (if (not (eq type :infer))
     544              type
     545              (let* ((fn (svref *acode-simple-type-inferrers* op-id)))
     546                (if fn
     547                  (let* ((inferred (nx-target-type (funcall fn form trust-decls))))
     548                    (when (eql (acode-operator form) op-id)
     549                      (acode-assert-type form inferred))
     550                    inferred)
     551                  t)))))))))
     552
    613553
    614554(defun nx-binop-numeric-contagion (form1 form2 trust-decls)
     
    671611; ??? Is it true that the "value" of the punted reference is unwrapped ? ???
    672612(defun acode-unwrapped-form (form)
    673   (while (and (consp (setq form (nx-untyped-form form)))
    674            (eq (%car form) (%nx1-operator lexical-reference))
    675            (acode-punted-var-p (cadr form)))
    676     (setq form (var-ea (cadr form))))
     613  (while (and (acode-p (setq form (nx-untyped-form form)))
     614           (eq (acode-operator form) (%nx1-operator lexical-reference))
     615           (acode-punted-var-p (car (acode-operands form))))
     616    (setq form (var-ea (car (acode-operands form)))))
    677617  form)
    678618
     
    681621  (if (acode-p x)
    682622    (if (eq (acode-operator x) (%nx1-operator fixnum))
    683       (cadr x))))
     623      (car (acode-operands x)))))
    684624
    685625(defun acode-xxx-form-p (x fixnum-supertype)
     
    689629        (if (acode-p x)
    690630          (if (and (eq (acode-operator x) (%nx1-operator immediate))
    691                    (typep (cadr x) fixnum-supertype))
    692             (cadr x))))))
     631                   (typep (car (acode-operands x)) fixnum-supertype))
     632            (car (acode-operands x)))))))
    693633
    694634(defun acode-integer-form-p (x)
     
    774714    (let* ((op (acode-operator x)))
    775715      (if (eql op (%nx1-operator fixnum))
    776         (let* ((val (cadr x)))
     716        (let* ((val (car (acode-operands x))))
    777717          (if (target-word-size-case
    778718               (32 (typep val '(signed-byte #.(- 32 2))))
     
    793733           (acode-p form)
    794734           (eq (acode-operator form) (%nx1-operator typed-form))
    795            (subtypep (cadr form) 'fixnum))))
     735           (subtypep (car (acode-operands  form)) 'fixnum))))
    796736
    797737
     
    803743       (acode-p form)
    804744       (eq (acode-operator form) (%nx1-operator typed-form))
    805        (subtypep (cadr form) *nx-target-natural-type*)))
     745       (subtypep (car (acode-operands form)) *nx-target-natural-type*)))
    806746
    807747(defun nx-acode-natural-type-p (form env)
    808748  (acode-natural-type-p form (nx-trust-declarations env)))
    809749
    810 ; Is acode-expression the result of alphatizing (%int-to-ptr <integer>) ?
     750;;; Is acode-expression the result of alphatizing (%int-to-ptr <integer>) ?
    811751(defun acode-absolute-ptr-p (acode-expression &optional skip)
    812752  (and (acode-p acode-expression)
    813753       (or skip (prog1 (eq (acode-operator acode-expression) (%nx1-operator %macptrptr%))
    814                   (setq acode-expression (%cadr acode-expression))))
    815        (eq (acode-operator acode-expression) (%nx1-operator %consmacptr%))
    816        (eq (acode-operator (setq acode-expression (%cadr acode-expression)))
    817            (%nx1-operator %immediate-int-to-ptr))
    818        (let ((op (acode-operator (setq acode-expression (%cadr acode-expression)))))
    819          (if (or (eq op (%nx1-operator fixnum))
    820                  (and (eq op (%nx1-operator immediate))
    821                       (integerp (%cadr acode-expression))))
    822            (%cadr acode-expression)))))
     754                     (setq acode-expression (car (acode-operands acode-expression)))))
     755          (eq (acode-operator acode-expression) (%nx1-operator %consmacptr%))
     756          (eq (acode-operator (setq acode-expression (car (acode-operands acode-expression))))
     757              (%nx1-operator %immediate-int-to-ptr))
     758          (let* ((op (acode-operator (setq acode-expression (car (acode-operands acode-expression)))))
     759                 (operands (acode-operands acode-expression)))
     760            (if (or (eq op (%nx1-operator fixnum))
     761                    (and (eq op (%nx1-operator immediate))
     762                         (integerp (car operands))))
     763              (car operands)))))
    823764
    824765(defun specifier-type-if-known (typespec &optional env &key whine values)
     
    11451086      (let* ((op (acode-operator init)))
    11461087        (if (eq op (%nx1-operator lexical-reference))
    1147           (let* ((target (%cadr init))
     1088          (let* ((target (car (acode-operands init)))
    11481089                 (setq-count (nx-var-root-nsetqs target)))
    11491090            (cons var (cons setq-count target)))
     
    11511092                   (or (eq op (%nx1-operator closed-function))
    11521093                       (eq op (%nx1-operator simple-function))))
    1153             (let* ((afunc (%cadr init)))
    1154               (setf (afunc-fn-downward-refcount afunc)
     1094            (let* ((afunc (car (acode-operands init))))
     1095              (setf (afunc-fn-downward-refcount afunc
     1096)
    11551097                    (afunc-fn-refcount afunc)
    11561098                    (afunc-bits afunc) (logior (ash 1 $fbitdownward) (ash 1 $fbitbounddownward)
     
    12311173               (or (eq op (%nx1-operator closed-function))
    12321174                   (eq op (%nx1-operator simple-function))))
    1233       (let* ((afunc (cadr val)))
     1175      (let* ((afunc (car (acode-operands val))))
    12341176        (setf (afunc-bits afunc) (%ilogior (%ilsl $fbitbounddownward 1) (afunc-bits afunc))
    12351177              (afunc-fn-downward-refcount afunc) 1)))
     
    18821824    (let* ((val (if (or (eq (acode-operator form) (%nx1-operator fixnum))
    18831825                        (eq (acode-operator form) (%nx1-operator immediate)))
    1884                   (cadr form))))
     1826                  (car (acode-operands form)))))
    18851827      (and (typep val *nx-target-natural-type*) val))))
    18861828
     
    18901832    (let* ((val (if (or (eq (acode-operator form) (%nx1-operator fixnum))
    18911833                        (eq (acode-operator form) (%nx1-operator immediate)))
    1892                   (cadr form))))
     1834                  (car (acode-operands form)))))
    18931835      (and (typep val '(unsigned-byte 32)) val))))
    18941836
     
    18981840    (let* ((val (if (or (eq (acode-operator form) (%nx1-operator fixnum))
    18991841                        (eq (acode-operator form) (%nx1-operator immediate)))
    1900                   (cadr form))))
     1842                  (car (acode-operands form)))))
    19011843      (and (typep val '(unsigned-byte 31)) val))))
    19021844
     
    19991941  (nx1-verify-length args 0 nil)
    20001942  (when (and (acode-p sym) (eq (acode-operator sym) (%nx1-operator immediate)))
    2001     (multiple-value-bind (valid name) (valid-function-name-p (%cadr sym))
     1943    (multiple-value-bind (valid name) (valid-function-name-p (car (acode-operands sym)))
    20021944      (when valid
    20031945        (setq global-only t sym name))))
     
    20501992        (result-type t))
    20511993    (when (and (acode-p fn) (eq (acode-operator fn) (%nx1-operator immediate)))
    2052       (multiple-value-bind (valid name) (valid-function-name-p (%cadr fn))
     1994      (multiple-value-bind (valid name) (valid-function-name-p (car (acode-operands fn)))
    20531995        (when valid
    20541996          (setq fn name global-only t))))
  • branches/acode-rewrite/source/compiler/nx1.lisp

    r15898 r15901  
    450450        (when (logbitp operator-cc-invertable-bit op)
    451451          (%rplaca
    452            (%cdr (%cadr subform))
    453            (acode-invert-condition-keyword (%cadr (%cadr subform))))
     452           (acode-operands (car (acode-operands subform)))
     453           (acode-invert-condition-keyword (car (acode-operands (car (acode-operands subform))))))
    454454          t)))))
    455455
     
    457457;;; (assuming, of course, that anyone should ...)
    458458(defun nx-untyped-form (form)
    459   (while (and (consp form)
    460               (or (and (eq (%car form) (%nx1-operator typed-form))
    461                        (null (nth 3 form)))
    462                   (eq (%car form) (%nx1-operator type-asserted-form))))
    463     (setq form (%caddr form)))
     459  (while (and (acode-p form)
     460              (or (and (eq (acode-operator form) (%nx1-operator typed-form))
     461                       (null (nth 2 (acode-operands form))))
     462                  (eq (acode-operator form) (%nx1-operator type-asserted-form))))
     463    (setq form (cadr (acode-operands form))))
    464464  form)
    465465
     
    13051305        (ref (acode-unwrapped-form (afunc-ref-form afunc))))
    13061306    (if ref
    1307       (%rplaca ref op) ; returns ref
     1307      (progn
     1308        (setf (acode-operator ref) op)
     1309        ref)
    13081310      (setf (afunc-ref-form afunc)
    13091311            (make-acode
     
    13131315(defnx1 nx1-%function %function context (form &aux symbol)
    13141316  (let ((sym (nx1-form :value form)))
    1315     (if (and (eq (car sym) (%nx1-operator immediate))
    1316              (setq symbol (cadr sym))
     1317    (if (and (eq (acode-operator sym) (%nx1-operator immediate))
     1318             (setq symbol (car (acode-operands sym)))
    13171319             (symbolp symbol))
    13181320      (make-acode (%nx1-default-operator) symbol)
     
    13491351               (setq *nx-loop-nesting-level* (1+ level)))
    13501352             (%rplaca (%cdr (%cdr (%cdr (%cdr info)))) t)
    1351              (cons (%nx1-operator tag-label) info))
     1353             (make-acode* (%nx1-operator tag-label) info))
    13521354           (nx1-form nil form))
    13531355         body))
  • branches/acode-rewrite/source/compiler/nx2.lisp

    r15898 r15901  
    172172    (or (nx-null form)
    173173        (nx-t form)
    174         (and (consp form)
     174        (and (acode-p form)
    175175             (or (eq (acode-operator form) (%nx1-operator immediate))
    176176                 (eq (acode-operator form) (%nx1-operator fixnum))
     
    182182      (when (or (eq op (%nx1-operator lexical-reference))
    183183                (eq op (%nx1-operator inherited-arg)))
    184         (%cadr form)))))
     184        (car (acode-operands form))))))
    185185
    186186(defun nx2-acode-call-p (form)
     
    208208      (nx2-lexical-reference-p form)
    209209      (let ((op (acode-operator form))
     210            (operands (acode-operands form))
    210211            (subforms nil))
    211212        (if (eq op (%nx1-operator setq-lexical))
    212           (and (neq var (cadr form))
    213                (nx2-setqed-var-not-set-by-form-p var (caddr form)))
     213          (and (neq var (car operands))
     214               (nx2-setqed-var-not-set-by-form-p var (cadr operands)))
    214215          (and (or (not closed)
    215216                   (logbitp operator-side-effect-free-bit op))
     
    218219                          (unless (nx2-setqed-var-not-set-by-form-p var subform closed) (return)))))
    219220                 (if
    220                    (cond ((%ilogbitp operator-acode-subforms-bit op) (setq subforms (%cdr form)))
    221                          ((%ilogbitp operator-acode-list-bit op) (setq subforms (cadr form))))
     221                   (cond ((%ilogbitp operator-acode-subforms-bit op) (setq subforms operands))
     222                         ((%ilogbitp operator-acode-list-bit op) (setq subforms (car operands))))
    222223                   (not-set-in-formlist subforms)
    223224                   (and (or (eq op (%nx1-operator call))
    224225                            (eq op (%nx1-operator lexical-function-call)))
    225                         (nx2-setqed-var-not-set-by-form-p var (cadr form))
    226                         (setq subforms (caddr form))
     226                        (nx2-setqed-var-not-set-by-form-p var (car operands))
     227                        (setq subforms (cadr operands))
    227228                        (not-set-in-formlist (car subforms))
    228229                        (not-set-in-formlist (cadr subforms))))))))))
     
    235236        (nx2-constant-form-p form)
    236237        (let ((op (acode-operator form))
     238              (operands (acode-operands form))
    237239              (subforms nil))
    238240          (if (eq op (%nx1-operator setq-lexical))
    239             (and (neq var (cadr form))
    240                  (nx2-var-not-reffed-by-form-p var (caddr form)))
     241            (and (neq var (car operands))
     242                 (nx2-var-not-reffed-by-form-p var (cadr operands)))
    241243            (and (or (not closed)
    242244                     (logbitp operator-side-effect-free-bit op))
     
    246248                   (if
    247249                     (cond ((%ilogbitp operator-acode-subforms-bit op) (setq subforms (%cdr form)))
    248                            ((%ilogbitp operator-acode-list-bit op) (setq subforms (cadr form))))
     250                           ((%ilogbitp operator-acode-list-bit op) (setq subforms (car operands))))
    249251                     (not-reffed-in-formlist subforms)
    250252                     (and (or (eq op (%nx1-operator call))
    251253                              (eq op (%nx1-operator lexical-function-call)))
    252                           (nx2-var-not-reffed-by-form-p var (cadr form))
    253                           (setq subforms (caddr form))
     254                          (nx2-var-not-reffed-by-form-p var (car operands))
     255                          (setq subforms (cadr operands))
    254256                          (not-reffed-in-formlist (car subforms))
    255257                          (not-reffed-in-formlist (cadr subforms)))))))))))
     
    275277    (when (and (acode-p alambda)
    276278               (eq (acode-operator alambda) (%nx1-operator lambda-list)))
    277       (destructuring-bind (req opt rest keys &rest ignore) (cdr alambda)
     279      (destructuring-bind (req opt rest keys &rest ignore) (acode-operands alambda)
    278280        (declare (ignore ignore))
    279281        (when (or (dolist (sp (caddr opt))
     
    320322  (let* ((x (acode-unwrapped-form x)))
    321323    (if (eq (acode-operator x) (%nx1-operator immediate))
    322       (cadr x)
     324      (car (acode-operands x))
    323325      (compiler-bug "not an immediate: ~s" x))))
    324326
     
    376378          ((or (eql op (%nx1-operator fixnum))
    377379               (eql op (%nx1-operator immediate)))
    378            (values (cadr form) t))
     380           (values (car (acode-operands form)) t))
    379381          (t (values nil nil)))))
    380382
     
    495497                       (or (eq (acode-operator unwrapped) (%nx1-operator mul2))
    496498                           (eq (acode-operator unwrapped) (%nx1-operator %i*)))
    497                        (setq f1 (acode-fixnum-form-p (cadr unwrapped)))
     499                       (setq f1 (acode-fixnum-form-p (car (acode-operands unwrapped))))
    498500                       (typep (setq f1/f2 (/ f1 f2)) 'fixnum))
    499501                (progn
     
    536538               (let* ((op (acode-operator form)))
    537539                 (cond ((eql op (%nx1-operator eq))
    538                         (destructuring-bind (cc x y) (cdr form)
     540                        (destructuring-bind (cc x y) (acode-operands form)
    539541                          (when (eq :eq (acode-immediate-operand cc))
    540542                            (if (setq var (nx2-lexical-reference-p x))
     
    543545                                (setq fixval (acode-fixnum-form-p x)))))))
    544546                       ((eql op (%nx1-operator %izerop))
    545                         (destructuring-bind (cc val) (cdr form)
     547                        (destructuring-bind (cc val) (acode-operands form)
    546548                          (when (eq :eq (acode-immediate-operand cc))
    547549                            (setq var (nx2-lexical-reference-p val)
     
    556558        (if (and (acode-p form) (eql (acode-operator form) (%nx1-operator or)))
    557559          (collect ((vals))
    558             (let* ((clauselist (cadr form)))
     560            (let* ((clauselist (car (acode-operands  form))))
    559561              (if (multiple-value-setq (var val) (is-simple-comparison-of-var-to-fixnum (car clauselist)))
    560562                (progn
     
    600602                                         (%nx1-operator if))))
    601603                         (setq otherwise original)
    602                          (destructuring-bind (test true false) (cdr form)
     604                         (destructuring-bind (test true false) (acode-operands form)
    603605                           (multiple-value-bind (v vals)
    604606                               (nx2-is-comparison-of-var-to-fixnums test)
  • branches/acode-rewrite/source/compiler/nxenv.lisp

    r15876 r15901  
    2727)
    2828
    29 #+ppc-target (require "PPCENV")
    30 #+x8632-target (require "X8632ENV")
    31 #+x8664-target (require "X8664ENV")
    32 
     29(def-accessors (acode) %svref
     30  nil                                   ; 'acode
     31  acode.operator                        ; fixnum
     32  acode.operands                        ; list, elements often acode
     33  acode.asserted-type                   ; NIL or type specifier.
     34  acode.info                            ; plist: notes, etc
     35  )
     36 
    3337(def-accessors (var) %svref
    3438  nil                                   ; 'var
     
    480484
    481485(defmacro make-acode (operator &rest args)
    482   `(%temp-list ,operator ,@args))
     486  `(%make-acode ,operator ,@args))
     487
     488(defmacro make-acode* (operator args)
     489  `(%make-acode ,operator ,args))
    483490
    484491
     
    486493(defmacro acode-operator (form)
    487494  ;; Gak.
    488   `(%car ,form))
    489 
    490 (defmacro acode-operand (n form)
    491   ;; Gak. Gak.
    492   `(nth ,n (the list ,form)))
     495  `(%acode-operator ,form))
     496
    493497
    494498(defmacro acode-operands (form)
    495   ;; Gak. Gak. Gak.
    496   `(%cdr ,form))
     499  `(%acode-operands ,form))
    497500
    498501(defmacro acode-p (x)
    499   " A big help this is ..."
    500   `(consp ,x))
     502  `(%acode-p ,x))
     503
     504(defun %make-acode (operator &rest operands)
     505  (%istruct 'acode operator operands nil nil))
     506
     507(defun %acode-p (thing)
     508  (istruct-typep thing 'acode))
     509
     510(defun %acode-operator (thing)
     511  (if (acode-p thing)
     512    (acode.operator thing)
     513    (error "Not acode: ~s" thing)))
     514
     515(defun (setf %acode-operator) (new thing)
     516  (if (acode-p thing)
     517    (setf (acode.operator thing) new)
     518    (error "Not acode: ~s" thing)))
     519
     520(defun %acode-operands (thing)
     521  (if (acode-p thing)
     522    (acode.operands thing)
     523    (error "Not acode: ~s" thing)))
     524
     525(defun (setf %acode-operands) (new thing)
     526  (if (acode-p thing)
     527    (setf (acode.operands thing) new)
     528    (error "Not acode: ~s" thing)))
     529
    501530
    502531
Note: See TracChangeset for help on using the changeset viewer.