1#| -*-Scheme-*-
2
3Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
4    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
5    2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014 Massachusetts
6    Institute of Technology
7
8This file is part of MIT/GNU Scheme.
9
10MIT/GNU Scheme is free software; you can redistribute it and/or modify
11it under the terms of the GNU General Public License as published by
12the Free Software Foundation; either version 2 of the License, or (at
13your option) any later version.
14
15MIT/GNU Scheme is distributed in the hope that it will be useful, but
16WITHOUT ANY WARRANTY; without even the implied warranty of
17MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
18General Public License for more details.
19
20You should have received a copy of the GNU General Public License
21along with MIT/GNU Scheme; if not, write to the Free Software
22Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
23USA.
24
25|#
26
27;;; Machine Model for Spectrum
28;;; package: (compiler)
29
30(declare (usual-integrations))
31
32;;;; Architecture Parameters
33
34(define use-pre/post-increment? true)
35(define-integrable endianness 'BIG)
36(define-integrable addressing-granularity 8)
37(define-integrable scheme-object-width 32)
38(define-integrable scheme-type-width 6)	;or 8
39
40;; NOTE: expt is not being constant-folded now.
41;; For the time being, some of the parameters below are
42;; pre-computed and marked with ***
43;; There are similar parameters in lapgen.scm
44;; Change them if any of the parameters above do.
45
46(define-integrable scheme-datum-width
47  (- scheme-object-width scheme-type-width))
48
49(define-integrable type-scale-factor
50  ;; (expt 2 (- 8 scheme-type-width)) ***
51  4)
52
53(define-integrable float-width 64)
54(define-integrable float-alignment 64)
55
56(define-integrable address-units-per-float
57  (quotient float-width addressing-granularity))
58
59;;; It is currently required that both packed characters and objects
60;;; be integrable numbers of address units.  Furthermore, the number
61;;; of address units per object must be an integral multiple of the
62;;; number of address units per character.  This will cause problems
63;;; on a machine that is word addressed: we will have to rethink the
64;;; character addressing strategy.
65
66(define-integrable address-units-per-object
67  (quotient scheme-object-width addressing-granularity))
68
69(define-integrable address-units-per-packed-char 1)
70
71(define-integrable signed-fixnum/upper-limit
72  ;; (expt 2 (-1+ scheme-datum-width)) ***
73  33554432)
74
75(define-integrable signed-fixnum/lower-limit
76  (- signed-fixnum/upper-limit))
77
78(define-integrable unsigned-fixnum/upper-limit
79  (* 2 signed-fixnum/upper-limit))
80
81(define-integrable (stack->memory-offset offset) offset)
82(define-integrable ic-block-first-parameter-offset 2)
83(define-integrable execute-cache-size 3) ; Long words per UUO link slot
84
85;;;; Closures and multi-closures
86
87;; On the 68k, to save space, entries can be at 2 mod 4 addresses,
88;; which makes it impossible to use an arbitrary closure entry-point
89;; to reference closed-over variables since the compiler only uses
90;; long-word offsets.  Instead, all closure entry points are bumped
91;; back to the first entry point, which is always long-word aligned.
92
93;; On the HP-PA, and all other RISCs, all the entry points are
94;; long-word aligned, so there is no need to bump back to the first
95;; entry point.
96
97(define-integrable closure-entry-size
98  #|
99     Long words in a single closure entry:
100       GC offset word
101       LDIL	L'target,26
102       BLE	R'target(5,26)
103       ADDI	-12,31,31
104   |#
105  4)
106
107;; Given: the number of entry points in a closure, and a particular
108;; entry point number, compute the distance from that entry point to
109;; the first variable slot in the closure object (in long words).
110
111(define (closure-first-offset nentries entry)
112  (if (zero? nentries)
113      1					; Strange boundary case
114      (- (* closure-entry-size (- nentries entry)) 1)))
115
116;; Like the above, but from the start of the complete closure object,
117;; viewed as a vector, and including the header word.
118
119(define (closure-object-first-offset nentries)
120  (case nentries
121    ((0)
122     ;; Vector header only
123     1)
124    ((1)
125     ;; Manifest closure header followed by single entry point
126     (+ 1 closure-entry-size))
127    (else
128     ;; Manifest closure header, number of entries, then entries.
129     (+ 1 1 (* closure-entry-size nentries)))))
130
131;; Bump distance in bytes from one entry point to another.
132;; Used for invocation purposes.
133
134(define (closure-entry-distance nentries entry entry*)
135  nentries				; ignored
136  (* (* closure-entry-size 4) (- entry* entry)))
137
138;; Bump distance in bytes from one entry point to the entry point used
139;; for variable-reference purposes.
140;; On a RISC, this is the entry point itself.
141
142(define (closure-environment-adjustment nentries entry)
143  nentries entry			; ignored
144  0)
145
146;;;; Machine Registers
147
148(define-integrable g0 0)
149(define-integrable g1 1)
150(define-integrable g2 2)
151(define-integrable g3 3)
152(define-integrable g4 4)
153(define-integrable g5 5)
154(define-integrable g6 6)
155(define-integrable g7 7)
156(define-integrable g8 8)
157(define-integrable g9 9)
158(define-integrable g10 10)
159(define-integrable g11 11)
160(define-integrable g12 12)
161(define-integrable g13 13)
162(define-integrable g14 14)
163(define-integrable g15 15)
164(define-integrable g16 16)
165(define-integrable g17 17)
166(define-integrable g18 18)
167(define-integrable g19 19)
168(define-integrable g20 20)
169(define-integrable g21 21)
170(define-integrable g22 22)
171(define-integrable g23 23)
172(define-integrable g24 24)
173(define-integrable g25 25)
174(define-integrable g26 26)
175(define-integrable g27 27)
176(define-integrable g28 28)
177(define-integrable g29 29)
178(define-integrable g30 30)
179(define-integrable g31 31)
180
181;; fp0 - fp3 are status registers.  The rest are real registers
182(define-integrable fp0 32)
183(define-integrable fp1 33)
184(define-integrable fp2 34)
185(define-integrable fp3 35)
186(define-integrable fp4 36)
187(define-integrable fp5 37)
188(define-integrable fp6 38)
189(define-integrable fp7 39)
190(define-integrable fp8 40)
191(define-integrable fp9 41)
192(define-integrable fp10 42)
193(define-integrable fp11 43)
194(define-integrable fp12 44)
195(define-integrable fp13 45)
196(define-integrable fp14 46)
197(define-integrable fp15 47)
198
199;; The following registers are available only on the newer processors
200(define-integrable fp16 48)
201(define-integrable fp17 49)
202(define-integrable fp18 50)
203(define-integrable fp19 51)
204(define-integrable fp20 52)
205(define-integrable fp21 53)
206(define-integrable fp22 54)
207(define-integrable fp23 55)
208(define-integrable fp24 56)
209(define-integrable fp25 57)
210(define-integrable fp26 58)
211(define-integrable fp27 59)
212(define-integrable fp28 60)
213(define-integrable fp29 61)
214(define-integrable fp30 62)
215(define-integrable fp31 63)
216
217(define-integrable number-of-machine-registers 64)
218(define-integrable number-of-temporary-registers 256)
219
220;;; Fixed-use registers for Scheme compiled code.
221(define-integrable regnum:return-value g2)
222(define-integrable regnum:scheme-to-interface-ble g3)
223(define-integrable regnum:regs-pointer g4)
224(define-integrable regnum:quad-bitmask g5)
225(define-integrable regnum:dynamic-link g19)
226(define-integrable regnum:memtop-pointer g20)
227(define-integrable regnum:free-pointer g21)
228(define-integrable regnum:stack-pointer g22)
229
230;;; Fixed-use registers due to architecture or OS calling conventions.
231(define-integrable regnum:zero g0)
232(define-integrable regnum:addil-result g1)
233(define-integrable regnum:C-global-pointer g27)
234(define-integrable regnum:C-return-value g28)
235(define-integrable regnum:C-stack-pointer g30)
236(define-integrable regnum:ble-return g31)
237(define-integrable regnum:fourth-arg g23)
238(define-integrable regnum:third-arg g24)
239(define-integrable regnum:second-arg g25)
240(define-integrable regnum:first-arg g26)
241
242(define (machine-register-value-class register)
243  (cond ((or (= register 0)
244	     (<= 6 register 18)
245	     (<= 23 register 26)
246	     (= register 29)
247	     (= register 31))
248	 value-class=word)
249	((or (= register 2) (= register 28))
250	 value-class=object)
251	((or (= register 1) (= register 3))
252	 value-class=unboxed)
253	((or (= register 4)
254	     (<= 19 register 22)
255	     (= register 27)
256	     (= register 30))
257	 value-class=address)
258	((= register 5)
259	 value-class=immediate)
260	((<= 32 register 63)
261	 value-class=float)
262	(else
263	 (error "illegal machine register" register))))
264
265(define-integrable (machine-register-known-value register)
266  register				;ignore
267  false)
268
269;;;; Interpreter Registers
270
271(define-integrable (interpreter-free-pointer)
272  (rtl:make-machine-register regnum:free-pointer))
273
274(define (interpreter-free-pointer? expression)
275  (and (rtl:register? expression)
276       (= (rtl:register-number expression) regnum:free-pointer)))
277
278(define-integrable (interpreter-regs-pointer)
279  (rtl:make-machine-register regnum:regs-pointer))
280
281(define (interpreter-regs-pointer? expression)
282  (and (rtl:register? expression)
283       (= (rtl:register-number expression) regnum:regs-pointer)))
284
285(define-integrable (interpreter-value-register)
286  (rtl:make-machine-register regnum:return-value))
287
288(define (interpreter-value-register? expression)
289  (and (rtl:register? expression)
290       (= (rtl:register-number expression) regnum:return-value)))
291
292(define-integrable (interpreter-stack-pointer)
293  (rtl:make-machine-register regnum:stack-pointer))
294
295(define (interpreter-stack-pointer? expression)
296  (and (rtl:register? expression)
297       (= (rtl:register-number expression) regnum:stack-pointer)))
298
299(define-integrable (interpreter-dynamic-link)
300  (rtl:make-machine-register regnum:dynamic-link))
301
302(define (interpreter-dynamic-link? expression)
303  (and (rtl:register? expression)
304       (= (rtl:register-number expression) regnum:dynamic-link)))
305
306(define-integrable (interpreter-environment-register)
307  (rtl:make-offset (interpreter-regs-pointer)
308		   (rtl:make-machine-constant 3)))
309
310(define (interpreter-environment-register? expression)
311  (and (rtl:offset? expression)
312       (interpreter-regs-pointer? (rtl:offset-base expression))
313       (let ((offset (rtl:offset-offset expression)))
314	 (and (rtl:machine-constant? offset)
315	      (= 3 (rtl:machine-constant-value offset))))))
316
317(define-integrable (interpreter-register:access)
318  (rtl:make-machine-register g28))
319
320(define-integrable (interpreter-register:cache-reference)
321  (rtl:make-machine-register g28))
322
323(define-integrable (interpreter-register:cache-unassigned?)
324  (rtl:make-machine-register g28))
325
326(define-integrable (interpreter-register:lookup)
327  (rtl:make-machine-register g28))
328
329(define-integrable (interpreter-register:unassigned?)
330  (rtl:make-machine-register g28))
331
332(define-integrable (interpreter-register:unbound?)
333  (rtl:make-machine-register g28))
334
335;;;; RTL Registers, Constants, and Primitives
336
337(define (rtl:machine-register? rtl-register)
338  (case rtl-register
339    ((STACK-POINTER)
340     (interpreter-stack-pointer))
341    ((DYNAMIC-LINK)
342     (interpreter-dynamic-link))
343    ((VALUE)
344     (interpreter-value-register))
345    ((FREE)
346     (interpreter-free-pointer))
347    ((MEMORY-TOP)
348     (rtl:make-machine-register regnum:memtop-pointer))
349    ((INTERPRETER-CALL-RESULT:ACCESS)
350     (interpreter-register:access))
351    ((INTERPRETER-CALL-RESULT:CACHE-REFERENCE)
352     (interpreter-register:cache-reference))
353    ((INTERPRETER-CALL-RESULT:CACHE-UNASSIGNED?)
354     (interpreter-register:cache-unassigned?))
355    ((INTERPRETER-CALL-RESULT:LOOKUP)
356     (interpreter-register:lookup))
357    ((INTERPRETER-CALL-RESULT:UNASSIGNED?)
358     (interpreter-register:unassigned?))
359    ((INTERPRETER-CALL-RESULT:UNBOUND?)
360     (interpreter-register:unbound?))
361    (else false)))
362
363(define (rtl:interpreter-register? rtl-register)
364  (case rtl-register
365    ((INT-MASK) 1)
366    ((ENVIRONMENT) 3)
367    ((TEMPORARY) 4)
368    (else false)))
369
370(define (rtl:interpreter-register->offset locative)
371  (or (rtl:interpreter-register? locative)
372      (error "Unknown register type" locative)))
373
374(define (rtl:constant-cost expression)
375  ;; Magic numbers.
376  (let ((if-integer
377	 (lambda (value)
378	   (cond ((zero? value) 1)
379		 ((fits-in-5-bits-signed? value) 2)
380		 (else 3)))))
381    (let ((if-synthesized-constant
382	   (lambda (type datum)
383	     (if-integer (make-non-pointer-literal type datum)))))
384      (case (rtl:expression-type expression)
385	((CONSTANT)
386	 (let ((value (rtl:constant-value expression)))
387	   (if (non-pointer-object? value)
388	       (if-synthesized-constant (object-type value)
389					(object-datum value))
390	       3)))
391	((MACHINE-CONSTANT)
392	 (if-integer (rtl:machine-constant-value expression)))
393	((ENTRY:PROCEDURE
394	  ENTRY:CONTINUATION
395	  ASSIGNMENT-CACHE
396	  VARIABLE-CACHE
397	  OFFSET-ADDRESS
398	  BYTE-OFFSET-ADDRESS
399	  FLOAT-OFFSET-ADDRESS)
400	 3)
401	((CONS-POINTER)
402	 (and (rtl:machine-constant? (rtl:cons-pointer-type expression))
403	      (rtl:machine-constant? (rtl:cons-pointer-datum expression))
404	      (if-synthesized-constant
405	       (rtl:machine-constant-value (rtl:cons-pointer-type expression))
406	       (rtl:machine-constant-value
407		(rtl:cons-pointer-datum expression)))))
408	(else false)))))
409
410(define compiler:open-code-floating-point-arithmetic?
411  true)
412
413(define compiler:primitives-with-no-open-coding
414  '(DIVIDE-FIXNUM GCD-FIXNUM &/ FLONUM-EXPM1 FLONUM-LOG1P))