带有延续的单声道 F# StackOverflow（启用尾调用消除）

Question

我正在运行一个使用 Continuations 制作的解释器示例，尽管启用了尾调用优化，但它在 Mono JIT 编译器版本 4.3.0 中失败并出现 stackoverflow 错误。相同的代码在 Windows (.NET 4.6) 中运行良好。

这是代码：

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

我发现这是 MONO 的一个问题，但我想知道是否有办法解决这个问题（我希望做 CSP 来为解释器实现几个功能）

同样值得注意的是，在 windows 上禁用尾调用优化会比在 mono/osx 上更快地触发 stackoverflow 错误。

Answer 1

我使用蹦床重新实现了coEval2。这个函数我巧妙地称为coEval3。 coEval2 在Debug 中为我崩溃，并按预期在Release 中工作。 coEval3 似乎在 Debug 和 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))

希望这有点用处