source: branches/working-0711/ccl/compiler/nx.lisp @ 8917

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

DEFINE-COMPILE-TIME-MACRO: put something in defenv.defined, so that
we can better catch forward references to macros. (Try to ensure
that that "something" is benign.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 10.0 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(in-package "CCL")
18
19(eval-when (:compile-toplevel)
20  (require 'nxenv)
21  (require 'numbers)
22  (require 'sequences)
23  (require 'optimizers))
24
25(eval-when (:load-toplevel :execute :compile-toplevel)
26  (require 'numbers) ; just calls 'logcount' and 'integer-length'
27  (require 'sort)    ; just calls '%sort-list-no-keys'
28  (require 'hash))
29
30(%include "ccl:compiler;nx-basic.lisp")
31
32(eval-when (:load-toplevel :execute)
33  (require "DEFSTRUCT"))
34
35(defparameter *nx-start* (cons nil nil))
36
37
38(defvar *host-backend*)
39(defvar *target-backend*)
40
41(defun find-backend (name)
42  (find name *known-backends* :key #'backend-name))
43
44(eval-when (:load-toplevel :execute :compile-toplevel)
45  (require "DLL-NODE")
46  #+ppc-target
47  (require "PPC32-ARCH")
48  (require "VREG")
49  #+ppc-target
50  (require "PPC-ASM")
51  (require "VINSN")
52  (require "REG")
53  (require "SUBPRIMS")
54  #+ppc-target
55  (require "PPC-LAP")
56)
57(%include "ccl:compiler;nx0.lisp")
58(%include "ccl:compiler;nx1.lisp")
59
60; put this in nx-basic too
61;(defvar *lisp-compiler-version* 666 "I lost count.")
62
63; At some point, COMPILE refused to compile things that were defined
64; in a non-null lexical environment (or so I remember.)   That seems
65; to have been broken when the change of 10/11/93 was made.
66; It makes no sense to talk about compiling something that was defined
67; in a lexical environment in which there are symbol or function bindings
68; present;  I'd thought that the old code checked for this, though it
69; may well have botched it.
70(defun compile (spec &optional def &aux (macro-p nil))
71  "Coerce DEFINITION (by default, the function whose name is NAME)
72  to a compiled function, returning (VALUES THING WARNINGS-P FAILURE-P),
73  where if NAME is NIL, THING is the result of compilation, and
74  otherwise THING is NAME. When NAME is not NIL, the compiled function
75  is also set into (MACRO-FUNCTION NAME) if NAME names a macro, or into
76  (FDEFINITION NAME) otherwise."
77  (unless def
78    (setq def (fboundp spec))
79    (when (and (symbolp spec) (not (lfunp def)))
80      (setq def (setq macro-p (macro-function spec)))))
81  #+have-interpreted-functions
82  (when (typep def 'interpreted-function)
83    (let ((lambda (function-lambda-expression def)))
84      (when lambda (setq def lambda))))
85  (unless def
86    (nx-error "Can't find compilable definition for ~S." spec))
87  (multiple-value-bind (lfun warnings)
88                       (if (functionp def)
89                         def
90                         (compile-named-function def
91                                                 :name spec
92                                                 :keep-lambda *save-definitions*
93                                                 :keep-symbols *save-local-symbols*))
94    (let ((harsh nil) (some nil) (init t))
95      (dolist (w warnings)
96        (multiple-value-setq (harsh some) (signal-compiler-warning w init nil harsh some))
97        (setq init nil))
98      (values
99       (if spec
100         (progn
101           (if macro-p
102             (setf (macro-function spec) lfun)
103             (setf (fdefinition spec) lfun))
104           spec)
105         lfun)
106       some
107       harsh))))
108
109(defparameter *default-compiler-policy* (new-compiler-policy))
110
111(defun current-compiler-policy () *default-compiler-policy*)
112
113(defun set-current-compiler-policy (&optional new-policy)
114  (setq *default-compiler-policy* 
115        (if new-policy (require-type new-policy 'compiler-policy) (new-compiler-policy))))
116
117#+ppc-target
118(defun xcompile-lambda (target def)
119  (let* ((*ppc2-debug-mask* (ash 1 ppc2-debug-vinsns-bit))
120         (backend (find-backend target))
121         (*target-ftd* (if backend
122                         (backend-target-foreign-type-data backend)
123                         *target-ftd*))
124         (*target-backend* (or backend *target-backend*)))
125    (multiple-value-bind (xlfun warnings)
126        (compile-named-function def :target target)
127      (signal-or-defer-warnings warnings nil)
128      (ppc-xdisassemble xlfun :target target)
129      xlfun)))
130
131(defun signal-or-defer-warnings (warnings env)
132  (let* ((defenv (definition-environment env))
133         (init t)
134         (defer (and defenv (cdr (defenv.type defenv)) *outstanding-deferred-warnings*)))
135    (dolist (w warnings)
136      (if (and defer (typep w 'undefined-function-reference))
137        (push w (deferred-warnings.warnings defer))
138        (progn
139          (signal-compiler-warning w init nil nil nil)
140          (setq init nil))))))
141
142(defparameter *load-time-eval-token* nil)
143(defparameter *nx-source-note-map* nil)
144
145(defun note-contained-in-p (note parent)
146  (loop for n = note then (code-note-source n) while (code-note-p n) thereis (eq n parent)))
147
148(defun nx-find-code-note (form)
149  ;; Try to find a source note for this form.  The act of matching up a source note with
150  ;; forms that might come from macroexpansion is heuristic at best.  In general, err in
151  ;; favor of not matching, because that leads to fewer false positives in code coverage
152  ;; reporting.
153  (when (or (consp form) (stringp form) (pathnamep form))
154    (let ((note (gethash form *nx-source-note-map*)))
155      (unless (listp note)
156        note))))
157
158(defun nx-ensure-code-note (form original parent-note)
159  ;; Try to find a source note for this form; if can't, just make a new record for it.
160  (let* ((source-note (or (and original (nx-find-code-note original))
161                          (nx-find-code-note form)))
162         (note (if (and source-note
163                        ;; Look out for a case like a lambda macro that turns (lambda ...)
164                        ;; into (FUNCTION (lambda ...)) which then has (lambda ...)
165                        ;; as a child.  Create a fresh note for the child, to avoid ambiguity.
166                        ;; Another case is forms wrapping THE around themselves.
167                        (neq source-note parent-note)
168                        ;; Don't use source notes from a different toplevel form, which could
169                        ;; happen due to inlining etc.  The result then is that the source note
170                        ;; appears in multiple places, and shows partial coverage (from the
171                        ;; other reference) in code that's never executed.
172                        (loop for p = parent-note then (code-note-parent-note p)
173                              when (null p) return t
174                              when (source-note-p p)
175                              return (let ((n source-note))
176                                       (loop as s = (code-note-source p)
177                                             while (source-note-p s) do (setq p s))
178                                       (loop as s = (code-note-source n)
179                                             while (source-note-p s) do (setq n s))
180                                       (eq n p))))
181                 source-note
182                 (make-code-note :form (or original form) :source parent-note))))
183    (register-code-note-parent note parent-note)
184    note))
185
186(eval-when (:compile-toplevel)
187  (declaim (ftype (function (&rest ignore) t)  ppc-compile)))
188
189(defparameter *nx-discard-xref-info-hook* nil)
190
191(defun compile-named-function (definition &key name env function-note keep-lambda keep-symbols policy load-time-eval-token target source-notes)
192  (when (and name *nx-discard-xref-info-hook*)
193    (funcall *nx-discard-xref-info-hook* name))
194  (setq 
195   definition
196   (let* ((*load-time-eval-token* load-time-eval-token)
197          (*nx-source-note-map* source-notes)
198          (*nx1-source-note-map* (and *fasl-save-source-locations* *nx-source-note-map*))
199          (*nx-current-code-note* (and source-notes
200                                       *compile-code-coverage*
201                                       (nx-ensure-code-note definition nil function-note)))
202          (*definition-source-note* (and *fasl-save-source-locations*
203                                         (or function-note
204                                             (and *form-source-note-map* (gethash definition *form-source-note-map*)))))
205          (env (new-lexical-environment env)))
206     (setf (lexenv.variables env) 'barrier)
207       (let* ((*target-backend* (or (if target (find-backend target)) *host-backend*))
208              (afunc (nx1-compile-lambda 
209                      name 
210                      definition 
211                      (make-afunc) 
212                      nil 
213                      env 
214                      (or policy *default-compiler-policy*)
215                      *load-time-eval-token*)))
216         (if (afunc-lfun afunc)
217             afunc
218             (funcall (backend-p2-compile *target-backend*)
219                      afunc
220                      ;; will also bind *nx-lexical-environment*
221                      (if keep-lambda (if (lambda-expression-p keep-lambda) keep-lambda definition))
222                      keep-symbols)))))
223  (values (afunc-lfun definition) (afunc-warnings definition)))
224 
225(defun compile-user-function (def name &optional env)
226  (multiple-value-bind (lfun warnings)
227      (compile-named-function def
228                              :name name
229                              :env env
230                              :keep-lambda *save-definitions*
231                              :keep-symbols *save-local-symbols*)
232    (signal-or-defer-warnings warnings env)
233    lfun))
234
235(defparameter *compiler-whining-conditions*
236  '((:undefined-function . undefined-function-reference)
237    (:global-mismatch . invalid-arguments-global)
238    (:lexical-mismatch . invalid-arguments)
239    (:environment-mismatch . invalid-arguments)
240    (:ignore . style-warning)
241    (:result-ignored . style-warning)
242    (:unused . style-warning)))
243
244
245
246(defun compiler-bug (format &rest args)
247  (error (make-condition 'compiler-bug
248                         :format-control format
249                         :format-arguments args)))
250
251
252(defparameter *nx-end* (cons nil nil))
253(provide 'nx)
254
255(defun define-compile-time-macro (name lambda-expression env)
256  (let ((definition-env (definition-environment env)))
257    (when definition-env
258      (push (list* name 
259                   'macro 
260                   (compile-named-function lambda-expression :name name :env env)) 
261            (defenv.functions definition-env))
262      (record-function-info name (cons nil 'macro) env))
263    name))
Note: See TracBrowser for help on using the repository browser.