source: branches/working-0711/ccl/compiler/backend.lisp @ 11836

Last change on this file since 11836 was 11836, checked in by gz, 12 years ago

Typecheck new bindings in nx1-env-body, if nx-declarations-typecheck is true. Remove the typechecking from nx1-typed-var-initform since no longer needed. Remove some bogus declarations found by compiling the system with typechecking declarations.

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