source: trunk/source/compiler/nx-basic.lisp @ 13891

Last change on this file since 13891 was 13891, checked in by gz, 10 years ago

Add DECOMP-ACODE, decompile acode into something more readable.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 41.6 KB
Line 
1;;;-*- Mode: Lisp; Package: CCL -*-
2;;;
3;;;   Copyright (C) 2009 Clozure Associates
4;;;   Copyright (C) 1994-2001 Digitool, Inc
5;;;   This file is part of Clozure CL. 
6;;;
7;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
8;;;   License , known as the LLGPL and distributed with Clozure CL as the
9;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
10;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
11;;;   conflict, the preamble takes precedence. 
12;;;
13;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
14;;;
15;;;   The LLGPL is also available online at
16;;;   http://opensource.franz.com/preamble.html
17
18
19;; used by compiler and eval - stuff here is not excised with rest of compiler
20
21
22(in-package :ccl)
23
24#|| Note: when MCL-AppGen 4.0 is built, the following form will need to be included in it:
25; for compiler-special-form-p, called by cheap-eval-in-environment
26(defparameter *nx1-compiler-special-forms*
27  `(%DEFUN %FUNCTION %NEW-PTR %NEWGOTAG %PRIMITIVE %VREFLET BLOCK CATCH COMPILER-LET DEBIND
28    DECLARE EVAL-WHEN FBIND FLET FUNCTION GO IF LABELS LAP LAP-INLINE LET LET* LOAD-TIME-VALUE
29    LOCALLY MACRO-BIND MACROLET MAKE-LIST MULTIPLE-VALUE-BIND MULTIPLE-VALUE-CALL
30    MULTIPLE-VALUE-LIST MULTIPLE-VALUE-PROG1 NEW-LAP NEW-LAP-INLINE NFUNCTION OLD-LAP
31    OLD-LAP-INLINE OR PROG1 PROGN PROGV QUOTE RETURN-FROM SETQ STRUCT-REF STRUCT-SET
32    SYMBOL-MACROLET TAGBODY THE THROW UNWIND-PROTECT WITH-STACK-DOUBLE-FLOATS WITHOUT-INTERRUPTS))
33||#
34
35(eval-when (:compile-toplevel)
36  (require 'nxenv))
37
38(defvar *lisp-compiler-version* 666 "I lost count.")
39
40(defvar *nx-compile-time-types* nil)
41(defvar *nx-proclaimed-types* nil)
42(defvar *nx-method-warning-name* nil)
43
44(defvar *nx-current-code-note*)
45
46;; The problem with undefind type warnings is that there is no in-language way to shut
47;; them up even when the reference is intentional.  (In case of undefined functions,
48;; you can declare FTYPE and that will turn off any warnings without interfering with
49;; the function being defined later).  For now just provide this as an out.
50(defvar *compiler-warn-on-undefined-type-references* #+ccl-qres t #-ccl-qres t)
51
52
53
54;; In lieu of a slot in acode.  Don't reference this variable elsewhere because I'm
55;; hoping to make it go away.
56(defparameter *nx-acode-note-map* nil)
57
58(defun acode-note (acode &aux (hash *nx-acode-note-map*))
59  (and hash (gethash acode hash)))
60
61(defun (setf acode-note) (note acode)
62  (when note
63    (assert *nx-acode-note-map*)
64    ;; Only record if have a unique key
65    (unless (or (atom acode)
66                (nx-null acode)
67                (nx-t acode))
68      (setf (gethash acode *nx-acode-note-map*) note))))
69
70
71(defstruct (code-note (:constructor %make-code-note))
72  ;; Code coverage state.  This MUST be the first slot - see nx2-code-coverage.
73  code-coverage
74  ;; The source note of this form, or NIL if random code form (no file info,
75  ;; generated by macros or other source transform)
76  source-note
77  ;; the note that was being compiled when this note was emitted.
78  parent-note
79  #+debug-code-notes ;; The actual source form - useful for debugging, otherwise unused.
80  form)
81
82(defun make-code-note (&key form source-note parent-note)
83  (declare (ignorable form))
84  (let ((note (%make-code-note
85               :source-note source-note
86               :parent-note parent-note)))
87    #+debug-code-notes
88    (when form
89      ;; Unfortunately, recording the macroexpanded form is problematic, since they
90      ;; can have references to non-dumpable forms, see e.g. loop.
91      (setf (code-note-form note)
92            (with-output-to-string (s) (let ((*print-circle* t)) (prin1 form s)))))
93    note))
94
95(defmethod print-object ((note code-note) stream)
96  (print-unreadable-object (note stream :type t :identity t)
97    (format stream "[~s]" (code-note-code-coverage note))
98    (let ((sn (code-note-source-note note)))
99      (if sn
100        (progn
101          (format stream " for ")
102          (print-source-note sn stream))
103        #+debug-code-notes
104        (when (code-note-form note)
105          (format stream " form ~a"
106                  (string-sans-most-whitespace (code-note-form note))))))))
107
108(defun nx-ensure-code-note (form &optional parent-note)
109  (let* ((parent-note (or parent-note *nx-current-code-note*))
110         (source-note (nx-source-note form)))
111    (unless (and source-note
112                 ;; Look out for a case like a lambda macro that turns (lambda ...)
113                 ;; into (FUNCTION (lambda ...)) which then has (lambda ...)
114                 ;; as a child.  Create a fresh note for the child, to avoid ambiguity.
115                 ;; Another case is forms wrapping THE around themselves.
116                 (neq source-note (code-note-source-note parent-note))
117                 ;; Don't use source notes from a different toplevel form, which could
118                 ;; happen due to inlining etc.  The result then is that the source note
119                 ;; appears in multiple places, and shows partial coverage (from the
120                 ;; other reference) in code that's never executed.
121                 (loop for p = parent-note then (code-note-parent-note p)
122                       when (null p) return t
123                       when (code-note-source-note p)
124                       return (eq (loop for n = source-note then s
125                                        as s = (source-note-source n)
126                                        unless (source-note-p s) return n)
127                                  (loop for n = (code-note-source-note p) then s
128                                        as s = (source-note-source n)
129                                        unless (source-note-p s) return n))))
130      (setq source-note nil))
131    (make-code-note :form form :source-note source-note :parent-note parent-note)))
132
133(defun nx-note-source-transformation (original new &aux (source-notes *nx-source-note-map*) sn)
134  (when (and source-notes
135             (setq sn (gethash original source-notes))
136             (not (gethash new source-notes)))
137    (setf (gethash new source-notes) sn)))
138
139
140(defvar *nx1-alphatizers* (make-hash-table :size 180 :test #'eq))
141
142(let ((policy (%istruct 'compiler-policy
143               #'(lambda (env)
144                   #+ccl-qres (< (debug-optimize-quantity env) 2)
145                   #-ccl-qres (neq (debug-optimize-quantity env) 3))   ;  allow-tail-recursion-elimination
146               #'(lambda (env)
147                   (declare (ignorable env))
148                   #+ccl-qres nil
149                   #-ccl-qres (eq (debug-optimize-quantity env) 3))   ; inhibit-register-allocation
150               #'(lambda (env)
151                   (let* ((safety (safety-optimize-quantity env)))
152                     (and (< safety 3)
153                          (>= (speed-optimize-quantity env)
154                              safety)))) ; trust-declarations
155               #'(lambda (env)
156                   #+ccl-qres (> (speed-optimize-quantity env)
157                                 (space-optimize-quantity env))
158                   #-ccl-qres (>= (speed-optimize-quantity env)
159                                  (+ (space-optimize-quantity env) 2))) ; open-code-inline
160               #'(lambda (env)
161                   (and (eq (speed-optimize-quantity env) 3) 
162                        (eq (safety-optimize-quantity env) 0)))   ; inhibit-safety-checking
163               #'(lambda (env)
164                   (let* ((safety (safety-optimize-quantity env)))
165                     (or (eq safety 3)
166                         (> safety (speed-optimize-quantity env)))))          ;declarations-typecheck
167               #'(lambda (env)
168                   (neq (debug-optimize-quantity env) 3))   ; inline-self-calls
169               #'(lambda (env)
170                   (and (neq (compilation-speed-optimize-quantity env) 3)
171                        (or (neq (speed-optimize-quantity env) 0)
172                            (and (neq (safety-optimize-quantity env) 3)
173                                 (neq (debug-optimize-quantity env) 3))))) ; allow-transforms
174               #'(lambda (var env)       ; force-boundp-checks
175                   (declare (ignore var))
176                   (eq (safety-optimize-quantity env) 3))
177               #'(lambda (var val env)       ; allow-constant-substitution
178                   (declare (ignore var val env))
179                   t)
180               nil           ; extensions
181               )))
182  (defun new-compiler-policy (&key (allow-tail-recursion-elimination nil atr-p)
183                                   (inhibit-register-allocation nil ira-p)
184                                   (trust-declarations nil td-p)
185                                   (open-code-inline nil oci-p)
186                                   (inhibit-safety-checking nil ischeck-p)
187                                   (inline-self-calls nil iscall-p)
188                                   (allow-transforms nil at-p)
189                                   (force-boundp-checks nil fb-p)
190                                   (allow-constant-substitution nil acs-p)
191                                   (declarations-typecheck nil dt-p))
192    (let ((p (copy-uvector policy)))
193      (if atr-p (setf (policy.allow-tail-recursion-elimination p) allow-tail-recursion-elimination))
194      (if ira-p (setf (policy.inhibit-register-allocation p) inhibit-register-allocation))
195      (if td-p (setf (policy.trust-declarations p) trust-declarations))
196      (if oci-p (setf (policy.open-code-inline p) open-code-inline))
197      (if ischeck-p (setf (policy.inhibit-safety-checking p) inhibit-safety-checking))
198      (if iscall-p (setf (policy.inline-self-calls p) inline-self-calls))
199      (if at-p (setf (policy.allow-transforms p) allow-transforms))
200      (if fb-p (setf (policy.force-boundp-checks p) force-boundp-checks))
201      (if acs-p (setf (policy.allow-constant-substitution p) allow-constant-substitution))
202      (if dt-p (setf (policy.declarations-typecheck p) declarations-typecheck))
203      p))
204  (defun %default-compiler-policy () policy))
205
206(%include "ccl:compiler;lambda-list.lisp")
207
208;Syntactic Environment Access.
209
210(defun declaration-information (decl-name &optional env)
211  (if (and env (not (istruct-typep env 'lexical-environment)))
212    (report-bad-arg env 'lexical-environment))
213; *** This needs to deal with things defined with DEFINE-DECLARATION ***
214  (case decl-name
215    (optimize
216     (list 
217      (list 'speed (speed-optimize-quantity env))
218      (list 'safety (safety-optimize-quantity env))
219      (list 'compilation-speed (compilation-speed-optimize-quantity env))
220      (list 'space (space-optimize-quantity env))
221      (list 'debug (debug-optimize-quantity env))))
222    (declaration
223     *nx-known-declarations*)))
224
225(defun function-information (name &optional env &aux decls)
226  (let ((name (ensure-valid-function-name name)))
227    (if (and env (not (istruct-typep env 'lexical-environment)))
228      (report-bad-arg env 'lexical-environment))
229    (if (special-operator-p name)
230      (values :special-form nil nil)
231      (flet ((process-new-fdecls (fdecls)
232                                 (dolist (fdecl fdecls)
233                                   (when (eq (car fdecl) name)
234                                     (let ((decl-type (cadr fdecl)))
235                                       (when (and (memq decl-type '(dynamic-extent inline ftype))
236                                                  (not (assq decl-type decls)))
237                                         (push (cdr fdecl) decls)))))))
238        (declare (dynamic-extent #'process-new-fdecls))
239        (do* ((root t)
240              (contour env (when root (lexenv.parent-env contour))))
241             ((null contour)
242              (if (macro-function name)
243                (values :macro nil nil)
244                (if (fboundp name)
245                  (values :function 
246                          nil 
247                          (if (assq 'inline decls)
248                            decls
249                            (if (proclaimed-inline-p name)
250                              (push '(inline . inline) decls)
251                                (if (proclaimed-notinline-p name)
252                                  (push '(inline . notinline) decls)))))
253                  (values nil nil decls))))
254          (if (istruct-typep contour 'definition-environment)
255            (if (assq name (defenv.functions contour))
256              (return (values :macro nil nil))
257              (progn (setq root nil) (process-new-fdecls (defenv.fdecls contour))))
258            (progn
259              (process-new-fdecls (lexenv.fdecls contour))
260              (let ((found (assq name (lexenv.functions contour))))
261                (when found
262                  (return
263                   (if (and (consp (cdr found))(eq (%cadr found) 'macro))
264                     (values :macro t nil)
265                     (values :function t decls))))))))))))
266
267(defun variable-information (var &optional env)
268  (setq var (require-type var 'symbol))
269  (if (and env (not (istruct-typep env 'lexical-environment)))
270    (report-bad-arg env 'lexical-environment))
271  (let* ((vartype nil)
272         (boundp nil)
273         (envtype nil)
274         (typedecls (nx-declared-type var env)) ; should grovel nested/shadowed special decls for us.
275         (decls (if (and typedecls (neq t typedecls)) (list (cons 'type typedecls)))))
276    (loop
277      (cond ((null env)
278             (if (constant-symbol-p var)
279               (setq vartype :constant decls nil)
280               (if (proclaimed-special-p var)
281                 (setq vartype :special)
282                 (let* ((not-a-symbol-macro (cons nil nil)))
283                   (declare (dynamic-extent not-a-symbol-macro))
284                   (unless (eq (gethash var *symbol-macros* not-a-symbol-macro)
285                               not-a-symbol-macro)
286                     (setq vartype :symbol-macro)))))
287             (return))
288            ((eq (setq envtype (istruct-type-name env)) 'definition-environment)
289             (cond ((assq var (defenv.constants env))
290                    (setq vartype :constant)
291                    (return))
292                   ((assq var (defenv.symbol-macros env))
293                    (setq vartype :symbol-macro)
294                    (return))
295                   ((assq var (defenv.specials env))
296                    (setq vartype :special)
297                    (return))))
298            (t
299             (dolist (vdecl (lexenv.vdecls env))
300               (when (eq (car vdecl) var)
301                 (let ((decltype (cadr vdecl)))
302                   (unless (assq decltype decls)
303                     (case decltype
304                       (special (setq vartype :special))
305                       ((type dynamic-extent ignore) (push (cdr vdecl) decls)))))))
306             (let ((vars (lexenv.variables env)))
307               (unless (atom vars)
308                 (dolist (v vars)
309                   (when (eq (var-name v) var)
310                     (setq boundp t)
311                     (if (and (consp (var-ea v))
312                              (eq :symbol-macro (car (var-ea v))))
313                       (setq vartype :symbol-macro)
314                       (unless vartype (setq vartype
315                                             (let* ((bits (var-bits v)))
316                                               (if (and (typep bits 'integer)
317                                                        (logbitp $vbitspecial bits))
318                                                 :special
319                                                 :lexical)))))
320                     (return)))
321                 (when vartype (return))))))
322      (setq env (if (eq envtype 'lexical-environment) (lexenv.parent-env env))))
323    (values vartype boundp decls)))
324
325(defun nx-target-type (typespec)
326  ;; Could do a lot more here
327  (if (or (eq *host-backend* *target-backend*)
328          (not (eq typespec 'fixnum)))
329    typespec
330    (target-word-size-case
331     (32 '(signed-byte 30))
332     (64 '(signed-byte 61)))))
333
334; Type declarations affect all references.
335(defun nx-declared-type (sym &optional (env *nx-lexical-environment*))
336  (loop
337    (when (or (null env) (istruct-typep env 'definition-environment)) (return))
338    (dolist (decl (lexenv.vdecls env))
339      (if (and (eq (car decl) sym)
340               (eq (cadr decl) 'type))
341               (return-from nx-declared-type (nx-target-type (cddr decl)))))
342    (let ((vars (lexenv.variables env)))
343      (when (and (consp vars) 
344                 (dolist (var vars) 
345                   (when (eq (var-name var) sym) 
346                     (return t))))
347        (return-from nx-declared-type t)))
348    (setq env (lexenv.parent-env env)))
349  (let ((decl (or (assq sym *nx-compile-time-types*)
350                     (assq sym *nx-proclaimed-types*))))
351    (if decl (%cdr decl) t)))
352
353(defun nx-declared-result-type (sym &optional (env *nx-lexical-environment*) args)
354  (when (symbolp (setq sym (maybe-setf-function-name sym)))
355    (let* ((ftype (find-ftype-decl sym env args))
356           (ctype (and ftype (if (typep ftype 'ctype) ftype (specifier-type-if-known ftype env)))))
357      (unless (or (null ctype)
358                  (not (function-ctype-p ctype))
359                  (eq *wild-type* (function-ctype-returns ctype)))
360        (let ((result-type (type-specifier (single-value-type (function-ctype-returns ctype)))))
361          (and (neq result-type 't) result-type))))))
362
363(defmacro define-declaration (decl-name lambda-list &body body &environment env)
364  (multiple-value-bind (body decls)
365                       (parse-body body env)
366    (let ((fn `(nfunction (define-declaration ,decl-name)
367                          (lambda ,lambda-list
368                            ,@decls
369                            (block ,decl-name
370                              ,@body)))))
371      `(progn
372         (proclaim '(declaration ,decl-name))
373         (setf (getf *declaration-handlers* ',decl-name) ,fn)))))
374
375(defun check-environment-args (variable symbol-macro function macro)
376  (flet ((check-all-pairs (pairlist argname)
377          (dolist (pair pairlist)
378            (unless (and (consp pair) (consp (%cdr pair)) (null (%cddr pair)) (symbolp (%car pair)))
379              (signal-simple-program-error "Malformed ~s argument: ~s is not of the form (~S ~S) in ~S" 
380                                           argname
381                                           pair
382                                           'name
383                                           'definition
384                                           pairlist))))
385         (check-all-symbols (symlist argname pairs pairsname)
386          (dolist (v symlist)
387            (unless (symbolp v) 
388              (signal-simple-program-error "Malformed ~S list: ~S is not a symbol in ~S." argname v symlist))
389            (when (assq v pairs) 
390              (signal-simple-program-error "~S ~S conflicts with ~S ~S" argname v pairsname (assq v pairs))))))
391    (check-all-pairs symbol-macro :symbol-macro)
392    (check-all-pairs macro :macro)
393    (check-all-symbols variable :variable symbol-macro :symbol-macro)
394    (check-all-symbols function :function macro :macro)))
395
396
397;; This -isn't- PARSE-DECLARATIONS.  It can't work; neither can this ...
398(defun process-declarations (env decls symbol-macros)
399  (let ((vdecls nil)
400        (fdecls nil)
401        (mdecls nil))
402    (flet ((add-type-decl (spec)
403            (destructuring-bind (typespec &rest vars) spec
404              (dolist (var vars)
405                (when (non-nil-symbol-p var)
406                  (push (list* var 
407                               'type
408                               (let ((already (assq 'type (nth-value 2 (variable-information var env)))))
409                                 (if already
410                                   (let ((oldtype (%cdr already)))
411                                     (if oldtype
412                                       (if (subtypep oldtype typespec)
413                                         oldtype
414                                         (if (subtypep typespec oldtype)
415                                           typespec))))
416                                   typespec)))
417                        vdecls))))))
418      ; do SPECIAL declarations first - this approximates the right thing, but doesn't quite make it.
419      (dolist (decl decls)
420        (when (eq (car decl) 'special)
421          (dolist (spec (%cdr decl))
422            (when (non-nil-symbol-p spec)
423              (if (assq spec symbol-macros)
424                (signal-program-error "Special declaration cannot be applied to symbol-macro ~S" spec))
425              (push (list* spec 'special t) vdecls)))))
426      (dolist (decl decls)
427        (let ((decltype (car decl)))
428          (case decltype
429              ((inline notinline)
430               (dolist (spec (%cdr decl))
431               (let ((fname nil))
432                 (if (non-nil-symbol-p spec)
433                   (setq fname spec)
434                   (if (setf-function-name-p spec)
435                     (setq fname (setf-function-name (cadr spec)))))
436                 (if fname
437                   (push (list* fname decltype t) fdecls)))))
438              (optimize
439               (dolist (spec (%cdr decl))
440                 (let ((val 3)
441                       (quantity spec))
442                   (if (consp spec)
443                     (setq quantity (car spec) val (cadr spec)))
444                 (if (and (fixnump val) (<= 0 val 3) (memq quantity '(debug speed space safety compilation-speed)))
445                   (push (cons quantity val) mdecls)))))
446              (dynamic-extent
447               (dolist (spec (%cdr decl))
448               (if (non-nil-symbol-p spec)
449                 (push (list* spec decltype t) vdecls)
450                 (if (and (consp spec) (eq (%car spec) 'function))
451                   (let ((fname (cadr spec)))
452                     (if (not (non-nil-symbol-p fname))
453                       (setq fname 
454                             (if (setf-function-name-p fname)
455                               (setf-function-name (cadr fname)))))
456                     (if fname (push (list* fname decltype t) fdecls)))))))
457              (type (add-type-decl (cdr decl)))
458              (ftype (destructuring-bind (typespec &rest fnames) (%cdr decl)
459                       (dolist (name fnames)
460                         (let ((fname name))
461                           (if (not (non-nil-symbol-p fname))
462                             (setq fname 
463                                   (if (setf-function-name-p fname)
464                                     (setf-function-name (cadr fname)))))
465                           (if fname (push (list* fname decltype typespec) fdecls))))))
466              (special)
467              (t
468               (if (memq decltype *cl-types*)
469                 (add-type-decl decl)
470                 (let ((handler (getf *declaration-handlers* decltype)))
471                   (when handler
472                     (multiple-value-bind (type info) (funcall handler decl)
473                       (ecase type
474                         (:variable
475                          (dolist (v info) (push (apply #'list* v) vdecls)))
476                         (:function
477                          (dolist (f info) (push (apply #'list* f) fdecls)))
478                         (:declare  ;; N.B. CLtL/2 semantics
479                          (push info mdecls)))))))))))
480      (setf (lexenv.vdecls env) (nconc vdecls (lexenv.vdecls env))
481            (lexenv.fdecls env) (nconc fdecls (lexenv.fdecls env))
482            (lexenv.mdecls env) (nconc mdecls (lexenv.mdecls env))))))
483
484 
485(defun cons-var (name &optional (bits 0))
486  (%istruct 'var name bits nil nil nil nil nil nil))
487
488
489(defun augment-environment (env &key variable symbol-macro function macro declare)
490  (if (and env (not (istruct-typep env 'lexical-environment)))
491    (report-bad-arg env 'lexical-environment))
492  (check-environment-args variable symbol-macro function macro)
493  (let* ((vars (mapcar #'cons-var variable))
494         (symbol-macros (mapcar #'(lambda (s)
495                                    (let* ((sym (car s)))
496                                      (unless (and (symbolp sym)
497                                                   (not (constantp sym env))
498                                                   (not (eq (variable-information sym env) :special)))
499                                        (signal-program-error "~S can't by bound as a SYMBOL-MACRO" sym))
500                                      (let ((v (cons-var (car s)))) 
501                                        (setf (var-expansion v) (cons :symbol-macro (cadr s)))
502                                        v)))
503                                symbol-macro))
504         (macros (mapcar #'(lambda (m) (list* (car m) 'macro (cadr m))) macro))
505         (functions (mapcar #'(lambda (f) (list* f 'function nil)) function))
506         (new-env (new-lexical-environment env)))
507    (setf (lexenv.variables new-env) (nconc vars symbol-macros)
508          (lexenv.functions new-env) (nconc functions macros))
509    (process-declarations new-env declare symbol-macro)
510    new-env))
511
512(defun enclose (lambda-expression &optional env)
513  (if (and env (not (istruct-typep env 'lexical-environment)))
514    (report-bad-arg env 'lexical-environment))
515  (unless (lambda-expression-p lambda-expression)
516    (error "Invalid lambda-expression ~S." lambda-expression))
517  (%make-function nil lambda-expression env))
518
519#|| Might be nicer to do %declaim
520(defmacro declaim (&rest decl-specs &environment env)
521  `(progn
522     (eval-when (:load-toplevel :execute)
523       (proclaim ',@decl-specs))
524     (eval-when (:compile-toplevel)
525       (%declaim ',@decl-specs ,env))))
526||#
527
528(defmacro declaim (&environment env &rest decl-specs)
529  "DECLAIM Declaration*
530  Do a declaration or declarations for the global environment."
531  (let* ((body (mapcar #'(lambda (spec) `(proclaim ',spec)) decl-specs)))
532  `(progn
533     (eval-when (:compile-toplevel)
534       (compile-time-proclamation ',decl-specs ,env))
535     (eval-when (:load-toplevel :execute)
536       ,@body))))
537
538(defvar *strict-checking* nil
539  "If true, issues warnings/errors in more cases, e.g. for valid but non-portable code")
540
541
542;; Should be true if compiler warnings UI doesn't use source locations, false if it does.
543(defvar *merge-compiler-warnings* t "If false, don't merge compiler warnings with different source locations")
544
545;;; If warnings have more than a single entry on their
546;;; args slot, don't merge them.
547(defun merge-compiler-warnings (old-warnings)
548  (let ((warnings nil))
549    (dolist (w old-warnings)
550      (let* ((w-args (compiler-warning-args w)))
551        (if
552          (or (cdr w-args)
553              ;; See if W can be merged into an existing warning
554              (dolist (w1 warnings t) 
555                (let ((w1-args (compiler-warning-args w1)))
556                  (when (and (eq (compiler-warning-warning-type w)
557                                 (compiler-warning-warning-type w1))
558                             w1-args
559                             (null (cdr w1-args))
560                             (eq (%car w-args)
561                                 (%car w1-args))
562                             (or *merge-compiler-warnings*
563                                 (eq (compiler-warning-source-note w)
564                                     (compiler-warning-source-note w1))))
565                    (let ((nrefs (compiler-warning-nrefs w1)))
566                      (setf (compiler-warning-nrefs w1)
567                            (cons (compiler-warning-source-note w)
568                                  (or nrefs
569                                      (list (compiler-warning-source-note w1)))))
570                      (return nil))))))
571          (push w warnings))))
572    warnings))
573
574;;; This is called by, e.g., note-function-info & so can't be -too- funky ...
575;;; don't call proclaimed-inline-p or proclaimed-notinline-p with alphatized crap
576
577(defun nx-declared-inline-p (sym env)
578  (setq sym (maybe-setf-function-name sym))
579  (loop
580    (when (listp env)
581      (return (and (symbolp sym)
582                   (proclaimed-inline-p sym))))
583    (dolist (decl (lexenv.fdecls env))
584      (when (and (eq (car decl) sym)
585                 (eq (cadr decl) 'inline))
586        (return-from nx-declared-inline-p (eq (cddr decl) 'inline))))
587    (setq env (lexenv.parent-env env))))
588
589(defun report-compile-time-argument-mismatch (condition stream &aux (type (compiler-warning-warning-type condition)))
590  (destructuring-bind (callee reason args spread-p)
591      (compiler-warning-args condition)
592    (format stream "In the ~a ~s with arguments ~:s,~%  "
593            (if spread-p "application of" "call to")
594            callee
595            args)
596    (ecase (car reason)
597      (:toomany
598       (destructuring-bind (provided max)
599           (cdr reason)
600         (format stream "~d argument~:p ~:*~[were~;was~:;were~] provided, but at most ~d ~:*~[are~;is~:;are~] accepted~&  by " provided max)))
601      (:toofew
602       (destructuring-bind (provided min)
603           (cdr reason)
604         (format stream "~d argument~:p ~:*~[were~;was~:;were~] provided, but at least ~d ~:*~[are~;is~:;are~] required~&  by " provided min)))
605      (:odd-keywords
606       (let* ((tail (cadr reason)))
607         (format stream "the variable portion of the argument list ~s contains an odd number~&  of arguments and so can't be used to initialize keyword parameters~&  for " tail)))
608      (:unknown-keyword
609       (destructuring-bind (badguy goodguys)
610           (cdr reason)
611         (format stream "the keyword argument~:[ ~s is~;s~{ ~s~^~#[~; and~:;,~]~} are~] not one of ~:s, which are recognized by "
612                 (consp badguy) badguy goodguys)))
613      (:unknown-gf-keywords
614         (let ((badguys (cadr reason)))
615           (when (and (consp badguys) (null (%cdr badguys))) (setq badguys (car badguys)))
616           (format stream "the keyword argument~:[ ~s is~;s~{ ~s~^~#[~; and~:;,~]~} are~] not recognized by "
617
618                   (consp badguys) badguys))))
619    (format stream
620            (ecase type
621              (:ftype-mismatch "the FTYPE declaration of ~s")
622              (:global-mismatch "the current global definition of ~s")
623              (:environment-mismatch "the definition of ~s visible in the current compilation unit.")
624              (:lexical-mismatch "the lexically visible definition of ~s")
625              ;; This can happen when compiling without compilation unit:
626              (:deferred-mismatch "~s"))
627            callee)))
628
629(defparameter *compiler-warning-formats*
630  '((:special . "Undeclared free variable ~S")
631    (:unused . "Unused lexical variable ~S")
632    (:ignore . "Variable ~S not ignored.")
633    (:undefined-function . "Undefined function ~S") ;; (deferred)
634    (:undefined-type . "Undefined type ~S")         ;; (deferred)
635    (:unknown-type-in-declaration . "Unknown or invalid type ~S, declaration ignored")
636    (:bad-declaration . "Unknown or invalid declaration ~S")
637    (:invalid-type . report-invalid-type-compiler-warning)
638    (:unknown-declaration-variable . "~s declaration for unknown variable ~s")
639    (:unknown-declaration-function . "~s declaration for unknown function ~s")
640    (:macro-used-before-definition . "Macro function ~S was used before it was defined.")
641    (:unsettable . "Shouldn't assign to variable ~S")
642    (:global-mismatch . report-compile-time-argument-mismatch)
643    (:environment-mismatch . report-compile-time-argument-mismatch)
644    (:lexical-mismatch . report-compile-time-argument-mismatch)   
645    (:ftype-mismatch . report-compile-time-argument-mismatch)
646    (:deferred-mismatch . report-compile-time-argument-mismatch)
647    (:type . "Type declarations violated in ~S")
648    (:type-conflict . "Conflicting type declarations for ~S")
649    (:special-fbinding . "Attempt to bind compiler special name: ~s. Result undefined.")
650    (:lambda . "Suspicious lambda-list: ~s")
651    (:incongruent-gf-lambda-list . "Lambda list of generic function ~s is incongruent with previously defined methods")
652    (:incongruent-method-lambda-list . "Lambda list of ~s is incongruent with previous definition of ~s")
653    (:gf-keys-not-accepted . "~s does not accept keywords ~s required by the generic functions")
654    (:result-ignored . "Function result ignored in call to ~s")
655    (:duplicate-definition . report-compile-time-duplicate-definition)
656    (:format-error . "~:{~@?~%~}")
657    (:program-error . "~a")
658    (:unsure . "Nonspecific warning")))
659
660(defun report-invalid-type-compiler-warning (condition stream)
661  (destructuring-bind (type &optional why) (compiler-warning-args condition)
662    (when (typep why 'invalid-type-specifier)
663      (setq type (invalid-type-specifier-typespec why) why nil))
664    (format stream "Invalid type specifier ~S~@[: ~A~]" type why)))
665
666(defun report-compile-time-duplicate-definition (condition stream)
667  (destructuring-bind (name old-file new-file &optional from to) (compiler-warning-args condition)
668    (format stream
669            "Duplicate definitions of ~s~:[~*~;~:* (as a ~a and a ~a)~]~:[~;, in this file~:[~; and in ~s~]~]"
670            (maybe-setf-name name) from to
671            (and old-file new-file)
672            (neq old-file new-file)
673            old-file)))
674
675(defun adjust-compiler-warning-args (warning-type args)
676  (case warning-type
677    ((:undefined-function :result-ignored) (mapcar #'maybe-setf-name args))
678    (t args)))
679
680
681(defun report-compiler-warning (condition stream &key short)
682  (let* ((warning-type (compiler-warning-warning-type condition))
683         (format-string (cdr (assq warning-type *compiler-warning-formats*)))
684         (warning-args (compiler-warning-args condition)))
685    (unless short
686      (let ((name (reverse (compiler-warning-function-name condition))))
687        (format stream "In ")
688        (print-nested-name name stream)
689        (when (every #'null name)
690          (let ((position (source-note-start-pos (compiler-warning-source-note condition))))
691            (when position (format stream " at position ~s" position))))
692        (format stream ": ")))
693    (if (typep format-string 'string)
694      (apply #'format stream format-string (adjust-compiler-warning-args warning-type warning-args))
695      (if (null format-string)
696        (format stream "~A: ~S" warning-type warning-args)
697        (funcall format-string condition stream)))
698    ;(format stream ".")
699    (let ((nrefs (compiler-warning-nrefs condition)))
700      (when nrefs
701        (format stream " (~D references)" (length nrefs))))))
702
703(defun environment-structref-info (name env)
704  (let ((defenv (definition-environment env)))
705    (when defenv
706      (cdr (assq name (defenv.structrefs defenv))))))
707
708;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
709;;
710;; decomp-acode
711;;
712;;  Decompile acode into something more readable.
713;;  For debugging, but also used for a code coverage feature
714
715
716(defun decomp-acode (acode)
717  (cond ((eq acode *nx-t*) t)
718        ((eq acode *nx-nil*) nil)
719        (t (let* ((op (car acode))
720                  (num (length *next-nx-operators*))
721                  (name (when (and (fixnump op)
722                                   (<= 0 op)
723                                   (setq op (logand op operator-id-mask))
724                                   (< op num))
725                          (car (nth (- num op 1) *next-nx-operators*)))))
726             (decomp-using-name (or name op) (cdr acode))))))
727
728;; TBD maybe decomp afunc-acode?
729(defun decomp-afunc (afunc)
730  (require-type afunc 'afunc))
731
732(defun decomp-var (var)
733  (var-name (require-type var 'var)))
734
735(defun decomp-formlist (formlist)
736  (mapcar #'decomp-acode formlist))
737
738(defun decomp-arglist (arglist)
739  (destructuring-bind (stack-forms register-forms) arglist
740    (nconc (decomp-formlist stack-forms)
741           (nreverse (decomp-formlist register-forms)))))
742
743(defun decomp-lambda-list (req opt rest keys auxen &optional whole)
744  (flet ((decomp-arg (var)
745           (if (acode-p var)
746             (destructuring-bind (op whole req opt rest keys auxen) var
747               (assert (eq op (%nx1-operator lambda-list))) ;; fake
748               (decomp-lambda-list req opt rest keys auxen whole))
749             (decomp-var var))))
750    (let ((whole (and whole (list '&whole (decomp-arg whole))))
751          (reqs (mapcar #'decomp-arg req))
752          (opts (when opt (cons '&optional (apply #'mapcar
753                                                  (lambda (var init supp)
754                                                    (list (decomp-arg var)
755                                                          (decomp-acode init)
756                                                          (and supp (decomp-arg supp))))
757                                                  opt))))
758          (rest (when rest (list '&rest (decomp-arg rest))))
759          (keys (when keys
760                  (destructuring-bind (aok vars supps inits keyvect) keys
761                    (nconc
762                     (when vars
763                       (cons '&key (map 'list (lambda (var supp init key)
764                                                (list* (list key (decomp-arg var))
765                                                       (decomp-acode init)
766                                                       (and supp (list (decomp-arg supp)))))
767                                        vars supps inits keyvect)))
768                     (when aok (list '&allow-other-keys))))))
769          (auxen (when (car auxen)
770                   (cons '&aux (apply #'mapcar
771                                      (lambda (var init)
772                                        (list (decomp-arg var) (decomp-acode init)))
773                                      auxen)))))
774      (nconc whole reqs opts rest keys auxen))))
775
776(defmacro defdecomp (names arglist &body body)
777  (let ((op-var (car arglist))
778        (args-vars (cdr arglist))
779        (op-decls nil)
780        (args-var (gensym)))
781    (multiple-value-bind (body decls) (parse-body body nil)
782    ;; Kludge but good enuff for here
783      (setq decls (loop for decl in decls
784                    collect (cons (car decl)
785                                  (loop for exp in (cdr decl)
786                                    do (when (and (consp exp) (member op-var (cdr exp)))
787                                         (push (list (car exp) op-var) op-decls))
788                                    collect (cons (car exp) (remove op-var (cdr exp)))))))
789    `(progn
790       ,@(loop for name in (if (atom names) (list names) names)
791           collect `(defmethod decomp-using-name ((,op-var (eql ',name)) ,args-var)
792                      (declare ,@op-decls)
793                      (destructuring-bind ,args-vars ,args-var
794                        ,@decls
795                        ,@body)))))))
796
797;; Default method
798(defmethod decomp-using-name (op forms)
799  `(,op ,@(decomp-formlist forms)))
800
801;; not real op, kludge generated below for lambda-bind
802(defdecomp keyref (op index)
803  `(,op ,index))
804
805(defdecomp immediate (op imm)
806  (declare (ignore op))
807  `',imm)
808
809(defdecomp fixnum (op raw-fixnum)
810  (declare (ignore op))
811  raw-fixnum)
812
813(defdecomp %function (op symbol)
814  (declare (ignore op))
815  `(function ,symbol))
816
817(defdecomp simple-function (op afunc)
818  (declare (ignore op))
819  `(quote ,(decomp-afunc afunc)))
820
821(defdecomp closed-function (op afunc)
822  `(,op ,(decomp-afunc afunc)))
823
824(defdecomp (progn prog1 multiple-value-prog1 or list %temp-list values) (op form-list)
825  `(,op ,@(decomp-formlist form-list)))
826
827(defdecomp multiple-value-call (op fn form-list)
828  `(,op ,(decomp-acode fn) ,@(decomp-formlist form-list)))
829
830(defdecomp vector (op formlist)
831  `(,op ,@(decomp-formlist formlist)))
832
833(defdecomp (%gvector list* %err-disp) (op arglist)
834  `(,op ,@(decomp-arglist arglist)))
835
836(defdecomp (i386-syscall syscall eabi-syscall poweropen-syscall
837            i386-ff-call ff-call eabi-ff-call poweropen-ff-call)
838           (op target argspecs argvals resultspec &rest rest)
839  `(,op
840    ,(decomp-acode target)
841    ,@(mapcan (lambda (spec val) (list spec (decomp-acode val))) argspecs argvals)
842    ,resultspec
843    ,@rest))
844
845(defdecomp (consp characterp istruct-typep %ptr-eql int>0-p %izerop endp eq %ilogbitp %base-char-p not neq) (op cc &rest forms)
846  (if (eq (acode-immediate-operand cc) :eq)
847    `(,op ,@(decomp-formlist forms))
848    `(,op ,(decomp-acode cc) ,@(decomp-formlist forms))))
849
850(defdecomp (typed-form type-asserted-form) (op typespec form &optional check-p)
851  `(,op ',typespec ,(decomp-acode form) ,check-p))
852
853(defdecomp (%i+ %i-) (op form1 form2 &optional overflow-p)
854  `(,op ,(decomp-acode form1) ,(decomp-acode form2) ,overflow-p))
855
856(defdecomp (immediate-get-xxx %immediate-set-xxx) (op bits &rest forms)
857  `(,op ,bits ,@(decomp-formlist forms)))
858
859(defdecomp call (op fn arglist &optional spread-p)
860  (declare (Ignore op))
861  `(,(if spread-p 'apply 'funcall) ,(decomp-acode fn) ,@(decomp-arglist arglist)))
862
863(defdecomp lexical-function-call (op afunc arglist &optional spread-p)
864  (declare (Ignore op))
865  `(,(if spread-p 'apply 'funcall) ,(decomp-afunc afunc) ,@(decomp-arglist arglist)))
866
867(defdecomp self-call (op arglist &optional spread-p)
868  (declare (Ignore op))
869  `(,(if spread-p 'self-apply 'self-funcall) ,@(decomp-arglist arglist)))
870
871(defdecomp (free-reference special-ref bound-special-ref global-ref) (op symbol)
872  `(,op ,symbol))
873
874(defdecomp (setq-special setq-free global-setq) (op symbol form)
875  `(,op ,symbol ,(decomp-acode form)))
876
877(defdecomp (inherited-arg lexical-reference setq-lexical) (op var &rest forms)
878  `(,op ,(decomp-var var) ,@(decomp-formlist forms)))
879
880
881(defdecomp (let let* with-downward-closures) (op vars vals body p2decls)
882  (declare (ignore p2decls))
883  `(,op ,(mapcar (lambda (var val) (list (decomp-var var) (decomp-acode val))) vars vals)
884    ,(decomp-acode body)))
885
886(defdecomp %decls-body (op form p2decls)
887  (declare (ignore p2decls))
888  `(,op ,(decomp-acode form)))
889
890(defdecomp multiple-value-bind (op vars form body p2decls)
891  (declare (ignore p2decls))
892  `(,op ,(mapcar #'decomp-var vars) ,(decomp-acode form) ,(decomp-acode body)))
893
894
895(defdecomp lambda-list (op req opt rest keys auxen body p2decls &optional code-note)
896  (declare (ignore p2decls code-note))
897  `(lambda-list ,(decomp-lambda-list req opt rest keys auxen) ,(decomp-acode body)))
898
899(defdecomp debind (op ll form req opt rest keys auxen whole body p2decls cdr-p)
900  (declare (ignore ll p2decls cdr-p))
901  `(,op ,(decomp-lambda-list req opt rest keys auxen whole) ,(decomp-acode form) ,(decomp-acode body)))
902
903(defdecomp lambda-bind (op vals req rest keys-p auxen body p2decls)
904  (declare (ignore keys-p p2decls))
905  (when (find-if #'fixnump (cadr auxen))
906    (destructuring-bind (vars vals) auxen
907      (setq auxen (list vars
908                        (mapcar (lambda (x) (if (fixnump x) `(keyref ,x) x)) vals)))))
909  (let ((lambda-list (decomp-lambda-list req nil rest nil  auxen)))
910    `(,op ,lambda-list ,(decomp-formlist vals) ,(decomp-acode body))))
911
912(defdecomp (flet labels) (op vars afuncs body p2decls)
913  (declare (ignore p2decls))
914  `(,op ,(mapcar (lambda (var afunc)
915                            (list (decomp-var var) (decomp-afunc afunc)))
916                          vars afuncs)
917    ,(decomp-acode body)))
918
919(defdecomp local-go (op tag)
920  `(,op ,(car tag)))
921
922(defdecomp tag-label (op &rest tag)
923  `(,op ,(car tag)))
924
925(defdecomp local-tagbody (op tags forms)
926  (declare (ignore tags))
927  `(,op ,@(decomp-formlist forms)))
928
929(defdecomp local-block (op block body)
930  `(,op ,(car block) ,(decomp-acode body)))
931
932(defdecomp local-return-from (op block form)
933  `(,op ,(car block) ,(decomp-acode form)))
934
935; end
Note: See TracBrowser for help on using the repository browser.