Mercurial > hg > xemacs-beta

comparison lisp/bytecomp.el @ 5574:d4f334808463

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Support inlining labels, bytecomp.el. lisp/ChangeLog addition: 2011-10-02 Aidan Kehoe <kehoea@parhasard.net> * bytecomp.el (byte-compile-initial-macro-environment): Add #'declare to this, so it doesn't need to rely on #'cl-compiling file to determine when we're byte-compiling. Update #'labels to support declaring labels inline, as Common Lisp requires. * bytecomp.el (byte-compile-function-form): Don't error if FUNCTION is quoting a non-lambda, non-symbol, just return it. * cl-extra.el (cl-macroexpand-all): If a label name has been quoted, expand to the label placeholder quoted with 'function. This allows the byte compiler to distinguish between uses of the placeholder as data and uses in contexts where it should be inlined. * cl-macs.el: * cl-macs.el (cl-do-proclaim): When proclaming something as inline, if it is bound as a label, don't modify the symbol's plist; instead, treat the first element of its placeholder constant vector as a place to store compile information. * cl-macs.el (declare): Leave processing declarations while compiling to the implementation of #'declare in byte-compile-initial-macro-environment. tests/ChangeLog addition: 2011-10-02 Aidan Kehoe <kehoea@parhasard.net> * automated/lisp-tests.el: * automated/lisp-tests.el (+): Test #'labels and inlining.
author Aidan Kehoe <kehoea@parhasard.net>
date Sun, 02 Oct 2011 15:32:16 +0100
parents f0f1fd0d8486
children 89cb6a66a61f
comparison
equal deleted inserted replaced
5573:f0f1fd0d8486 5574:d4f334808463
492 (byte-compile-warn 492 (byte-compile-warn
493 "%s is not of type %s" form type))) 493 "%s is not of type %s" form type)))
494 (if byte-compile-delete-errors 494 (if byte-compile-delete-errors
495 form 495 form
496 (funcall (cdr (symbol-function 'the)) type form)))) 496 (funcall (cdr (symbol-function 'the)) type form))))
497 (declare
498 . ,#'(lambda (&rest specs)
499 (while specs
500 (if (listp cl-declare-stack) (push (car specs) cl-declare-stack))
501 (cl-do-proclaim (pop specs) nil))))
497 (load-time-value 502 (load-time-value
498 . ,#'(lambda (form &optional read-only) 503 . ,#'(lambda (form &optional read-only)
499 (let* ((gensym (gensym)) 504 (let* ((gensym (gensym))
500 (byte-compile-bound-variables 505 (byte-compile-bound-variables
501 (acons gensym byte-compile-global-bit 506 (acons gensym byte-compile-global-bit
515 definition name))))) 520 definition name)))))
516 bindings)) 521 bindings))
517 (placeholders 522 (placeholders
518 (mapcar #'(lambda (lambda) 523 (mapcar #'(lambda (lambda)
519 (make-byte-code (second lambda) "\xc0\x87" 524 (make-byte-code (second lambda) "\xc0\x87"
520 [42] 1)) 525 ;; This list is used for
526 ;; the byte-optimize
527 ;; property, if the
528 ;; function is to be
529 ;; inlined. See
530 ;; cl-do-proclaim.
531 (vector nil) 1))
521 lambdas)) 532 lambdas))
522 (byte-compile-macro-environment 533 (byte-compile-macro-environment
523 (pairlis names (mapcar 534 (pairlis names (mapcar
524 #'(lambda (placeholder) 535 #'(lambda (placeholder)
525 `(lambda (&rest cl-labels-args) 536 `(lambda (&rest cl-labels-args)
537 ;; Be careful not to quote
538 ;; PLACEHOLDER, otherwise
539 ;; byte-optimize-funcall inlines
540 ;; it.
526 (list* 'funcall ,placeholder 541 (list* 'funcall ,placeholder
527 cl-labels-args))) 542 cl-labels-args)))
528 placeholders) 543 placeholders)
529 byte-compile-macro-environment)) 544 byte-compile-macro-environment))
530 (gensym (gensym))) 545 (gensym (gensym)))
531 (put gensym 'byte-compile-label-alist 546 (labels
532 (pairlis placeholders 547 ((byte-compile-transform-labels (form names lambdas
533 (mapcar 'second (mapcar 'cl-macroexpand-all 548 placeholders)
534 lambdas)))) 549 (let* ((inline
535 (put gensym 'byte-compile 550 (mapcan
536 #'(lambda (form) 551 #'(lambda (name placeholder lambda)
537 (let* ((byte-compile-label-alist 552 (and
538 (get (car form) 'byte-compile-label-alist))) 553 (eq
539 (dolist (acons byte-compile-label-alist) 554 (getf (aref
540 (setf (cdr acons) 555 (compiled-function-constants
541 (byte-compile-lambda (cdr acons)))) 556 placeholder) 0)
542 (byte-compile-body-do-effect 557 'byte-optimizer)
543 (sublis byte-compile-label-alist (cdr form) 558 'byte-compile-inline-expand)
544 :test #'eq)) 559 `(((function ,placeholder)
545 (dolist (acons byte-compile-label-alist) 560 ,(byte-compile-lambda lambda)
546 (nsubst (cdr acons) (car acons) 561 (function ,lambda)))))
547 byte-compile-label-alist :test #'eq 562 names placeholders lambdas))
548 :descend-structures t))))) 563 (compiled
549 (cl-macroexpand-all (cons gensym body) 564 (mapcar #'byte-compile-lambda
550 byte-compile-macro-environment)))) 565 (if (not inline)
566 lambdas
567 ;; See further down for the
568 ;; rationale of the sublis calls.
569 (sublis (pairlis
570 (mapcar #'cadar inline)
571 (mapcar #'third inline))
572 (sublis
573 (pairlis
574 (mapcar #'car inline)
575 (mapcar #'second inline))
576 lambdas :test #'equal)
577 :test #'eq))))
578 elt)
579 (mapc #'(lambda (placeholder function)
580 (nsubst function placeholder compiled
581 :test #'eq
582 :descend-structures t))
583 placeholders compiled)
584 (when inline
585 (dolist (triad inline)
586 (nsubst (setq elt (elt compiled
587 (position (cadar triad)
588 placeholders)))
589 (second triad) compiled :test #'eq
590 :descend-structures t)
591 (setf (second triad) elt))
592 ;; For inlined labels: first, replace uses of
593 ;; the placeholder in places where it's not an
594 ;; evident, explicit funcall (that is, where
595 ;; it is not to be inlined) with the compiled
596 ;; function:
597 (setq form (sublis
598 (pairlis (mapcar #'car inline)
599 (mapcar #'second inline))
600 form :test #'equal)
601 ;; Now replace uses of the placeholder
602 ;; where it is an evident funcall with the
603 ;; lambda, quoted as a function, to allow
604 ;; byte-optimize-funcall to do its
605 ;; thing. Note that the lambdas still have
606 ;; the placeholders, so there's no risk
607 ;; of recursive inlining.
608 form (sublis (pairlis
609 (mapcar #'cadar inline)
610 (mapcar #'third inline))
611 form :test #'eq)))
612 (sublis (pairlis placeholders compiled) form
613 :test #'eq))))
614 (put gensym 'byte-compile
615 #'(lambda (form)
616 (let* ((names (cadr (cl-pop2 form)))
617 (lambdas (mapcar #'cadr (cdr (pop form))))
618 (placeholders (cadr (pop form))))
619 (byte-compile-body-do-effect
620 (byte-compile-transform-labels form names
621 lambdas
622 placeholders)))))
623 (put gensym 'byte-hunk-handler
624 #'(lambda (form)
625 (let* ((names (cadr (cl-pop2 form)))
626 (lambdas (mapcar #'cadr (cdr (pop form))))
627 (placeholders (cadr (pop form))))
628 (byte-compile-file-form
629 (cons 'progn
630 (byte-compile-transform-labels
631 form names lambdas placeholders))))))
632 (cl-macroexpand-all `(,gensym ',names (list ,@lambdas)
633 ',placeholders ,@body)
634 byte-compile-macro-environment)))))
551 (flet . 635 (flet .
552 ,#'(lambda (bindings &rest body) 636 ,#'(lambda (bindings &rest body)
553 (let* ((names (mapcar 'car bindings)) 637 (let* ((names (mapcar 'car bindings))
554 (lambdas (mapcar 638 (lambdas (mapcar
555 (function* 639 (function*
3697 3781
3698 (defun byte-compile-function-form (form) 3782 (defun byte-compile-function-form (form)
3699 (if (cddr form) 3783 (if (cddr form)
3700 (byte-compile-normal-call 3784 (byte-compile-normal-call
3701 `(signal 'wrong-number-of-arguments '(function ,(length (cdr form))))) 3785 `(signal 'wrong-number-of-arguments '(function ,(length (cdr form)))))
3702 (byte-compile-constant 3786 (byte-compile-constant (if (eq 'lambda (car-safe (nth 1 form)))
3703 (cond ((symbolp (nth 1 form)) 3787 (byte-compile-lambda (nth 1 form))
3704 (nth 1 form)) 3788 (nth 1 form)))))
3705 ((byte-compile-lambda (nth 1 form)))))))
3706 3789
3707 (defun byte-compile-insert (form) 3790 (defun byte-compile-insert (form)
3708 (cond ((null (cdr form)) 3791 (cond ((null (cdr form))
3709 (byte-compile-constant nil)) 3792 (byte-compile-constant nil))
3710 ((<= (length form) 256) 3793 ((<= (length form) 256)