source: branches/qres/ccl/compiler/nx.lisp @ 15278

Last change on this file since 15278 was 13165, checked in by gz, 10 years ago

merge r13143, r13164 (fixes to compiler type handling)

  • 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) 2009 Clozure Associates
4;;;   Copyright (C) 1994-2001 Digitool, Inc
5;;;   This file is part of Clozure CL. 
6;;;
7;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
8;;;   License , known as the LLGPL and distributed with Clozure CL as the
9;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
10;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
11;;;   conflict, the preamble takes precedence. 
12;;;
13;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
14;;;
15;;;   The LLGPL is also available online at
16;;;   http://opensource.franz.com/preamble.html
17
18(in-package "CCL")
19
20(eval-when (:compile-toplevel)
21  (require 'nxenv)
22  (require 'numbers)
23  (require 'sequences)
24  (require 'optimizers))
25
26(eval-when (:load-toplevel :execute :compile-toplevel)
27  (require 'numbers) ; just calls 'logcount' and 'integer-length'
28  (require 'sort)    ; just calls '%sort-list-no-keys'
29  (require 'hash))
30
31(%include "ccl:compiler;nx-basic.lisp")
32
33(eval-when (:load-toplevel :execute)
34  (require "DEFSTRUCT"))
35
36(defparameter *nx-start* (cons nil nil))
37
38
39(defvar *host-backend*)
40(defvar *target-backend*)
41
42(defun find-backend (name)
43  (find name *known-backends* :key #'backend-name))
44
45(eval-when (:load-toplevel :execute :compile-toplevel)
46  (require "DLL-NODE")
47  #+ppc-target
48  (require "PPC32-ARCH")
49  (require "VREG")
50  #+ppc-target
51  (require "PPC-ASM")
52  (require "VINSN")
53  (require "REG")
54  (require "SUBPRIMS")
55  #+ppc-target
56  (require "PPC-LAP")
57)
58(%include "ccl:compiler;nx0.lisp")
59(%include "ccl:compiler;nx1.lisp")
60
61; put this in nx-basic too
62;(defvar *lisp-compiler-version* 666 "I lost count.")
63
64; At some point, COMPILE refused to compile things that were defined
65; in a non-null lexical environment (or so I remember.)   That seems
66; to have been broken when the change of 10/11/93 was made.
67; It makes no sense to talk about compiling something that was defined
68; in a lexical environment in which there are symbol or function bindings
69; present;  I'd thought that the old code checked for this, though it
70; may well have botched it.
71(defun compile (spec &optional def &aux (macro-p nil))
72  "Coerce DEFINITION (by default, the function whose name is NAME)
73  to a compiled function, returning (VALUES THING WARNINGS-P FAILURE-P),
74  where if NAME is NIL, THING is the result of compilation, and
75  otherwise THING is NAME. When NAME is not NIL, the compiled function
76  is also set into (MACRO-FUNCTION NAME) if NAME names a macro, or into
77  (FDEFINITION NAME) otherwise."
78  (unless def
79    (setq def (fboundp spec))
80    (when (and (symbolp spec) (not (lfunp def)))
81      (setq def (setq macro-p (macro-function spec)))))
82  #+have-interpreted-functions
83  (when (typep def 'interpreted-function)
84    (let ((lambda (function-lambda-expression def)))
85      (when lambda (setq def lambda))))
86  (unless def
87    (nx-error "Can't find compilable definition for ~S." spec))
88  (multiple-value-bind (lfun warnings)
89                       (if (functionp def)
90                         def
91                         (compile-named-function def
92                                                 :name spec
93                                                 :keep-lambda *save-definitions*
94                                                 :keep-symbols *save-local-symbols*))
95    (let ((harsh nil) (some nil) (init t))
96      (dolist (w warnings)
97        (multiple-value-setq (harsh some) (signal-compiler-warning w init nil harsh some))
98        (setq init nil))
99      (values
100       (if spec
101         (progn
102           (if macro-p
103             (setf (macro-function spec) lfun)
104             (setf (fdefinition spec) lfun))
105           spec)
106         lfun)
107       some
108       harsh))))
109
110(defparameter *default-compiler-policy* (new-compiler-policy))
111
112(defun current-compiler-policy () *default-compiler-policy*)
113
114(defun set-current-compiler-policy (&optional new-policy)
115  (setq *default-compiler-policy* 
116        (if new-policy (require-type new-policy 'compiler-policy) (new-compiler-policy))))
117
118#+ppc-target
119(defun xcompile-lambda (target def)
120  (let* ((*ppc2-debug-mask* (ash 1 ppc2-debug-vinsns-bit))
121         (backend (find-backend target))
122         (*target-ftd* (if backend
123                         (backend-target-foreign-type-data backend)
124                         *target-ftd*))
125         (*target-backend* (or backend *target-backend*)))
126    (multiple-value-bind (xlfun warnings)
127        (compile-named-function def :target target)
128      (signal-or-defer-warnings warnings nil)
129      (ppc-xdisassemble xlfun :target target)
130      xlfun)))
131 
132(defun compile-user-function (def name &optional env)
133  (multiple-value-bind (lfun warnings)
134                       (compile-named-function def
135                                               :name name
136                                               :env env
137                                               :keep-lambda *save-definitions*
138                                               :keep-symbols *save-local-symbols*)
139    (signal-or-defer-warnings warnings env)
140    lfun))
141
142(defun signal-or-defer-warnings (warnings env)
143  (let* ((defenv (definition-environment env))
144         (init t)
145         (defer (and defenv (cdr (defenv.type defenv)) *outstanding-deferred-warnings*)))
146    (dolist (w warnings)
147      (if (and defer (typep w 'undefined-reference))
148        (push w (deferred-warnings.warnings defer))
149        (progn
150          (signal-compiler-warning w init nil nil nil)
151          (setq init nil))))))
152
153(defparameter *load-time-eval-token* nil)
154
155(defparameter *nx-discard-xref-info-hook* nil)
156
157(defparameter *nx-in-frontend* nil)
158
159(defun compile-named-function (def &key name env policy load-time-eval-token target
160                                function-note keep-lambda keep-symbols source-notes
161                                (record-pc-mapping *record-pc-mapping*)
162                                (compile-code-coverage *compile-code-coverage*))
163  ;; SOURCE-NOTES, if not nil, is a hash table mapping source forms to locations,
164  ;;   is used to produce and attach a pc/source map to the lfun, also to attach
165  ;;   source locations and pc/source maps to inner lfuns.
166  ;; FUNCTION-NOTE, if not nil, is a note to attach to the function as the lfun
167  ;;   source location in preference to whatever the source-notes table assigns to it.
168  (when (and name *nx-discard-xref-info-hook*)
169    (funcall *nx-discard-xref-info-hook* name))
170  (setq 
171   def
172   (let* ((*load-time-eval-token* load-time-eval-token)
173          (*nx-source-note-map* source-notes)
174          (*nx-current-note* function-note)
175          (*record-pc-mapping* (and source-notes record-pc-mapping))
176          (*compile-code-coverage* (and source-notes compile-code-coverage))
177          (*nx-acode-note-map* (and (or *record-pc-mapping* *compile-code-coverage*)
178                                    (make-hash-table :test #'eq :shared nil)))
179          (*nx-current-code-note* (and *compile-code-coverage*
180                                       (make-code-note :form def :source-note function-note)))
181          (env (new-lexical-environment env)))
182     (setf (lexenv.variables env) 'barrier)
183     (let* ((*target-backend* (or (if target (find-backend target)) *host-backend*))
184            (*nx-in-frontend* t)
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       (setq *nx-in-frontend* nil)
194       (if (afunc-lfun afunc)
195         afunc
196         (funcall (backend-p2-compile *target-backend*)
197                  afunc
198                  ;; will also bind *nx-lexical-environment*
199                  (if keep-lambda (if (lambda-expression-p keep-lambda) keep-lambda def))
200                  keep-symbols)))))
201  (values (afunc-lfun def) (afunc-warnings def)))
202
203(defparameter *compiler-whining-conditions*
204  '((:undefined-function . undefined-function-reference)
205    (:undefined-type . undefined-type-reference)
206    (:deferred-mismatch . undefined-keyword-reference)
207    (:invalid-type . invalid-type-warning)
208    (:global-mismatch . invalid-arguments-global)
209    (:lexical-mismatch . invalid-arguments)
210    (:environment-mismatch . invalid-arguments)
211    (:ftype-mismatch . invalid-arguments)
212    (:ignore . style-warning)
213    (:result-ignored . style-warning)
214    (:lambda . style-warning)
215    (:format-error . style-warning)
216    (:unused . style-warning)))
217
218
219
220(defun compiler-bug (format &rest args)
221  (error (make-condition 'compiler-bug
222                         :format-control format
223                         :format-arguments args)))
224
225
226(defparameter *nx-end* (cons nil nil))
227(provide 'nx)
228
Note: See TracBrowser for help on using the repository browser.