← Back to branch summary

~ubuntu-branches/ubuntu/quantal/gclcvs/quantal

« back to all changes in this revision

Viewing changes to cmpnew/gcl_cmplet.lsp

  • Committer: Bazaar Package Importer
  • Author(s): Camm Maguire
  • Date: 2004-06-24 15:13:46 UTC
  • Revision ID: james.westby@ubuntu.com-20040624151346-xh0xaaktyyp7aorc
Tags: 2.7.0-26
C_GC_OFFSET is 2 on m68k-linux

Show diffs side-by-side

added added

removed removed

Lines of Context:
cmpnew/gcl_cmplet.lsp
 
1
;;; CMPLET  Let and Let*.
 
2
;;;
 
3
;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
 
4
 
 
5
;; This file is part of GNU Common Lisp, herein referred to as GCL
 
6
;;
 
7
;; GCL is free software; you can redistribute it and/or modify it under
 
8
;;  the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
 
9
;; the Free Software Foundation; either version 2, or (at your option)
 
10
;; any later version.
 
11
;; 
 
12
;; GCL is distributed in the hope that it will be useful, but WITHOUT
 
13
;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
 
14
;; FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library General Public 
 
15
;; License for more details.
 
16
;; 
 
17
;; You should have received a copy of the GNU Library General Public License 
 
18
;; along with GCL; see the file COPYING.  If not, write to the Free Software
 
19
;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
 
