Added loop/recur macro for tail-call optimization

This commit is contained in:
Clinton N. Dreisbach 2014-01-08 22:54:49 -05:00
parent 5fc047e77c
commit 47d67b0062
5 changed files with 183 additions and 0 deletions

View File

@ -8,3 +8,4 @@ Contents:
:maxdepth: 3 :maxdepth: 3
anaphoric anaphoric
loop

56
docs/contrib/loop.rst Normal file
View File

@ -0,0 +1,56 @@
==========
loop/recur
==========
.. versionadded:: 0.9.13
The loop/recur macro gives programmers a simple way to use tail-call
optimization (TCO) in their Hy code.
A tail call is a subroutine call that happens inside another
procedure as its final action; it may produce a return value which
is then immediately returned by the calling procedure. If any call
that a subroutine performs, such that it might eventually lead to
this same subroutine being called again down the call chain, is in
tail position, such a subroutine is said to be tail-recursive,
which is a special case of recursion. Tail calls are significant
because they can be implemented without adding a new stack frame
to the call stack. Most of the frame of the current procedure is
not needed any more, and it can be replaced by the frame of the
tail call. The program can then jump to the called
subroutine. Producing such code instead of a standard call
sequence is called tail call elimination, or tail call
optimization. Tail call elimination allows procedure calls in tail
position to be implemented as efficiently as goto statements, thus
allowing efficient structured programming.
-- Wikipedia (http://en.wikipedia.org/wiki/Tail_call)
Macros
======
.. _loop:
loop
-----
``loop`` establishes a recursion point. With ``loop``, ``recur``
rebinds the variables set in the recursion point and sends code
execution back to that recursion point. If ``recur`` is used in a
non-tail position, an exception is thrown.
Usage: `(loop bindings &rest body)`
Example:
.. code-block:: clojure
(require hy.contrib.loop)
(defn factorial [n]
(loop [[i n] [acc 1]]
(if (zero? i)
acc
(recur (dec i) (* acc i)))))
(factorial 1000)

79
hy/contrib/loop.hy Normal file
View File

@ -0,0 +1,79 @@
;;; Hy tail-call optimization
;;
;; Copyright (c) 2014 Clinton Dreisbach <clinton@dreisbach.us>
;;
;; Permission is hereby granted, free of charge, to any person obtaining a
;; copy of this software and associated documentation files (the "Software"),
;; to deal in the Software without restriction, including without limitation
;; the rights to use, copy, modify, merge, publish, distribute, sublicense,
;; and/or sell copies of the Software, and to permit persons to whom the
;; Software is furnished to do so, subject to the following conditions:
;;
;; The above copyright notice and this permission notice shall be included in
;; all copies or substantial portions of the Software.
;;
;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
;; THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;; DEALINGS IN THE SOFTWARE.
;;
;;; The loop/recur macro allows you to construct functions that use tail-call
;;; optimization to allow arbitrary levels of recursion.
(defn --trampoline-- [f]
"Wrap f function and make it tail-call optimized."
;; Takes the function "f" and returns a wrapper that may be used for tail-
;; recursive algorithms. Note that the returned function is not side-effect
;; free and should not be called from anywhere else during tail recursion.
(setv result None)
;; We have to put this in a list because of Python's
;; weirdness around local variables.
;; Assigning directly to it later would cause it to
;; shadow in a new scope.
(setv active [False])
(setv accumulated [])
(fn [&rest args]
(.append accumulated args)
(when (not (first active))
(assoc active 0 True)
(while (> (len accumulated) 0)
(setv result (apply f (.pop accumulated))))
(assoc active 0 False)
result)))
(defn recursive-replace [old-term new-term body]
"Recurses through lists of lists looking for old-term and replacing it with new-term."
((type body)
(list-comp (cond
[(= term old-term) new-term]
[(instance? hy.HyList term)
(recursive-replace old-term new-term term)]
[True term]) [term body])))
(defmacro loop [bindings &rest body]
;; Use inside functions like so:
;; (defun factorial [n]
;; (loop [[i n]
;; [acc 1]]
;; (if (= i 0)
;; acc
;; (recur (dec i) (* acc i)))))
;;
;; If recur is used in a non-tail-call position, None is returned, which
;; causes chaos. Fixing this to detect if recur is in a tail-call position
;; and erroring if not is a giant TODO.
(with-gensyms [recur-fn]
(let [[fnargs (map (fn [x] (first x)) bindings)]
[initargs (map second bindings)]
[new-body (recursive-replace 'recur recur-fn body)]]
`(do
(import [hy.contrib.loop [--trampoline--]])
(def ~recur-fn
(--trampoline-- (fn [~@fnargs]
~@new-body)))
(~recur-fn ~@initargs)))))

View File

@ -14,4 +14,5 @@ from .native_tests.core import * # noqa
from .native_tests.reader_macros import * # noqa from .native_tests.reader_macros import * # noqa
from .native_tests.with_test import * # noqa from .native_tests.with_test import * # noqa
from .native_tests.contrib.anaphoric import * # noqa from .native_tests.contrib.anaphoric import * # noqa
from .native_tests.contrib.loop import * # noqa
from .contrib.test_meth import * # noqa from .contrib.test_meth import * # noqa

View File

@ -0,0 +1,46 @@
(require hy.contrib.loop)
(import sys)
(defn tco-sum [x y]
(loop [[x x] [y y]]
(cond
[(> y 0) (recur (inc x) (dec y))]
[(< y 0) (recur (dec x) (inc y))]
[True x])))
(defn non-tco-sum [x y]
(cond
[(> y 0) (inc (non-tco-sum x (dec y)))]
[(< y 0) (dec (non-tco-sum x (inc y)))]
[True x]))
(defn test-loop []
;; non-tco-sum should fail
(try
(setv n (non-tco-sum 100 10000))
(catch [e RuntimeError]
(assert true))
(else
(assert false)))
;; tco-sum should not fail
(try
(setv n (tco-sum 100 10000))
(catch [e RuntimeError]
(assert false))
(else
(assert (= n 10100)))))
(defn test-recur-in-wrong-loc []
(defn bad-recur [n]
(loop [[i n]]
(if (= i 0)
0
(inc (recur (dec i))))))
(try
(bad-recur 3)
(catch [e TypeError]
(assert true))
(else
(assert false))))