Writing a pi-calculus compiler in F# (Part VIII)

Just joining us? We’re writing a compiler for the π-calculus in F#—Part I explains. Continuing from last time? Need a refresher? We finished the compiler and runtime library. Now it’s time to play!

 

Let’s see if this all works by creating a new C# project.  Reference Pirt.dll and echo.dll:

 

using System.Threading;

 

class EchoClient

{

    static void Main()

    {

        // create channel 'e'

        Channel e = new Channel("e");

 

        // start the echo program

        new Thread(new ThreadStart(new Main(e).Run)).Start();

 

        // call echo

 

        Channel k = new Channel("k");

        e.Send(k);

        Channel f = k.Receive();

        f.Send(new Channel("hello!"));

        Channel r = new Channel("r");

        f.Send(r);

 

        System.Console.WriteLine(r.Receive().Name);

    }

}

 

Let’s see if it runs:

 

$ csc /t:exe echoclient.cs /r:pirt.dll /r:echo.dll

Microsoft (R) Visual C# 2005 Compiler version 8.00.50727.42

for Microsoft (R) Windows (R) 2005 Framework version 2.0.50727

Copyright (C) Microsoft Corporation 2001-2005. All rights reserved.

 

 

$ echoclient

hello!

^C

$ _

 

Fairly tedious from C#, but it works!

 

Evaluating the Compiler

 

Some parts of the compiler are arguably fragile because they rely on other parts behaving just so. Here are some examples:

 

 

Although these all seem like egregious shortcomings, I believe there’s a point where making the coupling explicit (usually by extending the context and passing around data to connect two disconnected phases) is becomes more burdensome than remembering certain conventions exist between the two disparate pieces of code.

 

Variants of the π-Calculus

 

Messaging and channels make the π-calculus good for modeling distributed systems, but it is rather poor for implementing them! That’s because, in a distributed π system, two processes on different sides of the world can both say receive on channel x, and expect the contention to be resolved. Doing so at such a great distance is brittle or expensive. The join-calculus is similar process calculus with messages and channels, but receiving on a channel is limited to a particular scope, and in a distributed setting it follows intuition that messages must be sent to a well-defined location for the contention can be resolved locally. My research language and compiler, GPSL, is based on the join calculus. I recommend you read Cédric Fournet’s join calculus tutorial.

 

Another popular application of π-calculus is in modeling cryptographic protocols. The spi calculus uses type systems to ensure the secrecy of channel names.

 

There are even variants of the π-calculus, mostly for modeling biological systems, where we involve specific probabilities with Q and R getting y.

 

Further Reading

 

If you’re interested in learning more: Wikipedia has a brief overview of the π-calculus; Robin Milner’s Communicating and Mobile Systems: the π-calculus is a concise tutorial introduction and even extends to modeling object-orientation in π-calculus; Davide Sangiorgi’s The π-Calculus goes into detail about typed π-calculus, more detail about object encoding, and a π-calculus language Pict.

The Complete Source Code

 

ast.fs

 

open Microsoft.AbstractIL.IL

 

type id = string

 

type proc =

      | Inert

      | Par of proc * proc

      | Recv of id * id * proc

      | Send of id * id * proc

      | New of id * proc

      | Repeat of proc

      | Branch of code_label

 

lex.fsl

 

{

open System

open Pars

open Lexing

 

(* Fslex generated parsers follow the same pattern as OCamllex *)

(* and Mossmllex generated parsers, and do not update line number *)

(* information automatically, partly because the knowledge of when *)

(* a newline has occured is best placed in the lexer rules. *)

 

(* Thus the following boiler-plate code is very useful *)

 

let inc_lnum bol pos =

  let lnum = pos.pos_lnum in

  {pos with pos_lnum =  lnum+1; pos_bol = bol }

 

let newline lexbuf =

  lexbuf_set_curr_p lexbuf

    ( inc_lnum (lexeme_end lexbuf) (lexeme_end_p lexbuf))

 

}

 

let whitespace = [' ' '\t']

let newline = ('\n' | '\r' '\n')

 

