1 people like it.

Staged Trampoline

Staged Trampoline.

 1: 
 2: 
 3: 
 4: 
 5: 
 6: 
 7: 
 8: 
 9: 
10: 
11: 
12: 
13: 
14: 
15: 
16: 
17: 
18: 
19: 
20: 
21: 
22: 
23: 
24: 
25: 
26: 
27: 
28: 
29: 
30: 
31: 
32: 
33: 
34: 
35: 
36: 
37: 
38: 
39: 
40: 
41: 
42: 
43: 
44: 
45: 
46: 
47: 
48: 
49: 
50: 
51: 
52: 
53: 
54: 
55: 
56: 
57: 
58: 
59: 
60: 
61: 
62: 
63: 
64: 
65: 
66: 
67: 
68: 
69: 
70: 
71: 
72: 
73: 
74: 
75: 
76: 
77: 
78: 
79: 
80: 
81: 
82: 
83: 
84: 
85: 
86: 
87: 
88: 
89: 
90: 
91: 
92: 
93: 
94: 
95: 
96: 
97: 

// Staged Trampoline
#r "packages/FSharp.Compiler.Service.1.3.1.0/lib/net45/FSharp.Compiler.Service.dll"
#r "packages/QuotationCompiler.0.0.7-alpha/lib/net45/QuotationCompiler.dll"
#r "bin/FSharpSnippets.dll"

open System
open QuotationCompiler
open Microsoft.FSharp.Quotations

let counter = ref 0
let rec generateVars (types : Type list) : Var list = 
    match types with 
    | [] -> []
    | t :: ts -> 
        incr counter
        let var = new Var(sprintf "__paramTemp_%d__" !counter, t)
        var :: generateVars ts

// <@ fun x -> (% <@ x @> ) @> ~ lambda (fun x -> x)
let lambda (f : Expr<'T> -> Expr<'R>) : Expr<'T -> 'R> =
    let [var] = generateVars [typeof<'T>]
    Expr.Cast<_>(Expr.Lambda(var,  f (Expr.Cast<_>(Expr.Var var))))

// <@ fun x y -> (% <@ x @> ... <@ y @> ) @> ~ lambda (fun x y -> x ... y )
let lambda2 (f : Expr<'T> -> Expr<'S> -> Expr<'R>) : Expr<'T -> 'S -> 'R> =
    let [var; var'] = generateVars [typeof<'T>; typeof<'S>]
    Expr.Cast<_>(Expr.Lambda(var, Expr.Lambda(var',  f (Expr.Cast<_>(Expr.Var var)) (Expr.Cast<_>(Expr.Var var')))))


module Cont = 
    // Basic type
    type Cont<'T, 'R> = (((Expr<'T> -> Expr<unit>) -> Expr<int> -> (Expr<int> -> Expr<unit>) -> Expr<'R>) -> int -> Expr<'R>) -> int -> Expr<'R>

    // helper functions
    let return' : Expr<'T> -> Cont<'T, 'R> =
        fun v k spc -> k (fun f pc upc -> 
                                <@ if %pc = spc then 
                                    (% f v)
                                   Unchecked.defaultof<'R> @>) (spc + 1)
    let do' = return'

    let bind : Cont<'T, 'R> -> (Expr<'T> -> Cont<'V, 'R>) -> Cont<'V, 'R> = 
        fun cont f k spc -> 
            <@ 
                let v = ref Unchecked.defaultof<'T>
                (% lambda (fun v -> cont (fun k' -> 
                                            f <@ !(%v) @> (fun k'' -> 
                                                            k (fun u pc upc -> 
                                                                    <@ (% k' (fun v' -> <@ %v := %v' @>) pc upc) |> ignore; 
                                                                       (% k'' u pc upc) @>))) spc)) v
            @>

    let setjmp : Cont<int, 'R> =
        fun k spc -> k (fun f pc upc -> 
                            <@ if %pc = spc then 
                                (% f pc)
                               Unchecked.defaultof<'R> @>) (spc + 1)

    let longjmp : Expr<int> -> Cont<unit, 'R> =
        fun jmp k spc -> k (fun f pc upc -> 
                                <@ if %pc = spc then 
                                    (% upc <@ %jmp - 1 @>)
                                    (% f <@ () @>)
                                   Unchecked.defaultof<'R> @>) (spc + 1)


    type ContBuilder() = 
        member self.Return v = return' v
        member self.Bind(cont, f) = bind cont f

    let cont = new ContBuilder()

    let compile : Cont<'T, 'T> -> Expr<'T> = 
        fun cont ->
            cont (fun k spc -> <@ let r = ref Unchecked.defaultof<'T>
                                  let pc = ref 0
                                  while !pc >= 0 && !pc < spc do
                                    (% lambda2 (fun r pc -> k (fun i -> <@ %r := %i @>) <@ !(%pc) @> (fun pc' -> <@ %pc := %pc' @>))) r pc |> ignore;
                                    incr pc
                                  !r @>) 0 

open Cont

// Example
let example () =
    cont {
        let! jmp = setjmp
        let! x = cont { return <@ 1 @> }
        let! _ = do' <@ printfn "x: %d" %x @>
        let! y = cont { return <@ 2 @> }
        let! _ = do' <@ printfn "y: %d" %y @>
        let! _ = longjmp jmp
        return <@ () @>
    }

let f = QuotationCompiler.ToFunc <| compile (example ())
f()
namespace System
namespace QuotationCompiler
namespace Microsoft
namespace Microsoft.FSharp
namespace Microsoft.FSharp.Quotations
val counter : int ref

Full name: Script.counter
Multiple items
val ref : value:'T -> 'T ref

Full name: Microsoft.FSharp.Core.Operators.ref

--------------------
type 'T ref = Ref<'T>

Full name: Microsoft.FSharp.Core.ref<_>
val generateVars : types:Type list -> Var list

Full name: Script.generateVars
val types : Type list
type Type =
  inherit MemberInfo
  member Assembly : Assembly
  member AssemblyQualifiedName : string
  member Attributes : TypeAttributes
  member BaseType : Type
  member ContainsGenericParameters : bool
  member DeclaringMethod : MethodBase
  member DeclaringType : Type
  member Equals : o:obj -> bool + 1 overload
  member FindInterfaces : filter:TypeFilter * filterCriteria:obj -> Type[]
  member FindMembers : memberType:MemberTypes * bindingAttr:BindingFlags * filter:MemberFilter * filterCriteria:obj -> MemberInfo[]
  ...

Full name: System.Type
type 'T list = List<'T>

Full name: Microsoft.FSharp.Collections.list<_>
Multiple items
type Var =
  interface IComparable
  new : name:string * typ:Type * ?isMutable:bool -> Var
  member IsMutable : bool
  member Name : string
  member Type : Type
  static member Global : name:string * typ:Type -> Var

Full name: Microsoft.FSharp.Quotations.Var

--------------------
new : name:string * typ:Type * ?isMutable:bool -> Var
val t : Type
val ts : Type list
val incr : cell:int ref -> unit

Full name: Microsoft.FSharp.Core.Operators.incr
val var : Var
val sprintf : format:Printf.StringFormat<'T> -> 'T

Full name: Microsoft.FSharp.Core.ExtraTopLevelOperators.sprintf
val lambda : f:(Expr<'T> -> Expr<'R>) -> Expr<('T -> 'R)>

Full name: Script.lambda
val f : (Expr<'T> -> Expr<'R>)
Multiple items
type Expr =
  override Equals : obj:obj -> bool
  member GetFreeVars : unit -> seq<Var>
  member Substitute : substitution:(Var -> Expr option) -> Expr
  member ToString : full:bool -> string
  member CustomAttributes : Expr list
  member Type : Type
  static member AddressOf : target:Expr -> Expr
  static member AddressSet : target:Expr * value:Expr -> Expr
  static member Application : functionExpr:Expr * argument:Expr -> Expr
  static member Applications : functionExpr:Expr * arguments:Expr list list -> Expr
  ...

Full name: Microsoft.FSharp.Quotations.Expr

--------------------
type Expr<'T> =
  inherit Expr
  member Raw : Expr

Full name: Microsoft.FSharp.Quotations.Expr<_>
val typeof<'T> : Type

Full name: Microsoft.FSharp.Core.Operators.typeof
static member Expr.Cast : source:Expr -> Expr<'T>
static member Expr.Lambda : parameter:Var * body:Expr -> Expr
static member Expr.Var : variable:Var -> Expr
val lambda2 : f:(Expr<'T> -> Expr<'S> -> Expr<'R>) -> Expr<('T -> 'S -> 'R)>

Full name: Script.lambda2
val f : (Expr<'T> -> Expr<'S> -> Expr<'R>)
val var' : Var
type Cont<'T,'R> = (((Expr<'T> -> Expr<unit>) -> Expr<int> -> (Expr<int> -> Expr<unit>) -> Expr<'R>) -> int -> Expr<'R>) -> int -> Expr<'R>

Full name: Script.Cont.Cont<_,_>
type unit = Unit

Full name: Microsoft.FSharp.Core.unit
Multiple items
val int : value:'T -> int (requires member op_Explicit)

Full name: Microsoft.FSharp.Core.Operators.int

--------------------
type int = int32

Full name: Microsoft.FSharp.Core.int

--------------------
type int<'Measure> = int

Full name: Microsoft.FSharp.Core.int<_>
val return' : v:Expr<'T> -> k:(((Expr<'T> -> Expr<unit>) -> Expr<int> -> (Expr<int> -> Expr<unit>) -> Expr<'R>) -> int -> Expr<'R>) -> spc:int -> Expr<'R>

Full name: Script.Cont.return'
val v : Expr<'T>
val k : (((Expr<'T> -> Expr<unit>) -> Expr<int> -> (Expr<int> -> Expr<unit>) -> Expr<'R>) -> int -> Expr<'R>)
val spc : int
val f : (Expr<'T> -> Expr<unit>)
val pc : Expr<int>
val upc : (Expr<int> -> Expr<unit>)
module Unchecked

from Microsoft.FSharp.Core.Operators
val defaultof<'T> : 'T

Full name: Microsoft.FSharp.Core.Operators.Unchecked.defaultof
val do' : (Expr<'a> -> (((Expr<'a> -> Expr<unit>) -> Expr<int> -> (Expr<int> -> Expr<unit>) -> Expr<'b>) -> int -> Expr<'b>) -> int -> Expr<'b>)

Full name: Script.Cont.do'
val bind : cont:Cont<'T,'R> -> f:(Expr<'T> -> Cont<'V,'R>) -> k:(((Expr<'V> -> Expr<unit>) -> Expr<int> -> (Expr<int> -> Expr<unit>) -> Expr<'R>) -> int -> Expr<'R>) -> spc:int -> Expr<'R>

Full name: Script.Cont.bind
val cont : Cont<'T,'R>
val f : (Expr<'T> -> Cont<'V,'R>)
val k : (((Expr<'V> -> Expr<unit>) -> Expr<int> -> (Expr<int> -> Expr<unit>) -> Expr<'R>) -> int -> Expr<'R>)
val v : 'T ref
val v : Expr<'T ref>
val k' : ((Expr<'T> -> Expr<unit>) -> Expr<int> -> (Expr<int> -> Expr<unit>) -> Expr<'R>)
val k'' : ((Expr<'V> -> Expr<unit>) -> Expr<int> -> (Expr<int> -> Expr<unit>) -> Expr<'R>)
val u : (Expr<'V> -> Expr<unit>)
val v' : Expr<'T>
val ignore : value:'T -> unit

Full name: Microsoft.FSharp.Core.Operators.ignore
val setjmp : k:(((Expr<int> -> Expr<unit>) -> Expr<int> -> (Expr<int> -> Expr<unit>) -> Expr<'R>) -> int -> Expr<'R>) -> spc:int -> Expr<'R>

Full name: Script.Cont.setjmp
val k : (((Expr<int> -> Expr<unit>) -> Expr<int> -> (Expr<int> -> Expr<unit>) -> Expr<'R>) -> int -> Expr<'R>)
val f : (Expr<int> -> Expr<unit>)
val longjmp : jmp:Expr<int> -> k:(((Expr<unit> -> Expr<unit>) -> Expr<int> -> (Expr<int> -> Expr<unit>) -> Expr<'R>) -> int -> Expr<'R>) -> spc:int -> Expr<'R>

Full name: Script.Cont.longjmp
val jmp : Expr<int>
val k : (((Expr<unit> -> Expr<unit>) -> Expr<int> -> (Expr<int> -> Expr<unit>) -> Expr<'R>) -> int -> Expr<'R>)
val f : (Expr<unit> -> Expr<unit>)
Multiple items
type ContBuilder =
  new : unit -> ContBuilder
  member Bind : cont:Cont<'a,'b> * f:(Expr<'a> -> Cont<'c,'b>) -> Cont<'c,'b>
  member Return : v:Expr<'d> -> ((((Expr<'d> -> Expr<unit>) -> Expr<int> -> (Expr<int> -> Expr<unit>) -> Expr<'e>) -> int -> Expr<'e>) -> int -> Expr<'e>)

Full name: Script.Cont.ContBuilder

--------------------
new : unit -> ContBuilder
val self : ContBuilder
member ContBuilder.Return : v:Expr<'d> -> ((((Expr<'d> -> Expr<unit>) -> Expr<int> -> (Expr<int> -> Expr<unit>) -> Expr<'e>) -> int -> Expr<'e>) -> int -> Expr<'e>)

Full name: Script.Cont.ContBuilder.Return
val v : Expr<'d>
member ContBuilder.Bind : cont:Cont<'a,'b> * f:(Expr<'a> -> Cont<'c,'b>) -> Cont<'c,'b>

Full name: Script.Cont.ContBuilder.Bind
val cont : Cont<'a,'b>
val f : (Expr<'a> -> Cont<'c,'b>)
val cont : ContBuilder

Full name: Script.Cont.cont
val compile : cont:Cont<'T,'T> -> Expr<'T>

Full name: Script.Cont.compile
val cont : Cont<'T,'T>
val k : ((Expr<'T> -> Expr<unit>) -> Expr<int> -> (Expr<int> -> Expr<unit>) -> Expr<'T>)
val r : 'T ref
val pc : int ref
val r : Expr<'T ref>
val pc : Expr<int ref>
val i : Expr<'T>
val pc' : Expr<int>
module Cont

from Script
val example : unit -> Cont<unit,'a>

Full name: Script.example
val x : Expr<int>
val printfn : format:Printf.TextWriterFormat<'T> -> 'T

Full name: Microsoft.FSharp.Core.ExtraTopLevelOperators.printfn
val y : Expr<int>
val f : (unit -> unit)

Full name: Script.f
Multiple items
namespace QuotationCompiler

--------------------
type QuotationCompiler =
  private new : unit -> QuotationCompiler
  static member Eval : expr:Expr<'T> * ?useCache:bool -> 'T
  static member ToAssembly : expr:Expr * ?targetDirectory:string * ?assemblyName:string * ?compiledModuleName:string * ?compiledFunctionName:string -> string
  static member ToDynamicAssembly : expr:Expr * ?assemblyName:string -> MethodInfo
  static member ToFunc : expr:Expr<'T> * ?useCache:bool -> (unit -> 'T)

Full name: QuotationCompiler.QuotationCompiler
static member QuotationCompiler.ToFunc : expr:Expr<'T> * ?useCache:bool -> (unit -> 'T)
Raw view Test code New version

More information

Link:http://fssnip.net/7Tq
Posted:7 years ago
Author:NIck Palladinos
Tags: staging , trampoline

This web site is created using F# and Suave web server. It is hosted on Azure and the source code is on GitHub. Contributions are welcome!

The first version of fssnip.net has been created by @tomaspetricek back in 2010. This web site is a new, open-source and contribution-friendly version.