source: branches/1.2-devel/ccl/compiler/vreg.lisp @ 15278

Last change on this file since 15278 was 3198, checked in by gb, 14 years ago

rename s64-const -> s64const, since it's used now.

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