From 47d67b006293a3cdec7e0572200f9221f147b2c8 Mon Sep 17 00:00:00 2001 From: "Clinton N. Dreisbach" Date: Wed, 8 Jan 2014 22:54:49 -0500 Subject: [PATCH] Added loop/recur macro for tail-call optimization --- docs/contrib/index.rst | 1 + docs/contrib/loop.rst | 56 +++++++++++++++++++++ hy/contrib/loop.hy | 79 ++++++++++++++++++++++++++++++ tests/__init__.py | 1 + tests/native_tests/contrib/loop.hy | 46 +++++++++++++++++ 5 files changed, 183 insertions(+) create mode 100644 docs/contrib/loop.rst create mode 100644 hy/contrib/loop.hy create mode 100644 tests/native_tests/contrib/loop.hy diff --git a/docs/contrib/index.rst b/docs/contrib/index.rst index 80b7697..ba0e3a4 100644 --- a/docs/contrib/index.rst +++ b/docs/contrib/index.rst @@ -8,3 +8,4 @@ Contents: :maxdepth: 3 anaphoric + loop diff --git a/docs/contrib/loop.rst b/docs/contrib/loop.rst new file mode 100644 index 0000000..9c2c859 --- /dev/null +++ b/docs/contrib/loop.rst @@ -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) diff --git a/hy/contrib/loop.hy b/hy/contrib/loop.hy new file mode 100644 index 0000000..73526fa --- /dev/null +++ b/hy/contrib/loop.hy @@ -0,0 +1,79 @@ +;;; Hy tail-call optimization +;; +;; Copyright (c) 2014 Clinton Dreisbach +;; +;; 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))))) diff --git a/tests/__init__.py b/tests/__init__.py index ab4036b..5508950 100644 --- a/tests/__init__.py +++ b/tests/__init__.py @@ -14,4 +14,5 @@ from .native_tests.core import * # noqa from .native_tests.reader_macros import * # noqa from .native_tests.with_test import * # noqa from .native_tests.contrib.anaphoric import * # noqa +from .native_tests.contrib.loop import * # noqa from .contrib.test_meth import * # noqa diff --git a/tests/native_tests/contrib/loop.hy b/tests/native_tests/contrib/loop.hy new file mode 100644 index 0000000..520b840 --- /dev/null +++ b/tests/native_tests/contrib/loop.hy @@ -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))))