source: branches/gz-working/compiler/nx.lisp @ 8505

Last change on this file since 8505 was 8505, checked in by gz, 13 years ago

checkpoint work in progress, mainly some final cleanup, reorg, don't try to track atoms, keep track of source through transforms; reporting implementation in library;cover.lisp

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