diff --git a/flap/src/fopix/hobixToFopix.ml b/flap/src/fopix/hobixToFopix.ml index 478622a..ba84a84 100644 --- a/flap/src/fopix/hobixToFopix.ml +++ b/flap/src/fopix/hobixToFopix.ml @@ -8,152 +8,161 @@ 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 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 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))) +(* Liste de fonction prédéfini par le code, que l'on retrouve dans les tests *) +let fonction_predef = + [ "print_string"; "equal_string"; "equal_char"; "observe_int"; "print_int" ] +;; +(* On regarde si la fonction est prédéfini : + - soit par des noms + - soit par des opérations binaires *) +let is_a_predefined_function (S.Id op) = + FopixInterpreter.is_binary_primitive op || List.mem op fonction_predef +;; (** [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 + (* Une variable libre est une variable qui peut être substitué *) 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.Literal _ -> M.empty + (* Si la fonction est prédéfini, alors ce n'est pas une variable libre. *) + | S.Variable x -> if is_a_predefined_function x then M.empty else M.singleton x + | S.While (cond, e) -> unions fvs [ cond; e ] | 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!" + let liste_def_valeur = + match vd with + | S.SimpleValue (id, expr) -> [ id, expr ] + | S.RecFunctions list -> list + in + let id, expr = List.split liste_def_valeur in + M.diff (unions fvs (a :: expr)) (M.of_list id) + | 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) -> M.diff (fvs e) (M.of_list xs) | 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 +179,300 @@ 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 } +let bind_var env id expr = { env with vars = Dict.insert id expr env.vars } (** 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 env fdefs in + fs @ List.map (fun (x, e) -> T.DefineValue (x, e)) defs + (* Ce qu'il faut faire dans le cadre des fonctions mutuellement récursives : + - On récupère la liste des fonctions + - On créé des clotures pour chaque récursion + - On traduit chaque fonction mutuellement récursive en appel + de fonction anonyme + - On finit par combiner chaque liste de définition, + celle des la fonction de base, puis celle des des fonctions traduites. *) + and define_recursive_functions env rdefs = + (* On récupère d'abord les informations qui nous intéresse : + nom, variables libres, arguments, et le corps de la fonction récursive *) + let rdefs = + let rname = List.map fst rdefs in + let free_vars f = + match f with + | S.Fun (id, expr) -> + let new_id = id @ rname in + let lfree_vars = free_variables (S.Fun (new_id, expr)) in + lfree_vars, id, expr + | _ -> failwith "Error recFunctions : This is not a function" + in + List.map (fun (name, expr) -> name, free_vars expr) rdefs + in + (* On regarde si la fonction recursive est seule, si c'est le cas, on traite + le cas simple d'une fonction anonyme seul. *) + match rdefs with + | [ (name, (free_vars, arguments, expr)) ] -> + let defs, expre = fonction_anonyme env ~name free_vars arguments expr in + defs, [ identifier name, expre ] + | _ -> + (* Sinon, on créé des clotures pour chaque fonction de + nos fonctions récursives *) + let rdefs = creation_cloture_rec rdefs in + let fs, rdefs = List.split rdefs in + (* Puis on les traduit toute les fonctions *) + let trad_rdef = trad_rec_definition rdefs in + let fs', exprs = List.split trad_rdef in + fs @ List.concat fs', exprs + (* Fonction qui créé des clotures pour chaque récursion *) + and creation_cloture_rec rdefs = + let nb = List.length rdefs - 1 in + List.map + (fun (name, (free_vars, x, e)) -> + let new_name = make_fresh_variable () in + ( T.DefineValue (new_name, new_cloture nb free_vars) + , ((name, new_name), (free_vars, x, e)) )) + rdefs + (* Fonction qui traduit chaque fonction en appel de fonction anonyme + mais également le nom en identifiant de fonction pour fopix. *) + and trad_rec_definition rdefs = + let rname = List.map fst rdefs in + List.map + (fun ((name, new_name), (fv, x, e)) -> + let names = List.filter (fun (xi, _) -> xi != name) rname in + let defs, expr = fonction_anonyme ~name ~block:(new_name, names) env fv x e in + defs, (identifier name, expr)) + rdefs 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) + [], xc | S.Define (vdef, a) -> - failwith "Students! This is your job!" - | S.Apply (a, bs) -> - failwith "Students! This is your job!" + let afs, a = expression env a in + (match vdef with + | S.SimpleValue (id, b) -> + let bfs, b = expression env b in + afs @ bfs, T.Define (identifier id, a, b) + | S.RecFunctions rdefs -> + let fs, defs = define_recursive_functions env rdefs in + afs @ fs, defines defs a) + | S.Apply (a, bs) -> apply env a bs | 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) as f -> fonction_anonyme env (free_variables f) x e | 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 - + and old_env = make_fresh_variable () + and curr_env = make_fresh_variable () + (* Ici, on rajoute notre fonction anonyme dans la liste des + définitions de fonctions *) + and add_liste_funcdef env fid x expr = + let dfs, expr = expression env expr in + let dfs, expr = + let aux x (xs, acc) = + match x with + | T.DefineValue (id, exp) -> xs, T.Define (id, exp, acc) + | x -> x :: xs, acc + in + List.fold_right aux dfs ([], expr) + in + dfs @ [ T.DefineFunction (fid, old_env :: x, expr) ] + (* Traitement des fonctions anonymes *) + and fonction_anonyme ?name ?block env f x e = + (* On commence par générer de nouveaux identifiants pour nos fonctions *) + let fname = make_fresh_function_identifier () in + (* On traduit l'id de chaque argument *) + let arguments_x = List.map identifier x in + (* On créé la cloture pour notre fonction anonyme *) + let cloture, env = creation_cloture env name block fname f in + (* On met à jour la liste des définitions de fonctions *) + let dfs = add_liste_funcdef env fname arguments_x e in + dfs, cloture + and creation_cloture env name block fname free_vars = + let env = + match name with + | None -> env + | Some name -> bind_var env name (T.Variable old_env) + in + match block with + | None -> + (* Cas où on a une simple fonction anonyme *) + let new_clot = new_cloture 0 free_vars in + let blocks, env = add_to_cloture env fname (T.Variable curr_env) free_vars [] in + T.Define (curr_env, new_clot, blocks), env + | Some (block, rdefs) -> + (* Cas pour les fonctions mutuellements récursive *) + add_to_cloture env fname (T.Variable block) free_vars rdefs + (* Fonction qui initialise une cloture de taille espace + + la taille de la liste de variable (le nombre de variable libre) *) + and new_cloture espace list_variable = + allocate_block (lint (espace + List.length list_variable + 1)) + (* Fonction qui rajoute à la cloture l'ensemble de variable libres *) + and add_to_cloture env fname env_var free_vars rdefs = + (* On commence d'abord par écrire dans le premier bloc le nom de + la fonction fopix *) + let first_block = write_block env_var (lint 0) (T.Literal (T.LFun fname)) in + (* Ensuite, on s'occupe d'écrire dans chaque bloc de notre cloture + les variables libres *) + let env, vars_free, k = + List.fold_left + (fun (env, list, k) id -> + (* Pour chaque élément de la liste ... + On commence par lié la variable dans le nouvelle environnement + qui se trouve dans l'ancien environnement *) + let curr_env = bind_var env id (read_block (T.Variable old_env) (lint k)) in + (* On cherche la valeur de la variable dans + le dictionnaire du programme *) + let new_valeur = + match Dict.lookup id env.vars with + | None -> T.Variable (identifier id) + | Some v -> v + in + (* Enfin, on écrit dans notre cloture la valeur de la variable libre + à la position k *) + let new_instr = write_block env_var (lint k) new_valeur in + (* On rappelle notre fonction avec le nouvelle environnement, + en rajoutant notre instruction à la liste d'instruction, + et en incrémentant l'index *) + curr_env, new_instr :: list, k + 1) + (* On commence notre fonction avec l'env de base, + la liste d'instruction vide et l'indice à 1 + (0 étant l'initialisation du début) *) + (env, [], 1) + free_vars + in + (* Dans le cas d'une récursion, on rajoute chaque fonction dans l'env et + à la liste d'instruction*) + let env, vars_fun, _ = + List.fold_left + (fun (env, list, k) (id, id_var) -> + let curr_env = bind_var env id (read_block (T.Variable old_env) (lint k)) in + let new_instr = write_block env_var (lint k) (T.Variable id_var) in + curr_env, new_instr :: list, k + 1) + (* On commence avec k car on a mis k variables libres juste avant *) + (env, [], k) + rdefs + in + (* On créé une séquence d'instructions contenant + le premier bloc et la suite *) + let instrs = List.rev ((env_var :: first_block :: vars_free) @ vars_fun) in + seqs instrs, env + (* Revoir les explications c'est pas clair *) + and apply env f arguments = + (* D'abord, on traduit chaque arguments *) + let defs_args, trad_arguments = expressions env arguments in + (* On créé un FunCall en fonction de f *) + match f with + | S.Variable x when Dict.lookup x env.externals <> None || is_a_predefined_function x + -> + (* Si f est une externe fonction, on créé directement un FunCall *) + [], T.FunCall (function_identifier x, trad_arguments) + | _ -> + (* Sinon, ça veut dire que nous l'avons défini au préalable *) + (* On traduit la fonction *) + let defs_func, func = expression env f in + (* On récupère le nom de fonction et son expression *) + let fname, func_expr = + match func with + | T.Variable x -> x, fun x -> x + | _ -> + let fname = make_fresh_variable () in + fname, fun x -> T.Define (fname, func, x) + in + (* On récupère le pointeur qui pointe vers la première case + de la fonction *) + let get_pointer = read_block (T.Variable fname) (lint 0) in + (* On récupère l'appelle de la fonction *) + let defs_call = + func_expr (T.UnknownFunCall (get_pointer, T.Variable fname :: trad_arguments)) + in + (* Enfin, on concatène toute les parties de la fonction + (la traduction de tout les arguments) *) + let defs = defs_func @ defs_args in + (* Et on renvoie la def de la fonction ainsi que l'appel *) + defs, defs_call in program env p +;;