source: branches/1.2-devel/ccl/compiler/nx-basic.lisp @ 15278

Last change on this file since 15278 was 6471, checked in by gb, 12 years ago

FUNCTION-INFORMATION might return an afunc (or equivalent) as
a non-nil second value.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 22.2 KB
Line 
1;;;-*- Mode: Lisp; Package: CCL -*-
2;;;
3;;;   Copyright (C) 1994-2001 Digitool, Inc
4;;;   This file is part of OpenMCL. 
5;;;
6;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with OpenMCL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16
17
18;; used by compiler and eval - stuff here is not excised with rest of compiler
19
20
21(in-package :ccl)
22
23#| Note: when MCL-AppGen 4.0 is built, the following form will need to be included in it:
24; for compiler-special-form-p, called by cheap-eval-in-environment
25(defparameter *nx1-compiler-special-forms*
26  `(%DEFUN %FUNCTION %NEW-PTR %NEWGOTAG %PRIMITIVE %VREFLET BLOCK CATCH COMPILER-LET DEBIND
27    DECLARE EVAL-WHEN FBIND FLET FUNCTION GO IF LABELS LAP LAP-INLINE LET LET* LOAD-TIME-VALUE
28    LOCALLY MACRO-BIND MACROLET MAKE-LIST MULTIPLE-VALUE-BIND MULTIPLE-VALUE-CALL
29    MULTIPLE-VALUE-LIST MULTIPLE-VALUE-PROG1 NEW-LAP NEW-LAP-INLINE NFUNCTION OLD-LAP
30    OLD-LAP-INLINE OR PROG1 PROGN PROGV QUOTE RETURN-FROM SETQ STRUCT-REF STRUCT-SET
31    SYMBOL-MACROLET TAGBODY THE THROW UNWIND-PROTECT WITH-STACK-DOUBLE-FLOATS WITHOUT-INTERRUPTS))
32|#
33
34(eval-when (:compile-toplevel)
35  (require 'nxenv))
36
37(defvar *lisp-compiler-version* 666 "I lost count.")
38
39(defvar *nx-compile-time-types* nil)
40(defvar *nx-proclaimed-types* nil)
41(defvar *nx-method-warning-name* nil)
42
43(defvar *nx1-alphatizers* (make-hash-table :size 180 :test #'eq))
44
45(let ((policy (%istruct 'compiler-policy
46               #'(lambda (env)
47                   (neq (debug-optimize-quantity env) 3))   ;  allow-tail-recursion-elimination
48               #'(lambda (env)
49                   (eq (debug-optimize-quantity env) 3))   ; inhibit-register-allocation
50               #'(lambda (env)
51                   (let* ((safety (safety-optimize-quantity env)))
52                     (and (< safety 3)
53                          (>= (speed-optimize-quantity env)
54                              safety)))) ; trust-declarations
55               #'(lambda (env)
56                   (>= (speed-optimize-quantity env)
57                       (+ (space-optimize-quantity env) 2)))   ; open-code-inline
58               #'(lambda (env)
59                   (and (eq (speed-optimize-quantity env) 3) 
60                        (eq (safety-optimize-quantity env) 0)))   ; inhibit-safety-checking
61               #'(lambda (env)
62                   (and (eq (speed-optimize-quantity env) 3) 
63                        (eq (safety-optimize-quantity env) 0)))   ; inhibit-event-polling
64               #'(lambda (env)
65                   (neq (debug-optimize-quantity env) 3))   ; inline-self-calls
66               #'(lambda (env)
67                   (and (neq (compilation-speed-optimize-quantity env) 3)
68                        (neq (safety-optimize-quantity env) 3)
69                        (neq (debug-optimize-quantity env) 3)))   ; allow-transforms
70               #'(lambda (var env)       ; force-boundp-checks
71                   (declare (ignore var))
72                   (eq (safety-optimize-quantity env) 3))
73               #'(lambda (var val env)       ; allow-constant-substitution
74                   (declare (ignore var val env))
75                   t)
76               nil           ; extensions
77               )))
78  (defun new-compiler-policy (&key (allow-tail-recursion-elimination nil atr-p)
79                                   (inhibit-register-allocation nil ira-p)
80                                   (trust-declarations nil td-p)
81                                   (open-code-inline nil oci-p)
82                                   (inhibit-safety-checking nil ischeck-p)
83                                   (inhibit-event-polling nil iep-p)
84                                   (inline-self-calls nil iscall-p)
85                                   (allow-transforms nil at-p)
86                                   (force-boundp-checks nil fb-p)
87                                   (allow-constant-substitution nil acs-p))
88    (let ((p (copy-uvector policy)))
89      (if atr-p (setf (policy.allow-tail-recursion-elimination p) allow-tail-recursion-elimination))
90      (if ira-p (setf (policy.inhibit-register-allocation p) inhibit-register-allocation))
91      (if td-p (setf (policy.trust-declarations p) trust-declarations))
92      (if oci-p (setf (policy.open-code-inline p) open-code-inline))
93      (if ischeck-p (setf (policy.inhibit-safety-checking p) inhibit-safety-checking))
94      (if iep-p (setf (policy.inhibit-event-checking p) inhibit-event-polling))
95      (if iscall-p (setf (policy.inline-self-calls p) inline-self-calls))
96      (if at-p (setf (policy.allow-transforms p) allow-transforms))
97      (if fb-p (setf (policy.force-boundp-checks p) force-boundp-checks))
98      (if acs-p (setf (policy.allow-constant-substitution p) allow-constant-substitution))
99      p))
100  (defun %default-compiler-policy () policy))
101
102(%include "ccl:compiler;lambda-list.lisp")
103
104
105
106;Syntactic Environment Access.
107
108(defun declaration-information (decl-name &optional env)
109  (if (and env (not (istruct-typep env 'lexical-environment)))
110    (report-bad-arg env 'lexical-environment))
111; *** This needs to deal with things defined with DEFINE-DECLARATION ***
112  (case decl-name
113    (optimize
114     (list 
115      (list 'speed (speed-optimize-quantity env))
116      (list 'safety (safety-optimize-quantity env))
117      (list 'compilation-speed (compilation-speed-optimize-quantity env))
118      (list 'space (space-optimize-quantity env))
119      (list 'debug (debug-optimize-quantity env))))
120    (declaration
121     *nx-known-declarations*)))
122
123(defun function-information (name &optional env &aux decls)
124  (let ((name (ensure-valid-function-name name)))
125    (if (and env (not (istruct-typep env 'lexical-environment)))
126      (report-bad-arg env 'lexical-environment))
127    (if (special-operator-p name)
128      (values :special-form nil nil)
129      (flet ((process-new-fdecls (fdecls)
130                                 (dolist (fdecl fdecls)
131                                   (when (eq (car fdecl) name)
132                                     (let ((decl-type (cadr fdecl)))
133                                       (when (and (memq decl-type '(dynamic-extent inline ftype))
134                                                  (not (assq decl-type decls)))
135                                         (push (cdr fdecl) decls)))))))
136        (declare (dynamic-extent #'process-new-fdecls))
137        (do* ((root t)
138              (contour env (when root (lexenv.parent-env contour))))
139             ((null contour)
140              (if (macro-function name)
141                (values :macro nil nil)
142                (if (fboundp name)
143                  (values :function 
144                          nil 
145                          (if (assq 'inline decls)
146                            decls
147                            (if (proclaimed-inline-p name)
148                              (push '(inline . inline) decls)
149                                (if (proclaimed-notinline-p name)
150                                  (push '(inline . notinline) decls)))))
151                  (values nil nil decls))))
152          (if (eq (uvref contour 0) 'definition-environment)
153            (if (assq name (defenv.functions contour))
154              (return (values :macro nil nil))
155              (progn (setq root nil) (process-new-fdecls (defenv.fdecls contour))))
156            (progn
157              (process-new-fdecls (lexenv.fdecls contour))
158              (let ((found (assq name (lexenv.functions contour))))
159                (when found
160                  (return
161                   (if (and (consp (cdr found))(eq (%cadr found) 'macro))
162                     (values :macro t nil)
163                     (values :function t decls))))))))))))
164
165(defun variable-information (var &optional env)
166  (setq var (require-type var 'symbol))
167  (if (and env (not (istruct-typep env 'lexical-environment)))
168    (report-bad-arg env 'lexical-environment))
169  (let* ((vartype nil)
170         (boundp nil)
171         (envtype nil)
172         (typedecls (nx-declared-type var env)) ; should grovel nested/shadowed special decls for us.
173         (decls (if (and typedecls (neq t typedecls)) (list (cons 'type typedecls)))))
174    (loop
175      (cond ((null env)
176             (if (constant-symbol-p var)
177               (setq vartype :constant decls nil)
178               (if (proclaimed-special-p var)
179                 (setq vartype :special)
180                 (let* ((not-a-symbol-macro (cons nil nil)))
181                   (declare (dynamic-extent not-a-symbol-macro))
182                   (unless (eq (gethash var *symbol-macros* not-a-symbol-macro)
183                               not-a-symbol-macro)
184                     (setq vartype :symbol-macro)))))
185             (return))
186            ((eq (setq envtype (%svref env 0)) 'definition-environment)
187             (cond ((assq var (defenv.constants env))
188                    (setq vartype :constant)
189                    (return))
190                   ((assq var (defenv.symbol-macros env))
191                    (setq vartype :symbol-macro)
192                    (return))
193                   ((assq var (defenv.specials env))
194                    (setq vartype :special)
195                    (return))))
196            (t
197             (dolist (vdecl (lexenv.vdecls env))
198               (when (eq (car vdecl) var)
199                 (let ((decltype (cadr vdecl)))
200                   (unless (assq decltype decls)
201                     (case decltype
202                       (special (setq vartype :special))
203                       ((type dynamic-extent ignore) (push (cdr vdecl) decls)))))))
204             (let ((vars (lexenv.variables env)))
205               (unless (atom vars)
206                 (dolist (v vars)
207                   (when (eq (var-name v) var)
208                     (setq boundp t)
209                     (if (and (consp (var-ea v))
210                              (eq :symbol-macro (car (var-ea v))))
211                       (setq vartype :symbol-macro)
212                       (unless vartype (setq vartype
213                                             (let* ((bits (var-bits v)))
214                                               (if (and (typep bits 'integer)
215                                                        (logbitp $vbitspecial bits))
216                                                 :special
217                                                 :lexical)))))
218                     (return)))
219                 (when vartype (return))))))
220      (setq env (if (eq envtype 'lexical-environment) (lexenv.parent-env env))))
221    (values vartype boundp decls)))
222
223(defun nx-target-type (typespec)
224  ;; Could do a lot more here
225  (if (or (eq *host-backend* *target-backend*)
226          (not (eq typespec 'fixnum)))
227    typespec
228    (target-word-size-case
229     (32 '(signed-byte 30))
230     (64 '(signed-byte 61)))))
231
232; Type declarations affect all references.
233(defun nx-declared-type (sym &optional (env *nx-lexical-environment*))
234  (loop
235    (when (or (null env) (eq (uvref env 0) 'definition-environment)) (return))
236    (dolist (decl (lexenv.vdecls env))
237      (if (and (eq (car decl) sym)
238               (eq (cadr decl) 'type))
239               (return-from nx-declared-type (nx-target-type (cddr decl)))))
240    (let ((vars (lexenv.variables env)))
241      (when (and (consp vars) 
242                 (dolist (var vars) 
243                   (when (eq (var-name var) sym) 
244                     (return t))))
245        (return-from nx-declared-type t)))
246    (setq env (lexenv.parent-env env)))
247  (let ((decl (or (assq sym *nx-compile-time-types*)
248                     (assq sym *nx-proclaimed-types*))))
249    (if decl (%cdr decl) t)))
250
251(defmacro define-declaration (decl-name lambda-list &body body &environment env)
252  (multiple-value-bind (body decls)
253                       (parse-body body env)
254    (let ((fn `(nfunction (define-declaration ,decl-name)
255                          (lambda ,lambda-list
256                            ,@decls
257                            (block ,decl-name
258                              ,@body)))))
259      `(progn
260         (proclaim '(declaration ,decl-name))
261         (setf (getf *declaration-handlers* ',decl-name) ,fn)))))
262
263(defun check-environment-args (variable symbol-macro function macro)
264  (flet ((check-all-pairs (pairlist argname)
265          (dolist (pair pairlist)
266            (unless (and (consp pair) (consp (%cdr pair)) (null (%cddr pair)) (symbolp (%car pair)))
267              (signal-simple-program-error "Malformed ~s argument: ~s is not of the form (~S ~S) in ~S" 
268                                           argname
269                                           pair
270                                           'name
271                                           'definition
272                                           pairlist))))
273         (check-all-symbols (symlist argname pairs pairsname)
274          (dolist (v symlist)
275            (unless (symbolp v) 
276              (signal-simple-program-error "Malformed ~S list: ~S is not a symbol in ~S." argname v symlist))
277            (when (assq v pairs) 
278              (signal-simple-program-error "~S ~S conflicts with ~S ~S" argname v pairsname (assq v pairs))))))
279    (check-all-pairs symbol-macro :symbol-macro)
280    (check-all-pairs macro :macro)
281    (check-all-symbols variable :variable symbol-macro :symbol-macro)
282    (check-all-symbols function :function macro :macro)))
283
284
285;; This -isn't- PARSE-DECLARATIONS.  It can't work; neither can this ...
286(defun process-declarations (env decls symbol-macros)
287  (let ((vdecls nil)
288        (fdecls nil)
289        (mdecls nil))
290    (flet ((add-type-decl (spec)
291            (destructuring-bind (typespec &rest vars) spec
292              (dolist (var vars)
293                (when (non-nil-symbol-p var)
294                  (push (list* var 
295                               'type
296                               (let ((already (assq 'type (nth-value 2 (variable-information var env)))))
297                                 (if already
298                                   (let ((oldtype (%cdr already)))
299                                     (if oldtype
300                                       (if (subtypep oldtype typespec)
301                                         oldtype
302                                         (if (subtypep typespec oldtype)
303                                           typespec))))
304                                   typespec)))
305                        vdecls))))))
306      ; do SPECIAL declarations first - this approximates the right thing, but doesn't quite make it.
307      (dolist (decl decls)
308        (when (eq (car decl) 'special)
309          (dolist (spec (%cdr decl))
310            (when (non-nil-symbol-p spec)
311              (if (assq spec symbol-macros)
312                (signal-program-error "Special declaration cannot be applied to symbol-macro ~S" spec))
313              (push (list* spec 'special t) vdecls)))))
314      (dolist (decl decls)
315        (let ((decltype (car decl)))
316          (case decltype
317              ((inline notinline)
318               (dolist (spec (%cdr decl))
319               (let ((fname nil))
320                 (if (non-nil-symbol-p spec)
321                   (setq fname spec)
322                   (if (and (consp spec) (eq (%car spec) 'setf))
323                     (setq fname (setf-function-name (cadr spec)))))
324                 (if fname
325                   (push (list* fname decltype t) fdecls)))))
326              (optimize
327               (dolist (spec (%cdr decl))
328                 (let ((val 3)
329                       (quantity spec))
330                   (if (consp spec)
331                     (setq quantity (car spec) val (cadr spec)))
332                 (if (and (fixnump val) (<= 0 val 3) (memq quantity '(debug speed space safety compilation-speed)))
333                   (push (cons quantity val) mdecls)))))
334              (dynamic-extent
335               (dolist (spec (%cdr decl))
336               (if (non-nil-symbol-p spec)
337                 (push (list* spec decltype t) vdecls)
338                 (if (and (consp spec) (eq (%car spec) 'function))
339                   (let ((fname (cadr spec)))
340                     (if (not (non-nil-symbol-p fname))
341                       (setq fname 
342                             (if (and (consp fname) (eq (%car fname) 'setf))
343                               (setf-function-name (cadr fname)))))
344                     (if fname (push (list* fname decltype t) fdecls)))))))
345              (type (add-type-decl (cdr decl)))
346              (ftype (destructuring-bind (typespec &rest fnames) (%cdr decl)
347                       (dolist (name fnames)
348                         (let ((fname name))
349                           (if (not (non-nil-symbol-p fname))
350                             (setq fname 
351                                   (if (and (consp fname) (eq (%car fname) 'setf))
352                                     (setf-function-name (cadr fname)))))
353                           (if fname (push (list* fname decltype typespec) fdecls))))))
354              (special)
355              (t
356               (if (memq decltype *cl-types*)
357                 (add-type-decl decl)
358                 (let ((handler (getf *declaration-handlers* decltype)))
359                   (when handler
360                     (multiple-value-bind (type info) (funcall handler decl)
361                       (ecase type
362                         (:variable
363                          (dolist (v info) (push (apply #'list* v) vdecls)))
364                         (:function
365                          (dolist (f info) (push (apply #'list* f) fdecls)))
366                         (:declare  ;; N.B. CLtL/2 semantics
367                          (push info mdecls)))))))))))
368      (setf (lexenv.vdecls env) (nconc vdecls (lexenv.vdecls env))
369            (lexenv.fdecls env) (nconc fdecls (lexenv.fdecls env))
370            (lexenv.mdecls env) (nconc mdecls (lexenv.mdecls env))))))
371
372 
373(defun cons-var (name &optional (bits 0))
374  (%istruct 'var name bits nil nil nil nil nil))
375
376
377(defun augment-environment (env &key variable symbol-macro function macro declare)
378  (if (and env (not (istruct-typep env 'lexical-environment)))
379    (report-bad-arg env 'lexical-environment))
380  (check-environment-args variable symbol-macro function macro)
381  (let* ((vars (mapcar #'cons-var variable))
382         (symbol-macros (mapcar #'(lambda (s)
383                                    (let* ((sym (car s)))
384                                      (unless (and (symbolp sym)
385                                                   (not (constantp sym env))
386                                                   (not (eq (variable-information sym env) :special)))
387                                        (signal-program-error "~S can't by bound as a SYMBOL-MACRO" sym))
388                                      (let ((v (cons-var (car s)))) 
389                                        (setf (var-expansion v) (cons :symbol-macro (cadr s)))
390                                        v)))
391                                symbol-macro))
392         (macros (mapcar #'(lambda (m) (list* (car m) 'macro (cadr m))) macro))
393         (functions (mapcar #'(lambda (f) (list* f 'function nil)) function))
394         (new-env (new-lexical-environment env)))
395    (setf (lexenv.variables new-env) (nconc vars symbol-macros)
396          (lexenv.functions new-env) (nconc functions macros))
397    (process-declarations new-env declare symbol-macro)
398    new-env))
399
400(defun enclose (lambda-expression &optional env)
401  (if (and env (not (istruct-typep env 'lexical-environment)))
402    (report-bad-arg env 'lexical-environment))
403  (unless (lambda-expression-p lambda-expression)
404    (error "Invalid lambda-expression ~S." lambda-expression))
405  (%make-function nil lambda-expression env))
406
407#| Might be nicer to do %declaim
408(defmacro declaim (&rest decl-specs &environment env)
409  `(progn
410     (eval-when (:load-toplevel :execute)
411       (proclaim ',@decl-specs))
412     (eval-when (:compile-toplevel)
413       (%declaim ',@decl-specs ,env))))
414|#
415
416(defmacro declaim (&environment env &rest decl-specs)
417  "DECLAIM Declaration*
418  Do a declaration or declarations for the global environment."
419  (let* ((body (mapcar #'(lambda (spec) `(proclaim ',spec)) decl-specs)))
420  `(progn
421     (eval-when (:compile-toplevel)
422       (compile-time-proclamation ',decl-specs ,env))
423     (eval-when (:load-toplevel :execute)
424       ,@body))))
425
426(defun merge-compiler-warnings (old-warnings)
427  (let ((warnings nil))
428    (dolist (w old-warnings)
429      (if
430        (dolist (w1 warnings t) 
431          (let ((w1-args (compiler-warning-args w1)))
432            (when (and (eq (compiler-warning-warning-type w)
433                           (compiler-warning-warning-type w1))
434                       w1-args
435                       (eq (%car (compiler-warning-args w))
436                           (%car w1-args)))
437              (incf (compiler-warning-nrefs w1))
438              (return))))
439         (push w warnings)))
440    warnings))
441
442; This is called by, e.g., note-function-info & so can't be -too- funky ...
443;;; don't call proclaimed-inline-p or proclaimed-notinline-p with alphatized crap
444
445(defun nx-declared-inline-p (sym env)
446  (setq sym (maybe-setf-function-name sym))
447  (loop
448    (when (listp env)
449      (return (and (symbolp sym)
450                   (proclaimed-inline-p sym))))
451    (dolist (decl (lexenv.fdecls env))
452      (when (and (eq (car decl) sym)
453                 (eq (cadr decl) 'inline))
454        (return-from nx-declared-inline-p (eq (cddr decl) 'inline))))
455    (setq env (lexenv.parent-env env))))
456
457(defparameter *compiler-warning-formats*
458  '((:special . "Undeclared free variable ~S")
459    (:unused . "Unused lexical variable ~S")
460    (:ignore . "Variable ~S not ignored")
461    (:undefined-function . "Undefined function ~S")
462    (:unknown-declaration . "Unknown declaration ~S")
463    (:unknown-type-declaration . "Unknown type ~S")
464    (:macro-used-before-definition . "Macro function ~S was used before it was defined")
465    (:unsettable . "Shouldn't assign to variable ~S")
466    (:global-mismatch . "Function call arguments don't match current definition of ~S")
467    (:environment-mismatch . "Function call arguments don't match visible definition of ~S")
468    (:type . "Type declarations violated in ~S")
469    (:type-conflict . "Conflicting type declarations for ~S")
470    (:special-fbinding . "Attempt to bind compiler special name: ~s. Result undefined")))
471
472(defun report-compiler-warning (condition stream)
473  (let* ((warning-type (compiler-warning-warning-type condition))
474         (format-string (or (cdr (assq warning-type *compiler-warning-formats*))
475                            (format nil "~S compiler warning with args ~~S"
476                                    warning-type))))
477    (apply #'format stream format-string (compiler-warning-args condition))
478    (let ((nrefs (compiler-warning-nrefs condition)))
479      (when (and nrefs (neq nrefs 1))
480        (format stream " (~D references)" nrefs)))
481    (princ ", in " stream)
482    (print-nested-name (reverse (compiler-warning-function-name condition)) stream)
483    (princ "." stream)))
484
485(defun environment-structref-info (name env)
486  (let ((defenv (definition-environment env)))
487    (when defenv
488      (cdr (assq name (defenv.structrefs defenv))))))
489
490; end
Note: See TracBrowser for help on using the repository browser.