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

Various compiler bug-fixes. MPC seems to run correctly now.

* lisp/files.el (lexical-binding): Add a safe-local-variable property.

* lisp/emacs-lisp/byte-opt.el (byte-inline-lapcode): Check how many elements
are added to the stack.
(byte-compile-splice-in-already-compiled-code): Don't touch lexical nor
byte-compile-depth now that byte-inline-lapcode does it for us.
(byte-compile-inline-expand): Don't inline dynbind byte code into
lexbind code, since it has to be done differently.

* lisp/emacs-lisp/bytecomp.el (byte-compile-arglist-warn):
Correctly extract arglist from `closure's.
(byte-compile-cl-warn): Compiler-macros are run earlier now.
(byte-compile-top-level): Bind byte-compile-lexical-environment to nil,
except for lambdas.
(byte-compile-form): Don't run the compiler-macro expander here.
(byte-compile-let): Merge with byte-compile-let*.
Don't preserve-body-value if the body's value was discarded.

* lisp/emacs-lisp/cconv.el (cconv--set-diff, cconv--set-diff-map)
(cconv--map-diff, cconv--map-diff-elem, cconv--map-diff-set): New funs.
(cconv--env-var): New constant.
(cconv-closure-convert-rec): Use it and use them.  Fix a typo that
ended up forgetting to remove entries from lmenvs in `let'.
For `lambda' use the outer `fvrs' when building the closure and don't
forget to remove `vars' from the `emvrs' and `lmenvs' of the body.

* lisp/emacs-lisp/cl-macs.el (cl-byte-compile-block): Disable optimization
in lexbind, because it needs a different implementation.

* src/bytecode.c (exec_byte_code): Fix handling of &rest.

