source: trunk/source/compiler/nx2.lisp @ 11386

Last change on this file since 11386 was 11386, checked in by gb, 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.

File size: 7.4 KB
1;;;-*-Mode: LISP; Package: ccl -*-
3;;;   Copyright (C) 2008, Clozure Associates and contributors
4;;;   This file is part of OpenMCL. 
6;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with OpenMCL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
12;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
14;;;   The LLGPL is also available online at
17;;; Shared compiler backend utilities and infrastructure.
19(in-package "CCL")
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 TracBrowser for help on using the repository browser.