cmpflet.lsp 10.8 KB
Newer Older
1
2
3
;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil; Package: C -*-
;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab:

jgarcia's avatar
jgarcia committed
4
;;;;
jjgarcia's avatar
jjgarcia committed
5
6
7
8
9
10
11
12
13
14
15
16
17
18
;;;;  CMPFLET  Flet, Labels, and Macrolet.

;;;;  Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya.
;;;;  Copyright (c) 1990, Giuseppe Attardi.
;;;;
;;;;    This program is free software; you can redistribute it and/or
;;;;    modify it under the terms of the GNU Library General Public
;;;;    License as published by the Free Software Foundation; either
;;;;    version 2 of the License, or (at your option) any later version.
;;;;
;;;;    See file '../Copyright' for full details.

(in-package "COMPILER")

jjgarcia's avatar
jjgarcia committed
19
20
21
22
23
24
(defun c1labels (args) (c1labels/flet 'LABELS args))

(defun c1flet (args) (c1labels/flet 'FLET args))

(defun c1labels/flet (origin args)
  (check-args-number origin args 1)
25
  (let ((new-env (cmp-env-copy))
Daniel Kochmański's avatar
Daniel Kochmański committed
26
27
28
29
        (defs '())
        (local-funs '())
        (fnames '())
        body-c1form)
jjgarcia's avatar
jjgarcia committed
30
31
32
    ;; On a first round, we extract the definitions of the functions,
    ;; and build empty function objects that record the references to
    ;; this functions in the processed body. In the end
Daniel Kochmański's avatar
Daniel Kochmański committed
33
    ;;  DEFS = ( { ( fun-object  function-body ) }* ).
jjgarcia's avatar
jjgarcia committed
34
35
    (dolist (def (car args))
      (cmpck (or (endp def)
Daniel Kochmański's avatar
Daniel Kochmański committed
36
37
38
                 (not (si::valid-function-name-p (car def)))
                 (endp (cdr def)))
             "The local function definition ~s is illegal." def)
jjgarcia's avatar
jjgarcia committed
39
      (cmpck (member (car def) fnames)
40
             "~s: The function ~s was already defined." origin (car def))
jjgarcia's avatar
jjgarcia committed
41
      (push (car def) fnames)
42
      (let* ((name (car def))
Daniel Kochmański's avatar
Daniel Kochmański committed
43
44
45
46
             (var (make-var :name name :kind :object))
             (fun (make-fun :name name :var var)))
        (cmp-env-register-function fun new-env)
        (push (cons fun (cdr def)) defs)))
jjgarcia's avatar
jjgarcia committed
47

48
49
    ;; Now we compile the functions, either in the current environment
    ;; or in an empty environment in which there are no new functions
50
    (let ((*cmp-env* (cmp-env-copy (if (eq origin 'FLET) *cmp-env* new-env))))
51
      (dolist (def (nreverse defs))
Daniel Kochmański's avatar
Daniel Kochmański committed
52
53
        (let ((fun (first def)))
          ;; The closure type will be fixed later on by COMPUTE-...
54
          (push (c1compile-function (rest def) :fun fun)
Daniel Kochmański's avatar
Daniel Kochmański committed
55
                local-funs))))
56
57
58

    ;; When we are in a LABELs form, we have to propagate the external
    ;; variables from one function to the other functions that use it.
59
    (when (eq origin 'LABELS)
60
      (loop for change = nil
Daniel Kochmański's avatar
Daniel Kochmański committed
61
62
63
64
65
66
67
68
69
70
         do (loop for f1 in local-funs
               for vars = (fun-referenced-vars f1)
               for funs = (fun-referenced-funs f1)
               do (loop for f2 in (fun-referencing-funs f1)
                     for c1 = (add-to-fun-referenced-vars f2 vars)
                     for c2 = (add-to-fun-referenced-funs f2 funs)
                     for c3 = (update-fun-closure-type f2)
                     when (or c1 c2 c3)
                     do (setf change t)))
         do (unless change (return))))
71
72

    ;; Now we can compile the body itself.
73
    (let ((*cmp-env* new-env))
74
      (multiple-value-bind (body ss ts is other-decl)
Daniel Kochmański's avatar
Daniel Kochmański committed
75
          (c1body (rest args) t)
76
        (mapc #'cmp-env-declare-special ss)
Daniel Kochmański's avatar
Daniel Kochmański committed
77
78
        (check-vdecl nil ts is)
        (setq body-c1form (c1decl-body other-decl body))))
jjgarcia's avatar
jjgarcia committed
79
80
81
82
83
84

    ;; Keep only functions that have been referenced at least once.
    ;; It is not possible to look at FUN-REF before because functions
    ;; in a LABELS can reference each other.
    (setf local-funs (remove-if-not #'plusp local-funs :key #'fun-ref))

85
86
87
    ;; Keep on inspecting the functions until the closure type does not
    ;; change.
    (loop while
Daniel Kochmański's avatar
Daniel Kochmański committed
88
89
90
91
92
         (let ((x nil))
           (loop for f in local-funs
              when (update-fun-closure-type f)
              do (setf x t))
           x))
93

jjgarcia's avatar
jjgarcia committed
94
    (if local-funs
Daniel Kochmański's avatar
Daniel Kochmański committed
95
96
97
        (make-c1form* 'LOCALS :type (c1form-type body-c1form)
                      :args local-funs body-c1form (eq origin 'LABELS))
        body-c1form)))
jjgarcia's avatar
jjgarcia committed
98

99
(defun child-function-p (presumed-parent fun)
100
  (declare (optimize speed))
101
102
103
  (loop for real-parent = (fun-parent fun)
     while real-parent
     do (if (eq real-parent presumed-parent)
Daniel Kochmański's avatar
Daniel Kochmański committed
104
105
            (return t)
            (setf fun real-parent))))
106

107
108
(defun compute-closure-type (fun)
  (declare (si::c-local))
109
  (let ((lexical-closure-p nil))
110
111
    ;; it will have a full closure if it refers external non-global variables
    (dolist (var (fun-referenced-vars fun))
112
      (cond ((global-var-p var))
Daniel Kochmański's avatar
Daniel Kochmański committed
113
114
115
116
117
            ;; ...across CB
            ((ref-ref-ccb var)
             (return-from compute-closure-type 'CLOSURE))
            (t
             (setf lexical-closure-p t))))
118
119
120
    ;; ...or if it directly calls a function
    (dolist (f (fun-referenced-funs fun))
      (unless (child-function-p fun f)
Daniel Kochmański's avatar
Daniel Kochmański committed
121
122
123
124
        ;; .. which has a full closure
        (case (fun-closure f)
          (CLOSURE (return-from compute-closure-type 'CLOSURE))
          (LEXICAL (setf lexical-closure-p t)))))
125
    ;; ...or the function itself is referred across CB
126
127
    (when lexical-closure-p
      (if (or (fun-ref-ccb fun)
Daniel Kochmański's avatar
Daniel Kochmański committed
128
129
130
131
              (and (fun-var fun)
                   (plusp (var-ref (fun-var fun)))))
          'CLOSURE
          'LEXICAL))))
132

133
134
135
136
137
138
139
(defun update-fun-closure-type-many (function-list)
  (do ((finish nil t)
       (recompute nil))
      (finish
       recompute)
    (dolist (f function-list)
      (when (update-fun-closure-type f)
Daniel Kochmański's avatar
Daniel Kochmański committed
140
        (setf recompute t finish nil)))))
141

142
143
144
145
146
(defun prepend-new (l1 l2)
  (loop for f in l1
     do (pushnew f l2))
  l2)

147
148
(defun update-fun-closure-type (fun)
  (let ((old-type (fun-closure fun)))
149
150
    (when (eq old-type 'closure)
      (return-from update-fun-closure-type nil))
jjgarcia's avatar
jjgarcia committed
151
152
    ;; This recursive algorithm is guaranteed to stop when functions
    ;; do not change.
153
    (let ((new-type (compute-closure-type fun))
154
          to-be-updated)
jjgarcia's avatar
jjgarcia committed
155
156
      ;; Same type
      (when (eq new-type old-type)
Daniel Kochmański's avatar
Daniel Kochmański committed
157
        (return-from update-fun-closure-type nil))
158
      (when (fun-global fun)
Daniel Kochmański's avatar
Daniel Kochmański committed
159
160
        (cmpnote "Function ~A is global but is closed over some variables.~%~{~A ~}"
                 (fun-name fun) (mapcar #'var-name (fun-referenced-vars fun))))
161
      (setf to-be-updated (append (fun-child-funs fun) (fun-referencing-funs fun)))
jjgarcia's avatar
jjgarcia committed
162
      (setf (fun-closure fun) new-type)
163
      ;; All external, non-global variables become of type closure
jjgarcia's avatar
jjgarcia committed
164
      (when (eq new-type 'CLOSURE)
Daniel Kochmański's avatar
Daniel Kochmański committed
165
166
167
168
169
170
171
172
173
174
175
176
177
        (dolist (var (fun-referenced-vars fun))
          (unless (or (global-var-p var)
                      (eq (var-kind var) new-type))
            (setf (var-ref-clb var) nil
                  (var-ref-ccb var) t
                  (var-kind var) 'CLOSURE
                  (var-loc var) 'OBJECT
                  to-be-updated
                  (prepend-new (var-functions-reading var)
                               (prepend-new (var-functions-setting var)
                                            to-be-updated)))))
        (dolist (f (fun-referenced-funs fun))
          (setf (fun-ref-ccb f) t)))
178
179
      ;; If the status of some of the children changes, we have
      ;; to recompute the closure type.
180
      (when (update-fun-closure-type-many to-be-updated)
Daniel Kochmański's avatar
Daniel Kochmański committed
181
        (update-fun-closure-type fun))
jjgarcia's avatar
jjgarcia committed
182
      t)))
jjgarcia's avatar
jjgarcia committed
183

184
(defun c2locals (c1form funs body labels ;; labels is T when deriving from labels
Daniel Kochmański's avatar
Daniel Kochmański committed
185
186
187
188
                 &aux
                 (*env* *env*)
                 (*inline-blocks* 0)
                 (*env-lvl* *env-lvl*))
Daniel Kochmański's avatar
Daniel Kochmański committed
189
  (declare (ignore c1form labels))
jjgarcia's avatar
jjgarcia committed
190
191
  ;; create location for each function which is returned,
  ;; either in lexical:
192
193
194
195
196
197
  (loop with env-grows = nil
     with closed-vars = '()
     for fun in funs
     for var = (fun-var fun)
     when (plusp (var-ref var))
     do (case (var-kind var)
Daniel Kochmański's avatar
Daniel Kochmański committed
198
199
200
201
202
203
204
205
          ((lexical closure)
           (push var closed-vars)
           (unless env-grows
             (setq env-grows (var-ref-ccb var))))
          (otherwise
           (maybe-open-inline-block)
           (bind (next-lcl) var)
           (wt-nl "cl_object " *volatile* var ";")))
206
207
208
     finally
     ;; if we have closed variables
       (when (env-grows env-grows)
Daniel Kochmański's avatar
Daniel Kochmański committed
209
210
211
         (maybe-open-inline-block)
         (let ((env-lvl *env-lvl*))
           (wt "cl_object " *volatile* "env" (incf *env-lvl*) " = env" env-lvl ";")))
212
213
     ;; bind closed locations because of possible circularities
       (loop for var in closed-vars
Daniel Kochmański's avatar
Daniel Kochmański committed
214
          do (bind nil var)))
215
216
  ;; create the functions:
  (mapc #'new-local funs)
jjgarcia's avatar
jjgarcia committed
217
  ;; - then assign to it
218
219
220
221
  (loop for fun in funs
     for var = (fun-var fun)
     when (plusp (var-ref var))
     do (set-var (list 'MAKE-CCLOSURE fun) var))
222
  (c2expr body)
223
  (close-inline-blocks))
jjgarcia's avatar
jjgarcia committed
224

225

226
227
228
229
230
231
232
(defun c1decl-body (decls body)
  (if (null decls)
      (c1progn body)
      (let* ((*cmp-env* (reduce #'add-one-declaration decls
                                :initial-value (cmp-env-copy *cmp-env*))))
        (c1progn body))))

233
234
235
(defun c1locally (args)
  (multiple-value-bind (body ss ts is other-decl)
      (c1body args t)
236
237
    (if (or ss ts is other-decl)
        (let ((*cmp-env* (cmp-env-copy)))
238
          (mapc #'cmp-env-declare-special ss)
239
240
241
          (check-vdecl nil ts is)
          (c1decl-body other-decl body))
        (c1progn body))))
242

243
(defun c1macrolet (args)
244
  (check-args-number 'MACROLET args 1)
245
  (let ((*cmp-env* (si:cmp-env-register-macrolet (first args) (cmp-env-copy))))
246
    (c1locally (cdr args))))
jjgarcia's avatar
jjgarcia committed
247

248
(defun c1symbol-macrolet (args)
249
  (check-args-number 'SYMBOL-MACROLET args 1)
250
251
  (let ((*cmp-env* (cmp-env-copy)))
    (dolist (def (car args))
Daniel Kochmański's avatar
Daniel Kochmański committed
252
253
254
255
      (let ((name (first def)))     
        (cmpck (or (endp def) (not (symbolp name)) (endp (cdr def)))
             "The symbol-macro definition ~s is illegal." def)
        (cmp-env-register-symbol-macro name (second def))))
256
    (c1locally (cdr args))))
jjgarcia's avatar
jjgarcia committed
257

258
(defun local-function-ref (fname &optional build-object)
259
  (multiple-value-bind (fun cfb unw)
260
      (cmp-env-search-function fname)
Daniel Kochmański's avatar
Daniel Kochmański committed
261
    (declare (ignore unw))
262
    (when fun
263
      (when (functionp fun) 
Daniel Kochmański's avatar
Daniel Kochmański committed
264
265
266
267
        (when build-object
          ;; Macro definition appears in #'.... This should not happen.
          (cmperr "The name of a macro ~A was found in special form FUNCTION." fname))
        (return-from local-function-ref nil))
268
      (incf (fun-ref fun))
269
      (if build-object
Daniel Kochmański's avatar
Daniel Kochmański committed
270
271
272
273
274
275
          (setf (fun-ref-ccb fun) t)
          (let ((caller *current-function*))
            (when (and caller
                       (not (member fun (fun-referenced-funs caller) :test #'eq)))
              (push fun (fun-referenced-funs caller))
              (push caller (fun-referencing-funs fun)))))
276
277
      ;; we introduce a variable to hold the funob
      (let ((var (fun-var fun)))
278
        (when (and cfb build-object)
279
280
281
          (setf (var-ref-clb var) t)
          (when (not (eq (var-kind var) 'CLOSURE))
            (setf (var-kind var) 'LEXICAL)))))
282
    fun))
jjgarcia's avatar
jjgarcia committed
283

284
(defun c2call-local (c1form fun args)
Daniel Kochmański's avatar
Daniel Kochmański committed
285
  (declare (type fun fun))
286
  (unless (c2try-tail-recursive-call fun args)
287
288
    (let ((*inline-blocks* 0)
          (*temp* *temp*))
289
      (unwind-exit (call-loc (fun-name fun) fun (inline-args args)
Daniel Kochmański's avatar
Daniel Kochmański committed
290
                             (c1form-primary-type c1form)))
291
      (close-inline-blocks))))