20
 
 
21
 
 
22
(in-package 'compiler)
 
23
(eval-when (compile)
 
24
  (or (fboundp 'write-block-open) (load "cmplet.lsp")))
 
25
 
 
26
(si:putprop 'let 'c1let 'c1special)
 
27
(si:putprop 'let 'c2let 'c2)
 
28
(si:putprop 'let* 'c1let* 'c1special)
 
29
(si:putprop 'let* 'c2let* 'c2)
 
30
 
 
31
(defun c1let (args &aux (info (make-info))(setjmps *setjmps*)
 
32
                        (forms nil) (vars nil) (vnames nil)
 
33
                        ss is ts body other-decls
 
34
                        (*vars* *vars*))
 
35
  (when (endp args) (too-few-args 'let 1 0))
 
36
 
 
37
  (multiple-value-setq (body ss ts is other-decls) (c1body (cdr args) nil))
 
38
 
 
39
  (c1add-globals ss)
 
40
 
 
41
  (dolist** (x (car args))
 
42
    (cond ((symbolp x)
 
43
           (let ((v (c1make-var x ss is ts)))
 
44
                (push x vnames)
 
45
                (push v vars)
 
46
                (push (default-init (var-type v)) forms)))
 
47
          (t (cmpck (not (and (consp x) (or (endp (cdr x)) (endp (cddr x)))))
 
48
                    "The variable binding ~s is illegal." x)
 
49
             (let ((v (c1make-var (car x) ss is ts)))
 
50
                  (push (car x) vnames)
 
51
                  (push v vars)
 
52
                  (push (if (endp (cdr x))
 
53
                            (default-init (var-type v))
 
54
                            (and-form-type (var-type v)
 
55
                                           (c1expr* (cadr x) info)
 
56
                                           (cadr x)))
 
57
                        forms)))))
 
58
 
 
59
  (dolist* (v (reverse vars)) (push v *vars*))
 
60
 
 
61
  (check-vdecl vnames ts is)
 
62
 
 
63
  (setq body (c1decl-body other-decls body))
 
64
 
 
65
  (add-info info (cadr body))
 
66
  (setf (info-type info) (info-type (cadr body)))
 
67
 
 
68
  (dolist** (var vars) (check-vref var))
 
69
 
 
70
 
 
71
    (or (eql setjmps *setjmps*) (setf (info-volatile info) t))
 
72
        (list 'let info (reverse vars) (reverse forms) body)
 
73
  )
 
74
 
 
75
(defun c2let (vars forms body
 
76
                   &aux (block-p nil) (bindings nil) initials
 
77
                  
 
78
                        (*unwind-exit* *unwind-exit*)
 
79
                        (*vs* *vs*) (*clink* *clink*) (*ccb-vs* *ccb-vs*))
 
80
       (declare (object block-p))
 
81
 
 
82
  (do ((vl vars (cdr vl)) (fl forms (cdr fl)) (prev-ss nil))
 
83
      ((endp vl))
 
84
      (declare (object vl fl))
 
85
      (let* ((form (car fl)) (var (car vl))
 
86
            (kind (c2var-kind var)))
 
87
           (declare (object form var))
 
88
          (cond (kind  (setf (var-kind var) kind)
 
89
                       (setf (var-loc var) (next-cvar)))
 
90
                ((eq (var-kind var) 'down)
 
91
                 (or (si::fixnump (var-loc var)) (wfs-error)))
 
92
                (t (setf (var-ref var) (vs-push))))
 
93
        (case (var-kind var)
 
94
          ((FIXNUM CHARACTER LONG-FLOAT SHORT-FLOAT INTEGER)
 
95
           (push (list 'c2expr* (list 'var var nil) form)  initials))
 
96
          (otherwise
 
97
            (case (car form)
 
98
              (LOCATION
 
99
               (if (can-be-replaced var body)
 
100
                   (progn (setf (var-kind var) 'REPLACED)
 
101
                          (setf (var-loc var) (caddr form)))
 
102
                   (push (list var (caddr form)) bindings)))
 
103
              (VAR
 
104
               (let ((var1 (caaddr form)))
 
105
                    (declare (object var1))
 
106
                    (cond ((or (args-info-changed-vars var1 (cdr fl))
 
107
                               (and (member (var-kind var1) '(SPECIAL GLOBAL))
 
108
                                    (member (var-name var1) prev-ss)))
 
109
                           (push (list 'c2expr*
 
110
                                       (cond ((eq (var-kind var) 'object)
 
111
                                              (list 'var var nil))
 
112
                                             ((eq (var-kind var) 'down)
 
113
                                              ;(push (list var) bindings)
 
114
                                              (list 'down (var-loc var)))
 
115
                                             (t(push (list var) bindings)
 
116
                                              (list 'vs (var-ref var))))
 
117
                                       form)initials))
 
118
                          ((and (can-be-replaced var body)
 
119
                                (member (var-kind var1)
 
120
                                        '(LEXICAL REPLACED OBJECT))
 
121
                                (null (var-ref-ccb var1))
 
122
                                (not (is-changed  var1 (cadr body))))
 
123
                           (setf (var-kind var) 'REPLACED)
 
124
                           (setf (var-loc var)
 
125
                                 (case (var-kind var1)
 
126
                                   (LEXICAL (list 'vs (var-ref var1)))
 
127
                                   (REPLACED (var-loc var1))
 
128
                                   (OBJECT (list 'cvar (var-loc var1)))
 
129
                                   (otherwise (baboon)))))
 
130
                          (t (push (list var
 
131
                                         (list 'var var1 (cadr (caddr form))))
 
132
                                   bindings)))))
 
133
              (t (push (list 'c2expr*
 
134
                             (cond ((eq (var-kind var) 'object)
 
135
                                    (list 'var var nil))
 
136
                                   ((eq (var-kind var) 'down)
 
137
                                    ;(push (list var) bindings)
 
138
                                    (list 'down (var-loc var)))
 
139
                                   (t(push (list var) bindings)
 
140
                                    (list 'vs (var-ref var))))
 
141
                             form) initials))
 
142
              )))
 
143
        (when (eq (var-kind var) 'SPECIAL) (push (var-name var) prev-ss))
 
144
        ))
 
145
 
 
146
  (setq block-p (write-block-open vars))
 
147
 
 
148
  (dolist* (binding (reverse initials))
 
149
           (let ((*value-to-go* (second binding)))
 
150
              (c2expr* (third binding))))
 
151
  (dolist* (binding (reverse bindings))
 
152
    (if (cdr binding)
 
153
        (c2bind-loc (car binding) (cadr binding))
 
154
        (c2bind (car binding))))
 
155
 
 
156
  (c2expr body)
 
157
  (when block-p (wt "}"))
 
158
  )
 
159
 
 
160
(defun c1let* (args &aux (forms nil) (vars nil) (vnames nil)
 
161
                (setjmps *setjmps*)
 
162
                    ss is ts body other-decls
 
163
                    (info (make-info)) (*vars* *vars*))
 
164
  (when (endp args) (too-few-args 'let* 1 0))
 
165
 
 
166
  (multiple-value-setq (body ss ts is other-decls) (c1body (cdr args) nil))
 
167
  (c1add-globals ss)
 
168
 
 
169
  (dolist** (x (car args))
 
170
    (cond ((symbolp x)
 
171
           (let ((v (c1make-var x ss is ts)))
 
172
                (push x vnames)
 
173
                (push (default-init (var-type v)) forms)
 
174
                (push v vars)
 
175
                (push v *vars*)))
 
176
          ((not (and (consp x) (or (endp (cdr x)) (endp (cddr x)))))
 
177
           (cmperr "The variable binding ~s is illegal." x))
 
178
          (t (let ((v (c1make-var (car x) ss is ts)))
 
179
                  (push (car x) vnames)
 
180
                  (push (if (endp (cdr x))
 
181
                            (default-init (var-type v))
 
182
                            (and-form-type (var-type v)
 
183
                                           (c1expr* (cadr x) info)
 
184
                                           (cadr x)))
 
185
                        forms)
 
186
                  (push v vars)
 
187
                  (push v *vars*)))))
 
188
 
 
189
  (check-vdecl vnames ts is)
 
190
  (setq body (c1decl-body other-decls body))
 
191
  (add-info info (cadr body))
 
192
  (setf (info-type info) (info-type (cadr body)))
 
193
  (dolist** (var vars) (check-vref var))
 
194
(or (eql setjmps *setjmps*) (setf (info-volatile info) t))
 
195
  (list 'let*  info (reverse vars) (reverse forms) body)
 
196
  )
 
197
 
 
198
(defun c2let* (vars forms body
 
199
                    &aux (block-p nil)
 
200
                    (*unwind-exit* *unwind-exit*)
 
201
                    (*vs* *vs*) (*clink* *clink*) (*ccb-vs* *ccb-vs*))
 
202
       (declare (object block-p))
 
203
 
 
204
 
 
205
  (do ((vl vars (cdr vl))
 
206
       (fl forms (cdr fl)))
 
207
      ((endp vl))
 
208
      (declare (object vl fl))
 
209
      (let* ((form (car fl)) (var (car vl))
 
210
             (kind (c2var-kind var)))
 
211
           (declare (object form var))
 
212
          (cond (kind  (setf (var-kind var) kind)
 
213
                       (setf (var-loc var) (next-cvar))))
 
214
        (if (member (var-kind var)
 
215
                    '(FIXNUM CHARACTER LONG-FLOAT SHORT-FLOAT INTEGER))
 
216
            nil
 
217
            (case (car form)
 
218
              (LOCATION
 
219
               (cond ((can-be-replaced* var body (cdr fl))
 
220
                      (setf (var-kind var) 'REPLACED)
 
221
                      (setf (var-loc var) (caddr form)))
 
222
                     ((eq (var-kind var) 'object))
 
223
                     ((eq (var-kind var) 'down)
 
224
                      (or (si::fixnump (var-loc var)) (baboon)))
 
225
                     (t (setf (var-ref var) (vs-push))
 
226
                        )))
 
227
              (VAR
 
228
               (let ((var1 (caaddr form)))
 
229
                    (declare (object var1))
 
230
                    (cond ((and (can-be-replaced* var body (cdr fl))
 
231
                                (member (var-kind var1)
 
232
                                        '(LEXICAL REPLACED OBJECT))
 
233
                                (null (var-ref-ccb var1))
 
234
                                (not (args-info-changed-vars var1 (cdr fl)))
 
235
                                (not (is-changed var1 (cadr body))))
 
236
                           (setf (var-kind var) 'REPLACED)
 
237
                           (setf (var-loc var)
 
238
                                 (case (var-kind var1)
 
239
                                   (LEXICAL (list 'vs (var-ref var1)))
 
240
                                   (REPLACED (var-loc var1))
 
241
                                   (OBJECT (list 'cvar (var-loc var1)))
 
242
                                   (t (baboon)))))
 
243
                          ((eq (var-kind var)'object))
 
244
                          (t (setf (var-ref var) (vs-push))
 
245
                             )))
 
246
           )
 
247
          ((eq (var-kind var) 'object))    
 
248
          (t (setf (var-ref var) (vs-push))
 
249
             )))
 
250
        ))
 
251
 
 
252
  (setq block-p (write-block-open vars))
 
253
 
 
254
  (do ((vl vars (cdr vl))
 
255
        (fl forms (cdr fl))
 
256
        (var nil) (form nil))
 
257
      ((null vl))
 
258
      (setq var (car vl))(setq form (car fl))
 
259
;      (print (list (var-kind var) (car form)))
 
260
      (case
 
261
       (var-kind var)
 
262
       ((FIXNUM CHARACTER LONG-FLOAT SHORT-FLOAT OBJECT  INTEGER)
 
263
        (let ((*value-to-go* (list 'var var nil)))
 
264
          (c2expr* form)))
 
265
       (REPLACED )
 
266
       (t
 
267
        (case
 
268
         (car form)
 
269
         (LOCATION (c2bind-loc var (caddr form)))
 
270
         (VAR (c2bind-loc var (list 'var (caaddr form) (cadr (caddr form)))))
 
271
         (t (c2bind-init var form))))))
 
272
           
 
273
  (c2expr body)
 
274
 
 
275
  (when block-p (wt "}"))
 
276
  )
 
277
 
 
278
(defun can-be-replaced (var body)
 
279
  (and (or (eq (var-kind var) 'LEXICAL)
 
280
           (and (eq (var-kind var) 'object)
 
281
                (< (the fixnum (var-register var))
 
282
                   (the fixnum *register-min*))))
 
283
       (null (var-ref-ccb var))
 
284
       (not (eq (var-loc var) 'clb))
 
285
       (not (is-changed var (cadr body)))))
 
286
 
 
287
(defun can-be-replaced* (var body forms)
 
288
  (and (can-be-replaced var body)
 
289
       (dolist** (form forms t)
 
290
         (when (is-changed var (cadr form))
 
291
               (return nil)))
 
292
       ))
 
293
 
 
294
 
 
295
(defun write-block-open (vars)
 
296
  (let ( block-p)
 
297
    (dolist**
 
298
     (var vars)
 
299
     (let ((kind (var-kind var)))
 
300
       (declare (object kind))
 
301
       (when (member kind '(FIXNUM CHARACTER LONG-FLOAT SHORT-FLOAT OBJECT
 
302
                                   INTEGER))
 
303
             (wt-nl)
 
304
             (unless block-p (wt "{") (setq block-p t))
 
305
             (wt-var-decl var)
 
306
             )))
 
307
    block-p ))
 
308
 
 
309
 
 
310
;; ---------- stack-let for consing on stack ---------
 
311
 
 
312
;; Usage:  (stack-let ((a (cons 1 2)) (b (cons 3 4))) (foo a) (print b) 7)
 
313
;;  where foo must not keep a copy of `a', since the cons will be formed
 
314
;;  on the c stack.
 
315
 
 
316
(setf (get 'stack-let 'c1special) 'c1stack-let)
 
317
 
 
318
(defmacro stack-let (&rest x) (cons `let x))
 
319
 
 
320
(defun c1stack-let (args &aux npairs nums)
 
321
  (let ((pairs (car args))
 
322
        )
 
323
    (dolist (v pairs)
 
324
            (push
 
325
             (cond ((atom v) v)
 
326
                   ((let ((var (car v))
 
327
                          (val (second v)))
 
328
                      (and (consp val)
 
329
                           (or (eq (car val) 'cons)
 
330
                               (and (eq (car val) 'list)
 
331
                                    (null (cddr val))
 
332
                                    (setq val `(cons ,(second val) nil))))
 
333
                           (progn
 
334
                             (push (next-cvar) nums)
 
335
                             `(,var (stack-cons ,(car nums) ,@ (cdr val)))))))
 
336
                   (t (cmpwarn "Stack let = regular let for ~a ~a"
 
337
                               v (cdr args))
 
338
                      v))
 
339
             npairs))
 
340
    (let ((result (c1expr (cons 'let (cons (nreverse npairs) (cdr args))))))
 
341
      (list 'stack-let (second result) nums result))))
 
342
 
 
343
(setf (get 'stack-let 'c2) 'c2stack-let)
 
344
 
 
345
(defun c2stack-let (nums form)
 
346
  (let ((n (next-cvar)))
 
347
    (wt-nl "{Cons_Macro" n ";")
 
348
    (c2expr form)
 
349
    (wt "}")
 
350
    (wt-h
 
351
     "#define Cons_Macro" n (format nil " struct cons ~{STcons~a ~^,~};" nums)
 
352
     )))
 
353
 
 
354
(push '((fixnum t t) t #.(flags) 
 
355
        "(STcons#0.t=t_cons,STcons#0.m=0,STcons#0.c_car=(#1),
 
356
              STcons#0.c_cdr=(#2),(object)&STcons#0)")
 
357
        (get 'stack-cons 'inline-always))    
 
358
 
 
359
;; ---------- end stack-let for consing on stack ---------
 
360