rule token = parse

      | whitespace      { token lexbuf }

      | newline         { newline lexbuf; token lexbuf }

      | "("             { LPAREN }

      | ")"             { RPAREN }

      | "<"             { LANGLE }

      | ">"             { RANGLE }

      | "0"             { INERT }

      | "."             { SEQ }

      | "|"             { PAR }

      | "!"             { REP }

      | "new"                 { NEW }

      | ['a'-'z']['a'-'z' '0'-'9']* { ID(lexeme lexbuf) }

      | eof             { EOF }

 

pars.fsy

 

%{

open Ast

%}

 

%start start

%token <string> ID

%token LPAREN RPAREN LANGLE RANGLE INERT SEQ PAR REP NEW EOF

%type <Ast.proc> start

 

%%

 

start :     Proc EOF { $1 }

 

Proc  :     Proc1             { $1 }

            |     Proc1 PAR Proc    { Par ($1, $3) }

 

Proc1 :     INERT                                     { Inert }

            |     ID LPAREN ID RPAREN SEQ Proc1 { Recv ($1, $3, $6) }

            |     ID LANGLE ID RANGLE SEQ Proc1 { Send ($1, $3, $6) }

            |     LPAREN NEW ID RPAREN SEQ Proc1      { New ($3, $6) }

            |     REP Proc1                                 { Repeat $2 }

            |     LPAREN Proc RPAREN                        { $2 }

 

main.fs

 

open Ast

open System.IO

open Printf

open Idioms

open Microsoft.AbstractIL.IL

open Microsoft.AbstractIL.BinaryWriter

open Microsoft.AbstractIL.Internal.Bytes

open Microsoft.AbstractIL.Internal.Nums

open Microsoft.AbstractIL.Internal.Zset

 

(* free variables *)

 

let var_order (x: id) (y: id) =

      x.CompareTo(y)

 

let empty_vars =

      empty var_order

 

let rec free_vars p =

      match p with

      | Inert ->

            empty_vars

      | Par (p, q) ->

            union (free_vars p) (free_vars q)

      | Recv (ch, v, p) ->

            add ch (remove v (free_vars p))

      | Send (ch, v, p) ->

            addL [ch; v] (free_vars p)

      | New (v, p) ->

            remove v (free_vars p)

      | Repeat p ->

            free_vars p

      | Branch _ ->

            failwith "free_vars: free_vars of branch"

 

(* Scope of the pic runtime assembly *)

let runtime_scope =

      ScopeRef_assembly

            { assemRefName = "Pirt";

              assemRefHash = None;

              assemRefPublicKeyInfo = None;

              assemRefRetargetable = false;

              assemRefVersion = None;

              assemRefLocale = None }

 

(* the channel type in the runtime library *)

let channel_typ =

      mk_nongeneric_boxed_typ (mk_tref (runtime_scope, "Channel"))

 

(* the channel constructor *)

let channel_ctor_mspec =

      mk_ctor_mspec_for_typ (channel_typ, [typ_String])

 

(* the Send method *)

let send_mspec =

      mk_nongeneric_instance_mspec_in_typ (channel_typ, "Send", [channel_typ], Type_void)

     

(* the Receive method *)

let recv_mspec =

      mk_nongeneric_instance_mspec_in_typ (channel_typ, "Receive", [], channel_typ)

 

let tref_ThreadStart =

      mk_tref (mscorlib_scoref, "System.Threading.ThreadStart")

     

let typ_ThreadStart =

      mk_nongeneric_boxed_typ tref_ThreadStart

     

let mspec_ThreadStart_ctor =

      mk_ctor_mspec_for_typ (typ_ThreadStart, [typ_Object; typ_IntPtr])

 

let tref_Thread =

      mk_tref (mscorlib_scoref, "System.Threading.Thread")

     

let typ_Thread =

      mk_nongeneric_boxed_typ tref_Thread

     

let mspec_Thread_ctor =

      mk_ctor_mspec_for_typ (typ_Thread, [typ_ThreadStart])

 

