← Back to branch summary

~ubuntu-branches/ubuntu/trusty/mit-scheme/trusty-proposed

« back to all changes in this revision

Viewing changes to src/compiler/machines/C/traditional.scm

  • Committer: Bazaar Package Importer
  • Author(s): Soren Hansen
  • Date: 2007-05-09 10:57:57 UTC
  • mfrom: (1.1.5 upstream)
  • Revision ID: james.westby@ubuntu.com-20070509105757-p8focimovgqxaaed
Tags: 7.7.90+20070205-1ubuntu1
* Merge from debian unstable, remaining changes:
  * Bootstrapping done via supplied binary package. See log entry for
    7.7.90+20060906-3ubuntu1 for details.

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/compiler/machines/C/traditional.scm
 
1
#| -*-Scheme-*-
 
2
 
 
3
$Id: traditional.scm,v 1.6 2007/01/05 21:19:20 cph Exp $
 
4
 
 
5
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
 
6
    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
 
7
    2006, 2007 Massachusetts Institute of Technology
 
8
 
 
9
This file is part of MIT/GNU Scheme.
 
10
 
 
11
MIT/GNU Scheme is free software; you can redistribute it and/or modify
 
12
it under the terms of the GNU General Public License as published by
 
13
the Free Software Foundation; either version 2 of the License, or (at
 
14
your option) any later version.
 
15
 
 
16
MIT/GNU Scheme is distributed in the hope that it will be useful, but
 
17
WITHOUT ANY WARRANTY; without even the implied warranty of
 
18
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 
19
General Public License for more details.
 
20
 
 
21
You should have received a copy of the GNU General Public License
 
22
along with MIT/GNU Scheme; if not, write to the Free Software
 
23
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
 
24
USA.
 
25
 
 
26
|#
 
27
 
 
28
;;;; C-output fake assembler and linker
 
29
;; package: (compiler lap-syntaxer)
 
30
 
 
31
(declare (usual-integrations))
 
32
 
 
33
;;;; Object constructors
 
34
;; This is the 'traditional' way, i.e. when stackify is not used
 
35
;; It generates C code to explicitly construct the objects.
 
36
 
 
37
(define (->constructors names objects)
 
38
  (let ((table (build-table objects)))
 
39
    (receive (prefix suffix) (top-level-constructors table)
 
40
      (values prefix
 
41
              (c:group suffix
 
42
                       (c:group* (map (lambda (object&name)
 
43
                                        (top-level-updater object&name table))
 
44
                                      table))
 
45
                       (c:group*
 
46
                        (map (lambda (name object)
 
47
                               (c:= name (constructor object table)))
 
48
                             names
 
49
                             objects)))))))
 
