+2011-03-06 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * emacs-lisp/bytecomp.el (byte-compile-arglist-signature):
+ Handle integer arglist descriptor.
+ (byte-compile-make-args-desc): Make integer arglist descriptor.
+ (byte-compile-lambda): Use integer arglist descriptor to mark lexical
+ byte-coded functions instead of an extra slot.
+ * help-fns.el (help-add-fundoc-usage): Don't add a dummy doc.
+ (help-split-fundoc): Return a nil doc if there was no actual doc.
+ (help-function-arglist): Generate an arglist from an integer arg-desc.
+ * emacs-lisp/pcase.el (pcase--memoize): Rename from pcase-memoize;
+ Make only the key weak.
+ (pcase): Change the key used in the memoization table, so it does not
+ always get GC'd away.
+ * emacs-lisp/macroexp.el (macroexpand-all-1): Slight change to the
+ pcase pattern to generate slightly better code.
+
2011-03-01 Stefan Monnier <monnier@iro.umontreal.ca>
* emacs-lisp/cconv.el (cconv-liftwhen): Increase threshold.
(setq lap0 (car rest)
lap1 (nth 1 rest))
(if (memq (car lap0) byte-constref-ops)
- (if (or (eq (car lap0) 'byte-constant)
- (eq (car lap0) 'byte-constant2))
+ (if (memq (car lap0) '(byte-constant byte-constant2))
(unless (memq (cdr lap0) byte-compile-constants)
(setq byte-compile-constants (cons (cdr lap0)
byte-compile-constants)))
;;; Code:
+;; FIXME: Use lexical-binding and get rid of the atrocious "bytecomp-"
+;; variable prefix.
+
;; ========================================================================
;; Entry points:
;; byte-recompile-directory, byte-compile-file,
(t fn)))))))
(defun byte-compile-arglist-signature (arglist)
- (let ((args 0)
- opts
- restp)
- (while arglist
- (cond ((eq (car arglist) '&optional)
- (or opts (setq opts 0)))
- ((eq (car arglist) '&rest)
- (if (cdr arglist)
- (setq restp t
- arglist nil)))
- (t
- (if opts
- (setq opts (1+ opts))
+ (if (integerp arglist)
+ ;; New style byte-code arglist.
+ (cons (logand arglist 127) ;Mandatory.
+ (if (zerop (logand arglist 128)) ;No &rest.
+ (lsh arglist -8))) ;Nonrest.
+ ;; Old style byte-code, or interpreted function.
+ (let ((args 0)
+ opts
+ restp)
+ (while arglist
+ (cond ((eq (car arglist) '&optional)
+ (or opts (setq opts 0)))
+ ((eq (car arglist) '&rest)
+ (if (cdr arglist)
+ (setq restp t
+ arglist nil)))
+ (t
+ (if opts
+ (setq opts (1+ opts))
(setq args (1+ args)))))
- (setq arglist (cdr arglist)))
- (cons args (if restp nil (if opts (+ args opts) args)))))
+ (setq arglist (cdr arglist)))
+ (cons args (if restp nil (if opts (+ args opts) args))))))
(defun byte-compile-arglist-signatures-congruent-p (old new)
;; Return the new lexical environment
lexenv))))
+(defun byte-compile-make-args-desc (arglist)
+ (let ((mandatory 0)
+ nonrest (rest 0))
+ (while (and arglist (not (memq (car arglist) '(&optional &rest))))
+ (setq mandatory (1+ mandatory))
+ (setq arglist (cdr arglist)))
+ (setq nonrest mandatory)
+ (when (eq (car arglist) '&optional)
+ (setq arglist (cdr arglist))
+ (while (and arglist (not (eq (car arglist) '&rest)))
+ (setq nonrest (1+ nonrest))
+ (setq arglist (cdr arglist))))
+ (when arglist
+ (setq rest 1))
+ (if (> mandatory 127)
+ (byte-compile-report-error "Too many (>127) mandatory arguments")
+ (logior mandatory
+ (lsh nonrest 8)
+ (lsh rest 7)))))
+
;; Byte-compile a lambda-expression and return a valid function.
;; The value is usually a compiled function but may be the original
;; lambda-expression.
;; Build the actual byte-coded function.
(if (eq 'byte-code (car-safe compiled))
(apply 'make-byte-code
- (append (list bytecomp-arglist)
- ;; byte-string, constants-vector, stack depth
- (cdr compiled)
- ;; optionally, the doc string.
- (if (or bytecomp-doc bytecomp-int
- lexical-binding)
- (list bytecomp-doc))
- ;; optionally, the interactive spec.
- (if (or bytecomp-int lexical-binding)
- (list (nth 1 bytecomp-int)))
- (if lexical-binding
- '(t))))
+ (if lexical-binding
+ (byte-compile-make-args-desc bytecomp-arglist)
+ bytecomp-arglist)
+ (append
+ ;; byte-string, constants-vector, stack depth
+ (cdr compiled)
+ ;; optionally, the doc string.
+ (cond (lexical-binding
+ (require 'help-fns)
+ (list (help-add-fundoc-usage
+ bytecomp-doc bytecomp-arglist)))
+ ((or bytecomp-doc bytecomp-int)
+ (list bytecomp-doc)))
+ ;; optionally, the interactive spec.
+ (if bytecomp-int
+ (list (nth 1 bytecomp-int)))))
(setq compiled
(nconc (if bytecomp-int (list bytecomp-int))
(cond ((eq (car-safe compiled) 'progn) (cdr compiled))
;;; Code:
;; TODO:
+;; - byte-optimize-form should be applied before cconv.
+;; - maybe unify byte-optimize and compiler-macros.
;; - canonize code in macro-expand so we don't have to handle (let (var) body)
;; and other oddities.
-;; - Change new byte-code representation, so it directly gives the
-;; number of mandatory and optional arguments as well as whether or
-;; not there's a &rest arg.
;; - clean up cconv-closure-convert-rec, especially the `let' binding part.
;; - new byte codes for unwind-protect, catch, and condition-case so that
;; closures aren't needed at all.
;; - a reference to a var that is known statically to always hold a constant
;; should be turned into a byte-constant rather than a byte-stack-ref.
-;; Hmm... right, that's called constant propagation and could be done here
-;; But when that constant is a function, we have to be careful to make sure
+;; Hmm... right, that's called constant propagation and could be done here,
+;; but when that constant is a function, we have to be careful to make sure
;; the bytecomp only compiles it once.
;; - Since we know here when a variable is not mutated, we could pass that
;; info to the byte-compiler, e.g. by using a new `immutable-let'.
-;; - add tail-calls to bytecode.c and the bytecompiler.
+;; - add tail-calls to bytecode.c and the byte compiler.
;; (defmacro dlet (binders &rest body)
;; ;; Works in both lexical and non-lexical mode.
(macroexpand-all-forms args)))))
;; Macro expand compiler macros.
;; FIXME: Don't depend on CL.
- (`(,(and (pred symbolp) fun
- (guard (and (eq (get fun 'byte-compile)
- 'cl-byte-compile-compiler-macro)
- (functionp 'compiler-macroexpand))))
+ (`(,(pred (lambda (fun)
+ (and (symbolp fun)
+ (eq (get fun 'byte-compile)
+ 'cl-byte-compile-compiler-macro)
+ (functionp 'compiler-macroexpand))))
. ,_)
(let ((newform (compiler-macroexpand form)))
(if (eq form newform)
;; is in a loop, the repeated macro-expansion becomes terribly costly, so we
;; memoize previous macro expansions to try and avoid recomputing them
;; over and over again.
-(defconst pcase-memoize (make-hash-table :weakness t :test 'equal))
+(defconst pcase--memoize (make-hash-table :weakness 'key :test 'eq))
(defconst pcase--dontcare-upats '(t _ dontcare))
like `(,a . ,(pred (< a))) or, with more checks:
`(,(and a (pred numberp)) . ,(and (pred numberp) (pred (< a))))"
(declare (indent 1) (debug case)) ;FIXME: edebug `guard' and vars.
- (or (gethash (cons exp cases) pcase-memoize)
- (puthash (cons exp cases)
- (pcase--expand exp cases)
- pcase-memoize)))
+ ;; We want to use a weak hash table as a cache, but the key will unavoidably
+ ;; be based on `exp' and `cases', yet `cases' is a fresh new list each time
+ ;; we're called so it'll be immediately GC'd. So we use (car cases) as key
+ ;; which does come straight from the source code and should hence not be GC'd
+ ;; so easily.
+ (let ((data (gethash (car cases) pcase--memoize)))
+ ;; data = (EXP CASES . EXPANSION)
+ (if (and (equal exp (car data)) (equal cases (cadr data)))
+ ;; We have the right expansion.
+ (cddr data)
+ (when data
+ (message "pcase-memoize: equal first branch, yet different"))
+ (let ((expansion (pcase--expand exp cases)))
+ (puthash (car cases) (cons exp (cons cases expansion)) pcase--memoize)
+ expansion))))
;;;###autoload
(defmacro pcase-let* (bindings &rest body)
(and (symbolp upat) (not (memq upat pcase--dontcare-upats))))
(defun pcase--expand (exp cases)
+ ;; (message "pid=%S (pcase--expand %S ...hash=%S)"
+ ;; (emacs-pid) exp (sxhash cases))
(let* ((defs (if (symbolp exp) '()
(let ((sym (make-symbol "x")))
(prog1 `((,sym ,exp)) (setq exp sym)))))
;; Replace `fn' with the actual function name.
(if (consp def) "anonymous" def)
(match-string 1 docstring))
- (substring docstring 0 (match-beginning 0)))))
+ (unless (zerop (match-beginning 0))
+ (substring docstring 0 (match-beginning 0))))))
+;; FIXME: Move to subr.el?
(defun help-add-fundoc-usage (docstring arglist)
"Add the usage info to DOCSTRING.
If DOCSTRING already has a usage info, then just return it unchanged.
The usage info is built from ARGLIST. DOCSTRING can be nil.
ARGLIST can also be t or a string of the form \"(FUN ARG1 ARG2 ...)\"."
- (unless (stringp docstring) (setq docstring "Not documented"))
- (if (or (string-match "\n\n(fn\\(\\( .*\\)?)\\)\\'" docstring) (eq arglist t))
+ (unless (stringp docstring) (setq docstring ""))
+ (if (or (string-match "\n\n(fn\\(\\( .*\\)?)\\)\\'" docstring)
+ (eq arglist t))
docstring
(concat docstring
(if (string-match "\n?\n\\'" docstring)
(concat "(fn" (match-string 1 arglist) ")")
(format "%S" (help-make-usage 'fn arglist))))))
+;; FIXME: Move to subr.el?
(defun help-function-arglist (def)
;; Handle symbols aliased to other symbols.
(if (and (symbolp def) (fboundp def)) (setq def (indirect-function def)))
;; and do the same for interpreted closures
(if (eq (car-safe def) 'closure) (setq def (cddr def)))
(cond
+ ((and (byte-code-function-p def) (integerp (aref def 0)))
+ (let* ((args-desc (aref def 0))
+ (max (lsh args-desc -8))
+ (min (logand args-desc 127))
+ (rest (logand args-desc 128))
+ (arglist ()))
+ (dotimes (i min)
+ (push (intern (concat "arg" (number-to-string (1+ i)))) arglist))
+ (when (> max min)
+ (push '&optional arglist)
+ (dotimes (i (- max min))
+ (push (intern (concat "arg" (number-to-string (+ 1 i min))))
+ arglist)))
+ (unless (zerop rest) (push '&rest arglist) (push 'rest arglist))
+ (nreverse arglist)))
((byte-code-function-p def) (aref def 0))
((eq (car-safe def) 'lambda) (nth 1 def))
((and (eq (car-safe def) 'autoload) (not (eq (nth 4 def) 'keymap)))
"[Arg list not available until function definition is loaded.]")
(t t)))
+;; FIXME: Move to subr.el?
(defun help-make-usage (function arglist)
(cons (if (symbolp function) function 'anonymous)
(mapcar (lambda (arg)
+2011-03-06 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * bytecode.c (exec_byte_code): Remove old lexical binding slot handling
+ and replace it with the a integer args-desc handling.
+ * eval.c (funcall_lambda): Adjust arglist test accordingly.
+
2011-03-01 Stefan Monnier <monnier@iro.umontreal.ca>
* callint.c (quotify_arg): Simplify the logic.
DEFUN ("make-byte-code", Fmake_byte_code, Smake_byte_code, 4, MANY, 0,
doc: /* Create a byte-code object with specified arguments as elements.
-The arguments should be the arglist, bytecode-string, constant vector,
-stack size, (optional) doc string, and (optional) interactive spec.
+The arguments should be the ARGLIST, bytecode-string BYTE-CODE, constant
+vector CONSTANTS, maximum stack size DEPTH, (optional) DOCSTRING,
+and (optional) INTERACTIVE-SPEC.
The first four arguments are required; at most six have any
significance.
+The ARGLIST can be either like the one of `lambda', in which case the arguments
+will be dynamically bound before executing the byte code, or it can be an
+integer of the form NNNNNNNRMMMMMMM where the 7bit MMMMMMM specifies the
+minimum number of arguments, the 7-bit NNNNNNN specifies the maximum number
+of arguments (ignoring &rest) and the R bit specifies whether there is a &rest
+argument to catch the left-over arguments. If such an integer is used, the
+arguments will not be dynamically bound but will be instead pushed on the
+stack before executing the byte-code.
usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INTERACTIVE-SPEC &rest ELEMENTS) */)
(register int nargs, Lisp_Object *args)
{
stacke = stack.bottom - 1 + XFASTINT (maxdepth);
#endif
- if (! NILP (args_template))
- /* We should push some arguments on the stack. */
+ if (INTEGERP (args_template))
{
- Lisp_Object at;
- int pushed = 0, optional = 0;
-
- for (at = args_template; CONSP (at); at = XCDR (at))
- if (EQ (XCAR (at), Qand_optional))
- optional = 1;
- else if (EQ (XCAR (at), Qand_rest))
- {
- PUSH (pushed < nargs
- ? Flist (nargs - pushed, args)
- : Qnil);
- pushed = nargs;
- at = Qnil;
- break;
- }
- else if (pushed < nargs)
- {
- PUSH (*args++);
- pushed++;
- }
- else if (optional)
- PUSH (Qnil);
- else
- break;
-
- if (pushed != nargs || !NILP (at))
+ int at = XINT (args_template);
+ int rest = at & 128;
+ int mandatory = at & 127;
+ int nonrest = at >> 8;
+ eassert (mandatory <= nonrest);
+ if (nargs <= nonrest)
+ {
+ int i;
+ for (i = 0 ; i < nargs; i++, args++)
+ PUSH (*args);
+ if (nargs < mandatory)
+ /* Too few arguments. */
+ Fsignal (Qwrong_number_of_arguments,
+ Fcons (Fcons (make_number (mandatory),
+ rest ? Qand_rest : make_number (nonrest)),
+ Fcons (make_number (nargs), Qnil)));
+ else
+ {
+ for (; i < nonrest; i++)
+ PUSH (Qnil);
+ if (rest)
+ PUSH (Qnil);
+ }
+ }
+ else if (rest)
+ {
+ int i;
+ for (i = 0 ; i < nonrest; i++, args++)
+ PUSH (*args);
+ PUSH (Flist (nargs - nonrest, args));
+ }
+ else
+ /* Too many arguments. */
Fsignal (Qwrong_number_of_arguments,
- Fcons (args_template, Fcons (make_number (nargs), Qnil)));
+ Fcons (Fcons (make_number (mandatory),
+ make_number (nonrest)),
+ Fcons (make_number (nargs), Qnil)));
+ }
+ else if (! NILP (args_template))
+ /* We should push some arguments on the stack. */
+ {
+ error ("Unknown args template!");
}
while (1)
projects / emacs.git / commitdiff