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

Last change on this file since 12339 was 12339, checked in by gz, 11 years ago

Merge source location and code coverage implementation from the trunk. Some of the effects include:

  • make source notes take up less space
  • for code coverage, don't use with-code-coverage in pass2, therefore less impact on produced code.
  • accept method-function's in source location lookup
  • fix some cases that caused function source notes to not get recorded
  • record source files if source locations recording is not on.
  • record source locations in compile-time eval-when's.
  • better tracking of source notes through file compilation in some cases.
  • restore *fasl-eof-forms* support.
  • export a source-note API instead of converting to plists
  • only count emitted notes in cover coverage form totals
  • code coverage now more often has the source note for the whole definition.

Added :CCL-1.4 to *features*, to allow swank to be conditionalized for these changes (which will be part of CCL's 1.4 release)

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 8.6 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 compile-user-function (def name &optional env)
132  (multiple-value-bind (lfun warnings)
133                       (compile-named-function def
134                                               :name name
135                                               :env env
136                                               :keep-lambda *save-definitions*
137                                               :keep-symbols *save-local-symbols*)
138    (signal-or-defer-warnings warnings env)
139    lfun))
140
141#-BOOTSTRAPPED (unless (find-class 'undefined-reference nil)
142                 (deftype undefined-reference () 'undefined-function-reference)
143                 (defclass undefined-type-reference (undefined-function-reference) ()))
144
145(defun signal-or-defer-warnings (warnings env)
146  (let* ((defenv (definition-environment env))
147         (init t)
148         (defer (and defenv (cdr (defenv.type defenv)) *outstanding-deferred-warnings*)))
149    (dolist (w warnings)
150      (if (and defer (typep w 'undefined-reference))
151        (push w (deferred-warnings.warnings defer))
152        (progn
153          (signal-compiler-warning w init nil nil nil)
154          (setq init nil))))))
155
156(defparameter *load-time-eval-token* nil)
157
158(defparameter *nx-discard-xref-info-hook* nil)
159
160(defun compile-named-function (def &key name env policy load-time-eval-token target
161                                function-note keep-lambda keep-symbols source-notes
162                                (record-pc-mapping *record-pc-mapping*)
163                                (compile-code-coverage *compile-code-coverage*))
164  ;; SOURCE-NOTES, if not nil, is a hash table mapping source forms to locations,
165  ;;   is used to produce and attach a pc/source map to the lfun, also to attach
166  ;;   source locations and pc/source maps to inner lfuns.
167  ;; FUNCTION-NOTE, if not nil, is a note to attach to the function as the lfun
168  ;;   source location in preference to whatever the source-notes table assigns to it.
169  (when (and name *nx-discard-xref-info-hook*)
170    (funcall *nx-discard-xref-info-hook* name))
171  (setq 
172   def
173   (let* ((*load-time-eval-token* load-time-eval-token)
174          (*nx-source-note-map* source-notes)
175          (*nx-current-note* function-note)
176          (*record-pc-mapping* (and source-notes record-pc-mapping))
177          (*compile-code-coverage* (and source-notes compile-code-coverage))
178          (*nx-acode-note-map* (and (or *record-pc-mapping* *compile-code-coverage*)
179                                    (make-hash-table :test #'eq :shared nil)))
180          (*nx-current-code-note* (and *compile-code-coverage*
181                                       (make-code-note :form def :source-note function-note)))
182          (env (new-lexical-environment env)))
183     (setf (lexenv.variables env) 'barrier)
184     (let* ((*target-backend* (or (if target (find-backend target)) *host-backend*))
185            (afunc (nx1-compile-lambda 
186                    name 
187                    def
188                    (make-afunc) 
189                    nil 
190                    env 
191                    (or policy *default-compiler-policy*)
192                    *load-time-eval-token*)))
193       (if (afunc-lfun afunc)
194         afunc
195         (funcall (backend-p2-compile *target-backend*)
196                  afunc
197                  ;; will also bind *nx-lexical-environment*
198                  (if keep-lambda (if (lambda-expression-p keep-lambda) keep-lambda def))
199                  keep-symbols)))))
200  (values (afunc-lfun def) (afunc-warnings def)))
201
202(defparameter *compiler-whining-conditions*
203  '((:undefined-function . undefined-function-reference)
204    (:undefined-type . undefined-type-reference)
205    (:invalid-type . invalid-type-warning)
206    (:global-mismatch . invalid-arguments-global)
207    (:lexical-mismatch . invalid-arguments)
208    (:environment-mismatch . invalid-arguments)
209    (:ignore . style-warning)
210    (:result-ignored . style-warning)
211    (:lambda . style-warning)
212    (:format-error . style-warning)
213    (:unused . style-warning)))
214
215
216
217(defun compiler-bug (format &rest args)
218  (error (make-condition 'compiler-bug
219                         :format-control format
220                         :format-arguments args)))
221
222
223(defparameter *nx-end* (cons nil nil))
224(provide 'nx)
225
Note: See TracBrowser for help on using the repository browser.