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

Last change on this file since 8554 was 8554, checked in by mb, 14 years ago

Merge in mb-coverage-merge branch. No other changes.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 10.9 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 parent-source)
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.  But still, try hard to match things up best we can.  The main problem is
153  ;; with atoms, which the source recording stuff doesn't track properly.
154  #| -- This doesn't work, period, it leads to too many false positives.  The problem
155    -- is that even if we have just one instance of the form in the parent source,
156    -- there might be many generated occurences that do NOT correspond to the one
157    -- in the source, and the form can be one of those, leading to false positives on the
158    -- source version.
159  (when parent-source
160    (let ((note (gethash form *nx-source-note-map*)))
161      (cond ((consp note)
162             ;; This form (typically an atom) has multiple source locations.
163             ;; At least try to distinguish occurences in different outer forms.  This allows
164             ;; reasonable code coverage reporting for "(if (test) t (other))", although it
165             ;; doesn't work for cases like "(if foo foo (other))".
166             (loop with found = nil
167               for n in note
168               ;; I tried allowing parent-source to be an indirect ancestor, but that would
169               ;; catch unrelated references in outer forms.
170               when (eq (code-note-source n) parent-source)
171               do (if found (return nil) (setq found n))
172               finally (return found)))
173            ((not (null note))
174             (when (note-contained-in-p note parent-source)
175               ;; As an aside, here's a fun code coverage issue:  What if the same source
176               ;; form (i.e. single source location) gets used multiple times. e.g.
177               ;; (macrolet ((dup (x) `(progn (foo ,x) (bar ,x)))) (dup (something))).
178               ;; We could arrange to have separate records for each instance, but as of right
179               ;; now no existing or contemplated UI has a means of showing the distinction,
180               ;; so don't bother.
181               note))
182            (t nil))))
183  |#
184  (when (and parent-source
185             (or (consp form) (vectorp form) (pathnamep form)))
186    (let ((note (gethash form *nx-source-note-map*)))
187      (unless (listp note)
188        note))))
189
190(defun nx-ensure-code-note (form original parent-note)
191  ;; Try to find a source note for this form; if can't, just make a new record for it.
192  (let* ((parent-source (loop for n = parent-note then (code-note-source n)
193                          when (or (null n) (source-note-p n)) return n))
194         (note (or (and original (nx-find-code-note original parent-source))
195                   (nx-find-code-note form parent-source)
196                   (make-code-note :form (or original form) :source parent-note))))
197    (when (and parent-note (neq note parent-note))
198      (push note (code-note-subform-notes parent-note)))
199    note))
200
201(eval-when (:compile-toplevel)
202  (declaim (ftype (function (&rest ignore) t)  ppc-compile)))
203
204(defparameter *nx-discard-xref-info-hook* nil)
205
206(defun compile-named-function (definition &key name env function-note keep-lambda keep-symbols policy load-time-eval-token target source-notes)
207  (when (and name *nx-discard-xref-info-hook*)
208    (funcall *nx-discard-xref-info-hook* name))
209  (setq 
210   definition
211   (let ((*load-time-eval-token* load-time-eval-token)
212         (*nx-source-note-map* source-notes)
213         (*definition-source-note* (and *form-source-note-map* (gethash definition *form-source-note-map*)))
214         (env (new-lexical-environment env)))
215     (setf (lexenv.variables env) 'barrier)
216       (let* ((*target-backend* (or (if target (find-backend target)) *host-backend*))
217              (afunc (nx1-compile-lambda 
218                      name 
219                      definition 
220                      (make-afunc) 
221                      nil 
222                      env 
223                      (or policy *default-compiler-policy*)
224                      *load-time-eval-token*
225                      function-note)))
226         (if (afunc-lfun afunc)
227             afunc
228             (funcall (backend-p2-compile *target-backend*)
229                      afunc
230                      ;; will also bind *nx-lexical-environment*
231                      (if keep-lambda (if (lambda-expression-p keep-lambda) keep-lambda definition))
232                      keep-symbols)))))
233  (values (afunc-lfun definition) (afunc-warnings definition)))
234 
235(defun compile-user-function (def name &optional env)
236  (multiple-value-bind (lfun warnings)
237      (compile-named-function def
238                              :name name
239                              :env env
240                              :keep-lambda *save-definitions*
241                              :keep-symbols *save-local-symbols*)
242    (signal-or-defer-warnings warnings env)
243    lfun))
244
245(defparameter *compiler-whining-conditions*
246  '((:undefined-function . undefined-function-reference)
247    (:global-mismatch . invalid-arguments-global)
248    (:lexical-mismatch . invalid-arguments)
249    (:environment-mismatch . invalid-arguments)
250    (:ignore . style-warning)
251    (:unused . style-warning)))
252
253
254
255(defun compiler-bug (format &rest args)
256  (error (make-condition 'compiler-bug
257                         :format-control format
258                         :format-arguments args)))
259
260
261(defparameter *nx-end* (cons nil nil))
262(provide 'nx)
263
264(defun define-compile-time-macro (name lambda-expression env)
265  (let ((definition-env (definition-environment env)))
266    (if definition-env
267      (push (list* name 
268                   'macro 
269                   (compile-named-function lambda-expression :name name :env env)) 
270            (defenv.functions definition-env)))
271    name))
Note: See TracBrowser for help on using the repository browser.