let mspec_Thread_Start =

      mk_nongeneric_instance_mspec_in_typ (typ_Thread, "Start", [], Type_void)

 

(* code-generation context *)

 

type storage_context = (id * storage) list

 

and storage =

      | Local of u16

      | Field of field_spec

 

type closure_context = (proc * type_ref) list

 

type context = storage_context * closure_context

 

let mk_load ctx var =

      try

            match List.assoc var (fst ctx) with

            | Local n ->

                  [I_ldloc n]

            | Field f ->

                  [I_ldarg (int_to_u16 0);

                   mk_normal_ldfld f]

      with Not_found ->

            failwith ("undeclared variable '" ^ var ^ "' in scope variables: " ^ any_to_string (fst ctx))

 

let locals_of_context ctx =

      let is_local (_, s) =

            match s with

            | Local _ -> true

            | _           -> false

      in

      List.filter is_local (fst ctx)

 

let mk_store ctx var =

      let n = int_to_u16 (List.length (locals_of_context ctx)) in

      [I_stloc n],

      ((var, Local n) :: fst ctx, snd ctx)

     

let rec desugar_proc p =

      match p with

      | Inert ->

            p

      | Send (ch, v, q) ->

            Send (ch, v, desugar_proc q)

      | Recv (ch, v, q) ->

            Recv (ch, v, desugar_proc q)

      | New (v, q) ->

            New (v, desugar_proc q)

      | Par (Inert, q) ->

            desugar_proc q

      | Par (p, Inert) ->

            desugar_proc p

      | Par (p, q) ->

            Par (desugar_proc p, desugar_proc q)

      | Repeat Inert ->

            Inert

      | Repeat (Repeat p) ->

            desugar_proc (Repeat p)

      | Repeat (Par (p, q)) ->

            Par (desugar_proc (Repeat p), desugar_proc (Repeat q))

      | Repeat p ->

            Repeat (desugar_proc p)

      | Branch _ ->

            failwith "desugar_proc: desugar_proc of branch"

 

let canon_proc p =

      (* we need to keep running desugar_proc until it reaches a fixed

         point *)

      let rec f u v =

            if u = v then

                  u

            else

                  f v (desugar_proc v)

      in

      f p (desugar_proc p)

 

