source: branches/arm/compiler/backend.lisp @ 13741

Last change on this file since 13741 was 13697, checked in by gb, 9 years ago

Add a constant.

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