Tail-recursion and mutual recursion macros

tail-recur.lisp

;; A couple of silly macros for a language that has defmacro but no tail-recursion

;; the mutual recursion macro is even worse, because you can only really 'call' one of the functions

(defmacro recur (arg-pairs &body body)
  (let ((arg-names (mapcar #'car arg-pairs))  ;; extract loop variable names
        (arg-vals (mapcar #'cadr arg-pairs))) ;; extract start values

    ;; block to return from
    `(block nil
       (let (,@(loop for name in arg-names collect `(,(symb 'next- name) '()))) 
         ((lambda ,arg-names                     
            (macrolet ((tail-recur (&rest new-arg-values) 
                         `(recur-with-new-values recur ,new-arg-values)))
              (TAGBODY  
               recur
                 ,@body)))
          ,@arg-vals))))))  


;; make sure variables are set for the next loop
;; then jump back to the beginning of the function body
(defmacro recur-with-new-values (func-name arg-pairs)
  `(progn
     
     ;; set next loop variables
     ,@(loop for pair in arg-pairs collect `(setf ,(symb 'next- (car pair))
                                                  ,(cadr pair)))
     ;; set real loop var bindings to 'next'-bindings
     ,@(loop for pair in arg-pairs collect `(setf ,(car pair)
                                                  ,(symb 'next- (car pair))))
     (go ,func-name)))


(defun mkstr (&rest args)
  (with-output-to-string (s)
    (dolist (a args) (princ a s))))

(defun symb (&rest args)
  (values (intern (apply #'mkstr args))))

;; fibonacci using recur
(defun fibonacci (n)
  (recur ((a 0) (b 1) (count n))
    (if (<= count 0)
        (return a) ;;a->b  b->(+ a b) count -> (1- count) 
        (tail-recur (a b) (b (+ a b)) (count (1- count))))))

(fibonacci 0)
=> 0
(fibonacci 1)
=> 1
(fibonacci 2)
=> 1
(fibonacci 3)
=> 2



(defmacro mutual-recur (args &rest functions)
  (let* ((func-names (mapcar (lambda (x) (car x)) functions))
         (bodies (mapcar #'cadr functions))
         (tag-sets (let ((res '()))
                     (loop for name in func-names for body in bodies do
                                   (progn (push name res)
                                          (push body res)))
                     (nreverse res)))
         (macrojumps (loop for name in func-names collect (list name '(&rest new-arg-values)
                                                                ``(recur-with-new-values ,',name ,new-arg-values)))))
    `(block nil (macrolet (,@macrojumps)
                  (let (,@(loop for arg in args collect `(,(symb 'next- arg) '())))
                    (tagbody ,@tag-sets))))))


(defun even (n)
  (mutual-recur (n)                                  ;; n -> (abs (1- n))
                (even (if (= n 0) (return t) (not (odd (n (abs (1- n)))))))
                                                  ;; n -> (abs (1- n))
                (odd (if (= n 0) (return nil) (even (n (abs (1- n))))))))

(even 1)
=> nil
(even 2)
=> t


;; Updated version of recur that supports optional inline type declarations
;; requires the defstar package https://bitbucket.org/eeeickythump/defstar

(defmacro recur ((&rest arg-pairs) &body body)
  (let ((arg-names (mapcar #'first arg-pairs)) ;; extract loop
        ;; variable names
        (arg-types (loop for item in arg-pairs collect (if (= 3 (length item))
                                                               (second item) (member t nil))))
        (arg-vals (loop for item in arg-pairs collect (if (= 3 (length item))
                                                              (third item) (second item))))) ;; extract start values
    ;; block to return from
    `(block nil
       (*let (,@(loop for name in arg-names
                     for val in arg-vals
                   for type in arg-types collect `(,(symb 'next- name) ,@(if type (list type) '()) ,val))
             (ret-val '()))
         ((lambda ,arg-names
            (macrolet ((tail-recur (&rest new-arg-values)
                         (let ((new-arg-values 
                                (loop for set in new-arg-values collect
                                     (if (= 3 (length set))
                                         (if (eql '-> (second set))
                                             `(,(first set) ,(second set))
                                             (error "Unknown symbol: ~a" (second set)))
                                         set))))
                                `(recur-with-new-values recur ,new-arg-values)))
                       (exit (&optional return-value)
                         (if return-value
                             `(progn
                                (setf ret-val ,return-value)
                                (go exit))
                             `(go exit))))
              (TAGBODY
               recur
                 ,@body
               exit '())))
          ,@arg-vals)
         ret-val))))


;; without type declarations
(defun fibonacci (n)
  (recur ((a 0) (b 1) (count n))
    (if (<= count 0)
        (exit a) ;;a->b b->(+ a b) count -> (1- count)
        (tail-recur (a b) (b (+ a b)) (count (1- count))))))



;;  Though the version without type declarations is tail-recursive,
;;  and a tail-recursive fibonacci is typically O(n) in time complexity, 
;;  this version is not, because bignum arithmetic is not O(1) but typically log(n)

;;  this next version fixes that
(defun fibonacci% (n)
  (declare (optimize (speed 3) (safety 0) (debug 0)))
  (recur ((a fixnum 0) (b fixnum 1) (count fixnum n))
    (if (<= count 0)
        (exit a)
        (tail-recur (a b) (b (+ a b)) (count (1- count))))))

;; now we have a O(n) time fibonacci

(time (fibonacci 1234567))
-> 20.865 seconds of real time

(time (fibonacci% 1234567))
-> .120 seconds of real time

(dotimes (i 20000) (fibonacci% 1234567))
-> 23.9 seconds of real time

;;  The performance difference slowly gets larger as the numbers get larger (because bignum arithmetic grows logarithmically with size),
;;  but the typed version overflows rather quickly either way.

(fibonacci% 90)
-> 2880067194370816120
(fibonacci% 91)
-> -4563325426479245499