/[cmucl]/src/compiler/backend.lisp
ViewVC logotype

Contents of /src/compiler/backend.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.36 - (hide annotations)
Wed Nov 10 19:51:24 2010 UTC (3 years, 5 months ago) by rtoy
Branch: MAIN
CVS Tags: GIT-CONVERSION, cross-sol-x86-merged, cross-sol-x86-base, snapshot-2010-12, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, cross-sol-x86-2010-12-20, cross-sparc-branch-base, HEAD
Branch point for: cross-sparc-branch, cross-sol-x86-branch
Changes since 1.35: +9 -2 lines
Add new slots to the backend to hold the foreign linkage space start
and entry size.  Not yet used anywhere.

This change needs a cross-compile; use boot-2010-11-1-cross.lisp as
the cross-compile script.

compiler/backend.lisp:
o Add the two new slots to the backend.

compiler/dump.lisp:
o DUMP-DATA-MAYBE-BYTE-SWAPPING needs to handle (unicode) strings
o DUMP-DATA-MAYBE-BYTE-SWAPPING should not swap bytes of a string.
  Genesis will make that happen.

code/exports.lisp:
o Export BACKEND-FOREIGN-LINKAGE-SPACE-START and
  BACKEND-FOREIGN-LINKAGE-ENTRY-SIZE.

