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 signal-or-defer-warnings (warnings env) |
---|
132 | (let* ((defenv (definition-environment env)) |
---|
133 | (init t) |
---|
134 | (defer (and defenv (cdr (defenv.type defenv)) *outstanding-deferred-warnings*))) |
---|
135 | (dolist (w warnings) |
---|
136 | (if (and defer (typep w 'undefined-function-reference)) |
---|
137 | (push w (deferred-warnings.warnings defer)) |
---|
138 | (progn |
---|
139 | (signal-compiler-warning w init nil nil nil) |
---|
140 | (setq init nil)))))) |
---|
141 | |
---|
142 | (defparameter *load-time-eval-token* nil) |
---|
143 | (defparameter *nx-source-note-map* nil) |
---|
144 | |
---|
145 | (defun note-contained-in-p (note parent) |
---|
146 | (loop for n = note then (code-note-source n) while (code-note-p n) thereis (eq n parent))) |
---|
147 | |
---|
148 | (defun nx-find-code-note (form) |
---|
149 | ;; Try to find a source note for this form. The act of matching up a source note with |
---|
150 | ;; forms that might come from macroexpansion is heuristic at best. In general, err in |
---|
151 | ;; favor of not matching, because that leads to fewer false positives in code coverage |
---|
152 | ;; reporting. |
---|
153 | (when (or (consp form) (stringp form) (pathnamep form)) |
---|
154 | (let ((note (gethash form *nx-source-note-map*))) |
---|
155 | (unless (listp note) |
---|
156 | note)))) |
---|
157 | |
---|
158 | (defun nx-ensure-code-note (form original parent-note) |
---|
159 | ;; Try to find a source note for this form; if can't, just make a new record for it. |
---|
160 | (let* ((source-note (or (and original (nx-find-code-note original)) |
---|
161 | (nx-find-code-note form))) |
---|
162 | (note (if (and source-note |
---|
163 | ;; Look out for a case like a lambda macro that turns (lambda ...) |
---|
164 | ;; into (FUNCTION (lambda ...)) which then has (lambda ...) |
---|
165 | ;; as a child. Create a fresh note for the child, to avoid ambiguity. |
---|
166 | ;; Another case is forms wrapping THE around themselves. |
---|
167 | (neq source-note parent-note) |
---|
168 | ;; Don't use source notes from a different toplevel form, which could |
---|
169 | ;; happen due to inlining etc. The result then is that the source note |
---|
170 | ;; appears in multiple places, and shows partial coverage (from the |
---|
171 | ;; other reference) in code that's never executed. |
---|
172 | (loop for p = parent-note then (code-note-parent-note p) |
---|
173 | when (null p) return t |
---|
174 | when (source-note-p p) |
---|
175 | return (let ((n source-note)) |
---|
176 | (loop as s = (code-note-source p) |
---|
177 | while (source-note-p s) do (setq p s)) |
---|
178 | (loop as s = (code-note-source n) |
---|
179 | while (source-note-p s) do (setq n s)) |
---|
180 | (eq n p)))) |
---|
181 | source-note |
---|
182 | (make-code-note :form (or original form) :source parent-note)))) |
---|
183 | (register-code-note-parent note parent-note) |
---|
184 | note)) |
---|
185 | |
---|
186 | (eval-when (:compile-toplevel) |
---|
187 | (declaim (ftype (function (&rest ignore) t) ppc-compile))) |
---|
188 | |
---|
189 | (defparameter *nx-discard-xref-info-hook* nil) |
---|
190 | |
---|
191 | (defun compile-named-function (definition &key name env function-note keep-lambda keep-symbols policy load-time-eval-token target source-notes) |
---|
192 | (when (and name *nx-discard-xref-info-hook*) |
---|
193 | (funcall *nx-discard-xref-info-hook* name)) |
---|
194 | (setq |
---|
195 | definition |
---|
196 | (let* ((*load-time-eval-token* load-time-eval-token) |
---|
197 | (*nx-source-note-map* source-notes) |
---|
198 | (*nx1-source-note-map* (and *fasl-save-source-locations* *nx-source-note-map*)) |
---|
199 | (*nx-current-code-note* (and source-notes |
---|
200 | *compile-code-coverage* |
---|
201 | (nx-ensure-code-note definition nil function-note))) |
---|
202 | (*definition-source-note* (and *fasl-save-source-locations* |
---|
203 | (or function-note |
---|
204 | (and *form-source-note-map* (gethash definition *form-source-note-map*))))) |
---|
205 | (env (new-lexical-environment env))) |
---|
206 | (setf (lexenv.variables env) 'barrier) |
---|
207 | (let* ((*target-backend* (or (if target (find-backend target)) *host-backend*)) |
---|
208 | (afunc (nx1-compile-lambda |
---|
209 | name |
---|
210 | definition |
---|
211 | (make-afunc) |
---|
212 | nil |
---|
213 | env |
---|
214 | (or policy *default-compiler-policy*) |
---|
215 | *load-time-eval-token*))) |
---|
216 | (if (afunc-lfun afunc) |
---|
217 | afunc |
---|
218 | (funcall (backend-p2-compile *target-backend*) |
---|
219 | afunc |
---|
220 | ;; will also bind *nx-lexical-environment* |
---|
221 | (if keep-lambda (if (lambda-expression-p keep-lambda) keep-lambda definition)) |
---|
222 | keep-symbols))))) |
---|
223 | (values (afunc-lfun definition) (afunc-warnings definition))) |
---|
224 | |
---|
225 | (defun compile-user-function (def name &optional env) |
---|
226 | (multiple-value-bind (lfun warnings) |
---|
227 | (compile-named-function def |
---|
228 | :name name |
---|
229 | :env env |
---|
230 | :keep-lambda *save-definitions* |
---|
231 | :keep-symbols *save-local-symbols*) |
---|
232 | (signal-or-defer-warnings warnings env) |
---|
233 | lfun)) |
---|
234 | |
---|
235 | (defparameter *compiler-whining-conditions* |
---|
236 | '((:undefined-function . undefined-function-reference) |
---|
237 | (:global-mismatch . invalid-arguments-global) |
---|
238 | (:lexical-mismatch . invalid-arguments) |
---|
239 | (:environment-mismatch . invalid-arguments) |
---|
240 | (:ignore . style-warning) |
---|
241 | (:result-ignored . style-warning) |
---|
242 | (:unused . style-warning))) |
---|
243 | |
---|
244 | |
---|
245 | |
---|
246 | (defun compiler-bug (format &rest args) |
---|
247 | (error (make-condition 'compiler-bug |
---|
248 | :format-control format |
---|
249 | :format-arguments args))) |
---|
250 | |
---|
251 | |
---|
252 | (defparameter *nx-end* (cons nil nil)) |
---|
253 | (provide 'nx) |
---|
254 | |
---|
255 | (defun define-compile-time-macro (name lambda-expression env) |
---|
256 | (let ((definition-env (definition-environment env))) |
---|
257 | (when definition-env |
---|
258 | (push (list* name |
---|
259 | 'macro |
---|
260 | (compile-named-function lambda-expression :name name :env env)) |
---|
261 | (defenv.functions definition-env)) |
---|
262 | (record-function-info name (cons nil 'macro) env)) |
---|
263 | name)) |
---|