Commit ca105506 authored by Stefan Monnier's avatar Stefan Monnier
Browse files

Remove bytecomp- prefix, plus misc changes.

* lisp/emacs-lisp/byte-opt.el (byte-compile-inline-expand): Make it work to
inline lexbind interpreted functions into lexbind code.
(bytedecomp-bytes): Not a dynamic var any more.
(disassemble-offset): Get the bytes via an argument instead.
(byte-decompile-bytecode-1): Use push.
* lisp/emacs-lisp/bytecomp.el: Remove the bytecomp- prefix now that we use
lexical-binding.
(byte-compile-outbuffer): Rename from bytecomp-outbuffer.
* lisp/emacs-lisp/cl-macs.el (load-time-value):
* lisp/emacs-lisp/cl.el (cl-compiling-file): Adjust to new name.
* lisp/emacs-lisp/pcase.el (pcase-mutually-exclusive-predicates):
Add byte-code-function-p.
(pcase--u1): Remove left-over code from early development.
Fix case of variable shadowing in guards and predicates.
(pcase--u1): Add a new `let' pattern.
* src/image.c (parse_image_spec): Use Ffunctionp.
* src/lisp.h: Declare Ffunctionp.
parent 2663659f
2011-03-16 Stefan Monnier <monnier@iro.umontreal.ca>
* emacs-lisp/pcase.el (pcase-mutually-exclusive-predicates):
Add byte-code-function-p.
(pcase--u1): Remove left-over code from early development.
Fix case of variable shadowing in guards and predicates.
(pcase--u1): Add a new `let' pattern.
* emacs-lisp/bytecomp.el: Remove the bytecomp- prefix now that we use
lexical-binding.
(byte-compile-outbuffer): Rename from bytecomp-outbuffer.
* emacs-lisp/cl-macs.el (load-time-value):
* emacs-lisp/cl.el (cl-compiling-file): Adjust to new name.
* emacs-lisp/byte-opt.el (byte-compile-inline-expand): Make it work to
inline lexbind interpreted functions into lexbind code.
(bytedecomp-bytes): Not a dynamic var any more.
(disassemble-offset): Get the bytes via an argument instead.
(byte-decompile-bytecode-1): Use push.
2011-03-15 Stefan Monnier <monnier@iro.umontreal.ca>
* makefile.w32-in (COMPILE_FIRST): Fix up last change.
......
......@@ -265,45 +265,72 @@
(defun byte-compile-inline-expand (form)
(let* ((name (car form))
(fn (or (cdr (assq name byte-compile-function-environment))
(and (fboundp name) (symbol-function name)))))
(if (null fn)
(progn
(byte-compile-warn "attempt to inline `%s' before it was defined"
name)
form)
;; else
(localfn (cdr (assq name byte-compile-function-environment)))
(fn (or localfn (and (fboundp name) (symbol-function name)))))
(when (and (consp fn) (eq (car fn) 'autoload))
(load (nth 1 fn))
(setq fn (or (and (fboundp name) (symbol-function name))
(cdr (assq name byte-compile-function-environment)))))
(if (and (consp fn) (eq (car fn) 'autoload))
(pcase fn
(`nil
(byte-compile-warn "attempt to inline `%s' before it was defined"
name)
form)
(`(autoload . ,_)
(error "File `%s' didn't define `%s'" (nth 1 fn) name))
(cond
((and (symbolp fn) (not (eq fn t))) ;A function alias.
((and (pred symbolp) (guard (not (eq fn t)))) ;A function alias.
(byte-compile-inline-expand (cons fn (cdr form))))
((and (byte-code-function-p fn)
;; FIXME: This works to inline old-style-byte-codes into
;; old-style-byte-codes, but not mixed cases (not sure
;; about new-style into new-style).
(not lexical-binding)
(not (integerp (aref fn 0)))) ;New lexical byte-code.
((and (pred byte-code-function-p)
;; FIXME: This only works to inline old-style-byte-codes into
;; old-style-byte-codes.
(guard (not (or lexical-binding
(integerp (aref fn 0))))))
;; (message "Inlining %S byte-code" name)
(fetch-bytecode fn)
(let ((string (aref fn 1)))
;; Isn't it an error for `string' not to be unibyte?? --stef
(if (fboundp 'string-as-unibyte)
(setq string (string-as-unibyte string)))
(assert (not (multibyte-string-p string)))
;; `byte-compile-splice-in-already-compiled-code'
;; takes care of inlining the body.
(cons `(lambda ,(aref fn 0)
(byte-code ,string ,(aref fn 2) ,(aref fn 3)))
(cdr form))))
((eq (car-safe fn) 'lambda)
((and `(lambda . ,_)
;; With lexical-binding we have several problems:
;; - if `fn' comes from byte-compile-function-environment, we
;; need to preprocess `fn', so we handle it below.
;; - else, it means that `fn' is dyn-bound (otherwise it would
;; start with `closure') so copying the code here would cause
;; it to be mis-interpreted.
(guard (not lexical-binding)))
(macroexpand-all (cons fn (cdr form))
byte-compile-macro-environment))
((and (or (and `(lambda ,args . ,body)
(let env nil)
(guard (eq fn localfn)))
`(closure ,env ,args . ,body))
(guard lexical-binding))
(let ((renv ()))
(dolist (binding env)
(cond
((consp binding)
;; We check shadowing by the args, so that the `let' can be
;; moved within the lambda, which can then be unfolded.
;; FIXME: Some of those bindings might be unused in `body'.
(unless (memq (car binding) args) ;Shadowed.
(push `(,(car binding) ',(cdr binding)) renv)))
((eq binding t))
(t (push `(defvar ,binding) body))))
;; (message "Inlining closure %S" (car form))
(let ((newfn (byte-compile-preprocess
`(lambda ,args (let ,(nreverse renv) ,@body)))))
(if (eq (car-safe newfn) 'function)
(byte-compile-unfold-lambda `(,(cadr newfn) ,@(cdr form)))
(byte-compile-log-warning
(format "Inlining closure %S failed" name))
form))))
(t ;; Give up on inlining.
form)))))
form))))
;; ((lambda ...) ...)
(defun byte-compile-unfold-lambda (form &optional name)
......@@ -1318,43 +1345,42 @@
;; Used and set dynamically in byte-decompile-bytecode-1.
(defvar bytedecomp-op)
(defvar bytedecomp-ptr)
(defvar bytedecomp-bytes)
;; This function extracts the bitfields from variable-length opcodes.
;; Originally defined in disass.el (which no longer uses it.)
(defun disassemble-offset ()
(defun disassemble-offset (bytes)
"Don't call this!"
;; fetch and return the offset for the current opcode.
;; return nil if this opcode has no offset
;; Fetch and return the offset for the current opcode.
;; Return nil if this opcode has no offset.
(cond ((< bytedecomp-op byte-nth)
(let ((tem (logand bytedecomp-op 7)))
(setq bytedecomp-op (logand bytedecomp-op 248))
(cond ((eq tem 6)
;; Offset in next byte.
(setq bytedecomp-ptr (1+ bytedecomp-ptr))
(aref bytedecomp-bytes bytedecomp-ptr))
(aref bytes bytedecomp-ptr))
((eq tem 7)
;; Offset in next 2 bytes.
(setq bytedecomp-ptr (1+ bytedecomp-ptr))
(+ (aref bytedecomp-bytes bytedecomp-ptr)
(+ (aref bytes bytedecomp-ptr)
(progn (setq bytedecomp-ptr (1+ bytedecomp-ptr))
(lsh (aref bytedecomp-bytes bytedecomp-ptr) 8))))
(t tem)))) ;offset was in opcode
(lsh (aref bytes bytedecomp-ptr) 8))))
(t tem)))) ;Offset was in opcode.
((>= bytedecomp-op byte-constant)
(prog1 (- bytedecomp-op byte-constant) ;offset in opcode
(prog1 (- bytedecomp-op byte-constant) ;Offset in opcode.
(setq bytedecomp-op byte-constant)))
((or (and (>= bytedecomp-op byte-constant2)
(<= bytedecomp-op byte-goto-if-not-nil-else-pop))
(= bytedecomp-op byte-stack-set2))
;; Offset in next 2 bytes.
(setq bytedecomp-ptr (1+ bytedecomp-ptr))
(+ (aref bytedecomp-bytes bytedecomp-ptr)
(+ (aref bytes bytedecomp-ptr)
(progn (setq bytedecomp-ptr (1+ bytedecomp-ptr))
(lsh (aref bytedecomp-bytes bytedecomp-ptr) 8))))
(lsh (aref bytes bytedecomp-ptr) 8))))
((and (>= bytedecomp-op byte-listN)
(<= bytedecomp-op byte-discardN))
(setq bytedecomp-ptr (1+ bytedecomp-ptr)) ;offset in next byte
(aref bytedecomp-bytes bytedecomp-ptr))))
(setq bytedecomp-ptr (1+ bytedecomp-ptr)) ;Offset in next byte.
(aref bytes bytedecomp-ptr))))
(defvar byte-compile-tag-number)
......@@ -1386,19 +1412,19 @@
endtag)
(while (not (= bytedecomp-ptr length))
(or make-spliceable
(setq lap (cons bytedecomp-ptr lap)))
(push bytedecomp-ptr lap))
(setq bytedecomp-op (aref bytedecomp-bytes bytedecomp-ptr)
optr bytedecomp-ptr
offset (disassemble-offset)) ; this does dynamic-scope magic
;; This uses dynamic-scope magic.
offset (disassemble-offset bytedecomp-bytes))
(setq bytedecomp-op (aref byte-code-vector bytedecomp-op))
(cond ((memq bytedecomp-op byte-goto-ops)
;; it's a pc
;; It's a pc.
(setq offset
(cdr (or (assq offset tags)
(car (setq tags
(cons (cons offset
(byte-compile-make-tag))
tags)))))))
(let ((new (cons offset (byte-compile-make-tag))))
(push new tags)
new)))))
((cond ((eq bytedecomp-op 'byte-constant2)
(setq bytedecomp-op 'byte-constant) t)
((memq bytedecomp-op byte-constref-ops)))
......@@ -1408,9 +1434,9 @@
offset (if (eq bytedecomp-op 'byte-constant)
(byte-compile-get-constant tmp)
(or (assq tmp byte-compile-variables)
(car (setq byte-compile-variables
(cons (list tmp)
byte-compile-variables)))))))
(let ((new (list tmp)))
(push new byte-compile-variables)
new)))))
((and make-spliceable
(eq bytedecomp-op 'byte-return))
(if (= bytedecomp-ptr (1- length))
......@@ -1427,26 +1453,26 @@
(setq bytedecomp-op 'byte-discardN-preserve-tos)
(setq offset (- offset #x80))))
;; lap = ( [ (pc . (op . arg)) ]* )
(setq lap (cons (cons optr (cons bytedecomp-op (or offset 0)))
lap))
(push (cons optr (cons bytedecomp-op (or offset 0)))
lap)
(setq bytedecomp-ptr (1+ bytedecomp-ptr)))
;; take off the dummy nil op that we replaced a trailing "return" with.
(let ((rest lap))
(while rest
(cond ((numberp (car rest)))
((setq tmp (assq (car (car rest)) tags))
;; this addr is jumped to
;; This addr is jumped to.
(setcdr rest (cons (cons nil (cdr tmp))
(cdr rest)))
(setq tags (delq tmp tags))
(setq rest (cdr rest))))
(setq rest (cdr rest))))
(if tags (error "optimizer error: missed tags %s" tags))
;; Take off the dummy nil op that we replaced a trailing "return" with.
(if (null (car (cdr (car lap))))
(setq lap (cdr lap)))
(if endtag
(setq lap (cons (cons nil endtag) lap)))
;; remove addrs, lap = ( [ (op . arg) | (TAG tagno) ]* )
;; Remove addrs, lap = ( [ (op . arg) | (TAG tagno) ]* )
(mapcar (function (lambda (elt)
(if (numberp elt)
elt
......
This diff is collapsed.
......@@ -65,8 +65,16 @@
;;
;;; Code:
;; TODO:
;; TODO: (not just for cconv but also for the lexbind changes in general)
;; - inline lexical byte-code functions.
;; - investigate some old v18 stuff in bytecomp.el.
;; - optimize away unused cl-block-wrapper.
;; - let (e)debug find the value of lexical variables from the stack.
;; - byte-optimize-form should be applied before cconv.
;; OTOH, the warnings emitted by cconv-analyze need to come before optimize
;; since afterwards they can because obnoxious (warnings about an "unused
;; variable" should not be emitted when the variable use has simply been
;; optimized away).
;; - canonize code in macro-expand so we don't have to handle (let (var) body)
;; and other oddities.
;; - new byte codes for unwind-protect, catch, and condition-case so that
......@@ -377,6 +385,7 @@ places where they originally did not directly appear."
; first element is lambda expression
(`(,(and `(lambda . ,_) fun) . ,args)
;; FIXME: it's silly to create a closure just to call it.
;; Running byte-optimize-form earlier will resolve this.
`(funcall
,(cconv-convert `(function ,fun) env extend)
,@(mapcar (lambda (form)
......@@ -646,8 +655,8 @@ and updates the data stored in ENV."
(`(condition-case ,var ,protected-form . ,handlers)
;; FIXME: The bytecode for condition-case forces us to wrap the
;; form and handlers in closures (for handlers, it's probably
;; unavoidable, but not for the protected form).
;; form and handlers in closures (for handlers, it's understandable
;; but not for the protected form).
(cconv--analyse-function () (list protected-form) env form)
(dolist (handler handlers)
(cconv--analyse-function (if var (list var)) (cdr handler) env form)))
......@@ -657,8 +666,8 @@ and updates the data stored in ENV."
(cconv-analyse-form form env)
(cconv--analyse-function () body env form))
;; FIXME: The bytecode for save-window-excursion and the lack of
;; bytecode for track-mouse forces us to wrap the body.
;; FIXME: The lack of bytecode for track-mouse forces us to wrap the body.
;; `track-mouse' really should be made into a macro.
(`(track-mouse . ,body)
(cconv--analyse-function () body env form))
......
......@@ -282,7 +282,7 @@ Not documented
;;;;;; flet progv psetq do-all-symbols do-symbols dotimes dolist
;;;;;; do* do loop return-from return block etypecase typecase ecase
;;;;;; case load-time-value eval-when destructuring-bind function*
;;;;;; defmacro* defun* gentemp gensym) "cl-macs" "cl-macs.el" "864a28dc0495ad87d39637a965387526")
;;;;;; defmacro* defun* gentemp gensym) "cl-macs" "cl-macs.el" "80cb83265399ce021c8c0c7d1a8562f2")
;;; Generated autoloads from cl-macs.el
(autoload 'gensym "cl-macs" "\
......
......@@ -497,7 +497,7 @@ The result of the body appears to the compiler as a quoted constant."
(symbol-function 'byte-compile-file-form)))
(list 'byte-compile-file-form (list 'quote set))
'(byte-compile-file-form form)))
(print set (symbol-value 'bytecomp-outbuffer)))
(print set (symbol-value 'byte-compile-outbuffer)))
(list 'symbol-value (list 'quote temp)))
(list 'quote (eval form))))
......
......@@ -278,9 +278,9 @@ definitions to shadow the loaded ones for use in file byte-compilation.
(defvar cl-compiling-file nil)
(defun cl-compiling-file ()
(or cl-compiling-file
(and (boundp 'bytecomp-outbuffer)
(bufferp (symbol-value 'bytecomp-outbuffer))
(equal (buffer-name (symbol-value 'bytecomp-outbuffer))
(and (boundp 'byte-compile-outbuffer)
(bufferp (symbol-value 'byte-compile-outbuffer))
(equal (buffer-name (symbol-value 'byte-compile-outbuffer))
" *Compiler Output*"))))
(defvar cl-proclaims-deferred nil)
......
......@@ -27,16 +27,21 @@
;; Todo:
;; - (pcase e (`(,x . ,x) foo)) signals an "x unused" warning if `foo' doesn't
;; use x, because x is bound separately for the equality constraint
;; (as well as any pred/guard) and for the body, so uses at one place don't
;; count for the other.
;; - provide ways to extend the set of primitives, with some kind of
;; define-pcase-matcher. We could easily make it so that (guard BOOLEXP)
;; could be defined this way, as a shorthand for (pred (lambda (_) BOOLEXP)).
;; But better would be if we could define new ways to match by having the
;; extension provide its own `pcase--split-<foo>' thingy.
;; - along these lines, provide patterns to match CL structs.
;; - provide something like (setq VAR) so a var can be set rather than
;; let-bound.
;; - provide a way to fallthrough to other cases.
;; - provide a way to fallthrough to subsequent cases.
;; - try and be more clever to reduce the size of the decision tree, and
;; to reduce the number of leafs that need to be turned into function:
;; to reduce the number of leaves that need to be turned into function:
;; - first, do the tests shared by all remaining branches (it will have
;; to be performed anyway, so better so it first so it's shared).
;; - then choose the test that discriminates more (?).
......@@ -67,6 +72,7 @@ UPatterns can take the following forms:
`QPAT matches if the QPattern QPAT matches.
(pred PRED) matches if PRED applied to the object returns non-nil.
(guard BOOLEXP) matches if BOOLEXP evaluates to non-nil.
(let UPAT EXP) matches if EXP matches UPAT.
If a SYMBOL is used twice in the same pattern (i.e. the pattern is
\"non-linear\"), then the second occurrence is turned into an `eq'uality test.
......@@ -297,15 +303,21 @@ MATCH is the pattern that needs to be matched, of the form:
(symbolp . consp)
(symbolp . arrayp)
(symbolp . stringp)
(symbolp . byte-code-function-p)
(integerp . consp)
(integerp . arrayp)
(integerp . stringp)
(integerp . byte-code-function-p)
(numberp . consp)
(numberp . arrayp)
(numberp . stringp)
(numberp . byte-code-function-p)
(consp . arrayp)
(consp . stringp)
(arrayp . stringp)))
(consp . byte-code-function-p)
(arrayp . stringp)
(arrayp . byte-code-function-p)
(stringp . byte-code-function-p)))
(defun pcase--split-match (sym splitter match)
(cond
......@@ -514,7 +526,6 @@ Otherwise, it defers to REST which is a list of branches of the form
(cond
((memq upat '(t _)) (pcase--u1 matches code vars rest))
((eq upat 'dontcare) :pcase--dontcare)
((functionp upat) (error "Feature removed, use (pred %s)" upat))
((memq (car-safe upat) '(guard pred))
(if (eq (car upat) 'pred) (put sym 'pcase-used t))
(let* ((splitrest
......@@ -527,21 +538,24 @@ Otherwise, it defers to REST which is a list of branches of the form
(let* ((exp (cadr upat))
;; `vs' is an upper bound on the vars we need.
(vs (pcase--fgrep (mapcar #'car vars) exp))
(call (cond
((eq 'guard (car upat)) exp)
((functionp exp) `(,exp ,sym))
(t `(,@exp ,sym)))))
(env (mapcar (lambda (var)
(list var (cdr (assq var vars))))
vs))
(call (if (eq 'guard (car upat))
exp
(when (memq sym vs)
;; `sym' is shadowed by `env'.
(let ((newsym (make-symbol "x")))
(push (list newsym sym) env)
(setq sym newsym)))
(if (functionp exp) `(,exp ,sym)
`(,@exp ,sym)))))
(if (null vs)
call
;; Let's not replace `vars' in `exp' since it's
;; too difficult to do it right, instead just
;; let-bind `vars' around `exp'.
`(let ,(mapcar (lambda (var)
(list var (cdr (assq var vars))))
vs)
;; FIXME: `vars' can capture `sym'. E.g.
;; (pcase x ((and `(,x . ,y) (pred (fun x)))))
,call))))
`(let* ,env ,call))))
(pcase--u1 matches code vars then-rest)
(pcase--u else-rest))))
((symbolp upat)
......@@ -552,6 +566,25 @@ Otherwise, it defers to REST which is a list of branches of the form
(pcase--u1 (cons `(match ,sym . (pred (eq ,(cdr (assq upat vars)))))
matches)
code vars rest)))
((eq (car-safe upat) 'let)
;; A upat of the form (let VAR EXP).
;; (pcase--u1 matches code
;; (cons (cons (nth 1 upat) (nth 2 upat)) vars) rest)
(let* ((exp
(let* ((exp (nth 2 upat))
(found (assq exp vars)))
(if found (cdr found)
(let* ((vs (pcase--fgrep (mapcar #'car vars) exp))
(env (mapcar (lambda (v) (list v (cdr (assq v vars))))
vs)))
(if env `(let* ,env ,exp) exp)))))
(sym (if (symbolp exp) exp (make-symbol "x")))
(body
(pcase--u1 (cons `(match ,sym . ,(nth 1 upat)) matches)
code vars rest)))
(if (eq sym exp)
body
`(let* ((,sym ,exp)) ,body))))
((eq (car-safe upat) '\`)
(put sym 'pcase-used t)
(pcase--q1 sym (cadr upat) matches code vars rest))
......
......@@ -2082,6 +2082,7 @@ A fancy display is used on graphic displays, normal otherwise."
;; Note that any local variables in this function affect the
;; ability of -f batch-byte-compile to detect free variables.
;; So we give some of them with common names a cl1- prefix.
;; FIXME: A better fix would be to make this file use lexical-binding.
(let ((cl1-dir command-line-default-directory)
cl1-tem
;; This approach loses for "-batch -L DIR --eval "(require foo)",
......
......@@ -187,10 +187,13 @@ Then evaluate RESULT to get return value, default nil.
;; It would be cleaner to create an uninterned symbol,
;; but that uses a lot more space when many functions in many files
;; use dolist.
;; FIXME: This cost disappears in byte-compiled lexical-binding files.
(let ((temp '--dolist-tail--))
`(let ((,temp ,(nth 1 spec))
,(car spec))
(while ,temp
;; FIXME: In lexical-binding code, a `let' inside the loop might
;; turn out to be faster than the an outside `let' this `setq'.
(setq ,(car spec) (car ,temp))
,@body
(setq ,temp (cdr ,temp)))
......
2011-03-16 Stefan Monnier <monnier@iro.umontreal.ca>
* image.c (parse_image_spec): Use Ffunctionp.
* lisp.h: Declare Ffunctionp.
2011-03-13 Stefan Monnier <monnier@iro.umontreal.ca>
* eval.c (Ffunction): Use simpler format for closures.
......
......@@ -939,27 +939,27 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth,
save_restriction_save ());
break;
case Bcatch:
case Bcatch: /* FIXME: ill-suited for lexbind */
{
Lisp_Object v1;
BEFORE_POTENTIAL_GC ();
v1 = POP;
TOP = internal_catch (TOP, eval_sub, v1); /* FIXME: lexbind */
TOP = internal_catch (TOP, eval_sub, v1);
AFTER_POTENTIAL_GC ();
break;
}
case Bunwind_protect:
record_unwind_protect (Fprogn, POP); /* FIXME: lexbind */
case Bunwind_protect: /* FIXME: avoid closure for lexbind */
record_unwind_protect (Fprogn, POP);
break;
case Bcondition_case:
case Bcondition_case: /* FIXME: ill-suited for lexbind */
{
Lisp_Object handlers, body;
handlers = POP;
body = POP;
BEFORE_POTENTIAL_GC ();
TOP = internal_lisp_condition_case (TOP, body, handlers); /* FIXME: lexbind */
TOP = internal_lisp_condition_case (TOP, body, handlers);
AFTER_POTENTIAL_GC ();
break;
}
......
......@@ -835,10 +835,7 @@ parse_image_spec (Lisp_Object spec, struct image_keyword *keywords,
case IMAGE_FUNCTION_VALUE:
value = indirect_function (value);
/* FIXME: Shouldn't we use Ffunctionp here? */
if (SUBRP (value)
|| COMPILEDP (value)
|| (CONSP (value) && EQ (XCAR (value), Qlambda)))
if (!NILP (Ffunctionp (value)))
break;
return 0;
......
......@@ -2864,6 +2864,7 @@ extern void xsignal2 (Lisp_Object, Lisp_Object, Lisp_Object) NO_RETURN;
extern void xsignal3 (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object) NO_RETURN;
extern void signal_error (const char *, Lisp_Object) NO_RETURN;
EXFUN (Fcommandp, 2);
EXFUN (Ffunctionp, 1);
EXFUN (Feval, 2);
extern Lisp_Object eval_sub (Lisp_Object form);
EXFUN (Fapply, MANY);
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment