procyberian/emacs
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Fix pcase memoizing; change lexbound byte-code marker.

Browse source 
* src/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.
* lisp/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.
* lisp/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.
* lisp/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.
* lisp/emacs-lisp/macroexp.el (macroexpand-all-1): Slight change to the
pcase pattern to generate slightly better code.
This commit is contained in:
Stefan Monnier 2011-03-05 23:48:17 -05:00
parent d032d5e7df
commit e2abe5a13d
10 changed files with 188 additions and 78 deletions
Download patch file Download diff file Expand all files Collapse all files

17
lisp/ChangeLog
View file

@ -1,3 +1,20 @@
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.

3
lisp/emacs-lisp/byte-opt.el
View file

@ -2009,8 +2009,7 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
(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)))

87
lisp/emacs-lisp/bytecomp.el
View file

@ -33,6 +33,9 @@
;;; Code:
;; FIXME: Use lexical-binding and get rid of the atrocious "bytecomp-"
;; variable prefix.
;; ========================================================================
;; Entry points:
;; byte-recompile-directory, byte-compile-file,
@ -1180,22 +1183,28 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'."
(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)
@ -2645,6 +2654,26 @@ If FORM is a lambda or a macro, byte-compile it as a function."
;; 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.
@ -2716,18 +2745,22 @@ If FORM is a lambda or a macro, byte-compile it as a function."
;; 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))

11
lisp/emacs-lisp/cconv.el
View file

@ -66,22 +66,21 @@
;;; 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.

9
lisp/emacs-lisp/macroexp.el
View file

@ -176,10 +176,11 @@ Assumes the caller has bound `macroexpand-all-environment'."
(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)

23
lisp/emacs-lisp/pcase.el
View file

@ -42,7 +42,7 @@
;; 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))
@ -78,10 +78,21 @@ E.g. you can match pairs where the cdr is larger than the car with a pattern
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)
@ -135,6 +146,8 @@ of the form (UPAT EXP)."
(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)))))

26
lisp/help-fns.el
View file

@ -76,15 +76,18 @@ DEF is the function whose usage we're looking for in DOCSTRING."
;; 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)
@ -95,6 +98,7 @@ ARGLIST can also be t or a string of the form \"(FUN ARG1 ARG2 ...)\"."
(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)))
@ -103,12 +107,28 @@ ARGLIST can also be t or a string of the form \"(FUN ARG1 ARG2 ...)\"."
;; 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)