Merge branch 'jalon4'

This commit is contained in:
Mylloon 2023-12-18 19:33:51 +01:00
commit 38ab723583
Signed by: Anri
GPG key ID: A82D63DFF8D1317F

View file

@ -8,9 +8,7 @@ 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
The translation from Hobix to Fopix turns anonymous
lambda-abstractions into toplevel functions and applications into lambda-abstractions into toplevel functions and applications into
function calls. In other words, it translates a high-level language function calls. In other words, it translates a high-level language
(like OCaml) into a first order language (like C). (like OCaml) into a first order language (like C).
@ -63,97 +61,108 @@ module T = Target.AST
(Remark: Did you notice that this form of "auto-application" is (Remark: Did you notice that this form of "auto-application" is
very similar to the way "this" is defined in object-oriented very similar to the way "this" is defined in object-oriented
programming languages?) programming languages?) *)
*) (** Helpers functions. *)
(** 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 lint i = T.(Literal (LInt (Int64.of_int i)))
let write_block e i v = (* Liste de fonction prédéfini par le code, que l'on retrouve dans les tests *)
T.(FunCall (FunId "write_block", [e; i; v])) let fonction_predef =
[ "print_string"; "equal_string"; "equal_char"; "observe_int"; "print_int" ]
let read_block e i = ;;
T.(FunCall (FunId "read_block", [e; i]))
let lint i =
T.(Literal (LInt (Int64.of_int i)))
(* 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 (** [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
(* Une variable libre est une variable qui peut être substitué *)
let rec fvs = function let rec fvs = function
| S.Literal _ -> | S.Literal _ -> M.empty
M.empty (* Si la fonction est prédéfini, alors ce n'est pas une variable libre. *)
| S.Variable x -> | S.Variable x -> if is_a_predefined_function x then M.empty else M.singleton x
M.singleton x | S.While (cond, e) -> unions fvs [ cond; e ]
| S.While (cond, e) ->
failwith "Students! This is your job!"
| S.Define (vd, a) -> | S.Define (vd, a) ->
failwith "Students! This is your job!" let liste_def_valeur =
| S.ReadBlock (a, b) -> match vd with
unions fvs [a; b] | S.SimpleValue (id, expr) -> [ id, expr ]
| S.Apply (a, b) -> | S.RecFunctions list -> list
unions fvs (a :: b) in
| S.WriteBlock (a, b, c) | S.IfThenElse (a, b, c) -> let id, expr = List.split liste_def_valeur in
unions fvs [a; b; c] M.diff (unions fvs (a :: expr)) (M.of_list id)
| S.AllocateBlock a -> | S.ReadBlock (a, b) -> unions fvs [ a; b ]
fvs a | S.Apply (a, b) -> unions fvs (a :: b)
| S.Fun (xs, e) -> | 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.Fun (xs, e) -> M.diff (fvs e) (M.of_list xs)
| 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,58 +179,101 @@ 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
type environment = { ; externals : (HobixAST.identifier, int) Dict.t
vars : (HobixAST.identifier, FopixAST.expression) Dict.t;
externals : (HobixAST.identifier, int) Dict.t;
} }
let initial_environment () = let initial_environment () = { vars = Dict.empty; externals = Dict.empty }
{ 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 bind_external id n env = let reset_vars env = { env with vars = Dict.empty }
{ env with externals = Dict.insert id n env.externals } let bind_var env id expr = { env with vars = Dict.insert id expr env.vars }
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 env fdefs in
fs @ List.map (fun (x, e) -> T.DefineValue (x, e)) defs fs @ List.map (fun (x, e) -> T.DefineValue (x, e)) defs
(* Ce qu'il faut faire dans le cadre des fonctions mutuellement récursives :
and define_recursive_functions rdefs = - On récupère la liste des fonctions
failwith "Students! This is your job!" - 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 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
@ -232,66 +284,195 @@ let translate (p : S.t) env =
| 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!" let afs, a = expression env a in
| S.Apply (a, bs) -> (match vdef with
failwith "Students! This is your job!" | 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) -> | 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) as f -> fonction_anonyme env (free_variables f) x e
| 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
(fun bs t ->
match ExtStd.Option.map (expression env) t with match ExtStd.Option.map (expression env) t with
| None -> (bs, None) | None -> bs, None
| Some (bs', t') -> (bs @ bs', Some t') | Some (bs', t') -> bs @ bs', Some t')
) [] (Array.to_list bs) []
(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 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 in
program env p program env p
;;