source: trunk/ccl/compiler/backend.lisp @ 5345

Last change on this file since 5345 was 5345, checked in by gb, 13 years ago

It makes no sense to use the vinsn macros <- and inside ENSURING-NODE-TARGET,
so make it check for that.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 15.8 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(in-package "CCL")
17
18(eval-when (:compile-toplevel :execute)
19  (require "ARCH"))
20
21(defconstant platform-word-size-mask 64)
22(defconstant platform-os-mask 7)
23(defconstant platform-cpu-mask (logandc2 (1- platform-word-size-mask)
24                                         platform-os-mask))
25(defconstant platform-word-size-32 0)
26(defconstant platform-word-size-64 64)
27(defconstant platform-cpu-ppc (ash 0 3))
28(defconstant platform-cpu-sparc (ash 1 3))
29(defconstant platform-cpu-x86 (ash 2 3))
30(defconstant platform-os-vxworks 0)
31(defconstant platform-os-linux 1)
32(defconstant platform-os-solaris 2)
33(defconstant platform-os-darwin 3)
34(defconstant platform-os-freebsd 4)
35
36(defstruct backend
37  (name :a :type keyword)
38  (num-arg-regs 3 :type fixnum)    ; number of args passed in registers
39  (num-nvrs 0 :type fixnum)        ; number of callee-save node regs
40  (num-node-regs 0 :type fixnum)     ; number of node temps/arg regs
41  (lap-opcodes #() :type simple-vector)
42  (lookup-opcode #'false :type (or symbol function))
43  (lookup-macro #'false :type (or symbol function))
44  (p2-dispatch #() :type simple-vector)
45  (p2-compile 'error :type (or symbol function))
46  (p2-vinsn-templates (error "Missing arg") :type hash-table)
47  (p2-template-hash-name 'bogus :type symbol)
48  (target-specific-features () :type list)
49  (target-fasl-pathname "" :type (or string pathname))
50  (target-platform 0 :type fixnum)
51  (target-os ())
52  (target-arch-name nil :type symbol)
53  (target-foreign-type-data nil :type (or null foreign-type-data))
54  (lap-macros nil)
55  (target-arch nil)
56  (define-vinsn nil)
57  (platform-syscall-mask 0)
58  (define-callback nil)
59  (defcallback-body nil)
60  (lisp-context-register 0))
61
62(defmethod print-object ((b backend) s)
63  (print-unreadable-object (b s :type t :identity t)
64    (format s "~A" (backend-name b))))
65
66
67
68(defparameter *backend-node-regs* 0)
69(defparameter *backend-node-temps* 0)
70(defparameter *available-backend-node-temps* 0)
71(defparameter *backend-imm-temps* 0)
72(defparameter *available-backend-imm-temps* 0)
73(defparameter *backend-fp-temps* 0)
74(defparameter *available-backend-fp-temps* 0)
75(defparameter *backend-crf-temps* 0)
76(defparameter *available-backend-crf-temps* 0)
77(defparameter *backend-allocate-high-node-temps* nil)
78
79(defparameter *mode-name-value-alist*
80  '((:lisp . 0)
81    (:u32 . 1)
82    (:s32 . 2)
83    (:u16 . 3)
84    (:s16 . 4)
85    (:u8 . 5)
86    (:s8 . 6)
87    (:address . 7)
88    (:u64 . 8)
89    (:s64 . 9)))
90
91(defun gpr-mode-name-value (name)
92  (if (eq name :natural)
93    (setq name
94          (target-word-size-case
95           (32 :u32)
96           (64 :u64)))
97    (if (eq name :signed-natural)
98      (setq name
99          (target-word-size-case
100           (32 :s32)
101           (64 :s64)))))
102  (or (cdr (assq name *mode-name-value-alist*))
103      (error "Unknown gpr mode name: ~s" name)))
104
105(defun use-node-temp (n)
106  (declare (fixnum n))
107  (if (logbitp n *available-backend-node-temps*)
108    (setq *available-backend-node-temps*
109          (logand *available-backend-node-temps* (lognot (ash 1 n)))))
110  n)
111
112(defun node-reg-p (reg)
113  (and (= (hard-regspec-class reg) hard-reg-class-gpr)
114       (= (get-regspec-mode reg) hard-reg-class-gpr-mode-node)))
115
116(defun node-reg-value (reg)
117  (if (node-reg-p reg)
118    (hard-regspec-value reg)))
119
120; if EA is a register-spec of the indicated class, return
121; the register #.
122(defun backend-ea-physical-reg (ea class)
123  (declare (fixnum class))
124  (and ea
125       (register-spec-p ea)
126       (= (hard-regspec-class ea) class)
127       (hard-regspec-value ea)))
128
129(defun backend-crf-p (vreg)
130  (backend-ea-physical-reg vreg hard-reg-class-crf))
131
132(defun available-node-temp (mask)
133  (if *backend-allocate-high-node-temps*
134    (do* ((bit 31 (1- bit)))
135         ((< bit 0) (error "Bug: ran out of node temp registers."))
136      (when (logbitp bit mask)
137        (return bit)))   
138    (dotimes (bit 32 (error "Bug: ran out of node temp registers."))
139      (when (logbitp bit mask)
140        (return bit)))))
141
142(defun ensure-node-target (reg)
143  (if (node-reg-p reg)
144    reg
145    (available-node-temp *available-backend-node-temps*)))
146
147(defun select-node-temp ()
148  (let* ((mask *available-backend-node-temps*))
149    (if *backend-allocate-high-node-temps*
150      (do* ((bit 31 (1- bit)))
151           ((< bit 0) (error "Bug: ran out of node temp registers."))
152        (when (logbitp bit mask)
153          (setq *available-backend-node-temps* (bitclr bit mask))
154          (return bit)))
155      (dotimes (bit 32 (error "Bug: ran out of node temp registers."))
156        (when (logbitp bit mask)
157          (setq *available-backend-node-temps* (bitclr bit mask))
158          (return bit))))))
159
160(defun available-imm-temp (mask &optional (mode-name :natural))
161  (dotimes (bit 32 (error "Bug: ran out of imm temp registers."))
162    (when (logbitp bit mask)
163      (return (set-regspec-mode bit (gpr-mode-name-value mode-name))))))
164
165(defun use-imm-temp (n)
166  (declare (fixnum n))
167  (setq *available-backend-imm-temps* (logand *available-backend-imm-temps* (lognot (ash 1 n))))
168  n)
169
170
171(defun select-imm-temp (&optional (mode-name :u32))
172  (let* ((mask *available-backend-imm-temps*))
173    (dotimes (bit 32 (error "Bug: ran out of imm temp registers."))
174      (when (logbitp bit mask)
175        (setq *available-backend-imm-temps* (bitclr bit mask))
176        (return (set-regspec-mode bit (gpr-mode-name-value mode-name)))))))
177
178;;; Condition-register fields are PPC-specific, but we might as well have
179;;; a portable interface to them.
180
181(defun use-crf-temp (n)
182  (declare (fixnum n))
183  (setq *available-backend-crf-temps* (logand *available-backend-crf-temps* (lognot (ash 1 (ash n -2)))))
184  n)
185
186(defun select-crf-temp ()
187  (let* ((mask *available-backend-crf-temps*))
188    (dotimes (bit 8 (error "Bug: ran out of CR fields."))
189      (declare (fixnum bit))
190      (when (logbitp bit mask)
191        (setq *available-backend-crf-temps* (bitclr bit mask))
192        (return (make-hard-crf-reg (the fixnum (ash bit 2))))))))
193
194(defun available-crf-temp (mask)
195  (dotimes (bit 8 (error "Bug: ran out of CR fields."))
196    (when (logbitp bit mask)
197      (return (make-hard-crf-reg (the fixnum (ash bit 2)))))))
198
199(defun use-fp-temp (n)
200    (setq *available-backend-fp-temps* (logand *available-backend-fp-temps* (lognot (ash 1 n))))
201    n)
202
203(defun available-fp-temp (mask &optional (mode-name :double-float))
204  (dotimes (bit (integer-length mask) (error "Bug: ran out of node fp registers."))
205    (when (logbitp bit mask)
206      (let* ((mode (if (eq mode-name :double-float) 
207                     hard-reg-class-fpr-mode-double
208                     hard-reg-class-fpr-mode-single)))
209        (return (make-hard-fp-reg bit mode))))))
210
211(defparameter *backend-all-lregs* ())
212(defun note-logical-register (l)
213  (push l *backend-all-lregs*)
214  l)
215
216(defun free-logical-registers ()
217  (without-interrupts
218   (let* ((prev (pool.data *lreg-freelist*)))
219     (dolist (r *backend-all-lregs*)
220       (setf (lreg-value r) prev
221             prev r))
222     (setf (pool.data *lreg-freelist*) prev)
223     (setq *backend-all-lregs* nil))))
224
225
226(defun make-unwired-lreg (value &key 
227                                (class (if value (hard-regspec-class value) 0))
228                                (mode (if value (get-regspec-mode value) 0))
229                                (type (if value (get-node-regspec-type-modes value) 0)))
230  (note-logical-register (make-lreg (if value (hard-regspec-value value)) class mode type nil)))
231
232;;; Make an lreg with the same class, mode, & type as the prototype.
233(defun make-unwired-lreg-like (proto)
234  (make-unwired-lreg nil
235                     :class (hard-regspec-class proto)
236                     :mode (get-regspec-mode proto)
237                     :type (get-node-regspec-type-modes proto)))
238 
239(defun make-wired-lreg (value &key 
240                              (class (hard-regspec-class value))
241                              (mode (get-regspec-mode value))
242                              (type (get-node-regspec-type-modes value)))
243  (note-logical-register (make-lreg (hard-regspec-value value) class mode type t)))
244
245(defvar *backend-immediates*)
246
247(defun backend-new-immediate (imm)
248  (vector-push-extend imm *backend-immediates*))
249
250(defun backend-immediate-index (imm)
251  (or (position imm *backend-immediates*)
252      (backend-new-immediate imm)))
253
254(defvar *backend-vinsns*)
255
256(defvar *backend-labels*)
257
258(defun backend-gen-label (seg labelnum)
259  (append-dll-node (aref *backend-labels* labelnum) seg)
260  labelnum)
261
262(defconstant $backend-compound-branch-target-bit 18)
263(defconstant $backend-compound-branch-target-mask (ash 1 $backend-compound-branch-target-bit))
264
265(defconstant $backend-mvpass-bit 19)
266(defconstant $backend-mvpass-mask (ash 1 $backend-mvpass-bit))
267
268(defconstant $backend-return (- (ash 1 18) 1))
269(defconstant $backend-mvpass (- (ash 1 18) 2))
270
271(defconstant $backend-compound-branch-false-byte (byte 18 0))
272(defconstant $backend-compound-branch-true-byte (byte 18 20))
273
274
275(defun backend-get-next-label ()
276  (let* ((lnum (length *backend-labels*)))
277    (if (>= lnum $backend-mvpass)
278      (compiler-function-overflow)
279      (vector-push-extend (make-vinsn-label lnum) *backend-labels*))))
280
281
282;;; Loop through all labels in *backend-labels*; if the label has been
283;;; emitted, remove it from vinsns and return it to the
284;;; *vinsn-label-freelist*.  "vinsns" should then contain nothing but
285;;; ... vinsns
286
287(defun backend-remove-labels ()
288  (let* ((labels *backend-labels*)
289         (freelist *vinsn-label-freelist*))
290    (dotimes (i (the fixnum (length labels)))
291      (let* ((lab (aref labels i)))
292        (if lab
293          (if (vinsn-label-succ lab)
294            (remove-and-free-dll-node lab freelist)
295            (free-dll-node lab freelist)))))))
296
297(defun backend-copy-label (from to)
298  (let* ((from-lab (aref *backend-labels* from))
299         (to-lab (aref *backend-labels* to)))
300    (when (null (vinsn-label-succ from-lab))
301      (error "Copy label: not defined yet!"))
302    (backend-merge-labels from-lab to-lab)
303    (setf (aref *backend-labels* to) from-lab)))
304
305(defun backend-merge-labels (from-lab to-lab)
306  (let* ((to-refs (vinsn-label-refs to-lab)))
307    (when to-refs
308      ;; Make all extant refs to TO-LAB refer to FROM-LAB
309      (setf (vinsn-label-refs to-lab) nil)
310      (dolist (vinsn to-refs)
311        (push vinsn (vinsn-label-refs from-lab))
312        (let* ((vp (vinsn-variable-parts vinsn)))
313          (declare (simple-vector vp))
314          (dotimes (i (the fixnum (length vp)))
315            (when (eq to-lab (svref vp i))
316              (setf (svref vp i) from-lab))))))))
317
318;;; For now, the register-spec must be
319;;; a) non-nil
320;;; c) of an expected class.
321;;; Return the class and value.
322(defun regspec-class-and-value (regspec expected)
323  (declare (fixnum expected))
324  (let* ((class (hard-regspec-class regspec)))
325    (declare (type (unsigned-byte 8 class)))
326    (if (logbitp class expected)
327      (values class (if (typep regspec 'lreg)
328                      regspec
329                      (hard-regspec-value regspec)))
330      (error "bug: Register spec class (~d) is not one  of ~s." class expected))))
331
332(defmacro with-node-temps ((&rest reserved) (&rest nodevars) &body body)
333  `(let* ((*available-backend-node-temps* (logand *available-backend-node-temps* (lognot (logior ,@(mapcar #'(lambda (r) `(ash 1 (hard-regspec-value ,r))) reserved)))))
334          ,@(mapcar #'(lambda (v) `(,v (make-unwired-lreg (select-node-temp)))) nodevars))
335     ,@body))
336
337(defmacro with-imm-temps ((&rest reserved) (&rest immvars) &body body)
338  `(let* ((*available-backend-imm-temps* (logand *available-backend-imm-temps* (lognot (logior ,@(mapcar #'(lambda (r) `(ash 1 (hard-regspec-value ,r))) reserved)))))
339          ,@(mapcar #'(lambda (v) (let* ((var (if (atom v) v (car v)))
340                                         (mode-name (if (atom v) :u32 (cadr v)))) 
341                                    `(,var (select-imm-temp ',mode-name)))) immvars))
342          ,@body))
343
344
345(defmacro with-crf-target ((&rest reserved) name &body body)
346  `(let* ((,name (make-unwired-lreg 
347                  (available-crf-temp 
348                   (logand *available-backend-crf-temps* 
349                           (lognot (logior ,@(mapcar #'(lambda (r) `(ash 1 (ash (hard-regspec-value ,r) -2))) reserved))))))))
350     ,@body))
351
352(defmacro regspec-crf-gpr-case ((regspec regval) crf-form gpr-form)
353  (let* ((class (gensym)))
354    `(if ,regspec
355       (multiple-value-bind (,class ,regval) (regspec-class-and-value ,regspec hard-reg-class-gpr-crf-mask)
356         (declare (fixnum ,class ,regval))
357         (if (= ,class hard-reg-class-crf)
358           ,crf-form
359           ,gpr-form)))))
360
361;;; The NODE case may need to use ENSURING-NODE-TARGET.
362(defmacro unboxed-other-case ((regspec &rest mode-names)
363                              unboxed-case other-case)
364  `(if (and ,regspec
365        (= (hard-regspec-class ,regspec) hard-reg-class-gpr)
366        (logbitp  (get-regspec-mode ,regspec)
367         (logior ,@(mapcar #'(lambda (x) (ash 1 (gpr-mode-name-value x)))
368                           mode-names))))
369    ,unboxed-case
370    ,other-case))
371
372
373
374
375;;; Choose an immediate register (for targeting), but don't "reserve" it.
376(defmacro with-imm-target ((&rest reserved) spec &body body)
377  (let* ((name (if (atom spec) spec (car spec)))
378         (mode-name (if (atom spec) :natural (cadr spec))))
379    `(let* ((,name (make-unwired-lreg
380                    (available-imm-temp
381                     (logand
382                      *available-backend-imm-temps* 
383                      (lognot (logior ,@(mapcar
384                                         #'(lambda (r)
385                                             `(ash 1 (hard-regspec-value ,r)))
386                                         reserved))))
387                     ',mode-name))))
388       ,@body)))
389
390(defmacro with-node-target ((&rest reserved) name &body body)
391  `(let* ((,name (make-unwired-lreg
392                  (available-node-temp
393                   (logand
394                    *available-backend-node-temps* 
395                    (lognot (logior ,@(mapcar
396                                       #'(lambda (r)
397                                           `(ash 1 (hard-regspec-value ,r)))
398                                       reserved))))))))
399    ,@body))
400
401
402
403
404(defmacro with-fp-target ((&rest reserved) spec &body body)
405  (let* ((name (if (atom spec) spec (car spec)))
406         (mode-name (if (atom spec) :double-float (cadr spec))))
407    `(let* ((,name
408             (make-unwired-lreg
409              (available-fp-temp
410               (logand *available-backend-fp-temps*
411                       (lognot (logior
412                                ,@(mapcar
413                                   #'(lambda (r) 
414                                       `(ash 1 (hard-regspec-value ,r)))
415                                   reserved))))
416               ',mode-name))))
417       ,@body)))
418
419(defmacro ensuring-node-target ((target-var vreg-var) &body body)
420  `(let* ((*available-backend-node-temps* *available-backend-node-temps*)
421          (,target-var (ensure-node-target ,vreg-var)))
422    (declare (special *available-backend-node-temps*))
423    (macrolet ((<- (&whole call &rest args)
424                 (declare (ignore args))
425                 (error "Invalid use of <- inside ENSURING-NODE-TARGET: ~s" call))
426               (^ (&whole call &rest args)
427                 (declare (ignore args))
428                 (error "Invalid use of ^ inside ENSURING-NODE-TARGET: ~s" call)))
429      (progn
430        ,@body))
431    (<- ,target-var)))
432
433(defun acode-invert-condition-keyword (k)
434  (or 
435   (cdr (assq k '((:eq . :ne) (:ne . :eq) (:le . :gt) (:lt . :ge) (:ge . :lt) (:gt . :le))))
436   (error "Unknown condition: ~s" k)))
437
438(defun backend-arch-macroexpand (whole env)
439  (let* ((expander (arch::arch-macro-function
440                    (backend-target-arch-name *target-backend*)
441                    (car whole))))
442    (if expander
443      (funcall expander whole env)
444      (error "No arch-specific macro function for ~s in arch ~s"
445             (car whole) (backend-target-arch-name *target-backend*)))))
446
447(defmacro declare-arch-specific-macro (name)
448  `(progn
449    (setf (macro-function ',name) #'backend-arch-macroexpand)
450    ',name))
Note: See TracBrowser for help on using the repository browser.