1 ;;;============================================================================
5 ;;; Copyright (c) 1994-2012 by Marc Feeley, All Rights Reserved.
9 (include-adt "_envadt.scm")
10 (include-adt "_gvmadt.scm")
11 (include-adt "_ptreeadt.scm")
12 (include-adt "_sourceadt.scm")
14 ;;;----------------------------------------------------------------------------
16 ;;;; Interface to back ends
18 ;; This file defines the interface to all the target machine implementations.
19 ;; Target machine implementations define (among other things):
21 ;; - how Scheme objects are represented in the target machine
22 ;; - how GVM instructions are translated into target machine instructions
23 ;; - what is known about some of the Scheme primitives (e.g. which are
24 ;; defined, what their calling pattern is, which can be open-coded, etc.)
26 ;; When a given target machine module is loaded, a 'target' description
27 ;; object is created and added to the list of available back ends (the
28 ;; procedure 'target-add' should be used for this).
30 ;; Target description objects contain the following fields:
35 ;; begin! Procedure (lambda (info-port) ...)
36 ;; This procedure must be called to initialize the module
37 ;; before any of the other fields are referenced.
38 ;; If 'info-port' is not #f, it is used to display
39 ;; user-related information.
41 ;; end! Procedure (lambda () ...)
42 ;; This procedure must be called to do final 'cleanup'.
43 ;; References to the other fields in the module should thus
44 ;; happen inside calls to 'begin!' and 'end!'.
46 ;; dump Procedure (lambda (procs output output-root c-intf script-line
48 ;; This procedure takes a list of 'procedure objects' and dumps
49 ;; the corresponding loader-compatible object file to the
50 ;; specified file. The first procedure in 'procs', which must
51 ;; be a 0 argument procedure, will be called once when
52 ;; the program it is linked into is started up. 'options'
53 ;; is a list of back-end specific symbols passed by the
54 ;; front end of the compiler. 'c-intf' is a c-intf structure
55 ;; containing the C declarations, procedures, and initialization
56 ;; code contained in the source file. It is the responsibility
57 ;; of the back-end (and loader) to create one Scheme primitive
58 ;; for each C procedure in the c-intf structure and to provide
59 ;; the linking between the two. If the entries of the 'c-intf'
60 ;; structure are replaced with the empty list, the front-end
61 ;; will NOT produce the C interface file automatically as is
62 ;; normally the case (this is useful in the case of a back-end
63 ;; generating C that will itself be creating this file).
64 ;; The 'output' argument specifies the file name of the
65 ;; file to produce. If it is #f, 'output-root' concatenated
66 ;; with the appropriate extension should be used as a
67 ;; file name. The 'script-line' argument indicates the text
68 ;; on the first line of the source file (after the #! or @;)
69 ;; if the source file is a script or #f if it is not a script.
71 ;; nb-regs Integer denoting the maximum number of GVM registers
72 ;; that should be used when generating GVM code for this
75 ;; prim-info Procedure (lambda (name) ...)
76 ;; This procedure is used to get information about the
77 ;; Scheme primitive procedures built into the system (not
78 ;; necessarily standard procedures). The procedure returns
79 ;; a 'procedure object' describing the named procedure if it
80 ;; exists and #f if it doesn't.
82 ;; label-info Procedure (lambda (nb-parms nb-opts nb-keys rest? closed?) ...)
83 ;; This procedure returns information describing where
84 ;; parameters are located immediately following a procedure
85 ;; 'label' instruction with the given parameters. The locations
86 ;; can be registers or stack slots.
88 ;; jump-info Procedure (lambda (nb-args) ...)
89 ;; This procedure returns information describing where
90 ;; arguments are expected to be immediately following a 'jump'
91 ;; instruction that passes 'nb-args' arguments. The
92 ;; locations can be registers or stack slots.
94 ;; frame-constraints Frame constraints structure
95 ;; The frame constraints structure indicates the frame alignment
98 ;; proc-result GVM location.
99 ;; This value is the GVM register where the result of a
100 ;; procedure and task is returned.
102 ;; task-return GVM location.
103 ;; This value is the GVM register where the task's return address
106 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
108 ;;;; Target description object manipulation
110 (define (make-target version name)
112 (define current-target-version 6) ; number for this version of the module
114 (if (not (= version current-target-version))
115 (compiler-internal-error
116 "make-target, version of target module is not current" name))
118 (let ((x (make-vector 13)))
119 (vector-set! x 0 'target)
120 (vector-set! x 1 name)
123 (define (target-name x) (vector-ref x 1))
125 (define (target-begin! x) (vector-ref x 2))
126 (define (target-begin!-set! x y) (vector-set! x 2 y))
127 (define (target-end! x) (vector-ref x 3))
128 (define (target-end!-set! x y) (vector-set! x 3 y))
130 (define (target-dump x) (vector-ref x 4))
131 (define (target-dump-set! x y) (vector-set! x 4 y))
132 (define (target-nb-regs x) (vector-ref x 5))
133 (define (target-nb-regs-set! x y) (vector-set! x 5 y))
134 (define (target-prim-info x) (vector-ref x 6))
135 (define (target-prim-info-set! x y) (vector-set! x 6 y))
136 (define (target-label-info x) (vector-ref x 7))
137 (define (target-label-info-set! x y) (vector-set! x 7 y))
138 (define (target-jump-info x) (vector-ref x 8))
139 (define (target-jump-info-set! x y) (vector-set! x 8 y))
140 (define (target-frame-constraints x) (vector-ref x 9))
141 (define (target-frame-constraints-set! x y) (vector-set! x 9 y))
142 (define (target-proc-result x) (vector-ref x 10))
143 (define (target-proc-result-set! x y) (vector-set! x 10 y))
144 (define (target-task-return x) (vector-ref x 11))
145 (define (target-task-return-set! x y) (vector-set! x 11 y))
146 (define (target-switch-testable? x) (vector-ref x 12))
147 (define (target-switch-testable?-set! x y) (vector-set! x 12 y))
149 ;;;; Frame constraints structure
151 (define (make-frame-constraints reserve align) (vector reserve align))
152 (define (frame-constraints-reserve fc) (vector-ref fc 0))
153 (define (frame-constraints-align fc) (vector-ref fc 1))
155 ;;;; Database of all target modules loaded
157 (define targets-loaded '())
159 (define (target-get name)
160 (let ((x (assq name targets-loaded)))
164 "Target module is not available:" name))))
166 (define (target-add targ)
167 (let* ((name (target-name targ))
168 (x (assq name targets-loaded)))
171 (set! targets-loaded (cons (cons name targ) targets-loaded)))
174 (define (default-target)
175 (if (null? targets-loaded)
176 (compiler-error "No target module is available")
177 (car (car targets-loaded))))
179 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
181 ;;;; Target machine selection
183 (define (target-select! name info-port)
185 (set! target (target-get name))
187 ((target-begin! target) info-port)
189 (set! target.dump (target-dump target))
190 (set! target.nb-regs (target-nb-regs target))
191 (set! target.prim-info (target-prim-info target))
192 (set! target.label-info (target-label-info target))
193 (set! target.jump-info (target-jump-info target))
194 (set! target.frame-constraints (target-frame-constraints target))
195 (set! target.proc-result (target-proc-result target))
196 (set! target.task-return (target-task-return target))
197 (set! target.switch-testable? (target-switch-testable? target))
200 (target.prim-info **not-sym))
203 (target.prim-info **eq?-sym))
205 (set! **quasi-append-proc-obj
206 (target.prim-info **quasi-append-sym))
208 (set! **quasi-list-proc-obj
209 (target.prim-info **quasi-list-sym))
211 (set! **quasi-cons-proc-obj
212 (target.prim-info **quasi-cons-sym))
214 (set! **quasi-list->vector-proc-obj
215 (target.prim-info **quasi-list->vector-sym))
217 (set! **quasi-vector-proc-obj
218 (target.prim-info **quasi-vector-sym))
220 (set! **case-memv-proc-obj
221 (target.prim-info **case-memv-sym))
225 (define (target-unselect!)
227 (set! **not-proc-obj #f)
228 (set! **eq?-proc-obj #f)
229 (set! **quasi-append-proc-obj #f)
230 (set! **quasi-list-proc-obj #f)
231 (set! **quasi-cons-proc-obj #f)
232 (set! **quasi-list->vector-proc-obj #f)
233 (set! **quasi-vector-proc-obj #f)
234 (set! **case-memv-proc-obj #f)
236 ((target-end! target))
241 (define target.dump #f)
242 (define target.nb-regs #f)
243 (define target.prim-info #f)
244 (define target.label-info #f)
245 (define target.jump-info #f)
246 (define target.frame-constraints #f)
247 (define target.proc-result #f)
248 (define target.task-return #f)
249 (define target.switch-testable? #f)
251 ;; procedures defined in back-end:
253 (define **not-proc-obj #f) ;; ##not
254 (define **eq?-proc-obj #f) ;; ##eq?
255 (define **quasi-append-proc-obj #f) ;; ##quasi-append
256 (define **quasi-list-proc-obj #f) ;; ##quasi-list
257 (define **quasi-cons-proc-obj #f) ;; ##quasi-cons
258 (define **quasi-list->vector-proc-obj #f) ;; ##quasi-list->vector
259 (define **quasi-vector-proc-obj #f) ;; ##quasi-vector
260 (define **case-memv-proc-obj #f) ;; ##case-memv
262 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
264 ;;;; Declarations relevant to back end
266 ;; Arithmetic related declarations:
268 ;; (generic) all arithmetic is done on generic numbers
269 ;; (generic <var1> ...) apply only to primitives specified
271 ;; (fixnum) all arithmetic is done on fixnums
272 ;; (fixnum <var1> ...) apply only to primitives specified
274 ;; (flonum) all arithmetic is done on flonums
275 ;; (flonum <var1> ...) apply only to primitives specified
277 ;; (mostly-generic) generic arithmetic is frequent
278 ;; (mostly-generic <var1> ...) apply only to primitives specified
280 ;; (mostly-fixnum) fixnum arithmetic is frequent
281 ;; (mostly-fixnum <var1> ...) apply only to primitives specified
283 ;; (mostly-flonum) flonum arithmetic is frequent
284 ;; (mostly-flonum <var1> ...) apply only to primitives specified
286 ;; (mostly-fixnum-flonum) fixnum and flonum arithmetic is frequent
287 ;; (mostly-fixnum-flonum <var1> ...) apply only to primitives specified
289 ;; (mostly-flonum-fixnum) flonum and fixnum arithmetic is frequent
290 ;; (mostly-flonum-fixnum <var1> ...) apply only to primitives specified
292 (define-namable-decl generic-sym 'arith)
293 (define-namable-decl fixnum-sym 'arith)
294 (define-namable-decl flonum-sym 'arith)
296 (define (arith-implementation name env)
297 (declaration-value 'arith name generic-sym env))
299 (define-namable-decl mostly-generic-sym 'mostly-arith)
300 (define-namable-decl mostly-fixnum-sym 'mostly-arith)
301 (define-namable-decl mostly-flonum-sym 'mostly-arith)
302 (define-namable-decl mostly-fixnum-flonum-sym 'mostly-arith)
303 (define-namable-decl mostly-flonum-fixnum-sym 'mostly-arith)
305 (define (mostly-arith-implementation name env)
306 (declaration-value 'mostly-arith name mostly-fixnum-flonum-sym env))
308 ;;;============================================================================