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

Last change on this file since 15526 was 15526, checked in by gb, 7 years ago

Change the way that (APPLY inlined-functon args) inlines: don't use the
ancient DEBIND mechanism (which depends on a hairy subprim in the kernel
and which generates fairly bad code), but "manually" do a LET* and a
DESTRUCTURING-BIND with some environment hacking in NX1-DESTRUCTURE.

The environment hacking (processing the inlined function in the lexical
environment in which it was defined) was the argument for using the
magical DEBIND mechanism. However, it's been a while (if ever) since
we inlined anything that was defined in a non-null lexical environment,
so we didn't really retain the environment of definition. Hack things
up to do so, at least in the case where the inlined function is defined
in the current (file-)compilation environment. This involved changing
some of the def-info.* acccessors, and bootstrapping it involved moving
some of those accessors from l1-readloop.lisp to nx.lisp, at least for
the time being.

Change the implementation of DESTRUCTURING-BIND: don't use a
DESTRUCTURE-STATE object, do generate code to explicitly check the
length of the list wrt the lambda-list (and try to signal clear errors
if the check fails), and don't be so sloppy about binding SUPPLIED-P
variables for &optional/&key before the corresponding variables.
(This sloppiness caused us to not warn about an unused supplied-p
variable in PPRINT-LOGICAL-BLOCK.)

