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

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

Merge/bootstrap assorted low level stuff from trunk - kernel, syscall stuff, lowmem-bias, formatting tweaks, a few bug fixes included

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 9.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(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)
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.
163  (when (or (consp form) (stringp form) (pathnamep form))
164    (let ((note (gethash form *nx-source-note-map*)))
165      (unless (listp note)
166        note))))
167
168(defun nx-ensure-code-note (form original parent-note)
169  ;; Try to find a source note for this form; if can't, just make a new record for it.
170  (let* ((source-note (or (and original (nx-find-code-note original))
171                          (nx-find-code-note form)))
172         (note (if (and source-note
173                        ;; Look out for a case like a lambda macro that turns (lambda ...)
174                        ;; into (FUNCTION (lambda ...)) which then has (lambda ...)
175                        ;; as a child.  Create a fresh note for the child, to avoid ambiguity.
176                        ;; Another case is forms wrapping THE around themselves.
177                        (neq source-note parent-note)
178                        ;; Don't use source notes from a different toplevel form, which could
179                        ;; happen due to inlining etc.  The result then is that the source note
180                        ;; appears in multiple places, and shows partial coverage (from the
181                        ;; other reference) in code that's never executed.
182                        (loop for p = parent-note then (code-note-parent-note p)
183                              when (null p) return t
184                              when (source-note-p p)
185                              return (let ((n source-note))
186                                       (loop as s = (code-note-source p)
187                                             while (source-note-p s) do (setq p s))
188                                       (loop as s = (code-note-source n)
189                                             while (source-note-p s) do (setq n s))
190                                       (eq n p))))
191                 source-note
192                 (make-code-note :form (or original form) :source parent-note))))
193    (register-code-note-parent note parent-note)
194    note))
195
196(eval-when (:compile-toplevel)
197  (declaim (ftype (function (&rest ignore) t)  ppc-compile)))
198
199(defparameter *nx-discard-xref-info-hook* nil)
200
201(defun compile-named-function (def &key name env function-note keep-lambda keep-symbols policy load-time-eval-token target source-notes)
202  (when (and name *nx-discard-xref-info-hook*)
203    (funcall *nx-discard-xref-info-hook* name))
204  (setq 
205   def
206   (let* ((*load-time-eval-token* load-time-eval-token)
207          (*nx-source-note-map* source-notes)
208          (*nx1-source-note-map* (and *fasl-save-source-locations* *nx-source-note-map*))
209          (*nx-current-code-note* (and source-notes
210                                       *compile-code-coverage*
211                                       (nx-ensure-code-note def nil function-note)))
212          (*definition-source-note* (and *fasl-save-source-locations*
213                                         (or function-note
214                                             (and *form-source-note-map* (gethash def *form-source-note-map*)))))
215          (env (new-lexical-environment env)))
216     (setf (lexenv.variables env) 'barrier)
217       (let* ((*target-backend* (or (if target (find-backend target)) *host-backend*))
218              (afunc (nx1-compile-lambda 
219                      name 
220                      def
221                      (make-afunc) 
222                      nil 
223                      env 
224                      (or policy *default-compiler-policy*)
225                      *load-time-eval-token*)))
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 def))
232                      keep-symbols)))))
233  (values (afunc-lfun def) (afunc-warnings def)))
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    (:lambda . style-warning)
243    (:unused . style-warning)))
244
245
246
247(defun compiler-bug (format &rest args)
248  (error (make-condition 'compiler-bug
249                         :format-control format
250                         :format-arguments args)))
251
252
253(defparameter *nx-end* (cons nil nil))
254(provide 'nx)
255
Note: See TracBrowser for help on using the repository browser.