| 1 | ;;; precompiler.lisp |
|---|
| 2 | ;;; |
|---|
| 3 | ;;; Copyright (C) 2003-2008 Peter Graves <peter@armedbear.org> |
|---|
| 4 | ;;; $Id: precompiler.lisp 15386 2020-10-01 22:29:09Z mevenson $ |
|---|
| 5 | ;;; |
|---|
| 6 | ;;; This program is free software; you can redistribute it and/or |
|---|
| 7 | ;;; modify it under the terms of the GNU General Public License |
|---|
| 8 | ;;; as published by the Free Software Foundation; either version 2 |
|---|
| 9 | ;;; of the License, or (at your option) any later version. |
|---|
| 10 | ;;; |
|---|
| 11 | ;;; This program is distributed in the hope that it will be useful, |
|---|
| 12 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
|---|
| 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
|---|
| 14 | ;;; GNU General Public License for more details. |
|---|
| 15 | ;;; |
|---|
| 16 | ;;; You should have received a copy of the GNU General Public License |
|---|
| 17 | ;;; along with this program; if not, write to the Free Software |
|---|
| 18 | ;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. |
|---|
| 19 | ;;; |
|---|
| 20 | ;;; As a special exception, the copyright holders of this library give you |
|---|
| 21 | ;;; permission to link this library with independent modules to produce an |
|---|
| 22 | ;;; executable, regardless of the license terms of these independent |
|---|
| 23 | ;;; modules, and to copy and distribute the resulting executable under |
|---|
| 24 | ;;; terms of your choice, provided that you also meet, for each linked |
|---|
| 25 | ;;; independent module, the terms and conditions of the license of that |
|---|
| 26 | ;;; module. An independent module is a module which is not derived from |
|---|
| 27 | ;;; or based on this library. If you modify this library, you may extend |
|---|
| 28 | ;;; this exception to your version of the library, but you are not |
|---|
| 29 | ;;; obligated to do so. If you do not wish to do so, delete this |
|---|
| 30 | ;;; exception statement from your version. |
|---|
| 31 | |
|---|
| 32 | (in-package "SYSTEM") |
|---|
| 33 | |
|---|
| 34 | |
|---|
| 35 | (export '(process-optimization-declarations |
|---|
| 36 | inline-p notinline-p inline-expansion expand-inline |
|---|
| 37 | *defined-functions* *undefined-functions* note-name-defined)) |
|---|
| 38 | |
|---|
| 39 | (declaim (ftype (function (t) t) process-optimization-declarations)) |
|---|
| 40 | (defun process-optimization-declarations (forms) |
|---|
| 41 | (dolist (form forms) |
|---|
| 42 | (unless (and (consp form) (eq (%car form) 'DECLARE)) |
|---|
| 43 | (return)) |
|---|
| 44 | (dolist (decl (%cdr form)) |
|---|
| 45 | (case (car decl) |
|---|
| 46 | (OPTIMIZE |
|---|
| 47 | (dolist (spec (%cdr decl)) |
|---|
| 48 | (let ((val 3) |
|---|
| 49 | (quality spec)) |
|---|
| 50 | (when (consp spec) |
|---|
| 51 | (setf quality (%car spec) |
|---|
| 52 | val (cadr spec))) |
|---|
| 53 | (when (and (fixnump val) |
|---|
| 54 | (<= 0 val 3)) |
|---|
| 55 | (case quality |
|---|
| 56 | (speed |
|---|
| 57 | (setf *speed* val)) |
|---|
| 58 | (safety |
|---|
| 59 | (setf *safety* val)) |
|---|
| 60 | (debug |
|---|
| 61 | (setf *debug* val)) |
|---|
| 62 | (space |
|---|
| 63 | (setf *space* val)) |
|---|
| 64 | (compilation-speed) ;; Ignored. |
|---|
| 65 | (t |
|---|
| 66 | (compiler-warn "Ignoring unknown optimization quality ~S in ~S." quality decl))))))) |
|---|
| 67 | ((INLINE NOTINLINE) |
|---|
| 68 | (dolist (symbol (%cdr decl)) |
|---|
| 69 | (push (cons symbol (%car decl)) *inline-declarations*))) |
|---|
| 70 | (:explain |
|---|
| 71 | (dolist (spec (%cdr decl)) |
|---|
| 72 | (let ((val t) |
|---|
| 73 | (quality spec)) |
|---|
| 74 | (when (consp spec) |
|---|
| 75 | (setf quality (%car spec)) |
|---|
| 76 | (when (= (length spec) 2) |
|---|
| 77 | (setf val (%cadr spec)))) |
|---|
| 78 | (if val |
|---|
| 79 | (pushnew quality *explain*) |
|---|
| 80 | (setf *explain* (remove quality *explain*))))))))) |
|---|
| 81 | t) |
|---|
| 82 | |
|---|
| 83 | (declaim (ftype (function (t) t) inline-p)) |
|---|
| 84 | (defun inline-p (name) |
|---|
| 85 | (declare (optimize speed)) |
|---|
| 86 | (let ((entry (assoc name *inline-declarations* :test #'equal))) |
|---|
| 87 | (if entry |
|---|
| 88 | (eq (cdr entry) 'INLINE) |
|---|
| 89 | (and (symbolp name) (eq (get name '%inline) 'INLINE))))) |
|---|
| 90 | |
|---|
| 91 | (declaim (ftype (function (t) t) notinline-p)) |
|---|
| 92 | (defun notinline-p (name) |
|---|
| 93 | (declare (optimize speed)) |
|---|
| 94 | (let ((entry (assoc name *inline-declarations* :test #'equal))) |
|---|
| 95 | (if entry |
|---|
| 96 | (eq (cdr entry) 'NOTINLINE) |
|---|
| 97 | (and (symbolp name) (eq (get name '%inline) 'NOTINLINE))))) |
|---|
| 98 | |
|---|
| 99 | (defun expand-inline (form expansion) |
|---|
| 100 | ;; (format t "expand-inline form = ~S~%" form) |
|---|
| 101 | ;; (format t "expand-inline expansion = ~S~%" expansion) |
|---|
| 102 | (let* ((op (car form)) |
|---|
| 103 | (proclaimed-ftype (proclaimed-ftype op)) |
|---|
| 104 | (args (cdr form)) |
|---|
| 105 | (vars (cadr expansion)) |
|---|
| 106 | (varlist ()) |
|---|
| 107 | new-form) |
|---|
| 108 | ;; (format t "op = ~S proclaimed-ftype = ~S~%" op (proclaimed-ftype op)) |
|---|
| 109 | (do ((vars vars (cdr vars)) |
|---|
| 110 | (args args (cdr args))) |
|---|
| 111 | ((null vars)) |
|---|
| 112 | (push (list (car vars) (car args)) varlist)) |
|---|
| 113 | (setf new-form (list* 'LET (nreverse varlist) |
|---|
| 114 | (copy-tree (cddr expansion)))) |
|---|
| 115 | (when proclaimed-ftype |
|---|
| 116 | (let ((result-type (ftype-result-type proclaimed-ftype))) |
|---|
| 117 | (when (and result-type |
|---|
| 118 | (neq result-type t) |
|---|
| 119 | (neq result-type '*)) |
|---|
| 120 | (setf new-form (list 'TRULY-THE result-type new-form))))) |
|---|
| 121 | ;; (format t "expand-inline new form = ~S~%" new-form) |
|---|
| 122 | new-form)) |
|---|
| 123 | |
|---|
| 124 | (define-compiler-macro assoc (&whole form &rest args) |
|---|
| 125 | (cond ((and (= (length args) 4) |
|---|
| 126 | (eq (third args) :test) |
|---|
| 127 | (or (equal (fourth args) '(quote eq)) |
|---|
| 128 | (equal (fourth args) '(function eq)))) |
|---|
| 129 | `(assq ,(first args) ,(second args))) |
|---|
| 130 | ((= (length args) 2) |
|---|
| 131 | `(assql ,(first args) ,(second args))) |
|---|
| 132 | (t form))) |
|---|
| 133 | |
|---|
| 134 | (define-compiler-macro member (&whole form &rest args) |
|---|
| 135 | (let ((arg1 (first args)) |
|---|
| 136 | (arg2 (second args))) |
|---|
| 137 | (case (length args) |
|---|
| 138 | (2 |
|---|
| 139 | `(memql ,arg1 ,arg2)) |
|---|
| 140 | (4 |
|---|
| 141 | (let ((arg3 (third args)) |
|---|
| 142 | (arg4 (fourth args))) |
|---|
| 143 | (cond ((and (eq arg3 :test) |
|---|
| 144 | (or (equal arg4 '(quote eq)) |
|---|
| 145 | (equal arg4 '(function eq)))) |
|---|
| 146 | `(memq ,arg1 ,arg2)) |
|---|
| 147 | ((and (eq arg3 :test) |
|---|
| 148 | (or (equal arg4 '(quote eql)) |
|---|
| 149 | (equal arg4 '(function eql)) |
|---|
| 150 | (equal arg4 '(quote char=)) |
|---|
| 151 | (equal arg4 '(function char=)))) |
|---|
| 152 | `(memql ,arg1 ,arg2)) |
|---|
| 153 | (t |
|---|
| 154 | form)))) |
|---|
| 155 | (t |
|---|
| 156 | form)))) |
|---|
| 157 | |
|---|
| 158 | (define-compiler-macro search (&whole form &rest args) |
|---|
| 159 | (if (= (length args) 2) |
|---|
| 160 | `(simple-search ,@args) |
|---|
| 161 | form)) |
|---|
| 162 | |
|---|
| 163 | (define-compiler-macro identity (&whole form &rest args) |
|---|
| 164 | (if (= (length args) 1) |
|---|
| 165 | `(progn ,(car args)) |
|---|
| 166 | form)) |
|---|
| 167 | |
|---|
| 168 | (defun quoted-form-p (form) |
|---|
| 169 | (and (consp form) (eq (%car form) 'QUOTE) (= (length form) 2))) |
|---|
| 170 | |
|---|
| 171 | (define-compiler-macro eql (&whole form &rest args) |
|---|
| 172 | (let ((first (car args)) |
|---|
| 173 | (second (cadr args))) |
|---|
| 174 | (if (or (and (quoted-form-p first) (symbolp (cadr first))) |
|---|
| 175 | (and (quoted-form-p second) (symbolp (cadr second)))) |
|---|
| 176 | `(eq ,first ,second) |
|---|
| 177 | form))) |
|---|
| 178 | |
|---|
| 179 | (define-compiler-macro not (&whole form arg) |
|---|
| 180 | (if (atom arg) |
|---|
| 181 | form |
|---|
| 182 | (let ((op (case (car arg) |
|---|
| 183 | (>= '<) |
|---|
| 184 | (< '>=) |
|---|
| 185 | (<= '>) |
|---|
| 186 | (> '<=) |
|---|
| 187 | (t nil)))) |
|---|
| 188 | (if (and op (= (length arg) 3)) |
|---|
| 189 | (cons op (cdr arg)) |
|---|
| 190 | form)))) |
|---|
| 191 | |
|---|
| 192 | (defun predicate-for-type (type) |
|---|
| 193 | (cdr (assq type '((ARRAY . arrayp) |
|---|
| 194 | (ATOM . atom) |
|---|
| 195 | (BIT-VECTOR . bit-vector-p) |
|---|
| 196 | (CHARACTER . characterp) |
|---|
| 197 | (COMPLEX . complexp) |
|---|
| 198 | (CONS . consp) |
|---|
| 199 | (FIXNUM . fixnump) |
|---|
| 200 | (FLOAT . floatp) |
|---|
| 201 | (FUNCTION . functionp) |
|---|
| 202 | (HASH-TABLE . hash-table-p) |
|---|
| 203 | (INTEGER . integerp) |
|---|
| 204 | (LIST . listp) |
|---|
| 205 | (NULL . null) |
|---|
| 206 | (NUMBER . numberp) |
|---|
| 207 | (NUMBER . numberp) |
|---|
| 208 | (PACKAGE . packagep) |
|---|
| 209 | (RATIONAL . rationalp) |
|---|
| 210 | (REAL . realp) |
|---|
| 211 | (SIMPLE-BIT-VECTOR . simple-bit-vector-p) |
|---|
| 212 | (SIMPLE-STRING . simple-string-p) |
|---|
| 213 | (SIMPLE-VECTOR . simple-vector-p) |
|---|
| 214 | (STREAM . streamp) |
|---|
| 215 | (STRING . stringp) |
|---|
| 216 | (SYMBOL . symbolp))))) |
|---|
| 217 | |
|---|
| 218 | (define-compiler-macro typep (&whole form &rest args) |
|---|
| 219 | (if (= (length args) 2) ; no environment arg |
|---|
| 220 | (let* ((object (%car args)) |
|---|
| 221 | (type-specifier (%cadr args)) |
|---|
| 222 | (type (and (consp type-specifier) |
|---|
| 223 | (eq (%car type-specifier) 'QUOTE) |
|---|
| 224 | (%cadr type-specifier))) |
|---|
| 225 | (predicate (and type (predicate-for-type type)))) |
|---|
| 226 | (if predicate |
|---|
| 227 | `(,predicate ,object) |
|---|
| 228 | `(%typep ,@args))) |
|---|
| 229 | form)) |
|---|
| 230 | |
|---|
| 231 | (define-compiler-macro subtypep (&whole form &rest args) |
|---|
| 232 | (if (= (length args) 2) |
|---|
| 233 | `(%subtypep ,@args) |
|---|
| 234 | form)) |
|---|
| 235 | |
|---|
| 236 | (define-compiler-macro funcall (&whole form |
|---|
| 237 | &environment env &rest args) |
|---|
| 238 | (let ((callee (car args))) |
|---|
| 239 | (if (and (>= *speed* *debug*) |
|---|
| 240 | (consp callee) |
|---|
| 241 | (eq (%car callee) 'function) |
|---|
| 242 | (symbolp (cadr callee)) |
|---|
| 243 | (not (special-operator-p (cadr callee))) |
|---|
| 244 | (not (macro-function (cadr callee) env)) |
|---|
| 245 | (memq (symbol-package (cadr callee)) |
|---|
| 246 | (list (find-package "CL") (find-package "SYS")))) |
|---|
| 247 | `(,(cadr callee) ,@(cdr args)) |
|---|
| 248 | form))) |
|---|
| 249 | |
|---|
| 250 | (define-compiler-macro byte (size position) |
|---|
| 251 | `(cons ,size ,position)) |
|---|
| 252 | |
|---|
| 253 | (define-compiler-macro byte-size (bytespec) |
|---|
| 254 | `(car ,bytespec)) |
|---|
| 255 | |
|---|
| 256 | (define-compiler-macro byte-position (bytespec) |
|---|
| 257 | `(cdr ,bytespec)) |
|---|
| 258 | |
|---|
| 259 | (define-source-transform concatenate (&whole form result-type &rest sequences) |
|---|
| 260 | (if (equal result-type '(quote STRING)) |
|---|
| 261 | `(sys::concatenate-to-string (list ,@sequences)) |
|---|
| 262 | form)) |
|---|
| 263 | |
|---|
| 264 | (define-source-transform ldb (&whole form bytespec integer) |
|---|
| 265 | (if (and (consp bytespec) |
|---|
| 266 | (eq (%car bytespec) 'byte) |
|---|
| 267 | (= (length bytespec) 3)) |
|---|
| 268 | (let ((size (%cadr bytespec)) |
|---|
| 269 | (position (%caddr bytespec))) |
|---|
| 270 | `(%ldb ,size ,position ,integer)) |
|---|
| 271 | form)) |
|---|
| 272 | |
|---|
| 273 | (define-source-transform find (&whole form item sequence &key from-end test test-not start end key) |
|---|
| 274 | (cond ((and (>= (length form) 3) (null start) (null end)) |
|---|
| 275 | (cond ((and (stringp sequence) |
|---|
| 276 | (null from-end) |
|---|
| 277 | (member test '(#'eql #'char=) :test #'equal) |
|---|
| 278 | (null test-not) |
|---|
| 279 | (null key)) |
|---|
| 280 | `(string-find ,item ,sequence)) |
|---|
| 281 | (t |
|---|
| 282 | (let ((item-var (gensym)) |
|---|
| 283 | (seq-var (gensym))) |
|---|
| 284 | `(let ((,item-var ,item) |
|---|
| 285 | (,seq-var ,sequence)) |
|---|
| 286 | (if (listp ,seq-var) |
|---|
| 287 | (list-find* ,item-var ,seq-var ,from-end ,test ,test-not 0 (length ,seq-var) ,key) |
|---|
| 288 | (vector-find* ,item-var ,seq-var ,from-end ,test ,test-not 0 (length ,seq-var) ,key))))))) |
|---|
| 289 | (t |
|---|
| 290 | form))) |
|---|
| 291 | |
|---|
| 292 | (define-source-transform adjoin (&whole form &rest args) |
|---|
| 293 | (if (= (length args) 2) |
|---|
| 294 | `(adjoin-eql ,(first args) ,(second args)) |
|---|
| 295 | form)) |
|---|
| 296 | |
|---|
| 297 | (define-source-transform format (&whole form &rest args) |
|---|
| 298 | (if (stringp (second args)) |
|---|
| 299 | `(format ,(pop args) (formatter ,(pop args)) ,@args) |
|---|
| 300 | form)) |
|---|
| 301 | |
|---|
| 302 | (define-compiler-macro catch (&whole form tag &rest args) |
|---|
| 303 | (declare (ignore tag)) |
|---|
| 304 | (if (and (null (cdr args)) |
|---|
| 305 | (constantp (car args))) |
|---|
| 306 | (car args) |
|---|
| 307 | form)) |
|---|
| 308 | |
|---|
| 309 | (define-compiler-macro string= (&whole form &rest args) |
|---|
| 310 | (if (= (length args) 2) |
|---|
| 311 | `(sys::%%string= ,@args) |
|---|
| 312 | form)) |
|---|
| 313 | |
|---|
| 314 | (define-compiler-macro <= (&whole form &rest args) |
|---|
| 315 | (cond ((and (= (length args) 3) |
|---|
| 316 | (numberp (first args)) |
|---|
| 317 | (numberp (third args)) |
|---|
| 318 | (= (first args) (third args))) |
|---|
| 319 | `(= ,(second args) ,(first args))) |
|---|
| 320 | (t |
|---|
| 321 | form))) |
|---|
| 322 | |
|---|
| 323 | |
|---|
| 324 | (in-package "PRECOMPILER") |
|---|
| 325 | |
|---|
| 326 | |
|---|
| 327 | (export '(precompile-form precompile)) |
|---|
| 328 | |
|---|
| 329 | |
|---|
| 330 | ;; No source-transforms and inlining in precompile-function-call |
|---|
| 331 | ;; No macro expansion in precompile-dolist and precompile-dotimes |
|---|
| 332 | ;; No macro expansion in precompile-do/do* |
|---|
| 333 | ;; No macro expansion in precompile-defun |
|---|
| 334 | ;; Special precompilation in precompile-case and precompile-cond |
|---|
| 335 | ;; Special precompilation in precompile-when and precompile-unless |
|---|
| 336 | ;; No precompilation in precompile-nth-value |
|---|
| 337 | ;; Special precompilation in precompile-return |
|---|
| 338 | ;; |
|---|
| 339 | ;; if *in-jvm-compile* is false |
|---|
| 340 | |
|---|
| 341 | (defvar *in-jvm-compile* nil) |
|---|
| 342 | (defvar *precompile-env* nil) |
|---|
| 343 | |
|---|
| 344 | (declaim (inline expand-macro)) |
|---|
| 345 | (defun expand-macro (form) |
|---|
| 346 | (macroexpand-1 form *precompile-env*)) |
|---|
| 347 | |
|---|
| 348 | |
|---|
| 349 | (declaim (ftype (function (t) t) precompile1)) |
|---|
| 350 | (defun precompile1 (form) |
|---|
| 351 | (cond ((symbolp form) |
|---|
| 352 | (multiple-value-bind |
|---|
| 353 | (expansion expanded) |
|---|
| 354 | (expand-macro form) |
|---|
| 355 | (if expanded |
|---|
| 356 | (precompile1 expansion) |
|---|
| 357 | form))) |
|---|
| 358 | ((atom form) |
|---|
| 359 | form) |
|---|
| 360 | (t |
|---|
| 361 | (let ((op (%car form)) |
|---|
| 362 | handler) |
|---|
| 363 | (when (symbolp op) |
|---|
| 364 | (cond ((setf handler (get op 'precompile-handler)) |
|---|
| 365 | (return-from precompile1 (funcall handler form))) |
|---|
| 366 | ((macro-function op *precompile-env*) |
|---|
| 367 | (return-from precompile1 (precompile1 (expand-macro form)))) |
|---|
| 368 | ((special-operator-p op) |
|---|
| 369 | (error "PRECOMPILE1: unsupported special operator ~S." op)))) |
|---|
| 370 | (precompile-function-call form))))) |
|---|
| 371 | |
|---|
| 372 | (defun precompile-identity (form) |
|---|
| 373 | (declare (optimize speed)) |
|---|
| 374 | form) |
|---|
| 375 | |
|---|
| 376 | (declaim (ftype (function (t) cons) precompile-cons)) |
|---|
| 377 | (defun precompile-cons (form) |
|---|
| 378 | (cons (car form) (mapcar #'precompile1 (cdr form)))) |
|---|
| 379 | |
|---|
| 380 | (declaim (ftype (function (t t) t) precompile-function-call)) |
|---|
| 381 | (defun precompile-function-call (form) |
|---|
| 382 | (let ((op (car form))) |
|---|
| 383 | (when (and (consp op) (eq (%car op) 'LAMBDA)) |
|---|
| 384 | (return-from precompile-function-call |
|---|
| 385 | (or (precompile-function-position-lambda op (cdr form)) |
|---|
| 386 | (cons (precompile-lambda op) |
|---|
| 387 | (mapcar #'precompile1 (cdr form)))))) |
|---|
| 388 | (when (or (not *in-jvm-compile*) (notinline-p op)) |
|---|
| 389 | (return-from precompile-function-call (precompile-cons form))) |
|---|
| 390 | (when (source-transform op) |
|---|
| 391 | (let ((new-form (expand-source-transform form))) |
|---|
| 392 | (when (neq new-form form) |
|---|
| 393 | (return-from precompile-function-call (precompile1 new-form))))) |
|---|
| 394 | (when *enable-inline-expansion* |
|---|
| 395 | (let ((expansion (inline-expansion op))) |
|---|
| 396 | (when expansion |
|---|
| 397 | (let ((explain *explain*)) |
|---|
| 398 | (when (and explain (memq :calls explain)) |
|---|
| 399 | (format t "; inlining call to ~S~%" op))) |
|---|
| 400 | (return-from precompile-function-call (precompile1 (expand-inline form expansion)))))) |
|---|
| 401 | (cons op (mapcar #'precompile1 (cdr form))))) |
|---|
| 402 | |
|---|
| 403 | (defun precompile-function-position-lambda (lambda args) |
|---|
| 404 | (let* ((arglist (second lambda)) |
|---|
| 405 | (body (cddr lambda)) |
|---|
| 406 | (simple-arglist? (not (or (memq '&KEY arglist) (memq '&OPTIONAL arglist) (memq '&REST arglist))))) |
|---|
| 407 | (or |
|---|
| 408 | ;;give a chance for someone to transform single-form function bodies |
|---|
| 409 | (and (= (length body) 1) |
|---|
| 410 | (consp (car body)) |
|---|
| 411 | (symbolp (caar body)) |
|---|
| 412 | (get (caar body) 'sys::function-position-lambda-transform) |
|---|
| 413 | (funcall (get (caar body) 'sys::function-position-lambda-transform) |
|---|
| 414 | (caar body) (car body) (mapcar #'precompile1 args))) |
|---|
| 415 | (and simple-arglist? |
|---|
| 416 | (let ((arglist-length (if (memq '&aux arglist) (position '&aux arglist) (length arglist)))) |
|---|
| 417 | (if (= (length args) arglist-length) |
|---|
| 418 | ;; simplest case - we have a simple arglist with as many |
|---|
| 419 | ;; arguments as call args. Transform to let. |
|---|
| 420 | (return-from precompile-function-position-lambda |
|---|
| 421 | `(let* ,(append |
|---|
| 422 | (loop for arg-name in arglist |
|---|
| 423 | for arg in (mapcar #'precompile1 args) |
|---|
| 424 | until (eq arg-name '&aux) |
|---|
| 425 | collect (list arg-name arg)) |
|---|
| 426 | (subseq arglist (1+ arglist-length))) |
|---|
| 427 | ,@body)) |
|---|
| 428 | (error "Argument mismatch for lambda in function position: ~a applied to ~a" `(lambda ,arglist body) args))))))) |
|---|
| 429 | |
|---|
| 430 | (defmacro define-function-position-lambda-transform (body-function-name (arglist form args) &body body) |
|---|
| 431 | `(put ',body-function-name 'sys::function-position-lambda-transform |
|---|
| 432 | #'(lambda(,arglist ,form ,args) |
|---|
| 433 | ,@body))) |
|---|
| 434 | |
|---|
| 435 | (defun precompile-locally (form) |
|---|
| 436 | (let ((*inline-declarations* *inline-declarations*)) |
|---|
| 437 | (process-optimization-declarations (cdr form)) |
|---|
| 438 | (cons 'LOCALLY (mapcar #'precompile1 (cdr form))))) |
|---|
| 439 | |
|---|
| 440 | (defun precompile-block (form) |
|---|
| 441 | (let ((args (cdr form))) |
|---|
| 442 | (if (null (cdr args)) |
|---|
| 443 | nil |
|---|
| 444 | (list* 'BLOCK (car args) (mapcar #'precompile1 (cdr args)))))) |
|---|
| 445 | |
|---|
| 446 | (defun precompile-dolist (form) |
|---|
| 447 | (if *in-jvm-compile* |
|---|
| 448 | (precompile1 (macroexpand form *precompile-env*)) |
|---|
| 449 | (cons 'DOLIST (cons (mapcar #'precompile1 (cadr form)) |
|---|
| 450 | (mapcar #'precompile1 (cddr form)))))) |
|---|
| 451 | |
|---|
| 452 | (defun precompile-dotimes (form) |
|---|
| 453 | (if *in-jvm-compile* |
|---|
| 454 | (precompile1 (macroexpand form *precompile-env*)) |
|---|
| 455 | (cons 'DOTIMES (cons (mapcar #'precompile1 (cadr form)) |
|---|
| 456 | (mapcar #'precompile1 (cddr form)))))) |
|---|
| 457 | |
|---|
| 458 | (defun precompile-do/do*-vars (varlist) |
|---|
| 459 | (let ((result nil)) |
|---|
| 460 | (dolist (varspec varlist) |
|---|
| 461 | (if (atom varspec) |
|---|
| 462 | (push varspec result) |
|---|
| 463 | (case (length varspec) |
|---|
| 464 | (1 |
|---|
| 465 | (push (%car varspec) result)) |
|---|
| 466 | (2 |
|---|
| 467 | (let* ((var (%car varspec)) |
|---|
| 468 | (init-form (%cadr varspec))) |
|---|
| 469 | (unless (symbolp var) |
|---|
| 470 | (error 'type-error)) |
|---|
| 471 | (push (list var (precompile1 init-form)) |
|---|
| 472 | result))) |
|---|
| 473 | (3 |
|---|
| 474 | (let* ((var (%car varspec)) |
|---|
| 475 | (init-form (%cadr varspec)) |
|---|
| 476 | (step-form (%caddr varspec))) |
|---|
| 477 | (unless (symbolp var) |
|---|
| 478 | (error 'type-error)) |
|---|
| 479 | (push (list var (precompile1 init-form) (precompile1 step-form)) |
|---|
| 480 | result)))))) |
|---|
| 481 | (nreverse result))) |
|---|
| 482 | |
|---|
| 483 | (defun precompile-do/do*-end-form (end-form) |
|---|
| 484 | (let ((end-test-form (car end-form)) |
|---|
| 485 | (result-forms (cdr end-form))) |
|---|
| 486 | (list* (precompile1 end-test-form) (mapcar #'precompile1 result-forms)))) |
|---|
| 487 | |
|---|
| 488 | (defun precompile-do/do* (form) |
|---|
| 489 | (if *in-jvm-compile* |
|---|
| 490 | (precompile1 (macroexpand form *precompile-env*)) |
|---|
| 491 | (list* (car form) |
|---|
| 492 | (precompile-do/do*-vars (cadr form)) |
|---|
| 493 | (precompile-do/do*-end-form (caddr form)) |
|---|
| 494 | (mapcar #'precompile1 (cdddr form))))) |
|---|
| 495 | |
|---|
| 496 | (defun precompile-do-symbols (form) |
|---|
| 497 | (list* (car form) (cadr form) (mapcar #'precompile1 (cddr form)))) |
|---|
| 498 | |
|---|
| 499 | (defun precompile-load-time-value (form) |
|---|
| 500 | form) |
|---|
| 501 | |
|---|
| 502 | (defun precompile-progn (form) |
|---|
| 503 | (let ((body (cdr form))) |
|---|
| 504 | (if (eql (length body) 1) |
|---|
| 505 | (let ((res (precompile1 (%car body)))) |
|---|
| 506 | ;; If the result turns out to be a bare symbol, leave it wrapped |
|---|
| 507 | ;; with PROGN so it won't be mistaken for a tag in an enclosing |
|---|
| 508 | ;; TAGBODY. |
|---|
| 509 | (if (symbolp res) |
|---|
| 510 | (list 'progn res) |
|---|
| 511 | res)) |
|---|
| 512 | (cons 'PROGN (mapcar #'precompile1 body))))) |
|---|
| 513 | |
|---|
| 514 | (defun precompile-threads-synchronized-on (form) |
|---|
| 515 | (cons 'threads:synchronized-on (mapcar #'precompile1 (cdr form)))) |
|---|
| 516 | |
|---|
| 517 | (defun precompile-progv (form) |
|---|
| 518 | (if (< (length form) 3) |
|---|
| 519 | (error "Not enough arguments for ~S." 'progv) |
|---|
| 520 | (list* 'PROGV (mapcar #'precompile1 (%cdr form))))) |
|---|
| 521 | |
|---|
| 522 | (defun precompile-setf (form) |
|---|
| 523 | (let ((place (second form))) |
|---|
| 524 | (cond ((and (consp place) |
|---|
| 525 | (eq (%car place) 'VALUES)) |
|---|
| 526 | (setf form |
|---|
| 527 | (list* 'SETF |
|---|
| 528 | (list* 'VALUES |
|---|
| 529 | (mapcar #'precompile1 (%cdr place))) |
|---|
| 530 | (cddr form))) |
|---|
| 531 | (precompile1 (expand-macro form))) |
|---|
| 532 | ((symbolp place) |
|---|
| 533 | (multiple-value-bind |
|---|
| 534 | (expansion expanded) |
|---|
| 535 | ;; Expand once in case the form expands |
|---|
| 536 | ;; into something that needs special |
|---|
| 537 | ;; SETF treatment |
|---|
| 538 | (macroexpand-1 place *precompile-env*) |
|---|
| 539 | (if expanded |
|---|
| 540 | (precompile1 (list* 'SETF expansion |
|---|
| 541 | (cddr form))) |
|---|
| 542 | (precompile1 (expand-macro form))))) |
|---|
| 543 | (t |
|---|
| 544 | (precompile1 (expand-macro form)))))) |
|---|
| 545 | |
|---|
| 546 | (defun precompile-setq (form) |
|---|
| 547 | (let* ((args (cdr form)) |
|---|
| 548 | (len (length args))) |
|---|
| 549 | (when (oddp len) |
|---|
| 550 | (error 'simple-program-error |
|---|
| 551 | :format-control "Odd number of arguments to SETQ.")) |
|---|
| 552 | (if (= len 2) |
|---|
| 553 | (let* ((sym (%car args)) |
|---|
| 554 | (val (%cadr args))) |
|---|
| 555 | (multiple-value-bind |
|---|
| 556 | (expansion expanded) |
|---|
| 557 | ;; Expand once in case the form expands |
|---|
| 558 | ;; into something that needs special |
|---|
| 559 | ;; SETF treatment |
|---|
| 560 | (macroexpand-1 sym *precompile-env*) |
|---|
| 561 | (if expanded |
|---|
| 562 | (precompile1 (list 'SETF expansion val)) |
|---|
| 563 | (list 'SETQ sym (precompile1 val))))) |
|---|
| 564 | (let ((result ())) |
|---|
| 565 | (loop |
|---|
| 566 | (when (null args) |
|---|
| 567 | (return)) |
|---|
| 568 | (push (precompile-setq (list 'SETQ (car args) (cadr args))) result) |
|---|
| 569 | (setq args (cddr args))) |
|---|
| 570 | (setq result (nreverse result)) |
|---|
| 571 | (push 'PROGN result) |
|---|
| 572 | result)))) |
|---|
| 573 | |
|---|
| 574 | (defun precompile-psetf (form) |
|---|
| 575 | (setf form |
|---|
| 576 | (list* 'PSETF |
|---|
| 577 | (mapcar #'precompile1 (cdr form)))) |
|---|
| 578 | (precompile1 (expand-macro form))) |
|---|
| 579 | |
|---|
| 580 | (defun precompile-psetq (form) |
|---|
| 581 | ;; Make sure all the vars are symbols. |
|---|
| 582 | (do* ((rest (cdr form) (cddr rest)) |
|---|
| 583 | (var (car rest))) |
|---|
| 584 | ((null rest)) |
|---|
| 585 | (unless (symbolp var) |
|---|
| 586 | (error 'simple-error |
|---|
| 587 | :format-control "~S is not a symbol." |
|---|
| 588 | :format-arguments (list var)))) |
|---|
| 589 | ;; Delegate to PRECOMPILE-PSETF so symbol macros are handled correctly. |
|---|
| 590 | (precompile-psetf form)) |
|---|
| 591 | |
|---|
| 592 | |
|---|
| 593 | (defun precompile-lambda-list (form) |
|---|
| 594 | (let (new aux-tail) |
|---|
| 595 | (dolist (arg form (nreverse new)) |
|---|
| 596 | (if (or (atom arg) (> 2 (length arg))) |
|---|
| 597 | (progn |
|---|
| 598 | (when (eq arg '&aux) |
|---|
| 599 | (setf aux-tail t)) |
|---|
| 600 | (push arg new)) |
|---|
| 601 | ;; must be a cons of more than 1 cell |
|---|
| 602 | (let ((new-arg (copy-list arg))) |
|---|
| 603 | (unless (<= 1 (length arg) (if aux-tail 2 3)) |
|---|
| 604 | ;; the aux-vars have a maximum length of 2 conses |
|---|
| 605 | ;; optional and key vars may have 3 |
|---|
| 606 | (error 'program-error |
|---|
| 607 | :format-control |
|---|
| 608 | "The ~A binding specification ~S is invalid." |
|---|
| 609 | :format-arguments (list (if aux-tail "&AUX" |
|---|
| 610 | "&OPTIONAL/&KEY") arg))) |
|---|
| 611 | (setf (second new-arg) |
|---|
| 612 | (precompile1 (second arg))) |
|---|
| 613 | (push new-arg new)))))) |
|---|
| 614 | |
|---|
| 615 | (defun extract-lambda-vars (lambda-list) |
|---|
| 616 | (let ((state :required) |
|---|
| 617 | vars) |
|---|
| 618 | (dolist (var/key lambda-list vars) |
|---|
| 619 | (cond |
|---|
| 620 | ((eq '&aux var/key) (setf state :aux)) |
|---|
| 621 | ((eq '&key var/key) (setf state :key)) |
|---|
| 622 | ((eq '&optional var/key) (setf state :optional)) |
|---|
| 623 | ((eq '&rest var/key) (setf state :rest)) |
|---|
| 624 | ((symbolp var/key) (unless (eq var/key '&allow-other-keys) |
|---|
| 625 | (push var/key vars))) |
|---|
| 626 | ((and (consp var/key) |
|---|
| 627 | (member state '(:optional :key))) |
|---|
| 628 | (setf var/key (car var/key)) |
|---|
| 629 | (when (and (consp var/key) (eq state :key)) |
|---|
| 630 | (setf var/key (second var/key))) |
|---|
| 631 | (if (symbolp var/key) |
|---|
| 632 | (push var/key vars) |
|---|
| 633 | (error 'program-error |
|---|
| 634 | :format-control |
|---|
| 635 | "Unexpected ~A variable specifier ~A." |
|---|
| 636 | :format-arguments (list state var/key)))) |
|---|
| 637 | ((and (consp var/key) (eq state :aux)) |
|---|
| 638 | (if (symbolp (car var/key)) |
|---|
| 639 | (push (car var/key) vars) |
|---|
| 640 | (error 'program-error |
|---|
| 641 | :format-control "Unexpected &AUX format for ~A." |
|---|
| 642 | :format-arguments (list var/key)))) |
|---|
| 643 | (t |
|---|
| 644 | (error 'program-error |
|---|
| 645 | :format-control "Unexpected lambda-list format: ~A." |
|---|
| 646 | :format-arguments (list lambda-list))))))) |
|---|
| 647 | |
|---|
| 648 | (defun precompile-lambda (form) |
|---|
| 649 | (let ((body (cddr form)) |
|---|
| 650 | (precompiled-lambda-list |
|---|
| 651 | (precompile-lambda-list (cadr form))) |
|---|
| 652 | (*inline-declarations* *inline-declarations*) |
|---|
| 653 | (*precompile-env* (make-environment *precompile-env*))) |
|---|
| 654 | (process-optimization-declarations body) |
|---|
| 655 | (dolist (var (extract-lambda-vars precompiled-lambda-list)) |
|---|
| 656 | (environment-add-symbol-binding *precompile-env* var nil)) |
|---|
| 657 | (list* 'LAMBDA precompiled-lambda-list |
|---|
| 658 | (mapcar #'precompile1 body)))) |
|---|
| 659 | |
|---|
| 660 | (defun precompile-named-lambda (form) |
|---|
| 661 | (let ((lambda-form (list* 'LAMBDA (caddr form) (cdddr form)))) |
|---|
| 662 | (let ((body (cddr lambda-form)) |
|---|
| 663 | (precompiled-lambda-list |
|---|
| 664 | (precompile-lambda-list (cadr lambda-form))) |
|---|
| 665 | (*inline-declarations* *inline-declarations*) |
|---|
| 666 | (*precompile-env* (make-environment *precompile-env*))) |
|---|
| 667 | (process-optimization-declarations body) |
|---|
| 668 | (dolist (var (extract-lambda-vars precompiled-lambda-list)) |
|---|
| 669 | (environment-add-symbol-binding *precompile-env* var nil)) |
|---|
| 670 | (list* 'NAMED-LAMBDA (cadr form) precompiled-lambda-list |
|---|
| 671 | (mapcar #'precompile1 body))))) |
|---|
| 672 | |
|---|
| 673 | (defun precompile-defun (form) |
|---|
| 674 | (if *in-jvm-compile* |
|---|
| 675 | (precompile1 (expand-macro form)) |
|---|
| 676 | form)) |
|---|
| 677 | |
|---|
| 678 | (defun precompile-macrolet (form) |
|---|
| 679 | (let ((*precompile-env* (make-environment *precompile-env*))) |
|---|
| 680 | (dolist (definition (cadr form)) |
|---|
| 681 | (environment-add-macro-definition |
|---|
| 682 | *precompile-env* |
|---|
| 683 | (car definition) |
|---|
| 684 | (make-macro (car definition) |
|---|
| 685 | (make-closure |
|---|
| 686 | (make-macro-expander definition) |
|---|
| 687 | NIL)))) |
|---|
| 688 | (multiple-value-bind (body decls) |
|---|
| 689 | (parse-body (cddr form) nil) |
|---|
| 690 | `(locally ,@decls ,@(mapcar #'precompile1 body))))) |
|---|
| 691 | |
|---|
| 692 | (defun precompile-symbol-macrolet (form) |
|---|
| 693 | (let ((*precompile-env* (make-environment *precompile-env*)) |
|---|
| 694 | (defs (cadr form))) |
|---|
| 695 | (dolist (def defs) |
|---|
| 696 | (let ((sym (car def)) |
|---|
| 697 | (expansion (cadr def))) |
|---|
| 698 | (when (special-variable-p sym) |
|---|
| 699 | (error 'program-error |
|---|
| 700 | :format-control |
|---|
| 701 | "Attempt to bind the special variable ~S with SYMBOL-MACROLET." |
|---|
| 702 | :format-arguments (list sym))) |
|---|
| 703 | (environment-add-symbol-binding *precompile-env* |
|---|
| 704 | sym |
|---|
| 705 | (sys::make-symbol-macro expansion)))) |
|---|
| 706 | (multiple-value-bind (body decls) |
|---|
| 707 | (parse-body (cddr form) nil) |
|---|
| 708 | (when decls |
|---|
| 709 | (let ((specials ())) |
|---|
| 710 | (dolist (decl decls) |
|---|
| 711 | (when (eq (car decl) 'DECLARE) |
|---|
| 712 | (dolist (declspec (cdr decl)) |
|---|
| 713 | (when (eq (car declspec) 'SPECIAL) |
|---|
| 714 | (setf specials (append specials (cdr declspec))))))) |
|---|
| 715 | (when specials |
|---|
| 716 | (let ((syms (mapcar #'car (cadr form)))) |
|---|
| 717 | (dolist (special specials) |
|---|
| 718 | (when (memq special syms) |
|---|
| 719 | (error 'program-error |
|---|
| 720 | :format-control |
|---|
| 721 | "~S is a symbol-macro and may not be declared special." |
|---|
| 722 | :format-arguments (list special)))))))) |
|---|
| 723 | `(locally ,@decls ,@(mapcar #'precompile1 body))))) |
|---|
| 724 | |
|---|
| 725 | (defun precompile-the (form) |
|---|
| 726 | (list 'THE |
|---|
| 727 | (second form) |
|---|
| 728 | (precompile1 (third form)))) |
|---|
| 729 | |
|---|
| 730 | (defun precompile-truly-the (form) |
|---|
| 731 | (list 'TRULY-THE |
|---|
| 732 | (second form) |
|---|
| 733 | (precompile1 (third form)))) |
|---|
| 734 | |
|---|
| 735 | (defun precompile-let/let*-vars (vars) |
|---|
| 736 | (let ((result nil)) |
|---|
| 737 | (dolist (var vars) |
|---|
| 738 | (cond ((consp var) |
|---|
| 739 | (unless (<= 1 (length var) 2) |
|---|
| 740 | (error 'program-error |
|---|
| 741 | :format-control |
|---|
| 742 | "The LET/LET* binding specification ~S is invalid." |
|---|
| 743 | :format-arguments (list var))) |
|---|
| 744 | (let ((v (%car var)) |
|---|
| 745 | (expr (cadr var))) |
|---|
| 746 | (unless (symbolp v) |
|---|
| 747 | (error 'simple-type-error |
|---|
| 748 | :format-control "The variable ~S is not a symbol." |
|---|
| 749 | :format-arguments (list v))) |
|---|
| 750 | (push (list v (precompile1 expr)) result) |
|---|
| 751 | (environment-add-symbol-binding *precompile-env* v nil))) |
|---|
| 752 | ;; any value will do: we just need to shadow any symbol macros |
|---|
| 753 | (t |
|---|
| 754 | (push var result) |
|---|
| 755 | (environment-add-symbol-binding *precompile-env* var nil)))) |
|---|
| 756 | (nreverse result))) |
|---|
| 757 | |
|---|
| 758 | (defun precompile-let (form) |
|---|
| 759 | (let ((*precompile-env* (make-environment *precompile-env*))) |
|---|
| 760 | (list* 'LET |
|---|
| 761 | (precompile-let/let*-vars (cadr form)) |
|---|
| 762 | (mapcar #'precompile1 (cddr form))))) |
|---|
| 763 | |
|---|
| 764 | ;; (LET* ((X 1)) (LET* ((Y 2)) (LET* ((Z 3)) (+ X Y Z)))) => |
|---|
| 765 | ;; (LET* ((X 1) (Y 2) (Z 3)) (+ X Y Z)) |
|---|
| 766 | (defun maybe-fold-let* (form) |
|---|
| 767 | (if (and (= (length form) 3) |
|---|
| 768 | (consp (%caddr form)) |
|---|
| 769 | (eq (%car (%caddr form)) 'LET*)) |
|---|
| 770 | (let ((third (maybe-fold-let* (%caddr form)))) |
|---|
| 771 | (list* 'LET* (append (%cadr form) (cadr third)) (cddr third))) |
|---|
| 772 | form)) |
|---|
| 773 | |
|---|
| 774 | (defun precompile-let* (form) |
|---|
| 775 | (setf form (maybe-fold-let* form)) |
|---|
| 776 | (let ((*precompile-env* (make-environment *precompile-env*))) |
|---|
| 777 | (list* 'LET* |
|---|
| 778 | (precompile-let/let*-vars (cadr form)) |
|---|
| 779 | (mapcar #'precompile1 (cddr form))))) |
|---|
| 780 | |
|---|
| 781 | (defun precompile-case (form) |
|---|
| 782 | (if *in-jvm-compile* |
|---|
| 783 | (precompile1 (macroexpand form *precompile-env*)) |
|---|
| 784 | (let* ((keyform (cadr form)) |
|---|
| 785 | (clauses (cddr form)) |
|---|
| 786 | (result (list (precompile1 keyform)))) |
|---|
| 787 | (dolist (clause clauses) |
|---|
| 788 | (push (precompile-case-clause clause) result)) |
|---|
| 789 | (cons (car form) (nreverse result))))) |
|---|
| 790 | |
|---|
| 791 | (defun precompile-case-clause (clause) |
|---|
| 792 | (let ((keys (car clause)) |
|---|
| 793 | (forms (cdr clause))) |
|---|
| 794 | (cons keys (mapcar #'precompile1 forms)))) |
|---|
| 795 | |
|---|
| 796 | (defun precompile-cond (form) |
|---|
| 797 | (if *in-jvm-compile* |
|---|
| 798 | (precompile1 (macroexpand form *precompile-env*)) |
|---|
| 799 | (let ((clauses (cdr form)) |
|---|
| 800 | (result nil)) |
|---|
| 801 | (dolist (clause clauses) |
|---|
| 802 | (push (precompile-cond-clause clause) result)) |
|---|
| 803 | (cons 'COND (nreverse result))))) |
|---|
| 804 | |
|---|
| 805 | (defun precompile-cond-clause (clause) |
|---|
| 806 | (let ((test (car clause)) |
|---|
| 807 | (forms (cdr clause))) |
|---|
| 808 | (cons (precompile1 test) (mapcar #'precompile1 forms)))) |
|---|
| 809 | |
|---|
| 810 | (defun precompile-local-function-def (def) |
|---|
| 811 | (let ((name (car def)) |
|---|
| 812 | (body (cddr def))) |
|---|
| 813 | ;; Macro names are shadowed by local functions. |
|---|
| 814 | (environment-add-function-definition *precompile-env* name body) |
|---|
| 815 | (cdr (precompile-named-lambda (list* 'NAMED-LAMBDA def))))) |
|---|
| 816 | |
|---|
| 817 | (defun precompile-local-functions (defs) |
|---|
| 818 | (let ((result nil)) |
|---|
| 819 | (dolist (def defs (nreverse result)) |
|---|
| 820 | (push (precompile-local-function-def def) result)))) |
|---|
| 821 | |
|---|
| 822 | (defun find-use (name expression) |
|---|
| 823 | (cond ((atom expression) |
|---|
| 824 | nil) |
|---|
| 825 | ((eq (%car expression) name) |
|---|
| 826 | t) |
|---|
| 827 | ((consp name) |
|---|
| 828 | t) ;; FIXME Recognize use of SETF functions! |
|---|
| 829 | (t |
|---|
| 830 | (or (find-use name (%car expression)) |
|---|
| 831 | (find-use name (%cdr expression)))))) |
|---|
| 832 | |
|---|
| 833 | (defun precompile-flet/labels (form) |
|---|
| 834 | (let* ((*precompile-env* (make-environment *precompile-env*)) |
|---|
| 835 | (operator (car form)) |
|---|
| 836 | (locals (cadr form)) |
|---|
| 837 | precompiled-locals |
|---|
| 838 | applicable-locals |
|---|
| 839 | body) |
|---|
| 840 | (when (eq operator 'FLET) |
|---|
| 841 | ;; FLET functions *don't* shadow within their own FLET form |
|---|
| 842 | (setf precompiled-locals |
|---|
| 843 | (precompile-local-functions locals)) |
|---|
| 844 | (setf applicable-locals precompiled-locals)) |
|---|
| 845 | ;; augment the environment with the newly-defined local functions |
|---|
| 846 | ;; to shadow preexisting macro definitions with the same names |
|---|
| 847 | (dolist (local locals) |
|---|
| 848 | ;; we can use the non-precompiled locals, because the function body isn't used |
|---|
| 849 | (environment-add-function-definition *precompile-env* |
|---|
| 850 | (car local) (cddr local))) |
|---|
| 851 | (when (eq operator 'LABELS) |
|---|
| 852 | ;; LABELS functions *do* shadow within their own LABELS form |
|---|
| 853 | (setf precompiled-locals |
|---|
| 854 | (precompile-local-functions locals)) |
|---|
| 855 | (setf applicable-locals precompiled-locals)) |
|---|
| 856 | ;; then precompile (thus macro-expand) the body before inspecting it |
|---|
| 857 | ;; for the use of our locals and eliminating dead code |
|---|
| 858 | (setq body (mapcar #'precompile1 (cddr form))) |
|---|
| 859 | (dolist (local precompiled-locals) |
|---|
| 860 | (let* ((name (car local)) |
|---|
| 861 | (used-p (find-use name body))) |
|---|
| 862 | (unless used-p |
|---|
| 863 | (when (eq operator 'LABELS) |
|---|
| 864 | (dolist (local precompiled-locals) |
|---|
| 865 | (when (neq name (car local)) |
|---|
| 866 | (when (find-use name (cddr local)) |
|---|
| 867 | (setf used-p t) |
|---|
| 868 | (return)) |
|---|
| 869 | ;; Scope of defined function names includes |
|---|
| 870 | ;; &OPTIONAL, &KEY and &AUX parameters |
|---|
| 871 | ;; (LABELS.7B, LABELS.7C and LABELS.7D). |
|---|
| 872 | (let ((vars (or |
|---|
| 873 | (cdr (memq '&optional (cadr local))) |
|---|
| 874 | (cdr (memq '&key (cadr local))) |
|---|
| 875 | (cdr (memq '&aux (cadr local)))))) |
|---|
| 876 | (when (and vars (find-use name vars)) |
|---|
| 877 | (setf used-p t) |
|---|
| 878 | (return))) |
|---|
| 879 | )))) |
|---|
| 880 | (unless used-p |
|---|
| 881 | (compiler-style-warn "; Note: deleting unused local function ~A ~S~%" |
|---|
| 882 | operator name) |
|---|
| 883 | (setf applicable-locals (remove local applicable-locals))))) |
|---|
| 884 | (if applicable-locals |
|---|
| 885 | (list* operator applicable-locals body) |
|---|
| 886 | (list* 'LOCALLY body)))) |
|---|
| 887 | |
|---|
| 888 | (defun precompile-function (form) |
|---|
| 889 | (if (and (consp (cadr form)) (eq (caadr form) 'LAMBDA)) |
|---|
| 890 | (list 'FUNCTION (precompile-lambda (%cadr form))) |
|---|
| 891 | form)) |
|---|
| 892 | |
|---|
| 893 | (defun precompile-if (form) |
|---|
| 894 | (let ((args (cdr form))) |
|---|
| 895 | (case (length args) |
|---|
| 896 | (2 |
|---|
| 897 | (let ((test (precompile1 (%car args)))) |
|---|
| 898 | (cond ((null test) |
|---|
| 899 | nil) |
|---|
| 900 | (;;(constantp test) |
|---|
| 901 | (eq test t) |
|---|
| 902 | (precompile1 (%cadr args))) |
|---|
| 903 | (t |
|---|
| 904 | (list 'IF |
|---|
| 905 | test |
|---|
| 906 | (precompile1 (%cadr args))))))) |
|---|
| 907 | (3 |
|---|
| 908 | (let ((test (precompile1 (%car args)))) |
|---|
| 909 | (cond ((null test) |
|---|
| 910 | (precompile1 (%caddr args))) |
|---|
| 911 | (;;(constantp test) |
|---|
| 912 | (eq test t) |
|---|
| 913 | (precompile1 (%cadr args))) |
|---|
| 914 | (t |
|---|
| 915 | (list 'IF |
|---|
| 916 | test |
|---|
| 917 | (precompile1 (%cadr args)) |
|---|
| 918 | (precompile1 (%caddr args))))))) |
|---|
| 919 | (t |
|---|
| 920 | (error "wrong number of arguments for IF"))))) |
|---|
| 921 | |
|---|
| 922 | (defun precompile-when (form) |
|---|
| 923 | (if *in-jvm-compile* |
|---|
| 924 | (precompile1 (macroexpand form *precompile-env*)) |
|---|
| 925 | (precompile-cons form))) |
|---|
| 926 | |
|---|
| 927 | (defun precompile-unless (form) |
|---|
| 928 | (if *in-jvm-compile* |
|---|
| 929 | (precompile1 (macroexpand form *precompile-env*)) |
|---|
| 930 | (precompile-cons form))) |
|---|
| 931 | |
|---|
| 932 | ;; MULTIPLE-VALUE-BIND is handled explicitly by the JVM compiler. |
|---|
| 933 | (defun precompile-multiple-value-bind (form) |
|---|
| 934 | (let ((vars (cadr form)) |
|---|
| 935 | (values-form (caddr form)) |
|---|
| 936 | (body (cdddr form)) |
|---|
| 937 | (*precompile-env* (make-environment *precompile-env*))) |
|---|
| 938 | (dolist (var vars) |
|---|
| 939 | (environment-add-symbol-binding *precompile-env* var nil)) |
|---|
| 940 | (list* 'MULTIPLE-VALUE-BIND |
|---|
| 941 | vars |
|---|
| 942 | (precompile1 values-form) |
|---|
| 943 | (mapcar #'precompile1 body)))) |
|---|
| 944 | |
|---|
| 945 | ;; MULTIPLE-VALUE-LIST is handled explicitly by the JVM compiler. |
|---|
| 946 | (defun precompile-multiple-value-list (form) |
|---|
| 947 | (list 'MULTIPLE-VALUE-LIST (precompile1 (cadr form)))) |
|---|
| 948 | |
|---|
| 949 | (defun precompile-nth-value (form) |
|---|
| 950 | (if *in-jvm-compile* |
|---|
| 951 | (precompile1 (macroexpand form *precompile-env*)) |
|---|
| 952 | form)) |
|---|
| 953 | |
|---|
| 954 | (defun precompile-return (form) |
|---|
| 955 | (if *in-jvm-compile* |
|---|
| 956 | (precompile1 (macroexpand form *precompile-env*)) |
|---|
| 957 | (list 'RETURN (precompile1 (cadr form))))) |
|---|
| 958 | |
|---|
| 959 | (defun precompile-return-from (form) |
|---|
| 960 | (list 'RETURN-FROM (cadr form) (precompile1 (caddr form)))) |
|---|
| 961 | |
|---|
| 962 | (defun precompile-tagbody (form) |
|---|
| 963 | (do ((body (cdr form) (cdr body)) |
|---|
| 964 | (result ())) |
|---|
| 965 | ((null body) (cons 'TAGBODY (nreverse result))) |
|---|
| 966 | (if (atom (car body)) |
|---|
| 967 | (push (car body) result) |
|---|
| 968 | (push (let* ((first-form (car body)) |
|---|
| 969 | (expanded (precompile1 first-form))) |
|---|
| 970 | (if (and (symbolp expanded) |
|---|
| 971 | (neq expanded first-form)) |
|---|
| 972 | ;; Workaround: |
|---|
| 973 | ;; Since our expansion/compilation order |
|---|
| 974 | ;; is out of sync with the definition of |
|---|
| 975 | ;; TAGBODY (which requires the compiler |
|---|
| 976 | ;; to look for tags before expanding), |
|---|
| 977 | ;; we need to disguise anything which might |
|---|
| 978 | ;; look like a tag. We do this by wrapping |
|---|
| 979 | ;; it in a PROGN form. |
|---|
| 980 | (list 'PROGN expanded) |
|---|
| 981 | expanded)) result)))) |
|---|
| 982 | |
|---|
| 983 | (defun precompile-eval-when (form) |
|---|
| 984 | (list* 'EVAL-WHEN (cadr form) (mapcar #'precompile1 (cddr form)))) |
|---|
| 985 | |
|---|
| 986 | (defun precompile-unwind-protect (form) |
|---|
| 987 | (list* 'UNWIND-PROTECT |
|---|
| 988 | (precompile1 (cadr form)) |
|---|
| 989 | (mapcar #'precompile1 (cddr form)))) |
|---|
| 990 | |
|---|
| 991 | (declaim (ftype (function (t t) t) precompile-form)) |
|---|
| 992 | (defun precompile-form (form in-jvm-compile |
|---|
| 993 | &optional precompile-env) |
|---|
| 994 | (let ((*in-jvm-compile* in-jvm-compile) |
|---|
| 995 | (*inline-declarations* *inline-declarations*) |
|---|
| 996 | (pre::*precompile-env* precompile-env)) |
|---|
| 997 | (precompile1 form))) |
|---|
| 998 | |
|---|
| 999 | (defun install-handler (symbol &optional handler) |
|---|
| 1000 | (declare (type symbol symbol)) |
|---|
| 1001 | (let ((handler (or handler |
|---|
| 1002 | (find-symbol (sys::%format nil "PRECOMPILE-~A" |
|---|
| 1003 | (symbol-name symbol)) |
|---|
| 1004 | 'precompiler)))) |
|---|
| 1005 | (unless (and handler (fboundp handler)) |
|---|
| 1006 | (error "No handler for ~S." (let ((*package* (find-package :keyword))) |
|---|
| 1007 | (format nil "~S" symbol)))) |
|---|
| 1008 | (setf (get symbol 'precompile-handler) handler))) |
|---|
| 1009 | |
|---|
| 1010 | (defun install-handlers () |
|---|
| 1011 | (mapcar #'install-handler '(BLOCK |
|---|
| 1012 | CASE |
|---|
| 1013 | COND |
|---|
| 1014 | DOLIST |
|---|
| 1015 | DOTIMES |
|---|
| 1016 | EVAL-WHEN |
|---|
| 1017 | FUNCTION |
|---|
| 1018 | IF |
|---|
| 1019 | LAMBDA |
|---|
| 1020 | MACROLET |
|---|
| 1021 | MULTIPLE-VALUE-BIND |
|---|
| 1022 | MULTIPLE-VALUE-LIST |
|---|
| 1023 | NAMED-LAMBDA |
|---|
| 1024 | NTH-VALUE |
|---|
| 1025 | PROGN |
|---|
| 1026 | PROGV |
|---|
| 1027 | PSETF |
|---|
| 1028 | PSETQ |
|---|
| 1029 | RETURN |
|---|
| 1030 | RETURN-FROM |
|---|
| 1031 | SETF |
|---|
| 1032 | SETQ |
|---|
| 1033 | SYMBOL-MACROLET |
|---|
| 1034 | TAGBODY |
|---|
| 1035 | UNWIND-PROTECT |
|---|
| 1036 | UNLESS |
|---|
| 1037 | WHEN)) |
|---|
| 1038 | |
|---|
| 1039 | (dolist (pair '((ECASE precompile-case) |
|---|
| 1040 | |
|---|
| 1041 | (AND precompile-cons) |
|---|
| 1042 | (OR precompile-cons) |
|---|
| 1043 | |
|---|
| 1044 | (CATCH precompile-cons) |
|---|
| 1045 | (MULTIPLE-VALUE-CALL precompile-cons) |
|---|
| 1046 | (MULTIPLE-VALUE-PROG1 precompile-cons) |
|---|
| 1047 | |
|---|
| 1048 | (DO precompile-do/do*) |
|---|
| 1049 | (DO* precompile-do/do*) |
|---|
| 1050 | |
|---|
| 1051 | (LET precompile-let) |
|---|
| 1052 | (LET* precompile-let*) |
|---|
| 1053 | |
|---|
| 1054 | (LOCALLY precompile-locally) |
|---|
| 1055 | |
|---|
| 1056 | (FLET precompile-flet/labels) |
|---|
| 1057 | (LABELS precompile-flet/labels) |
|---|
| 1058 | |
|---|
| 1059 | (LOAD-TIME-VALUE precompile-load-time-value) |
|---|
| 1060 | |
|---|
| 1061 | (DECLARE precompile-identity) |
|---|
| 1062 | (DEFUN precompile-defun) |
|---|
| 1063 | (GO precompile-identity) |
|---|
| 1064 | (QUOTE precompile-identity) |
|---|
| 1065 | (THE precompile-the) |
|---|
| 1066 | (THROW precompile-cons) |
|---|
| 1067 | (TRULY-THE precompile-truly-the) |
|---|
| 1068 | |
|---|
| 1069 | (THREADS:SYNCHRONIZED-ON |
|---|
| 1070 | precompile-threads-synchronized-on) |
|---|
| 1071 | |
|---|
| 1072 | (JVM::WITH-INLINE-CODE precompile-identity))) |
|---|
| 1073 | (install-handler (first pair) (second pair)))) |
|---|
| 1074 | |
|---|
| 1075 | (install-handlers) |
|---|
| 1076 | |
|---|
| 1077 | (export '(precompile-form)) |
|---|
| 1078 | |
|---|
| 1079 | (in-package #:ext) |
|---|
| 1080 | |
|---|
| 1081 | (export 'macroexpand-all) |
|---|
| 1082 | |
|---|
| 1083 | (defun macroexpand-all (form &optional env) |
|---|
| 1084 | (precompiler:precompile-form form t env)) |
|---|
| 1085 | |
|---|
| 1086 | (in-package #:lisp) |
|---|
| 1087 | |
|---|
| 1088 | (export '(compiler-let)) |
|---|
| 1089 | |
|---|
| 1090 | (defmacro compiler-let (bindings &body forms &environment env) |
|---|
| 1091 | (let ((bindings (mapcar #'(lambda (binding) |
|---|
| 1092 | (if (atom binding) (list binding) binding)) |
|---|
| 1093 | bindings))) |
|---|
| 1094 | (progv (mapcar #'car bindings) |
|---|
| 1095 | (mapcar #'(lambda (binding) |
|---|
| 1096 | (eval (cadr binding))) bindings) |
|---|
| 1097 | (macroexpand-all `(progn ,@forms) env)))) |
|---|
| 1098 | |
|---|
| 1099 | (in-package #:system) |
|---|
| 1100 | |
|---|
| 1101 | (defun set-function-definition (name new old) |
|---|
| 1102 | (let ((*warn-on-redefinition* nil)) |
|---|
| 1103 | (sys::%set-lambda-name new name) |
|---|
| 1104 | (sys:set-call-count new (sys:call-count old)) |
|---|
| 1105 | (sys::%set-arglist new (sys::arglist old)) |
|---|
| 1106 | (when (macro-function name) |
|---|
| 1107 | (setf new (make-macro name new))) |
|---|
| 1108 | (if (typep old 'mop:funcallable-standard-object) |
|---|
| 1109 | (mop:set-funcallable-instance-function old new) |
|---|
| 1110 | (setf (fdefinition name) new)))) |
|---|
| 1111 | |
|---|
| 1112 | (defun precompile (name &optional definition) |
|---|
| 1113 | (unless definition |
|---|
| 1114 | (setq definition (or (and (symbolp name) (macro-function name)) |
|---|
| 1115 | (fdefinition name)))) |
|---|
| 1116 | (let ((expr definition) |
|---|
| 1117 | env result |
|---|
| 1118 | (pre::*precompile-env* nil)) |
|---|
| 1119 | (when (functionp definition) |
|---|
| 1120 | (multiple-value-bind (form closure-p) |
|---|
| 1121 | (function-lambda-expression definition) |
|---|
| 1122 | (unless form |
|---|
| 1123 | (return-from precompile (values nil t t))) |
|---|
| 1124 | (setq env closure-p) |
|---|
| 1125 | (setq expr form))) |
|---|
| 1126 | (unless (and (consp expr) (eq (car expr) 'lambda)) |
|---|
| 1127 | (format t "Unable to precompile ~S.~%" name) |
|---|
| 1128 | (return-from precompile (values nil t t))) |
|---|
| 1129 | (setf result |
|---|
| 1130 | (sys:make-closure (precompiler:precompile-form expr nil env) env)) |
|---|
| 1131 | (when (and name (functionp result)) |
|---|
| 1132 | (sys::set-function-definition name result definition)) |
|---|
| 1133 | (values (or name result) nil nil))) |
|---|
| 1134 | |
|---|
| 1135 | (defun precompile-package (pkg &key (verbose cl:*compile-verbose*)) |
|---|
| 1136 | (dolist (sym (package-symbols pkg)) |
|---|
| 1137 | (when (fboundp sym) |
|---|
| 1138 | (unless (special-operator-p sym) |
|---|
| 1139 | (let ((f (fdefinition sym))) |
|---|
| 1140 | (unless (compiled-function-p f) |
|---|
| 1141 | (when verbose |
|---|
| 1142 | (format t "~&; precompiler; Precompiling ~S~%" sym) |
|---|
| 1143 | (finish-output)) |
|---|
| 1144 | (precompile sym)))))) |
|---|
| 1145 | t) |
|---|
| 1146 | |
|---|
| 1147 | (defun %compile (name definition) |
|---|
| 1148 | (if (and name (fboundp name) (%typep (symbol-function name) 'generic-function)) |
|---|
| 1149 | (values name nil nil) |
|---|
| 1150 | (precompile name definition))) |
|---|
| 1151 | |
|---|
| 1152 | ;; ;; Redefine EVAL to precompile its argument. |
|---|
| 1153 | ;; (defun eval (form) |
|---|
| 1154 | ;; (%eval (precompile-form form nil))) |
|---|
| 1155 | |
|---|
| 1156 | ;; ;; Redefine DEFMACRO to precompile the expansion function on the fly. |
|---|
| 1157 | ;; (defmacro defmacro (name lambda-list &rest body) |
|---|
| 1158 | ;; (let* ((form (gensym "WHOLE-")) |
|---|
| 1159 | ;; (env (gensym "ENVIRONMENT-"))) |
|---|
| 1160 | ;; (multiple-value-bind (body decls) |
|---|
| 1161 | ;; (parse-defmacro lambda-list form body name 'defmacro :environment env) |
|---|
| 1162 | ;; (let ((expander `(lambda (,form ,env) ,@decls (block ,name ,body)))) |
|---|
| 1163 | ;; `(progn |
|---|
| 1164 | ;; (let ((macro (make-macro ',name |
|---|
| 1165 | ;; (or (precompile nil ,expander) ,expander)))) |
|---|
| 1166 | ;; ,@(if (special-operator-p name) |
|---|
| 1167 | ;; `((put ',name 'macroexpand-macro macro)) |
|---|
| 1168 | ;; `((fset ',name macro))) |
|---|
| 1169 | ;; (%set-arglist macro ',lambda-list) |
|---|
| 1170 | ;; ',name)))))) |
|---|
| 1171 | |
|---|
| 1172 | ;; Make an exception just this one time... |
|---|
| 1173 | (when (get 'defmacro 'macroexpand-macro) |
|---|
| 1174 | (fset 'defmacro (get 'defmacro 'macroexpand-macro)) |
|---|
| 1175 | (remprop 'defmacro 'macroexpand-macro)) |
|---|
| 1176 | |
|---|
| 1177 | (defvar *defined-functions*) |
|---|
| 1178 | |
|---|
| 1179 | (defvar *undefined-functions*) |
|---|
| 1180 | |
|---|
| 1181 | (defun note-name-defined (name) |
|---|
| 1182 | (when (boundp '*defined-functions*) |
|---|
| 1183 | (push name *defined-functions*)) |
|---|
| 1184 | (when (and (boundp '*undefined-functions*) (not (null *undefined-functions*))) |
|---|
| 1185 | (setf *undefined-functions* (remove name *undefined-functions*)))) |
|---|
| 1186 | |
|---|
| 1187 | ;; Redefine DEFUN to precompile the definition on the fly. |
|---|
| 1188 | (defmacro defun (name lambda-list &body body &environment env) |
|---|
| 1189 | (note-name-defined name) |
|---|
| 1190 | (multiple-value-bind (body decls doc) |
|---|
| 1191 | (parse-body body) |
|---|
| 1192 | (let* ((block-name (fdefinition-block-name name)) |
|---|
| 1193 | (lambda-expression |
|---|
| 1194 | `(named-lambda ,name ,lambda-list |
|---|
| 1195 | ,@decls |
|---|
| 1196 | ,@(when doc `(,doc)) |
|---|
| 1197 | (block ,block-name ,@body)))) |
|---|
| 1198 | (cond ((and (boundp 'jvm::*file-compilation*) |
|---|
| 1199 | ;; when JVM.lisp isn't loaded yet, this variable isn't bound |
|---|
| 1200 | ;; meaning that we're not trying to compile to a file: |
|---|
| 1201 | ;; Both COMPILE and COMPILE-FILE bind this variable. |
|---|
| 1202 | ;; This function is also triggered by MACROEXPAND, though. |
|---|
| 1203 | jvm::*file-compilation*) |
|---|
| 1204 | `(progn |
|---|
| 1205 | (fset ',name ,lambda-expression) |
|---|
| 1206 | ;; the below matter, for example when loading a |
|---|
| 1207 | ;; compiled defun that is inside some other form |
|---|
| 1208 | ;; (e.g. flet) |
|---|
| 1209 | (record-source-information-for-type ',(if (consp name) (second name) name) '(:function ,name)) |
|---|
| 1210 | (%set-arglist (fdefinition ',name) ',(third lambda-expression)) |
|---|
| 1211 | ,@(when doc |
|---|
| 1212 | `((%set-documentation ',name 'function ,doc))) |
|---|
| 1213 | ',name)) |
|---|
| 1214 | (t |
|---|
| 1215 | (when (and env (empty-environment-p env)) |
|---|
| 1216 | (setf env nil)) |
|---|
| 1217 | (when (null env) |
|---|
| 1218 | (setf lambda-expression (precompiler:precompile-form lambda-expression nil))) |
|---|
| 1219 | (let ((sym (if (consp name) (second name) name))) |
|---|
| 1220 | `(prog1 |
|---|
| 1221 | (%defun ',name ,lambda-expression) |
|---|
| 1222 | (record-source-information-for-type ',sym '(:function ,name)) |
|---|
| 1223 | (%set-arglist (fdefinition ',name) ',(third lambda-expression)) |
|---|
| 1224 | ;; don't do this. building abcl fails autoloading |
|---|
| 1225 | ;; stuff it shouldn't yet |
|---|
| 1226 | ;;(%set-arglist (symbol-function ',name) ,(format nil "~{~s~^ ;; ~}" (third lambda-expression))) |
|---|
| 1227 | ,@(when doc |
|---|
| 1228 | `((%set-documentation ',name 'function ,doc))) |
|---|
| 1229 | ))))))) |
|---|
| 1230 | (export '(precompile)) |
|---|
| 1231 | |
|---|
| 1232 | ;;(provide "PRECOMPILER") |
|---|
