← Back to branch summary

~ubuntu-branches/ubuntu/intrepid/mit-scheme/intrepid-updates

« back to all changes in this revision

Viewing changes to src/compiler/machines/vax/machin.scm

  • Committer: Bazaar Package Importer
  • Author(s): Chris Hanson
  • Date: 2002-03-14 17:04:07 UTC
  • Revision ID: james.westby@ubuntu.com-20020314170407-m5lg1d6bdsl9lv0s
Tags: upstream-7.7.0
Import upstream version 7.7.0

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/compiler/machines/vax/machin.scm
 
1
#| -*-Scheme-*-
 
2
 
 
3
$Id: machin.scm,v 4.13 1999/01/02 06:06:43 cph Exp $
 
4
 
 
5
Copyright (c) 1987-1999 Massachusetts Institute of Technology
 
6
 
 
7
This program is free software; you can redistribute it and/or modify
 
8
it under the terms of the GNU General Public License as published by
 
9
the Free Software Foundation; either version 2 of the License, or (at
 
10
your option) any later version.
 
11
 
 
12
This program is distributed in the hope that it will be useful, but
 
13
WITHOUT ANY WARRANTY; without even the implied warranty of
 
14
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 
15
General Public License for more details.
 
16
 
 
17
You should have received a copy of the GNU General Public License
 
18
along with this program; if not, write to the Free Software
 
19
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 
20
|#
 
21
 
 
22
;;;; Machine Model for DEC Vax
 
23
;;; package: (compiler)
 
24
 
 
25
(declare (usual-integrations))
 
26
 
 
27
;;;; Architecture Parameters
 
28
 
 
29
(define use-pre/post-increment? true)
 
