Changeset 11386

Nov 17, 2008, 1:44:07 PM (12 years ago)

Start to add some general acode-walking routines that (hopefully)
can be shared between current and future backends.

Add NX2-ALLOCATE-GLOBAL-REGISTERS, which is like the existing PPC2/X862
versions but hopefully deals better with inherited (closed-over) variables.
(If it assigns an NVR to a variable, that NVR will be in the VAR-NVR
slot; shared var-bits (maintained in the parent) aren't affected. (In
particular, the $vbitreg bit isn't meaningful: a variable can be
in a registers in one function and not in another, in different registers,
etc. Of course, a closed-over variable can only be assigned a register
if it's never setqed, which is a conservative approximation of the
real restriction.)

NX2-ASSIGN-REGISTER-VARIABLE returns the value of the VAR-NVR slot.

1 edited


  • trunk/source/compiler/nx2.lisp

    r11367 r11386  
     22(defun nx2-bigger-cdr-than (x y)
     23  (declare (cons x y))
     24  (> (the fixnum (cdr x)) (the fixnum (cdr y))))
     26;;; Return an unordered list of "varsets": each var in a varset can be
     27;;; assigned a register and all vars in a varset can be assigned the
     28;;; same register (e.g., no scope conflicts.)
     30(defun nx2-partition-vars (vars inherited-vars)
     31  (labels ((var-weight (var)
     32             (let* ((bits (nx-var-bits var)))
     33               (declare (fixnum bits))
     34               (if (eql 0 (logand bits (logior
     35                                        (ash 1 $vbitpuntable)
     36                                        (ash -1 $vbitspecial)
     37                                        (ash 1 $vbitnoreg))))
     38                 (if (eql (logior (ash 1 $vbitclosed) (ash 1 $vbitsetq))
     39                          (logand bits (logior (ash 1 $vbitclosed) (ash 1 $vbitsetq))))
     40                   0
     41                   (var-refs var))
     42                 0)))
     43           (sum-weights (varlist)
     44             (let ((sum 0))
     45               (dolist (v varlist sum) (incf sum (var-weight v)))))
     46           (vars-disjoint-p (v1 v2)
     47             (if (eq v1 v2)
     48               nil
     49               (if (memq v1 (var-binding-info v2))
     50                 nil
     51                 (if (memq v2 (var-binding-info v1))
     52                   nil
     53                   t)))))
     54    (dolist (iv inherited-vars)
     55      (dolist (v vars) (push iv (var-binding-info v)))
     56      (push iv vars))
     57    (setq vars (%sort-list-no-key
     58                ;;(delete-if #'(lambda (v) (eql (var-weight v) 0)) vars)
     59                (do* ((handle (cons nil vars))
     60                      (splice handle))
     61                     ((null (cdr splice)) (cdr handle))                 
     62                  (declare (dynamic-extent handle) (type cons handle splice))
     63                  (if (eql 0 (var-weight (%car (cdr splice))))
     64                    (rplacd splice (%cdr (cdr splice)))
     65                    (setq splice (cdr splice))))
     66                #'(lambda (v1 v2) (%i> (var-weight v1) (var-weight v2)))))
     67    ;; This isn't optimal.  It partitions all register-allocatable
     68    ;; variables into sets such that 1) no variable is a member of
     69    ;; more than one set and 2) all variables in a given set are
     70    ;; disjoint from each other A set might have exactly one member.
     71    ;; If a register is allocated for any member of a set, it's
     72    ;; allocated for all members of that set.
     73    (let* ((varsets nil))
     74      (do* ((all vars (cdr all)))
     75           ((null all))
     76        (let* ((var (car all)))
     77          (when (dolist (already varsets t)
     78                  (when (memq var (car already)) (return)))
     79            (let* ((varset (cons var nil)))
     80              (dolist (v (cdr all))
     81                (when (dolist (already varsets t)
     82                        (when (memq v (car already)) (return)))
     83                  (when (dolist (d varset t)
     84                          (unless (vars-disjoint-p v d) (return)))
     85                    (push v varset))))
     86              (let* ((weight (sum-weights varset)))
     87                (declare (fixnum weight))
     88                (if (>= weight 3)
     89                  (push (cons (nreverse varset) weight) varsets)))))))
     90      varsets)))
     92;;; Maybe globally allocate registers to symbols naming functions & variables,
     93;;; and to simple lexical variables.
     94(defun nx2-allocate-global-registers (fcells vcells all-vars inherited-vars nvrs)
     95  (if (null nvrs)
     96    (progn
     97      (dolist (c fcells) (%rplacd c nil))
     98      (dolist (c vcells) (%rplacd c nil))
     99      (values 0 nil))
     100    (let* ((maybe (nx2-partition-vars all-vars inherited-vars)))
     101      (dolist (c fcells)
     102        (if (>= (the fixnum (cdr c)) 3) (push c maybe)))
     103      (dolist (c vcells)
     104        (if (>= (the fixnum (cdr c)) 3) (push c maybe)))
     105      (do* ((things (%sort-list-no-key maybe #'nx2-bigger-cdr-than) (cdr things))
     106            (n 0 (1+ n))
     107            (registers nvrs)
     108            (regno (pop registers) (pop registers))
     109            (constant-alist ()))
     110           ((or (null things) (null regno))
     111            (dolist (cell fcells) (%rplacd cell nil))
     112            (dolist (cell vcells) (%rplacd cell nil))
     113            (values n constant-alist))
     114        (declare (list things)
     115                 (fixnum n regno))
     116        (let* ((thing (car things)))
     117          (if (or (memq thing fcells)
     118                  (memq thing vcells))
     119            (push (cons thing regno) constant-alist)
     120            (dolist (var (car thing))
     121              (setf (var-nvr var) regno))))))))
     123(defun nx2-assign-register-var (v)
     124  (var-nvr v))
     127(defun nx2-constant-form-p (form)
     128  (setq form (nx-untyped-form form))
     129  (if form
     130    (or (nx-null form)
     131        (nx-t form)
     132        (and (consp form)
     133             (or (eq (acode-operator form) (%nx1-operator immediate))
     134                 (eq (acode-operator form) (%nx1-operator fixnum))
     135                 (eq (acode-operator form) (%nx1-operator simple-function)))))))
     137(defun nx2-lexical-reference-p (form)
     138  (when (acode-p form)
     139    (let ((op (acode-operator (setq form (acode-unwrapped-form-value form)))))
     140      (when (or (eq op (%nx1-operator lexical-reference))
     141                (eq op (%nx1-operator inherited-arg)))
     142        (%cadr form)))))
     144;;; Returns true iff lexical variable VAR isn't setq'ed in FORM.
     145;;; Punts a lot ...
     146(defun nx2-var-not-set-by-form-p (var form)
     147  (let* ((bits (nx-var-bits var)))
     148    (or (not (%ilogbitp $vbitsetq bits))
     149        (nx2-setqed-var-not-set-by-form-p var form (logbitp $vbitclosed bits)))))
     151(defun nx2-setqed-var-not-set-by-form-p (var form &optional closed)
     152  (setq form (acode-unwrapped-form form))
     153  (or (atom form)
     154      (nx2-constant-form-p form)
     155      (nx2-lexical-reference-p form)
     156      (let ((op (acode-operator form))
     157            (subforms nil))
     158        (if (eq op (%nx1-operator setq-lexical))
     159          (and (neq var (cadr form))
     160               (nx2-setqed-var-not-set-by-form-p var (caddr form)))
     161          (and (or (not closed)
     162                   (logbitp operator-side-effect-free-bit op))
     163               (flet ((not-set-in-formlist (formlist)
     164                        (dolist (subform formlist t)
     165                          (unless (nx2-setqed-var-not-set-by-form-p var subform closed) (return)))))
     166                 (if
     167                   (cond ((%ilogbitp operator-acode-subforms-bit op) (setq subforms (%cdr form)))
     168                         ((%ilogbitp operator-acode-list-bit op) (setq subforms (cadr form))))
     169                   (not-set-in-formlist subforms)
     170                   (and (or (eq op (%nx1-operator call))
     171                            (eq op (%nx1-operator lexical-function-call)))
     172                        (nx2-setqed-var-not-set-by-form-p var (cadr form))
     173                        (setq subforms (caddr form))
     174                        (not-set-in-formlist (car subforms))
     175                        (not-set-in-formlist (cadr subforms))))))))))
Note: See TracChangeset for help on using the changeset viewer.