50
 
 
51
(define (build-table nodes)
 
52
  (map cdr
 
53
       (sort (sort/enumerate
 
54
              (keep-matching-items
 
55
                  (let loop ((nodes nodes) (table '()))
 
56
                    (if (pair? nodes)
 
57
                        (loop (cdr nodes)
 
58
                              (insert-in-table (car nodes) 0 table))
 
59
                        table))
 
60
                cdr))
 
61
             (lambda (entry1 entry2)
 
62
               (let ((obj1 (cadr entry1))
 
63
                     (obj2 (cadr entry2)))
 
64
                 (if (fake-compiled-block? obj1)
 
65
                     (if (fake-compiled-block? obj2)
 
66
                         (< (fake-block/index obj1)
 
67
                            (fake-block/index obj2))
 
68
                         #t)
 
69
                     (if (fake-compiled-block? obj2)
 
70
                         #f
 
71
                         (< (car entry1) (car entry2)))))))))
 
72
 
 
73
(define-integrable (table/find table value)
 
74
  ;; assv ?
 
75
  (assq value table))  
 
76
 
 
77
(define (top-level-constructors table)
 
78
  (let loop ((table (reverse table)) (prefix (c:group)) (suffix (c:group)))
 
79
    (if (pair? table)
 
80
        (receive (prefix* suffix*) (top-level-constructor (car table))
 
81
          (loop (cdr table)
 
82
                (c:group prefix* prefix)
 
83
                (c:group suffix* suffix)))
 
84
        (values prefix suffix))))
 
85
 
 
86
(define (top-level-constructor o.n)
 
87
  (let ((object (car o.n))
 
88
        (name (cdr o.n)))
 
89
    (cond ((pair? object)
 
90
           (values (c:group)
 
91
                   (c:= name (c:ecall "CONS" #f #f))))
 
92
          ((fake-compiled-block? object)
 
93
           (set! *subblocks* (cons object *subblocks*))
 
94
           (values (c:= name
 
95
                        (c:ecall 'initialize_subblock
 
96
                                 (fake-block/c-proc object)))
 
97
                   (c:group)))
 
98
          ((fake-compiled-procedure? object)
 
99
           (values (c:group)
 
100
                   (c:= name (compiled-procedure-constructor object))))
 
101
          ((reference-trap? object)
 
102
           (if (not (unassigned-reference-trap? object))
 
103
               (error "Can't dump reference trap:" object))
 
104
           (values (c:group)
 
105
                   (c:= name (->simple-C-object object))))
 
106
          ((%record? object)
 
107
           (values (c:group)
 
108
                   (c:= name
 
109
                        (c:ecall "ALLOCATE_RECORD" (%record-length object)))))
 
110
          ((vector? object)
 
111
           (values (c:group)
 
112
                   (c:= name
 
113
                        (c:ecall "ALLOCATE_VECTOR" (vector-length object)))))
 
114
          (else
 
115
           (values (c:group)
 
116
                   (c:= name (->simple-C-object object)))))))
 
117
 
 
118
(define (top-level-updater o.n table)
 
119
  (let ((object (car o.n))
 
120
        (name (cdr o.n)))
 
121
 
 
122
    (define-integrable (do-vector-like object vlength vref vset-name)
 
123
      (let loop ((i (vlength object)) (code (c:group)))
 
124
        (if (zero? i)
 
125
            code
 
126
            (let ((i-1 (- i 1)))
 
127
              (loop i-1
 
128
                    (c:group (c:scall vset-name
 
129
                                      name
 
130
                                      i-1
 
131
                                      (constructor (vref object i-1) table))
 
132
                             code))))))
 
133
 
 
134
    (cond ((pair? object)
 
135
           (c:group (c:scall "SET_PAIR_CAR"
 
136
                             name
 
137
                             (constructor (car object) table))
 
138
                    (c:scall "SET_PAIR_CDR"
 
139
                             name
 
140
                             (constructor (cdr object) table))))
 
141
          ((or (fake-compiled-block? object)
 
142
               (fake-compiled-procedure? object)
 
143
               (reference-trap? object))
 
144
           (c:group))
 
145
          ((%record? object)
 
146
           (do-vector-like object %record-length %record-ref "RECORD_SET"))
 
147
          ((vector? object)
 
148
           (do-vector-like object vector-length vector-ref "VECTOR_SET"))
 
149
          (else
 
150
           (c:group)))))
 
151
 
 
152
(define (constructor object table)
 
153
  (let process ((object object))
 
154
    (cond ((table/find table object) => cdr)
 
155
          ((pair? object)
 
156
           (let ((elts
 
157
                  (let loop
 
158
                      ((object (cdr object))
 
159
                       (elts (list (process (car object)))))
 
160
                    (if (pair? object)
 
161
                        (let ((p (table/find table object)))
 
162
                          (if p
 
163
                              (cons p elts)
 
164
                              (loop (cdr object)
 
165
                                    (cons (process (car object))
 
166
                                          elts))))
 
167
                        (cons object elts)))))
 
168
             (let ((n-elts (length elts)))
 
169
               (if (fix:= n-elts 2)
 
170
                   (c:ecall "CONS" (cadr elts) (car elts))
 
171
                   (apply c:ecall "RCONSM" n-elts elts)))))
 
172
          ((fake-compiled-procedure? object)
 
173
           (compiled-procedure-constructor object))
 
174
          ((reference-trap? object)
 
175
           (->simple-C-object object))
 
176
          ((or (fake-compiled-block? object)
 
177
               (vector? object)
 
178
               (%record? object))
 
179
           (error "constructor: Can't build directly:" object))
 
180
          (else
 
181
           (->simple-C-object object)))))
 
182
 
 
183
(define (compiled-procedure-constructor object)
 
184
  (c:ecall "CC_BLOCK_TO_ENTRY"
 
185
           (fake-procedure/block-name object)
 
186
           (fake-procedure/label-tag object)))
 
187
 
 
188
(define (->simple-C-object object)
 
189
  (cond ((symbol? object)
 
190
         (let ((name (symbol->string object)))
 
191
           (c:ecall "C_SYM_INTERN"
 
192
                    (string-length name)
 
193
                    (c:string (C-quotify-string name)))))
 
194
        ((string? object)
 
195
         (c:ecall "C_STRING_TO_SCHEME_STRING"
 
196
                  (string-length object)
 
197
                  (c:string (C-quotify-string object))))
 
198
        ((number? object)
 
199
         (let process ((number object))
 
200
           (cond ((flo:flonum? number)
 
201
                  (c:ecall "DOUBLE_TO_FLONUM" number))
 
202
                 ((guaranteed-long? number)
 
203
                  (c:ecall "LONG_TO_INTEGER" number))
 
204
                 ((exact-integer? number)
 
205
                  (let ((bignum-string
 
206
                         (number->string (if (negative? number)
 
207
                                             (- number)
 
208
                                             number)
 
209
                                         16)))
 
210
                    (c:ecall "DIGIT_STRING_TO_INTEGER"
 
211
                             (negative? number)
 
212
                             (string-length bignum-string)
 
213
                             bignum-string)))
 
214
                 ((and (exact? number) (rational? number))
 
215
                  (c:ecall "MAKE_RATIO"
 
216
                           (process (numerator number))
 
217
                           (process (denominator number))))
 
218
                 ((and (complex? number) (not (real? number)))
 
219
                  (c:ecall "MAKE_complext"
 
220
                           (process (real-part number))
 
221
                           (process (imag-part number))))
 
222
                 (else
 
223
                  (error "->simple-C-object: Unknown number:" number)))))
 
224
        ((not object) "SHARP_F")
 
225
        ((eq? #t object) "SHARP_T")
 
226
        ((null? object) "EMPTY_LIST")
 
227
        ((eq? object unspecific) "UNSPECIFIC")
 
228
        ((primitive-procedure? object)
 
229
         (let ((arity (primitive-procedure-arity object)))
 
230
           (if (< arity -1)
 
231
               (error "->simple-C-object: Unknown arity primitive:" object))
 
232
           (c:ecall "MAKE_PRIMITIVE_PROCEDURE"
 
233
                    (c:string (primitive-procedure-name object))
 
234
                    arity)))
 
235
        ((char? object)
 
236
         (c:ecall "MAKE_CHAR"
 
237
                  (c:hex (char-bits object))
 
238
                  (c:hex (char-code object))))
 
239
        ((bit-string? object)
 
240
         (let ((string
 
241
                (number->string (bit-string->unsigned-integer object) 16)))
 
242
           (c:ecall "DIGIT_STRING_TO_BIT_STRING"
 
243
                    (bit-string-length object)
 
244
                    (string-length string)
 
245
                    (c:string (string-reverse string)))))
 
246
        ;; This one is here for multi-definitions with no initial value
 
247
        ((unassigned-reference-trap? object)
 
248
         "UNASSIGNED_OBJECT")
 
249
        ((object-non-pointer? object)
 
250
         (c:make-object (c:hex (object-type object))
 
251
                        (c:hex (object-datum object))))
 
252
        (else
 
253
         (error "->simple-C-object: unrecognized object:" object))))
 
254
 
 
255
;;; Hack to make sort a stable sort
 
256
 
 
257
(define (sort/enumerate l)
 
258
  (let loop ((l l) (n 0) (l* '()))
 
259
    (if (null? l)
 
260
        l*
 
261
        (loop (cdr l)
 
262
              (+ n 1)
 
263
              (cons (cons n (car l)) l*)))))
 
264
 
 
265
(define (insert-in-table node depth table)
 
266
  (cond ((or (not node)
 
267
             (eq? node #t)
 
268
             (null? node)
 
269
             (eq? node unspecific)
 
270
             (guaranteed-fixnum? node)
 
271
             (reference-trap? node))
 
272
         table)
 
273
        ((table/find table node)
 
274
         => (lambda (pair)
 
275
              (if (not (cdr pair))
 
276
                  (set-cdr! pair (generate-variable-name)))
 
277
              table))
 
278
        (else
 
279
         (let* ((name (name-if-complicated node depth))
 
280
                (depth* (if name 1 (+ depth 1)))
 
281
                (table (cons (cons node name) table)))
 
282
 
 
283
           (define-integrable (do-vector-like node vlength vref)
 
284
             (let loop ((table table) (i (vlength node)))
 
285
               (if (fix:> i 0)
 
286
                   (loop (insert-in-table (vref node (fix:- i 1))
 
287
                                          depth*
 
288
                                          table)
 
289
                         (fix:- i 1))
 
290
                   table)))
 
291
             
 
292
           (cond ((pair? node)
 
293
                  ;; Special treatment on the CDR because of RCONSM.
 
294
                  (insert-in-table
 
295
                   (car node)
 
296
                   depth*
 
297
                   (insert-in-table (cdr node)
 
298
                                    (if name 1 depth)
 
299
                                    table)))
 
300
                 ((vector? node)
 
301
                  (do-vector-like node vector-length vector-ref))
 
302
                 ((or (fake-compiled-procedure? node)
 
303
                      (fake-compiled-block? node))
 
304
                  table)
 
305
                 ((%record? node)
 
306
                  (do-vector-like node %record-length %record-ref))
 
307
                 ;; Atom
 
308
                 (else table))))))
 
309
 
 
310
(define num)
 
311
(define new-variables)
 
312
(define *depth-limit* 2)
 
313
 
 
314
(define (generate-variable-name)
 
315
  (let ((var (string-append "tmpObj" (number->string num))))
 
316
    (set! new-variables (cons var new-variables))
 
317
    (set! num (+ num 1))
 
318
    var))
 
319
 
 
320
(define (name-if-complicated node depth)
 
321
  (cond ((fake-compiled-block? node)
 
322
         (let ((name (fake-block/name node)))
 
323
           (set! new-variables (cons name new-variables))
 
324
           name))
 
325
        ((or (%record? node)
 
326
             (vector? node)
 
327
             (> depth *depth-limit*))
 
328
         (generate-variable-name))
 
329
        (else #f)))
 
 
b'\\ No newline at end of file'