source: trunk/source/compiler/nx.lisp @ 15094

Last change on this file since 15094 was 14421, checked in by gb, 10 years ago

systems.lisp, compile-ccl.lisp, l1-boot-2.lisp: Compile and load
ACODE-REWRITE.

acode-rewrite.lisp: new, improved ... still not working, still not
complete.

nx.lisp: COMPILE-NAMED-FUNCTION optionally rewrites acode after generating
it (under control of *NX-REWRITE-ACODE*, for now.)

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 9.2 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
32(%include "ccl:compiler;nx-basic.lisp")
33
34(eval-when (:load-toplevel :execute)
35  (require "DEFSTRUCT"))
36
37(defparameter *nx-start* (cons nil nil))
38
39
40(defvar *host-backend*)
41(defvar *target-backend*)
42
43(defun find-backend (name)
44  (find name *known-backends* :key #'backend-name))
45
46(eval-when (:load-toplevel :execute :compile-toplevel)
47  (require "DLL-NODE")
48  #+ppc-target
49  (require "PPC32-ARCH")
50  (require "VREG")
51  #+ppc-target
52  (require "PPC-ASM")
53  (require "VINSN")
54  (require "REG")
55  (require "SUBPRIMS")
56  #+ppc-target
57  (require "PPC-LAP")
58)
59(%include "ccl:compiler;nx0.lisp")
60(%include "ccl:compiler;nx1.lisp")
61
62; put this in nx-basic too
63;(defvar *lisp-compiler-version* 666 "I lost count.")
64
65; At some point, COMPILE refused to compile things that were defined
66; in a non-null lexical environment (or so I remember.)   That seems
67; to have been broken when the change of 10/11/93 was made.
68; It makes no sense to talk about compiling something that was defined
69; in a lexical environment in which there are symbol or function bindings
70; present;  I'd thought that the old code checked for this, though it
71; may well have botched it.
72(defun compile (spec &optional def &aux (macro-p nil))
73  "Coerce DEFINITION (by default, the function whose name is NAME)
74  to a compiled function, returning (VALUES THING WARNINGS-P FAILURE-P),
75  where if NAME is NIL, THING is the result of compilation, and
76  otherwise THING is NAME. When NAME is not NIL, the compiled function
77  is also set into (MACRO-FUNCTION NAME) if NAME names a macro, or into
78  (FDEFINITION NAME) otherwise."
79  (unless def
80    (setq def (fboundp spec))
81    (when (and (symbolp spec) (not (lfunp def)))
82      (setq def (setq macro-p (macro-function spec)))))
83  #+have-interpreted-functions
84  (when (typep def 'interpreted-function)
85    (let ((lambda (function-lambda-expression def)))
86      (when lambda (setq def lambda))))
87  (unless def
88    (nx-error "Can't find compilable definition for ~S." spec))
89  (multiple-value-bind (lfun warnings)
90                       (if (functionp def)
91                         def
92                         (compile-named-function def
93                                                 :name spec
94                                                 :keep-lambda *save-definitions*
95                                                 :keep-symbols *save-local-symbols*))
96    (let ((harsh nil) (some nil) (init t))
97      (dolist (w warnings)
98        (multiple-value-setq (harsh some) (signal-compiler-warning w init nil harsh some))
99        (setq init nil))
100      (values
101       (if spec
102         (progn
103           (if macro-p
104             (setf (macro-function spec) lfun)
105             (setf (fdefinition spec) lfun))
106           spec)
107         lfun)
108       some
109       harsh))))
110
111(defparameter *default-compiler-policy* (new-compiler-policy))
112
113(defun current-compiler-policy () *default-compiler-policy*)
114
115(defun set-current-compiler-policy (&optional new-policy)
116  (setq *default-compiler-policy* 
117        (if new-policy (require-type new-policy 'compiler-policy) (new-compiler-policy))))
118
119#+ppc-target
120(defun xcompile-lambda (target def)
121  (let* ((*ppc2-debug-mask* (ash 1 ppc2-debug-vinsns-bit))
122         (backend (find-backend target))
123         (*target-ftd* (if backend
124                         (backend-target-foreign-type-data backend)
125                         *target-ftd*))
126         (*target-backend* (or backend *target-backend*)))
127    (multiple-value-bind (xlfun warnings)
128        (compile-named-function def :target target)
129      (signal-or-defer-warnings warnings nil)
130      (ppc-xdisassemble xlfun :target target)
131      xlfun)))
132 
133(defun compile-user-function (def name &optional env)
134  (multiple-value-bind (lfun warnings)
135                       (compile-named-function def
136                                               :name name
137                                               :env env
138                                               :keep-lambda *save-definitions*
139                                               :keep-symbols *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-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(defparameter *nx-discard-xref-info-hook* nil)
158
159(defparameter *nx-in-frontend* nil)
160(defparameter *nx-rewrite-acode* nil)
161
162
163(defun compile-named-function (def &key name env policy load-time-eval-token target
164                                function-note keep-lambda keep-symbols source-notes
165                                (record-pc-mapping *record-pc-mapping*)
166                                (compile-code-coverage *compile-code-coverage*))
167  ;; SOURCE-NOTES, if not nil, is a hash table mapping source forms to locations,
168  ;;   is used to produce and attach a pc/source map to the lfun, also to attach
169  ;;   source locations and pc/source maps to inner lfuns.
170  ;; FUNCTION-NOTE, if not nil, is a note to attach to the function as the lfun
171  ;;   source location in preference to whatever the source-notes table assigns to it.
172  (when (and name *nx-discard-xref-info-hook*)
173    (funcall *nx-discard-xref-info-hook* name))
174  (setq 
175   def
176   (let* ((*load-time-eval-token* load-time-eval-token)
177          (*nx-source-note-map* source-notes)
178          (*nx-current-note* function-note)
179          (*record-pc-mapping* (and source-notes record-pc-mapping))
180          (*compile-code-coverage* (and source-notes compile-code-coverage))
181          (*nx-acode-note-map* (and (or *record-pc-mapping* *compile-code-coverage*)
182                                    (make-hash-table :test #'eq :shared nil)))
183          (*nx-current-code-note* (and *compile-code-coverage*
184                                       (make-code-note :form def :source-note function-note)))
185          (env (new-lexical-environment env)))
186     (setf (lexenv.variables env) 'barrier)
187     (let* ((*target-backend* (or (if target (find-backend target)) *host-backend*))
188            (*nx-target-fixnum-type*
189             (target-word-size-case
190              (32 *nx-32-bit-fixnum-type*)
191              (64 *nx-64-bit-fixnum-type*)))
192            (*nx-target-natural-type*
193               (target-word-size-case
194                (32 *nx-32-bit-natural-type*)
195                (64 *nx-64-bit-natural-type*)))
196            (*nx-in-frontend* t)
197            (afunc (nx1-compile-lambda 
198                    name 
199                    def
200                    (make-afunc) 
201                    nil 
202                    env 
203                    (or policy *default-compiler-policy*)
204                    *load-time-eval-token*)))
205       (setq *nx-in-frontend* nil)
206       (if (afunc-lfun afunc)
207         afunc
208         (progn
209           (when (and *nx-rewrite-acode*
210                      (afunc-acode afunc))
211             (rewrite-acode-form (afunc-acode afunc) t))
212           (funcall (backend-p2-compile *target-backend*)
213                    afunc
214                    ;; will also bind *nx-lexical-environment*
215                    (if keep-lambda (if (lambda-expression-p keep-lambda) keep-lambda def))
216                    keep-symbols))))))
217  (values (afunc-lfun def) (afunc-warnings def)))
218
219(defparameter *compiler-whining-conditions*
220  '((:undefined-function . undefined-function-reference)
221    (:undefined-type . undefined-type-reference)
222    (:deferred-mismatch . undefined-keyword-reference)
223    (:invalid-type . invalid-type-warning)
224    (:global-mismatch . invalid-arguments-global)
225    (:lexical-mismatch . invalid-arguments)
226    (:environment-mismatch . invalid-arguments)
227    (:ftype-mismatch . invalid-arguments)
228    (:unknown-type-in-declaration . style-warning)
229    (:ignore . style-warning)
230    (:result-ignored . style-warning)
231    (:lambda . style-warning)
232    (:format-error . style-warning)
233    (:unused . style-warning)
234    (:type-conflict . style-warning)))
235
236
237
238(defun compiler-bug (format &rest args)
239  (error (make-condition 'compiler-bug
240                         :format-control format
241                         :format-arguments args)))
242
243
244(defparameter *nx-end* (cons nil nil))
245(provide 'nx)
246
Note: See TracBrowser for help on using the repository browser.