Changeset 12297


Ignore:
Timestamp:
Jun 25, 2009, 12:15:25 PM (10 years ago)
Author:
gz
Message:

Define nx-form-constant-p and nx-form-constant-value and try to use them consistently in optimizers to deal with constants. Make them take an env arg in case we ever want to extend them to handle constant var lookup; While in there, fix nx1-the constant case to use the massaged typespec

Location:
trunk/source/compiler
Files:
5 edited

Legend:

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

    r12063 r12297  
    36703670                ((eq op (%nx1-operator %new-ptr))
    36713671                 (let* ((clear-form (caddr form))
    3672                         (cval (nx-constant-form-p clear-form)))
     3672                        (cval (nx2-constant-form-value clear-form)))
    36733673                   (if cval
    36743674                       (progn
     
    61796179
    61806180(defppc2 ppc2-if if (seg vreg xfer testform true false &aux test-val)
    6181   (if (setq test-val (nx-constant-form-p (acode-unwrapped-form-value testform)))
     6181  (if (setq test-val (nx2-constant-form-value (acode-unwrapped-form-value testform)))
    61826182    (ppc2-form seg vreg xfer (if (nx-null test-val) false true))
    61836183    (let* ((cstack *ppc2-cstack*)
  • trunk/source/compiler/X86/x862.lisp

    r12219 r12297  
    42704270                ((eq op (%nx1-operator %new-ptr))
    42714271                 (let* ((clear-form (caddr form))
    4272                         (cval (nx-constant-form-p clear-form)))
     4272                        (cval (nx2-constant-form-value clear-form)))
    42734273                   (if cval
    42744274                     (progn
     
    70207020
    70217021(defx862 x862-if if (seg vreg xfer testform true false &aux test-val)
    7022   (if (setq test-val (nx-constant-form-p (acode-unwrapped-form-value testform)))
     7022  (if (setq test-val (nx2-constant-form-value (acode-unwrapped-form-value testform)))
    70237023    (x862-form seg vreg xfer (if (nx-null test-val) false true))
    70247024    (let* ((cstack *x862-cstack*)
  • trunk/source/compiler/nx0.lisp

    r12219 r12297  
    359359
    360360(defun nx-proclaimed-parameter-p (sym)
     361  (setq sym (nx-need-sym sym))
    361362  (or (constantp sym)
    362363      (multiple-value-bind (special-p info) (nx-lex-info sym t)
     
    17241725     form)))
    17251726
    1726 (defun nx-constant-form-p (form)
     1727(defun nx2-constant-form-value (form)
    17271728  (setq form (nx-untyped-form form))
    17281729  (and (or (nx-null form)
     
    21562157            (not (%cdr form)))
    21572158       (nx-error "Illegally quoted form ~S." f))))
     2159
     2160(defun nx-form-constant-p (form env)
     2161  (declare (ignore env))
     2162  (or (quoted-form-p form)
     2163      (self-evaluating-p form)))
     2164
     2165(defun nx-form-constant-value (form env)
     2166  (declare (ignore env))
     2167  (declare (type (satisfies nx-form-constant-p) form))
     2168  (if (consp form) (%cadr form) form))
    21582169
    21592170; Returns two values: expansion & win
     
    23992410;;; Treat (VALUES x . y) as X if it appears in a THE form
    24002411(defun nx-form-type (form &optional (env *nx-lexical-environment*))
    2401   (if (quoted-form-p form)
    2402     (type-of (nx-unquote form))
    2403     (if (self-evaluating-p form)
    2404       (type-of form)
    2405       (if (and (consp form)             ; Kinda bogus now, but require-type
    2406                (eq (%car form) 'require-type) ; should be special some day
    2407                (quoted-form-p (caddr form)))
    2408         (%cadr (%caddr form))
    2409         (if (nx-trust-declarations env)
    2410           (if (symbolp form)
    2411             (nx-target-type (nx-declared-type form env))
    2412             (if (consp form)
    2413               (if (eq (%car form) 'the)
    2414                 (destructuring-bind (typespec val) (%cdr form)
    2415                   (declare (ignore val))
    2416                   (let* ((ctype (values-specifier-type typespec)))
    2417                     (if (typep ctype 'values-ctype)
    2418                       (let* ((req (values-ctype-required ctype)))
    2419                         (if req
    2420                           (nx-target-type (type-specifier (car req)))
    2421                           '*))
    2422                       (nx-target-type (type-specifier ctype)))))
    2423                 (if (eq (%car form) 'setq)
    2424                   (nx-declared-type (cadr form) env)
    2425                   (let* ((op (gethash (%car form) *nx1-operators*)))
    2426                     (or (and op (cdr (assq op *nx-operator-result-types*)))
    2427                         (and (not op)(cdr (assq (car form) *nx-operator-result-types-by-name*)))
    2428                         (and (memq (car form) *numeric-ops*)
    2429                              (grovel-numeric-form form env))
    2430                         (and (memq (car form) *logical-ops*)
    2431                              (grovel-logical-form form env))
    2432                         ;; Sort of the right idea, but this should be done
    2433                         ;; in a more general way.
    2434                         (when (or (eq (car form) 'aref)
    2435                                   (eq (car form) 'uvref))
    2436                           (let* ((atype (nx-form-type (cadr form) env))
    2437                                  (a-ctype (specifier-type atype)))
    2438                             (when (array-ctype-p a-ctype)
    2439                               (type-specifier (array-ctype-specialized-element-type
    2440                                                a-ctype)))))
    2441                         t))))
    2442               t))
    2443           t)))))
     2412  (if (nx-form-constant-p form env)
     2413    (type-of (nx-form-constant-value form env))
     2414    (if (and (consp form)          ; Kinda bogus now, but require-type
     2415             (eq (%car form) 'require-type) ; should be special some day
     2416             (nx-form-constant-p (caddr form) env))
     2417      (nx-form-constant-value (%caddr form) env)
     2418      (if (nx-trust-declarations env)
     2419        (if (symbolp form)
     2420          (nx-target-type (nx-declared-type form env))
     2421          (if (consp form)
     2422            (if (eq (%car form) 'the)
     2423              (destructuring-bind (typespec val) (%cdr form)
     2424                (declare (ignore val))
     2425                (let* ((ctype (values-specifier-type typespec)))
     2426                  (if (typep ctype 'values-ctype)
     2427                    (let* ((req (values-ctype-required ctype)))
     2428                      (if req
     2429                        (nx-target-type (type-specifier (car req)))
     2430                        '*))
     2431                    (nx-target-type (type-specifier ctype)))))
     2432              (if (eq (%car form) 'setq)
     2433                (nx-declared-type (cadr form) env)
     2434                (let* ((op (gethash (%car form) *nx1-operators*)))
     2435                  (or (and op (cdr (assq op *nx-operator-result-types*)))
     2436                      (and (not op)(cdr (assq (car form) *nx-operator-result-types-by-name*)))
     2437                      (and (memq (car form) *numeric-ops*)
     2438                           (grovel-numeric-form form env))
     2439                      (and (memq (car form) *logical-ops*)
     2440                           (grovel-logical-form form env))
     2441                      ;; Sort of the right idea, but this should be done
     2442                      ;; in a more general way.
     2443                      (when (or (eq (car form) 'aref)
     2444                                (eq (car form) 'uvref))
     2445                        (let* ((atype (nx-form-type (cadr form) env))
     2446                               (a-ctype (specifier-type atype)))
     2447                          (when (array-ctype-p a-ctype)
     2448                            (type-specifier (array-ctype-specialized-element-type
     2449                                             a-ctype)))))
     2450                      t))))
     2451            t))
     2452        t))))
    24442453
    24452454(defparameter *numeric-ops* '(+ -  / * +-2 --2 *-2 /-2))
     
    24822491(defun nx-form-typep (arg type &optional (env *nx-lexical-environment*))
    24832492  (setq type (nx-target-type (type-expand type)))
    2484   (if (constantp arg)
    2485     (typep (nx-unquote arg) type env)
     2493  (if (nx-form-constant-p arg env)
     2494    (typep (nx-form-constant-value arg env) type env)
    24862495    (subtypep (nx-form-type arg env) type env)))
    24872496
  • trunk/source/compiler/nx1.lisp

    r12276 r12297  
    1919;;; Wimp out, but don't choke on (the (values ...) form)
    2020(defnx1 nx1-the the (&whole call typespec form &environment env)
    21   (if (and (self-evaluating-p form)
    22            (not (typep form typespec))
    23            (progn (nx1-whine :type call) t))
    24     (setq typespec t))
    2521  ;; Allow VALUES types here (or user-defined types that
    2622  ;; expand to VALUES types).  We could do a better job
     
    4541           (*nx-form-type* typespec)
    4642           (transformed (nx-transform form env)))
     43      (when (and (nx-form-constant-p transformed env)
     44                 (not (typep (nx-form-constant-value transformed env) typespec)))
     45        (nx1-whine :type call)
     46        (setq typespec t))
    4747      (do* ()
    4848           ((or (atom transformed)
     
    7474
    7575(defnx1 nx1-istruct-typep ((istruct-typep)) (&whole whole thing type &environment env)
    76   (if (and (quoted-form-p type) (symbolp (cadr type)))
     76  (if (and (nx-form-constant-p type env) (non-nil-symbol-p (nx-form-constant-value type env)))
    7777    (make-acode (%nx1-operator istruct-typep)
    7878                (nx1-immediate :eq)
     
    11211121  (make-acode (%nx1-operator catch) (nx1-form operation) (nx1-catch-body body)))
    11221122
    1123 (defnx1 nx1-%badarg ((%badarg)) (badthing right-type)
     1123(defnx1 nx1-%badarg ((%badarg)) (badthing right-type &environment env)
    11241124  (make-acode (%nx1-operator %badarg2)
    11251125              (nx1-form badthing)
    1126               (nx1-form (or (if (quoted-form-p right-type) (%typespec-id (cadr right-type))) right-type))))
     1126              (nx1-form (or (if (nx-form-constant-p right-type env) (%typespec-id (nx-form-constant-value right-type env)))
     1127                            right-type))))
    11271128
    11281129(defnx1 nx1-unwind-protect (unwind-protect) (protected-form &body cleanup-form)
     
    14851486     (nx1-form value))))
    14861487
    1487 (defnx1 nx1-funcall ((funcall)) (func &rest args)
     1488(defnx1 nx1-funcall ((funcall)) (func &rest args &environment env)
    14881489  (let ((name func))
    14891490    (if (and (consp name)
     
    15021503      (nx1-form (cons name args))  ; This picks up call-next-method evil.
    15031504      (let* ((result-type t))
    1504         (when (and (quoted-form-p func)
    1505                    (or (typep (setq name (nx-unquote func)) 'symbol)
     1505        (when (and (nx-form-constant-p func env)
     1506                   (or (typep (setq name (nx-form-constant-value func env)) 'symbol)
    15061507                       (setq name (valid-function-name-p name))))
    15071508          (setq result-type (nx1-call-result-type name args nil t)))
  • trunk/source/compiler/optimizers.lisp

    r12219 r12297  
    176176
    177177(defun eql-iff-eq-p (thing env)
    178   (if (quoted-form-p thing)
    179     (setq thing (%cadr thing))
    180     (if (not (self-evaluating-p thing))
    181         (return-from eql-iff-eq-p
    182           (or (nx-form-typep thing  'symbol env)
    183               (nx-form-typep thing 'character env)
    184               (nx-form-typep thing
    185                              '(or fixnum
    186                                #+64-bit-target single-float
    187                                symbol character
    188                                (and (not number) (not macptr))) env)))))
     178  (if (nx-form-constant-p thing env)
     179    (setq thing (nx-form-constant-value thing env))
     180    (return-from eql-iff-eq-p
     181      (or (nx-form-typep thing  'symbol env)
     182          (nx-form-typep thing 'character env)
     183          (nx-form-typep thing
     184                         '(or fixnum
     185                           #+64-bit-target single-float
     186                           symbol character
     187                           (and (not number) (not macptr))) env))))
    189188  (or (fixnump thing) #+64-bit-target (typep thing 'single-float)
    190189      (symbolp thing) (characterp thing)
     
    192191
    193192(defun equal-iff-eql-p (thing env)
    194   (if (quoted-form-p thing)
    195     (setq thing (%cadr thing))
    196     (if (not (self-evaluating-p thing))
    197       (return-from equal-iff-eql-p
    198         (nx-form-typep thing
    199                        '(and (not cons) (not string) (not bit-vector) (not pathname)) env))))
     193  (if (nx-form-constant-p thing env)
     194    (setq thing (nx-form-constant-value thing env))
     195    (return-from equal-iff-eql-p
     196      (nx-form-typep thing
     197                     '(and (not cons) (not string) (not bit-vector) (not pathname)) env)))
    200198  (not (typep thing '(or cons string bit-vector pathname))))
    201199
     
    508506    (if (nx-form-typep (setq n (nx-transform n env)) 'fixnum env)
    509507        (let* ((limit (gensym))
    510                (upper (if (constantp n) n most-positive-fixnum))
     508               (upper (if (nx-form-constant-p n env) (nx-form-constant-value n env) most-positive-fixnum))
    511509               (top (gensym))
    512510               (test (gensym)))
     
    556554    (multiple-value-bind (true true-win) (nx-transform true env)
    557555      (multiple-value-bind (false false-win) (nx-transform false env)
    558         (if (or (quoted-form-p test) (self-evaluating-p test))
    559           (if (eval test)
     556        (if (nx-form-constant-p test env)
     557          (if (nx-form-constant-value test env)
    560558            true
    561559            false)
     
    650648(defun infer-array-type (dims element-type element-type-p displaced-to-p fill-pointer-p adjustable-p env)
    651649  (let* ((ctype (make-array-ctype :complexp (or displaced-to-p fill-pointer-p adjustable-p))))
    652     (if (quoted-form-p dims)
    653       (let* ((dims (nx-unquote dims)))
     650    (if (nx-form-constant-p dims env)
     651      (let* ((dims (nx-form-constant-value dims env)))
    654652        (if (listp dims)
    655653          (progn
     
    679677                '*))))
    680678    (let* ((typespec (if element-type-p
    681                        (if (constantp element-type)
    682                          (nx-unquote element-type)
     679                       (if (nx-form-constant-p element-type env)
     680                         (nx-form-constant-value element-type env)
    683681                         '*)
    684682                       t))
     
    717715                       (comp-make-displaced-array dims keys)))
    718716                    ((or displaced-index-offset-p
    719                          (not (constantp element-type))
     717                         (not (nx-form-constant-p element-type env))
    720718                         (null (setq element-type-keyword
    721719                                     (target-element-type-type-keyword
    722                                       (eval element-type) env))))
     720                                      (nx-form-constant-value element-type env) env))))
    723721                     (comp-make-array-1 dims keys))
    724722                    ((and (typep element-type-keyword 'keyword)
     
    939937(define-compiler-macro require-type (&whole call &environment env arg type &aux ctype)
    940938  (cond ((and (or (eq type t)
    941                   (and (quoted-form-p type)
    942                        (setq type (%cadr type))))
     939                  (and (nx-form-constant-p type env)
     940                       (setq type (nx-form-constant-value type env))))
    943941              (setq ctype (specifier-type-if-known type env :whine t)))
    944942         (cond ((nx-form-typep arg type env) arg)
     
    10571055              (loop-function (nx-form-sequence-iterator sequence env)))
    10581056          (if loop-function
    1059             (let ((item-var (unless (or (constantp item)
     1057            (let ((item-var (unless (or (nx-form-constant-p item env)
    10601058                                        (and (equal find-test '#'funcall)
    10611059                                             (function-form-p item)))
     
    11061104               (not (and test test-not)))
    11071105        (let ((position-test (or test test-not '#'eql))
    1108               (loop-test (if test-not 'unless 'when))
    1109               (sequence-value (if (constantp sequence)
    1110                                 (eval-constant sequence)
    1111                                 sequence)))
    1112           (cond ((nx-form-typep sequence-value 'list env)
    1113                  (let ((item-var (unless (or (constantp item)
     1106              (loop-test (if test-not 'unless 'when)))
     1107          (cond ((nx-form-typep sequence 'list env)
     1108                 (let ((item-var (unless (or (nx-form-constant-p item env)
    11141109                                             (and (equal position-test '#'funcall)
    11151110                                                  (function-form-p item)))
     
    11241119                                    (return ,position-var))
    11251120                        (incf ,position-var)))))
    1126                 ((nx-form-typep sequence-value 'vector env)
    1127                  (let ((item-var (unless (or (constantp item)
     1121                ((nx-form-typep sequence 'vector env)
     1122                 (let ((item-var (unless (or (nx-form-constant-p item env)
    11281123                                             (and (equal position-test '#'funcall)
    11291124                                                  (function-form-p item)))
     
    15781573
    15791574(define-compiler-macro typep  (&whole call &environment env thing type &optional e)
    1580   (if (or (quoted-form-p type) (self-evaluating-p type))
    1581     (let ((type-val (nx-unquote type)))
     1575  (if (nx-form-constant-p type env)
     1576    (let ((type-val (nx-form-constant-value type env)))
    15821577      (if (eq type-val t)
    15831578        `(progn ,thing t)
    1584         (if (and (or (quoted-form-p thing) (self-evaluating-p thing))
     1579        (if (and (nx-form-constant-p thing env)
    15851580                 (specifier-type-if-known type-val env))
    1586           (typep (nx-unquote thing) type-val env)
     1581          (typep (nx-form-constant-value thing env) type-val env)
    15871582          (or (and (null e) (optimize-typep thing type-val env))
    15881583              call))))
     
    18871882  call)
    18881883
    1889 (define-compiler-macro make-string (&whole call size &rest keys)
     1884(define-compiler-macro make-string (&whole call &environment env size &rest keys)
    18901885  (if (constant-keywords-p keys)
    18911886    (destructuring-bind (&key (element-type () element-type-p)
     
    18931888                        keys
    18941889      (if (and element-type-p
    1895                (quoted-form-p element-type))
    1896         (let* ((element-type (cadr element-type)))
     1890               (nx-form-constant-p element-type env))
     1891        (let* ((element-type (nx-form-constant-value element-type env)))
    18971892          (if (subtypep element-type 'base-char)
    18981893            `(allocate-typed-vector :simple-string ,size ,@(if initial-element-p `(,initial-element)))
     
    22682263
    22692264(define-compiler-macro coerce (&whole call &environment env thing type)
    2270   (cond ((quoted-form-p type)
    2271          (setq type (cadr type))
     2265  (cond ((nx-form-constant-p type env)
     2266         (setq type (nx-form-constant-value type env))
    22722267         (let ((ctype (specifier-type-if-known type env :whine t)))
    22732268           (if ctype
     
    23052300    call))
    23062301
    2307 (define-compiler-macro instance-slots (&whole w instance)
    2308   (if (and (constantp instance)
    2309            (eql (typecode instance) (nx-lookup-target-uvector-subtag :instance)))
     2302(define-compiler-macro instance-slots (&whole w instance &environment env)
     2303  (if (and (nx-form-constant-p instance env)
     2304           (eql (typecode (nx-form-constant-value instance env)) (nx-lookup-target-uvector-subtag :instance)))
    23102305    `(instance.slots ,instance)
    23112306    (let* ((itemp (gensym))
     
    23902385;;; a package name is used as a constant argument to some functions.
    23912386
    2392 (defun package-ref-form (arg)
    2393   (when (and arg (constantp arg) (typep (setq arg (nx-unquote arg))
    2394                                         '(or symbol string)))
     2387(defun package-ref-form (arg env)
     2388  (when (and arg (nx-form-constant-p arg env)
     2389             (typep (setq arg (nx-form-constant-value arg env))
     2390                    '(or symbol string)))
    23952391    `(load-time-value (register-package-ref ,(string arg)))))
    23962392
    23972393
    23982394
    2399 (define-compiler-macro intern (&whole w string &optional package)
    2400   (let* ((ref (package-ref-form package)))
     2395(define-compiler-macro intern (&whole w string &optional package &environment env)
     2396  (let* ((ref (package-ref-form package env)))
    24012397    (if (or ref
    24022398            (setq ref (and (consp package)
     
    24042400                           (consp (cdr package))
    24052401                           (null (cddr package))
    2406                            (package-ref-form (cadr package)))))
     2402                           (package-ref-form (cadr package) env))))
    24072403      `(%pkg-ref-intern ,string ,ref)
    24082404      w)))
    24092405
    2410 (define-compiler-macro find-symbol (&whole w string &optional package)
    2411   (let* ((ref (package-ref-form package)))
     2406(define-compiler-macro find-symbol (&whole w string &optional package &environment env)
     2407  (let* ((ref (package-ref-form package env)))
    24122408    (if (or ref
    24132409            (setq ref (and (consp package)
     
    24152411                           (consp (cdr package))
    24162412                           (null (cddr package))
    2417                            (package-ref-form (cadr package)))))
     2413                           (package-ref-form (cadr package) env))))
    24182414      `(%pkg-ref-find-symbol ,string ,ref)
    24192415      w)))
    24202416
    2421 (define-compiler-macro find-package (&whole w package)
    2422   (let* ((ref (package-ref-form package)))
     2417(define-compiler-macro find-package (&whole w package &environment env)
     2418  (let* ((ref (package-ref-form package env)))
    24232419    (if ref
    24242420      `(package-ref.pkg ,ref)
    24252421      w)))
    24262422
    2427 (define-compiler-macro pkg-arg (&whole w package &optional allow-deleted)
    2428   (let* ((ref (unless allow-deleted (package-ref-form package))))
     2423(define-compiler-macro pkg-arg (&whole w package &optional allow-deleted &environment env)
     2424  (let* ((ref (unless allow-deleted (package-ref-form package env))))
    24292425    (if ref
    24302426      (let* ((r (gensym)))
     
    24792475
    24802476
    2481 (define-compiler-macro register-istruct-cell (&whole w arg)
    2482   (if (and (quoted-form-p arg)
    2483            (cadr arg)
    2484            (typep (cadr arg) 'symbol))
    2485     `',(register-istruct-cell (cadr arg))
     2477(define-compiler-macro register-istruct-cell (&whole w arg &environment env)
     2478  (if (and (nx-form-constant-p arg env)
     2479           (setq arg (nx-form-constant-value arg env))
     2480           (symbolp arg))
     2481    `',(register-istruct-cell arg)
    24862482    w))
    24872483
Note: See TracChangeset for help on using the changeset viewer.