* src/eval.c (Vinternal_interpreter_environment): Remove.
(syms_of_eval): Do declare Vinternal_interpreter_environment as
a global lisp var, but unintern it to hide it.
(Fcommandp):
* src/data.c (Finteractive_form): Understand `closure's.
parent ce5b520a
2011-02-17 Stefan Monnier <monnier@iro.umontreal.ca>
* files.el (lexical-binding): Add a safe-local-variable property.
* emacs-lisp/cl-macs.el (cl-byte-compile-block): Disable optimization
in lexbind, because it needs a different implementation.
* emacs-lisp/cconv.el (cconv--set-diff, cconv--set-diff-map)
(cconv--map-diff, cconv--map-diff-elem, cconv--map-diff-set): New funs.
(cconv--env-var): New constant.
(cconv-closure-convert-rec): Use it and use them. Fix a typo that
ended up forgetting to remove entries from lmenvs in `let'.
For `lambda' use the outer `fvrs' when building the closure and don't
forget to remove `vars' from the `emvrs' and `lmenvs' of the body.
* emacs-lisp/bytecomp.el (byte-compile-arglist-warn):
Correctly extract arglist from `closure's.
(byte-compile-cl-warn): Compiler-macros are run earlier now.
(byte-compile-top-level): Bind byte-compile-lexical-environment to nil,
except for lambdas.
(byte-compile-form): Don't run the compiler-macro expander here.
(byte-compile-let): Merge with byte-compile-let*.
Don't preserve-body-value if the body's value was discarded.
* emacs-lisp/byte-opt.el (byte-inline-lapcode): Check how many elements
are added to the stack.
(byte-compile-splice-in-already-compiled-code): Don't touch lexical nor
byte-compile-depth now that byte-inline-lapcode does it for us.
(byte-compile-inline-expand): Don't inline dynbind byte code into
lexbind code, since it has to be done differently.
2011-02-12 Stefan Monnier <monnier@iro.umontreal.ca>
* emacs-lisp/byte-lexbind.el: Delete.
......
;;; -*- lexical-binding: t -*-
;;; doc-view.el --- View PDF/PostScript/DVI files in Emacs
;;; doc-view.el --- View PDF/PostScript/DVI files in Emacs -*- lexical-binding: t -*-
;; Copyright (C) 2007-2011 Free Software Foundation, Inc.
;;
......
......@@ -248,7 +248,18 @@
;; are no collisions, and that byte-compile-tag-number is reasonable
;; after this is spliced in. The provided list is destroyed.
(defun byte-inline-lapcode (lap)
(setq byte-compile-output (nconc (nreverse lap) byte-compile-output)))
;; "Replay" the operations: we used to just do
;; (setq byte-compile-output (nconc (nreverse lap) byte-compile-output))
;; but that fails to update byte-compile-depth, so we had to assume
;; that `lap' ends up adding exactly 1 element to the stack. This
;; happens to be true for byte-code generated by bytecomp.el without
;; lexical-binding, but it's not true in general, and it's not true for
;; code output by bytecomp.el with lexical-binding.
(dolist (op lap)
(cond
((eq (car op) 'TAG) (byte-compile-out-tag op))
((memq (car op) byte-goto-ops) (byte-compile-goto (car op) (cdr op)))
(t (byte-compile-out (car op) (cdr op))))))
(defun byte-compile-inline-expand (form)
(let* ((name (car form))
......@@ -266,25 +277,32 @@
(cdr (assq name byte-compile-function-environment)))))
(if (and (consp fn) (eq (car fn) 'autoload))
(error "File `%s' didn't define `%s'" (nth 1 fn) name))
(if (and (symbolp fn) (not (eq fn t)))
(byte-compile-inline-expand (cons fn (cdr form)))
(if (byte-code-function-p fn)
(let (string)
(fetch-bytecode fn)
(setq 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)))
;; `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)))
(if (eq (car-safe fn) 'lambda)
(macroexpand-all (cons fn (cdr form))
byte-compile-macro-environment)
;; Give up on inlining.
form))))))
(cond
((and (symbolp fn) (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 (and (>= (length fn) 7)
(aref fn 6)))) ;6 = COMPILED_PUSH_ARGS
;; (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)))
;; `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)
(macroexpand-all (cons fn (cdr form))
byte-compile-macro-environment))
(t ;; Give up on inlining.
form)))))
;; ((lambda ...) ...)
(defun byte-compile-unfold-lambda (form &optional name)
......@@ -1298,10 +1316,7 @@
(if (not (memq byte-optimize '(t lap)))
(byte-compile-normal-call form)
(byte-inline-lapcode
(byte-decompile-bytecode-1 (nth 1 form) (nth 2 form) t))
(setq byte-compile-maxdepth (max (+ byte-compile-depth (nth 3 form))
byte-compile-maxdepth))
(setq byte-compile-depth (1+ byte-compile-depth))))
(byte-decompile-bytecode-1 (nth 1 form) (nth 2 form) t))))
(put 'byte-code 'byte-compile 'byte-compile-splice-in-already-compiled-code)
......
......@@ -752,9 +752,10 @@ BYTES and PC are updated after evaluating all the arguments."
(bytes-var (car (last args 2)))
(pc-var (car (last args))))
`(setq ,bytes-var ,(if (null (cdr byte-exprs))
`(cons ,@byte-exprs ,bytes-var)
`(nconc (list ,@(reverse byte-exprs)) ,bytes-var))
,pc-var (+ ,(length byte-exprs) ,pc-var))))
`(progn (assert (<= 0 ,(car byte-exprs)))
(cons ,@byte-exprs ,bytes-var))
`(nconc (list ,@(reverse byte-exprs)) ,bytes-var))
,pc-var (+ ,(length byte-exprs) ,pc-var))))
(defmacro byte-compile-push-bytecode-const2 (opcode const2 bytes pc)
"Push OPCODE and the two-byte constant CONST2 onto BYTES, and add 3 to PC.
......@@ -817,7 +818,7 @@ CONST2 may be evaulated multiple times."
;; These insns all put their operand into one extra byte.
(byte-compile-push-bytecodes opcode off bytes pc))
((= opcode byte-discardN)
;; byte-discardN is wierd in that it encodes a flag in the
;; byte-discardN is weird in that it encodes a flag in the
;; top bit of its one-byte argument. If the argument is
;; too large to fit in 7 bits, the opcode can be repeated.
(let ((flag (if (eq op 'byte-discardN-preserve-tos) #x80 0)))
......@@ -1330,11 +1331,11 @@ extra args."
(eq 'lambda (car-safe (cdr-safe old)))
(setq old (cdr old)))
(let ((sig1 (byte-compile-arglist-signature
(if (eq 'lambda (car-safe old))
(nth 1 old)
(if (byte-code-function-p old)
(aref old 0)
'(&rest def)))))
(pcase old
(`(lambda ,args . ,_) args)
(`(closure ,_ ,_ ,args . ,_) args)
((pred byte-code-function-p) (aref old 0))
(t '(&rest def)))))
(sig2 (byte-compile-arglist-signature (nth 2 form))))
(unless (byte-compile-arglist-signatures-congruent-p sig1 sig2)
(byte-compile-set-symbol-position (nth 1 form))
......@@ -1402,14 +1403,7 @@ extra args."
;; but such warnings are never useful,
;; so don't warn about them.
macroexpand cl-macroexpand-all
cl-compiling-file)))
;; Avoid warnings for things which are safe because they
;; have suitable compiler macros, but those aren't
;; expanded at this stage. There should probably be more
;; here than caaar and friends.
(not (and (eq (get func 'byte-compile)
'cl-byte-compile-compiler-macro)
(string-match "\\`c[ad]+r\\'" (symbol-name func)))))
cl-compiling-file))))
(byte-compile-warn "function `%s' from cl package called at runtime"
func)))
form)
......@@ -2701,8 +2695,8 @@ If FORM is a lambda or a macro, byte-compile it as a function."
(if (eq (car-safe form) 'list)
(byte-compile-top-level (nth 1 bytecomp-int))
(setq bytecomp-int (list 'interactive
(byte-compile-top-level
(nth 1 bytecomp-int)))))))
(byte-compile-top-level
(nth 1 bytecomp-int)))))))
((cdr bytecomp-int)
(byte-compile-warn "malformed interactive spec: %s"
(prin1-to-string bytecomp-int)))))
......@@ -2788,6 +2782,9 @@ If FORM is a lambda or a macro, byte-compile it as a function."
(byte-compile-tag-number 0)
(byte-compile-depth 0)
(byte-compile-maxdepth 0)
(byte-compile-lexical-environment
(when (eq output-type 'lambda)
byte-compile-lexical-environment))
(byte-compile-output nil))
(if (memq byte-optimize '(t source))
(setq form (byte-optimize-form form for-effect)))
......@@ -2798,14 +2795,13 @@ If FORM is a lambda or a macro, byte-compile it as a function."
(stringp (nth 1 form)) (vectorp (nth 2 form))
(natnump (nth 3 form)))
form
;; Set up things for a lexically-bound function
;; Set up things for a lexically-bound function.
(when (and lexical-binding (eq output-type 'lambda))
;; See how many arguments there are, and set the current stack depth
;; accordingly
(dolist (var byte-compile-lexical-environment)
(setq byte-compile-depth (1+ byte-compile-depth)))
;; accordingly.
(setq byte-compile-depth (length byte-compile-lexical-environment))
;; If there are args, output a tag to record the initial
;; stack-depth for the optimizer
;; stack-depth for the optimizer.
(when (> byte-compile-depth 0)
(byte-compile-out-tag (byte-compile-make-tag))))
;; Now compile FORM
......@@ -2964,9 +2960,10 @@ That command is designed for interactive use only" bytecomp-fn))
;; for CL compiler macros since the symbol may be
;; `cl-byte-compile-compiler-macro' but if CL isn't
;; loaded, this function doesn't exist.
(or (not (memq bytecomp-handler
'(cl-byte-compile-compiler-macro)))
(functionp bytecomp-handler)))
(and (not (eq bytecomp-handler
;; Already handled by macroexpand-all.
'cl-byte-compile-compiler-macro))
(functionp bytecomp-handler)))
(funcall bytecomp-handler form)
(byte-compile-normal-call form))
(if (byte-compile-warning-enabled-p 'cl-functions)
......@@ -3612,7 +3609,7 @@ discarding."
(byte-defop-compiler-1 while)
(byte-defop-compiler-1 funcall)
(byte-defop-compiler-1 let)
(byte-defop-compiler-1 let*)
(byte-defop-compiler-1 let* byte-compile-let)
(defun byte-compile-progn (form)
(byte-compile-body-do-effect (cdr form)))
......@@ -3819,10 +3816,8 @@ Return the offset in the form (VAR . OFFSET)."
(byte-compile-push-constant nil)))))
(defun byte-compile-not-lexical-var-p (var)
(or (not (symbolp var)) ; form is not a list
(if (eval-when-compile (fboundp 'special-variable-p))
(special-variable-p var)
(boundp var))
(or (not (symbolp var))
(special-variable-p var)
(memq var byte-compile-bound-variables)
(memq var '(nil t))
(keywordp var)))
......@@ -3833,9 +3828,8 @@ INIT-LEXENV should be a lexical-environment alist describing the
positions of the init value that have been pushed on the stack.
Return non-nil if the TOS value was popped."
;; The presence of lexical bindings mean that we may have to
;; juggle things on the stack, either to move them to TOS for
;; dynamic binding, or to put them in a non-stack environment
;; vector.
;; juggle things on the stack, to move them to TOS for
;; dynamic binding.
(cond ((not (byte-compile-not-lexical-var-p var))
;; VAR is a simple stack-allocated lexical variable
(push (assq var init-lexenv)
......@@ -3883,56 +3877,41 @@ binding slots have been popped."
(defun byte-compile-let (form)
"Generate code for the `let' form FORM."
;; First compute the binding values in the old scope.
(let ((varlist (car (cdr form)))
(init-lexenv nil))
(dolist (var varlist)
(push (byte-compile-push-binding-init var) init-lexenv))
;; Now do the bindings, execute the body, and undo the bindings.
(let ((byte-compile-bound-variables byte-compile-bound-variables) ;new scope
(varlist (reverse (car (cdr form))))
(let ((clauses (cadr form))
(init-lexenv nil))
(when (eq (car form) 'let)
;; First compute the binding values in the old scope.
(dolist (var clauses)
(push (byte-compile-push-binding-init var) init-lexenv)))
;; New scope.
(let ((byte-compile-bound-variables byte-compile-bound-variables)
(byte-compile-lexical-environment byte-compile-lexical-environment))
(dolist (var varlist)
(let ((var (if (consp var) (car var) var)))
(cond ((null lexical-binding)
;; If there are no lexical bindings, we can do things simply.
(byte-compile-dynamic-variable-bind var))
((byte-compile-bind var init-lexenv)
(pop init-lexenv)))))
;; Bind the variables.
;; For `let', do it in reverse order, because it makes no
;; semantic difference, but it is a lot more efficient since the
;; values are now in reverse order on the stack.
(dolist (var (if (eq (car form) 'let) (reverse clauses) clauses))
(unless (eq (car form) 'let)
(push (byte-compile-push-binding-init var) init-lexenv))
(let ((var (if (consp var) (car var) var)))
(cond ((null lexical-binding)
;; If there are no lexical bindings, we can do things simply.
(byte-compile-dynamic-variable-bind var))
((byte-compile-bind var init-lexenv)
(pop init-lexenv)))))
;; Emit the body.
(byte-compile-body-do-effect (cdr (cdr form)))
;; Unbind the variables.
(if lexical-binding
;; Unbind both lexical and dynamic variables.
(byte-compile-unbind varlist init-lexenv t)
;; Unbind dynamic variables.
(byte-compile-out 'byte-unbind (length varlist))))))
(defun byte-compile-let* (form)
"Generate code for the `let*' form FORM."
(let ((byte-compile-bound-variables byte-compile-bound-variables) ;new scope
(clauses (cadr form))
(init-lexenv nil)
;; bind these to restrict the scope of any changes
(byte-compile-lexical-environment byte-compile-lexical-environment))
;; Bind the variables
(dolist (var clauses)
(push (byte-compile-push-binding-init var) init-lexenv)
(let ((var (if (consp var) (car var) var)))
(cond ((null lexical-binding)
;; If there are no lexical bindings, we can do things simply.
(byte-compile-dynamic-variable-bind var))
((byte-compile-bind var init-lexenv)
(pop init-lexenv)))))
;; Emit the body
(byte-compile-body-do-effect (cdr (cdr form)))
;; Unbind the variables
(if lexical-binding
;; Unbind both lexical and dynamic variables
(byte-compile-unbind clauses init-lexenv t)
;; Unbind dynamic variables
(byte-compile-out 'byte-unbind (length clauses)))))
(let ((init-stack-depth byte-compile-depth))
(byte-compile-body-do-effect (cdr (cdr form)))
;; Unbind the variables.
(if lexical-binding
;; Unbind both lexical and dynamic variables.
(progn
(assert (or (eq byte-compile-depth init-stack-depth)
(eq byte-compile-depth (1+ init-stack-depth))))
(byte-compile-unbind clauses init-lexenv (> byte-compile-depth
init-stack-depth)))
;; Unbind dynamic variables.
(byte-compile-out 'byte-unbind (length clauses)))))))
......@@ -4254,8 +4233,8 @@ binding slots have been popped."
(progn
;; ## remove this someday
(and byte-compile-depth
(not (= (cdr (cdr tag)) byte-compile-depth))
(error "Compiler bug: depth conflict at tag %d" (car (cdr tag))))
(not (= (cdr (cdr tag)) byte-compile-depth))
(error "Compiler bug: depth conflict at tag %d" (car (cdr tag))))
(setq byte-compile-depth (cdr (cdr tag))))
(setcdr (cdr tag) byte-compile-depth)))
......
......@@ -70,6 +70,15 @@
;;
;;; Code:
;;; TODO:
;; - Use abstract `make-closure' and `closure-ref' expressions, which bytecomp
;; should turn into building corresponding byte-code function.
;; - don't use `curry', instead build a new compiled-byte-code object
;; (merge the closure env into the static constants pool).
;; - use relative addresses for byte-code-stack-ref.
;; - warn about unused lexical vars.
;; - clean up cconv-closure-convert-rec, especially the `let' binding part.
(eval-when-compile (require 'cl))
(defconst cconv-liftwhen 3
......@@ -187,14 +196,14 @@ Returns a list of free variables."
-- TOPLEVEL(optional) is a boolean variable, true if we are at the root of AST
Returns a form where all lambdas don't have any free variables."
(message "Entering cconv-closure-convert...")
;; (message "Entering cconv-closure-convert...")
(let ((cconv-mutated '())
(cconv-lambda-candidates '())
(cconv-captured '())
(cconv-captured+mutated '()))
;; Analyse form - fill these variables with new information
;; Analyse form - fill these variables with new information.
(cconv-analyse-form form '() 0)
;; Calculate an intersection of cconv-mutated and cconv-captured
;; Calculate an intersection of cconv-mutated and cconv-captured.
(dolist (mvr cconv-mutated)
(when (memq mvr cconv-captured) ;
(push mvr cconv-captured+mutated)))
......@@ -216,14 +225,51 @@ Returns a form where all lambdas don't have any free variables."
res))
(defconst cconv--dummy-var (make-symbol "ignored"))
(defconst cconv--env-var (make-symbol "env"))
(defun cconv--set-diff (s1 s2)
"Return elements of set S1 that are not in set S2."
(let ((res '()))
(dolist (x s1)
(unless (memq x s2) (push x res)))
(nreverse res)))
(defun cconv--set-diff-map (s m)
"Return elements of set S that are not in Dom(M)."
(let ((res '()))
(dolist (x s)
(unless (assq x m) (push x res)))
(nreverse res)))
(defun cconv--map-diff (m1 m2)
"Return the submap of map M1 that has Dom(M2) removed."
(let ((res '()))
(dolist (x m1)
(unless (assq (car x) m2) (push x res)))
(nreverse res)))
(defun cconv--map-diff-elem (m x)
"Return the map M minus any mapping for X."
;; Here we assume that X appears at most once in M.
(let* ((b (assq x m))
(res (if b (remq b m) m)))
(assert (null (assq x res))) ;; Check the assumption was warranted.
res))
(defun cconv-closure-convert-rec
(form emvrs fvrs envs lmenvs)
(defun cconv--map-diff-set (m s)
"Return the map M minus any mapping for elements of S."
;; Here we assume that X appears at most once in M.
(let ((res '()))
(dolist (b m)
(unless (memq (car b) s) (push b res)))
(nreverse res)))
(defun cconv-closure-convert-rec (form emvrs fvrs envs lmenvs)
;; This function actually rewrites the tree.
"Eliminates all free variables of all lambdas in given forms.
Arguments:
-- FORM is a piece of Elisp code after macroexpansion.
-- LMENVS is a list of environments used for lambda-lifting. Initially empty.
-- LMENVS is a list of environments used for lambda-lifting. Initially empty.
-- EMVRS is a list that contains mutated variables that are visible
within current environment.
-- ENVS is an environment(list of free variables) of current closure.
......@@ -343,10 +389,9 @@ Returns a form where all lambdas don't have any free variables."
(setq lmenvs (remq old-lmenv lmenvs))
(push new-lmenv lmenvs)
(push `(,closedsym ,var) binders-new))))
;; we push the element after redefined free variables
;; are processes. this is important to avoid the bug
;; when free variable and the function have the same
;; name
;; We push the element after redefined free variables are
;; processed. This is important to avoid the bug when free
;; variable and the function have the same name.
(push (list var new-val) binders-new)
(when (eq letsym 'let*) ; update fvrs
......@@ -355,11 +400,7 @@ Returns a form where all lambdas don't have any free variables."
(when emvr-push
(push emvr-push emvrs)
(setq emvr-push nil))
(let (lmenvs-1) ; remove var from lmenvs if redefined
(dolist (iter lmenvs)
(when (not (assq var lmenvs))
(push iter lmenvs-1)))
(setq lmenvs lmenvs-1))
(setq lmenvs (cconv--map-diff-elem lmenvs var))
(when lmenv-push
(push lmenv-push lmenvs)
(setq lmenv-push nil)))
......@@ -368,19 +409,10 @@ Returns a form where all lambdas don't have any free variables."
(let (var fvrs-1 emvrs-1 lmenvs-1)
;; Here we update emvrs, fvrs and lmenvs lists
(dolist (vr fvrs)
; safely remove
(when (not (assq vr binders-new)) (push vr fvrs-1)))
(setq fvrs fvrs-1)
(dolist (vr emvrs)
; safely remove
(when (not (assq vr binders-new)) (push vr emvrs-1)))
(setq emvrs emvrs-1)
; push new
(setq fvrs (cconv--set-diff-map fvrs binders-new))
(setq emvrs (cconv--set-diff-map emvrs binders-new))
(setq emvrs (append emvrs emvrs-new))
(dolist (vr lmenvs)
(when (not (assq (car vr) binders-new))
(push vr lmenvs-1)))
(setq lmenvs (cconv--set-diff-map lmenvs binders-new))
(setq lmenvs (append lmenvs lmenvs-new)))
;; Here we do the same letbinding as for let* above
......@@ -402,9 +434,9 @@ Returns a form where all lambdas don't have any free variables."
(symbol-name var))))
(setq new-lmenv (list (car lmenv)))
(dolist (frv (cdr lmenv)) (if (eq frv var)
(push closedsym new-lmenv)
(push frv new-lmenv)))
(dolist (frv (cdr lmenv))
(push (if (eq frv var) closedsym frv)
new-lmenv))
(setq new-lmenv (reverse new-lmenv))
(setq lmenvs (remq lmenv lmenvs))
(push new-lmenv lmenvs)
......@@ -449,13 +481,9 @@ Returns a form where all lambdas don't have any free variables."
(`(quote . ,_) form) ; quote form
(`(function . ((lambda ,vars . ,body-forms))) ; function form
(let (fvrs-new) ; we remove vars from fvrs
(dolist (elm fvrs) ;i use such a tricky way to avoid side effects
(when (not (memq elm vars))
(push elm fvrs-new)))
(setq fvrs fvrs-new))
(let* ((fv (delete-dups (cconv-freevars form '())))
(leave fvrs) ; leave = non nil if we should leave env unchanged
(let* ((fvrs-new (cconv--set-diff fvrs vars)) ; Remove vars from fvrs.
(fv (delete-dups (cconv-freevars form '())))
(leave fvrs-new) ; leave=non-nil if we should leave env unchanged.
(body-forms-new '())
(letbind '())
(mv nil)
......@@ -470,7 +498,7 @@ Returns a form where all lambdas don't have any free variables."
(if (eq (length envs) (length fv))
(let ((fv-temp fv))
(while (and fv-temp leave)
(when (not (memq (car fv-temp) fvrs)) (setq leave nil))
(when (not (memq (car fv-temp) fvrs-new)) (setq leave nil))
(setq fv-temp (cdr fv-temp))))
(setq leave nil))
......@@ -479,23 +507,30 @@ Returns a form where all lambdas don't have any free variables."
(dolist (elm fv)
(push
(cconv-closure-convert-rec
;; Remove `elm' from `emvrs' for this call because in case
;; `elm' is a variable that's wrapped in a cons-cell, we
;; want to put the cons-cell itself in the closure, rather
;; than just a copy of its current content.
elm (remq elm emvrs) fvrs envs lmenvs)
envector)) ; process vars for closure vector
envector)) ; Process vars for closure vector.
(setq envector (reverse envector))
(setq envs fv))
(setq envector `(env))) ; leave unchanged
(setq fvrs fv)) ; update substitution list
;; the difference between envs and fvrs is explained
;; in comment in the beginning of the function
(dolist (elm cconv-captured+mutated) ; find mutated arguments
(setq mv (car elm)) ; used in inner closures
(setq envector `(,cconv--env-var))) ; Leave unchanged.
(setq fvrs-new fv)) ; Update substitution list.
(setq emvrs (cconv--set-diff emvrs vars))
(setq lmenvs (cconv--map-diff-set lmenvs vars))
;; The difference between envs and fvrs is explained
;; in comment in the beginning of the function.
(dolist (elm cconv-captured+mutated) ; Find mutated arguments
(setq mv (car elm)) ; used in inner closures.
(when (and (memq mv vars) (eq form (caddr elm)))
(progn (push mv emvrs)
(push `(,mv (list ,mv)) letbind))))
(dolist (elm body-forms) ; convert function body
(push (cconv-closure-convert-rec
elm emvrs fvrs envs lmenvs)
elm emvrs fvrs-new envs lmenvs)
body-forms-new))
(setq body-forms-new
......@@ -509,12 +544,12 @@ Returns a form where all lambdas don't have any free variables."
; 1 free variable - do not build vector
((null (cdr envector))
`(curry
(function (lambda (env . ,vars) . ,body-forms-new))
(function (lambda (,cconv--env-var . ,vars) . ,body-forms-new))
,(car envector)))
; >=2 free variables - build vector
(t
`(curry
(function (lambda (env . ,vars) . ,body-forms-new))
(function (lambda (,cconv--env-var . ,vars) . ,body-forms-new))
(vector . ,envector))))))
(`(function . ,_) form) ; same as quote
......@@ -674,13 +709,10 @@ Returns a form where all lambdas don't have any free variables."
(let ((free (memq form fvrs)))
(if free ;form is a free variable
(let* ((numero (- (length fvrs) (length free)))
(var '()))
(assert numero)
(if (null (cdr envs))
(setq var 'env)
;replace form =>
;(aref env #)
(setq var `(aref env ,numero)))
(var (if (null (cdr envs))
cconv--env-var
;; Replace form => (aref env #)
`(aref ,cconv--env-var ,numero))))
(if (memq form emvrs) ; form => (car (aref env #)) if mutable