Staged Reducer

Fusion via reducer partial application, based on http://manojo.github.io/resources/staged-fold-fusion.pdf

 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:

// Fusion via reducer partial application
// based on http://manojo.github.io/resources/staged-fold-fusion.pdf 

#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"

open QuotationCompiler
open Microsoft.FSharp.Quotations

// <@ fun x -> (% <@ x @> ) @> ~ lambda (fun x -> x)
let lambda (f : Expr<'T> -> Expr<'R>) : Expr<'T -> 'R> =
    let var = new Var("__temp__", 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 = new Var("__temp__", typeof<'T>)
    let var' = new Var("__temp'__", typeof<'S>)
    Expr.Cast<_>(Expr.Lambda(var, Expr.Lambda(var',  f (Expr.Cast<_>(Expr.Var var)) (Expr.Cast<_>(Expr.Var var')))))


   
// Basic Structure
type Reducer<'T> = 
    abstract Apply<'R> : (Expr<'R> -> Expr<'T> -> Expr<'R>) -> Expr<'R> -> Expr<'R> 
        
// Basic operations
let ofArray (array : Expr<'T []>) : Reducer<'T> = 
    { new Reducer<'T> with
        member self.Apply<'R> (f : Expr<'R> -> Expr<'T> -> Expr<'R>) (s : Expr<'R>) =
            <@  let mutable i = 0
                let mutable s = %s
                while i < (%array).Length do
                    let v = (%array).[i]
                    s <- (%lambda2 f) s v
                    i <- i + 1
                s @> }
    

let map (f : Expr<'A> -> Expr<'B>) (reducer : Reducer<'A>) : Reducer<'B> = 
    { new Reducer<'B> with 
        member self.Apply<'R> (f' : Expr<'R> -> Expr<'B> -> Expr<'R>) (s : Expr<'R>) : Expr<'R> = 
                reducer.Apply<'R> (fun s' a -> f' s' (f a)) s }

let filter (p : Expr<'T> -> Expr<bool>) (reducer : Reducer<'T>) : Reducer<'T> = 
    { new Reducer<'T> with 
        member self.Apply<'R> (f : Expr<'R> -> Expr<'T> -> Expr<'R>) (s : Expr<'R>) : Expr<'R> = 
                reducer.Apply<'R> (fun s' a -> <@ if (% p a) then (% f s' a) else %s' @>) s }

let fold (f : Expr<'S> -> Expr<'T> -> Expr<'S>) (s : Expr<'S>) (reducer : Reducer<'T>) : Expr<'S> = 
    reducer.Apply<'S> f s 

let compile (f : Expr<'T -> 'R>) : 'T -> 'R = QuotationCompiler.ToFunc(f) ()


// Example

let test arr = 
    arr 
    |> ofArray
    |> filter (fun v -> <@ %v % 2 = 0 @>)
    |> map (fun v -> <@ %v * 2 @>)
    |> fold (fun s v -> <@ %s + %v @>) <@ 0 @>

let f = test |> lambda |> compile
f [|1..100|] // 5100

namespace QuotationCompiler

namespace Microsoft

namespace Microsoft.FSharp

namespace Microsoft.FSharp.Quotations

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 var : Var

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:System.Type * ?isMutable:bool -> Var

val typeof<'T> : System.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 Reducer<'T> =
  interface
    abstract member Apply : (Expr<'R> -> Expr<'T> -> Expr<'R>) -> Expr<'R> -> Expr<'R>
  end

Full name: Script.Reducer<_>

abstract member Reducer.Apply : (Expr<'R> -> Expr<'T> -> Expr<'R>) -> Expr<'R> -> Expr<'R>

Full name: Script.Reducer`1.Apply

val ofArray : array:Expr<'T []> -> Reducer<'T>

Full name: Script.ofArray

Multiple items
val array : Expr<'T []>

--------------------
type 'T array = 'T []

Full name: Microsoft.FSharp.Core.array<_>

val self : Reducer<'T>

abstract member Reducer.Apply : (Expr<'R> -> Expr<'T> -> Expr<'R>) -> Expr<'R> -> Expr<'R>

val f : (Expr<'R> -> Expr<'T> -> Expr<'R>)

val s : Expr<'R>

val mutable i : int

val mutable s : 'R

val v : 'T

val map : f:(Expr<'A> -> Expr<'B>) -> reducer:Reducer<'A> -> Reducer<'B>

Full name: Script.map

val f : (Expr<'A> -> Expr<'B>)

val reducer : Reducer<'A>

val self : Reducer<'B>

val f' : (Expr<'R> -> Expr<'B> -> Expr<'R>)

val s' : Expr<'R>

val a : Expr<'A>

val filter : p:(Expr<'T> -> Expr<bool>) -> reducer:Reducer<'T> -> Reducer<'T>

Full name: Script.filter

val p : (Expr<'T> -> Expr<bool>)

type bool = System.Boolean

Full name: Microsoft.FSharp.Core.bool

val reducer : Reducer<'T>

val a : Expr<'T>

val fold : f:(Expr<'S> -> Expr<'T> -> Expr<'S>) -> s:Expr<'S> -> reducer:Reducer<'T> -> Expr<'S>

Full name: Script.fold

val f : (Expr<'S> -> Expr<'T> -> Expr<'S>)

val s : Expr<'S>

val compile : f:Expr<('T -> 'R)> -> ('T -> 'R)

Full name: Script.compile

val f : Expr<('T -> 'R)>

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)

val test : arr:Expr<int []> -> Expr<int>

Full name: Script.test

val arr : Expr<int []>

val v : Expr<int>

val s : Expr<int>

val f : (int [] -> int)

Full name: Script.f

Raw view Test code New version

More information

Link:	http://fssnip.net/7QC
Posted:	8 years ago
Author:	Nick Palladinos
Tags:	staging, reducer, fusion