[Openmcl-cvs-notifications] r11386 - /trunk/source/compiler/nx2.lisp
gb at clozure.com
gb at clozure.com
Mon Nov 17 08:44:07 EST 2008
Author: gb
Date: Mon Nov 17 08:44:07 2008
New Revision: 11386
Log:
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.
Modified:
trunk/source/compiler/nx2.lisp
Modified: trunk/source/compiler/nx2.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/compiler/nx2.lisp (original)
+++ trunk/source/compiler/nx2.lisp Mon Nov 17 08:44:07 2008
@@ -19,3 +19,157 @@
(in-package "CCL")
=
=
+(defun nx2-bigger-cdr-than (x y)
+ (declare (cons x y))
+ (> (the fixnum (cdr x)) (the fixnum (cdr y))))
+
+;;; Return an unordered list of "varsets": each var in a varset can be
+;;; assigned a register and all vars in a varset can be assigned the
+;;; same register (e.g., no scope conflicts.)
+
+(defun nx2-partition-vars (vars inherited-vars)
+ (labels ((var-weight (var)
+ (let* ((bits (nx-var-bits var)))
+ (declare (fixnum bits))
+ (if (eql 0 (logand bits (logior
+ (ash 1 $vbitpuntable)
+ (ash -1 $vbitspecial)
+ (ash 1 $vbitnoreg))))
+ (if (eql (logior (ash 1 $vbitclosed) (ash 1 $vbitsetq))
+ (logand bits (logior (ash 1 $vbitclosed) (ash 1 =
$vbitsetq))))
+ 0
+ (var-refs var))
+ 0)))
+ (sum-weights (varlist) =
+ (let ((sum 0))
+ (dolist (v varlist sum) (incf sum (var-weight v)))))
+ (vars-disjoint-p (v1 v2)
+ (if (eq v1 v2)
+ nil
+ (if (memq v1 (var-binding-info v2))
+ nil
+ (if (memq v2 (var-binding-info v1))
+ nil
+ t)))))
+ (dolist (iv inherited-vars)
+ (dolist (v vars) (push iv (var-binding-info v)))
+ (push iv vars))
+ (setq vars (%sort-list-no-key
+ ;;(delete-if #'(lambda (v) (eql (var-weight v) 0)) vars) =
+ (do* ((handle (cons nil vars))
+ (splice handle))
+ ((null (cdr splice)) (cdr handle)) =
+ (declare (dynamic-extent handle) (type cons handle splic=
e))
+ (if (eql 0 (var-weight (%car (cdr splice))))
+ (rplacd splice (%cdr (cdr splice)))
+ (setq splice (cdr splice))))
+ #'(lambda (v1 v2) (%i> (var-weight v1) (var-weight v2)))))
+ ;; This isn't optimal. It partitions all register-allocatable
+ ;; variables into sets such that 1) no variable is a member of
+ ;; more than one set and 2) all variables in a given set are
+ ;; disjoint from each other A set might have exactly one member.
+ ;; If a register is allocated for any member of a set, it's
+ ;; allocated for all members of that set.
+ (let* ((varsets nil))
+ (do* ((all vars (cdr all)))
+ ((null all))
+ (let* ((var (car all)))
+ (when (dolist (already varsets t)
+ (when (memq var (car already)) (return)))
+ (let* ((varset (cons var nil)))
+ (dolist (v (cdr all))
+ (when (dolist (already varsets t)
+ (when (memq v (car already)) (return)))
+ (when (dolist (d varset t)
+ (unless (vars-disjoint-p v d) (return)))
+ (push v varset))))
+ (let* ((weight (sum-weights varset)))
+ (declare (fixnum weight))
+ (if (>=3D weight 3)
+ (push (cons (nreverse varset) weight) varsets)))))))
+ varsets)))
+
+;;; Maybe globally allocate registers to symbols naming functions & variab=
les,
+;;; and to simple lexical variables.
+(defun nx2-allocate-global-registers (fcells vcells all-vars inherited-var=
s nvrs)
+ (if (null nvrs)
+ (progn
+ (dolist (c fcells) (%rplacd c nil))
+ (dolist (c vcells) (%rplacd c nil))
+ (values 0 nil))
+ (let* ((maybe (nx2-partition-vars all-vars inherited-vars)))
+ (dolist (c fcells) =
+ (if (>=3D (the fixnum (cdr c)) 3) (push c maybe)))
+ (dolist (c vcells) =
+ (if (>=3D (the fixnum (cdr c)) 3) (push c maybe)))
+ (do* ((things (%sort-list-no-key maybe #'nx2-bigger-cdr-than) (cdr t=
hings))
+ (n 0 (1+ n))
+ (registers nvrs)
+ (regno (pop registers) (pop registers))
+ (constant-alist ()))
+ ((or (null things) (null regno))
+ (dolist (cell fcells) (%rplacd cell nil))
+ (dolist (cell vcells) (%rplacd cell nil))
+ (values n constant-alist))
+ (declare (list things)
+ (fixnum n regno))
+ (let* ((thing (car things)))
+ (if (or (memq thing fcells)
+ (memq thing vcells))
+ (push (cons thing regno) constant-alist)
+ (dolist (var (car thing))
+ (setf (var-nvr var) regno))))))))
+
+(defun nx2-assign-register-var (v)
+ (var-nvr v))
+
+
+(defun nx2-constant-form-p (form)
+ (setq form (nx-untyped-form form))
+ (if form
+ (or (nx-null form)
+ (nx-t form)
+ (and (consp form)
+ (or (eq (acode-operator form) (%nx1-operator immediate))
+ (eq (acode-operator form) (%nx1-operator fixnum))
+ (eq (acode-operator form) (%nx1-operator simple-function)=
))))))
+
+(defun nx2-lexical-reference-p (form)
+ (when (acode-p form)
+ (let ((op (acode-operator (setq form (acode-unwrapped-form-value form)=
))))
+ (when (or (eq op (%nx1-operator lexical-reference))
+ (eq op (%nx1-operator inherited-arg)))
+ (%cadr form)))))
+
+;;; Returns true iff lexical variable VAR isn't setq'ed in FORM.
+;;; Punts a lot ...
+(defun nx2-var-not-set-by-form-p (var form)
+ (let* ((bits (nx-var-bits var)))
+ (or (not (%ilogbitp $vbitsetq bits))
+ (nx2-setqed-var-not-set-by-form-p var form (logbitp $vbitclosed bi=
ts)))))
+
+(defun nx2-setqed-var-not-set-by-form-p (var form &optional closed)
+ (setq form (acode-unwrapped-form form))
+ (or (atom form)
+ (nx2-constant-form-p form)
+ (nx2-lexical-reference-p form)
+ (let ((op (acode-operator form))
+ (subforms nil))
+ (if (eq op (%nx1-operator setq-lexical))
+ (and (neq var (cadr form))
+ (nx2-setqed-var-not-set-by-form-p var (caddr form)))
+ (and (or (not closed)
+ (logbitp operator-side-effect-free-bit op))
+ (flet ((not-set-in-formlist (formlist)
+ (dolist (subform formlist t)
+ (unless (nx2-setqed-var-not-set-by-form-p var su=
bform closed) (return)))))
+ (if
+ (cond ((%ilogbitp operator-acode-subforms-bit op) (setq=
subforms (%cdr form)))
+ ((%ilogbitp operator-acode-list-bit op) (setq sub=
forms (cadr form))))
+ (not-set-in-formlist subforms)
+ (and (or (eq op (%nx1-operator call))
+ (eq op (%nx1-operator lexical-function-call)))
+ (nx2-setqed-var-not-set-by-form-p var (cadr form))
+ (setq subforms (caddr form))
+ (not-set-in-formlist (car subforms))
+ (not-set-in-formlist (cadr subforms))))))))))
More information about the Openmcl-cvs-notifications
mailing list