diff --git a/flap/src/fopix/hobixToFopix.ml b/flap/src/fopix/hobixToFopix.ml index 478622a..d49fe01 100644 --- a/flap/src/fopix/hobixToFopix.ml +++ b/flap/src/fopix/hobixToFopix.ml @@ -8,152 +8,140 @@ module S = Source.AST module Target = Fopix 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 - 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. - 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 - 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: + let f = + let x = 6 * 7 in + let z = x + 1 in + fun y -> x + y * z - let f = - let x = 6 * 7 in - let z = x + 1 in - fun y -> x + y * z + The values needed to execute the function "fun y -> x + y * z" are + its free variables "x" and "z". The same program with explicit usage + of closure can be written like this: - The values needed to execute the function "fun y -> x + y * z" are - its free variables "x" and "z". The same program with explicit usage - of closure can be written like this: + let g y env = env[1] + y * env[2] + let f = + let x = 6 * 7 in + let z = x + 1 in + [| g; x; z |] - let g y env = env[1] + y * env[2] - let f = - let x = 6 * 7 in - let z = x + 1 in - [| g; x; z |] + (in an imaginary OCaml in which arrays are untyped.) - (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 - example: + let f = ... (* As in the previous example *) + let u = f 0 - let f = ... (* As in the previous example *) - let u = f 0 + The application "f 0" must be turned into an expression in which + "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 - "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: + let g y env = env[1] + y * env[2] + let f = + let x = 6 * 7 in + let z = x + 1 in + [| g; x; z |] + let u = f[0] 0 f - let g y env = env[1] + y * env[2] - let f = - let x = 6 * 7 in - 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 + very similar to the way "this" is defined in object-oriented + programming languages?) *) - (Remark: Did you notice that this form of "auto-application" is - very similar to the way "this" is defined in object-oriented - programming languages?) +(** Helpers functions. *) -*) - -(** - Helpers functions. -*) - -let error pos msg = - Error.error "compilation" pos msg +let error pos msg = Error.error "compilation" pos msg let make_fresh_variable = 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 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 x = make_fresh_variable () in T.Define (x, e, f x) +;; let rec defines ds e = match ds with - | [] -> - e - | (x, d) :: ds -> - T.Define (x, d, defines ds e) + | [] -> e + | (x, d) :: ds -> T.Define (x, d, defines ds e) +;; -let seq a b = - define a (fun _ -> b) +let seq a b = define a (fun _ -> b) let rec seqs = function | [] -> assert false - | [x] -> x + | [ x ] -> x | x :: xs -> seq x (seqs xs) +;; -let 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 lint i = - T.(Literal (LInt (Int64.of_int i))) - +let 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 lint i = T.(Literal (LInt (Int64.of_int i))) (** [free_variables e] returns the list of free variables that - occur in [e].*) + occur in [e].*) let free_variables = 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 let rec unions f = function | [] -> M.empty - | [s] -> f s + | [ s ] -> f s | s :: xs -> M.union (f s) (unions f xs) in let rec fvs = function - | S.Literal _ -> - M.empty - | S.Variable x -> - M.singleton x - | S.While (cond, e) -> - failwith "Students! This is your job!" - | S.Define (vd, a) -> - failwith "Students! This is your job!" - | S.ReadBlock (a, b) -> - 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.Literal _ -> M.empty + | S.Variable x -> M.singleton x + | S.While (cond, e) -> failwith "Students! This is your job!" + | S.Define (vd, a) -> failwith "Students! This is your job!" + | S.ReadBlock (a, b) -> 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) -> - let c = match c with None -> [] | Some c -> [c] in - unions fvs (a :: ExtStd.Array.present_to_list b @ c) + let c = + match c with + | None -> [] + | Some c -> [ c ] + in + unions fvs ((a :: ExtStd.Array.present_to_list b) @ c) in 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 body. @@ -170,128 +158,106 @@ let free_variables = 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 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 + } -*) -type environment = { - vars : (HobixAST.identifier, FopixAST.expression) Dict.t; - externals : (HobixAST.identifier, int) Dict.t; -} - -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 } +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]. *) let arity_of_external id env = match Dict.lookup id env.externals with - | Some n -> n - | None -> assert false (* By is_external. *) - + | Some n -> n + | None -> assert false (* By is_external. *) +;; (** [translate p env] turns an Hobix program [p] into a Fopix program using [env] to retrieve contextual information. *) let translate (p : S.t) env = let rec program env defs = let env, defs = ExtStd.List.foldmap definition env defs in - (List.flatten defs, env) + List.flatten defs, env and definition env = function | S.DeclareExtern (id, n) -> - let env = bind_external id n env in - (env, [T.ExternalFunction (function_identifier id, n)]) - | S.DefineValue vd -> - (env, value_definition env vd) + let env = bind_external id n env in + env, [ T.ExternalFunction (function_identifier id, n) ] + | S.DefineValue vd -> env, value_definition env vd and value_definition env = function | S.SimpleValue (x, e) -> - let fs, e = expression (reset_vars env) e in - fs @ [T.DefineValue (identifier x, e)] + let fs, e = expression (reset_vars env) e in + fs @ [ T.DefineValue (identifier x, e) ] | S.RecFunctions fdefs -> - let fs, defs = define_recursive_functions fdefs in - fs @ List.map (fun (x, e) -> T.DefineValue (x, e)) defs - - and define_recursive_functions rdefs = - failwith "Students! This is your job!" + let fs, defs = define_recursive_functions fdefs in + fs @ List.map (fun (x, e) -> T.DefineValue (x, e)) defs + and define_recursive_functions rdefs = failwith "Students! This is your job!" and expression env = function - | S.Literal l -> - [], T.Literal (literal l) + | S.Literal l -> [], T.Literal (literal l) | S.While (cond, e) -> - let cfs, cond = expression env cond in - let efs, e = expression env e in - cfs @ efs, T.While (cond, e) + let cfs, cond = expression env cond in + let efs, e = expression env e in + cfs @ efs, T.While (cond, e) | S.Variable x -> let xc = match Dict.lookup x env.vars with - | None -> T.Variable (identifier x) - | Some e -> e + | None -> T.Variable (identifier x) + | Some e -> e in - ([], xc) - | S.Define (vdef, a) -> - failwith "Students! This is your job!" - | S.Apply (a, bs) -> - failwith "Students! This is your job!" + [], xc + | S.Define (vdef, a) -> failwith "Students! This is your job!" + | S.Apply (a, bs) -> failwith "Students! This is your job!" | S.IfThenElse (a, b, c) -> let afs, a = expression env a in let bfs, b = expression env b in let cfs, c = expression env c in 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 -> let afs, a = expression env a in - (afs, allocate_block a) + afs, allocate_block a | S.WriteBlock (a, b, c) -> let afs, a = expression env a in let bfs, b = expression env b in let cfs, c = expression env c in - afs @ bfs @ cfs, - T.FunCall (T.FunId "write_block", [a; b; c]) + afs @ bfs @ cfs, T.FunCall (T.FunId "write_block", [ a; b; c ]) | S.ReadBlock (a, b) -> let afs, a = expression env a in let bfs, b = expression env b in - afs @ bfs, - T.FunCall (T.FunId "read_block", [a; b]) + afs @ bfs, T.FunCall (T.FunId "read_block", [ a; b ]) | S.Switch (a, bs, default) -> let afs, a = expression env a in let bsfs, bs = - ExtStd.List.foldmap (fun bs t -> - match ExtStd.Option.map (expression env) t with - | None -> (bs, None) - | Some (bs', t') -> (bs @ bs', Some t') - ) [] (Array.to_list bs) + ExtStd.List.foldmap + (fun bs t -> + match ExtStd.Option.map (expression env) t with + | None -> bs, None + | Some (bs', t') -> bs @ bs', Some t') + [] + (Array.to_list bs) in - let dfs, default = match default with + let dfs, default = + match default with | 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 - afs @ bsfs @ dfs, - T.Switch (a, Array.of_list bs, default) - - + afs @ bsfs @ dfs, T.Switch (a, Array.of_list bs, default) and expressions env = function - | [] -> - [], [] + | [] -> [], [] | e :: es -> - let efs, es = expressions env es in - let fs, e = expression env e in - fs @ efs, e :: es - + let efs, es = expressions env es in + let fs, e = expression env e in + fs @ efs, e :: es and literal = function | S.LInt x -> T.LInt x | S.LString s -> T.LString s | S.LChar c -> T.LChar c - 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 +;;