F# StackOverflow in mono with continuations (tail call eliminations enabled)

Question

I was running a example of an interpreter made with Continuations, and it fails in Mono JIT compiler version 4.3.0 with a stackoverflow error despite the Tail Call optimization enabled. The same code works fine in Windows (.NET 4.6).

This is the code:

open System
open System.Runtime

let print x = printfn "%A" x

type 'data env = (string * 'data) list

let rec lookup env x = 
    match env with 
    | []         -> failwith (x + " not found")
    | (y, v)::yr -> if x=y then v else lookup yr x

(* Abstract syntax of functional language with exceptions *)

type exn = 
  | Exn of string

type expr = 
  | CstI of int
  | CstB of bool
  | Var of string
  | Let of string * expr * expr
  | Prim of string * expr * expr
  | If of expr * expr * expr 
  | Letfun of string * string * expr * expr        (* (f, x, fbody, ebody) *)
  | Call of string * expr
  | Raise of exn
  | TryWith of expr * exn * expr                    (* try e1 with exn -> e2 *)

type value = 
  | Int of int
  | Closure of string * string * expr * value env  (* (f, x, fBody, fDeclEnv) *)

type answer = 
  | Result of int
  | Abort of string


let rec coEval2 (e : expr) (env : value env) (cont : int -> answer)
                (econt : exn -> answer) : answer =
    match e with
    | CstI i -> cont i
    | CstB b -> cont (if b then 1 else 0)
    | Var x  -> 
      match lookup env x with
      | Int i -> cont i 
      | _     -> Abort "coEval2 Var"
    | Prim(ope, e1, e2) -> 
      coEval2 e1 env 
        (fun i1 ->
         coEval2 e2 env 
           (fun i2 ->
            match ope with
            | "*" -> cont(i1 * i2)
            | "+" -> cont(i1 + i2)
            | "-" -> cont(i1 - i2)
            | "=" -> cont(if i1 = i2 then 1 else 0)
            | "<" -> cont(if i1 < i2 then 1 else 0)
            | _   -> Abort "unknown primitive") econt) econt
    | Let(x, eRhs, letBody) -> 
      coEval2 eRhs env (fun xVal -> 
                        let bodyEnv = (x, Int xVal) :: env 
                        coEval2 letBody bodyEnv cont econt)
                       econt
    | If(e1, e2, e3) -> 
      coEval2 e1 env (fun b ->
                      if b<>0 then coEval2 e2 env cont econt
                              else coEval2 e3 env cont econt) econt
    | Letfun(f, x, fBody, letBody) -> 
      let bodyEnv = (f, Closure(f, x, fBody, env)) :: env 
      coEval2 letBody bodyEnv cont econt
    | Call(f, eArg) -> 
      let fClosure = lookup env f
      match fClosure with
       | Closure (f, x, fBody, fDeclEnv) ->
         coEval2 eArg env  
           (fun xVal ->
            let fBodyEnv = (x, Int xVal) :: (f, fClosure) :: fDeclEnv
            coEval2 fBody fBodyEnv cont econt)
           econt
       | _ -> raise (Failure "eval Call: not a function")
    | Raise exn -> econt exn
    | TryWith (e1, exn, e2) -> 
      let econt1 thrown =
          if thrown = exn then coEval2 e2 env cont econt
                          else econt thrown
      coEval2 e1 env cont econt1

    (* The top-level error continuation returns the continuation, 
       adding the text Uncaught exception *)

let eval2 e env = 
    coEval2 e env 
        (fun v -> Result v) 
        (fun (Exn s) -> Abort ("Uncaught exception: " + s))

let run2 e = eval2 e []


(* Example: deep recursion to check for constant-space tail recursion *)

let exdeep = Letfun("deep", "x", 
                    If(Prim("=", Var "x", CstI 0),
                       CstI 1,
                       Call("deep", Prim("-", Var "x", CstI 1))),
                    Call("deep", Var "n"));

let rundeep n = eval2 exdeep [("n", Int n)];

[<EntryPoint>]
let main argv = 
    rundeep 10000 |> ignore
    "All fine!" |> print

    0

I found that this is a problem with MONO but I wonder if there exists a way to work around this (I wish to do CSP to implement several features for the interpreter)

It is also notable that disabling the tail call optimization triggers the stackoverflow error way faster on windows than on mono/osx.

Answer 1

I reimplemented coEval2 using a trampoline. This function I cleverly called coEval3 . coEval2 crashes for me in Debug and works in Release as expected. coEval3 seemed to work for me in both Debug and Release .

// After "jumping" the trampoline we either have a result (Done)
//  or we need to "jump" again (Next)
type result<'T> =
  | Done    of  'T
  | Next    of  (unit -> result<'T>)

let coEval3 (e : expr) (env : value env) (cont : int -> answer) (econt : exn -> answer) : answer =
  // "Jumps" once producing either a result or a new "jump"
  let rec jump (e : expr) (env : value env) (cont : int -> result<answer>) (econt : exn -> result<answer>) () : result<answer> =
    match e with
    | CstI i -> cont i
    | CstB b -> cont (if b then 1 else 0)
    | Var x  -> 
      match lookup env x with
      | Int i -> cont i
      | _     -> Abort "coEval2 Var" |> Done
    | Prim(ope, e1, e2) -> 
      jump e1 env 
        (fun i1 ->
          jump e2 env 
            (fun i2 ->
            match ope with
            | "*" -> cont(i1 * i2)
            | "+" -> cont(i1 + i2)
            | "-" -> cont(i1 - i2)
            | "=" -> cont(if i1 = i2 then 1 else 0)
            | "<" -> cont(if i1 < i2 then 1 else 0)
            | _   -> Abort "unknown primitive" |> Done) econt |> Next) econt |> Next
    | Let(x, eRhs, letBody) -> 
      jump eRhs env (fun xVal -> 
                        let bodyEnv = (x, Int xVal) :: env 
                        jump letBody bodyEnv cont econt |> Next)
                        econt |> Next
    | If(e1, e2, e3) -> 
      jump e1 env (fun b ->
                      if b<>0 then jump e2 env cont econt |> Next
                              else jump e3 env cont econt |> Next) econt |> Next
    | Letfun(f, x, fBody, letBody) -> 
      let bodyEnv = (f, Closure(f, x, fBody, env)) :: env 
      jump letBody bodyEnv cont econt |> Next
    | Call(f, eArg) -> 
      let fClosure = lookup env f
      match fClosure with
        | Closure (f, x, fBody, fDeclEnv) ->
          jump eArg env  
            (fun xVal ->
            let fBodyEnv = (x, Int xVal) :: (f, fClosure) :: fDeclEnv
            jump fBody fBodyEnv cont econt |> Next)
            econt |> Next
        | _ -> raise (Failure "eval Call: not a function")
    | Raise exn -> econt exn
    | TryWith (e1, exn, e2) -> 
      let econt1 thrown =
          if thrown = exn then jump e2 env cont econt |> Next
                          else econt thrown
      jump e1 env cont econt1 |> Next

    (* The top-level error continuation returns the continuation, 
        adding the text Uncaught exception *)

  // If trampoline is tail-recursive F# will implement this as a loop, 
  //  this is important for us as this means that the recursion is essentially
  //  turned into a loop
  let rec trampoline j =
    match j () with
    | Done v -> v
    | Next jj -> trampoline jj

  let inline lift f v = f v |> Done

  trampoline (jump e env (lift cont) (lift econt))

Hope this is somewhat useful