source: branches/1.2-devel/ccl/compiler/nx.lisp @ 15278

Last change on this file since 15278 was 7719, checked in by gb, 12 years ago

Add #'compiler-bug.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 7.1 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 spec nil *save-definitions* *save-local-symbols*))
91    (let ((harsh nil) (some nil) (init t))
92      (dolist (w warnings)
93        (multiple-value-setq (harsh some) (signal-compiler-warning w init nil harsh some))
94        (setq init nil))
95      (values
96       (if spec
97         (progn
98           (if macro-p
99             (setf (macro-function spec) lfun)
100             (setf (fdefinition spec) lfun))
101           spec)
102         lfun)
103       some
104       harsh))))
105
106(defparameter *default-compiler-policy* (new-compiler-policy))
107
108(defun current-compiler-policy () *default-compiler-policy*)
109
110(defun set-current-compiler-policy (&optional new-policy)
111  (setq *default-compiler-policy* 
112        (if new-policy (require-type new-policy 'compiler-policy) (new-compiler-policy))))
113
114#+ppc-target
115(defun xcompile-lambda (target def)
116  (let* ((*ppc2-debug-mask* (ash 1 ppc2-debug-vinsns-bit))
117         (backend (find-backend target))
118         (*target-ftd* (if backend
119                         (backend-target-foreign-type-data backend)
120                         *target-ftd*))
121         (*target-backend* (or backend *target-backend*)))
122    (multiple-value-bind (xlfun warnings)
123        (compile-named-function def nil
124                                nil
125                                nil
126                                nil
127                                nil
128                                nil
129                                target)
130      (signal-or-defer-warnings warnings nil)
131      (ppc-xdisassemble xlfun :target target)
132      xlfun)))
133 
134(defun compile-user-function (def name &optional env)
135  (multiple-value-bind (lfun warnings)
136                       (compile-named-function def name
137                                               env
138                                               *save-definitions*
139                                               *save-local-symbols*)
140    (signal-or-defer-warnings warnings env)
141    lfun))
142
143(defun signal-or-defer-warnings (warnings env)
144  (let* ((defenv (definition-environment env))
145         (init t)
146         (defer (and defenv (cdr (defenv.type defenv)) *outstanding-deferred-warnings*)))
147    (dolist (w warnings)
148      (if (and defer (typep w 'undefined-function-reference))
149        (push w (deferred-warnings.warnings defer))
150        (progn
151          (signal-compiler-warning w init nil nil nil)
152          (setq init nil))))))
153
154(defparameter *load-time-eval-token* nil)
155
156
157
158
159(eval-when (:compile-toplevel)
160  (declaim (ftype (function (&rest ignore) t)  ppc-compile)))
161
162(defparameter *nx-discard-xref-info-hook* nil)
163
164(defun compile-named-function
165    (def &optional name env keep-lambda keep-symbols policy *load-time-eval-token* target)
166  (when (and name *nx-discard-xref-info-hook*)
167    (funcall *nx-discard-xref-info-hook* name))
168  (setq 
169   def
170   (let ((env (new-lexical-environment env)))
171     (setf (lexenv.variables env) 'barrier)
172       (let* ((*target-backend* (or (if target (find-backend target)) *host-backend*))
173              (afunc (nx1-compile-lambda 
174                      name 
175                      def 
176                      (make-afunc) 
177                      nil 
178                      env 
179                      (or policy *default-compiler-policy*)
180                      *load-time-eval-token*)))
181         (if (afunc-lfun afunc)
182           afunc
183           (funcall (backend-p2-compile *target-backend*)
184            afunc
185            ; will also bind *nx-lexical-environment*
186            (if keep-lambda (if (lambda-expression-p keep-lambda) keep-lambda def))
187            keep-symbols)))))
188  (values (afunc-lfun def) (afunc-warnings def)))
189
190
191 
192
193
194
195
196(defparameter *compiler-whining-conditions*
197  '((:undefined-function . undefined-function-reference)
198    (:global-mismatch . invalid-arguments-global)
199    (:lexical-mismatch . invalid-arguments)
200    (:environment-mismatch . invalid-arguments)
201    (:ignore . style-warning)
202    (:unused . style-warning)))
203
204
205
206(defun compiler-bug (format &rest args)
207  (error (make-condition 'compiler-bug
208                         :format-control format
209                         :format-arguments args)))
210
211
212(defparameter *nx-end* (cons nil nil))
213(provide 'nx)
214
Note: See TracBrowser for help on using the repository browser.