Merge branch 'jalon4'

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
+    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 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
-      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
   | [] -> assert false
-  | [x] -> x
+  | [ x ] -> x
   | 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
-     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 _ ->
+    | 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) ->
-       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) ->
-       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
   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
+  }
 
-*)
+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 bind_var env id expr = { env with vars = Dict.insert id expr env.vars }
-
-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
+  | 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
     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
+      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
     | 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 ->
-       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
-    | S.Literal l ->
+    | S.Literal l -> [], T.Literal (literal l)
-      [], T.Literal (literal l)
     | 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 ->
       let xc =
         match Dict.lookup x env.vars with
-          | None -> T.Variable (identifier x)
+        | None -> T.Variable (identifier x)
-          | Some e -> e
+        | Some e -> e
       in
-      ([], xc)
+      [], xc
     | 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) ->
       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) as f -> fonction_anonyme env (free_variables f) x e
-    | 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,
+      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) ->
       let afs, a = expression env a 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) ->
       let afs, a = expression env a in
       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
-      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,
+      afs @ bsfs @ dfs, T.Switch (a, Array.of_list bs, default)
-      T.Switch (a, Array.of_list bs, default)
-
-
   and expressions env = function
-    | [] ->
+    | [] -> [], []
-       [], []
     | 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
     | 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
+;;