bootfiles/20b/boot-2010-11-1-cross.lisp:
o Cross-compile script for this change.
1 wlott 1.1 ;;; -*- Package: C; Log: C.Log -*-
2     ;;;
3     ;;; **********************************************************************
4 ram 1.13 ;;; This code was written as part of the CMU Common Lisp project at
5     ;;; Carnegie Mellon University, and has been placed in the public domain.
6     ;;;
7     (ext:file-comment
8 rtoy 1.36 "$Header: /tiger/var/lib/cvsroots/cmucl/src/compiler/backend.lisp,v 1.36 2010/11/10 19:51:24 rtoy Exp $")
9 ram 1.13 ;;;
10 wlott 1.1 ;;; **********************************************************************
11     ;;;
12     ;;; This file isolates all the backend specific data so that we can compile
13     ;;; and use different backends.
14     ;;;
15     ;;; Written by William Lott.
16     ;;;
17     (in-package "C")
18 rtoy 1.33 (intl:textdomain "cmucl")
19 wlott 1.1
20 wlott 1.26 (export '(*backend* *target-backend* *native-backend* backend
21 wlott 1.16 backend-name backend-version backend-fasl-file-type
22     backend-fasl-file-implementation backend-fasl-file-version
23     backend-register-save-penalty backend-byte-order
24     backend-any-primitive-type backend-info-environment
25     backend-instruction-formats backend-instruction-flavors
26     backend-assembler-resources backend-special-arg-types
27     backend-disassem-params backend-internal-errors
28 wlott 1.24 backend-assembler-params backend-page-size
29 rtoy 1.36 backend-foreign-linkage-space-start
30     backend-foreign-linkage-entry-size
31 wlott 1.16
32     ;; The various backends need to call these support routines
33 wlott 1.26 def-vm-support-routine make-stack-pointer-tn primitive-type
34     primitive-type-of emit-nop location-number))
35 wlott 1.2
36 wlott 1.1
37 wlott 1.18 ;;;; VM support routine stuff.
38    
39     (eval-when (compile eval)
40    
41     (defmacro def-vm-support-routines (&rest routines)
42     `(progn
43     (eval-when (compile load eval)
44     (defparameter vm-support-routines ',routines))
45     (defstruct (vm-support-routines
46     (:print-function %print-vm-support-routines))
47     ,@(mapcar #'(lambda (routine)
48     `(,routine nil :type (or function null)))
49     routines))
50     ,@(mapcar
51     #'(lambda (name)
52     `(defun ,name (&rest args)
53     (apply (or (,(symbolicate "VM-SUPPORT-ROUTINES-" name)
54     (backend-support-routines *backend*))
55 rtoy 1.35 (error (intl:gettext "Machine specific support routine ~S ~
56     undefined for ~S")
57 wlott 1.18 ',name *backend*))
58     args)))
59     routines)))
60    
61     ); eval-when
62    
63     (def-vm-support-routines
64     ;; From VM.LISP
65     immediate-constant-sc
66     location-print-name
67    
68     ;; From PRIMTYPE.LISP
69     primitive-type-of
70     primitive-type
71    
72     ;; From C-CALL.LISP
73     make-call-out-tns
74    
75     ;; From CALL.LISP
76     standard-argument-location
77     make-return-pc-passing-location
78     make-old-fp-passing-location
79     make-old-fp-save-location
80     make-return-pc-save-location
81     make-argument-count-location
82     make-nfp-tn
83     make-stack-pointer-tn
84     make-number-stack-pointer-tn
85     make-unknown-values-locations
86     select-component-format
87    
88     ;; From NLX.LISP
89     make-nlx-sp-tn
90     make-dynamic-state-tns
91 dtc 1.32 make-nlx-entry-argument-start-location
92 wlott 1.18
93     ;; From SUPPORT.LISP
94     generate-call-sequence
95 wlott 1.25 generate-return-sequence
96    
97     ;; For use with scheduler.
98     emit-nop
99 wlott 1.26 location-number)
100 wlott 1.18
101     (defprinter vm-support-routines)
102    
103     (defmacro def-vm-support-routine (name ll &body body)
104     (unless (member (intern (string name) (find-package "C"))
105     vm-support-routines)
106 rtoy 1.35 (warn (intl:gettext "Unknown VM support routine: ~A") name))
107 wlott 1.18 (let ((local-name (symbolicate (backend-name *target-backend*) "-" name)))
108     `(progn
109     (defun ,local-name ,ll ,@body)
110     (setf (,(intern (concatenate 'simple-string
111     "VM-SUPPORT-ROUTINES-"
112     (string name))
113     (find-package "C"))
114     (backend-support-routines *target-backend*))
115     #',local-name))))
116    
117    
118    
119 wlott 1.16 ;;;; The backend structure.
120 wlott 1.1
121     (defstruct (backend
122     (:print-function %print-backend))
123     ;; The name of this backend. Something like ``PMAX''
124     (name nil)
125    
126     ;; The version string for this backend.
127     ;; Something like ``DECstation 3100/Mach 0.0''
128     (version nil)
129    
130     ;; Information about fasl files for this backend.
131     (fasl-file-type nil)
132     (fasl-file-implementation nil)
133     (fasl-file-version nil)
134    
135 wlott 1.16 ;; The VM support routines.
136     (support-routines (make-vm-support-routines) :type vm-support-routines)
137    
138 wlott 1.1 ;; The number of references that a TN must have to offset the overhead of
139     ;; saving the TN across a call.
140     (register-save-penalty 0)
141    
142     ;; The byte order of the target machine. Should either be :big-endian
143     ;; which has the MSB first (RT) or :little-endian which has the MSB last
144     ;; (VAX).
145     (byte-order nil :type (or null (member :little-endian :big-endian)))
146    
147     ;; Translates from SC numbers to SC info structures. SC numbers are always
148     ;; used instead of names at run time, so changing this vector changes all the
149     ;; references.
150 wlott 1.9 (sc-numbers (make-array sc-number-limit :initial-element nil)
151     :type sc-vector)
152 wlott 1.1
153     ;; A list of all the SBs defined, so that we can easily iterate over them.
154     (sb-list () :type list)
155    
156     ;; Translates from template names to template structures.
157     (template-names (make-hash-table :test #'eq) :type hash-table)
158    
159     ;; Hashtable from SC and SB names the corresponding structures. The META
160     ;; versions are only used at meta-compile and load times, so the defining
161     ;; macros can change these at meta-compile time without breaking the
162     ;; compiler.
163     (sc-names (make-hash-table :test #'eq) :type hash-table)
164     (sb-names (make-hash-table :test #'eq) :type hash-table)
165     (meta-sc-names (make-hash-table :test #'eq) :type hash-table)
166     (meta-sb-names (make-hash-table :test #'eq) :type hash-table)
167    
168     ;; Like *SC-Numbers*, but is updated at meta-compile time.
169 wlott 1.9 (meta-sc-numbers (make-array sc-number-limit :initial-element nil)
170     :type sc-vector)
171 wlott 1.1
172     ;; Translates from primitive type names to the corresponding primitive-type
173     ;; structure.
174     (primitive-type-names (make-hash-table :test #'eq) :type hash-table)
175    
176     ;; Establishes a convenient handle on primitive type unions, or whatever.
177     ;; These names can only be used as the :arg-types or :result-types for VOPs
178     ;; and can map to anything else that can be used as :arg-types or
179     ;; :result-types (e.g. :or, :constant).
180     (primitive-type-aliases (make-hash-table :test #'eq) :type hash-table)
181    
182     ;; Meta-compile time translation from names to primitive types.
183     (meta-primitive-type-names (make-hash-table :test #'eq) :type hash-table)
184    
185     ;; The primitive type T is somewhat magical, in that it is the only
186     ;; primitive type that overlaps with other primitive types. An object
187     ;; of primitive-type T is in the canonical descriptor (boxed or pointer)
188     ;; representation.
189     ;;
190     ;; We stick the T primitive-type in a variable so that people who have to
191     ;; special-case it can get at it conveniently. This is done by the machine
192     ;; specific VM definition, since the DEF-PRIMITIVE-TYPE for T must specify
193     ;; the SCs that boxed objects can be allocated in.
194     (any-primitive-type nil :type (or null primitive-type))
195    
196     ;; Hashtable translating from VOP names to the corresponding VOP-Parse
197     ;; structures. This information is only used at meta-compile time.
198     (parsed-vops (make-hash-table :test #'eq) :type hash-table)
199 wlott 1.4
200     ;; The backend specific aspects of the info environment.
201 wlott 1.6 (info-environment nil :type list)
202 wlott 1.1
203 wlott 1.6 ;; Support for the assembler.
204     (instruction-formats (make-hash-table :test #'eq) :type hash-table)
205     (instruction-flavors (make-hash-table :test #'equal) :type hash-table)
206     (special-arg-types (make-hash-table :test #'eq) :type hash-table)
207 ram 1.11 (assembler-resources nil :type list)
208 wlott 1.10
209 wlott 1.16 ;; The backend specific features list, if any. During a compilation,
210     ;; *features* is bound to *features* - misfeatures + features.
211     (%features nil :type list)
212     (misfeatures nil :type list)
213    
214 ram 1.14 ;; Disassembler information.
215     (disassem-params nil :type t)
216 wlott 1.6
217 wlott 1.16 ;; Mappings between CTYPE structures and the corresponding predicate.
218     ;; The type->predicate mapping hash is an alist because there is no
219     ;; such thing as a type= hash table.
220     (predicate-types (make-hash-table :test #'eq) :type hash-table)
221     (type-predicates nil :type list)
222 wlott 1.6
223 wlott 1.16 ;; Vector of the internal errors defined for this backend, or NIL if
224     ;; they haven't been installed yet.
225 wlott 1.21 (internal-errors nil :type (or simple-vector null))
226 wlott 1.1
227 wlott 1.21 ;; Assembler parameters.
228 wlott 1.24 (assembler-params nil :type t)
229    
230     ;; The maximum number of bytes per page on this system. Used by genesis.
231 rtoy 1.36 (page-size 0 :type index)
232    
233     ;; The foreign linkage space start and size
234    
235     (foreign-linkage-space-start 0 :type (unsigned-byte 32))
236     (foreign-linkage-entry-size 0 :type index))
237 wlott 1.24
238 wlott 1.16
239 wlott 1.1 (defprinter backend
240     name)
241    
242    
243     (defvar *native-backend* (make-backend)
244 rtoy 1.34 "The backend for the machine we are running on. Do not change this.")
245 wlott 1.1 (defvar *target-backend* *native-backend*
246 rtoy 1.34 "The backend we are attempting to compile.")
247 wlott 1.1 (defvar *backend* *native-backend*
248 rtoy 1.34 "The backend we are using to compile with.")
249 wlott 1.16
250    
251 wlott 1.15
252 wlott 1.16 ;;;; Other utility functions for fiddling with the backend.
253 wlott 1.15
254 wlott 1.16 (export '(backend-features target-featurep backend-featurep native-featurep))
255 wlott 1.15
256 wlott 1.16 (defun backend-features (backend)
257 rtoy 1.34 "Compute the *FEATURES* list to use with BACKEND."
258 wlott 1.16 (union (backend-%features backend)
259     (set-difference *features*
260     (backend-misfeatures backend))))
261    
262 wlott 1.15 (defun target-featurep (feature)
263 rtoy 1.34 "Same as EXT:FEATUREP, except use the features found in *TARGET-BACKEND*."
264 wlott 1.16 (let ((*features* (backend-features *target-backend*)))
265 wlott 1.15 (featurep feature)))
266    
267     (defun backend-featurep (feature)
268 rtoy 1.34 "Same as EXT:FEATUREP, except use the features found in *BACKEND*."
269 wlott 1.20 (let ((*features* (backend-features *backend*)))
270 wlott 1.15 (featurep feature)))
271    
272     (defun native-featurep (feature)
273 rtoy 1.34 "Same as EXT:FEATUREP, except use the features found in *NATIVE-BACKEND*."
274 wlott 1.16 (let ((*features* (backend-features *native-backend*)))
275 wlott 1.15 (featurep feature)))
276 wlott 1.16
277    
278     ;;; NEW-BACKEND
279     ;;;
280     ;;; Utility for creating a new backend structure for use with cross
281     ;;; compilers.
282     ;;;
283     (defun new-backend (name features misfeatures)
284     ;; If VM names a different package, rename that package so that VM doesn't
285     ;; name it.
286     (let ((pkg (find-package "VM")))
287     (when pkg
288     (let ((pkg-name (package-name pkg)))
289     (unless (string= pkg-name name)
290     (rename-package pkg pkg-name
291     (remove "VM" (package-nicknames pkg)
292     :test #'string=))
293     (unuse-package pkg "C")))))
294     ;; Make sure VM names our package, creating it if necessary.
295     (let* ((pkg (or (find-package name)
296     (make-package name :nicknames '("VM"))))
297     (nicknames (package-nicknames pkg)))
298     (unless (member "VM" nicknames :test #'string=)
299     (rename-package pkg name (cons "VM" nicknames)))
300     ;; And make sure we are using the necessary packages.
301 wlott 1.21 (use-package '("C-CALL" "ALIEN-INTERNALS" "ALIEN" "BIGNUM" "UNIX"
302 hallgren 1.27 "LISP" "KERNEL" "EXTENSIONS" "SYSTEM" "C" "NEW-ASSEM")
303 wlott 1.21 pkg))
304 wlott 1.16 ;; Make sure the native info env list is stored in *native-backend*
305     (unless (backend-info-environment *native-backend*)
306     (setf (backend-info-environment *native-backend*) *info-environment*))
307     ;; Cons up a backend structure, filling in the info-env and features slots.
308     (let ((backend (make-backend
309     :name name
310     :info-environment
311     (cons (make-info-environment
312     :name
313     (concatenate 'string name " backend"))
314     (remove-if #'(lambda (name)
315     (let ((len (length name)))
316     (and (> len 8)
317     (string= name " backend"
318     :start1 (- len 8)))))
319     *info-environment*
320     :key #'info-env-name))
321     :%features features
322     :misfeatures misfeatures)))
323 wlott 1.23 (setf *target-backend* backend)
324     (define-standard-type-predicates)
325     backend))

  ViewVC Help
Powered by ViewVC 1.1.5