Last active
March 24, 2022 08:04
-
-
Save zehnpaard/582a9b5218f9dd406ab0853542289252 to your computer and use it in GitHub Desktop.
ANF to CPS conversion in OCaml
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
module A = Ast | |
let n = ref (-1) | |
let genid s = incr n; s ^ "." ^ string_of_int !n | |
let find = List.assoc | |
let rec g env e = match e with | |
| A.Int _ -> e | |
| A.Bool _ -> e | |
| A.Add(e1,e2) -> A.Add(g env e1, g env e2) | |
| A.Lt(e1,e2) -> A.Lt(g env e1, g env e2) | |
| A.Var s -> A.Var(find s env) | |
| A.Let(s,e1,e2) -> | |
let s' = genid s in | |
A.Let(s', g env e1, g ((s,s')::env) e2) | |
| A.If(e1,e2,e3) -> A.If(g env e1, g env e2, g env e3) | |
| A.Fn(ss,e) -> | |
let ss' = List.map genid ss in | |
A.Fn(ss', g ((List.combine ss ss') @ env) e) | |
| A.Call(e,es) -> A.Call(g env e, List.map (g env) es) | |
let f = g [] |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
open Ast | |
let rec is_value = function | |
| Int _ | Bool _ | Var _ -> true | |
| Fn(_,e) -> is_cps e | |
| _ -> false | |
and is_atomic = function | |
| Add(e1,e2) | Lt(e1,e2) -> is_value e1 && is_value e2 | |
| e -> is_value e | |
and is_cps = function | |
| If(e1,e2,e3) -> is_atomic e1 && is_cps e2 && is_cps e3 | |
| Call(f,es) -> List.fold_left (fun a b -> a && is_atomic b) (is_atomic f) es | |
| e -> is_atomic e | |
let n = ref (-1) | |
let gensym s = incr n; "k" ^ s ^ string_of_int !n | |
let rec transform_m = function | |
| Fn(ss,e) -> let k = gensym "" in Fn(ss@[k],(transform_t e (Var k))) | |
| e -> e | |
and transform_t e k = match e with | |
| Fn _ | Var _ | Int _ | Bool _ | Add _ | Lt _ -> Call(k,[transform_m e]) | |
| Call(f,es) -> | |
let f = transform_m f in | |
let es = List.map transform_m es in | |
Call(f,es@[k]) | |
| Let(s,e1,e2) -> transform_t e1 (Fn([s], transform_t e2 k)) | |
| If(e1,e2,e3) -> If(e1, transform_t e2 k, transform_t e3 k) | |
let f e = transform_t e (let kv = gensym "v" in Fn([kv],Var(kv))) |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
module A = Ast | |
let n = ref (-1) | |
let gensym () = incr n; "g" ^ string_of_int !n | |
let is_value = function | |
| A.Int _ | A.Bool _ | A.Var _ | A.Fn _ -> true | |
| A.Add _ | A.Lt _ | A.Let _ | A.If _ | A.Call _ -> false | |
let id x = x | |
let rec normalize m k = match m with | |
| A.Let(v,e1,e2) -> | |
normalize e1 (fun x -> | |
A.Let(v,x, normalize e2 k)) | |
| A.If(e1,e2,e3) -> | |
normalize_name e1 (fun x -> | |
k (A.If(x, normalize e2 id, normalize e3 id))) | |
| A.Add(e1,e2) -> | |
normalize_name e1 (fun x -> | |
normalize_name e2 (fun y -> | |
k (A.Add(x,y)))) | |
| A.Lt(e1,e2) -> | |
normalize_name e1 (fun x -> | |
normalize_name e2 (fun y -> | |
k (A.Lt(x,y)))) | |
| A.Fn(vs,e) -> | |
k (A.Fn(vs,normalize e id)) | |
| A.Call(e,es) -> | |
normalize_name e (fun x -> | |
normalize_names es (fun ys -> | |
k (A.Call(x,ys)))) | |
| _ -> k m | |
and normalize_name m k = | |
normalize m (fun n -> | |
if is_value(n) then k n | |
else let g = gensym () in A.Let(g,n,k (A.Var g))) | |
and normalize_names ms k = match ms with | |
| [] -> k [] | |
| m::ms -> | |
normalize_name m (fun n -> | |
normalize_names ms (fun ns -> k (n::ns))) | |
let f m = normalize m id |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
type t = | |
| Int of int | |
| Bool of bool | |
| Add of t * t | |
| Lt of t * t | |
| Var of string | |
| Let of string * t * t | |
| If of t * t * t | |
| Fn of string list * t | |
| Call of t * t list | |
let rec to_string = function | |
| Int n -> string_of_int n | |
| Bool b -> string_of_bool b | |
| Add(n, m) -> "(+ " ^ to_string n ^ " " ^ to_string m ^ ")" | |
| Lt(n, m) -> "(< " ^ to_string n ^ " " ^ to_string m ^ ")" | |
| Var s -> s | |
| Let(v,e1,e2) -> "(let [" ^ v ^ " " ^ to_string e1 ^ "] " ^ to_string e2 ^ ")" | |
| If(e1,e2,e3) -> "(if " ^ to_string e1 ^ " " ^ to_string e2 ^ " " ^ to_string e3 ^ ")" | |
| Fn(vs,e) -> | |
let vs' = String.concat " " vs in | |
"(fn [" ^ vs' ^ "] " ^ to_string e ^ ")" | |
| Call(e,es) -> | |
let es' = String.concat " " @@ List.map to_string es in | |
"(" ^ to_string e ^ " " ^ es' ^ ")" |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
{ | |
open Parser | |
} | |
let digit = ['0'-'9'] | |
let number = '-'? digit digit* | |
let whitespace = ['\t' ' ' '\n'] | |
let alpha = ['a'-'z''A'-'Z'] | |
let var = alpha (alpha|digit)* | |
rule f = parse | |
| whitespace+ { f lexbuf } | |
| "(" { LPAREN } | |
| ")" { RPAREN } | |
| "[" { LBRACK } | |
| "]" { RBRACK } | |
| "+" { PLUS } | |
| "<" { LT } | |
| "let" { LET } | |
| "if" { IF } | |
| "fn" { FN } | |
| "true" { TRUE } | |
| "false" { FALSE } | |
| number as n { INT (int_of_string n ) } | |
| var as s { VAR s } | |
| eof { EOF } |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
let f s = | |
Lexing.from_string s | |
|> Parser.f Lexer.f | |
|> Alpha.f | |
|> Anormal.f | |
let () = | |
let e = read_line () |> f in | |
e |> Ast.to_string |> print_endline; | |
e |> Anftocps.f |> Ast.to_string |> print_endline; | |
e |> Anftocps.f |> Anftocps.is_cps |> string_of_bool |> print_endline; |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
%{ | |
open Ast | |
%} | |
%token LPAREN | |
%token RPAREN | |
%token LBRACK | |
%token RBRACK | |
%token <string> VAR | |
%token EOF | |
%token <int> INT | |
%token PLUS | |
%token LET | |
%token TRUE | |
%token FALSE | |
%token LT | |
%token IF | |
%token FN | |
%start <Ast.t> f | |
%% | |
f: | |
| expr EOF { $1 } | |
expr: | |
| INT { Int $1 } | |
| TRUE { Bool true } | |
| FALSE { Bool false } | |
| VAR { Var $1 } | |
| LPAREN PLUS expr expr RPAREN { Add ($3, $4) } | |
| LPAREN LT expr expr RPAREN { Lt ($3, $4) } | |
| LPAREN LET LBRACK VAR expr RBRACK expr RPAREN { Let($4, $5, $7)} | |
| LPAREN IF expr expr expr RPAREN { If($3, $4, $5)} | |
| LPAREN FN LBRACK list(VAR) RBRACK expr RPAREN { Fn($4, $6)} | |
| LPAREN expr list(expr) RPAREN { Call($2, $3) } |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment