162 |
;; This really ought to be loaded already! |
;; This really ought to be loaded already! |
163 |
(load-library "byte-run")) |
(load-library "byte-run")) |
164 |
|
|
165 |
|
;; We want to do (require 'byte-lexbind) when compiling, to avoid compilation |
166 |
|
;; errors; however that file also wants to do (require 'bytecomp) for the |
167 |
|
;; same reason. Since we know it's OK to load byte-lexbind.el second, we |
168 |
|
;; have that file require a feature that's provided before at the beginning |
169 |
|
;; of this file, to avoid an infinite require loop. |
170 |
|
;; `eval-when-compile' is defined in byte-run.el, so it must come after the |
171 |
|
;; preceding load expression. |
172 |
|
(provide 'bytecomp-preload) |
173 |
|
(eval-when-compile (require 'byte-lexbind)) |
174 |
|
|
175 |
;; The feature of compiling in a specific target Emacs version |
;; The feature of compiling in a specific target Emacs version |
176 |
;; has been turned off because compile time options are a bad idea. |
;; has been turned off because compile time options are a bad idea. |
177 |
(defmacro byte-compile-single-version () nil) |
(defmacro byte-compile-single-version () nil) |
391 |
:type '(choice (const name) (const callers) (const calls) |
:type '(choice (const name) (const callers) (const calls) |
392 |
(const calls+callers) (const nil))) |
(const calls+callers) (const nil))) |
393 |
|
|
394 |
(defvar byte-compile-debug nil) |
;(defvar byte-compile-debug nil) |
395 |
|
(defvar byte-compile-debug t) |
396 |
|
|
397 |
;; (defvar byte-compile-overwrite-file t |
;; (defvar byte-compile-overwrite-file t |
398 |
;; "If nil, old .elc files are deleted before the new is saved, and .elc |
;; "If nil, old .elc files are deleted before the new is saved, and .elc |
419 |
;; (byte-compiler-options . (lambda (&rest forms) |
;; (byte-compiler-options . (lambda (&rest forms) |
420 |
;; (apply 'byte-compiler-options-handler forms))) |
;; (apply 'byte-compiler-options-handler forms))) |
421 |
(eval-when-compile . (lambda (&rest body) |
(eval-when-compile . (lambda (&rest body) |
422 |
(list 'quote |
(list |
423 |
(byte-compile-eval (byte-compile-top-level |
'quote |
424 |
(cons 'progn body)))))) |
(byte-compile-eval |
425 |
|
(byte-compile-top-level |
426 |
|
(macroexpand-all |
427 |
|
(cons 'progn body) |
428 |
|
byte-compile-initial-macro-environment)))))) |
429 |
(eval-and-compile . (lambda (&rest body) |
(eval-and-compile . (lambda (&rest body) |
430 |
(eval (cons 'progn body)) |
(eval (cons 'progn body)) |
431 |
(cons 'progn body)))) |
(cons 'progn body)))) |
724 |
;; front of the constants-vector than the constant-referencing instructions. |
;; front of the constants-vector than the constant-referencing instructions. |
725 |
;; Also, this lets us notice references to free variables. |
;; Also, this lets us notice references to free variables. |
726 |
|
|
727 |
|
(defmacro byte-compile-push-bytecodes (&rest args) |
728 |
|
"Push BYTE... onto BYTES, and increment PC by the number of bytes pushed. |
729 |
|
ARGS is of the form (BYTE... BYTES PC), where BYTES and PC are variable names. |
730 |
|
BYTES and PC are updated after evaluating all the arguments." |
731 |
|
(let ((byte-exprs (butlast args 2)) |
732 |
|
(bytes-var (car (last args 2))) |
733 |
|
(pc-var (car (last args)))) |
734 |
|
`(setq ,bytes-var ,(if (null (cdr byte-exprs)) |
735 |
|
`(cons ,@byte-exprs ,bytes-var) |
736 |
|
`(nconc (list ,@(reverse byte-exprs)) ,bytes-var)) |
737 |
|
,pc-var (+ ,(length byte-exprs) ,pc-var)))) |
738 |
|
|
739 |
|
(defmacro byte-compile-push-bytecode-const2 (opcode const2 bytes pc) |
740 |
|
"Push OPCODE and the two-byte constant CONST2 onto BYTES, and add 3 to PC. |
741 |
|
CONST2 may be evaulated multiple times." |
742 |
|
`(byte-compile-push-bytecodes ,opcode (logand ,const2 255) (lsh ,const2 -8) |
743 |
|
,bytes ,pc)) |
744 |
|
|
745 |
(defun byte-compile-lapcode (lap) |
(defun byte-compile-lapcode (lap) |
746 |
"Turns lapcode into bytecode. The lapcode is destroyed." |
"Turns lapcode into bytecode. The lapcode is destroyed." |
747 |
;; Lapcode modifications: changes the ID of a tag to be the tag's PC. |
;; Lapcode modifications: changes the ID of a tag to be the tag's PC. |
749 |
op off ; Operation & offset |
op off ; Operation & offset |
750 |
opcode ; numeric value of OP |
opcode ; numeric value of OP |
751 |
(bytes '()) ; Put the output bytes here |
(bytes '()) ; Put the output bytes here |
752 |
(patchlist nil) ; List of tags and goto's to patch |
(patchlist nil)) ; List of gotos to patch |
753 |
rest rel tmp) |
(dolist (lap-entry lap) |
754 |
(while lap |
(setq op (car lap-entry) |
755 |
(setq op (car (car lap)) |
off (cdr lap-entry)) |
|
off (cdr (car lap))) |
|
756 |
(cond ((not (symbolp op)) |
(cond ((not (symbolp op)) |
757 |
(error "Non-symbolic opcode `%s'" op)) |
(error "Non-symbolic opcode `%s'" op)) |
758 |
((eq op 'TAG) |
((eq op 'TAG) |
759 |
(setcar off pc) |
(setcar off pc)) |
|
(setq patchlist (cons off patchlist))) |
|
760 |
((null op) |
((null op) |
761 |
;; a no-op added by `byte-compile-delay-out' |
;; a no-op added by `byte-compile-delay-out' |
762 |
(unless (zerop off) |
(unless (zerop off) |
763 |
(error |
(error |
764 |
"Placeholder added by `byte-compile-delay-out' not filled in.") |
"Placeholder added by `byte-compile-delay-out' not filled in.") |
765 |
)) |
)) |
|
((memq op byte-goto-ops) |
|
|
(setq pc (+ pc 3)) |
|
|
(setq bytes (cons (cons pc (cdr off)) |
|
|
(cons nil |
|
|
(cons (symbol-value op) bytes)))) |
|
|
(setq patchlist (cons bytes patchlist))) |
|
766 |
(t |
(t |
767 |
(setq opcode (symbol-value op)) |
(setq opcode (symbol-value op)) |
768 |
(setq bytes |
(cond ((memq op byte-goto-ops) |
769 |
(cond ((cond ((consp off) |
;; goto |
770 |
;; Variable or constant reference |
(byte-compile-push-bytecodes opcode nil (cdr off) bytes pc) |
771 |
(setq off (cdr off)) |
(push bytes patchlist)) |
772 |
(eq op 'byte-constant))) |
((and (consp off) |
773 |
(cond ((< off byte-constant-limit) |
;; Variable or constant reference |
774 |
(setq pc (1+ pc)) |
(progn (setq off (cdr off)) |
775 |
(cons (+ byte-constant off) bytes)) |
(eq op 'byte-constant))) |
776 |
(t |
;; constant ref |
777 |
(setq pc (+ 3 pc)) |
(if (< off byte-constant-limit) |
778 |
(cons (lsh off -8) |
(byte-compile-push-bytecodes (+ byte-constant off) |
779 |
(cons (logand off 255) |
bytes pc) |
780 |
(cons byte-constant2 bytes)))))) |
(byte-compile-push-bytecode-const2 byte-constant2 off |
781 |
((and (= opcode byte-stack-set) |
bytes pc))) |
782 |
(> off 255)) |
((and (= opcode byte-stack-set) |
783 |
;; Use the two-byte version of byte-stack-set if the |
(> off 255)) |
784 |
;; offset is too large for the normal version. |
;; Use the two-byte version of byte-stack-set if the |
785 |
(setq pc (+ 3 pc)) |
;; offset is too large for the normal version. |
786 |
(cons (lsh off -8) |
(byte-compile-push-bytecode-const2 byte-stack-set2 off |
787 |
(cons (logand off 255) |
bytes pc)) |
788 |
(cons byte-stack-set2 bytes)))) |
((and (>= opcode byte-listN) |
789 |
((and (>= opcode byte-listN) |
(<= opcode byte-vec-set)) |
790 |
(<= opcode byte-vec-set)) |
;; These insns all put their operand into one extra byte. |
791 |
;; These insns all put their operand into one extra |
(byte-compile-push-bytecodes opcode off bytes pc)) |
792 |
;; byte. |
((null off) |
793 |
(setq pc (+ 2 pc)) |
;; opcode that doesn't use OFF |
794 |
(cons off (cons opcode bytes))) |
(byte-compile-push-bytecodes opcode bytes pc)) |
795 |
((null off) |
;; The following three cases are for the special |
796 |
;; opcode that doesn't use OFF |
;; insns that encode their operand into 0, 1, or 2 |
797 |
(setq pc (1+ pc)) |
;; extra bytes depending on its magnitude. |
798 |
(cons opcode bytes)) |
((< off 6) |
799 |
;; The following three cases are for the special |
(byte-compile-push-bytecodes (+ opcode off) bytes pc)) |
800 |
;; insns that encode their operand into 0, 1, or 2 |
((< off 256) |
801 |
;; extra bytes depending on its magnitude. |
(byte-compile-push-bytecodes (+ opcode 6) off bytes pc)) |
802 |
((< off 6) |
(t |
803 |
(setq pc (1+ pc)) |
(byte-compile-push-bytecode-const2 (+ opcode 7) off |
804 |
(cons (+ opcode off) bytes)) |
bytes pc)))))) |
|
((< off 256) |
|
|
(setq pc (+ 2 pc)) |
|
|
(cons off (cons (+ opcode 6) bytes))) |
|
|
(t |
|
|
(setq pc (+ 3 pc)) |
|
|
(cons (lsh off -8) |
|
|
(cons (logand off 255) |
|
|
(cons (+ opcode 7) bytes)))))))) |
|
|
(setq lap (cdr lap))) |
|
805 |
;;(if (not (= pc (length bytes))) |
;;(if (not (= pc (length bytes))) |
806 |
;; (error "Compiler error: pc mismatch - %s %s" pc (length bytes))) |
;; (error "Compiler error: pc mismatch - %s %s" pc (length bytes))) |
807 |
;; Patch PC into jumps |
|
808 |
(let (bytes) |
;; Patch tag PCs into absolute jumps |
809 |
(while patchlist |
(dolist (bytes-tail patchlist) |
810 |
(setq bytes (car patchlist)) |
(setq pc (caar bytes-tail)) ; Pick PC from goto's tag |
811 |
(cond ((atom (car bytes))) ; Tag |
(setcar (cdr bytes-tail) (logand pc 255)) |
812 |
(t ; Absolute jump |
(setcar bytes-tail (lsh pc -8))) |
813 |
(setq pc (car (cdr (car bytes)))) ; Pick PC from tag |
|
|
(setcar (cdr bytes) (logand pc 255)) |
|
|
(setcar bytes (lsh pc -8)))) |
|
|
(setq patchlist (cdr patchlist)))) |
|
814 |
(concat (nreverse bytes)))) |
(concat (nreverse bytes)))) |
815 |
|
|
816 |
|
|
2224 |
(setq fun (cdr fun))) |
(setq fun (cdr fun))) |
2225 |
(cond ((eq (car-safe fun) 'lambda) |
(cond ((eq (car-safe fun) 'lambda) |
2226 |
;; expand macros |
;; expand macros |
2227 |
(setq fun (macroexpand-all fun byte-compile-macro-environment)) |
(setq fun |
2228 |
|
(macroexpand-all fun |
2229 |
|
byte-compile-initial-macro-environment)) |
2230 |
;; get rid of the `function' quote added by the `lambda' macro |
;; get rid of the `function' quote added by the `lambda' macro |
2231 |
(setq fun (cadr fun)) |
(setq fun (cadr fun)) |
2232 |
(setq fun (if macro |
(setq fun (if macro |
2638 |
(byte-compile-out 'byte-call (length (cdr form)))) |
(byte-compile-out 'byte-call (length (cdr form)))) |
2639 |
|
|
2640 |
(defun byte-compile-check-variable (var &optional binding) |
(defun byte-compile-check-variable (var &optional binding) |
2641 |
|
"Do various error checks before a use of the variable VAR. |
2642 |
|
If BINDING is non-nil, VAR is being bound." |
2643 |
(when (symbolp var) |
(when (symbolp var) |
2644 |
(byte-compile-set-symbol-position var)) |
(byte-compile-set-symbol-position var)) |
2645 |
(cond ((or (not (symbolp var)) (byte-compile-const-symbol-p var)) |
(cond ((or (not (symbolp var)) (byte-compile-const-symbol-p var)) |
2666 |
(byte-compile-out base-op tmp))) |
(byte-compile-out base-op tmp))) |
2667 |
|
|
2668 |
(defun byte-compile-dynamic-variable-bind (var) |
(defun byte-compile-dynamic-variable-bind (var) |
2669 |
|
"Generate code to bind the lexical variable VAR to the top-of-stack value." |
2670 |
(byte-compile-check-variable var t) |
(byte-compile-check-variable var t) |
2671 |
(when (memq 'free-vars byte-compile-warnings) |
(when (memq 'free-vars byte-compile-warnings) |
2672 |
(push var byte-compile-bound-variables)) |
(push var byte-compile-bound-variables)) |
2675 |
;; This is used when it's know that VAR _definitely_ has a lexical |
;; This is used when it's know that VAR _definitely_ has a lexical |
2676 |
;; binding, and no error-checking should be done. |
;; binding, and no error-checking should be done. |
2677 |
(defun byte-compile-lexical-variable-ref (var) |
(defun byte-compile-lexical-variable-ref (var) |
2678 |
|
"Generate code to push the value of the lexical variable VAR on the stack." |
2679 |
(let ((binding (assq var byte-compile-lexical-environment))) |
(let ((binding (assq var byte-compile-lexical-environment))) |
2680 |
(when (null binding) |
(when (null binding) |
2681 |
(error "Lexical binding not found for `%s'" var)) |
(error "Lexical binding not found for `%s'" var)) |
2689 |
(byte-compile-out 'byte-vec-ref (byte-compile-lexvar-offset binding))))) |
(byte-compile-out 'byte-vec-ref (byte-compile-lexvar-offset binding))))) |
2690 |
|
|
2691 |
(defun byte-compile-variable-ref (var) |
(defun byte-compile-variable-ref (var) |
2692 |
|
"Generate code to push the value of the dynamic variable VAR on the stack." |
2693 |
(byte-compile-check-variable var) |
(byte-compile-check-variable var) |
2694 |
(let ((lex-binding (assq var byte-compile-lexical-environment))) |
(let ((lex-binding (assq var byte-compile-lexical-environment))) |
2695 |
(if lex-binding |
(if lex-binding |
2713 |
(byte-compile-dynamic-variable-op 'byte-varref var)))) |
(byte-compile-dynamic-variable-op 'byte-varref var)))) |
2714 |
|
|
2715 |
(defun byte-compile-variable-set (var) |
(defun byte-compile-variable-set (var) |
2716 |
|
"Generate code to set the dynamic variable VAR from the top-of-stack value." |
2717 |
(byte-compile-check-variable var) |
(byte-compile-check-variable var) |
2718 |
(let ((lex-binding (assq var byte-compile-lexical-environment))) |
(let ((lex-binding (assq var byte-compile-lexical-environment))) |
2719 |
(if lex-binding |
(if lex-binding |
3364 |
init-lexenv) |
init-lexenv) |
3365 |
|
|
3366 |
(defun byte-compile-let (form) |
(defun byte-compile-let (form) |
3367 |
|
"Generate code for the `let' form FORM." |
3368 |
(let ((clauses (cadr form)) |
(let ((clauses (cadr form)) |
3369 |
(lforminfo (and lexical-binding (byte-compile-compute-lforminfo form))) |
(lforminfo (and lexical-binding (byte-compile-compute-lforminfo form))) |
3370 |
(init-lexenv nil) |
(init-lexenv nil) |
3408 |
(byte-compile-out 'byte-unbind (length clauses)))))) |
(byte-compile-out 'byte-unbind (length clauses)))))) |
3409 |
|
|
3410 |
(defun byte-compile-let* (form) |
(defun byte-compile-let* (form) |
3411 |
|
"Generate code for the `let*' form FORM." |
3412 |
(let ((clauses (cadr form)) |
(let ((clauses (cadr form)) |
3413 |
(lforminfo (and lexical-binding (byte-compile-compute-lforminfo form))) |
(lforminfo (and lexical-binding (byte-compile-compute-lforminfo form))) |
3414 |
(init-lexenv nil) |
(init-lexenv nil) |