source: release/1.3/source/compiler/nx.lisp @ 11747

Last change on this file since 11747 was 11747, checked in by rme, 11 years ago

Merge trunk changes through r11740.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 8.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
154(defparameter *nx-discard-xref-info-hook* nil)
155
156(defun compile-named-function (def &key name env policy load-time-eval-token target
157                                function-note keep-lambda keep-symbols source-notes
158                                (record-pc-mapping *record-pc-mapping*)
159                                (compile-code-coverage *compile-code-coverage*))
160  ;; SOURCE-NOTES, if not nil, is a hash table mapping source forms to locations,
161  ;;   is used to produce and attach a pc/source map to the lfun, also to attach
162  ;;   source locations and pc/source maps to inner lfuns.
163  ;; FUNCTION-NOTE, if not nil, is a note to attach to the function as the lfun
164  ;;   source location in preference to whatever the source-notes table assigns to it.
165  (when (and name *nx-discard-xref-info-hook*)
166    (funcall *nx-discard-xref-info-hook* name))
167  (setq 
168   def
169   (let* ((*load-time-eval-token* load-time-eval-token)
170          (*nx-source-note-map* source-notes)
171          (*nx-current-note* function-note)
172          (*record-pc-mapping* (and source-notes record-pc-mapping))
173          (*compile-code-coverage* (and source-notes compile-code-coverage))
174          (*nx-acode-note-map* (and (or *record-pc-mapping* *compile-code-coverage*)
175                                    (make-hash-table :test #'eq :shared nil)))
176          (*nx-current-code-note* (and *compile-code-coverage*
177                                       (make-code-note :form def :source-note function-note)))
178          (env (new-lexical-environment env)))
179     (setf (lexenv.variables env) 'barrier)
180     (let* ((*target-backend* (or (if target (find-backend target)) *host-backend*))
181            (afunc (nx1-compile-lambda 
182                    name 
183                    def
184                    (make-afunc) 
185                    nil 
186                    env 
187                    (or policy *default-compiler-policy*)
188                    *load-time-eval-token*)))
189       (if (afunc-lfun afunc)
190         afunc
191         (funcall (backend-p2-compile *target-backend*)
192                  afunc
193                  ;; will also bind *nx-lexical-environment*
194                  (if keep-lambda (if (lambda-expression-p keep-lambda) keep-lambda def))
195                  keep-symbols)))))
196  (values (afunc-lfun def) (afunc-warnings def)))
197
198(defparameter *compiler-whining-conditions*
199  '((:undefined-function . undefined-function-reference)
200    (:global-mismatch . invalid-arguments-global)
201    (:lexical-mismatch . invalid-arguments)
202    (:environment-mismatch . invalid-arguments)
203    (:ignore . style-warning)
204    (:result-ignored . style-warning)
205    (:lambda . style-warning)
206    (:unused . style-warning)))
207
208
209
210(defun compiler-bug (format &rest args)
211  (error (make-condition 'compiler-bug
212                         :format-control format
213                         :format-arguments args)))
214
215
216(defparameter *nx-end* (cons nil nil))
217(provide 'nx)
218
Note: See TracBrowser for help on using the repository browser.