Changeset 14421


Ignore:
Timestamp:
Nov 8, 2010, 11:13:03 AM (9 years ago)
Author:
gb
Message:

systems.lisp, compile-ccl.lisp, l1-boot-2.lisp: Compile and load
ACODE-REWRITE.

acode-rewrite.lisp: new, improved ... still not working, still not
complete.

nx.lisp: COMPILE-NAMED-FUNCTION optionally rewrites acode after generating
it (under control of *NX-REWRITE-ACODE*, for now.)

Location:
trunk/source
Files:
5 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/compiler/acode-rewrite.lisp

    r13067 r14421  
    11;;;-*- Mode: Lisp; Package: CCL -*-
    22;;;
    3 ;;;   Copyright (C) 2007-2009 Clozure Associates
     3;;;   Copyright (C) 2007-2010 Clozure Associates
    44;;;   This file is part of Clozure CL. 
    55;;;
     
    1818
    1919
    20 (defvar *acode-post-trust-decls* nil)
     20(defvar *acode-rewrite-tail-allow* nil)
     21(defvar *acode-rewrite-reckless* nil)
     22(defvar *acode-rewrite-open-code-inline* nil)
     23(defvar *acode-rewrite-trust-declarations* nil)
     24(defvar *acode-rewrite-full-safety* nil)
     25
    2126
    2227;;; Rewrite acode trees.
    2328
    24 (next-nx-defops)
     29;(next-nx-defops)
    2530(defvar *acode-rewrite-functions* nil)
    2631(let* ((newsize (%i+ (next-nx-num-ops) 10))
     
    3439
    3540(eval-when (:compile-toplevel :load-toplevel :execute)
    36   (defmacro def-acode-rewrite (name operator-list arglist &body body)
     41  (defmacro def-acode-rewrite (name operator-list typecons arglist &body body)
    3742    (if (atom operator-list)
    3843      (setq operator-list (list operator-list)))
    39     (multiple-value-bind (body decls)
    40         (parse-body body nil t)
    41       (collect ((let-body))
    42         (dolist (operator operator-list)
    43           (let-body `(setf (svref *acode-rewrite-functions* (logand operator-id-mask (%nx1-operator ,operator))) fun)))
    44         (destructuring-bind (op whole type) arglist
     44    (multiple-value-bind (lambda-list whole)
     45        (normalize-lambda-list arglist t)
     46      (multiple-value-bind (body decls)
     47          (parse-body body nil t)
     48        (collect ((let-body))
     49          (dolist (operator operator-list)
     50            (let-body `(setf (svref *acode-rewrite-functions* (logand operator-id-mask (%nx1-operator ,operator))) fun)))
     51          (let* ((whole-var (gensym "WHOLE")))
     52            (multiple-value-bind (bindings binding-decls)
     53                (%destructure-lambda-list lambda-list whole-var nil nil
     54                                          :cdr-p t
     55                                          :whole-p nil
     56                                          :use-whole-var t
     57                                          :default-initial-value nil)
     58              (when whole
     59                (setq bindings (nconc bindings (list `(,whole ,whole-var)))))
     60             
    4561        `(let* ((fun (nfunction ,name
    46                                 (lambda (,op ,whole ,type)
    47                                   (declare (ignorable ,op ,type))
    48                                   ,@decls
    49                                   (block ,name ,@body)))))
    50           ,@(let-body)))))))
     62                                (lambda (,typecons ,whole-var)
     63                                  (declare (ignorable ,typecons))
     64                                  (block ,name
     65                                    (let* ,(nreverse bindings)
     66                                      ,@(when binding-decls `((declare ,@binding-decls)))
     67                                      ,@decls
     68                                      ,@body))))))
     69          ,@(let-body)))))))))
    5170
    5271;;; Don't walk the form (that's already happened.)
     
    5574    (let* ((op (acode-operator form))
    5675           (operands (cdr form)))
    57       (cond ((and *acode-post-trust-decls*
     76      (cond ((and *acode-rewrite-trust-declarations*
    5877                  (eq op (%nx1-operator typed-form)))
    5978             (acode-operand 0 operands))
     
    6584
    6685(defun acode-constant-p (form)
    67   (let* ((form (acode-unwrapped-form-value form)))
    68     (or (eq form *nx-nil*)
    69         (eq form *nx-t*)
    70         (let* ((operator (if (acode-p form) (acode-operator form))))
    71           (or (eq operator (%nx1-operator fixnum))
    72               (eq operator (%nx1-operator immediate)))))))
     86  ;; This returns (values constant-value constantp); some code
     87  ;; may need to check constantp if constant-value is nil.
     88  (let* ((form (acode-unwrapped-form-value form))
     89         (op (if (acode-p form) (acode-operator form))))
     90    (cond ((eql op (%nx1-operator nil))
     91           (values nil t))
     92          ((eql op (%nx1-operator t))
     93           (values t t))
     94          ((or (eql op (%nx1-operator fixnum))
     95               (eql op (%nx1-operator immediate)))
     96           (values (cadr form) t))
     97          (t (values nil nil)))))
     98
    7399
    74100(defun acode-post-form-typep (form type)
    75101  (let* ((ctype (specifier-type type))
    76102         (form (acode-unwrapped-form-value form)))
    77     (cond ((eq form *nx-nil*) (ctypep nil ctype))
    78           ((eq form *nx-t*) (ctypep t ctype))
     103    (cond ((nx-null form) (ctypep nil ctype))
     104          ((nx-t form) (ctypep t ctype))
    79105          ((not (acode-p form)) (values nil nil))
    80106          (t
    81107           (let* ((op (acode-operator form))
    82108                  (operands (cdr form)))
    83              (cond ((and *acode-post-trust-decls*
     109             (cond ((and *acode-rewrite-trust-declarations*
    84110                         (eq op (%nx1-operator typed-form)))
    85111                    (subtypep (acode-operand 0 operands) type))
     
    89115                   (t (values nil nil))))))))
    90116
    91              
    92 
    93 (defun rewrite-acode-ref (ref &optional (type t))
    94   (let* ((form (car ref)))
    95     (if (acode-p form)
    96       (let* ((op (acode-operator form))
    97              (rewrite (svref *acode-rewrite-functions* (logand op operator-id-mask))))
    98         (when rewrite
    99           (let* ((new (funcall rewrite op (cdr form) type)))
    100             (when new
    101               (setf (car ref) new)
    102               t)))))))
    103 
    104 ;;; Maybe ewrite the operands of a binary real arithmetic operation
    105 (defun acode-post-binop-numeric-contagion (pform1 pform2)
    106   (let* ((form1 (car pform1))
    107          (form2 (car pform2)))
    108     (cond ((acode-post-form-typep form1 'double-float)
    109            (unless (acode-post-form-typep form2 'double-float)
    110              (let* ((c2 (acode-real-constant-p form2)))
    111                (if c2
    112                  (setf (car pform2)
    113                        (make-acode (%nx1-operator immediate)
    114                                    (float c2 0.0d0)))
    115                  (if (acode-post-form-typep form2 'fixnum)
    116                    (setf (car pform2)
    117                          (make-acode (%nx1-operator typed-form)
    118                                      'double-float
    119                                      (make-acode (%nx1-operator %fixnum-to-double)
    120                                                  form2))))))))
    121           ((acode-post-form-typep form2 'double-float)
    122            (let* ((c1 (acode-real-constant-p form1)))
    123              (if c1
    124                (setf (car pform1)
    125                      (make-acode (%nx1-operator immediate)
    126                                  (float c1 0.0d0)))
    127                (if (acode-post-form-typep form1 'fixnum)
    128                  (setf (car pform1)
    129                        (make-acode (%nx1-operator typed-form)
    130                                    'double-float
    131                                    (make-acode (%nx1-operator %fixnum-to-double)
    132                                                form1)))))))
    133           ((acode-post-form-typep form1 'single-float)
    134            (unless (acode-post-form-typep form2 'single-float)
    135              (let* ((c2 (acode-real-constant-p form2)))
    136                (if c2
    137                  (setf (car pform2) (make-acode (%nx1-operator immediate)
    138                                                 (float c2 0.0f0)))
    139                  (if (acode-post-form-typep form2 'fixnum)
    140                    (setf (car pform2)
    141                          (make-acode (%nx1-operator typed-form)
    142                                      'single-float
    143                                      (make-acode (%nx1-operator %fixnum-to-single)
    144                                                  form2))))))))
    145           ((acode-post-form-typep form2 'single-float)
    146            (let* ((c1 (acode-real-constant-p form1)))
    147              (if c1
    148                (setf (car pform1) (make-acode (%nx1-operator immediate)
    149                                               (float c1 0.0f0)))
    150 
    151                (if (acode-post-form-typep form1 'fixnum)
    152                  (setf (car pform1)
    153                        (make-acode (%nx1-operator typed-form)
    154                                    'single-float
    155                                    (make-acode (%nx1-operator %fixnum-to-single)
    156                                                form1))))))))))
    157 
    158 (defun constant-fold-acode-binop (function x y)
    159   (let* ((constant-x (acode-real-constant-p x))
    160          (constant-y (acode-real-constant-p y)))
    161     (if (and constant-x constant-y)
    162       (let* ((result (ignore-errors (funcall function x y))))
    163         (when result
    164           (nx1-form result))))))
    165 
    166 (defun acode-rewrite-and-fold-binop (function args)
    167   (rewrite-acode-ref args)
    168   (rewrite-acode-ref (cdr args))
    169   (constant-fold-acode-binop function (car args) (cadr args)))
    170 
    171 (defun rewrite-acode-forms (forms)
    172   (do* ((head forms (cdr head)))
    173        ((null head))
    174     (rewrite-acode-ref head)))
    175 
    176 (defun acode-assert-type (actualtype operator operands assertedtype)
    177   (make-acode (%nx1-operator typed-form)
    178               (type-specifier (type-intersection (specifier-type actualtype)
    179                                                  (specifier-type assertedtype)))
    180               (cons operator operands)))
    181 
    182 (def-acode-rewrite acode-rewrite-progn progn (op w type)
    183   (rewrite-acode-forms w))
    184 
    185 (def-acode-rewrite acode-rewrite-not not (op w type)
    186   (rewrite-acode-ref w))
    187 
    188 (def-acode-rewrite acode-rewrite-%i+ %i+ (op w type)
    189   (or
    190    (acode-rewrite-and-fold-binop '+ w)
    191    ;; TODO: maybe cancel overflow check, assert FIXNUM result.
    192    (acode-assert-type 'integer op w type)))
    193 
    194 (def-acode-rewrite acode-rewrite-%i- %i- (op w type)
    195   (or
    196    (acode-rewrite-and-fold-binop '- w))
    197    ;; TODO: maybe cancel overflow check, assert FIXNUM result.
    198    (acode-assert-type 'integer op w type)) 
    199 
    200 (def-acode-rewrite acode-rewrite-%ilsl %ilsl (op w type)
    201   (or
    202    (acode-rewrite-and-fold-binop '%ilsl w)
    203    (acode-assert-type 'fixnum op w type)))
    204 
    205 (def-acode-rewrite acode-rewrite-%ilogand2 %ilogand2 (op w type)
    206   (or
    207    (acode-rewrite-and-fold-binop 'logand w)
    208    ;; If either argument's an UNSIGNED-BYTE constant, the result
    209    ;; is an UNSIGNED-BYTE no greater than that constant.
    210    (destructuring-bind (x y) w
    211      (let* ((fix-x (acode-fixnum-form-p x))
    212             (fix-y (acode-fixnum-form-p y)))
    213        (acode-assert-type (if fix-x
    214                             `(integer 0 ,fix-x)
    215                             (if fix-y
    216                               `(integer 0 ,fix-y)
    217                               'fixnum))
    218                           op w type)))))
    219 
    220 (def-acode-rewrite acode-rewrite-%ilogior2 %ilogior2 (op w type)
    221   (or
    222    (acode-rewrite-and-fold-binop 'logior w)
    223    ;; If either argument's an UNSIGNED-BYTE constant, the result
    224    ;; is an UNSIGNED-BYTE no greater than that constant.
    225    (destructuring-bind (x y) w
    226      (let* ((fix-x (acode-fixnum-form-p x))
    227             (fix-y (acode-fixnum-form-p y)))
    228        (acode-assert-type (if fix-x
    229                             `(integer 0 ,fix-x)
    230                             (if fix-y
    231                               `(integer 0 ,fix-y)
    232                               'fixnum))
    233                           op w type)))))
    234 
    235 (def-acode-rewrite acode-rewrite-ilogbitp (logbitp %ilogbitp) (op w type)
    236   (or (acode-rewrite-and-fold-binop 'logbitp w)
    237       (acode-assert-type 'boolean op w type)))
    238 
    239 (def-acode-rewrite acode-rewrite-eq eq (op w type)
    240   (or (acode-rewrite-and-fold-binop 'eq w)
    241       (acode-assert-type 'boolean op w type)))
    242 
    243 (def-acode-rewrite acode-rewrite-neq neq (op w type)
    244   (or (acode-rewrite-and-fold-binop 'neq w)
    245       (acode-assert-type 'boolean op w type))  )
    246 
    247 (def-acode-rewrite acode-rewrite-list list (op w type)
    248   (rewrite-acode-forms (car w))
    249   (acode-assert-type 'list op w type))
    250 
    251 (def-acode-rewrite acode-rewrite-values values (op w type)
    252   (rewrite-acode-forms (car w)))
    253 
    254 (def-acode-rewrite acode-rewrite-if if (op w type)
    255   (rewrite-acode-forms w)
    256   (destructuring-bind (test true &optional (false *nx-nil*)) w
    257     (if (acode-constant-p test)
    258       (if (eq *nx-nil* (acode-unwrapped-form-value test))
    259         false
    260         true))))
    261 
    262 (def-acode-rewrite acode-rewrite-or or (op w type)
    263   (rewrite-acode-forms (car w))
    264   ;; Try to short-circuit if there are any true constants.
    265   ;; The constant-valued case will return a single value.
    266   (do* ((forms w (cdr forms)))
    267        ((null (cdr forms)))
    268     (let* ((form (car forms)))
    269       (when (and (acode-constant-p form)
    270                  (not (eq *nx-nil* (acode-unwrapped-form-value form))))
    271         (progn
    272           (rplacd forms nil)
    273           (return))))))
    274 
    275 (def-acode-rewrite acode-rewrite-%fixnum-ref (%fixnum-ref %fixnum-ref-natural) (op w type)
    276   (rewrite-acode-forms w))
    277 
    278 (def-acode-rewrite acode-rewrite-multiple-value-prog1 multiple-value-prog1 (op w type)
    279   (rewrite-acode-forms w))
    280 
    281 (def-acode-rewrite acode-rewrite-multiple-value-bind multiple-value-bind (op w type)
    282   (rewrite-acode-forms (cdr w)))
    283 
    284 (def-acode-rewrite acode-rewrite-multiple-value-call multiple-value-call (op w type)
    285   (rewrite-acode-forms w))
    286 
    287 (def-acode-rewrite acode-rewrite-typed-form typed-form (op w type)
    288   (let* ((ourtype (car w)))
    289     (rewrite-acode-ref (cdr w) ourtype)
    290     (let* ((subform (cadr w)))
    291       (and (acode-p subform) (eq (acode-operator subform) op) subform))))
    292 
    293 ;; w: vars, list of initial-value forms, body
    294 (def-acode-rewrite acode-rewrite-let (let let*) (op w type)
    295   (collect ((newvars)
    296             (newvals))
    297     (do* ((vars (car w) (cdr vars))
    298           (vals (cadr w) (cdr vals)))
    299          ((null vars)
    300           (rplaca w (newvars))
    301           (rplaca (cdr w) (newvals))
    302           (rewrite-acode-ref (cddr w))
    303           (unless (car w) (caddr w)))
    304       (rewrite-acode-ref (car vals))
    305       (let* ((var (car vars))
    306              (bits (nx-var-bits var)))
    307         (cond ((logbitp $vbitpuntable bits)
    308                (setf (var-bits var)
    309                      (logior (ash 1 $vbitpunted) bits)
    310                      (var-ea var) (car vals)))
    311               (t
    312                (newvars var)
    313                (newvals (car vals))))))))
     117(defun rewrite-acode-form (form type)
     118  (when (acode-p form)
     119    (let* ((op (acode-operator form))
     120           (rest (acode-operands form))
     121           (rewrite (svref *acode-rewrite-functions* (logand op operator-id-mask))))
     122      (when rewrite
     123        (let* ((new (cons op rest))
     124               (type-cons (list type new)))
     125          (setf (car form) (%nx1-operator type-asserted-form)
     126                (cdr form) type-cons)
     127          (funcall rewrite type-cons new))))))
     128     
     129   
     130
     131(defun acode-constant-fold-numeric-binop (type-cons whole form1 form2 function)
     132  (rewrite-acode-form form1 t)
     133  (rewrite-acode-form form2 t)
     134  (let* ((v1 (acode-xxx-form-p form1 'number))
     135         (v2 (acode-xxx-form-p form2 'number))
     136         (val (and v1 v2 (ignore-errors (funcall function v1 v2)))))
     137    (when val
     138      (setf (car whole) (if (typep val *nx-target-fixnum-type*)
     139                          (%nx1-operator fixnum)
     140                          (%nx1-operator immediate))
     141            (cadr whole) val
     142            (cddr whole) nil
     143            (car type-cons) (if (typep val 'integer)
     144                             `(integer ,val ,val)
     145                             (type-of val)))
     146      val)))
     147
     148(defun acode-rewrite-decls (decls)
     149  (if (fixnump decls)
     150    (locally (declare (fixnum decls))
     151      (setq *acode-rewrite-tail-allow* (neq 0 (%ilogand2 $decl_tailcalls decls))
     152            *acode-rewrite-open-code-inline* (neq 0 (%ilogand2 $decl_opencodeinline decls))
     153            *acode-rewrite-full-safety* (neq 0 (%ilogand2 $decl_full_safety decls))
     154            *acode-rewrite-reckless* (neq 0 (%ilogand2 $decl_unsafe decls))
     155            *acode-rewrite-trust-declarations* (neq 0 (%ilogand2 $decl_trustdecls decls))))))
     156
     157(defmacro with-acode-declarations (declsform &body body)
     158  `(let* ((*acode-rewrite-tail-allow* *acode-rewrite-tail-allow*)
     159          (*acode-rewrite-reckless* *acode-rewrite-reckless*)
     160          (*acode-rewrite-open-code-inline* *acode-rewrite-open-code-inline*)
     161          (*acode-rewrite-trust-declarations* *acode-rewrite-trust-declarations*)
     162          (*acode-rewrite-full-safety* *acode-rewrite-full-safety*))
     163     (acode-rewrite-decls ,declsform)
     164     ,@body))
     165
     166(defun acode-maybe-punt-var (var initform)
     167  (let* ((bits (nx-var-bits var)))
     168    (declare (fixnum bits))
     169    (cond ((and (logbitp $vbitpuntable var)
     170                (not (logbitp $vbitpunted var)))
     171           (nx-set-var-bits var (logior (ash 1 $vbitpunted) bits))
     172           (rewrite-acode-form initform (or (var-inittype var) t))
     173           (nx2-replace-var-refs var initform)
     174           (setf (var-ea var) initform))
     175          (t
     176           (rewrite-acode-form initform t)))))
     177           
     178(defun acode-type-merge (type-cons derived)
     179  (let* ((asserted (car type-cons))
     180         (intersection (ignore-errors (type-specifier (specifier-type `(and ,asserted ,derived))))))
     181    (when intersection
     182      (setf (car type-cons) intersection))))
     183
     184         
     185   
     186 
     187
     188(def-acode-rewrite acode-rewrite-lambda lambda-list type-cons (req opt rest keys auxen body p2-decls &optional code-note)
     189  (declare (ignore code-note req rest))
     190  (with-acode-declarations p2-decls
     191    (dolist (optinit (cadr opt))
     192      (rewrite-acode-form optinit t))
     193    (dolist (keyinit (nth 3 keys))
     194      (rewrite-acode-form keyinit t))
     195    (do* ((auxvars (car auxen) (cdr auxvars))
     196          (auxvals (cadr auxen) (cdr auxvals)))
     197         ((null auxvars))
     198      (acode-maybe-punt-var (car auxvars) (car auxvals)))
     199    (rewrite-acode-form body (car type-cons))
     200    (acode-type-merge type-cons (acode-form-type body *acode-rewrite-trust-declarations*))))
     201
     202(def-acode-rewrite acode-rewrite-progn progn type-cons (&rest forms)
     203  (do* ((form (pop forms) (pop forms)))
     204       ((null forms))
     205    (if forms
     206      (rewrite-acode-form form t)
     207      (progn
     208        (rewrite-acode-form form (car type-cons))
     209        (acode-type-merge type-cons (acode-form-type form *acode-rewrite-trust-declarations*))))))
     210
     211(def-acode-rewrite acode-rewrite-prog1 prog1 type-cons (first &rest others)
     212  (rewrite-acode-form first (car type-cons))
     213  (dolist (other others) (rewrite-acode-form other t))
     214  (acode-type-merge type-cons (acode-form-type first *acode-rewrite-trust-declarations*)))
     215
     216(def-acode-rewrite acode-rewrite-%slot-ref %slot-ref type-cons (instance idx)
     217  (rewrite-acode-form instance t)
     218  (rewrite-acode-form idx t))
     219
     220(def-acode-rewrite acode-rewrite-svref (%svref svref) type-cons (&whole w vector idx)
     221  (rewrite-acode-form vector t)
     222  (rewrite-acode-form idx t)
     223  (let* ((cv (acode-constant-p vector)))
     224    (when (if (eql (car w) (%nx1-operator svref))
     225            (typep cv 'simple-vector)
     226            (gvectorp cv))
     227      (let* ((cidx (acode-fixnum-form-p idx)))
     228        (when (and (typep cidx 'fixnum)
     229                   (>= (the fixnum cidx) 0)
     230                   (< (the fixnum cidx) (the fixnum (uvsize cv))))
     231          (let* ((val (%svref cv cidx)))
     232            (setf (car w) (if (nx1-target-fixnump val)
     233                            (%nx1-operator fixnum)
     234                            (%nx1-operator immediate))
     235                  (cadr w) val
     236                  (cddr w) nil)
     237            (acode-type-merge type-cons (type-of val))))))))
     238
     239(def-acode-rewrite acode-rewrite-%sbchar %sbchar type-cons (&whole w string idx)
     240  (rewrite-acode-form string t)
     241  (rewrite-acode-form idx t)
     242  (let* ((cv (acode-constant-p string)))
     243    (when (typep cv 'simple-string)
     244      (let* ((cidx (acode-fixnum-form-p idx)))
     245        (when (and (typep cidx 'fixnum)
     246                   (>= (the fixnum cidx) 0)
     247                   (< (the fixnum cidx) (the fixnum (length cv))))
     248          (let* ((val (%schar cv cidx)))
     249            (setf (car w) (%nx1-operator immediate)
     250                  (cadr w) val
     251                  (cddr w) nil)
     252            (acode-type-merge type-cons 'character)))))))
     253
     254(def-acode-rewrite acode-rewrite-svset (%svset svset) type-cons (vector idx value)
     255  (rewrite-acode-form vector t)
     256  (rewrite-acode-form idx t)
     257  (rewrite-acode-form value (car type-cons))
     258  (acode-type-merge type-cons (acode-form-type value *acode-rewrite-trust-declarations*)))
     259
     260(def-acode-rewrite acode-rewrite-consp consp type-cons (&whole w cc thing)
     261  (rewrite-acode-form thing t)
     262  (multiple-value-bind (cthing constantp) (acode-constant-p thing)
     263    (if constantp
     264      (let* ((consp (consp cthing))
     265             (ccode (cadr cc))
     266             (val (if (eq ccode :eq) (not (not consp)) (not consp))))
     267        (setf (car w) (if val (%nx1-operator t) (%nx1-operator nil))
     268              (cdr w) nil)))))
     269
     270(def-acode-rewrite acode-rewrite-cons cons type-cons (x y)
     271  (rewrite-acode-form x t)
     272  (rewrite-acode-form y t)
     273  (acode-type-merge type-cons 'cons))
     274
     275(def-acode-rewrite acode-rewrite-rplacx (%rplaca %rplacd rplaca rplacd) type-cons (cell val)
     276  (rewrite-acode-form cell t)
     277  (rewrite-acode-form val t)
     278  (acode-type-merge type-cons 'cons))
     279
     280(def-acode-rewrite acode-rewrite-set-cxr (set-car set-cdr) type-cons (cell val)
     281  (rewrite-acode-form cell t)
     282  (rewrite-acode-form val t)
     283  (acode-type-merge type-cons (acode-form-type val *acode-rewrite-trust-declarations*)))
     284
     285(def-acode-rewrite acode-rewrite-cxr (%car %cdr car cdr) type-cons (cell)
     286  (rewrite-acode-form cell t))
     287
     288(def-acode-rewrite acode-rewrite-vector vector type-cons (arglist)
     289  (dolist (f arglist) (rewrite-acode-form f t))
     290  (acode-type-merge type-cons 'simple-vector))
     291
     292                   
    314293       
    315    
    316      
    317 
    318 
    319 
    320 (def-acode-rewrite acode-rewrite-lexical-reference lexical-reference (op w type)
    321   (let* ((var (car w)))
    322     (if (acode-punted-var-p var)
    323       (var-ea var))))
    324 
    325 (def-acode-rewrite acode-rewrite-add2 add2 (op w type)
    326   (or (acode-rewrite-and-fold-binop '+ w)
    327       (progn
    328         (acode-post-binop-numeric-contagion w (cdr w))
    329         (let* ((xtype (acode-post-form-type (car w)))
    330                (ytype (acode-post-form-type (cadr w))))
    331           (cond ((and (subtypep xtype 'double-float)
    332                       (subtypep ytype 'double-float))
    333                  (make-acode (%nx1-operator typed-form)
    334                              'double-float
    335                              (make-acode* (%nx1-operator %double-float+-2)
    336                                           w)))
    337                 ((and (subtypep xtype 'single-float)
    338                       (subtypep ytype 'single-float))
    339                  (make-acode (%nx1-operator typed-form)
    340                              'single-float
    341                              (make-acode* (%nx1-operator %short-float+-2)
    342                                           w)))
    343                 ((and (subtypep xtype 'fixnum)
    344                       (subtypep ytype 'fixnum))
    345                  (make-acode (%nx1-operator typed-form)
    346                              'fixnum
    347                              (make-acode (%nx1-operator %i+)
    348                                          (car w)
    349                                          (cadr w)
    350                                          (not (subtypep type 'fixnum))))))))))
    351 
    352 (def-acode-rewrite acode-rewrite-sub2 sub2 (op w type)
    353   (or (acode-rewrite-and-fold-binop '- w)
    354       (progn
    355         (acode-post-binop-numeric-contagion w (cdr w))
    356         (let* ((xtype (acode-post-form-type (car w)))
    357                (ytype (acode-post-form-type (cadr w))))
    358           (cond ((and (subtypep xtype 'double-float)
    359                       (subtypep ytype 'double-float))
    360                  (make-acode (%nx1-operator typed-form)
    361                              'double-float
    362                              (make-acode* (%nx1-operator %double-float--2)
    363                                           w)))
    364                 ((and (subtypep xtype 'single-float)
    365                       (subtypep ytype 'single-float))
    366                  (make-acode (%nx1-operator typed-form)
    367                              'single-float
    368                              (make-acode* (%nx1-operator %short-float--2)
    369                                           w)))
    370                 ((and (subtypep xtype 'fixnum)
    371                       (subtypep ytype 'fixnum))
    372                  (make-acode (%nx1-operator typed-form)
    373                              'fixnum
    374                              (make-acode (%nx1-operator %i-)
    375                                          (car w)
    376                                          (cadr w)
    377                                          (not (subtypep type 'fixnum))))))))))
    378                  
    379 
     294       
  • trunk/source/compiler/nx.lisp

    r14406 r14421  
    158158
    159159(defparameter *nx-in-frontend* nil)
    160 
     160(defparameter *nx-rewrite-acode* nil)
    161161
    162162
     
    206206       (if (afunc-lfun afunc)
    207207         afunc
    208          (funcall (backend-p2-compile *target-backend*)
    209                   afunc
    210                   ;; will also bind *nx-lexical-environment*
    211                   (if keep-lambda (if (lambda-expression-p keep-lambda) keep-lambda def))
    212                   keep-symbols)))))
     208         (progn
     209           (when (and *nx-rewrite-acode*
     210                      (afunc-acode afunc))
     211             (rewrite-acode-form (afunc-acode afunc) t))
     212           (funcall (backend-p2-compile *target-backend*)
     213                    afunc
     214                    ;; will also bind *nx-lexical-environment*
     215                    (if keep-lambda (if (lambda-expression-p keep-lambda) keep-lambda def))
     216                    keep-symbols))))))
    213217  (values (afunc-lfun def) (afunc-warnings def)))
    214218
  • trunk/source/level-1/l1-boot-2.lisp

    r14362 r14421  
    242242
    243243      #+arm-target
    244       (provide "ARM2")
    245      
     244      (provide "ARM2")
     245      (bin-load-provide "ACODE-REWRITE" "acode-rewrite")
     246     
    246247      (l1-load-provide "NX" "nx")
    247248     
  • trunk/source/lib/compile-ccl.lisp

    r14317 r14421  
    4141(defparameter *compiler-modules*
    4242  '(nx optimizers dll-node arch vreg vinsn
    43     reg subprims  backend nx2))
     43    reg subprims  backend nx2 acode-rewrite))
    4444
    4545
  • trunk/source/lib/systems.lisp

    r14171 r14421  
    8282    (nxenv            "ccl:bin;nxenv"            ("ccl:compiler;nxenv.lisp"))
    8383    (nx2              "ccl:bin;nx2"              ("ccl:compiler;nx2.lisp"))
     84    (acode-rewrite    "ccl:bin;acode-rewrite"    ("ccl:compiler;acode-rewrite.lisp"))
    8485    (nx-base-app      "ccl:l1f;nx-base-app"      ("ccl:compiler;nx-base-app.lisp"
    8586                                                  "ccl:compiler;lambda-list.lisp"))
Note: See TracChangeset for help on using the changeset viewer.