Add initial compiler from linear lambda-calculus to stellogen

Author: engboris

bin/cosmog.ml

@@ -0,0 +1,38 @@
+open Base
+open Cmdliner
+open Stellogen
+
+let run input_file =
+  let lexbuf = Sedlexing.Utf8.from_channel (Stdlib.open_in input_file) in
+  let start_pos filename =
+    { Lexing.pos_fname = filename; pos_lnum = 1; pos_bol = 0; pos_cnum = 0 }
+  in
+  Sedlexing.set_position lexbuf (start_pos input_file);
+  let lexer = Sedlexing.with_tokenizer Cosmog_lexer.read lexbuf in
+  let parser =
+    MenhirLib.Convert.Simplified.traditional2revised Cosmog_parser.expr_file
+  in
+  parser lexer |> Cosmog_compile.compile
+  |> List.map ~f:Expr.Raw.to_string
+  |> String.concat ~sep:"\n"
+  |> fun s ->
+  let oc = Stdlib.open_out "out.sg" in
+  Stdlib.output_string oc s;
+  Stdlib.close_out oc
+
+let input_file_arg =
+  let doc = "Input file to process." in
+  Arg.(required & pos 0 (some string) None & info [] ~docv:"FILENAME" ~doc)
+
+let wrap f input_file =
+  try Ok (f input_file) with e -> Error (`Msg (Stdlib.Printexc.to_string e))
+
+let compile_cmd =
+  let term = Term.(const (wrap run) $ input_file_arg |> term_result) in
+  Cmd.v (Cmd.info "compile" ~doc:"Compile a mini ML program") term
+
+let default_cmd =
+  let doc = "Cosmographer: compile mini-ML to Stellogen" in
+  Cmd.group (Cmd.info "cosmog" ~doc) [ compile_cmd ]
+
+let () = Stdlib.exit (Cmd.eval default_cmd)

bin/dune

@@ -1,6 +1,6 @@
 (executables
- (public_names sgen)
- (names sgen)
+ (public_names sgen cosmog)
+ (names sgen cosmog)
  (libraries stellogen base cmdliner))
 
 (env

src/cosmog_compile.ml

@@ -0,0 +1,63 @@
+open Base
+
+let pos x = Expr.Raw.Symbol ("+" ^ x)
+
+let neg x = Expr.Raw.Symbol ("-" ^ x)
+
+let out x = x ^ "_out"
+
+let func es = Expr.Raw.List es
+
+let var x = Expr.Raw.Var x
+
+let star es = Expr.Raw.Cons es
+
+let interact e = Expr.Raw.List [ Expr.Raw.Symbol "interact"; e ]
+
+let group es = Expr.Raw.Group es
+
+let def x t = Expr.Raw.List [ Expr.Raw.Symbol ":="; Expr.Raw.Symbol x; t ]
+
+let show x = Expr.Raw.List [ Expr.Raw.Symbol "show"; x ]
+
+let id x = Expr.Raw.Call (Expr.Raw.Symbol x)
+
+let add s = function
+  | Expr.Raw.Cons es -> Expr.Raw.Cons (Expr.Raw.Symbol s :: es)
+  | e -> Expr.Raw.Cons [ Expr.Raw.Symbol s; e ]
+
+let inject_lr = function
+  | Expr.Raw.Cons [ Expr.Raw.List [ h1; a1 ]; Expr.Raw.List [ h2; a2 ] ] ->
+    Expr.Raw.Cons
+      [ Expr.Raw.List [ h1; add "l" a1 ]; Expr.Raw.List [ h2; add "r" a2 ] ]
+  | _ -> failwith "Compiler error: could not apply inject_lr"
+
+(* FIXME *)
+let rec compile_expr e =
+  if not @@ Lambda.is_linear e then
+    failwith
+      (Printf.sprintf "Compiler error: term '%s' is not linear."
+         (Lambda.to_string e) );
+  match e.content with
+  | Lambda.Var _ ->
+    [ star [ func [ pos e.loc; var "X" ]; func [ pos (out e.loc); var "X" ] ] ]
+  | Lambda.Fun (_x, _t) ->
+    [ star [ func [ pos e.loc; var "X" ]; func [ pos (out e.loc); var "X" ] ]
+      |> inject_lr
+    ]
+  | Lambda.App (t1, t2) ->
+    let cuts =
+      star
+        [ func [ neg (t1.loc ^ "_out"); var "X" ]
+        ; func [ neg (t2.loc ^ "_out"); var "X" ]
+        ]
+    in
+    let out = star [ func [ pos (e.loc ^ "_out"); var "X" ] ] in
+    [ cuts; out ] @ compile_expr t1 @ compile_expr t2
+
+let compile_decl = function
+  | Lambda.Let (x, t) -> [ def x (group (compile_expr t)) ]
+  | Lambda.Print x -> [ show (interact (id x)) ]
+
+let compile : Lambda.program -> Expr.Raw.t list =
+ fun e -> List.map ~f:compile_decl e |> List.concat

src/cosmog_lexer.ml

@@ -0,0 +1,58 @@
+open Cosmog_parser
+
+let space = [%sedlex.regexp? Plus (' ' | '\t')]
+
+let newline = [%sedlex.regexp? '\r' | '\n' | "\r\n"]
+
+let rec comments lexbuf =
+  let tok =
+    match%sedlex lexbuf with
+    | "*)" | eof -> read lexbuf
+    | _ ->
+      ignore (Sedlexing.next lexbuf);
+      comments lexbuf
+  in
+  tok
+
+and read lexbuf =
+  match%sedlex lexbuf with
+  | "fun" -> FUN
+  | "let" -> LET
+  | "print" -> PRINT
+  | 'a' .. 'z', Star ('a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_' | '\'') ->
+    let id = Sedlexing.Utf8.lexeme lexbuf in
+    IDENT id
+  | '(' -> LPAR
+  | ')' -> RPAR
+  | "->" -> RARROW
+  | "=" -> EQ
+  | "(*" -> comments lexbuf
+  | '"' -> string_literal lexbuf
+  | space -> read lexbuf
+  | newline -> read lexbuf
+  | eof -> EOF
+  | _ -> failwith "Unexpected symbol in lexing."
+
+and string_literal lexbuf =
+  let buffer = Buffer.create 32 in
+  let rec loop () =
+    match%sedlex lexbuf with
+    | '"' -> STRING (Buffer.contents buffer)
+    | '\\', any ->
+      let escaped =
+        match%sedlex lexbuf with
+        | 'n' -> '\n'
+        | 't' -> '\t'
+        | '\\' -> '\\'
+        | '"' -> '"'
+        | _ -> failwith "Unknown escape sequence"
+      in
+      Buffer.add_char buffer escaped;
+      loop ()
+    | eof -> failwith "Unterminated string literal"
+    | any ->
+      Buffer.add_string buffer (Sedlexing.Utf8.lexeme lexbuf);
+      loop ()
+    | _ -> failwith "Invalid character in string literal"
+  in
+  loop ()

src/cosmog_parser.mly

@@ -0,0 +1,47 @@
+%{
+open Lambda
+
+let counter = ref 0
+
+let fresh_loc content =
+  let n = !counter in
+  counter := n + 1;
+  { content; loc = string_of_int n }
+%}
+
+%token <string> IDENT
+%token <string> STRING
+%token FUN
+%token RARROW
+%token EQ
+%token LET
+%token PRINT
+%token LPAR RPAR
+%token EOF
+
+%start <Lambda.program> expr_file
+
+%%
+
+let delimited_opt(l, x, r) :=
+  | ~=x; <>
+  | ~=delimited(l, x, r); <>
+
+let pars(x) == ~=delimited(LPAR, x, RPAR); <>
+
+let expr_file :=
+  | EOF; { [] }
+  | es=decl+; EOF; { es }
+
+let decl :=
+  | LET; x=IDENT; EQ; e=expr; { Let (x, fresh_loc e) }
+  | PRINT; ~=IDENT; <Print>
+
+let expr :=
+  | ~=pars(expr); <>
+  | x=IDENT;
+    { Var x }
+  | FUN; x=IDENT; RARROW; e=expr;
+    { Fun (fresh_loc x, fresh_loc e) }
+  | LPAR; e1=expr; e2=expr; RPAR;
+    { App (fresh_loc e1, fresh_loc e2) }

src/dune

@@ -12,3 +12,7 @@
 (menhir
  (modules parser)
  (flags --table --dump --explain))
+
+(menhir
+ (modules cosmog_parser)
+ (flags --table --dump --explain))

src/expr.ml

@@ -5,29 +5,6 @@ open Expr_err
 
 let ( let* ) x f = Result.bind x ~f
 
-type ident = string
-
-module Raw = struct
-  type t =
-    | Symbol of string
-    | Var of ident
-    | String of string
-    | Focus of t
-    | Call of t
-    | List of t list
-    | Stack of t list
-    | Group of t list
-    | Cons of t list
-    | ConsWithParams of t list * t list
-    | ConsWithBase of t list * t
-end
-
-type expr =
-  | Symbol of string
-  | Var of ident
-  | List of expr list
-[@@derive eq]
-
 let primitive = String.append "%"
 
 let nil_op = primitive "nil"
@@ -52,6 +29,53 @@ let incomp_op = "slice"
 
 let group_op = "%group"
 
+type ident = string
+
+module Raw = struct
+  type t =
+    | Symbol of string
+    | Var of ident
+    | String of string
+    | Focus of t
+    | Call of t
+    | List of t list
+    | Stack of t list
+    | Group of t list
+    | Cons of t list
+    | ConsWithParams of t list * t list
+    | ConsWithBase of t list * t
+
+  let rec to_string : t -> string = function
+    | Symbol s -> s
+    | Var x -> x
+    | String s -> Printf.sprintf "\"%s\"" s
+    | Focus e -> Printf.sprintf "%s%s" focus_op (to_string e)
+    | Call e -> Printf.sprintf "%s%s" call_op (to_string e)
+    | List es ->
+      Printf.sprintf "(%s)" (List.map ~f:to_string es |> String.concat ~sep:" ")
+    | Stack es ->
+      Printf.sprintf "<%s>" (List.map ~f:to_string es |> String.concat ~sep:" ")
+    | Group es ->
+      Printf.sprintf "{ %s }"
+        (List.map ~f:to_string es |> String.concat ~sep:" ")
+    | Cons es ->
+      Printf.sprintf "[%s]" (List.map ~f:to_string es |> String.concat ~sep:" ")
+    | ConsWithParams (es1, es2) ->
+      Printf.sprintf "[%s | %s]"
+        (List.map ~f:to_string es1 |> String.concat ~sep:" ")
+        (List.map ~f:to_string es2 |> String.concat ~sep:" ")
+    | ConsWithBase (es, e) ->
+      Printf.sprintf "[%s|%s]"
+        (List.map ~f:to_string es |> String.concat ~sep:" ")
+        (to_string e)
+end
+
+type expr =
+  | Symbol of string
+  | Var of ident
+  | List of expr list
+[@@derive eq]
+
 let rec to_string : expr -> string = function
   | Symbol s -> s
   | Var x -> x

src/lambda.ml

@@ -0,0 +1,44 @@
+open Base
+
+type ident = string
+
+type 'a loc =
+  { content : 'a
+  ; loc : string
+  }
+
+type expr =
+  | Var of ident
+  | Fun of (ident loc * expr loc)
+  | App of (expr loc * expr loc)
+
+type env = (ident * expr) list
+
+type declaration =
+  | Let of ident * expr loc
+  | Print of ident
+
+type program = declaration list
+
+let rec to_string e =
+  match e.content with
+  | Var x -> x
+  | Fun (x, t) -> Printf.sprintf "fun %s -> %s" x.content (to_string t)
+  | App (t1, t2) -> Printf.sprintf "(%s %s)" (to_string t1) (to_string t2)
+
+let rec free_vars e =
+  match e.content with
+  | Var x -> [ x ]
+  | Fun (x, t) ->
+    List.filter (free_vars t) ~f:(fun y -> not @@ equal_string x.content y)
+  | App (t1, t2) -> free_vars t1 @ free_vars t2
+
+let rec is_linear e =
+  match e.content with
+  | Var _ -> true
+  | Fun (x, t) ->
+    is_linear t
+    && List.length
+         (List.filter (free_vars t) ~f:(fun y -> equal_string x.content y))
+       = 1
+  | App (t1, t2) -> is_linear t1 && is_linear t2