source: branches/tfe/ccl/compiler/tfe/tgen.lisp @ 6561

Last change on this file since 6561 was 6561, checked in by gb, 13 years ago

close some parens

File size: 17.8 KB
Line 
1(in-package "CCL")
2
3(eval-when (:compile-toplevel :load-toplevel :execute)
4  (require "NXENV")
5  (require "TATTR" "ccl:compiler;tfe;tattr")
6  (require "TNODE" "ccl:compiler;tfe;tnode")
7  (require "GLOBALFN" "ccl:compiler;tfe;globalfn")
8  (require "TPRIM" "ccl:compiler;tfe;tprim")
9  (require "TENV" "ccl:compiler;tfe;tenv"))
10
11(defun tgen-warn (condition &rest args)
12  (apply #'warn condition args))
13
14(defun tgen-error (condition &rest args)
15  (apply #'error condition args))
16
17(defvar *tgen-handlers* (make-hash-table :test #'eq))
18
19(eval-when (:compile-toplevel :execute)
20 
21  (defun parse-tgen (name tconn-var arglist body &optional env)
22    (unless (verify-lambda-list arglist t t t)
23      (error "Invalid lambda list ~s" arglist))
24    (multiple-value-bind (lambda-list whole environment)
25        (normalize-lambda-list arglist t t)
26      (multiple-value-bind (body local-decs)
27          (parse-body body env)
28        (unless whole (setq whole (gensym)))
29        (unless environment (setq environment (gensym)))
30        (multiple-value-bind (bindings binding-decls)
31            (%destructure-lambda-list lambda-list whole nil nil
32                                      :cdr-p t
33                                      :whole-p nil
34                                      :use-whole-var t
35                                      :default-initial-value nil)
36          `(lambda (,tconn-var ,whole ,environment)
37            (declare (ignorable ,environment))
38            ,@(hoist-special-decls whole local-decs)
39            ,@(hoist-special-decls environment local-decs)
40            (block ,name
41              (let* ,(nreverse bindings)
42                ,@(when binding-decls `((declare ,@binding-decls)))
43                ,@local-decs 
44                ,@body)))))))
45
46  (defmacro deftgen (name opname arglist &body body &environment env)
47    `(progn
48      (setf (gethash ',opname *tgen-handlers*)
49       (nfunction ,name
50        ,(parse-tgen name (car arglist) (cdr arglist) body env)))
51      ',name)))
52
53
54
55
56
57(defun tgen-constant (tconn form env)
58  (declare (ignore env))
59  (setf (tconn-derived-type tconn) (ctype-of form)
60        (tconn-child tconn) (make-tconstref :parent tconn :leaf form))
61  tconn)
62
63(defun tgen-require-symbol (x context)
64  (if (typep x 'symbol)
65    x
66    (error "~s is not a symbol, in ~s" x context)))
67
68(defun tgen-not-symbol-or-lambda (tconn form env)
69  (declare (ignorable tconn env))
70  (error "CAR of ~S is not a symbol or lambda-expression" form))
71
72
73(defun tgen-arglist (tconn args env)
74  (let* ((arglist (make-targlist-node :parent tconn)))
75    (setf (tconn-child tconn) arglist)
76    (do* ((a args (cdr a))
77          (n 0 (1+ n))
78          (pred nil targ)
79          (targ (make-targlist-conn :parent arglist :env env)
80                (make-targlist-conn :parent arglist :env env)))
81         ((null a) (setf (targlist-node-last arglist) pred
82                         (targlist-node-n arglist) n)
83          arglist)
84      (if pred
85        (setf (targlist-conn-succ pred) targ)
86        (setf (targlist-node-first arglist) targ))
87      (setf (targlist-conn-pred targ) pred)
88      (tgen-form targ (car a) env)))
89  tconn)
90     
91
92(defun tgen-compiler-macro-function (thing env)
93  (declare (ignore thing env)))
94
95(defun tgen-combination (tconn form env)
96  (let* ((op (car form)))
97    (cond ((and (consp op) (eq (car op) 'lambda))
98           (tgen-lambda-application tconn form env))
99          ((symbolp op)
100           (multiple-value-bind (info local) (function-information op env)
101             (if local
102               (if (eq info :macro)
103                 (tgen-form tconn (macroexpand-1 form env) env)
104                 (tgen-application tconn form env))
105               (let* ((handler (gethash op *tgen-handlers*))
106                      (compiler-macro-function (tgen-compiler-macro-function op env))
107                      (macro-function (macro-function op env)))
108                 (if handler
109                   (funcall handler tconn form env)
110                   (progn
111                     (if compiler-macro-function
112                       (multiple-value-bind (new win)
113                           (compiler-macroexpand-1 form env)
114                         (when win
115                           (return-from tgen-combination
116                             (tgen-form tconn new env)))))
117                     (if macro-function
118                       (multiple-value-bind (new win)
119                           (macroexpand-1 form env)
120                         (when win
121                           (return-from tgen-combination
122                             (tgen-form tconn new env)))))
123                     ;; No special-operation handlers, compiler-macros,
124                     ;; or macros apply.  Treat the form as an application.
125                     (tgen-application tconn form env)))))))
126          (t (tgen-not-symbol-or-lambda tconn form env)))))
127                   
128(defun tgen-application (tconn form env)
129  (destructuring-bind (fname &rest args) form
130    (let* ((tapp (make-tapplication :parent tconn)))
131      (setf (tconn-child tconn) tapp)
132      (let* ((fconn (make-tconn :parent tapp))
133             (argsconn (make-tconn :parent tapp)))
134        (multiple-value-bind (info local decls)
135            (function-information fname env)
136          (declare (ignore info))
137          (let* ((ref (if local
138                        (make-tlocalfuncref :parent fconn :leaf (tenv-func-lookup fname env))
139                        (make-tgfuncnameref :parent fconn :leaf fname))))
140            (setf (tconn-child fconn) ref)
141            (setf (tapplication-arglist tapp) argsconn
142                  (tapplication-functional tapp) fconn)
143            (tgen-arglist argsconn args env)
144            (if (not local)
145              (setf (tapplication-info tapp)
146                    (get-known-global-function-info fname)))
147            (if (eq (cdr (assq 'inline decls)) 'notinline)
148              (setf (tapplication-attributes tapp)
149                    (encode-tapplication-attributes :notinline))))))))
150  tconn)
151           
152(defun tgen-symbol (tconn form env)
153  (if (null form)
154    (tgen-constant tconn form env)
155    (multiple-value-bind (kind local decls) (variable-information form env)
156      (declare (ignorable local decls))
157      (let* ((type-specifier (or (cdr (assq 'type decls)) t)))
158        (case kind
159          (:symbol-macro
160           (tgen-form tconn (macroexpand-1 form env) env))
161          (:constant
162           (let* ((defenv (definition-environment env))
163                  (pair (if defenv
164                          (assq form (defenv.constants defenv))))
165                  (val (if pair
166                         (cdr pair)
167                         (%svref form target::symbol.vcell-cell))))
168             (if (and (not (eq (%unbound-marker) val))
169                      (nx-apply-env-hook
170                       policy.allow-constant-substitution
171                       form val env))
172               (tgen-constant tconn val env)
173               (let* ((ref (make-tfreeref :parent tconn
174                                          :leaf form
175                                          :flags (ash 1 $sym_vbit_global))))
176                 (setf (tconn-child tconn) ref)))))
177          (:lexical
178           (let* ((ref (make-tlexref :parent tconn
179                                     :leaf form)))
180             (setf (tconn-child tconn) ref)
181             (setf (tconn-declared-type tconn) (specifier-type type-specifier))
182             (tenv-note-lexref ref (tenv-find-lexical-variable form env))
183             ))
184          (:special
185           (let* ((ref
186                   (if (logbitp $sym_vbit_global (%symbol-bits form))
187                     (make-tstaticref :parent tconn :leaf form)
188                     (make-tspecialref :parent tconn
189                                       :leaf form))))
190             (setf (tconn-declared-type tconn) (specifier-type type-specifier))
191             (setf (tconn-child tconn) ref)))
192          (t
193           (let* ((ref (make-tfreeref :parent tconn :leaf form)))
194             (setf (tconn-child tconn) ref))))
195        tconn))))
196
197(defun tgen-form (tconn form env)
198  (if (symbolp form)
199    (tgen-symbol tconn form env)
200    (if (constantp form)
201      (tgen-constant tconn
202                     (if (quoted-form-p form)
203                       (cadr form)
204                       form)
205                     env)
206      (tgen-combination tconn form env))))
207     
208(defun tgen-seq (tconn forms env)
209  (if (null forms)
210    (tgen-constant tconn forms env)
211    (if (null (cdr forms))
212      (tgen-form tconn (car forms) env)
213      (do* ((parent tconn)
214            (for-value (tconn-for-value tconn))
215            (head forms (cdr head))
216            (tail (cdr head) (cdr tail)))
217           ((null (cdr tail))
218            (let* ((tseq (make-tseq :parent parent)))
219              (setf (tconn-child parent) tseq)
220              (let* ((effect-conn (make-tconn :parent tseq :env env :for-value nil))
221                     (value-conn (make-tconn :parent tseq :env env :for-value for-value)))
222                (setf (tseq-for-effect tseq) effect-conn
223                      (tseq-for-value tseq) value-conn)
224                (tgen-form effect-conn (car head) env)
225                (tgen-form value-conn (car tail) env)
226                tconn)))
227        (let* ((tseq (make-tseq :parent parent)))
228          (setf (tconn-child parent) tseq)
229          (let* ((effect-conn (make-tconn :parent tseq :env env)))
230            (setf (tseq-for-effect tseq) effect-conn)
231            (tgen-form effect-conn (car head) env)
232            (setf (tseq-for-value tseq)
233                  (setq parent (make-tconn :parent tseq :env env)))))))))
234                     
235       
236       
237(deftgen tgen-the the (tconn typespec form &environment env)
238  (let* ((ctype (specifier-type typespec))
239         (current-declared-type (tconn-declared-type tconn)))
240    (setf (tconn-declared-type tconn)
241          (if current-declared-type
242            (type-intersection ctype current-declared-type)
243            ctype))
244    (tgen-form tconn form env)
245    tconn))
246
247(deftgen tgen-if if (tconn test true &optional false &environment env)
248  (let* ((tif (make-tif :parent tconn))
249         (ttest (make-tconn :parent tif :env env))
250         (ttrue (make-tconn :parent tif :env env))
251         (tfalse (make-tconn :parent tif :env env)))
252    (setf (tconn-child tconn) tif
253          (tif-test tif) ttest
254          (tif-true tif) ttrue
255          (tif-false tif) tfalse)
256    (tgen-form ttest test env)
257    (tgen-form ttrue true env)
258    (tgen-form tfalse false env))
259  tconn)
260
261(deftgen tgen-progn progn (tconn &rest forms &environment env)
262  (tgen-seq tconn forms env))
263
264(deftgen tgen-prog1 prog1 (tconn form &rest others &environment env)
265  (let* ((tprog1 (make-tprog1 :parent tconn)))
266    (setf (tconn-child tconn) tprog1)
267    (let* ((save-tconn (make-tconn :parent tprog1 :env env))
268           (discard-tconn (make-tconn :parent tprog1 :env env)))
269      (setf (tprog1-save tprog1) save-tconn
270            (tprog1-discard tprog1) discard-tconn)
271      (tgen-form save-tconn form env)
272      (tgen-seq discard-tconn others env)
273      tconn)))
274
275(deftgen tgen-catch catch (tconn tag &body body &environment env)
276  (let* ((tcatch (make-tcatch :parent tconn)))
277    (setf (tconn-child tconn) tcatch)
278    (let* ((ttag (make-tconn :parent tcatch :env env))
279           (new-env (new-lexical-environment env))
280           (tbody (make-tconn :parent tcatch :env new-env)))
281      (setf (tcatch-tag tcatch) ttag
282            (tcatch-body tcatch) tbody)
283      (tgen-form ttag tag env)
284      (setf (lexenv.variables new-env) 'catch)
285      (tgen-seq tbody body new-env)
286      tconn)))
287
288(deftgen tgen-setq setq (tconn &rest pairs &environment env)
289  (if (null pairs)
290    (tgen-constant tconn pairs env)
291    (let* ((len (list-length pairs)))
292      (unless (evenp len)
293        (error "Odd number of args to SETQ: ~s" pairs))
294      (if (> len 2)
295        (collect ((body))
296          (do* ((p pairs (cddr p)))
297               ((null p) (tgen-seq tconn (body) env))
298            (body `(setq ,(car p) ,(cadr p)))))
299        (let* ((var (tgen-require-symbol (car pairs) `(setq ,@pairs)))
300               (val (cadr pairs)))
301          (multiple-value-bind (kind local) (variable-information var env)
302            (declare (ignorable local))
303            (case kind
304              (:constant (error "Can't assign to constant ~s" var))
305              (:symbol-macro
306               (tgen-form tconn `(setf ,(macroexpand-1 var env) ,val) env))
307              (:lexical
308               (let* ((tsetq (make-tsetq-lexical :parent tconn)))
309                 (setf (tconn-child tconn) tsetq)
310                 (let* ((tval-conn (make-tconn :parent tsetq :env env))
311                        (v (tenv-find-lexical-variable var env)))
312                   (setf (tsetq-val tsetq) tval-conn
313                         (tsetq-thing tsetq) v)
314                   (tgen-form tval-conn val env)
315                   (tenv-note-setq tsetq v)
316                   tconn)))
317              (t
318               (unless kind
319                 (tgen-warn 'undeclared-free-variable var))
320               (let* ((tsetq (make-tsetq-special :parent tconn)))
321                 (setf (tconn-child tconn) tsetq)
322                 (let* ((tval-conn (make-tconn :parent tsetq :env env)))
323                   (setf (tsetq-val tsetq) tval-conn
324                         (tsetq-thing tsetq) var)
325                   (tgen-form tval-conn val env)
326                   tconn))))))))))
327
328
329
330(defun primitivize (node)
331  (when (typep node 'tapplication)
332    (let* ((info (tapplication-info node))
333           (p (if info (known-function-info-primitive-transform info))))
334      (when p
335        (funcall p node)
336        t))))
337
338(defun tscavenge (node)
339  )
340
341
342(defmethod tsimplify ((conn tconn) notify)
343  (tsimplify (tconn-child conn)) notify)
344
345(defmethod tsimplify ((node tnode) notify)
346  (declare (ignore notify)))
347
348(defmethod tsimplify ((bind tbind) notify)
349  ;; If the initial value of the binding is a constant and the variable
350  ;; is never SETQed, replace all references to the variable with the
351  ;; constant and replace the bind node with its body.
352  (let* ((initval (tbind-initval bind))
353         (initval-child (tconn-child initval)))
354    (when (and (null (tbind-sets bind))
355               (typep initval-child 'tconstref))
356      (let* ((constval (tconstref-leaf initval-child))
357             (declared-type (tconn-declared-type initval))
358             (derived-type (tconn-derived-type initval)))
359        (do* ((ref (tbind-refs bind) (tlexref-next ref)))
360             ((null ref)
361              (let* ((body (tconn-child (tbind-body bind)))
362                     (parent (tbind-parent bind)))
363                (setf (tconn-child parent) body
364                      (tconn-parent body) parent)
365                (funcall notify)))
366          (let* ((parent (tnode-parent ref))
367                 (copy (make-tconstref :parent parent :leaf constval)))
368            (setf (tconn-child parent) copy
369                  (tconn-declared-type parent) declared-type
370                  (tconn-derived-type parent) derived-type)))))))
371
372
373(defmethod tsimplify ((node tapplication) notify)
374  (let* ((info (tapplication-info node))
375         (attrs (if info (known-function-info-attributes info)))
376         (appattrs (tapplication-attributes node)))
377    (when (and attrs
378               (global-function-attribute-p :can-constant-fold attrs)
379               (not (tapplication-attribute-p :notinline appattrs)))
380      (collect ((constant-args))
381        (let* ((arglist (tapplication-arglist node)))
382          (do* ((arg (targlist-node-first (tconn-child arglist))
383                     (targlist-conn-succ arg)))
384               ((null arg))
385            (let* ((child (targlist-conn-child arg)))
386              (if (not (typep child 'tconstref))
387                (return-from tsimplify nil)
388                (constant-args (tconstref-leaf child)))))
389          (let* ((args (constant-args))
390                 (fname (tgfuncnameref-leaf
391                         (tconn-child (tapplication-functional node))))
392                 (vals
393                  (handler-case
394                      (multiple-value-list (apply fname args))
395                    (error (c)
396                           (tgen-warn
397                            "error ~s trying to  constant-fold call ~s"
398                            c (cons fname args))
399                           (setf (tapplication-attributes node)
400                                 (logior appattrs
401                                         (encode-tapplication-attributes
402                                          :notinline)))
403                           (return-from tsimplify nil))))
404                 (tconn (tnode-parent node)))
405            (if (and vals (null (cdr vals)))
406              (let* ((ref (make-tconstref :parent tconn :leaf (car vals))))
407                (setf (tconn-child tconn) ref)
408                (funcall notify))
409              (let* ((valprim (make-tprim :parent tconn
410                                          :info (tpriminfo values))))
411                (setf (tconn-child tconn) valprim)
412                (let* ((argsconn (make-tconn :parent valprim)))
413                  (setf (tprim-arglist valprim) argsconn)
414                  (tgen-arglist argsconn vals (tconn-env tconn)))
415                (funcall notify)))))))))
416
417(defun simplify-tree (root)
418  (let* ((changed nil)
419         (f #'(lambda (node) (tsimplify node #'(lambda () (setq changed t))))))
420    (declare (dynamic-exent f))
421    (loop
422      (setq changed nil)
423      (tdfwalk root f)
424      (unless changed (return))))
425  root)
426
427(deftgen tgen-locally locally (tconn &body body &environment old-env)
428  (multiple-value-bind (body decls) (parse-body body old-env)
429    (with-declarations (pending env old-env)
430      (nx-process-declarations pending decls env)
431      (tgen-seq tconn body env))))
432
433(deftgen tgen-function function (tconn arg &environment env)
434  (multiple-value-bind (valid name) (valid-function-name-p arg)
435    (if valid
436      (multiple-value-bind (info local) (function-information arg env)
437        (case info
438          ((:special-form :macro)
439           (tgen-error "~s can't be used to reference special operator or macro ~s" 'function arg))
440          (t
441           (if local
442             (setf (tconn-child tconn)
443                   (make-tlocalfuncref :parent tconn :leaf local))
444             (setf (tconn-child tconn)
445                   (make-tgfuncnameref :parent tconn :leaf name)))))))))
446     
447             
448
449
450
451       
452           
453       
454     
455 
456(deftgen tgen-let* let* (tconn (&rest pairs) &body body &environment old-env)
457  (multiple-value-bind (body decls) (parse-body body old-env)
458    (with-declarations (pending env old-env)
459      (nx-process-declarations pending decls env)
460      (do* ((parent tconn)
461            (env env (new-lexical-environment env))
462            (p pairs (cdr p))
463            (bind (make-tbind :parent parent)
464                  (make-tbind :parent parent)))
465           ((null p)
466            (tenv-effect-other-decls pending env old-env)
467            (tgen-seq parent body env)
468            (tenv-check-env-var-usage env old-env)
469            tconn)
470        (setf (tconn-child parent) bind)
471        (let* ((pair (car p))
472               (sym (if (atom pair) pair (car pair)))
473               (val (if (consp pair)
474                      (if (and (consp (cdr pair))
475                               (null (cddr pair)))
476                        (cadr pair)
477                        (tgen-error "Bad initial value form: ~s" pair)))))
478          (let* ((initform-conn (make-tconn :parent bind :env env))
479                 (bconn (make-tconn :parent bind :env env)))
480            (setf (tbind-initval bind) initform-conn)
481            (tgen-form initform-conn val env)
482            (let* ((var (tenv-new-var pending sym env)))
483              (setf (tbind-var bind) var 
484                    (var-refs var) bind))
485            (setq parent (setf (tbind-body bind) bconn))))))))
486           
Note: See TracBrowser for help on using the repository browser.