1;;; precompiler.lisp 2;;; 3;;; Copyright (C) 2003-2008 Peter Graves <peter@armedbear.org> 4;;; $Id$ 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") 1233