Changeset 11386 for trunk/source/compiler/nx2.lisp
 Timestamp:
 Nov 17, 2008, 1:44:07 PM (11 years ago)
 File:

 1 edited
Legend:
 Unmodified
 Added
 Removed

trunk/source/compiler/nx2.lisp
r11367 r11386 20 20 21 21 22 (defun nx2biggercdrthan (x y) 23 (declare (cons x y)) 24 (> (the fixnum (cdr x)) (the fixnum (cdr y)))) 25 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.) 29 30 (defun nx2partitionvars (vars inheritedvars) 31 (labels ((varweight (var) 32 (let* ((bits (nxvarbits 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 (varrefs var)) 42 0))) 43 (sumweights (varlist) 44 (let ((sum 0)) 45 (dolist (v varlist sum) (incf sum (varweight v))))) 46 (varsdisjointp (v1 v2) 47 (if (eq v1 v2) 48 nil 49 (if (memq v1 (varbindinginfo v2)) 50 nil 51 (if (memq v2 (varbindinginfo v1)) 52 nil 53 t))))) 54 (dolist (iv inheritedvars) 55 (dolist (v vars) (push iv (varbindinginfo v))) 56 (push iv vars)) 57 (setq vars (%sortlistnokey 58 ;;(deleteif #'(lambda (v) (eql (varweight v) 0)) vars) 59 (do* ((handle (cons nil vars)) 60 (splice handle)) 61 ((null (cdr splice)) (cdr handle)) 62 (declare (dynamicextent handle) (type cons handle splice)) 63 (if (eql 0 (varweight (%car (cdr splice)))) 64 (rplacd splice (%cdr (cdr splice))) 65 (setq splice (cdr splice)))) 66 #'(lambda (v1 v2) (%i> (varweight v1) (varweight v2))))) 67 ;; This isn't optimal. It partitions all registerallocatable 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 (varsdisjointp v d) (return))) 85 (push v varset)))) 86 (let* ((weight (sumweights varset))) 87 (declare (fixnum weight)) 88 (if (>= weight 3) 89 (push (cons (nreverse varset) weight) varsets))))))) 90 varsets))) 91 92 ;;; Maybe globally allocate registers to symbols naming functions & variables, 93 ;;; and to simple lexical variables. 94 (defun nx2allocateglobalregisters (fcells vcells allvars inheritedvars 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 (nx2partitionvars allvars inheritedvars))) 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 (%sortlistnokey maybe #'nx2biggercdrthan) (cdr things)) 106 (n 0 (1+ n)) 107 (registers nvrs) 108 (regno (pop registers) (pop registers)) 109 (constantalist ())) 110 ((or (null things) (null regno)) 111 (dolist (cell fcells) (%rplacd cell nil)) 112 (dolist (cell vcells) (%rplacd cell nil)) 113 (values n constantalist)) 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) constantalist) 120 (dolist (var (car thing)) 121 (setf (varnvr var) regno)))))))) 122 123 (defun nx2assignregistervar (v) 124 (varnvr v)) 125 126 127 (defun nx2constantformp (form) 128 (setq form (nxuntypedform form)) 129 (if form 130 (or (nxnull form) 131 (nxt form) 132 (and (consp form) 133 (or (eq (acodeoperator form) (%nx1operator immediate)) 134 (eq (acodeoperator form) (%nx1operator fixnum)) 135 (eq (acodeoperator form) (%nx1operator simplefunction))))))) 136 137 (defun nx2lexicalreferencep (form) 138 (when (acodep form) 139 (let ((op (acodeoperator (setq form (acodeunwrappedformvalue form))))) 140 (when (or (eq op (%nx1operator lexicalreference)) 141 (eq op (%nx1operator inheritedarg))) 142 (%cadr form))))) 143 144 ;;; Returns true iff lexical variable VAR isn't setq'ed in FORM. 145 ;;; Punts a lot ... 146 (defun nx2varnotsetbyformp (var form) 147 (let* ((bits (nxvarbits var))) 148 (or (not (%ilogbitp $vbitsetq bits)) 149 (nx2setqedvarnotsetbyformp var form (logbitp $vbitclosed bits))))) 150 151 (defun nx2setqedvarnotsetbyformp (var form &optional closed) 152 (setq form (acodeunwrappedform form)) 153 (or (atom form) 154 (nx2constantformp form) 155 (nx2lexicalreferencep form) 156 (let ((op (acodeoperator form)) 157 (subforms nil)) 158 (if (eq op (%nx1operator setqlexical)) 159 (and (neq var (cadr form)) 160 (nx2setqedvarnotsetbyformp var (caddr form))) 161 (and (or (not closed) 162 (logbitp operatorsideeffectfreebit op)) 163 (flet ((notsetinformlist (formlist) 164 (dolist (subform formlist t) 165 (unless (nx2setqedvarnotsetbyformp var subform closed) (return))))) 166 (if 167 (cond ((%ilogbitp operatoracodesubformsbit op) (setq subforms (%cdr form))) 168 ((%ilogbitp operatoracodelistbit op) (setq subforms (cadr form)))) 169 (notsetinformlist subforms) 170 (and (or (eq op (%nx1operator call)) 171 (eq op (%nx1operator lexicalfunctioncall))) 172 (nx2setqedvarnotsetbyformp var (cadr form)) 173 (setq subforms (caddr form)) 174 (notsetinformlist (car subforms)) 175 (notsetinformlist (cadr subforms))))))))))
Note: See TracChangeset
for help on using the changeset viewer.