source: branches/qres/ccl/compiler/vreg.lisp @ 15278

Last change on this file since 15278 was 13070, checked in by gz, 10 years ago

r13066, r13067 from trunk: copyrights etc

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 11.5 KB
Line 
1;;;-*- Mode: Lisp; Package: CCL -*-
2;;;
3;;;   Copyright (C) 2009 Clozure Associates
4;;;   Copyright (C) 1994-2001 Digitool, Inc
5;;;   This file is part of Clozure CL. 
6;;;
7;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
8;;;   License , known as the LLGPL and distributed with Clozure CL as the
9;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
10;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
11;;;   conflict, the preamble takes precedence. 
12;;;
13;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
14;;;
15;;;   The LLGPL is also available online at
16;;;   http://opensource.franz.com/preamble.html
17
18
19(cl:eval-when (:compile-toplevel :load-toplevel :execute)
20  (ccl::require "ARCH"))
21
22(in-package "CCL")
23
24(defvar *logical-register-counter* -1)
25
26(def-standard-initial-binding *lreg-freelist* (%cons-pool))
27
28(defstruct (lreg
29            (:print-function print-lreg)
30            (:constructor %make-lreg))
31  (value nil :type t)                   ; physical reg or frame address or ...
32  (id (incf (the fixnum *logical-register-counter*)) :type fixnum)                   ; for printing
33  (class 0 :type fixnum)                ; target storage class: GPR, FPR, CRF ...
34  (mode 0 :type fixnum)                 ; mode (:u8, :address, etc)
35  (type 0 :type fixnum)                 ; type
36  (defs () :type list)                  ; list of vinsns which assign to this reg
37  (refs () :type list)                  ; list of vinsns which reference this vreg
38  (conflicts () :type list)             ; other lregs which can't map to the same physical reg
39  (wired t :type boolean)               ; when true, targeted value must be preserved.
40  (info nil)                            ; Whatever; used in printing.
41)
42
43(defun free-lreg (l)
44  (without-interrupts                   ; explicitly
45   (let* ((p *lreg-freelist*))
46     (setf (lreg-value l) (pool.data p)
47           (pool.data p) l)
48     nil)))
49
50(defun alloc-lreg ()
51  (let* ((p *lreg-freelist*))
52    (without-interrupts 
53     (let* ((l (pool.data p)))
54       (when l 
55         (setf (pool.data p) (lreg-value l))
56         (setf (lreg-defs l) nil
57               (lreg-refs l) nil
58               (lreg-conflicts l) nil
59               (lreg-id l) (incf *logical-register-counter*)
60               (lreg-wired l) t)
61         l)))))
62
63(defun make-lreg (value class mode type wired)
64  (let* ((l (alloc-lreg)))
65    (cond (l
66           (setf (lreg-value l) value
67                 (lreg-class l) class
68                 (lreg-type l) type
69                 (lreg-mode l) mode
70                 (lreg-wired l) wired)           
71           l)
72          (t (%make-lreg :value value :class class :type type :mode mode :wired wired)))))
73 
74
75(defun print-lreg (l s d)
76  (declare (ignore d))
77  (print-unreadable-object (l s :type t)
78    (format s "~d" (lreg-id l))
79    (let* ((value (lreg-value l))
80           (class (lreg-class l))
81           (mode-name (if (eq class hard-reg-class-gpr)
82                        (car (rassoc (lreg-mode l) *mode-name-value-alist*)))))
83      (format s " ~a "
84              (case class
85                (#.hard-reg-class-fpr "FPR")
86                (#.hard-reg-class-gpr "GPR")
87                (#.hard-reg-class-crf "CRF")
88                (t  (format nil "class ~d" class))))
89      (if value
90        (format s (if (lreg-wired l) "[~s]" "{~s}") value)
91        (progn
92          (if mode-name
93            (format s "{?/~a}" mode-name)
94            (format s "{?}")))))))
95
96(def-standard-initial-binding *lcell-freelist* (%cons-pool))
97(defvar *next-lcell-id* -1)
98
99(defstruct (lcell 
100            (:print-function print-lcell)
101            (:constructor %make-lcell (kind parent width attributes info)))
102  (kind :node)         ; for printing
103  (id (incf (the fixnum *next-lcell-id*)) :type fixnum)                          ;
104  (parent nil)                          ; backpointer to unique parent
105  (children nil)                        ; list of children
106  (width 4)                             ; size in bytes or NIL if deleted
107  (offset nil)                          ; sum of ancestor's widths or 0, NIL if deleted
108  (refs nil)                            ; vinsns which load/store into this cell
109  (attributes 0 :type fixnum)           ; bitmask
110  (info nil))                           ; whatever
111
112(defun print-lcell (c s d)
113  (declare (ignore d))
114  (print-unreadable-object (c s :type t)
115    (format s "~d" (lcell-id c))
116    (let* ((offset (lcell-offset c)))
117      (when offset
118        (format s "@#x~x" offset)))))
119
120(defun free-lcell (c)
121  (without-interrupts                   ; explicitly
122   (let* ((p *lcell-freelist*))
123     (setf (lcell-kind c) (pool.data p)
124           (pool.data p) c)
125     nil)))
126
127(defun alloc-lcell (kind parent width attributes info)
128  (let* ((p *lcell-freelist*))
129    (without-interrupts 
130     (let* ((c (pool.data p)))
131       (when c 
132         (setf (pool.data p) (lcell-kind c))
133         (setf (lcell-kind c) kind
134               (lcell-parent c) parent
135               (lcell-width c) width
136               (lcell-attributes c) (the fixnum attributes)
137               (lcell-info c) info
138               (lcell-offset c) nil
139               (lcell-refs c) nil
140               (lcell-children c) nil
141               (lcell-id c) (incf *next-lcell-id*))
142         c)))))
143
144(defun make-lcell (kind parent width attributes info)
145  (let* ((c (or (alloc-lcell kind parent width attributes info)
146                (%make-lcell kind parent width attributes info))))
147    (when parent (push c (lcell-children parent)))
148    c))
149 
150; Recursively calculate, but don't cache (or pay attention to previously calculated offsets)
151(defun calc-lcell-offset (c)
152  (if c
153    (let* ((p (lcell-parent c)))
154      (if (null p)
155        0
156        (+ (calc-lcell-offset p) (or (lcell-width p) 0))))
157    0))
158
159; A cell's "depth" is its offset + its width
160(defun calc-lcell-depth (c)
161  (if c 
162    (+ (calc-lcell-offset c) (or (lcell-width c) 0))
163    0))
164
165; I don't know why "compute" means "memoize", but it does.
166(defun compute-lcell-offset (c)
167  (or (lcell-offset c)
168      (setf (lcell-offset c)
169            (let* ((p (lcell-parent c)))
170              (if (null p)
171                0
172                (+ (compute-lcell-offset p) (or (lcell-width p) 0)))))))
173
174(defun compute-lcell-depth (c)
175  (if c
176    (+ (compute-lcell-offset c) (or (lcell-width c) 0))
177    0))
178
179
180
181                   
182
183(defparameter *spec-class-storage-class-alist*
184  `((:lisp . ,arch::storage-class-lisp)
185    (:imm . ,arch::storage-class-imm)
186    (:wordptr . ,arch::storage-class-wordptr)
187    (:u8 . ,arch::storage-class-u8)
188    (:s8 . ,arch::storage-class-s8)
189    (:u16 . ,arch::storage-class-u16)
190    (:s16 . ,arch::storage-class-s16)
191    (:u32 . ,arch::storage-class-u32)
192    (:s32 . ,arch::storage-class-s32)
193    (:u64 . ,arch::storage-class-u64)
194    (:s64 . ,arch::storage-class-s64)
195    (:address . ,arch::storage-class-address)
196    (:single-float . ,arch::storage-class-single-float)
197    (:double-float . ,arch::storage-class-double-float)
198    (:pc . ,arch::storage-class-pc)
199    (:locative . ,arch::storage-class-locative)
200    (:crf . ,arch::storage-class-crf)
201    (:crbit . ,arch::storage-class-crbit)
202    (:crfbit . ,arch::storage-class-crfbit)   
203    (t . nil)))
204   
205(defun spec-class->storage-class (class-name)
206  (or (cdr (assoc class-name *spec-class-storage-class-alist* :test #'eq))
207      (error "Unknown storage-class specifier: ~s" class-name)))
208   
209(defun vreg-ok-for-storage-class (vreg sclass)
210  (declare (ignore vreg sclass))
211  t)
212
213
214
215(defparameter *vreg-specifier-constant-constraints*
216  `((:u8const . ,(specifier-type '(unsigned-byte 8)))
217    (:u16const . ,(specifier-type '(unsigned-byte 16)))
218    (:u32const . ,(specifier-type '(unsigned-byte 32)))
219    (:u64const . ,(specifier-type '(unsigned-byte 64)))
220    (:s8const . ,(specifier-type '(signed-byte 8)))
221    (:s16const . ,(specifier-type '(signed-byte 16)))
222    (:s32const . ,(specifier-type '(signed-byte 32)))
223    (:s64const . ,(specifier-type '(signed-byte 64)))
224    (:lcell . ,(specifier-type 'lcell))))
225
226(defun match-vreg-value (vreg value)
227  (declare (ignorable vreg value))      ; at least until this -does- something.
228  ;(format t "~&vreg = ~s, value = ~s" vreg value)
229  t)
230
231(defun match-vreg-constraint (constraint vreg template valvect n)
232  (let* ((res&args (vinsn-template-results&args template))
233         (target (cadr constraint))
234         (matchspec (assq target res&args))
235         (matchpos (if matchspec (position matchspec res&args))))
236    (unless matchpos
237      (warn "Unknown template vreg name ~s in constraint ~s." target constraint))
238    (unless (< matchpos n)
239      (warn "Forward-referenced vreg name ~s in constraint ~s." target constraint))
240    (let* ((target-val (svref valvect matchpos)))
241      (unless (ecase (car constraint) (:eq (eq vreg target-val)) (:ne (neq vreg target-val)))
242        (warn "~& use of vreg ~s conflicts with value already assigned ~
243               to ~s wrt constraint ~s ." vreg (car matchspec) constraint)))))
244
245(defun note-vinsn-sets-gpr (vinsn gpr)
246  (setf (vinsn-gprs-set vinsn) (logior (vinsn-gprs-set vinsn) (ash 1 gpr))))
247
248(defun note-vinsn-sets-fpr (vinsn fpr)
249  (setf (vinsn-fprs-set vinsn) (logior (vinsn-fprs-set vinsn) (ash 1 fpr))))
250
251(defun match-vreg (vreg spec vinsn vp n)
252  (declare (fixnum n))
253  (let* ((class (if (atom spec) spec (car spec)))
254         (value (if (atom spec) nil (cadr spec)))
255         (template (vinsn-template vinsn))
256         (result-p (< n (the fixnum (length (vinsn-template-result-vreg-specs template))))))
257    (let* ((spec-class (assoc class *spec-class-storage-class-alist* :test #'eq)))
258      (if spec-class
259        (let* ((vreg-value (hard-regspec-value vreg)))
260          (if (typep vreg 'fixnum) 
261            (setq vreg vreg-value)
262            (if (typep vreg 'lreg)
263              (if result-p
264                (pushnew vinsn (lreg-defs vreg))
265                (pushnew vinsn (lreg-refs vreg)))
266              (error "Bad vreg: ~s" vreg)))
267          (when vreg-value
268            (case class
269              (:crf (use-crf-temp vreg-value))
270              ((:u8 :s8 :u16 :s16 :u32 :s32 :u64 :s64 :address)
271               (when result-p (note-vinsn-sets-gpr vinsn vreg-value))
272               (use-imm-temp vreg-value))
273              ((:single-float :double-float)
274               (use-fp-temp vreg-value)
275               (when result-p (note-vinsn-sets-fpr vinsn vreg-value)))
276              ((:imm t)
277               (when result-p (note-vinsn-sets-gpr vinsn vreg-value))
278               (if (logbitp vreg-value *backend-imm-temps*)
279                 (use-imm-temp vreg-value)
280                 (use-node-temp vreg-value)))
281              (:lisp
282               (use-node-temp vreg-value)
283               (when result-p (note-vinsn-sets-gpr vinsn vreg-value)))))
284          (unless (or (eq class 't) (vreg-ok-for-storage-class vreg class))
285            (warn "~s was expected to have storage class matching specifier ~s" vreg class))
286          (when value
287            (if (atom value)
288              (match-vreg-value vreg-value value)
289              (match-vreg-constraint value vreg-value template vp n))))
290        (if (eq class :label)
291          (progn
292            (unless (typep vreg 'vinsn-label)
293              (error "Label expected, found ~s." vreg))
294            (push vinsn (vinsn-label-refs vreg)))
295          (let* ((ctype (cdr (assoc class *vreg-specifier-constant-constraints* :test #'eq))))
296            (unless ctype (error "Unknown vreg constraint : ~s ." class))
297            (unless (ctypep vreg ctype)
298              (error "~S : value doesn't match constraint ~s in template for ~s ." vreg class (vinsn-template-name template)))))))
299    (when (typep vreg 'lcell)
300      (pushnew vinsn (lcell-refs vreg)))
301    vreg))
302
303(defun note-lreg-conflict (lreg conflicts-with)
304  (and (typep lreg 'lreg)
305       (typep conflicts-with 'lreg)
306       (pushnew conflicts-with (lreg-conflicts lreg))
307       (pushnew lreg (lreg-conflicts conflicts-with))
308       t))
309
310(ccl::provide "VREG")
Note: See TracBrowser for help on using the repository browser.