source: trunk/source/compiler/nx.lisp @ 15528

Last change on this file since 15528 was 15528, checked in by gb, 7 years ago

Try to emit a clearer warning if a SPECIAL variable is declared IGNORE.
Fixes ticket:1035 in the trunk.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 11.3 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(in-package "CCL")
19
20(eval-when (:compile-toplevel)
21  (require 'nxenv)
22  (require 'numbers)
23  (require 'sequences)
24  (require 'optimizers))
25
26(eval-when (:load-toplevel :execute :compile-toplevel)
27  (require 'numbers) ; just calls 'logcount' and 'integer-length'
28  (require 'sort)    ; just calls '%sort-list-no-keys'
29  (require 'hash))
30
31
32(%include "ccl:compiler;nx-basic.lisp")
33
34(eval-when (:load-toplevel :execute)
35  (require "DEFSTRUCT"))
36
37(defparameter *nx-start* (cons nil nil))
38
39
40
41
42
43(defun %def-info.lambda (def-info)
44  (and def-info
45       (let ((data (svref def-info 3)))
46         (or (and (consp (car data)) (eq (caar data) 'lambda) (car data))
47             (and (eq (car data) 'lambda) data)))))
48
49
50
51(defun %def-info.environment (def-info)
52  (and def-info
53       (let* ((data (svref def-info 3)))
54         (and (consp (car data))
55              (eq (caar data) 'lambda)
56              (cdr data)))))
57
58(defun def-info.function-type (def-info)
59  (if (null def-info)
60    nil ;; ftype only, for the purposes here, is same as nothing.
61    (let ((data (svref def-info 3)))
62      (if (and (consp (car data)) (eq 'lambda (caar data)))
63        'defun
64        (ecase (car data)
65          ((nil lambda) 'defun)
66          (:methods 'defgeneric)
67          (macro 'defmacro)
68          (ftype nil)
69          (type nil))))))
70
71;;; Return T if and only if the lexical environment contains variable
72;;; or function bindings (other than macros or symbol-macros).
73(defun binding-free-environment-p (env)
74  (do* ((env env (lexenv.parent-env env)))
75       ((or (null env) (typep env 'definition-environment)) t)
76    (let* ((vars (lexenv.variables env)))
77      (unless (or (atom vars)
78                  (dolist (var vars t)
79                    (let* ((ea (var-ea var)))
80                      (unless (and (consp ea)
81                                 (eq (car ea) :symbol-macro))
82                        (return)))))
83        (return)))
84    (unless (dolist (f (lexenv.functions env) t)
85              (unless (and (consp f)
86                           (consp (cdr f))
87                           (eq 'macro (cadr f)))
88                (return))))))
89         
90
91(defun retain-lambda-expression (name lambda-expression env)
92  (if (and (let* ((lambda-list (cadr lambda-expression)))
93             (and (not (memq '&lap lambda-list))
94                  (not (memq '&method lambda-list))
95                  (not (memq '&lexpr lambda-list))))
96           (nx-declared-inline-p name env)
97           (not (gethash name *nx1-alphatizers*))
98           (binding-free-environment-p env))
99    (cons lambda-expression env)))
100
101(defvar *host-backend*)
102(defvar *target-backend*)
103
104(defun find-backend (name)
105  (find name *known-backends* :key #'backend-name))
106
107(eval-when (:load-toplevel :execute :compile-toplevel)
108  (require "DLL-NODE")
109  #+ppc-target
110  (require "PPC32-ARCH")
111  (require "VREG")
112  #+ppc-target
113  (require "PPC-ASM")
114  (require "VINSN")
115  (require "REG")
116  (require "SUBPRIMS")
117  #+ppc-target
118  (require "PPC-LAP")
119)
120(%include "ccl:compiler;nx0.lisp")
121(%include "ccl:compiler;nx1.lisp")
122
123; put this in nx-basic too
124;(defvar *lisp-compiler-version* 666 "I lost count.")
125
126; At some point, COMPILE refused to compile things that were defined
127; in a non-null lexical environment (or so I remember.)   That seems
128; to have been broken when the change of 10/11/93 was made.
129; It makes no sense to talk about compiling something that was defined
130; in a lexical environment in which there are symbol or function bindings
131; present;  I'd thought that the old code checked for this, though it
132; may well have botched it.
133(defun compile (spec &optional def &aux (macro-p nil))
134  "Coerce DEFINITION (by default, the function whose name is NAME)
135  to a compiled function, returning (VALUES THING WARNINGS-P FAILURE-P),
136  where if NAME is NIL, THING is the result of compilation, and
137  otherwise THING is NAME. When NAME is not NIL, the compiled function
138  is also set into (MACRO-FUNCTION NAME) if NAME names a macro, or into
139  (FDEFINITION NAME) otherwise."
140  (unless def
141    (setq def (fboundp spec))
142    (when (and (symbolp spec) (not (lfunp def)))
143      (setq def (setq macro-p (macro-function spec)))))
144  #+have-interpreted-functions
145  (when (typep def 'interpreted-function)
146    (let ((lambda (function-lambda-expression def)))
147      (when lambda (setq def lambda))))
148  (unless def
149    (nx-error "Can't find compilable definition for ~S." spec))
150  (multiple-value-bind (lfun warnings)
151                       (if (functionp def)
152                         def
153                         (compile-named-function def
154                                                 :name spec
155                                                 :keep-lambda *save-definitions*
156                                                 :keep-symbols *save-local-symbols*))
157    (let ((harsh nil) (some nil) (init t))
158      (dolist (w warnings)
159        (multiple-value-setq (harsh some) (signal-compiler-warning w init nil harsh some))
160        (setq init nil))
161      (values
162       (if spec
163         (progn
164           (if macro-p
165             (setf (macro-function spec) lfun)
166             (setf (fdefinition spec) lfun))
167           spec)
168         lfun)
169       some
170       harsh))))
171
172(defparameter *default-compiler-policy* (new-compiler-policy))
173
174(defun current-compiler-policy () *default-compiler-policy*)
175
176(defun set-current-compiler-policy (&optional new-policy)
177  (setq *default-compiler-policy* 
178        (if new-policy (require-type new-policy 'compiler-policy) (new-compiler-policy))))
179
180#+ppc-target
181(defun xcompile-lambda (target def)
182  (let* ((*ppc2-debug-mask* (ash 1 ppc2-debug-vinsns-bit))
183         (backend (find-backend target))
184         (*target-ftd* (if backend
185                         (backend-target-foreign-type-data backend)
186                         *target-ftd*))
187         (*target-backend* (or backend *target-backend*)))
188    (multiple-value-bind (xlfun warnings)
189        (compile-named-function def :target target)
190      (signal-or-defer-warnings warnings nil)
191      (ppc-xdisassemble xlfun :target target)
192      xlfun)))
193 
194(defun compile-user-function (def name &optional env)
195  (multiple-value-bind (lfun warnings)
196                       (compile-named-function def
197                                               :name name
198                                               :env env
199                                               :keep-lambda *save-definitions*
200                                               :keep-symbols *save-local-symbols*)
201    (signal-or-defer-warnings warnings env)
202    lfun))
203
204(defun signal-or-defer-warnings (warnings env)
205  (let* ((defenv (definition-environment env))
206         (init t)
207         (defer (and defenv (cdr (defenv.type defenv)) *outstanding-deferred-warnings*)))
208    (dolist (w warnings)
209      (if (and defer (typep w 'undefined-reference))
210        (push w (deferred-warnings.warnings defer))
211        (progn
212          (signal-compiler-warning w init nil nil nil)
213          (setq init nil))))))
214
215(defparameter *load-time-eval-token* nil)
216
217
218(defparameter *nx-discard-xref-info-hook* nil)
219
220(defparameter *nx-in-frontend* nil)
221(defparameter *nx-rewrite-acode* nil)
222
223
224(defun compile-named-function (def &key name env policy load-time-eval-token target
225                                function-note keep-lambda keep-symbols source-notes
226                                (record-pc-mapping *record-pc-mapping*)
227                                (compile-code-coverage *compile-code-coverage*))
228  ;; SOURCE-NOTES, if not nil, is a hash table mapping source forms to locations,
229  ;;   is used to produce and attach a pc/source map to the lfun, also to attach
230  ;;   source locations and pc/source maps to inner lfuns.
231  ;; FUNCTION-NOTE, if not nil, is a note to attach to the function as the lfun
232  ;;   source location in preference to whatever the source-notes table assigns to it.
233  (when (and name *nx-discard-xref-info-hook*)
234    (funcall *nx-discard-xref-info-hook* name))
235  (setq 
236   def
237   (let* ((*load-time-eval-token* load-time-eval-token)
238          (*nx-source-note-map* source-notes)
239          (*nx-current-note* function-note)
240          (*record-pc-mapping* (and source-notes record-pc-mapping))
241          (*compile-code-coverage* (and source-notes compile-code-coverage))
242          (*nx-acode-note-map* (and (or *record-pc-mapping* *compile-code-coverage*)
243                                    (make-hash-table :test #'eq :shared nil)))
244          (*nx-current-code-note* (and *compile-code-coverage*
245                                       (make-code-note :form def :source-note function-note)))
246          (env (new-lexical-environment env)))
247     (setf (lexenv.variables env) 'barrier)
248     (let* ((*target-backend* (or (if target (find-backend target)) *host-backend*))
249            (*nx-target-fixnum-type*
250             (target-word-size-case
251              (32 *nx-32-bit-fixnum-type*)
252              (64 *nx-64-bit-fixnum-type*)))
253            (*nx-target-natural-type*
254               (target-word-size-case
255                (32 *nx-32-bit-natural-type*)
256                (64 *nx-64-bit-natural-type*)))
257            (*nx-in-frontend* t)
258            (afunc (nx1-compile-lambda 
259                    name 
260                    def
261                    (make-afunc) 
262                    nil 
263                    env 
264                    (or policy *default-compiler-policy*)
265                    *load-time-eval-token*)))
266       (setq *nx-in-frontend* nil)
267       (if (afunc-lfun afunc)
268         afunc
269         (progn
270           (when (and *nx-rewrite-acode*
271                      (afunc-acode afunc))
272             (rewrite-acode-form (afunc-acode afunc) t))
273           (funcall (backend-p2-compile *target-backend*)
274                    afunc
275                    ;; will also bind *nx-lexical-environment*
276                    (if keep-lambda (if (lambda-expression-p keep-lambda) keep-lambda def))
277                    keep-symbols))))))
278  (values (afunc-lfun def) (afunc-warnings def)))
279
280(defparameter *compiler-whining-conditions*
281  '((:undefined-function . undefined-function-reference)
282    (:undefined-type . undefined-type-reference)
283    (:deferred-mismatch . undefined-keyword-reference)
284    (:invalid-type . invalid-type-warning)
285    (:global-mismatch . invalid-arguments-global)
286    (:lexical-mismatch . invalid-arguments)
287    (:environment-mismatch . invalid-arguments)
288    (:ftype-mismatch . invalid-arguments)
289    (:unknown-type-in-declaration . style-warning)
290    (:ignore . style-warning)
291    (:result-ignored . style-warning)
292    (:lambda . style-warning)
293    (:format-error . style-warning)
294    (:unused . style-warning)
295    (:type-conflict . style-warning)
296    (:special-ignore . style-warning)))
297
298
299
300(defun compiler-bug (format &rest args)
301  (error (make-condition 'compiler-bug
302                         :format-control format
303                         :format-arguments args)))
304
305
306(defparameter *nx-end* (cons nil nil))
307(provide 'nx)
308
Note: See TracBrowser for help on using the repository browser.