Function: cl--self-tco

cl--self-tco is a byte-compiled function defined in cl-macs.el.gz.

Signature

(cl--self-tco VAR FARGS BODY)

Source Code

;; Defined in /usr/src/emacs/lisp/emacs-lisp/cl-macs.el.gz
(defun cl--self-tco (var fargs body)
  ;; This tries to "optimize" tail calls for the specific case
  ;; of recursive self-calls by replacing them with a `while' loop.
  ;; It is quite far from a general tail-call optimization, since it doesn't
  ;; even handle mutually recursive functions.
  (letrec
      ((done nil) ;; Non-nil if some TCO happened.
       ;; This var always holds the value nil until (just before) we
       ;; exit the loop.
       (retvar (make-symbol "retval"))
       (ofargs (mapcar (lambda (s) (if (memq s cl--lambda-list-keywords) s
                                (make-symbol (symbol-name s))))
                       fargs))
       (opt-exps (lambda (exps) ;; `exps' is in tail position!
                   (append (butlast exps)
                           (list (funcall opt (car (last exps)))))))
       (opt
        (lambda (exp) ;; `exp' is in tail position!
          (pcase exp
            ;; FIXME: Optimize `apply'?
            (`(funcall ,(pred (eq var)) . ,aargs)
             ;; This is a self-recursive call in tail position.
             (let ((sets nil)
                   (fargs ofargs))
               (while fargs
                 (pcase (pop fargs)
                   ('&rest
                    (push (pop fargs) sets)
                    (push `(list . ,aargs) sets)
                    ;; (cl-assert (null fargs))
                    )
                   ('&optional nil)
                   (farg
                    (push farg sets)
                    (push (pop aargs) sets))))
               (setq done t)
               `(progn (setq . ,(nreverse sets))
                       :recurse)))
            (`(progn . ,exps) `(progn . ,(funcall opt-exps exps)))
            (`(if ,cond ,then . ,else)
             `(if ,cond ,(funcall opt then) . ,(funcall opt-exps else)))
            (`(and  . ,exps) `(and . ,(funcall opt-exps exps)))
            (`(or ,arg) (funcall opt arg))
            (`(or ,arg . ,args)
             (let ((val (make-symbol "val")))
               `(let ((,val ,arg))
                  (if ,val ,(funcall opt val) ,(funcall opt `(or . ,args))))))
            (`(cond . ,conds)
             (let ((cs '()))
               (while conds
                 (pcase (pop conds)
                   (`(,exp)
                    (push (if conds
                              ;; This returns the value of `exp' but it's
                              ;; only in tail position if it's the
                              ;; last condition.
                              ;; Note: This may set the var before we
                              ;; actually exit the loop, but luckily it's
                              ;; only the case if we set the var to nil,
                              ;; so it does preserve the invariant that
                              ;; the var is nil until we exit the loop.
                              `((setq ,retvar ,exp) nil)
                            `(,(funcall opt exp)))
                          cs))
                   (exps
                    (push (funcall opt-exps exps) cs))))
               ;; No need to set `retvar' to return nil.
               `(cond . ,(nreverse cs))))
            ((and `(,(or 'let 'let*) ,bindings . ,exps)
                  (guard
                   ;; Note: it's OK for this `let' to shadow any
                   ;; of the formal arguments since we will only
                   ;; setq the fresh new `ofargs' vars instead ;-)
                   (let ((shadowings
                          (mapcar (lambda (b) (if (consp b) (car b) b)) bindings)))
                     (and
                      ;; If `var' is shadowed, then it clearly can't be
                      ;; tail-called any more.
                      (not (memq var shadowings))
                      ;; If any of the new bindings is a dynamic
                      ;; variable, the body is not in tail position.
                      (not (delq nil (mapcar #'macroexp--dynamic-variable-p
                                             shadowings)))))))
             `(,(car exp) ,bindings . ,(funcall opt-exps exps)))
            ((and `(condition-case ,err-var ,bodyform . ,handlers)
                  (guard (not (eq err-var var))))
             `(condition-case ,err-var
                  ,(if (assq :success handlers)
                       bodyform
                     `(progn (setq ,retvar ,bodyform) nil))
                . ,(mapcar (lambda (h)
                             (cons (car h) (funcall opt-exps (cdr h))))
                           handlers)))
            ('nil nil)  ;No need to set `retvar' to return nil.
            (_ `(progn (setq ,retvar ,exp) nil))))))

    (let ((optimized-body (funcall opt-exps body)))
      (if (not done)
          (cons fargs body)
        ;; We use two sets of vars: `ofargs' and `fargs' because we need
        ;; to be careful that if a closure captures a formal argument
        ;; in one iteration, it needs to capture a different binding
        ;; then that of other iterations, e.g.
        (cons
         ofargs
         `((let (,retvar)
             (while (let ,(delq nil
                                (cl-mapcar
                                 (lambda (a oa)
                                   (unless (memq a cl--lambda-list-keywords)
                                     (list a oa)))
                                 fargs ofargs))
                      . ,optimized-body))
             ,retvar)))))))