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

Last change on this file since 8646 was 8646, checked in by gz, 14 years ago

Assorted code coverage fixes:

  • stop using the 'function-source-note property of lfun-info, conflicts with meta-. and was problematic anyway. Pass function entry note directly through nx1-lambda on.
  • be more careful about tracking macroexpansions/transformations in a number of places, one interesting change being to add note-source-transformation to allow macros to report unusual transformations, and make defgeneric use it for :method's.
  • be more careful about tracking parent/child code note relationships in various ways.
  • Better handling of nested functions.
  • Better handling of inlining (or rather, better avoidance of screws caused by inlining, actual code coverage info for inlining still not available).
  • Assorted fixes in code coverage reporting, account for internal functions, ensure coloring outside-in, default :statistic to T.
  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 9.8 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          (*nx-current-code-note* (and source-notes
199                                       *compile-code-coverage*
200                                       (nx-ensure-code-note definition nil function-note)))
201          (*definition-source-note* (and *form-source-note-map* (gethash definition *form-source-note-map*)))
202          (env (new-lexical-environment env)))
203     (setf (lexenv.variables env) 'barrier)
204       (let* ((*target-backend* (or (if target (find-backend target)) *host-backend*))
205              (afunc (nx1-compile-lambda 
206                      name 
207                      definition 
208                      (make-afunc) 
209                      nil 
210                      env 
211                      (or policy *default-compiler-policy*)
212                      *load-time-eval-token*)))
213         (if (afunc-lfun afunc)
214             afunc
215             (funcall (backend-p2-compile *target-backend*)
216                      afunc
217                      ;; will also bind *nx-lexical-environment*
218                      (if keep-lambda (if (lambda-expression-p keep-lambda) keep-lambda definition))
219                      keep-symbols)))))
220  (values (afunc-lfun definition) (afunc-warnings definition)))
221 
222(defun compile-user-function (def name &optional env)
223  (multiple-value-bind (lfun warnings)
224      (compile-named-function def
225                              :name name
226                              :env env
227                              :keep-lambda *save-definitions*
228                              :keep-symbols *save-local-symbols*)
229    (signal-or-defer-warnings warnings env)
230    lfun))
231
232(defparameter *compiler-whining-conditions*
233  '((:undefined-function . undefined-function-reference)
234    (:global-mismatch . invalid-arguments-global)
235    (:lexical-mismatch . invalid-arguments)
236    (:environment-mismatch . invalid-arguments)
237    (:ignore . style-warning)
238    (:unused . style-warning)))
239
240
241
242(defun compiler-bug (format &rest args)
243  (error (make-condition 'compiler-bug
244                         :format-control format
245                         :format-arguments args)))
246
247
248(defparameter *nx-end* (cons nil nil))
249(provide 'nx)
250
251(defun define-compile-time-macro (name lambda-expression env)
252  (let ((definition-env (definition-environment env)))
253    (if definition-env
254      (push (list* name 
255                   'macro 
256                   (compile-named-function lambda-expression :name name :env env)) 
257            (defenv.functions definition-env)))
258    name))
Note: See TracBrowser for help on using the repository browser.