Since the new DESTRUCTURING-BIND code expands into many POPs, try
to make PROG1 better about unnecessary pushes/pops to the stack
in the x86 backend. (Should do this on ARM too; it's not that
critical in the DESTRUCTURING-BIND case but may matter elsewhere.)

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 11.3 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
41
42
43(defun %def-info.lambda (def-info)
44  (and def-info
45       (let ((data (svref def-info 3)))
46         (or (and (consp (car data)) (eq (caar data) 'lambda) (car data))
47             (and (eq (car data) 'lambda) data)))))
48
49
50
51(defun %def-info.environment (def-info)
52  (and def-info
53       (let* ((data (svref def-info 3)))
54         (and (consp (car data))
55              (eq (caar data) 'lambda)
56              (cdr data)))))
57
58(defun def-info.function-type (def-info)
59  (if (null def-info)
60    nil ;; ftype only, for the purposes here, is same as nothing.
61    (let ((data (svref def-info 3)))
62      (if (and (consp (car data)) (eq 'lambda (caar data)))
63        'defun
64        (ecase (car data)
65          ((nil lambda) 'defun)
66          (:methods 'defgeneric)
67          (macro 'defmacro)
68          (ftype nil)
69          (type nil))))))
70
71;;; Return T if and only if the lexical environment contains variable
72;;; or function bindings (other than macros or symbol-macros).
73(defun binding-free-environment-p (env)
74  (do* ((env env (lexenv.parent-env env)))
75       ((or (null env) (typep env 'definition-environment)) t)
76    (let* ((vars (lexenv.variables env)))
77      (unless (or (atom vars)
78                  (dolist (var vars t)
79                    (let* ((ea (var-ea var)))
80                      (unless (and (consp ea)
81                                 (eq (car ea) :symbol-macro))
82                        (return)))))
83        (return)))
84    (unless (dolist (f (lexenv.functions env) t)
85              (unless (and (consp f)
86                           (consp (cdr f))
87                           (eq 'macro (cadr f)))
88                (return))))))
89         
90
91(defun retain-lambda-expression (name lambda-expression env)
92  (if (and (let* ((lambda-list (cadr lambda-expression)))
93             (and (not (memq '&lap lambda-list))
94                  (not (memq '&method lambda-list))
95                  (not (memq '&lexpr lambda-list))))
96           (nx-declared-inline-p name env)
97           (not (gethash name *nx1-alphatizers*))
98           (binding-free-environment-p env))
99    (cons lambda-expression env)))
100
101(defvar *host-backend*)
102(defvar *target-backend*)
103
104(defun find-backend (name)
105  (find name *known-backends* :key #'backend-name))
106
107(eval-when (:load-toplevel :execute :compile-toplevel)
108  (require "DLL-NODE")
109  #+ppc-target
110  (require "PPC32-ARCH")
111  (require "VREG")
112  #+ppc-target
113  (require "PPC-ASM")
114  (require "VINSN")
115  (require "REG")
116  (require "SUBPRIMS")
117  #+ppc-target
118  (require "PPC-LAP")
119)
120(%include "ccl:compiler;nx0.lisp")
121(%include "ccl:compiler;nx1.lisp")
122
123; put this in nx-basic too
124;(defvar *lisp-compiler-version* 666 "I lost count.")
125
126; At some point, COMPILE refused to compile things that were defined
127; in a non-null lexical environment (or so I remember.)   That seems
128; to have been broken when the change of 10/11/93 was made.
129; It makes no sense to talk about compiling something that was defined
130; in a lexical environment in which there are symbol or function bindings
131; present;  I'd thought that the old code checked for this, though it
132; may well have botched it.
133(defun compile (spec &optional def &aux (macro-p nil))
134  "Coerce DEFINITION (by default, the function whose name is NAME)
135  to a compiled function, returning (VALUES THING WARNINGS-P FAILURE-P),
136  where if NAME is NIL, THING is the result of compilation, and
137  otherwise THING is NAME. When NAME is not NIL, the compiled function
138  is also set into (MACRO-FUNCTION NAME) if NAME names a macro, or into
139  (FDEFINITION NAME) otherwise."
140  (unless def
141    (setq def (fboundp spec))
142    (when (and (symbolp spec) (not (lfunp def)))
143      (setq def (setq macro-p (macro-function spec)))))
144  #+have-interpreted-functions
145  (when (typep def 'interpreted-function)
146    (let ((lambda (function-lambda-expression def)))
147      (when lambda (setq def lambda))))
148  (unless def
149    (nx-error "Can't find compilable definition for ~S." spec))
150  (multiple-value-bind (lfun warnings)
151                       (if (functionp def)
152                         def
153                         (compile-named-function def
154                                                 :name spec
155                                                 :keep-lambda *save-definitions*
156                                                 :keep-symbols *save-local-symbols*))
157    (let ((harsh nil) (some nil) (init t))
158      (dolist (w warnings)
159        (multiple-value-setq (harsh some) (signal-compiler-warning w init nil harsh some))
160        (setq init nil))
161      (values
162       (if spec
163         (progn
164           (if macro-p
165             (setf (macro-function spec) lfun)
166             (setf (fdefinition spec) lfun))
167           spec)
168         lfun)
169       some
170       harsh))))
171
172(defparameter *default-compiler-policy* (new-compiler-policy))
173
174(defun current-compiler-policy () *default-compiler-policy*)
175
176(defun set-current-compiler-policy (&optional new-policy)
177  (setq *default-compiler-policy* 
178        (if new-policy (require-type new-policy 'compiler-policy) (new-compiler-policy))))
179
180#+ppc-target
181(defun xcompile-lambda (target def)
182  (let* ((*ppc2-debug-mask* (ash 1 ppc2-debug-vinsns-bit))
183         (backend (find-backend target))
184         (*target-ftd* (if backend
185                         (backend-target-foreign-type-data backend)
186                         *target-ftd*))
187         (*target-backend* (or backend *target-backend*)))
188    (multiple-value-bind (xlfun warnings)
189        (compile-named-function def :target target)
190      (signal-or-defer-warnings warnings nil)
191      (ppc-xdisassemble xlfun :target target)
192      xlfun)))
193 
194(defun compile-user-function (def name &optional env)
195  (multiple-value-bind (lfun warnings)
196                       (compile-named-function def
197                                               :name name
198                                               :env env
199                                               :keep-lambda *save-definitions*
200                                               :keep-symbols *save-local-symbols*)
201    (signal-or-defer-warnings warnings env)
202    lfun))
203
204(defun signal-or-defer-warnings (warnings env)
205  (let* ((defenv (definition-environment env))
206         (init t)
207         (defer (and defenv (cdr (defenv.type defenv)) *outstanding-deferred-warnings*)))
208    (dolist (w warnings)
209      (if (and defer (typep w 'undefined-reference))
210        (push w (deferred-warnings.warnings defer))
211        (progn
212          (signal-compiler-warning w init nil nil nil)
213          (setq init nil))))))
214
215(defparameter *load-time-eval-token* nil)
216
217
218(defparameter *nx-discard-xref-info-hook* nil)
219
220(defparameter *nx-in-frontend* nil)
221(defparameter *nx-rewrite-acode* nil)
222
223
224(defun compile-named-function (def &key name env policy load-time-eval-token target
225                                function-note keep-lambda keep-symbols source-notes
226                                (record-pc-mapping *record-pc-mapping*)
227                                (compile-code-coverage *compile-code-coverage*))
228  ;; SOURCE-NOTES, if not nil, is a hash table mapping source forms to locations,
229  ;;   is used to produce and attach a pc/source map to the lfun, also to attach
230  ;;   source locations and pc/source maps to inner lfuns.
231  ;; FUNCTION-NOTE, if not nil, is a note to attach to the function as the lfun
232  ;;   source location in preference to whatever the source-notes table assigns to it.
233  (when (and name *nx-discard-xref-info-hook*)
234    (funcall *nx-discard-xref-info-hook* name))
235  (setq 
236   def
237   (let* ((*load-time-eval-token* load-time-eval-token)
238          (*nx-source-note-map* source-notes)
239          (*nx-current-note* function-note)
240          (*record-pc-mapping* (and source-notes record-pc-mapping))
241          (*compile-code-coverage* (and source-notes compile-code-coverage))
242          (*nx-acode-note-map* (and (or *record-pc-mapping* *compile-code-coverage*)
243                                    (make-hash-table :test #'eq :shared nil)))
244          (*nx-current-code-note* (and *compile-code-coverage*
245                                       (make-code-note :form def :source-note function-note)))
246          (env (new-lexical-environment env)))
247     (setf (lexenv.variables env) 'barrier)
248     (let* ((*target-backend* (or (if target (find-backend target)) *host-backend*))
249            (*nx-target-fixnum-type*
250             (target-word-size-case
251              (32 *nx-32-bit-fixnum-type*)
252              (64 *nx-64-bit-fixnum-type*)))
253            (*nx-target-natural-type*
254               (target-word-size-case
255                (32 *nx-32-bit-natural-type*)
256                (64 *nx-64-bit-natural-type*)))
257            (*nx-in-frontend* t)
258            (afunc (nx1-compile-lambda 
259                    name 
260                    def
261                    (make-afunc) 
262                    nil 
263                    env 
264                    (or policy *default-compiler-policy*)
265                    *load-time-eval-token*)))
266       (setq *nx-in-frontend* nil)
267       (if (afunc-lfun afunc)
268         afunc
269         (progn
270           (when (and *nx-rewrite-acode*
271                      (afunc-acode afunc))
272             (rewrite-acode-form (afunc-acode afunc) t))
273           (funcall (backend-p2-compile *target-backend*)
274                    afunc
275                    ;; will also bind *nx-lexical-environment*
276                    (if keep-lambda (if (lambda-expression-p keep-lambda) keep-lambda def))
277                    keep-symbols))))))
278  (values (afunc-lfun def) (afunc-warnings def)))
279
280(defparameter *compiler-whining-conditions*
281  '((:undefined-function . undefined-function-reference)
282    (:undefined-type . undefined-type-reference)
283    (:deferred-mismatch . undefined-keyword-reference)
284    (:invalid-type . invalid-type-warning)
285    (:global-mismatch . invalid-arguments-global)
286    (:lexical-mismatch . invalid-arguments)
287    (:environment-mismatch . invalid-arguments)
288    (:ftype-mismatch . invalid-arguments)
289    (:unknown-type-in-declaration . style-warning)
290    (:ignore . style-warning)
291    (:result-ignored . style-warning)
292    (:lambda . style-warning)
293    (:format-error . style-warning)
294    (:unused . style-warning)
295    (:type-conflict . style-warning)))
296
297
298
299(defun compiler-bug (format &rest args)
300  (error (make-condition 'compiler-bug
301                         :format-control format
302                         :format-arguments args)))
303
304
305(defparameter *nx-end* (cons nil nil))
306(provide 'nx)
307
Note: See TracBrowser for help on using the repository browser.