Automatically translate continuations into thunks and trampolines

[mailund]

To avoid actually recursing when we write tail-recursive functions, we sometimes need continuation-passing-style functions. For those, we end up creating continuations that recurse too deeply. We can fix this with "thunks and trampolines".

Can we automatically, perhaps with some help provided to the transformation function, translate something like this:

make_left_cont <- function(tree, cont) {
    force(tree) ; force(cont)
    function(new_tree) {
        cont(rbt_set_balance(
            RBT_SET(
                tree$col,
                tree$val,
                new_tree,
                tree$right
            )))
    }
}
make_right_cont <- function(tree, cont) {
    force(tree) ; force(cont)
    function(new_tree) {
        cont(rbt_set_balance(
            RBT_SET(
                tree$col,
                tree$val,
                tree$left,
                new_tree
            )))
    }
}

rbt_set_insert_tr_ <- function(tree, elm, cont) {
    if (is_red_black_set_empty(tree)) {
        return(
            cont(RBT_SET(RBT_RED, 
                         elm, 
                         RBT_SET_EMPTY, 
                         RBT_SET_EMPTY)))
    }

    if (elm < tree$val) {
        rbt_set_insert_tr_(
            tree$left,
            elm, 
            make_left_cont(tree, cont)
        )
        
    } else if (elm > tree$val) {
        rbt_set_insert_tr_(
            tree$right,
            elm,
            make_right_cont(tree, cont)
        )
        
    } else {
		cont(tree)
    }
}

into this:

make_thunk <- function(f, ...) {
    force(f)
    params <- list(...)
    function() do.call(f, params)
}
trampoline <- function(thunk) {
    while (is.function(thunk)) thunk <- thunk()
    thunk
}

make_left_cont <- function(tree, cont) {
    force(tree) ; force(cont)
    function(new_tree) {
        make_thunk(
            cont,
            rbt_set_balance(RBT_SET(
                tree$col, 
                tree$val,
                new_tree,
                tree$right
            ))
        )
    }
}
make_right_cont <- function(tree, cont) {
    force(tree) ; force(cont)
    function(new_tree) {
        make_thunk(
            cont,
            rbt_set_balance(RBT_SET(
                tree$col,
                tree$val,
                tree$left,
                new_tree
            ))
        )
    }
}

rbt_set_insert_tr_ <- function(tree, elm, cont) {
    if (is_red_black_set_empty(tree)) {
        return(
            trampoline(cont(RBT_SET(
                RBT_RED, 
                elm,
                RBT_SET_EMPTY,
                RBT_SET_EMPTY
            )))
        )
    }

    if (elm < tree$val) {
        rbt_set_insert_tr_(
            tree$left,
            elm,
            make_left_cont(tree, cont)
        )
        
    } else if (elm > tree$val) {
        rbt_set_insert_tr_(
            tree$right,
            elm,
            make_right_cont(tree, cont)
        )
    } else {
        trampoline(cont(tree))
    }
}
rbt_set_insert_tr_ <- tailr::loop_transform(rbt_set_insert_tr_)

rbt_set_insert_tr <- function(tree, elm) {
    tree <- rbt_set_insert_tr_(tree, elm, cont = identity)
    tree$col <- RBT_BLACK
    tree
}