Changeset 12297

Jun 25, 2009, 12:15:25 PM (11 years ago)

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

5 edited


  • 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
    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
    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  
    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)))
    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))))
     2160(defun nx-form-constant-p (form env)
     2161  (declare (ignore env))
     2162  (or (quoted-form-p form)
     2163      (self-evaluating-p form)))
     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))
    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))))
    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)))
  • 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)
    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)))
    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))))
    11281129(defnx1 nx1-unwind-protect (unwind-protect) (protected-form &body cleanup-form)
    14851486     (nx1-form value))))
    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  
    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)
    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))))
    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)))
    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)
    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)))
    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))
    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.
    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)))))
    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)))
    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)))
    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)))
    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)))
    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))
Note: See TracChangeset for help on using the changeset viewer.