Thursday, 22 March 2012

Drawing trees with WPF

The F#.NET Journal just published an article about visualization:

"The ability to visualize trees is vitally important in many different applications. This article examines at a simple but effective algorithm for visualizing trees and uses WPF to draw the results..."

To read this article and more, subscribe to The F#.NET Journal today!

Monday, 19 March 2012

Compiling to CIL

The F#.NET Journal just published an article about metaprogramming:

"One of the advantages of the Common-Language Runtime (CLR) is the ability to compile run-time generated code to CIL and have it JIT compiled to native code and evaluated. Regular expressions in .NET are perhaps the most obvious practical application where this capability can pay dividends. This article covers a tiny compiler written in F# that generates and compiles CIL code on-the-fly..."


To read this article and more, subscribe to The F#.NET Journal today!

Efficient structural serialization

The F#.NET Journal just published an article about serialization:

"The .NET Framework provides binary, JSON and XML serializers. This article takes a look at these built-in serializers before developing a new structural serializer for values of F# types that addresses some of the shortcomings of the existing serializers..."


To read this article and more, subscribe to The F#.NET Journal today!

Monday, 12 March 2012

Optimizing Black-Scholes in F#

Dave Thomas published an interesting post called Black-Scholes Taste Test where he describes Black-Scholes calculators written in idiomatic C# and F# and finds that the F# is 30% faster than the C#. This is primarily due to the use of floating-point exponentiation in the C# vs the pown function in F#.
We found there is still considerable room for improvement. Specifically, the following optimizations make our F# solution 40% faster than Dave's F#:

  • Hoist the constants including the magic number 0.2316419 and 1.0 / sqrt(2.0 * Math.PI).
  • Consolidate the call to abs and the final branch in the cns function into a single branch using F#'s inline to factor out the commonality.
  • Do common subexpression elimination (CSE) on the k*k*k etc. by hand.
  • Replace /2.0 with *0.5.
  • In the blackscholes function, eliminate the common subexpression sqrt t.
  • Potentially use partial application to precompute a blackscholes function for either Call or Put in order to remove dynamic dispatch from the inner loop (but this depends upon how the function is called).

This resulted in the following F# solution:
type Style = Call | Put

let a1 = 0.31938153
let a2 = -0.356563782
let a3 = 1.781477937
let a4 = -1.821255978
let a5 = 1.330274429
let b = 0.2316419
let c = 1.0 / sqrt(2.0 * System.Math.PI)

let cnd x =
  let inline w l =
    let k  = 1.0 / (1.0 + b * l)
    let k2 = k * k
    let k4 = k2 * k2
    c * exp(-0.5 * l * l) * (a1 * k + a2 * k2 + a3 * k * k2 + (a4 * k4 + a5 * k * k4))
  if x < 0.0 then w -x else 1.0 - w x

let blackscholes style s x t r v =
  let sqrtt = sqrt t
  let d1 = (log(s / x) + (r + v * v / 2.0) * t) / (v * sqrtt)
  let d2 = d1 - v * sqrtt
  let x = x * exp(-r * t)
  match style with
  | Call -> s * cnd d1 - x * cnd d2
  | Put -> x * cnd -d2 - s * cnd -d1

Saturday, 10 March 2012

Generating resilient HTML

Instead of requiring content to be written off-line and uploaded, many blog hosts including Google's Blogger provide an in-browser editor. Unfortunately, Google's editor is easily confused by HTML in the written document and it will corrupt blog posts. In fact, our last post took four attempts before we were able to create something readable. Of course, code is often hit by this problem.

The following WPF-based F# program produces a window that allows content to be pasted into the text box at the top and converted into raw HTML at the bottom that can then be pasted into blogs with a greatly reduced risk of corruption:

open System.Windows

[<System.STAThread>]
do
   let panel = Controls.StackPanel()
   let input = Controls.TextBox(AcceptsReturn=true)
   let output = Controls.TextBox(AcceptsReturn=true)
   input.TextChanged.Add(fun e ->
      output.Text <-
         [ for c in input.Text do
            match int c with
            | 13 -> ()
            | 10 -> yield "<br />"
            | 32 -> yield "&nbsp;"
            | c -> yield sprintf "&#%d;" c ]
         |> String.concat "")
   panel.Children.Add input |> ignore
   panel.Children.Add output |> ignore
   let content = Controls.ScrollViewer(Content=panel)
   Window(Content=content) |> Application().Run |> ignore

Sunday, 4 March 2012

Using LLVM from F# under Windows

LLVM is an awesome low-level virtual machine that provides excellent code generators for all major architectures including x86, x64 and ARM but it is used primarily under Linux and Mac OS X and not Windows. This blog post describes how to install LLVM and its dependencies under Windows and use F# to write a mini-compiler capable of JIT compiling and executing the Fibonacci function.

Installation

  1. export PATH=$PATH:/c/Python27/
  2. gunzip <llvm-3.0.tar.gz | tar xv llvm-3.0.tar.gz
  3. cd llvm-3.0.src
  4. ./configure --enable-shared --enable-jit --enable-bindings=none
  5. make

  • Add the C:\MinGW\msys\1.0\home\Jon\llvm-3.0.src\Release\bin\ directory to the Windows PATH via Start Menu  Computer (Right click)  Advanced system settings  Environment variables.
  • Restart Visual Studio 2010
  • Create a new solution and add Keith Sheppard's llvm-fs project to it.
Now we're ready to start writing F# code that calls out to LLVM via PInvoke in order to get code JIT compiled and executed.

A first compiler
The following F# program contains an expression and function compiler that can compile and execute a variety of self-recursive functions:


open LLVM.Generated.Core
open LLVM.Core
open LLVM.Generated.ExecutionEngine
open LLVM.ExecutionEngine

type Type =
  | TBool
  | TInt
  | TFunction of Type list * Type

  member ty.LLVM =
    match ty with
    | TBool -> int8Type()
    | TInt -> int32Type()
    | TFunction(argTys, retTy) ->
        functionType retTy.LLVM [|for ty in argTys -> ty.LLVM|]

type State =
  {
    Find: string -> ValueRef * Type
    Builder: BuilderRef
    Blk: BasicBlockRef
    Function: ValueRef
  }

  member state.AppendBasicBlock() =
    appendBasicBlock state.Function ""

  member state.MoveTo blk =
    positionBuilderAtEnd state.Builder blk
    { state with Blk = blk }

type BinOp = Add | Leq

type Expr =
  | EInt of int
  | EVar of string
  | EBinOp of BinOp * Expr * Expr
  | EIf of Expr * Expr * Expr
  | EApply of Expr * Expr list
  | EReturn of Expr

  static member (+) (f, g) = EBinOp(Add, f, g)
  static member (<=.) (f, g) = EBinOp(Leq, f, g)

let find state s =
  match Map.tryFind s state with
  | Some v -> v
  | None -> failwithf "Unknown variable '%s'" s

let rec cont state f kBlk =
  let f, state = compileExpr state f
  let _ = buildBr state.Builder kBlk
  f, state
and compileExpr state expr =
  match expr with
  | EReturn f ->
      let (f, fTy), state = compileExpr state f
      (buildRet state.Builder f, fTy), state
  | EInt n -> (constInt (int32Type()) (uint64 n) false, TInt), state
  | EVar s -> state.Find s, state
  | EBinOp(op, f, g) ->
      let (f, fTy), (g, gTy), state = compileExpr2 state f g
      match op, fTy, gTy with
      | Add, TInt, TInt -> (buildAdd state.Builder f g "", TInt), state
      | Leq, TInt, TInt -> (buildICmp state.Builder IntPredicate.IntSLE f g "", TBool), state
      | _ -> failwith "Type error"
  | EIf(p, t, f) ->
      let tBlk = state.AppendBasicBlock()
      let fBlk = state.AppendBasicBlock()
      let kBlk = state.AppendBasicBlock()
      let (p, pTy), state = compileExpr state p
      if pTy <> TBool then failwith "Type error"
      let _ = buildCondBr state.Builder p tBlk fBlk
      let (t, tTy), state = cont (state.MoveTo tBlk) t kBlk
      let (f, fTy), state = cont (state.MoveTo fBlk) f kBlk
      if tTy <> fTy then failwith "Type error"
      let state = state.MoveTo kBlk
      let phi = buildPhi state.Builder (tTy: Type).LLVM ""
      addIncoming phi [|t, tBlk; f, fBlk|]
      (phi, tTy), state
  | EApply(f, xs) ->
      let (f, fTy), state = compileExpr state f
      let xs, state = compileExprs state xs
      match fTy with
      | TFunction(argTys, retTy) when argTys = List.map snd xs ->
          (buildCall state.Builder f [|for x, _ in xs -> x|] "", retTy), state
      | _ -> failwith "Type error"
and compileExpr2 state f g =
  let f, state = compileExpr state f
  let g, state = compileExpr state g
  f, g, state
and compileExprs state = function
  | [] -> [], state
  | f::fs ->
      let f, state = compileExpr state f
      let fs, state = compileExprs state fs
      f::fs, state  

let compileFn m name (args: (string * Type) list) body (retTy: Type) =
  let funcType = functionType retTy.LLVM [|for _, ty in args -> ty.LLVM|]
  let fn = addFunction m name funcType
  let bldr = new Builder ()
  let find x =
    List.mapi (fun i x -> i, x) args
    |> Seq.pick (fun (i, (k, ty)) -> if k=x then Some(getParam fn (uint32 i), ty) else None)
  let find x = if x=name then (fn, TFunction(List.map snd args, retTy)) else find x
  let state =
    {
      Find = find
      Builder = bldr
      Blk = appendBasicBlock fn ""
      Function = fn
    }
  positionBuilderAtEnd bldr state.Blk
  let (_, retTy'), state = compileExpr state (EReturn body)
  if retTy <> retTy' then failwith "Type error"
  fn

open System.Runtime.InteropServices

[<DllImport("LLVM-3.0.dll", EntryPoint="LLVMInitializeX86Target")>]
extern void initializeX86Target()

do
  initializeX86Target ()
  let myModule = moduleCreateWithName "addModule"
  let ee = createExecutionEngineForModule myModule
  let inline mkInt n = createGenericValueOfInt (int32Type()) (uint64 n) false

  let add = compileFn myModule "add" ["m", TInt; "n", TInt] (EVar "m" + EVar "n") TInt
  let result = runFunction ee add [|mkInt 3; mkInt 8|]
  printfn "3 + 8 = %d" (genericValueToInt result false)

  let sign =
    compileFn myModule "sign"
      ["n", TInt]
      (EIf(EVar "n" <=. EInt 0, EInt -1, EInt 1))
      TInt
  let result = runFunction ee sign [|mkInt 3|]
  printfn "sign 3 = %d" (genericValueToInt result false)

  let fib =
    compileFn myModule "fib"
      ["n", TInt]
      (EIf(EVar "n" <=. EInt 1, EVar "n",
          EApply(EVar "fib", [EVar "n" + EInt -1]) +
            EApply(EVar "fib", [EVar "n" + EInt -2])))
      TInt
  let result = runFunction ee fib [|mkInt 10|]
  printfn "fib 10 = %d" (genericValueToInt result false)


As of writing, an unknown bug (probably in llvm-fs) causes Visual Studio 2010 to stop with an error about unbalanced stacks every time an LLVM function is invoked. We have tried each calling convention and they all give this error.