30
(define-integrable endianness 'LITTLE)
 
31
(define-integrable addressing-granularity 8)
 
32
(define-integrable scheme-object-width 32)
 
33
(define-integrable scheme-type-width 6) ;or 8
 
34
 
 
35
;; NOTE: expt is not being constant-folded now.
 
36
;; For the time being, some of the parameters below are
 
37
;; pre-computed and marked with ***
 
38
;; There are similar parameters in lapgen.scm
 
39
;; Change them if any of the parameters above change.
 
40
 
 
41
(define-integrable scheme-datum-width
 
42
  (- scheme-object-width scheme-type-width))
 
43
 
 
44
(define-integrable float-width 64)
 
45
(define-integrable float-alignment 32)
 
46
 
 
47
(define-integrable address-units-per-float
 
48
  (quotient float-width addressing-granularity))
 
49
 
 
50
;;; It is currently required that both packed characters and objects
 
51
;;; be integrable numbers of address units.  Furthermore, the number
 
52
;;; of address units per object must be an integral multiple of the
 
53
;;; number of address units per character.  This will cause problems
 
54
;;; on a machine that is word addressed: we will have to rethink the
 
55
;;; character addressing strategy.
 
56
 
 
57
(define-integrable address-units-per-object
 
58
  (quotient scheme-object-width addressing-granularity))
 
59
 
 
60
(define-integrable address-units-per-packed-char 1)
 
61
 
 
62
(define-integrable signed-fixnum/upper-limit
 
63
  ;; (expt 2 (-1+ scheme-datum-width)) ***
 
64
  33554432)
 
65
 
 
66
(define-integrable signed-fixnum/lower-limit
 
67
  (- signed-fixnum/upper-limit))
 
68
 
 
69
(define-integrable unsigned-fixnum/upper-limit
 
70
  (* 2 signed-fixnum/upper-limit))
 
71
 
 
72
(define-integrable (stack->memory-offset offset) offset)
 
73
(define-integrable ic-block-first-parameter-offset 2)
 
74
 
 
75
;; This must return a word based offset.
 
76
;; On the VAX, to save space, entries can be at 2 mod 4 addresses,
 
77
;; which makes it impossible if the closure object used for
 
78
;; referencing points to arbitrary entries.  Instead, all closure
 
79
;; entry points bump to the canonical entry point, which is always
 
80
;; longword aligned.
 
81
;; On other machines (word aligned), it may be easier to bump back
 
82
;; to each entry point, and the entry number `entry' would be part
 
83
;; of the computation.
 
84
 
 
85
(define (closure-first-offset nentries entry)
 
86
  entry                                 ; ignored
 
87
  (if (zero? nentries)
 
88
      1
 
89
      (quotient (+ (+ 3 1) (* 5 (- nentries 1))) 2)))
 
90
 
 
91
;; This is from the start of the complete closure object,
 
92
;; viewed as a vector, and including the header word.
 
93
 
 
94
(define (closure-object-first-offset nentries)
 
95
  (case nentries
 
96
    ((0) 1)
 
97
    ((1) 4)
 
98
    (else
 
99
     (quotient (+ 5 (* 5 nentries)) 2))))
 
100
 
 
101
;; Bump from one entry point to another.
 
102
 
 
103
(define (closure-entry-distance nentries entry entry*)
 
104
  nentries                              ; ignored
 
105
  (* 10 (- entry* entry)))
 
106
 
 
107
;; Bump to the canonical entry point.
 
108
 
 
109
(define (closure-environment-adjustment nentries entry)
 
110
  (declare (integrate-operator closure-entry-distance))
 
111
  (closure-entry-distance nentries entry 0))
 
112
 
 
113
(define-integrable r0 0)                ; return value
 
114
(define-integrable r1 1)
 
115
(define-integrable r2 2)
 
116
(define-integrable r3 3)
 
117
(define-integrable r4 4)
 
118
(define-integrable r5 5)
 
119
(define-integrable r6 6)
 
120
(define-integrable r7 7)
 
121
(define-integrable r8 8)
 
122
(define-integrable r9 9)
 
123
(define-integrable r10 10)
 
124
(define-integrable r11 11)
 
125
(define-integrable r12 12)              ; AP
 
126
(define-integrable r13 13)              ; FP
 
127
(define-integrable r14 14)              ; SP
 
128
(define-integrable r15 15)              ; PC, not really useable.
 
129
 
 
130
(define number-of-machine-registers 16)
 
131
(define number-of-temporary-registers 256)
 
132
 
 
133
(define-integrable regnum:return-value r9)
 
134
(define-integrable regnum:regs-pointer r10)
 
135
(define-integrable regnum:pointer-mask r11)
 
136
(define-integrable regnum:free-pointer r12)
 
137
(define-integrable regnum:dynamic-link r13)
 
138
(define-integrable regnum:stack-pointer r14)
 
139
(define-integrable (machine-register-known-value register) register false)
 
140
 
 
141
(define (machine-register-value-class register)
 
142
  (cond ((<= 0 register 9) value-class=object)
 
143
        ((= 11 register) value-class=immediate)
 
144
        ((<= 10 register 15) value-class=address)
 
145
        (else (error "illegal machine register" register))))
 
146
 
 
147
;;;; RTL Generator Interface
 
148
 
 
149
(define (interpreter-register:access)
 
150
  (rtl:make-machine-register r0))
 
151
 
 
152
(define (interpreter-register:cache-reference)
 
153
  (rtl:make-machine-register r0))
 
154
 
 
155
(define (interpreter-register:cache-unassigned?)
 
156
  (rtl:make-machine-register r0))
 
157
 
 
158
(define (interpreter-register:lookup)
 
159
  (rtl:make-machine-register r0))
 
160
 
 
161
(define (interpreter-register:unassigned?)
 
162
  (rtl:make-machine-register r0))
 
163
 
 
164
(define (interpreter-register:unbound?)
 
165
  (rtl:make-machine-register r0))
 
166
 
 
167
(define-integrable (interpreter-value-register)
 
168
  (rtl:make-machine-register regnum:return-value))
 
169
 
 
170
(define (interpreter-value-register? expression)
 
171
  (and (rtl:register? expression)
 
172
       (= (rtl:register-number expression) regnum:return-value)))
 
173
 
 
174
(define (interpreter-environment-register)
 
175
  (rtl:make-offset (interpreter-regs-pointer) 3))
 
176
 
 
177
(define (interpreter-environment-register? expression)
 
178
  (and (rtl:offset? expression)
 
179
       (interpreter-regs-pointer? (rtl:offset-base expression))
 
180
       (= 3 (rtl:offset-number expression))))
 
181
 
 
182
(define (interpreter-free-pointer)
 
183
  (rtl:make-machine-register regnum:free-pointer))
 
184
 
 
185
(define (interpreter-free-pointer? expression)
 
186
  (and (rtl:register? expression)
 
187
       (= (rtl:register-number expression) regnum:free-pointer)))
 
188
 
 
189
(define (interpreter-regs-pointer)
 
190
  (rtl:make-machine-register regnum:regs-pointer))
 
191
 
 
192
(define (interpreter-regs-pointer? expression)
 
193
  (and (rtl:register? expression)
 
194
       (= (rtl:register-number expression) regnum:regs-pointer)))
 
195
 
 
196
(define (interpreter-stack-pointer)
 
197
  (rtl:make-machine-register regnum:stack-pointer))
 
198
 
 
199
(define (interpreter-stack-pointer? expression)
 
200
  (and (rtl:register? expression)
 
201
       (= (rtl:register-number expression) regnum:stack-pointer)))
 
202
 
 
203
(define (interpreter-dynamic-link)
 
204
  (rtl:make-machine-register regnum:dynamic-link))
 
205
 
 
206
(define (interpreter-dynamic-link? expression)
 
207
  (and (rtl:register? expression)
 
208
       (= (rtl:register-number expression) regnum:dynamic-link)))
 
209
 
 
210
(define (rtl:machine-register? rtl-register)
 
211
  (case rtl-register
 
212
    ((STACK-POINTER)
 
213
     (interpreter-stack-pointer))
 
214
    ((DYNAMIC-LINK)
 
215
     (interpreter-dynamic-link))
 
216
    ((VALUE)
 
217
     (interpreter-value-register))
 
218
    ((FREE)
 
219
     (interpreter-free-pointer))
 
220
    ((INTERPRETER-CALL-RESULT:ACCESS)
 
221
     (interpreter-register:access))
 
222
    ((INTERPRETER-CALL-RESULT:CACHE-REFERENCE)
 
223
     (interpreter-register:cache-reference))
 
224
    ((INTERPRETER-CALL-RESULT:CACHE-UNASSIGNED?)
 
225
     (interpreter-register:cache-unassigned?))
 
226
    ((INTERPRETER-CALL-RESULT:LOOKUP)
 
227
     (interpreter-register:lookup))
 
228
    ((INTERPRETER-CALL-RESULT:UNASSIGNED?)
 
229
     (interpreter-register:unassigned?))
 
230
    ((INTERPRETER-CALL-RESULT:UNBOUND?)
 
231
     (interpreter-register:unbound?))
 
232
    (else
 
233
     false)))
 
234
 
 
235
(define (rtl:interpreter-register? rtl-register)
 
236
  (case rtl-register
 
237
    ((MEMORY-TOP) 0)
 
238
    ((INT-MASK) 1)
 
239
    #| ((VALUE) 2) |#
 
240
    ((ENVIRONMENT) 3)
 
241
    ((TEMPORARY) 4)
 
242
    (else false)))
 
243
 
 
244
(define (rtl:interpreter-register->offset locative)
 
245
  (or (rtl:interpreter-register? locative)
 
246
      (error "Unknown register type" locative)))
 
247
 
 
248
(define (rtl:constant-cost expression)
 
249
  ;; Magic numbers
 
250
  ;; number of bytes for the instruction to construct/fetch into register.
 
251
  (let ((if-integer
 
252
         (lambda (value)
 
253
           (cond ((zero? value) 2)
 
254
                 ((<= -63 value 63)
 
255
                  3)
 
256
                 (else
 
257
                  7)))))
 
258
    (let ((if-synthesized-constant
 
259
           (lambda (type datum)
 
260
             (if-integer (make-non-pointer-literal type datum)))))
 
261
      (case (rtl:expression-type expression)
 
262
        ((CONSTANT)
 
263
         (let ((value (rtl:constant-value expression)))
 
264
           (if (non-pointer-object? value)
 
265
               (if-synthesized-constant (object-type value)
 
266
                                        (careful-object-datum value))
 
267
               3)))
 
268
        ((MACHINE-CONSTANT)
 
269
         (if-integer (rtl:machine-constant-value expression)))
 
270
        ((ENTRY:PROCEDURE
 
271
          ENTRY:CONTINUATION
 
272
          ASSIGNMENT-CACHE
 
273
          VARIABLE-CACHE
 
274
          OFFSET-ADDRESS
 
275
          BYTE-OFFSET-ADDRESS)
 
276
         4)                             ; assuming word offset
 
277
        ((CONS-POINTER)
 
278
         (and (rtl:machine-constant? (rtl:cons-pointer-type expression))
 
279
              (rtl:machine-constant? (rtl:cons-pointer-datum expression))
 
280
              (if-synthesized-constant
 
281
               (rtl:machine-constant-value (rtl:cons-pointer-type expression))
 
282
               (rtl:machine-constant-value
 
283
                (rtl:cons-pointer-datum expression)))))
 
284
        (else false)))))
 
285
 
 
286
;;; Floating-point open-coding not implemented for VAXen.
 
287
 
 
288
(define compiler:open-code-floating-point-arithmetic?
 
289
  false)
 
290
 
 
291
(define compiler:primitives-with-no-open-coding
 
292
  '(DIVIDE-FIXNUM GCD-FIXNUM &/
 
293
    VECTOR-CONS STRING-ALLOCATE FLOATING-VECTOR-CONS
 
294
    FLOATING-VECTOR-REF FLOATING-VECTOR-SET!))
 
 
b'\\ No newline at end of file'