Paris7/compilation
Archived
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Activity

fmt

Browse source
This commit is contained in:
Mylloon 2023-12-10 15:45:36 +01:00
parent 90658e0155
commit 63ec3b464e
Signed by: Anri
GPG key ID: A82D63DFF8D1317F
1 changed files with 140 additions and 174 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

314
flap/src/fopix/hobixToFopix.ml
View file

@ -8,152 +8,140 @@ module S = Source.AST
module Target = Fopix module Target = Fopix
module T = Target.AST module T = Target.AST
(** (** The translation from Hobix to Fopix turns anonymous
lambda-abstractions into toplevel functions and applications into
function calls. In other words, it translates a high-level language
(like OCaml) into a first order language (like C).
The translation from Hobix to Fopix turns anonymous To do so, we follow the closure conversion technique.
lambda-abstractions into toplevel functions and applications into
function calls. In other words, it translates a high-level language
(like OCaml) into a first order language (like C).
To do so, we follow the closure conversion technique. The idea is to make explicit the construction of closures, which
represent functions as first-class objects. A closure is a block
that contains a code pointer to a toplevel function [f] followed by all
the values needed to execute the body of [f]. For instance, consider
the following OCaml code:
The idea is to make explicit the construction of closures, which let f =
represent functions as first-class objects. A closure is a block let x = 6 * 7 in
that contains a code pointer to a toplevel function [f] followed by all let z = x + 1 in
the values needed to execute the body of [f]. For instance, consider fun y -> x + y * z
the following OCaml code:
let f = The values needed to execute the function "fun y -> x + y * z" are
let x = 6 * 7 in its free variables "x" and "z". The same program with explicit usage
let z = x + 1 in of closure can be written like this:
fun y -> x + y * z
The values needed to execute the function "fun y -> x + y * z" are let g y env = env[1] + y * env[2]
its free variables "x" and "z". The same program with explicit usage let f =
of closure can be written like this: let x = 6 * 7 in
let z = x + 1 in
[| g; x; z |]
let g y env = env[1] + y * env[2] (in an imaginary OCaml in which arrays are untyped.)
let f =
let x = 6 * 7 in
let z = x + 1 in
[| g; x; z |]
(in an imaginary OCaml in which arrays are untyped.) Once closures are explicited, there are no more anonymous functions!
Once closures are explicited, there are no more anonymous functions! But, wait, how to we call such a function? Let us see that on an
example:
But, wait, how to we call such a function? Let us see that on an let f = ... (* As in the previous example *)
example: let u = f 0
let f = ... (* As in the previous example *) The application "f 0" must be turned into an expression in which
let u = f 0 "f" is a closure and the call to "f" is replaced to a call to "g"
with the proper arguments. The argument "y" of "g" is known from
the application: it is "0". Now, where is "env"? Easy! It is the
closure itself! We get:
The application "f 0" must be turned into an expression in which let g y env = env[1] + y * env[2]
"f" is a closure and the call to "f" is replaced to a call to "g" let f =
with the proper arguments. The argument "y" of "g" is known from let x = 6 * 7 in
the application: it is "0". Now, where is "env"? Easy! It is the let z = x + 1 in
closure itself! We get: [| g; x; z |]
let u = f[0] 0 f
let g y env = env[1] + y * env[2] (Remark: Did you notice that this form of "auto-application" is
let f = very similar to the way "this" is defined in object-oriented
let x = 6 * 7 in programming languages?) *)
let z = x + 1 in
[| g; x; z |]
let u = f[0] 0 f
(Remark: Did you notice that this form of "auto-application" is (** Helpers functions. *)
very similar to the way "this" is defined in object-oriented
programming languages?)
*) let error pos msg = Error.error "compilation" pos msg
(**
Helpers functions.
*)
let error pos msg =
Error.error "compilation" pos msg
let make_fresh_variable = let make_fresh_variable =
let r = ref 0 in let r = ref 0 in
fun () -> incr r; T.Id (Printf.sprintf "_%d" !r) fun () ->
incr r;
T.Id (Printf.sprintf "_%d" !r)
;;
let make_fresh_function_identifier = let make_fresh_function_identifier =
let r = ref 0 in let r = ref 0 in
fun () -> incr r; T.FunId (Printf.sprintf "_%d" !r) fun () ->
incr r;
T.FunId (Printf.sprintf "_%d" !r)
;;
let define e f = let define e f =
let x = make_fresh_variable () in let x = make_fresh_variable () in
T.Define (x, e, f x) T.Define (x, e, f x)
;;
let rec defines ds e = let rec defines ds e =
match ds with match ds with
| [] -> | [] -> e
e | (x, d) :: ds -> T.Define (x, d, defines ds e)
| (x, d) :: ds -> ;;
T.Define (x, d, defines ds e)
let seq a b = let seq a b = define a (fun _ -> b)
define a (fun _ -> b)
let rec seqs = function let rec seqs = function
| [] -> assert false | [] -> assert false
| [x] -> x | [ x ] -> x
| x :: xs -> seq x (seqs xs) | x :: xs -> seq x (seqs xs)
;;
let allocate_block e = let allocate_block e = T.(FunCall (FunId "allocate_block", [ e ]))
T.(FunCall (FunId "allocate_block", [e])) let write_block e i v = T.(FunCall (FunId "write_block", [ e; i; v ]))
let read_block e i = T.(FunCall (FunId "read_block", [ e; i ]))
let write_block e i v = let lint i = T.(Literal (LInt (Int64.of_int i)))
T.(FunCall (FunId "write_block", [e; i; v]))
let read_block e i =
T.(FunCall (FunId "read_block", [e; i]))
let lint i =
T.(Literal (LInt (Int64.of_int i)))
(** [free_variables e] returns the list of free variables that (** [free_variables e] returns the list of free variables that
occur in [e].*) occur in [e].*)
let free_variables = let free_variables =
let module M = let module M =
Set.Make (struct type t = S.identifier let compare = compare end) Set.Make (struct
type t = S.identifier
let compare = compare
end)
in in
let rec unions f = function let rec unions f = function
| [] -> M.empty | [] -> M.empty
| [s] -> f s | [ s ] -> f s
| s :: xs -> M.union (f s) (unions f xs) | s :: xs -> M.union (f s) (unions f xs)
in in
let rec fvs = function let rec fvs = function
| S.Literal _ -> | S.Literal _ -> M.empty
M.empty | S.Variable x -> M.singleton x
| S.Variable x -> | S.While (cond, e) -> failwith "Students! This is your job!"
M.singleton x | S.Define (vd, a) -> failwith "Students! This is your job!"
| S.While (cond, e) -> | S.ReadBlock (a, b) -> unions fvs [ a; b ]
failwith "Students! This is your job!" | S.Apply (a, b) -> unions fvs (a :: b)
| S.Define (vd, a) -> | S.WriteBlock (a, b, c) | S.IfThenElse (a, b, c) -> unions fvs [ a; b; c ]
failwith "Students! This is your job!" | S.AllocateBlock a -> fvs a
| S.ReadBlock (a, b) -> | S.Fun (xs, e) -> failwith "Students! This is your job!"
unions fvs [a; b]
| S.Apply (a, b) ->
unions fvs (a :: b)
| S.WriteBlock (a, b, c) | S.IfThenElse (a, b, c) ->
unions fvs [a; b; c]
| S.AllocateBlock a ->
fvs a
| S.Fun (xs, e) ->
failwith "Students! This is your job!"
| S.Switch (a, b, c) -> | S.Switch (a, b, c) ->
let c = match c with None -> [] | Some c -> [c] in let c =
unions fvs (a :: ExtStd.Array.present_to_list b @ c) match c with
| None -> []
| Some c -> [ c ]
in
unions fvs ((a :: ExtStd.Array.present_to_list b) @ c)
in in
fun e -> M.elements (fvs e) fun e -> M.elements (fvs e)
;;
(** (** A closure compilation environment relates an identifier to the way
A closure compilation environment relates an identifier to the way
it is accessed in the compiled version of the function's it is accessed in the compiled version of the function's
body. body.
@ -170,128 +158,106 @@ let free_variables =
Indeed, "x" is a local variable that can be accessed directly in Indeed, "x" is a local variable that can be accessed directly in
the compiled version of this function's body whereas "y" is a free the compiled version of this function's body whereas "y" is a free
variable whose value must be retrieved from the closure's variable whose value must be retrieved from the closure's
environment. environment. *)
type environment =
{ vars : (HobixAST.identifier, FopixAST.expression) Dict.t
; externals : (HobixAST.identifier, int) Dict.t
}
*) let initial_environment () = { vars = Dict.empty; externals = Dict.empty }
type environment = { let bind_external id n env = { env with externals = Dict.insert id n env.externals }
vars : (HobixAST.identifier, FopixAST.expression) Dict.t; let is_external id env = Dict.lookup id env.externals <> None
externals : (HobixAST.identifier, int) Dict.t; let reset_vars env = { env with vars = Dict.empty }
}
let initial_environment () =
{ vars = Dict.empty; externals = Dict.empty }
let bind_external id n env =
{ env with externals = Dict.insert id n env.externals }
let is_external id env =
Dict.lookup id env.externals <> None
let reset_vars env =
{ env with vars = Dict.empty }
(** Precondition: [is_external id env = true]. *) (** Precondition: [is_external id env = true]. *)
let arity_of_external id env = let arity_of_external id env =
match Dict.lookup id env.externals with match Dict.lookup id env.externals with
| Some n -> n | Some n -> n
| None -> assert false (* By is_external. *) | None -> assert false (* By is_external. *)
;;
(** [translate p env] turns an Hobix program [p] into a Fopix program (** [translate p env] turns an Hobix program [p] into a Fopix program
using [env] to retrieve contextual information. *) using [env] to retrieve contextual information. *)
let translate (p : S.t) env = let translate (p : S.t) env =
let rec program env defs = let rec program env defs =
let env, defs = ExtStd.List.foldmap definition env defs in let env, defs = ExtStd.List.foldmap definition env defs in
(List.flatten defs, env) List.flatten defs, env
and definition env = function and definition env = function
| S.DeclareExtern (id, n) -> | S.DeclareExtern (id, n) ->
let env = bind_external id n env in let env = bind_external id n env in
(env, [T.ExternalFunction (function_identifier id, n)]) env, [ T.ExternalFunction (function_identifier id, n) ]
| S.DefineValue vd -> | S.DefineValue vd -> env, value_definition env vd
(env, value_definition env vd)
and value_definition env = function and value_definition env = function
| S.SimpleValue (x, e) -> | S.SimpleValue (x, e) ->
let fs, e = expression (reset_vars env) e in let fs, e = expression (reset_vars env) e in
fs @ [T.DefineValue (identifier x, e)] fs @ [ T.DefineValue (identifier x, e) ]
| S.RecFunctions fdefs -> | S.RecFunctions fdefs ->
let fs, defs = define_recursive_functions fdefs in let fs, defs = define_recursive_functions fdefs in
fs @ List.map (fun (x, e) -> T.DefineValue (x, e)) defs fs @ List.map (fun (x, e) -> T.DefineValue (x, e)) defs
and define_recursive_functions rdefs = failwith "Students! This is your job!"
and define_recursive_functions rdefs =
failwith "Students! This is your job!"
and expression env = function and expression env = function
| S.Literal l -> | S.Literal l -> [], T.Literal (literal l)
[], T.Literal (literal l)
| S.While (cond, e) -> | S.While (cond, e) ->
let cfs, cond = expression env cond in let cfs, cond = expression env cond in
let efs, e = expression env e in let efs, e = expression env e in
cfs @ efs, T.While (cond, e) cfs @ efs, T.While (cond, e)
| S.Variable x -> | S.Variable x ->
let xc = let xc =
match Dict.lookup x env.vars with match Dict.lookup x env.vars with
| None -> T.Variable (identifier x) | None -> T.Variable (identifier x)
| Some e -> e | Some e -> e
in in
([], xc) [], xc
| S.Define (vdef, a) -> | S.Define (vdef, a) -> failwith "Students! This is your job!"
failwith "Students! This is your job!" | S.Apply (a, bs) -> failwith "Students! This is your job!"
| S.Apply (a, bs) ->
failwith "Students! This is your job!"
| S.IfThenElse (a, b, c) -> | S.IfThenElse (a, b, c) ->
let afs, a = expression env a in let afs, a = expression env a in
let bfs, b = expression env b in let bfs, b = expression env b in
let cfs, c = expression env c in let cfs, c = expression env c in
afs @ bfs @ cfs, T.IfThenElse (a, b, c) afs @ bfs @ cfs, T.IfThenElse (a, b, c)
| S.Fun (x, e) -> failwith "Students! This is your job!"
| S.Fun (x, e) ->
failwith "Students! This is your job!"
| S.AllocateBlock a -> | S.AllocateBlock a ->
let afs, a = expression env a in let afs, a = expression env a in
(afs, allocate_block a) afs, allocate_block a
| S.WriteBlock (a, b, c) -> | S.WriteBlock (a, b, c) ->
let afs, a = expression env a in let afs, a = expression env a in
let bfs, b = expression env b in let bfs, b = expression env b in
let cfs, c = expression env c in let cfs, c = expression env c in
afs @ bfs @ cfs, afs @ bfs @ cfs, T.FunCall (T.FunId "write_block", [ a; b; c ])
T.FunCall (T.FunId "write_block", [a; b; c])
| S.ReadBlock (a, b) -> | S.ReadBlock (a, b) ->
let afs, a = expression env a in let afs, a = expression env a in
let bfs, b = expression env b in let bfs, b = expression env b in
afs @ bfs, afs @ bfs, T.FunCall (T.FunId "read_block", [ a; b ])
T.FunCall (T.FunId "read_block", [a; b])
| S.Switch (a, bs, default) -> | S.Switch (a, bs, default) ->
let afs, a = expression env a in let afs, a = expression env a in
let bsfs, bs = let bsfs, bs =
ExtStd.List.foldmap (fun bs t -> ExtStd.List.foldmap
match ExtStd.Option.map (expression env) t with (fun bs t ->
| None -> (bs, None) match ExtStd.Option.map (expression env) t with
| Some (bs', t') -> (bs @ bs', Some t') | None -> bs, None
) [] (Array.to_list bs) | Some (bs', t') -> bs @ bs', Some t')
[]
(Array.to_list bs)
in in
let dfs, default = match default with let dfs, default =
match default with
| None -> [], None | None -> [], None
| Some e -> let bs, e = expression env e in bs, Some e | Some e ->
let bs, e = expression env e in
bs, Some e
in in
afs @ bsfs @ dfs, afs @ bsfs @ dfs, T.Switch (a, Array.of_list bs, default)
T.Switch (a, Array.of_list bs, default)
and expressions env = function and expressions env = function
| [] -> | [] -> [], []
[], []
| e :: es -> | e :: es ->
let efs, es = expressions env es in let efs, es = expressions env es in
let fs, e = expression env e in let fs, e = expression env e in
fs @ efs, e :: es fs @ efs, e :: es
and literal = function and literal = function
| S.LInt x -> T.LInt x | S.LInt x -> T.LInt x
| S.LString s -> T.LString s | S.LString s -> T.LString s
| S.LChar c -> T.LChar c | S.LChar c -> T.LChar c
and identifier (S.Id x) = T.Id x and identifier (S.Id x) = T.Id x
and function_identifier (S.Id x) = T.FunId x in
and function_identifier (S.Id x) = T.FunId x
in
program env p program env p
;;