let rec gen_proc p entry_label ctx =

      match p with

      | Inert ->

            mk_bblock

                  { bblockLabel = entry_label;

                    bblockInstrs = [| I_ret |] },

            ctx

      | Send (ch, v, q) ->

            let q_entry = generate_code_label "" in

            let send_code = mk_bblock

                  { bblockLabel = entry_label;

                    bblockInstrs = Array.of_list

                        (mk_load ctx ch @

                         mk_load ctx v @

                         [ mk_normal_call send_mspec;

                           I_br q_entry ])} in

            let q_code, ctx' = gen_proc q q_entry ctx in

            join_code send_code q_code, ctx'

      | Recv (ch, v, q) ->

            let q_entry = generate_code_label "" in

            let store, ctx' = mk_store ctx v in

            let recv_code = mk_bblock

                  { bblockLabel = entry_label;

                    bblockInstrs = Array.of_list

                        (mk_load ctx ch @

                         [mk_normal_call recv_mspec] @

                         store @

                         [I_br q_entry])} in

            let q_code, ctx'' = gen_proc q q_entry ctx' in

            join_code recv_code q_code, ctx''

      | New (v, p) ->

            let p_entry = generate_code_label "" in

            let store, ctx' = mk_store ctx v in

            let new_code = mk_bblock

                  { bblockLabel = entry_label;

                    bblockInstrs = Array.of_list

                        ([I_ldstr (string_as_unicode_bytes v);

                          mk_normal_newobj channel_ctor_mspec] @

                         store @

                         [I_br p_entry])} in

            let p_code, ctx'' = gen_proc p p_entry ctx' in

            join_code new_code p_code, ctx''

      | Par (p, q) ->

            let p_tref = mk_tref (ScopeRef_local,

                                            generate_code_label "Closure") in

            let ctx' = (fst ctx, snd ctx @ [p, p_tref]) in

            let vs = elements (free_vars p) in

            let p_ctor_mspec = mk_ctor_mspec_for_nongeneric_boxed_tref

                  (p_tref, List.map (fun _ -> channel_typ) vs) in

            let p_run_mspec = mk_nongeneric_instance_mspec_in_nongeneric_boxed_tref (p_tref, "Run", [], Type_void) in

            let q_entry = generate_code_label "" in

            let p_code = mk_bblock

                  { bblockLabel = entry_label;

                    bblockInstrs = Array.of_list

                        (List.flatten (List.map (mk_load ctx') vs) @

                         [mk_normal_newobj p_ctor_mspec;

                          I_ldftn p_run_mspec;

                          mk_normal_newobj mspec_ThreadStart_ctor;

                          mk_normal_newobj mspec_Thread_ctor;

                          mk_normal_callvirt mspec_Thread_Start;

                          I_br q_entry])} in

            let q_code, ctx'' = gen_proc q q_entry ctx' in

            join_code p_code q_code, ctx''

      | Repeat p ->

            let loop_entry = generate_code_label "" in

            (match p with

            | Inert

            | Par _

            | Repeat _ ->

                  failwith "gen_proc: gen_proc of non-canonical process"

            | Branch _ ->

                  failwith "gen_proc: encountered repeat-branch"

            | Send (ch, v, q) ->

                  let p' = Send (ch, v, Par (q, Branch entry_label)) in

                  gen_proc p' entry_label ctx

            | Recv (ch, v, q) ->

                  let p' = Recv (ch, v, Par (q, Branch entry_label)) in

                  gen_proc p' entry_label ctx

            | New (v, q) ->

                  let p' = New (v, Par (q, Branch entry_label)) in

                  gen_proc p' entry_label ctx)

      | Branch label ->

            mk_bblock

                  { bblockLabel = entry_label;

                    bblockInstrs = [| I_br label |] },

            ctx

 

let gen_closure p tref (tdefs, trefs) =

      let typ = mk_nongeneric_boxed_typ tref in

     

      (* fields for captured variables *)

      let vs = elements (free_vars p) in

      let fss = List.map (fun v -> mk_fspec_in_typ (typ, v, channel_typ)) vs in

      let store = List.map2 (fun v f -> v, Field f) vs fss in

      let fds = List.map (fun v -> mk_instance_fdef (v, channel_typ, None, MemAccess_private)) vs in

     

      (* constructor *)

      let ctor_params = List.map (fun v -> mk_param (Some v, channel_typ)) vs in

      let ctor_entry = generate_code_label "" in

      let n = ref 0 in

      let ctor_code = nonbranching_instrs_then_ret ctor_entry (List.flatten

            ([I_ldarg (int_to_u16 0);

              mk_normal_call (mk_nongeneric_instance_mspec_in_typ (typ_Object, ".ctor", [], Type_void))] ::

             List.map (fun f ->

                  incr n;

                  [I_ldarg (int_to_u16 0);

                   I_ldarg (int_to_u16 !n);

                   mk_normal_stfld f]

                          ) fss)) in

      let ctor_body = mk_ilmbody (true, [], 2, ctor_code, None) in

      let ctor_mdef = mk_ctor (MemAccess_public, ctor_params, MethodBody_il ctor_body) in

 

      (* run method *)

      let run_entry = generate_code_label "" in

      let run_code, ctx = gen_proc p run_entry (store, trefs) in

      let run_body = mk_ilmbody (

            true,

            List.map (fun _ -> mk_local channel_typ) (locals_of_context ctx),

            2,

            run_code,

            None) in

      let run_mdef = mk_instance_mdef ("Run", MemAccess_public, [], Type_void, MethodBody_il run_body) in

 

      (* type definition *)

      let tdef =

            { tdKind = TypeDef_class;

              tdName = tname_of_tref tref;

              tdGenericParams = [];

              tdAccess = TypeAccess_public;

              tdAbstract = false;

              tdSealed = true;

              tdSerializable = false;

              tdComInterop = false;

              tdLayout = TypeLayout_auto;

              tdSpecialName = false;

              tdEncoding = TypeEncoding_autochar;

              tdNested = mk_tdefs [];

              tdImplements = [];

              tdExtends = Some typ_Object;

              tdMethodDefs = mk_mdefs [ctor_mdef; run_mdef];

              tdSecurityDecls = mk_security_decls [];

              tdHasSecurity = false;

              tdFieldDefs = mk_fdefs fds;

              tdMethodImpls = mk_mimpls [];

              tdInitSemantics = TypeInit_beforefield;

              tdEvents = mk_events [];

              tdProperties = mk_properties [];

              tdCustomAttrs = mk_custom_attrs [] } in

             

      tdef :: tdefs, snd ctx

 

let gen_closures p =

      let rec f (tdefs, trefs) =

            match trefs with

            | [] ->

                  tdefs

            | (q, tref)::trefs' ->

                  f (gen_closure q tref (tdefs, trefs'))

      in

      f ([], [p, mk_tref (ScopeRef_local, "Main")])

 

let _ =

      if Array.length Sys.argv <> 2 || not (File.Exists(Sys.argv.(1)))

      then begin

            printf "usage: pic <file>\n";

            exit 1

      end;

     

      let filename = Sys.argv.(1) in

      let proc = ref Inert in

      using (new StreamReader(filename)) (fun input ->

            proc :=

                  let lexbuf = Lexing.from_stream_reader input in

                  try Pars.start Lex.token lexbuf

                  with e ->

                        let pos = Lexing.lexbuf_curr_p lexbuf in

                        printf "%s (%d, %d): parse error: %s"

                              filename

                              (pos.pos_lnum+1)

                              (pos.pos_cnum - pos.pos_bol + 1)

                              (e.Message);

                        exit 1;

                        Inert

      );

 

      proc := canon_proc !proc;

      let tds = gen_closures !proc in

      let assem_name = Path.GetFileNameWithoutExtension(filename) in

      let modul_name = assem_name ^ ".dll" in

      let output_filename = Path.Combine(Path.GetDirectoryName(filename), modul_name) in

      let modul = mk_simple_mainmod assem_name modul_name true (mk_tdefs tds) in

      write_binary output_filename None None None modul

 

The runtime library, channel.cs:

 

using System.Threading;

 

public class Channel

{

    public readonly string Name;

    private volatile Channel channel;

    private readonly AutoResetEvent sending;

    private readonly AutoResetEvent receiving;

 

    public Channel(string name)

    {

        this.Name = name;

        this.sending = new AutoResetEvent(false);

        this.receiving = new AutoResetEvent(false);

    }

 

    public void Send(Channel channel)

    {

        lock (this.sending)

        {

            this.channel = channel;

            this.sending.Set();

            this.receiving.WaitOne();

        }

    }

 

    public Channel Receive()

    {

        lock (this.receiving)

        {

            this.sending.WaitOne();

 

            Channel result = this.channel;

            this.channel = null;

 

            this.receiving.Set();

            return result;

        }

    }

}

 

An example program, echo.pi:

 

!e(k).(new f).k<f>.f(x).f(r).r<x>.0

 

A C# driver program, echoclient.cs:

 

using System.Threading;

 

class EchoClient

{

    static void Main()

    {

        // create channel 'e'

        Channel e = new Channel("e");

 

        // start the echo program

        new Thread(new ThreadStart(new Main(e).Run)).Start();

 

        // call echo

 

        Channel k = new Channel("k");

        e.Send(k);

        Channel f = k.Receive();

        f.Send(new Channel("hello!"));

        Channel r = new Channel("r");

        f.Send(r);

 

        System.Console.WriteLine(r.Receive().Name);

    }

}

 

Special!

 

Congratulations, you read this far! Thank you. Now I’ll award you with some information you can really use: To write π in Microsoft Office Word, type 03C0 and press Alt-X. Your 03C0 will be transmuted into π.

Comments:

what a great find! thanks for posting this. i can't wait to get my hands dirty. — cor.byt

Powered by Google App Engine
Custom Search