From 8e508820afd6d8ce6985256547158050f9d27620 Mon Sep 17 00:00:00 2001 From: RozhkovAleksandr Date: Mon, 3 Mar 2025 23:32:06 +0300 Subject: [PATCH 01/92] make beta-ast in pattern_elim --- FML/lib/anf/pattern_elim.ml | 119 ++++++++++++++++++++++++++++++++++++ FML/lib/dune | 2 +- 2 files changed, 120 insertions(+), 1 deletion(-) create mode 100644 FML/lib/anf/pattern_elim.ml diff --git a/FML/lib/anf/pattern_elim.ml b/FML/lib/anf/pattern_elim.ml new file mode 100644 index 000000000..fc52513a9 --- /dev/null +++ b/FML/lib/anf/pattern_elim.ml @@ -0,0 +1,119 @@ +(** Copyright 2024-2025, Dmitry Pilyuk, Aleksandr Rozhkov *) + +(** SPDX-License-Identifier: LGPL-2.1 *) + +open Ast + +type pe_const = + | Pe_Cint of int + | Pe_CBool of bool + +type pe_expr = + | Pe_EUnit + | Pe_ENill + | Pe_EIdentifier of string + | Pe_EConst of pe_const + | Pe_EVar of string + | Pe_EIf of pe_expr * pe_expr * pe_expr + | Pe_EFun of string list * pe_expr + | Pe_EApp of pe_expr * pe_expr + | Pe_ELet of pe_str_item * pe_expr + | Pe_ECons of pe_expr * pe_expr + | Pe_ETuple of pe_expr list + +and pe_str_item = + | Pe_Nonrec of string * pe_expr + | Pe_Rec of (string * pe_expr) list + +type pe_structure = pe_str_item list + +let const_to_str = function + | Pe_CBool b -> if b then "true" else "false" + | Pe_Cint i -> Format.sprintf "%i" i +;; + +let rec expr_to_str = function + | Pe_EUnit -> "()" + | Pe_ENill -> "[]" + | Pe_EIdentifier a -> a + | Pe_EConst c -> const_to_str c + | Pe_EVar id -> id + | Pe_EIf (e1, e2, e3) -> + Format.sprintf + "if %s\nthen %s\nelse %s" + (expr_to_str e1) + (expr_to_str e2) + (expr_to_str e3) + | Pe_EFun (args, e) -> + Format.sprintf + "(fun%s -> %s)" + (List.fold_left (fun acc name -> acc ^ " " ^ name) "" args) + (expr_to_str e) + | Pe_EApp (e1, e2) -> Format.sprintf "(%s %s)" (expr_to_str e1) (expr_to_str e2) + | Pe_ELet (Pe_Nonrec (name, e1), e2) -> + Format.sprintf "let %s = %s in\n%s" name (expr_to_str e1) (expr_to_str e2) + | Pe_ELet (Pe_Rec decl_list, e2) -> + let name1, e1 = List.hd decl_list in + let tl = List.tl decl_list in + Format.sprintf "let rec %s = %s" name1 (expr_to_str e1) + ^ List.fold_left + (fun acc (name, e) -> acc ^ Format.sprintf " and %s = %s" name (expr_to_str e)) + "" + tl + ^ Format.sprintf " in\n%s" (expr_to_str e2) + | Pe_ECons (e1, e2) -> Format.sprintf "(%s::%s)" (expr_to_str e1) (expr_to_str e2) + | Pe_ETuple e_list -> + Format.sprintf + "(%s)" + (expr_to_str (List.hd e_list) + ^ List.fold_left + (fun acc e -> acc ^ Format.sprintf ", %s" (expr_to_str e)) + "" + (List.tl e_list)) +;; + +let decl_to_str = function + | Pe_Nonrec (name, e) -> Format.sprintf "let %s = %s" name (expr_to_str e) + | Pe_Rec decl_list -> + let name1, e1 = List.hd decl_list in + let tl = List.tl decl_list in + Format.sprintf "let rec %s = %s" name1 (expr_to_str e1) + ^ List.fold_left + (fun acc (name, e) -> acc ^ Format.sprintf "\nand %s = %s" name (expr_to_str e)) + "" + tl +;; + +let pp_pe_expr ppf expr = Format.fprintf ppf "%s" (expr_to_str expr) + +let pp_pe_structure ppf p = + let len = List.length p in + List.iteri + (fun i a -> + if i = len - 1 + then Format.fprintf ppf "%s" (decl_to_str a) + else Format.fprintf ppf "%s\n\n" (decl_to_str a)) + p +;; + +type value_to_get = + | Tuple of int + | Cons_head + | Cons_tail + | Other + +let get_element e = function + | Tuple i -> Pe_EApp (Pe_EApp (Pe_EVar "tuple_element", e), Pe_EConst (Pe_Cint i)) + | Cons_head -> Pe_EApp (Pe_EVar "list_head", e) + | Cons_tail -> Pe_EApp (Pe_EVar "list_tail", e) + | Other -> e +;; + +let const_to_peconst const = + let pe_const = + match const with + | CInt i -> Pe_Cint i + | CBool b -> Pe_CBool b + in + Pe_EConst pe_const +;; \ No newline at end of file diff --git a/FML/lib/dune b/FML/lib/dune index 31260dc14..c1dbac93a 100644 --- a/FML/lib/dune +++ b/FML/lib/dune @@ -3,7 +3,7 @@ (library (name fml_lib) (public_name FML.Lib) - (modules Ast Parser Inf_errors Inf_pprint Inferencer Typedtree) + (modules Ast Parser Inf_errors Inf_pprint Inferencer Typedtree Pattern_elim) (modules_without_implementation inf_errors) (libraries base angstrom) (preprocess From e9116cebff3f2d5f2c43ec3a2fa1006c5a368560 Mon Sep 17 00:00:00 2001 From: Dmitry Pilyuk Date: Thu, 6 Mar 2025 13:43:22 +0300 Subject: [PATCH 02/92] Add Pe Ast --- FML/lib/anf/pattern_elim.ml | 26 ++------------------------ FML/lib/anf/pe_ast.ml | 30 ++++++++++++++++++++++++++++++ FML/lib/dune | 10 +++++++++- 3 files changed, 41 insertions(+), 25 deletions(-) create mode 100644 FML/lib/anf/pe_ast.ml diff --git a/FML/lib/anf/pattern_elim.ml b/FML/lib/anf/pattern_elim.ml index fc52513a9..ecfbb0293 100644 --- a/FML/lib/anf/pattern_elim.ml +++ b/FML/lib/anf/pattern_elim.ml @@ -3,29 +3,7 @@ (** SPDX-License-Identifier: LGPL-2.1 *) open Ast - -type pe_const = - | Pe_Cint of int - | Pe_CBool of bool - -type pe_expr = - | Pe_EUnit - | Pe_ENill - | Pe_EIdentifier of string - | Pe_EConst of pe_const - | Pe_EVar of string - | Pe_EIf of pe_expr * pe_expr * pe_expr - | Pe_EFun of string list * pe_expr - | Pe_EApp of pe_expr * pe_expr - | Pe_ELet of pe_str_item * pe_expr - | Pe_ECons of pe_expr * pe_expr - | Pe_ETuple of pe_expr list - -and pe_str_item = - | Pe_Nonrec of string * pe_expr - | Pe_Rec of (string * pe_expr) list - -type pe_structure = pe_str_item list +open Pe_ast let const_to_str = function | Pe_CBool b -> if b then "true" else "false" @@ -116,4 +94,4 @@ let const_to_peconst const = | CBool b -> Pe_CBool b in Pe_EConst pe_const -;; \ No newline at end of file +;; diff --git a/FML/lib/anf/pe_ast.ml b/FML/lib/anf/pe_ast.ml new file mode 100644 index 000000000..9c9dd9d0c --- /dev/null +++ b/FML/lib/anf/pe_ast.ml @@ -0,0 +1,30 @@ +(** Copyright 2024-2025, Dmitry Pilyuk, Aleksandr Rozhkov *) + +(** SPDX-License-Identifier: LGPL-2.1 *) + +type rec_flag = + | Rec + | NoRec + +type pe_const = + | Pe_Cint of int + | Pe_CBool of bool + +type pe_expr = + | Pe_EUnit + | Pe_ENill + | Pe_EIdentifier of string + | Pe_EConst of pe_const + | Pe_EVar of string + | Pe_EIf of pe_expr * pe_expr * pe_expr + | Pe_EFun of string list * pe_expr + | Pe_EApp of pe_expr * pe_expr + | Pe_ELet of rec_flag * string * pe_expr * pe_expr + | Pe_ECons of pe_expr * pe_expr + | Pe_ETuple of pe_expr list + +type pe_declaration = + | Pe_Nonrec of (string * pe_expr) list + | Pe_Rec of (string * pe_expr) list + +type pe_program = pe_declaration list diff --git a/FML/lib/dune b/FML/lib/dune index c1dbac93a..44c08b6b0 100644 --- a/FML/lib/dune +++ b/FML/lib/dune @@ -3,7 +3,15 @@ (library (name fml_lib) (public_name FML.Lib) - (modules Ast Parser Inf_errors Inf_pprint Inferencer Typedtree Pattern_elim) + (modules + Ast + Parser + Inf_errors + Inf_pprint + Inferencer + Typedtree + Pattern_elim + Pe_ast) (modules_without_implementation inf_errors) (libraries base angstrom) (preprocess From 3c6834adcfcd5970dcb5582179fd96288d6e37f7 Mon Sep 17 00:00:00 2001 From: RozhkovAleksandr Date: Thu, 6 Mar 2025 14:00:20 +0300 Subject: [PATCH 03/92] fix --- FML/lib/anf/pattern_elim.ml | 38 +++++++++++++++++++------------------ 1 file changed, 20 insertions(+), 18 deletions(-) diff --git a/FML/lib/anf/pattern_elim.ml b/FML/lib/anf/pattern_elim.ml index ecfbb0293..a3766d85b 100644 --- a/FML/lib/anf/pattern_elim.ml +++ b/FML/lib/anf/pattern_elim.ml @@ -28,17 +28,10 @@ let rec expr_to_str = function (List.fold_left (fun acc name -> acc ^ " " ^ name) "" args) (expr_to_str e) | Pe_EApp (e1, e2) -> Format.sprintf "(%s %s)" (expr_to_str e1) (expr_to_str e2) - | Pe_ELet (Pe_Nonrec (name, e1), e2) -> + | Pe_ELet (NoRec, name, e1, e2) -> Format.sprintf "let %s = %s in\n%s" name (expr_to_str e1) (expr_to_str e2) - | Pe_ELet (Pe_Rec decl_list, e2) -> - let name1, e1 = List.hd decl_list in - let tl = List.tl decl_list in - Format.sprintf "let rec %s = %s" name1 (expr_to_str e1) - ^ List.fold_left - (fun acc (name, e) -> acc ^ Format.sprintf " and %s = %s" name (expr_to_str e)) - "" - tl - ^ Format.sprintf " in\n%s" (expr_to_str e2) + | Pe_ELet (Rec, name1, e1, e2) -> + Format.sprintf "let rec %s = %s in\n%s" name1 (expr_to_str e1) (expr_to_str e2) | Pe_ECons (e1, e2) -> Format.sprintf "(%s::%s)" (expr_to_str e1) (expr_to_str e2) | Pe_ETuple e_list -> Format.sprintf @@ -51,15 +44,24 @@ let rec expr_to_str = function ;; let decl_to_str = function - | Pe_Nonrec (name, e) -> Format.sprintf "let %s = %s" name (expr_to_str e) + | Pe_Nonrec decl_list -> + (match decl_list with + | [] -> "" + | (name, e) :: tl -> + Format.sprintf "let %s = %s" name (expr_to_str e) + ^ List.fold_left + (fun acc (name, e) -> acc ^ Format.sprintf "\nlet %s = %s" name (expr_to_str e)) + "" + tl) | Pe_Rec decl_list -> - let name1, e1 = List.hd decl_list in - let tl = List.tl decl_list in - Format.sprintf "let rec %s = %s" name1 (expr_to_str e1) - ^ List.fold_left - (fun acc (name, e) -> acc ^ Format.sprintf "\nand %s = %s" name (expr_to_str e)) - "" - tl + (match decl_list with + | [] -> "" + | (name, e) :: tl -> + Format.sprintf "let rec %s = %s" name (expr_to_str e) + ^ List.fold_left + (fun acc (name, e) -> acc ^ Format.sprintf "\nand %s = %s" name (expr_to_str e)) + "" + tl) ;; let pp_pe_expr ppf expr = Format.fprintf ppf "%s" (expr_to_str expr) From 73b744a11446729e157149f2acfb4f7b2418e220 Mon Sep 17 00:00:00 2001 From: RozhkovAleksandr Date: Thu, 6 Mar 2025 22:08:47 +0300 Subject: [PATCH 04/92] fix pe --- FML/lib/anf/pattern_elim.ml | 396 ++++++++++++++++++++++++++++++++++++ FML/tests/dune | 31 +++ FML/tests/pe_manytests.t | 176 ++++++++++++++++ FML/tests/pe_runner.ml | 26 +++ 4 files changed, 629 insertions(+) create mode 100644 FML/tests/pe_manytests.t create mode 100644 FML/tests/pe_runner.ml diff --git a/FML/lib/anf/pattern_elim.ml b/FML/lib/anf/pattern_elim.ml index a3766d85b..340564bf9 100644 --- a/FML/lib/anf/pattern_elim.ml +++ b/FML/lib/anf/pattern_elim.ml @@ -5,6 +5,7 @@ open Ast open Pe_ast + let const_to_str = function | Pe_CBool b -> if b then "true" else "false" | Pe_Cint i -> Format.sprintf "%i" i @@ -97,3 +98,398 @@ let const_to_peconst const = in Pe_EConst pe_const ;; + +open Base + +let make_apply op expr1 expr2 = Pe_EApp (Pe_EApp (Pe_EIdentifier op, expr1), expr2) + +module StrSet = struct + open Base + + type t = (string, String.comparator_witness) Set.t + + let empty = Set.empty (module String) + let singleton str = Set.singleton (module String) str + let union = Set.union + let union_list lst = Set.union_list (module String) lst + let find s str = Set.mem s str + let add = Set.add + let to_list = Set.to_list + let of_list = Set.of_list (module String) + let fold = Set.fold + let diff = Set.diff +end + + + +type bindings = (int, Int.comparator_witness) Set.t + +let contains ng id = + match Set.find ng ~f:(Int.equal id) with + | Some _ -> true + | None -> false +;; + +module MonadCounter = struct + open Base + + type 'a t = bindings * int -> bindings * int * 'a + + let return x (binds, var) = binds, var, x + + let fresh (binds, var) = + let rec helper num = if contains binds num then helper (num + 1) else num in + let next = helper var in + binds, next + 1, next + ;; + + let bind (m : 'a t) (f : 'a -> 'b t) : 'b t = + fun t -> + let binds, var, x = m t in + f x (binds, var) + ;; + + let ( >>= ) = bind + let ( let* ) = bind + + let ( >>| ) (m : 'a t) (f : 'a -> 'b) : 'b t = + fun t -> + let binds, var, x = m t in + binds, var, f x + ;; + + let run (m : 'a t) binds start = m (binds, start) + + let map (xs : 'a list) ~(f : 'a -> 'b t) : 'b list t = + let* xs = + List.fold xs ~init:(return []) ~f:(fun acc x -> + let* acc = acc in + let* x = f x in + return (x :: acc)) + in + return @@ List.rev xs + ;; + + let fold_left (xs : 'a list) ~(init : 'b t) ~(f : 'b -> 'a -> 'b t) : 'b t = + List.fold xs ~init ~f:(fun acc x -> + let* acc = acc in + f acc x) + ;; + + let fold_right xs ~init ~f = + List.fold_right xs ~init ~f:(fun x acc -> + let* acc = acc in + f x acc) + ;; +end + +let rec get_binds_pat = + function + | PConstraint (pat, _) -> get_binds_pat pat + | PAny | PConst _ | PNill | PUnit -> StrSet.empty + | PIdentifier ident -> StrSet.singleton ident + | PCons (p1, p2) -> StrSet.union (get_binds_pat p1) (get_binds_pat p2) + | PTuple pl -> + Base.List.fold pl ~init:StrSet.empty ~f:(fun acc p -> + StrSet.union acc (get_binds_pat p)) +;; + +let check_pat expr pat = + let rec helper add expr = function + | PConstraint (p, _) -> helper add expr p + | PConst c -> + (match c with + | _ -> [ make_apply "( = )" expr (const_to_peconst c) ]) + | PTuple pl -> + let t = List.mapi pl ~f:(fun i p -> helper true (get_element expr (Tuple i)) p) in + List.concat t + | PCons (l, r) -> + let rec length l = function + | Ast.PCons (_, r) -> length (l + 1) r + | _ -> l + in + let min_length = length 0 r in + let list_length = Pe_EApp (Pe_EIdentifier "list_len", expr) in + let check = make_apply "( > )" list_length (Pe_EConst (Pe_Cint min_length)) in + let l = helper true (get_element expr Cons_head) l in + let r = helper false (get_element expr Cons_tail) r in + if add then (check :: l) @ r else l @ r + | _ -> [] + in + helper true expr pat +;; + +let check_decls expr pat = + let rec helper name = function + | PConstraint (p, _) -> helper name p + | PCons (l, r) -> + (match helper name l with + | _ :: _ as lst -> Cons_head :: lst + | _ -> Cons_tail :: helper name r) + | PTuple pl -> + let t = List.map pl ~f:(helper name) in + (match List.findi t ~f:(fun _ a -> not @@ List.is_empty a) with + | Some (i, lst) -> Tuple i :: lst + | None -> []) + | PIdentifier v when String.equal v name -> [ Other ] + | _ -> [] + in + let create_expr name = + List.fold_left (helper name pat) ~init:expr ~f:(fun acc unpack -> + get_element acc unpack) + in + let names = get_binds_pat pat in + let decls = List.map (StrSet.to_list names) ~f:(fun name -> (name, create_expr name)) in + Pe_Nonrec decls +;; + + + +let make_condition checks e1 e2 = + let cond = + List.fold (List.tl_exn checks) ~init:(List.hd_exn checks) ~f:(fun acc a -> + make_apply "( && )" acc a) + in + Pe_EIf (cond, e1, e2) +;; + +let make_case expr pat case_expr not_match_expr = + let checks = check_pat expr pat in + let decl = check_decls expr pat in + let let_expr = + match decl with + | Pe_Nonrec decl_list -> + List.fold_right decl_list ~init:case_expr ~f:(fun (name, value) acc -> + Pe_ELet (NoRec, name, value, acc)) + | Pe_Rec decl_list -> + List.fold_right decl_list ~init:case_expr ~f:(fun (name, value) acc -> + Pe_ELet (Rec, name, value, acc)) + in + if List.is_empty checks then let_expr else make_condition checks let_expr not_match_expr +;; + +open MonadCounter +let get_id i = "a" ^ Int.to_string i + +let rec pe_expr = + let open Ast in + function + | EUnit -> return @@ Pe_EUnit + | ENill -> return @@ Pe_ENill + | EConstraint (e, _) -> pe_expr e + | EConst c -> return @@ const_to_peconst c + | EIdentifier v -> return @@ Pe_EIdentifier v + | EApplication (e1, e2) -> + let* e1 = pe_expr e1 in + let* e2 = pe_expr e2 in + return @@ Pe_EApp (e1, e2) + | EIf (e1, e2, e3) -> + let* e1 = pe_expr e1 in + let* e2 = pe_expr e2 in + let* e3 = pe_expr e3 in + return @@ Pe_EIf (e1, e2, e3) + | ECons (e1, e2) -> + let* e1 = pe_expr e1 in + let* e2 = pe_expr e2 in + return @@ Pe_ECons (e1, e2) + | ETuple e_list -> + let* e_list = map e_list ~f:(fun e -> pe_expr e) in + return @@ Pe_ETuple e_list + | EFun (p, e) -> + let rec extract_body = function + | EFun (_, e) -> extract_body e + | e -> e + in + let body = extract_body e in + let rec extract_args = function + | EFun (p, e) -> p :: extract_args e + | _ -> [] + in + let other = extract_args e in + let last_args = p :: other in + let f1 (new_args, args_to_match, pat_list) arg = + match arg with + | PIdentifier v when not (List.mem new_args v ~equal:String.equal) -> + return (v :: new_args, args_to_match, pat_list) + | _ -> + let* fresh_name = fresh >>| get_id in + return (fresh_name :: new_args, fresh_name :: args_to_match, arg :: pat_list) + in + let* new_args, args_to_match, pat_list = + fold_left last_args ~init:(return ([], [], [])) ~f:f1 + in + let new_args = List.rev new_args in + let args_to_match = List.rev args_to_match in + let pat_list = List.rev pat_list in + let* new_body = pe_expr body in + (match List.length args_to_match with + | 0 -> return @@ Pe_EFun (new_args, new_body) + | 1 -> + let pat = List.hd_exn pat_list in + let to_match = Pe_EIdentifier (List.hd_exn args_to_match) in + let case_expr = make_case to_match pat new_body (Pe_EIdentifier "fail_match") in + return @@ Pe_EFun (new_args, case_expr) + | _ -> + let pat = PTuple pat_list in + let to_match = + let vals = List.map args_to_match ~f:(fun a -> Pe_EIdentifier a) in + Pe_ETuple vals + in + let* fresh_name = fresh >>| get_id in + let case_expr = make_case (Pe_EIdentifier fresh_name) pat new_body (Pe_EIdentifier "fail_match") in + return @@ Pe_EFun (new_args, Pe_ELet (NoRec, fresh_name, to_match, case_expr))) + | EMatch (e_last, case_list) -> + let* e = pe_expr e_last in + (match e_last with + | EIdentifier _ | EConst _ -> pe_match e case_list + | _ -> + let* fresh_name = fresh >>| get_id in + let* e_match = pe_match (Pe_EIdentifier fresh_name) case_list in + return @@ (Pe_ELet (NoRec, fresh_name, e, e_match))) + | ELetIn (NoRec, pat, e1, e2) -> + let* e1 = pe_expr e1 in + let* e2 = pe_expr e2 in + (match pat with + | PIdentifier name -> return @@ Pe_ELet (NoRec, name, e1, e2) + | _ -> + (match e1 with + | Pe_EIdentifier _ -> + let case_expr = make_case e1 pat e2 (Pe_EIdentifier "fail_match") in + return case_expr + | _ -> + let* fresh_name = fresh >>| get_id in + let case_expr = make_case (Pe_EIdentifier fresh_name) pat e2 (Pe_EIdentifier "fail_match") in + return @@ Pe_ELet (NoRec, fresh_name, e1, case_expr))) + | ELetIn (Rec, pat, e1, e2) -> + let* decl = pe_case [ pat, e1 ] in + let* e = pe_expr e2 in + let result = + match decl with + | Pe_Nonrec decl_list -> + List.fold_right decl_list ~init:e ~f:(fun (name, value) acc -> Pe_ELet (NoRec, name, value, acc)) + | Pe_Rec decl_list -> + List.fold_right decl_list ~init:e ~f:(fun (name, value) acc -> Pe_ELet (Rec, name, value, acc)) + in + return result + +and pe_match to_match = function + | (p, e) :: tl -> + let checks = check_pat to_match p in + let decls = check_decls to_match p in + let* e = pe_expr e in + let let_in = + (match decls with + | Pe_Nonrec decl_list -> + List.fold_right decl_list ~init:e ~f:(fun (name, value) acc -> Pe_ELet (NoRec, name, value, acc)) + | Pe_Rec decl_list -> + List.fold_right decl_list ~init:e ~f:(fun (name, value) acc -> Pe_ELet (Rec, name, value, acc))) + in + if List.is_empty checks + then return let_in + else + let* match_e = pe_match to_match tl in + return @@ make_condition checks let_in match_e + | _ -> return @@ Pe_EIdentifier "fail_match" + +and pe_case decl_list = + let f1 (pat, e) = + let* e = pe_expr e in + return + (match pat with + | PIdentifier v -> v, e + | _ -> "", e) + in + let* new_decls = map decl_list ~f:f1 in + return @@ Pe_Rec new_decls +;; + +let pe_declaration = function + | NoRecDecl decl_list -> + let* decls = + map decl_list ~f:(fun (Ast.DDeclaration (pat, e)) -> + let* e = pe_expr e in + match pat with + | PIdentifier name -> return (name, e) + | PUnit -> return ("()", e) + | _ -> + let* fresh_name = fresh >>| get_id in + return (fresh_name, e)) + in + return (Pe_Nonrec decls) + | RecDecl decl_list -> + let* decls = + map decl_list ~f:(fun (Ast.DDeclaration (pat, e)) -> + let* e = pe_expr e in + match pat with + | PIdentifier v -> return (v, e) + | _ -> return ("()", e)) (* TODO: более информативное сообщение *) + in + return (Pe_Rec decls) +;; + +let pe_structure program = + let rec helper = function + | [] -> return [] + | hd :: tl -> + let* hd = pe_declaration hd in + let* tl = helper tl in + return @@ hd :: tl + in + helper program +;; + +let rec get_binds_expr = function + | EConstraint (e, _) -> get_binds_expr e + | EConst _ | EUnit |ENill-> StrSet.empty + | EIdentifier ident -> StrSet.singleton ident + | ECons (e1, e2) -> StrSet.union (get_binds_expr e1) (get_binds_expr e2) + | EApplication (e1, e2) -> StrSet.union (get_binds_expr e1) (get_binds_expr e2) + | EFun (pat, e) -> StrSet.union (get_binds_pat pat) (get_binds_expr e) + | EIf (e1, e2, e3) -> + StrSet.union_list [ get_binds_expr e1; get_binds_expr e2; get_binds_expr e3 ] + | ELetIn (_, p, e1, e2) -> + StrSet.union (get_binds_pat p) (StrSet.union (get_binds_expr e1) (get_binds_expr e2)) + | EMatch (e, p_list) -> + StrSet.union_list + (get_binds_expr e + :: List.map p_list ~f:(fun (p, e) -> + StrSet.union (get_binds_pat p) (get_binds_expr e))) + | ETuple e_list -> StrSet.union_list @@ List.map e_list ~f:get_binds_expr + +and get_binds_case (pat, e) = StrSet.union (get_binds_pat pat) (get_binds_expr e) + +and get_binds_declaration = function + | NoRecDecl decl_list -> + List.fold decl_list ~init:StrSet.empty ~f:(fun acc (DDeclaration (pat, e)) -> + StrSet.union acc (StrSet.union (get_binds_pat pat) (get_binds_expr e))) + | RecDecl decl_list -> + List.fold decl_list ~init:StrSet.empty ~f:(fun acc (DDeclaration (pat, e)) -> + StrSet.union acc (StrSet.union (get_binds_pat pat) (get_binds_expr e))) +;; + +let make_binds structure = + let make_id id = + let is_digit = function + | '0' .. '9' -> true + | _ -> false + in + let char_to_digit c = Char.to_int c - Char.to_int '0' in + let rec helper acc = function + | [] -> Some acc + | hd :: tl -> + if is_digit hd then helper ((acc * 10) + char_to_digit hd) tl else None + in + let char_list = String.to_list id in + match List.length char_list with + | x when x >= 2 && x <= 10 && Char.equal (List.hd_exn char_list) 'a' -> + helper 0 (List.tl_exn char_list) + | _ -> None + in + let idents = + List.fold_left structure ~init:StrSet.empty ~f:(fun acc t -> + StrSet.union acc (get_binds_declaration t)) + in + Set.filter_map (module Int) idents ~f:make_id +;; + +let run_pe structure = run (pe_structure structure) (make_binds structure) 0 \ No newline at end of file diff --git a/FML/tests/dune b/FML/tests/dune index 7e2970e6b..918a2e27b 100644 --- a/FML/tests/dune +++ b/FML/tests/dune @@ -20,6 +20,12 @@ (modules inferencer_runner) (libraries fml_lib stdio)) +(executable + (name pe_runner) + (public_name pe_runner) + (modules pe_runner) + (libraries fml_lib stdio)) + (cram (applies_to parser_manytests) (deps @@ -67,3 +73,28 @@ manytests/typed/010sukharev.ml manytests/typed/015tuples.ml manytests/typed/016lists.ml)) + + +(cram + (applies_to pe_manytests) + (deps + ./pe_runner.exe + manytests/do_not_type/001.ml + manytests/do_not_type/002if.ml + manytests/do_not_type/003occurs.ml + manytests/do_not_type/004let_poly.ml + manytests/do_not_type/015tuples.ml + manytests/typed/001fac.ml + manytests/typed/002fac.ml + manytests/typed/003fib.ml + manytests/typed/004manyargs.ml + manytests/typed/005fix.ml + manytests/typed/006partial.ml + manytests/typed/006partial2.ml + manytests/typed/006partial3.ml + manytests/typed/007order.ml + manytests/typed/008ascription.ml + manytests/typed/009let_poly.ml + manytests/typed/010sukharev.ml + manytests/typed/015tuples.ml + manytests/typed/016lists.ml)) \ No newline at end of file diff --git a/FML/tests/pe_manytests.t b/FML/tests/pe_manytests.t new file mode 100644 index 000000000..350e6e055 --- /dev/null +++ b/FML/tests/pe_manytests.t @@ -0,0 +1,176 @@ + $ ./pe_runner.exe < manytests/typed/001fac.ml + let rec fac = (fun n -> if ((( <= ) n) 1) + then 1 + else ((( * ) n) (fac ((( - ) n) 1)))) + + let main = let a0 = (print_int (fac 4)) in + 0 + + $ ./pe_runner.exe < manytests/typed/002fac.ml + let rec fac_cps = (fun n k -> if ((( = ) n) 1) + then (k 1) + else ((fac_cps ((( - ) n) 1)) (fun p -> (k ((( * ) p) n))))) + + let main = let a0 = (print_int ((fac_cps 4) (fun print_int -> print_int))) in + 0 + + $ ./pe_runner.exe < manytests/typed/003fib.ml + let rec fib_acc = (fun a b n -> if ((( = ) n) 1) + then b + else let n1 = ((( - ) n) 1) in + let ab = ((( + ) a) b) in + (((fib_acc b) ab) n1)) + + let rec fib = (fun n -> if ((( < ) n) 2) + then n + else ((( + ) (fib ((( - ) n) 1))) (fib ((( - ) n) 2)))) + + let main = let a1 = (print_int (((fib_acc 0) 1) 4)) in + let a0 = (print_int (fib 4)) in + 0 + + $ ./pe_runner.exe < manytests/typed/004manyargs.ml + let wrap = (fun f -> if ((( = ) 1) 1) + then f + else f) + + let test3 = (fun a b c -> let a = (print_int a) in + let b = (print_int b) in + let c = (print_int c) in + 0) + + let test10 = (fun a b c d e f g h i j -> ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) a) b)) c)) d)) e)) f)) g)) h)) i)) j)) + + let main = let rez = (((((((((((wrap test10) 1) 10) 100) 1000) 10000) 100000) 1000000) 10000000) 100000000) 1000000000) in + let a0 = (print_int rez) in + let temp2 = ((((wrap test3) 1) 10) 100) in + 0 + + $ ./pe_runner.exe < manytests/typed/005fix.ml + let rec fix = (fun f x -> ((f (fix f)) x)) + + let fac = (fun self n -> if ((( <= ) n) 1) + then 1 + else ((( * ) n) (self ((( - ) n) 1)))) + + let main = let a0 = (print_int ((fix fac) 6)) in + 0 + + $ ./pe_runner.exe < manytests/typed/006partial.ml + let foo = (fun b -> if b + then (fun foo -> ((( + ) foo) 2)) + else (fun foo -> ((( * ) foo) 10))) + + let foo = (fun x -> ((foo true) ((foo false) ((foo true) ((foo false) x))))) + + let main = let a0 = (print_int (foo 11)) in + 0 + + $ ./pe_runner.exe < manytests/typed/006partial2.ml + let foo = (fun a b c -> let a2 = (print_int a) in + let a1 = (print_int b) in + let a0 = (print_int c) in + ((( + ) a) ((( * ) b) c))) + + let main = let foo = (foo 1) in + let foo = (foo 2) in + let foo = (foo 3) in + let a3 = (print_int foo) in + 0 + $ ./pe_runner.exe < manytests/typed/006partial3.ml + let foo = (fun a -> let a1 = (print_int a) in + (fun b -> let a0 = (print_int b) in + (fun c -> (print_int c)))) + + let main = let a2 = (((foo 4) 8) 9) in + 0 + $ ./pe_runner.exe < manytests/typed/007order.ml + let _start = (fun a0 a1 a a2 b _c a3 d __ -> let a6 = (a0, a1, a2, a3) in + let a5 = (print_int ((( + ) a) b)) in + let a4 = (print_int __) in + ((( + ) ((( / ) ((( * ) a) b)) _c)) d)) + + let main = (print_int (((((((((_start (print_int 1)) (print_int 2)) 3) (print_int 4)) 100) 1000) (print_int (( ~- ) 1))) 10000) (( ~- ) 555555))) + $ ./pe_runner.exe < manytests/typed/008ascription.ml + let addi = (fun f g x -> ((f x) (g x))) + + let main = let a0 = (print_int (((addi (fun x b -> if b + then ((( + ) x) 1) + else ((( * ) x) 2))) (fun _start -> ((( = ) ((( / ) _start) 2)) 0))) 4)) in + 0 + + $ ./pe_runner.exe < manytests/typed/009let_poly.ml + let temp = let f = (fun x -> x) in + ((f 1), (f true)) + + $ ./pe_runner.exe < manytests/typed/015tuples.ml + let rec fix = (fun f x -> ((f (fix f)) x)) + + let map = (fun f p -> let a = ((tuple_element p) 0) in + let b = ((tuple_element p) 1) in + ((f a), (f b))) + + let fixpoly = (fun l -> ((fix (fun self l -> ((map (fun li x -> ((li (self l)) x))) l))) l)) + + let feven = (fun p n -> let e = ((tuple_element p) 0) in + let o = ((tuple_element p) 1) in + if ((( == ) n) 0) + then 1 + else (o ((( - ) n) 1))) + + let fodd = (fun p n -> let e = ((tuple_element p) 0) in + let o = ((tuple_element p) 1) in + if ((( == ) n) 0) + then 0 + else (e ((( - ) n) 1))) + + let tie = (fixpoly (feven, fodd)) + + let rec meven = (fun n -> if ((( = ) n) 0) + then 1 + else (modd ((( - ) n) 1))) + and modd = (fun n -> if ((( = ) n) 0) + then 1 + else (meven ((( - ) n) 1))) + + let main = let a3 = (print_int (modd 1)) in + let a2 = (print_int (meven 2)) in + let even = ((tuple_element tie) 0) in + let odd = ((tuple_element tie) 1) in + let a1 = (print_int (odd 3)) in + let a0 = (print_int (even 4)) in + 0 + + $ ./pe_runner.exe < manytests/typed/016lists.ml + let rec length = (fun xs -> 0) + + let length_tail = let rec helper = (fun acc xs -> acc) in + (helper 0) + + let rec map = (fun f xs -> []) + + let rec append = (fun xs ys -> ys) + + let concat = let rec helper = (fun xs -> []) in + helper + + let rec iter = (fun f xs -> ()) + + let rec cartesian = (fun xs ys -> []) + + let main = let a1 = ((iter print_int) (1::(2::(3::[])))) in + let a0 = (print_int (length ((cartesian (1::(2::[]))) (1::(2::(3::(4::[]))))))) in + 0 + + $ ./pe_runner.exe < manytests/do_not_type/001.ml + Infer error: + $ ./pe_runner.exe < manytests/do_not_type/002if.ml + Infer error: + $ ./pe_runner.exe < manytests/do_not_type/003occurs.ml + Infer error: + + $ ./pe_runner.exe < manytests/do_not_type/004let_poly.ml + Infer error: + + $ ./pe_runner.exe < manytests/do_not_type/015tuples.ml + Infer error: diff --git a/FML/tests/pe_runner.ml b/FML/tests/pe_runner.ml new file mode 100644 index 000000000..fe0ae54a5 --- /dev/null +++ b/FML/tests/pe_runner.ml @@ -0,0 +1,26 @@ +(** Copyright 2024-2025, Dmitry Pilyuk, Aleksandr Rozhkov *) + +(** SPDX-License-Identifier: LGPL-2.1 *) + + +open Fml_lib.Parser +open Fml_lib.Inferencer +open Fml_lib.Pattern_elim + + +let () = + let input = Stdio.In_channel.input_all Stdlib.stdin in + let parse_and_infer input = + match parse input with + | Ok parsed -> + (match run_program_inferencer parsed with + | Ok _ -> Ok parsed + | Error _ -> Error (Format.asprintf "Infer error:" )) + | Error e -> Error (Format.sprintf "Parsing error: %s" e) + in + match parse_and_infer input with + | Ok ast -> + let _, _, converted = run_pe ast in + Format.printf "%a" pp_pe_structure converted + | Error message -> Format.printf "%s" message +;; From 0fbd7cc2b98c497243a92998e2e0a2b819cf5062 Mon Sep 17 00:00:00 2001 From: RozhkovAleksandr Date: Thu, 6 Mar 2025 22:35:01 +0300 Subject: [PATCH 05/92] fix pe (unit pattern) --- FML/lib/anf/pattern_elim.ml | 33 +++++++++---------------- FML/tests/pe_manytests.t | 48 ++++++++++++++++++------------------- 2 files changed, 35 insertions(+), 46 deletions(-) diff --git a/FML/lib/anf/pattern_elim.ml b/FML/lib/anf/pattern_elim.ml index 340564bf9..36fab2a9f 100644 --- a/FML/lib/anf/pattern_elim.ml +++ b/FML/lib/anf/pattern_elim.ml @@ -351,6 +351,7 @@ let rec pe_expr = let* e2 = pe_expr e2 in (match pat with | PIdentifier name -> return @@ Pe_ELet (NoRec, name, e1, e2) + | PUnit -> return @@ Pe_ELet (NoRec, "()", e1, e2) | _ -> (match e1 with | Pe_EIdentifier _ -> @@ -360,17 +361,16 @@ let rec pe_expr = let* fresh_name = fresh >>| get_id in let case_expr = make_case (Pe_EIdentifier fresh_name) pat e2 (Pe_EIdentifier "fail_match") in return @@ Pe_ELet (NoRec, fresh_name, e1, case_expr))) - | ELetIn (Rec, pat, e1, e2) -> - let* decl = pe_case [ pat, e1 ] in - let* e = pe_expr e2 in - let result = - match decl with - | Pe_Nonrec decl_list -> - List.fold_right decl_list ~init:e ~f:(fun (name, value) acc -> Pe_ELet (NoRec, name, value, acc)) - | Pe_Rec decl_list -> - List.fold_right decl_list ~init:e ~f:(fun (name, value) acc -> Pe_ELet (Rec, name, value, acc)) - in - return result + | ELetIn (Rec, pat, e1, e2) -> + let* e1 = pe_expr e1 in + let* e2 = pe_expr e2 in + (match pat with + | PIdentifier name -> return @@ Pe_ELet (Rec, name, e1, e2) + | PUnit -> return @@ Pe_ELet (Rec, "()", e1, e2) + | _ -> + let* fresh_name = fresh >>| get_id in + let case_expr = make_case (Pe_EIdentifier fresh_name) pat e2 (Pe_EIdentifier "fail_match") in + return @@ Pe_ELet (Rec, fresh_name, e1, case_expr)) and pe_match to_match = function | (p, e) :: tl -> @@ -390,17 +390,6 @@ and pe_match to_match = function let* match_e = pe_match to_match tl in return @@ make_condition checks let_in match_e | _ -> return @@ Pe_EIdentifier "fail_match" - -and pe_case decl_list = - let f1 (pat, e) = - let* e = pe_expr e in - return - (match pat with - | PIdentifier v -> v, e - | _ -> "", e) - in - let* new_decls = map decl_list ~f:f1 in - return @@ Pe_Rec new_decls ;; let pe_declaration = function diff --git a/FML/tests/pe_manytests.t b/FML/tests/pe_manytests.t index 350e6e055..460d34807 100644 --- a/FML/tests/pe_manytests.t +++ b/FML/tests/pe_manytests.t @@ -3,7 +3,7 @@ then 1 else ((( * ) n) (fac ((( - ) n) 1)))) - let main = let a0 = (print_int (fac 4)) in + let main = let () = (print_int (fac 4)) in 0 $ ./pe_runner.exe < manytests/typed/002fac.ml @@ -11,7 +11,7 @@ then (k 1) else ((fac_cps ((( - ) n) 1)) (fun p -> (k ((( * ) p) n))))) - let main = let a0 = (print_int ((fac_cps 4) (fun print_int -> print_int))) in + let main = let () = (print_int ((fac_cps 4) (fun print_int -> print_int))) in 0 $ ./pe_runner.exe < manytests/typed/003fib.ml @@ -25,8 +25,8 @@ then n else ((( + ) (fib ((( - ) n) 1))) (fib ((( - ) n) 2)))) - let main = let a1 = (print_int (((fib_acc 0) 1) 4)) in - let a0 = (print_int (fib 4)) in + let main = let () = (print_int (((fib_acc 0) 1) 4)) in + let () = (print_int (fib 4)) in 0 $ ./pe_runner.exe < manytests/typed/004manyargs.ml @@ -42,7 +42,7 @@ let test10 = (fun a b c d e f g h i j -> ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) a) b)) c)) d)) e)) f)) g)) h)) i)) j)) let main = let rez = (((((((((((wrap test10) 1) 10) 100) 1000) 10000) 100000) 1000000) 10000000) 100000000) 1000000000) in - let a0 = (print_int rez) in + let () = (print_int rez) in let temp2 = ((((wrap test3) 1) 10) 100) in 0 @@ -53,7 +53,7 @@ then 1 else ((( * ) n) (self ((( - ) n) 1)))) - let main = let a0 = (print_int ((fix fac) 6)) in + let main = let () = (print_int ((fix fac) 6)) in 0 $ ./pe_runner.exe < manytests/typed/006partial.ml @@ -63,38 +63,38 @@ let foo = (fun x -> ((foo true) ((foo false) ((foo true) ((foo false) x))))) - let main = let a0 = (print_int (foo 11)) in + let main = let () = (print_int (foo 11)) in 0 $ ./pe_runner.exe < manytests/typed/006partial2.ml - let foo = (fun a b c -> let a2 = (print_int a) in - let a1 = (print_int b) in - let a0 = (print_int c) in + let foo = (fun a b c -> let () = (print_int a) in + let () = (print_int b) in + let () = (print_int c) in ((( + ) a) ((( * ) b) c))) let main = let foo = (foo 1) in let foo = (foo 2) in let foo = (foo 3) in - let a3 = (print_int foo) in + let () = (print_int foo) in 0 $ ./pe_runner.exe < manytests/typed/006partial3.ml - let foo = (fun a -> let a1 = (print_int a) in - (fun b -> let a0 = (print_int b) in + let foo = (fun a -> let () = (print_int a) in + (fun b -> let () = (print_int b) in (fun c -> (print_int c)))) - let main = let a2 = (((foo 4) 8) 9) in + let main = let () = (((foo 4) 8) 9) in 0 $ ./pe_runner.exe < manytests/typed/007order.ml - let _start = (fun a0 a1 a a2 b _c a3 d __ -> let a6 = (a0, a1, a2, a3) in - let a5 = (print_int ((( + ) a) b)) in - let a4 = (print_int __) in + let _start = (fun a0 a1 a a2 b _c a3 d __ -> let a4 = (a0, a1, a2, a3) in + let () = (print_int ((( + ) a) b)) in + let () = (print_int __) in ((( + ) ((( / ) ((( * ) a) b)) _c)) d)) let main = (print_int (((((((((_start (print_int 1)) (print_int 2)) 3) (print_int 4)) 100) 1000) (print_int (( ~- ) 1))) 10000) (( ~- ) 555555))) $ ./pe_runner.exe < manytests/typed/008ascription.ml let addi = (fun f g x -> ((f x) (g x))) - let main = let a0 = (print_int (((addi (fun x b -> if b + let main = let () = (print_int (((addi (fun x b -> if b then ((( + ) x) 1) else ((( * ) x) 2))) (fun _start -> ((( = ) ((( / ) _start) 2)) 0))) 4)) in 0 @@ -133,12 +133,12 @@ then 1 else (meven ((( - ) n) 1))) - let main = let a3 = (print_int (modd 1)) in - let a2 = (print_int (meven 2)) in + let main = let () = (print_int (modd 1)) in + let () = (print_int (meven 2)) in let even = ((tuple_element tie) 0) in let odd = ((tuple_element tie) 1) in - let a1 = (print_int (odd 3)) in - let a0 = (print_int (even 4)) in + let () = (print_int (odd 3)) in + let () = (print_int (even 4)) in 0 $ ./pe_runner.exe < manytests/typed/016lists.ml @@ -158,8 +158,8 @@ let rec cartesian = (fun xs ys -> []) - let main = let a1 = ((iter print_int) (1::(2::(3::[])))) in - let a0 = (print_int (length ((cartesian (1::(2::[]))) (1::(2::(3::(4::[]))))))) in + let main = let () = ((iter print_int) (1::(2::(3::[])))) in + let () = (print_int (length ((cartesian (1::(2::[]))) (1::(2::(3::(4::[]))))))) in 0 $ ./pe_runner.exe < manytests/do_not_type/001.ml From ca6b955962625f3ecf5b1d8f4083b3bc3532a834 Mon Sep 17 00:00:00 2001 From: RozhkovAleksandr Date: Thu, 6 Mar 2025 22:56:29 +0300 Subject: [PATCH 06/92] add monade for pe --- FML/lib/anf/common.ml | 111 ++++++++++++++++++++++++++++++++++++++++++ FML/lib/dune | 1 + 2 files changed, 112 insertions(+) create mode 100644 FML/lib/anf/common.ml diff --git a/FML/lib/anf/common.ml b/FML/lib/anf/common.ml new file mode 100644 index 000000000..605db5253 --- /dev/null +++ b/FML/lib/anf/common.ml @@ -0,0 +1,111 @@ +(** Copyright 2024-2025, Dmitry Pilyuk, Aleksandr Rozhkov *) + +(** SPDX-License-Identifier: LGPL-2.1 *) + +open Base +open Ast +open Pe_ast + + +let make_apply op expr1 expr2 = Pe_EApp (Pe_EApp (Pe_EIdentifier op, expr1), expr2) + +module StrSet = struct + open Base + + type t = (string, String.comparator_witness) Set.t + + let empty = Set.empty (module String) + let singleton str = Set.singleton (module String) str + let union = Set.union + let union_list lst = Set.union_list (module String) lst + let find s str = Set.mem s str + let add = Set.add + let to_list = Set.to_list + let of_list = Set.of_list (module String) + let fold = Set.fold + let diff = Set.diff +end + + + +type bindings = (int, Int.comparator_witness) Set.t + +let contains ng id = + match Set.find ng ~f:(Int.equal id) with + | Some _ -> true + | None -> false +;; + +module MonadCounter = struct + open Base + + type 'a t = bindings * int -> bindings * int * 'a + + let return x (binds, var) = binds, var, x + + let fresh (binds, var) = + let rec helper num = if contains binds num then helper (num + 1) else num in + let next = helper var in + binds, next + 1, next + ;; + + let bind (m : 'a t) (f : 'a -> 'b t) : 'b t = + fun t -> + let binds, var, x = m t in + f x (binds, var) + ;; + + let ( >>= ) = bind + let ( let* ) = bind + + let ( >>| ) (m : 'a t) (f : 'a -> 'b) : 'b t = + fun t -> + let binds, var, x = m t in + binds, var, f x + ;; + + let run (m : 'a t) binds start = m (binds, start) + + let map (xs : 'a list) ~(f : 'a -> 'b t) : 'b list t = + let* xs = + List.fold xs ~init:(return []) ~f:(fun acc x -> + let* acc = acc in + let* x = f x in + return (x :: acc)) + in + return @@ List.rev xs + ;; + + let fold_left (xs : 'a list) ~(init : 'b t) ~(f : 'b -> 'a -> 'b t) : 'b t = + List.fold xs ~init ~f:(fun acc x -> + let* acc = acc in + f acc x) + ;; + + let fold_right xs ~init ~f = + List.fold_right xs ~init ~f:(fun x acc -> + let* acc = acc in + f x acc) + ;; +end + +let rec get_binds_pat = + function + | PConstraint (pat, _) -> get_binds_pat pat + | PAny | PConst _ | PNill | PUnit -> StrSet.empty + | PIdentifier ident -> StrSet.singleton ident + | PCons (p1, p2) -> StrSet.union (get_binds_pat p1) (get_binds_pat p2) + | PTuple pl -> + Base.List.fold pl ~init:StrSet.empty ~f:(fun acc p -> + StrSet.union acc (get_binds_pat p)) +;; + +let make_condition checks e1 e2 = + let cond = + List.fold (List.tl_exn checks) ~init:(List.hd_exn checks) ~f:(fun acc a -> + make_apply "( && )" acc a) + in + Pe_EIf (cond, e1, e2) +;; + +let get_id i = "a" ^ Int.to_string i \ No newline at end of file diff --git a/FML/lib/dune b/FML/lib/dune index 44c08b6b0..8eb8e9e04 100644 --- a/FML/lib/dune +++ b/FML/lib/dune @@ -11,6 +11,7 @@ Inferencer Typedtree Pattern_elim + Common Pe_ast) (modules_without_implementation inf_errors) (libraries base angstrom) From 0d100a15ab8c59f7583ba95e913f60724f55c89d Mon Sep 17 00:00:00 2001 From: RozhkovAleksandr Date: Thu, 6 Mar 2025 23:14:55 +0300 Subject: [PATCH 07/92] fix again --- FML/lib/anf/pattern_elim.ml | 132 ++++-------------------------------- 1 file changed, 12 insertions(+), 120 deletions(-) diff --git a/FML/lib/anf/pattern_elim.ml b/FML/lib/anf/pattern_elim.ml index 36fab2a9f..e009818d6 100644 --- a/FML/lib/anf/pattern_elim.ml +++ b/FML/lib/anf/pattern_elim.ml @@ -4,6 +4,7 @@ open Ast open Pe_ast +open Common let const_to_str = function @@ -65,8 +66,6 @@ let decl_to_str = function tl) ;; -let pp_pe_expr ppf expr = Format.fprintf ppf "%s" (expr_to_str expr) - let pp_pe_structure ppf p = let len = List.length p in List.iteri @@ -100,101 +99,9 @@ let const_to_peconst const = ;; open Base +open MonadCounter -let make_apply op expr1 expr2 = Pe_EApp (Pe_EApp (Pe_EIdentifier op, expr1), expr2) - -module StrSet = struct - open Base - - type t = (string, String.comparator_witness) Set.t - - let empty = Set.empty (module String) - let singleton str = Set.singleton (module String) str - let union = Set.union - let union_list lst = Set.union_list (module String) lst - let find s str = Set.mem s str - let add = Set.add - let to_list = Set.to_list - let of_list = Set.of_list (module String) - let fold = Set.fold - let diff = Set.diff -end - - - -type bindings = (int, Int.comparator_witness) Set.t - -let contains ng id = - match Set.find ng ~f:(Int.equal id) with - | Some _ -> true - | None -> false -;; - -module MonadCounter = struct - open Base - - type 'a t = bindings * int -> bindings * int * 'a - - let return x (binds, var) = binds, var, x - - let fresh (binds, var) = - let rec helper num = if contains binds num then helper (num + 1) else num in - let next = helper var in - binds, next + 1, next - ;; - - let bind (m : 'a t) (f : 'a -> 'b t) : 'b t = - fun t -> - let binds, var, x = m t in - f x (binds, var) - ;; - - let ( >>= ) = bind - let ( let* ) = bind - - let ( >>| ) (m : 'a t) (f : 'a -> 'b) : 'b t = - fun t -> - let binds, var, x = m t in - binds, var, f x - ;; - - let run (m : 'a t) binds start = m (binds, start) - - let map (xs : 'a list) ~(f : 'a -> 'b t) : 'b list t = - let* xs = - List.fold xs ~init:(return []) ~f:(fun acc x -> - let* acc = acc in - let* x = f x in - return (x :: acc)) - in - return @@ List.rev xs - ;; - - let fold_left (xs : 'a list) ~(init : 'b t) ~(f : 'b -> 'a -> 'b t) : 'b t = - List.fold xs ~init ~f:(fun acc x -> - let* acc = acc in - f acc x) - ;; - - let fold_right xs ~init ~f = - List.fold_right xs ~init ~f:(fun x acc -> - let* acc = acc in - f x acc) - ;; -end - -let rec get_binds_pat = - function - | PConstraint (pat, _) -> get_binds_pat pat - | PAny | PConst _ | PNill | PUnit -> StrSet.empty - | PIdentifier ident -> StrSet.singleton ident - | PCons (p1, p2) -> StrSet.union (get_binds_pat p1) (get_binds_pat p2) - | PTuple pl -> - Base.List.fold pl ~init:StrSet.empty ~f:(fun acc p -> - StrSet.union acc (get_binds_pat p)) -;; - -let check_pat expr pat = +let check_pattern expr pat = let rec helper add expr = function | PConstraint (p, _) -> helper add expr p | PConst c -> @@ -219,7 +126,7 @@ let check_pat expr pat = helper true expr pat ;; -let check_decls expr pat = +let check_declaration expr pat = let rec helper name = function | PConstraint (p, _) -> helper name p | PCons (l, r) -> @@ -243,19 +150,9 @@ let check_decls expr pat = Pe_Nonrec decls ;; - - -let make_condition checks e1 e2 = - let cond = - List.fold (List.tl_exn checks) ~init:(List.hd_exn checks) ~f:(fun acc a -> - make_apply "( && )" acc a) - in - Pe_EIf (cond, e1, e2) -;; - let make_case expr pat case_expr not_match_expr = - let checks = check_pat expr pat in - let decl = check_decls expr pat in + let checks = check_pattern expr pat in + let decl = check_declaration expr pat in let let_expr = match decl with | Pe_Nonrec decl_list -> @@ -268,9 +165,6 @@ let make_case expr pat case_expr not_match_expr = if List.is_empty checks then let_expr else make_condition checks let_expr not_match_expr ;; -open MonadCounter -let get_id i = "a" ^ Int.to_string i - let rec pe_expr = let open Ast in function @@ -374,8 +268,8 @@ let rec pe_expr = and pe_match to_match = function | (p, e) :: tl -> - let checks = check_pat to_match p in - let decls = check_decls to_match p in + let checks = check_pattern to_match p in + let decls = check_declaration to_match p in let* e = pe_expr e in let let_in = (match decls with @@ -392,7 +286,7 @@ and pe_match to_match = function | _ -> return @@ Pe_EIdentifier "fail_match" ;; -let pe_declaration = function +let pe_program = function | NoRecDecl decl_list -> let* decls = map decl_list ~f:(fun (Ast.DDeclaration (pat, e)) -> @@ -420,7 +314,7 @@ let pe_structure program = let rec helper = function | [] -> return [] | hd :: tl -> - let* hd = pe_declaration hd in + let* hd = pe_program hd in let* tl = helper tl in return @@ hd :: tl in @@ -445,8 +339,6 @@ let rec get_binds_expr = function StrSet.union (get_binds_pat p) (get_binds_expr e))) | ETuple e_list -> StrSet.union_list @@ List.map e_list ~f:get_binds_expr -and get_binds_case (pat, e) = StrSet.union (get_binds_pat pat) (get_binds_expr e) - and get_binds_declaration = function | NoRecDecl decl_list -> List.fold decl_list ~init:StrSet.empty ~f:(fun acc (DDeclaration (pat, e)) -> @@ -456,7 +348,7 @@ and get_binds_declaration = function StrSet.union acc (StrSet.union (get_binds_pat pat) (get_binds_expr e))) ;; -let make_binds structure = +let create_bundle structure = let make_id id = let is_digit = function | '0' .. '9' -> true @@ -481,4 +373,4 @@ let make_binds structure = Set.filter_map (module Int) idents ~f:make_id ;; -let run_pe structure = run (pe_structure structure) (make_binds structure) 0 \ No newline at end of file +let run_pe structure = run (pe_structure structure) (create_bundle structure) 0 \ No newline at end of file From bc672225621a99dd819511dae26a05499b18d284 Mon Sep 17 00:00:00 2001 From: Dmitry Pilyuk Date: Thu, 6 Mar 2025 23:15:01 +0300 Subject: [PATCH 08/92] Add new manytests --- FML/tests/dune | 15 ++- FML/tests/inferencer_manytests.t | 14 +- FML/tests/parser_manytests.t | 213 ++++++++++++++++++++++++++++++- FML/tests/pe_manytests.t | 22 ++++ 4 files changed, 257 insertions(+), 7 deletions(-) diff --git a/FML/tests/dune b/FML/tests/dune index 918a2e27b..5169b8d8e 100644 --- a/FML/tests/dune +++ b/FML/tests/dune @@ -46,7 +46,9 @@ manytests/typed/007order.ml manytests/typed/008ascription.ml manytests/typed/009let_poly.ml - manytests/typed/010sukharev.ml + manytests/typed/011mapcps.ml + manytests/typed/012fibcps.ml + manytests/typed/013foldfoldr.ml manytests/typed/015tuples.ml manytests/typed/016lists.ml)) @@ -70,11 +72,12 @@ manytests/typed/007order.ml manytests/typed/008ascription.ml manytests/typed/009let_poly.ml - manytests/typed/010sukharev.ml + manytests/typed/011mapcps.ml + manytests/typed/012fibcps.ml + manytests/typed/013foldfoldr.ml manytests/typed/015tuples.ml manytests/typed/016lists.ml)) - (cram (applies_to pe_manytests) (deps @@ -95,6 +98,8 @@ manytests/typed/007order.ml manytests/typed/008ascription.ml manytests/typed/009let_poly.ml - manytests/typed/010sukharev.ml + manytests/typed/011mapcps.ml + manytests/typed/012fibcps.ml + manytests/typed/013foldfoldr.ml manytests/typed/015tuples.ml - manytests/typed/016lists.ml)) \ No newline at end of file + manytests/typed/016lists.ml)) diff --git a/FML/tests/inferencer_manytests.t b/FML/tests/inferencer_manytests.t index ef8f5b272..249ec35ba 100644 --- a/FML/tests/inferencer_manytests.t +++ b/FML/tests/inferencer_manytests.t @@ -45,6 +45,19 @@ $ ./inferencer_runner.exe < manytests/typed/009let_poly.ml val temp : int * bool + $ ./inferencer_runner.exe < manytests/typed/011mapcps.ml + val map : ('a -> 'b) -> 'a list -> ('b list -> 'c) -> 'c + val iter : ('a -> 'b) -> 'a list -> unit + val main : unit + $ ./inferencer_runner.exe < manytests/typed/012fibcps.ml + val fib : int -> (int -> 'a) -> 'a + val main : unit + $ ./inferencer_runner.exe < manytests/typed/013foldfoldr.ml + val id : 'a -> 'a + val fold_right : ('a -> 'b -> 'b) -> 'b -> 'a list -> 'b + val foldl : ('a -> 'b -> 'a) -> 'a -> 'b list -> 'a + val main : unit + $ ./inferencer_runner.exe < manytests/typed/015tuples.ml val fix : (('a -> 'b) -> 'a -> 'b) -> 'a -> 'b val map : ('a -> 'b) -> 'a * 'a -> 'b * 'b @@ -79,4 +92,3 @@ $ ./inferencer_runner.exe < manytests/do_not_type/015tuples.ml Type error: Only variables are allowed as left-hand side of `let rec' - diff --git a/FML/tests/parser_manytests.t b/FML/tests/parser_manytests.t index c4f811f04..9844eeba2 100644 --- a/FML/tests/parser_manytests.t +++ b/FML/tests/parser_manytests.t @@ -667,7 +667,217 @@ )) ]) ] - + $ ./parser_runner.exe < manytests/typed/011mapcps.ml + [(RecDecl + [(DDeclaration ((PIdentifier "map"), + (EFun ((PIdentifier "f"), + (EFun ((PIdentifier "xs"), + (EFun ((PIdentifier "k"), + (EMatch ((EIdentifier "xs"), + [(PNill, (EApplication ((EIdentifier "k"), ENill))); + ((PCons ((PIdentifier "h"), (PIdentifier "tl"))), + (EApplication ( + (EApplication ( + (EApplication ((EIdentifier "map"), + (EIdentifier "f"))), + (EIdentifier "tl"))), + (EFun ((PIdentifier "tl"), + (EApplication ((EIdentifier "k"), + (ECons ( + (EApplication ((EIdentifier "f"), + (EIdentifier "h"))), + (EIdentifier "tl"))) + )) + )) + ))) + ] + )) + )) + )) + )) + )) + ]); + (RecDecl + [(DDeclaration ((PIdentifier "iter"), + (EFun ((PIdentifier "f"), + (EFun ((PIdentifier "xs"), + (EMatch ((EIdentifier "xs"), + [(PNill, EUnit); + ((PCons ((PIdentifier "h"), (PIdentifier "tl"))), + (ELetIn (NoRec, (PIdentifier "w"), + (EApplication ((EIdentifier "f"), (EIdentifier "h"))), + (EApplication ( + (EApplication ((EIdentifier "iter"), + (EIdentifier "f"))), + (EIdentifier "tl"))) + ))) + ] + )) + )) + )) + )) + ]); + (NoRecDecl + [(DDeclaration ((PIdentifier "main"), + (EApplication ( + (EApplication ((EIdentifier "iter"), (EIdentifier "print_int"))), + (EApplication ( + (EApplication ( + (EApplication ((EIdentifier "map"), + (EFun ((PIdentifier "x"), + (EApplication ( + (EApplication ((EIdentifier "( + )"), + (EIdentifier "x"))), + (EConst (CInt 1)))) + )) + )), + (ECons ((EConst (CInt 1)), + (ECons ((EConst (CInt 2)), + (ECons ((EConst (CInt 3)), ENill)))) + )) + )), + (EFun ((PIdentifier "x"), (EIdentifier "x"))))) + )) + )) + ]) + ] + $ ./parser_runner.exe < manytests/typed/012fibcps.ml + [(RecDecl + [(DDeclaration ((PIdentifier "fib"), + (EFun ((PIdentifier "n"), + (EFun ((PIdentifier "k"), + (EIf ( + (EApplication ( + (EApplication ((EIdentifier "( < )"), (EIdentifier "n"))), + (EConst (CInt 2)))), + (EApplication ((EIdentifier "k"), (EIdentifier "n"))), + (EApplication ( + (EApplication ((EIdentifier "fib"), + (EApplication ( + (EApplication ((EIdentifier "( - )"), + (EIdentifier "n"))), + (EConst (CInt 1)))) + )), + (EFun ((PIdentifier "a"), + (EApplication ( + (EApplication ((EIdentifier "fib"), + (EApplication ( + (EApplication ((EIdentifier "( - )"), + (EIdentifier "n"))), + (EConst (CInt 2)))) + )), + (EFun ((PIdentifier "b"), + (EApplication ((EIdentifier "k"), + (EApplication ( + (EApplication ((EIdentifier "( + )"), + (EIdentifier "a"))), + (EIdentifier "b"))) + )) + )) + )) + )) + )) + )) + )) + )) + )) + ]); + (NoRecDecl + [(DDeclaration ((PIdentifier "main"), + (EApplication ((EIdentifier "print_int"), + (EApplication ( + (EApplication ((EIdentifier "fib"), (EConst (CInt 6)))), + (EFun ((PIdentifier "x"), (EIdentifier "x"))))) + )) + )) + ]) + ] + $ ./parser_runner.exe < manytests/typed/013foldfoldr.ml + [(NoRecDecl + [(DDeclaration ((PIdentifier "id"), + (EFun ((PIdentifier "x"), (EIdentifier "x"))))) + ]); + (RecDecl + [(DDeclaration ((PIdentifier "fold_right"), + (EFun ((PIdentifier "f"), + (EFun ((PIdentifier "acc"), + (EFun ((PIdentifier "xs"), + (EMatch ((EIdentifier "xs"), + [(PNill, (EIdentifier "acc")); + ((PCons ((PIdentifier "h"), (PIdentifier "tl"))), + (EApplication ( + (EApplication ((EIdentifier "f"), + (EIdentifier "h"))), + (EApplication ( + (EApplication ( + (EApplication ((EIdentifier "fold_right"), + (EIdentifier "f"))), + (EIdentifier "acc"))), + (EIdentifier "tl"))) + ))) + ] + )) + )) + )) + )) + )) + ]); + (NoRecDecl + [(DDeclaration ((PIdentifier "foldl"), + (EFun ((PIdentifier "f"), + (EFun ((PIdentifier "a"), + (EFun ((PIdentifier "bs"), + (EApplication ( + (EApplication ( + (EApplication ( + (EApplication ((EIdentifier "fold_right"), + (EFun ((PIdentifier "b"), + (EFun ((PIdentifier "g"), + (EFun ((PIdentifier "x"), + (EApplication ((EIdentifier "g"), + (EApplication ( + (EApplication ( + (EIdentifier "f"), + (EIdentifier "x"))), + (EIdentifier "b"))) + )) + )) + )) + )) + )), + (EIdentifier "id"))), + (EIdentifier "bs"))), + (EIdentifier "a"))) + )) + )) + )) + )) + ]); + (NoRecDecl + [(DDeclaration ((PIdentifier "main"), + (EApplication ((EIdentifier "print_int"), + (EApplication ( + (EApplication ( + (EApplication ((EIdentifier "foldl"), + (EFun ((PIdentifier "x"), + (EFun ((PIdentifier "y"), + (EApplication ( + (EApplication ((EIdentifier "( * )"), + (EIdentifier "x"))), + (EIdentifier "y"))) + )) + )) + )), + (EConst (CInt 1)))), + (ECons ((EConst (CInt 1)), + (ECons ((EConst (CInt 2)), + (ECons ((EConst (CInt 3)), ENill)))) + )) + )) + )) + )) + ]) + ] $ ./parser_runner.exe < manytests/typed/015tuples.ml [(RecDecl [(DDeclaration ((PIdentifier "fix"), @@ -1154,3 +1364,4 @@ (ETuple [(EIdentifier "a"); (EIdentifier "b")]))) ]) ] + diff --git a/FML/tests/pe_manytests.t b/FML/tests/pe_manytests.t index 460d34807..f20fbc870 100644 --- a/FML/tests/pe_manytests.t +++ b/FML/tests/pe_manytests.t @@ -103,6 +103,27 @@ let temp = let f = (fun x -> x) in ((f 1), (f true)) + $ ./pe_runner.exe < manytests/typed/011mapcps.ml + let rec map = (fun f xs k -> (k [])) + + let rec iter = (fun f xs -> ()) + + let main = ((iter print_int) (((map (fun x -> ((( + ) x) 1))) (1::(2::(3::[])))) (fun x -> x))) + $ ./pe_runner.exe < manytests/typed/012fibcps.ml + let rec fib = (fun n k -> if ((( < ) n) 2) + then (k n) + else ((fib ((( - ) n) 1)) (fun a -> ((fib ((( - ) n) 2)) (fun b -> (k ((( + ) a) b))))))) + + let main = (print_int ((fib 6) (fun x -> x))) + $ ./pe_runner.exe < manytests/typed/013foldfoldr.ml + let id = (fun x -> x) + + let rec fold_right = (fun f acc xs -> acc) + + let foldl = (fun f a bs -> ((((fold_right (fun b g x -> (g ((f x) b)))) id) bs) a)) + + let main = (print_int (((foldl (fun x y -> ((( * ) x) y))) 1) (1::(2::(3::[]))))) + $ ./pe_runner.exe < manytests/typed/015tuples.ml let rec fix = (fun f x -> ((f (fix f)) x)) @@ -174,3 +195,4 @@ $ ./pe_runner.exe < manytests/do_not_type/015tuples.ml Infer error: + From 96d0977979c95063de07a4bdfe74b4a65952dbe5 Mon Sep 17 00:00:00 2001 From: Dmitry Pilyuk Date: Fri, 7 Mar 2025 01:49:10 +0300 Subject: [PATCH 09/92] Fix problem with PNill --- FML/lib/anf/pattern_elim.ml | 98 ++++++++++++++++++++------------- FML/tests/pe_manytests.t | 107 +++++++++++++++++++++++++++++++----- 2 files changed, 152 insertions(+), 53 deletions(-) diff --git a/FML/lib/anf/pattern_elim.ml b/FML/lib/anf/pattern_elim.ml index e009818d6..5af632857 100644 --- a/FML/lib/anf/pattern_elim.ml +++ b/FML/lib/anf/pattern_elim.ml @@ -6,7 +6,6 @@ open Ast open Pe_ast open Common - let const_to_str = function | Pe_CBool b -> if b then "true" else "false" | Pe_Cint i -> Format.sprintf "%i" i @@ -52,7 +51,8 @@ let decl_to_str = function | (name, e) :: tl -> Format.sprintf "let %s = %s" name (expr_to_str e) ^ List.fold_left - (fun acc (name, e) -> acc ^ Format.sprintf "\nlet %s = %s" name (expr_to_str e)) + (fun acc (name, e) -> + acc ^ Format.sprintf "\nlet %s = %s" name (expr_to_str e)) "" tl) | Pe_Rec decl_list -> @@ -61,7 +61,8 @@ let decl_to_str = function | (name, e) :: tl -> Format.sprintf "let rec %s = %s" name (expr_to_str e) ^ List.fold_left - (fun acc (name, e) -> acc ^ Format.sprintf "\nand %s = %s" name (expr_to_str e)) + (fun acc (name, e) -> + acc ^ Format.sprintf "\nand %s = %s" name (expr_to_str e)) "" tl) ;; @@ -101,26 +102,38 @@ let const_to_peconst const = open Base open MonadCounter +(* let check_pattern expr pat = + let rec helper expr = function + | PConstraint (p, _) -> helper expr p + | PConst c -> [ make_apply "( = )" expr (const_to_peconst c) ] + | PTuple pl -> + List.concat @@ List.mapi pl ~f:(fun i p -> helper (get_element expr (Tuple i)) p) + | PCons (l, r) -> + let l = helper (get_element expr Cons_head) l in + + let r = helper (get_element expr Cons_tail) r in + l @ r + | PNill -> [ Pe_EApp (Pe_EIdentifier "is_empty", expr) ] + | _ -> [] + in + helper expr pat +;; *) + let check_pattern expr pat = let rec helper add expr = function | PConstraint (p, _) -> helper add expr p - | PConst c -> - (match c with - | _ -> [ make_apply "( = )" expr (const_to_peconst c) ]) + | PConst c -> [ make_apply "( = )" expr (const_to_peconst c) ] | PTuple pl -> - let t = List.mapi pl ~f:(fun i p -> helper true (get_element expr (Tuple i)) p) in - List.concat t + List.concat + @@ List.mapi pl ~f:(fun i p -> helper true (get_element expr (Tuple i)) p) | PCons (l, r) -> - let rec length l = function - | Ast.PCons (_, r) -> length (l + 1) r - | _ -> l + let check = + Pe_EApp (Pe_EIdentifier "not", Pe_EApp (Pe_EIdentifier "is_empty", expr)) in - let min_length = length 0 r in - let list_length = Pe_EApp (Pe_EIdentifier "list_len", expr) in - let check = make_apply "( > )" list_length (Pe_EConst (Pe_Cint min_length)) in let l = helper true (get_element expr Cons_head) l in let r = helper false (get_element expr Cons_tail) r in if add then (check :: l) @ r else l @ r + | PNill -> [ Pe_EApp (Pe_EIdentifier "is_empty", expr) ] | _ -> [] in helper true expr pat @@ -146,7 +159,7 @@ let check_declaration expr pat = get_element acc unpack) in let names = get_binds_pat pat in - let decls = List.map (StrSet.to_list names) ~f:(fun name -> (name, create_expr name)) in + let decls = List.map (StrSet.to_list names) ~f:(fun name -> name, create_expr name) in Pe_Nonrec decls ;; @@ -230,7 +243,9 @@ let rec pe_expr = Pe_ETuple vals in let* fresh_name = fresh >>| get_id in - let case_expr = make_case (Pe_EIdentifier fresh_name) pat new_body (Pe_EIdentifier "fail_match") in + let case_expr = + make_case (Pe_EIdentifier fresh_name) pat new_body (Pe_EIdentifier "fail_match") + in return @@ Pe_EFun (new_args, Pe_ELet (NoRec, fresh_name, to_match, case_expr))) | EMatch (e_last, case_list) -> let* e = pe_expr e_last in @@ -239,7 +254,7 @@ let rec pe_expr = | _ -> let* fresh_name = fresh >>| get_id in let* e_match = pe_match (Pe_EIdentifier fresh_name) case_list in - return @@ (Pe_ELet (NoRec, fresh_name, e, e_match))) + return @@ Pe_ELet (NoRec, fresh_name, e, e_match)) | ELetIn (NoRec, pat, e1, e2) -> let* e1 = pe_expr e1 in let* e2 = pe_expr e2 in @@ -253,18 +268,22 @@ let rec pe_expr = return case_expr | _ -> let* fresh_name = fresh >>| get_id in - let case_expr = make_case (Pe_EIdentifier fresh_name) pat e2 (Pe_EIdentifier "fail_match") in + let case_expr = + make_case (Pe_EIdentifier fresh_name) pat e2 (Pe_EIdentifier "fail_match") + in return @@ Pe_ELet (NoRec, fresh_name, e1, case_expr))) - | ELetIn (Rec, pat, e1, e2) -> - let* e1 = pe_expr e1 in - let* e2 = pe_expr e2 in - (match pat with - | PIdentifier name -> return @@ Pe_ELet (Rec, name, e1, e2) - | PUnit -> return @@ Pe_ELet (Rec, "()", e1, e2) - | _ -> - let* fresh_name = fresh >>| get_id in - let case_expr = make_case (Pe_EIdentifier fresh_name) pat e2 (Pe_EIdentifier "fail_match") in - return @@ Pe_ELet (Rec, fresh_name, e1, case_expr)) + | ELetIn (Rec, pat, e1, e2) -> + let* e1 = pe_expr e1 in + let* e2 = pe_expr e2 in + (match pat with + | PIdentifier name -> return @@ Pe_ELet (Rec, name, e1, e2) + | PUnit -> return @@ Pe_ELet (Rec, "()", e1, e2) + | _ -> + let* fresh_name = fresh >>| get_id in + let case_expr = + make_case (Pe_EIdentifier fresh_name) pat e2 (Pe_EIdentifier "fail_match") + in + return @@ Pe_ELet (Rec, fresh_name, e1, case_expr)) and pe_match to_match = function | (p, e) :: tl -> @@ -272,11 +291,13 @@ and pe_match to_match = function let decls = check_declaration to_match p in let* e = pe_expr e in let let_in = - (match decls with - | Pe_Nonrec decl_list -> - List.fold_right decl_list ~init:e ~f:(fun (name, value) acc -> Pe_ELet (NoRec, name, value, acc)) - | Pe_Rec decl_list -> - List.fold_right decl_list ~init:e ~f:(fun (name, value) acc -> Pe_ELet (Rec, name, value, acc))) + match decls with + | Pe_Nonrec decl_list -> + List.fold_right decl_list ~init:e ~f:(fun (name, value) acc -> + Pe_ELet (NoRec, name, value, acc)) + | Pe_Rec decl_list -> + List.fold_right decl_list ~init:e ~f:(fun (name, value) acc -> + Pe_ELet (Rec, name, value, acc)) in if List.is_empty checks then return let_in @@ -305,7 +326,8 @@ let pe_program = function let* e = pe_expr e in match pat with | PIdentifier v -> return (v, e) - | _ -> return ("()", e)) (* TODO: более информативное сообщение *) + | _ -> return ("()", e)) + (* TODO: более информативное сообщение *) in return (Pe_Rec decls) ;; @@ -316,14 +338,14 @@ let pe_structure program = | hd :: tl -> let* hd = pe_program hd in let* tl = helper tl in - return @@ hd :: tl + return @@ (hd :: tl) in helper program ;; let rec get_binds_expr = function | EConstraint (e, _) -> get_binds_expr e - | EConst _ | EUnit |ENill-> StrSet.empty + | EConst _ | EUnit | ENill -> StrSet.empty | EIdentifier ident -> StrSet.singleton ident | ECons (e1, e2) -> StrSet.union (get_binds_expr e1) (get_binds_expr e2) | EApplication (e1, e2) -> StrSet.union (get_binds_expr e1) (get_binds_expr e2) @@ -344,7 +366,7 @@ and get_binds_declaration = function List.fold decl_list ~init:StrSet.empty ~f:(fun acc (DDeclaration (pat, e)) -> StrSet.union acc (StrSet.union (get_binds_pat pat) (get_binds_expr e))) | RecDecl decl_list -> - List.fold decl_list ~init:StrSet.empty ~f:(fun acc (DDeclaration (pat, e)) -> + List.fold decl_list ~init:StrSet.empty ~f:(fun acc (DDeclaration (pat, e)) -> StrSet.union acc (StrSet.union (get_binds_pat pat) (get_binds_expr e))) ;; @@ -373,4 +395,4 @@ let create_bundle structure = Set.filter_map (module Int) idents ~f:make_id ;; -let run_pe structure = run (pe_structure structure) (create_bundle structure) 0 \ No newline at end of file +let run_pe structure = run (pe_structure structure) (create_bundle structure) 0 diff --git a/FML/tests/pe_manytests.t b/FML/tests/pe_manytests.t index f20fbc870..74f4fde83 100644 --- a/FML/tests/pe_manytests.t +++ b/FML/tests/pe_manytests.t @@ -104,9 +104,22 @@ ((f 1), (f true)) $ ./pe_runner.exe < manytests/typed/011mapcps.ml - let rec map = (fun f xs k -> (k [])) - - let rec iter = (fun f xs -> ()) + let rec map = (fun f xs k -> if (is_empty xs) + then (k []) + else if (not (is_empty xs)) + then let h = (list_head xs) in + let tl = (list_tail xs) in + (((map f) tl) (fun tl -> (k ((f h)::tl)))) + else fail_match) + + let rec iter = (fun f xs -> if (is_empty xs) + then () + else if (not (is_empty xs)) + then let h = (list_head xs) in + let tl = (list_tail xs) in + let w = (f h) in + ((iter f) tl) + else fail_match) let main = ((iter print_int) (((map (fun x -> ((( + ) x) 1))) (1::(2::(3::[])))) (fun x -> x))) $ ./pe_runner.exe < manytests/typed/012fibcps.ml @@ -118,7 +131,13 @@ $ ./pe_runner.exe < manytests/typed/013foldfoldr.ml let id = (fun x -> x) - let rec fold_right = (fun f acc xs -> acc) + let rec fold_right = (fun f acc xs -> if (is_empty xs) + then acc + else if (not (is_empty xs)) + then let h = (list_head xs) in + let tl = (list_tail xs) in + ((f h) (((fold_right f) acc) tl)) + else fail_match) let foldl = (fun f a bs -> ((((fold_right (fun b g x -> (g ((f x) b)))) id) bs) a)) @@ -163,21 +182,79 @@ 0 $ ./pe_runner.exe < manytests/typed/016lists.ml - let rec length = (fun xs -> 0) - - let length_tail = let rec helper = (fun acc xs -> acc) in + let rec length = (fun xs -> if (is_empty xs) + then 0 + else if (not (is_empty xs)) + then let h = (list_head xs) in + let tl = (list_tail xs) in + ((( + ) 1) (length tl)) + else fail_match) + + let length_tail = let rec helper = (fun acc xs -> if (is_empty xs) + then acc + else if (not (is_empty xs)) + then let h = (list_head xs) in + let tl = (list_tail xs) in + ((helper ((( + ) acc) 1)) tl) + else fail_match) in (helper 0) - let rec map = (fun f xs -> []) - - let rec append = (fun xs ys -> ys) - - let concat = let rec helper = (fun xs -> []) in + let rec map = (fun f xs -> if (is_empty xs) + then [] + else if ((( && ) (not (is_empty xs))) (is_empty (list_tail xs))) + then let a = (list_head xs) in + ((f a)::[]) + else if ((( && ) (not (is_empty xs))) (is_empty (list_tail (list_tail xs)))) + then let a = (list_head xs) in + let b = (list_head (list_tail xs)) in + ((f a)::((f b)::[])) + else if ((( && ) (not (is_empty xs))) (is_empty (list_tail (list_tail (list_tail xs))))) + then let a = (list_head xs) in + let b = (list_head (list_tail xs)) in + let c = (list_head (list_tail (list_tail xs))) in + ((f a)::((f b)::((f c)::[]))) + else if (not (is_empty xs)) + then let a = (list_head xs) in + let b = (list_head (list_tail xs)) in + let c = (list_head (list_tail (list_tail xs))) in + let d = (list_head (list_tail (list_tail (list_tail xs)))) in + let tl = (list_tail (list_tail (list_tail (list_tail xs)))) in + ((f a)::((f b)::((f c)::((f d)::((map f) tl))))) + else fail_match) + + let rec append = (fun xs ys -> if (is_empty xs) + then ys + else if (not (is_empty xs)) + then let x = (list_head xs) in + let xs = (list_tail xs) in + (x::((append xs) ys)) + else fail_match) + + let concat = let rec helper = (fun xs -> if (is_empty xs) + then [] + else if (not (is_empty xs)) + then let h = (list_head xs) in + let tl = (list_tail xs) in + ((append h) (helper tl)) + else fail_match) in helper - let rec iter = (fun f xs -> ()) - - let rec cartesian = (fun xs ys -> []) + let rec iter = (fun f xs -> if (is_empty xs) + then () + else if (not (is_empty xs)) + then let h = (list_head xs) in + let tl = (list_tail xs) in + let () = (f h) in + ((iter f) tl) + else fail_match) + + let rec cartesian = (fun xs ys -> if (is_empty xs) + then [] + else if (not (is_empty xs)) + then let h = (list_head xs) in + let tl = (list_tail xs) in + ((append ((map (fun a -> (h, a))) ys)) ((cartesian tl) ys)) + else fail_match) let main = let () = ((iter print_int) (1::(2::(3::[])))) in let () = (print_int (length ((cartesian (1::(2::[]))) (1::(2::(3::(4::[]))))))) in From bd343e38b3a7c491f85fb0b23c1b0c2cbac4b4f8 Mon Sep 17 00:00:00 2001 From: RozhkovAleksandr Date: Fri, 7 Mar 2025 13:23:45 +0300 Subject: [PATCH 10/92] pe fix(ast trouble) --- FML/lib/anf/pattern_elim.ml | 7 +++---- FML/lib/anf/pe_ast.ml | 1 - 2 files changed, 3 insertions(+), 5 deletions(-) diff --git a/FML/lib/anf/pattern_elim.ml b/FML/lib/anf/pattern_elim.ml index 5af632857..5350667cc 100644 --- a/FML/lib/anf/pattern_elim.ml +++ b/FML/lib/anf/pattern_elim.ml @@ -16,7 +16,6 @@ let rec expr_to_str = function | Pe_ENill -> "[]" | Pe_EIdentifier a -> a | Pe_EConst c -> const_to_str c - | Pe_EVar id -> id | Pe_EIf (e1, e2, e3) -> Format.sprintf "if %s\nthen %s\nelse %s" @@ -84,9 +83,9 @@ type value_to_get = | Other let get_element e = function - | Tuple i -> Pe_EApp (Pe_EApp (Pe_EVar "tuple_element", e), Pe_EConst (Pe_Cint i)) - | Cons_head -> Pe_EApp (Pe_EVar "list_head", e) - | Cons_tail -> Pe_EApp (Pe_EVar "list_tail", e) + | Tuple i -> Pe_EApp (Pe_EApp (Pe_EIdentifier "tuple_element", e), Pe_EConst (Pe_Cint i)) + | Cons_head -> Pe_EApp (Pe_EIdentifier "list_head", e) + | Cons_tail -> Pe_EApp (Pe_EIdentifier "list_tail", e) | Other -> e ;; diff --git a/FML/lib/anf/pe_ast.ml b/FML/lib/anf/pe_ast.ml index 9c9dd9d0c..62fc21c63 100644 --- a/FML/lib/anf/pe_ast.ml +++ b/FML/lib/anf/pe_ast.ml @@ -15,7 +15,6 @@ type pe_expr = | Pe_ENill | Pe_EIdentifier of string | Pe_EConst of pe_const - | Pe_EVar of string | Pe_EIf of pe_expr * pe_expr * pe_expr | Pe_EFun of string list * pe_expr | Pe_EApp of pe_expr * pe_expr From ecc44623f174c5171cca1cc64dad2f324237b835 Mon Sep 17 00:00:00 2001 From: RozhkovAleksandr Date: Fri, 7 Mar 2025 14:42:13 +0300 Subject: [PATCH 11/92] add monade --- FML/lib/anf/common.ml | 35 +++++++++++++++++++++++++++++++++-- 1 file changed, 33 insertions(+), 2 deletions(-) diff --git a/FML/lib/anf/common.ml b/FML/lib/anf/common.ml index 605db5253..72212203b 100644 --- a/FML/lib/anf/common.ml +++ b/FML/lib/anf/common.ml @@ -6,6 +6,39 @@ open Base open Ast open Pe_ast +module StrMap = struct + type 'a t = (string, 'a, String.comparator_witness) Map.t + + let empty = Map.empty (module String) + let singleton str = Map.singleton (module String) str + let find m str = Map.find m str + let add = Map.add + let update = Map.update + let merge_two fst snd = Map.merge_skewed fst snd ~combine:(fun ~key:_ _ v2 -> v2) +end + +let builtins = + [ "( + )" + ; "( - )" + ; "( / )" + ; "( * )" + ; "( < )" + ; "( > )" + ; "( <= )" + ; "( >= )" + ; "( <> )" + ; "( = )" + ; "( != )" + ; "( && )" + ; "( || )" + ; "print_int" + ; "list_head" + ; "list_tail" + ; "list_len" + ; "tuple_element" + ; "fail_match" + ] +;; let make_apply op expr1 expr2 = Pe_EApp (Pe_EApp (Pe_EIdentifier op, expr1), expr2) @@ -26,8 +59,6 @@ module StrSet = struct let diff = Set.diff end - - type bindings = (int, Int.comparator_witness) Set.t let contains ng id = From 31e8f600f0b31c3aab2fb76d036fd9cc78a109af Mon Sep 17 00:00:00 2001 From: RozhkovAleksandr Date: Fri, 7 Mar 2025 15:57:17 +0300 Subject: [PATCH 12/92] add alpha converter --- FML/lib/anf/alpha_conv.ml | 127 +++++++++++++++ FML/lib/dune | 3 +- FML/tests/alpha_conv_manytest.t | 275 ++++++++++++++++++++++++++++++++ FML/tests/alpha_conv_runner.ml | 27 ++++ FML/tests/dune | 32 ++++ 5 files changed, 463 insertions(+), 1 deletion(-) create mode 100644 FML/lib/anf/alpha_conv.ml create mode 100644 FML/tests/alpha_conv_manytest.t create mode 100644 FML/tests/alpha_conv_runner.ml diff --git a/FML/lib/anf/alpha_conv.ml b/FML/lib/anf/alpha_conv.ml new file mode 100644 index 000000000..9d24c1faf --- /dev/null +++ b/FML/lib/anf/alpha_conv.ml @@ -0,0 +1,127 @@ +(** Copyright 2024-2025, Dmitry Pilyuk, Aleksandr Rozhkov *) + +(** SPDX-License-Identifier: LGPL-2.1 *) + +open Base +open Pe_ast +open Common +open Common.MonadCounter +open Common.StrSet + +let rec ac_expr env bindings = function + | Pe_EUnit -> return Pe_EUnit + | Pe_ENill -> return Pe_ENill + | Pe_EConst _ as c -> return c + | Pe_EIdentifier x as v -> + (match StrMap.find bindings x with + | Some x -> return @@ Pe_EIdentifier x + | None -> return v) + | Pe_ECons (h, t) -> + let* h = ac_expr env bindings h in + let* t = ac_expr env bindings t in + return @@ Pe_ECons (h, t) + | Pe_EApp (e1, e2) -> + let* e1 = ac_expr env bindings e1 in + let* e2 = ac_expr env bindings e2 in + return @@ Pe_EApp (e1, e2) + | Pe_EIf (e1, e2, e3) -> + let* e1 = ac_expr env bindings e1 in + let* e2 = ac_expr env bindings e2 in + let* e3 = ac_expr env bindings e3 in + return @@ Pe_EIf (e1, e2, e3) + | Pe_EFun (args, body) -> + let* args, env, bindings = + fold_left + args + ~init:(return ([], env, bindings)) + ~f:(fun (names, env, bindings) name -> + let* env, bindings, name = rename env bindings name in + return (name :: names, env, bindings)) + in + let args = List.rev args in + let* body = ac_expr env bindings body in + return @@ Pe_EFun (args, body) + | Pe_ETuple el -> + let* e_list = map el ~f:(ac_expr env bindings) in + return @@ Pe_ETuple e_list + | Pe_ELet (rec_flag, name, e1, e2) -> + let* new_e1 = ac_expr env bindings e1 in + let* env, bindings, new_name = rename env bindings name in + let* new_e2 = ac_expr env bindings e2 in + return @@ Pe_ELet (rec_flag, new_name, new_e1, new_e2) + +and rename env binds name = + if String.equal name "()" + then return (env, binds, "()") + else if find env name + then + let* fresh = fresh in + let id = get_id fresh in + return (add env id, StrMap.update binds name ~f:(fun _ -> id), id) + else return (add env name, binds, name) +;; + +let ac_declaration env bindings = function + | Pe_Nonrec bindings_list -> + let ids, exps = List.unzip bindings_list in + let* ids, env, bindings = + fold_left + ids + ~init:(return ([], env, bindings)) + ~f:(fun (ids, env, bindings) id -> + let* env, bindings, id = rename env bindings id in + return (id :: ids, env, bindings)) + in + let ids = List.rev ids in + let exps = List.map exps ~f:(ac_expr env bindings) in + let* bindings_list = + List.fold2_exn + ids + exps + ~init:(return []) + ~f:(fun acc name expr -> + let* acc = acc in + let* expr = expr in + return ((name, expr) :: acc)) + in + let bindings_list = List.rev bindings_list in + return (env, bindings, Pe_Nonrec bindings_list) + | Pe_Rec bindings_list -> + let ids, exps = List.unzip bindings_list in + let* ids, env, bindings = + fold_left + ids + ~init:(return ([], env, bindings)) + ~f:(fun (ids, env, bindings) id -> + let* env, bindings, id = rename env bindings id in + return (id :: ids, env, bindings)) + in + let ids = List.rev ids in + let exps = List.map exps ~f:(ac_expr env bindings) in + let* bindings_list = + List.fold2_exn + ids + exps + ~init:(return []) + ~f:(fun acc name expr -> + let* acc = acc in + let* expr = expr in + return ((name, expr) :: acc)) + in + let bindings_list = List.rev bindings_list in + return (env, bindings, Pe_Rec bindings_list) +;; +let ac_program program env = + let rec helper env bindings = function + | [] -> return [] + | hd :: tl -> + let* env, bindings, ast = ac_declaration env bindings hd in + let* rest = helper env bindings tl in + return (ast :: rest) + in + helper env (Map.empty (module String)) program +;; + +let run_alpha_conv bindings init prog = + run (ac_program prog (of_list builtins)) bindings init +;; \ No newline at end of file diff --git a/FML/lib/dune b/FML/lib/dune index 8eb8e9e04..1baeaced1 100644 --- a/FML/lib/dune +++ b/FML/lib/dune @@ -12,7 +12,8 @@ Typedtree Pattern_elim Common - Pe_ast) + Pe_ast + Alpha_conv) (modules_without_implementation inf_errors) (libraries base angstrom) (preprocess diff --git a/FML/tests/alpha_conv_manytest.t b/FML/tests/alpha_conv_manytest.t new file mode 100644 index 000000000..11477cd97 --- /dev/null +++ b/FML/tests/alpha_conv_manytest.t @@ -0,0 +1,275 @@ + $ ./alpha_conv_runner.exe < manytests/typed/001fac.ml + let rec fac = (fun n -> if ((( <= ) n) 1) + then 1 + else ((( * ) n) (fac ((( - ) n) 1)))) + + let main = let () = (print_int (fac 4)) in + 0 + + $ ./alpha_conv_runner.exe < manytests/typed/002fac.ml + let rec fac_cps = (fun n k -> if ((( = ) n) 1) + then (k 1) + else ((fac_cps ((( - ) n) 1)) (fun p -> (k ((( * ) p) n))))) + + let main = let () = (print_int ((fac_cps 4) (fun a0 -> a0))) in + 0 + + $ ./alpha_conv_runner.exe < manytests/typed/003fib.ml + let rec fib_acc = (fun a b n -> if ((( = ) n) 1) + then b + else let n1 = ((( - ) n) 1) in + let ab = ((( + ) a) b) in + (((fib_acc b) ab) n1)) + + let rec fib = (fun n -> if ((( < ) n) 2) + then n + else ((( + ) (fib ((( - ) n) 1))) (fib ((( - ) n) 2)))) + + let main = let () = (print_int (((fib_acc 0) 1) 4)) in + let () = (print_int (fib 4)) in + 0 + + $ ./alpha_conv_runner.exe < manytests/typed/004manyargs.ml + let wrap = (fun f -> if ((( = ) 1) 1) + then f + else f) + + let test3 = (fun a b c -> let a0 = (print_int a) in + let a1 = (print_int b) in + let a2 = (print_int c) in + 0) + + let test10 = (fun a b c d e f g h i j -> ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) a) b)) c)) d)) e)) f)) g)) h)) i)) j)) + + let main = let rez = (((((((((((wrap test10) 1) 10) 100) 1000) 10000) 100000) 1000000) 10000000) 100000000) 1000000000) in + let () = (print_int rez) in + let temp2 = ((((wrap test3) 1) 10) 100) in + 0 + + $ ./alpha_conv_runner.exe < manytests/typed/005fix.ml + let rec fix = (fun f x -> ((f (fix f)) x)) + + let fac = (fun self n -> if ((( <= ) n) 1) + then 1 + else ((( * ) n) (self ((( - ) n) 1)))) + + let main = let () = (print_int ((fix fac) 6)) in + 0 + + $ ./alpha_conv_runner.exe < manytests/typed/006partial.ml + let foo = (fun b -> if b + then (fun a0 -> ((( + ) a0) 2)) + else (fun a1 -> ((( * ) a1) 10))) + + let a2 = (fun x -> ((a2 true) ((a2 false) ((a2 true) ((a2 false) x))))) + + let main = let () = (print_int (a2 11)) in + 0 + + $ ./alpha_conv_runner.exe < manytests/typed/006partial2.ml + let foo = (fun a b c -> let () = (print_int a) in + let () = (print_int b) in + let () = (print_int c) in + ((( + ) a) ((( * ) b) c))) + + let main = let a0 = (foo 1) in + let a1 = (a0 2) in + let a2 = (a1 3) in + let () = (print_int a2) in + 0 + $ ./alpha_conv_runner.exe < manytests/typed/006partial3.ml + let foo = (fun a -> let () = (print_int a) in + (fun b -> let () = (print_int b) in + (fun c -> (print_int c)))) + + let main = let () = (((foo 4) 8) 9) in + 0 + $ ./alpha_conv_runner.exe < manytests/typed/007order.ml + let _start = (fun a0 a1 a a2 b _c a3 d __ -> let a4 = (a0, a1, a2, a3) in + let () = (print_int ((( + ) a) b)) in + let () = (print_int __) in + ((( + ) ((( / ) ((( * ) a) b)) _c)) d)) + + let main = (print_int (((((((((_start (print_int 1)) (print_int 2)) 3) (print_int 4)) 100) 1000) (print_int (( ~- ) 1))) 10000) (( ~- ) 555555))) + $ ./alpha_conv_runner.exe < manytests/typed/008ascription.ml + let addi = (fun f g x -> ((f x) (g x))) + + let main = let () = (print_int (((addi (fun x b -> if b + then ((( + ) x) 1) + else ((( * ) x) 2))) (fun _start -> ((( = ) ((( / ) _start) 2)) 0))) 4)) in + 0 + + $ ./alpha_conv_runner.exe < manytests/typed/009let_poly.ml + let temp = let f = (fun x -> x) in + ((f 1), (f true)) + + $ ./alpha_conv_runner.exe < manytests/typed/011mapcps.ml + let rec map = (fun f xs k -> if (is_empty xs) + then (k []) + else if (not (is_empty xs)) + then let h = (list_head xs) in + let tl = (list_tail xs) in + (((map f) tl) (fun a0 -> (k ((f h)::a0)))) + else fail_match) + + let rec iter = (fun f xs -> if (is_empty xs) + then () + else if (not (is_empty xs)) + then let h = (list_head xs) in + let tl = (list_tail xs) in + let w = (f h) in + ((iter f) tl) + else fail_match) + + let main = ((iter print_int) (((map (fun x -> ((( + ) x) 1))) (1::(2::(3::[])))) (fun x -> x))) + $ ./alpha_conv_runner.exe < manytests/typed/012fibcps.ml + let rec fib = (fun n k -> if ((( < ) n) 2) + then (k n) + else ((fib ((( - ) n) 1)) (fun a -> ((fib ((( - ) n) 2)) (fun b -> (k ((( + ) a) b))))))) + + let main = (print_int ((fib 6) (fun x -> x))) + $ ./alpha_conv_runner.exe < manytests/typed/013foldfoldr.ml + let id = (fun x -> x) + + let rec fold_right = (fun f acc xs -> if (is_empty xs) + then acc + else if (not (is_empty xs)) + then let h = (list_head xs) in + let tl = (list_tail xs) in + ((f h) (((fold_right f) acc) tl)) + else fail_match) + + let foldl = (fun f a bs -> ((((fold_right (fun b g x -> (g ((f x) b)))) id) bs) a)) + + let main = (print_int (((foldl (fun x y -> ((( * ) x) y))) 1) (1::(2::(3::[]))))) + + $ ./alpha_conv_runner.exe < manytests/typed/015tuples.ml + let rec fix = (fun f x -> ((f (fix f)) x)) + + let map = (fun f p -> let a = ((tuple_element p) 0) in + let b = ((tuple_element p) 1) in + ((f a), (f b))) + + let fixpoly = (fun l -> ((fix (fun self a0 -> ((map (fun li x -> ((li (self a0)) x))) a0))) l)) + + let feven = (fun p n -> let e = ((tuple_element p) 0) in + let o = ((tuple_element p) 1) in + if ((( == ) n) 0) + then 1 + else (o ((( - ) n) 1))) + + let fodd = (fun p n -> let e = ((tuple_element p) 0) in + let o = ((tuple_element p) 1) in + if ((( == ) n) 0) + then 0 + else (e ((( - ) n) 1))) + + let tie = (fixpoly (feven, fodd)) + + let rec meven = (fun n -> if ((( = ) n) 0) + then 1 + else (modd ((( - ) n) 1))) + and modd = (fun n -> if ((( = ) n) 0) + then 1 + else (meven ((( - ) n) 1))) + + let main = let () = (print_int (modd 1)) in + let () = (print_int (meven 2)) in + let even = ((tuple_element tie) 0) in + let odd = ((tuple_element tie) 1) in + let () = (print_int (odd 3)) in + let () = (print_int (even 4)) in + 0 + + $ ./alpha_conv_runner.exe < manytests/typed/016lists.ml + let rec length = (fun xs -> if (is_empty xs) + then 0 + else if (not (is_empty xs)) + then let h = (list_head xs) in + let tl = (list_tail xs) in + ((( + ) 1) (length tl)) + else fail_match) + + let length_tail = let rec helper = (fun acc xs -> if (is_empty xs) + then acc + else if (not (is_empty xs)) + then let h = (list_head xs) in + let tl = (list_tail xs) in + ((helper ((( + ) acc) 1)) tl) + else fail_match) in + (helper 0) + + let rec map = (fun f xs -> if (is_empty xs) + then [] + else if ((( && ) (not (is_empty xs))) (is_empty (list_tail xs))) + then let a = (list_head xs) in + ((f a)::[]) + else if ((( && ) (not (is_empty xs))) (is_empty (list_tail (list_tail xs)))) + then let a = (list_head xs) in + let b = (list_head (list_tail xs)) in + ((f a)::((f b)::[])) + else if ((( && ) (not (is_empty xs))) (is_empty (list_tail (list_tail (list_tail xs))))) + then let a = (list_head xs) in + let b = (list_head (list_tail xs)) in + let c = (list_head (list_tail (list_tail xs))) in + ((f a)::((f b)::((f c)::[]))) + else if (not (is_empty xs)) + then let a = (list_head xs) in + let b = (list_head (list_tail xs)) in + let c = (list_head (list_tail (list_tail xs))) in + let d = (list_head (list_tail (list_tail (list_tail xs)))) in + let tl = (list_tail (list_tail (list_tail (list_tail xs)))) in + ((f a)::((f b)::((f c)::((f d)::((map f) tl))))) + else fail_match) + + let rec append = (fun xs ys -> if (is_empty xs) + then ys + else if (not (is_empty xs)) + then let x = (list_head xs) in + let a0 = (list_tail xs) in + (x::((append a0) ys)) + else fail_match) + + let concat = let rec helper = (fun xs -> if (is_empty xs) + then [] + else if (not (is_empty xs)) + then let h = (list_head xs) in + let tl = (list_tail xs) in + ((append h) (helper tl)) + else fail_match) in + helper + + let rec iter = (fun f xs -> if (is_empty xs) + then () + else if (not (is_empty xs)) + then let h = (list_head xs) in + let tl = (list_tail xs) in + let () = (f h) in + ((iter f) tl) + else fail_match) + + let rec cartesian = (fun xs ys -> if (is_empty xs) + then [] + else if (not (is_empty xs)) + then let h = (list_head xs) in + let tl = (list_tail xs) in + ((append ((map (fun a -> (h, a))) ys)) ((cartesian tl) ys)) + else fail_match) + + let main = let () = ((iter print_int) (1::(2::(3::[])))) in + let () = (print_int (length ((cartesian (1::(2::[]))) (1::(2::(3::(4::[]))))))) in + 0 + + $ ./alpha_conv_runner.exe < manytests/do_not_type/001.ml + Infer error: + $ ./alpha_conv_runner.exe < manytests/do_not_type/002if.ml + Infer error: + $ ./alpha_conv_runner.exe < manytests/do_not_type/003occurs.ml + Infer error: + + $ ./alpha_conv_runner.exe < manytests/do_not_type/004let_poly.ml + Infer error: + + $ ./alpha_conv_runner.exe < manytests/do_not_type/015tuples.ml + Infer error: + diff --git a/FML/tests/alpha_conv_runner.ml b/FML/tests/alpha_conv_runner.ml new file mode 100644 index 000000000..4e372c906 --- /dev/null +++ b/FML/tests/alpha_conv_runner.ml @@ -0,0 +1,27 @@ +(** Copyright 2024-2025, Dmitry Pilyuk, Aleksandr Rozhkov *) + +(** SPDX-License-Identifier: LGPL-2.1 *) + +open Fml_lib.Parser +open Fml_lib.Inferencer +open Fml_lib.Pattern_elim +open Fml_lib.Alpha_conv + + +let () = + let input = Stdio.In_channel.input_all Stdlib.stdin in + let parse_and_infer input = + match parse input with + | Ok parsed -> + (match run_program_inferencer parsed with + | Ok _ -> Ok parsed + | Error _ -> Error (Format.asprintf "Infer error:" )) + | Error e -> Error (Format.sprintf "Parsing error: %s" e) + in + match parse_and_infer input with + | Ok ast -> + let bind, cnt, ast = run_pe ast in + let _, _, ast = run_alpha_conv bind cnt ast in + Format.printf "%a" pp_pe_structure ast + | Error message -> Format.printf "%s" message +;; \ No newline at end of file diff --git a/FML/tests/dune b/FML/tests/dune index 5169b8d8e..d5facd44e 100644 --- a/FML/tests/dune +++ b/FML/tests/dune @@ -26,6 +26,12 @@ (modules pe_runner) (libraries fml_lib stdio)) + (executable + (name alpha_conv_runner) + (public_name alpha_conv_runner) + (modules alpha_conv_runner) + (libraries fml_lib stdio)) + (cram (applies_to parser_manytests) (deps @@ -103,3 +109,29 @@ manytests/typed/013foldfoldr.ml manytests/typed/015tuples.ml manytests/typed/016lists.ml)) + +(cram + (applies_to alpha_conv_manytest) + (deps + ./alpha_conv_runner.exe + manytests/do_not_type/001.ml + manytests/do_not_type/002if.ml + manytests/do_not_type/003occurs.ml + manytests/do_not_type/004let_poly.ml + manytests/do_not_type/015tuples.ml + manytests/typed/001fac.ml + manytests/typed/002fac.ml + manytests/typed/003fib.ml + manytests/typed/004manyargs.ml + manytests/typed/005fix.ml + manytests/typed/006partial.ml + manytests/typed/006partial2.ml + manytests/typed/006partial3.ml + manytests/typed/007order.ml + manytests/typed/008ascription.ml + manytests/typed/009let_poly.ml + manytests/typed/011mapcps.ml + manytests/typed/012fibcps.ml + manytests/typed/013foldfoldr.ml + manytests/typed/015tuples.ml + manytests/typed/016lists.ml)) \ No newline at end of file From 409a271333d84ce2036f4dda189676f67eb17087 Mon Sep 17 00:00:00 2001 From: Dmitry Pilyuk Date: Sat, 8 Mar 2025 15:18:15 +0300 Subject: [PATCH 13/92] Closure converdion --- FML/lib/anf/alpha_conv.ml | 87 +++++----- FML/lib/anf/closure_conv.ml | 164 ++++++++++++++++++ FML/lib/anf/common.ml | 10 +- FML/lib/dune | 3 +- FML/tests/closure_conv_manytest.t | 275 ++++++++++++++++++++++++++++++ FML/tests/closure_conv_runner.ml | 28 +++ FML/tests/dune | 36 +++- 7 files changed, 549 insertions(+), 54 deletions(-) create mode 100644 FML/lib/anf/closure_conv.ml create mode 100644 FML/tests/closure_conv_manytest.t create mode 100644 FML/tests/closure_conv_runner.ml diff --git a/FML/lib/anf/alpha_conv.ml b/FML/lib/anf/alpha_conv.ml index 9d24c1faf..f7b720064 100644 --- a/FML/lib/anf/alpha_conv.ml +++ b/FML/lib/anf/alpha_conv.ml @@ -63,54 +63,47 @@ and rename env binds name = let ac_declaration env bindings = function | Pe_Nonrec bindings_list -> - let ids, exps = List.unzip bindings_list in - let* ids, env, bindings = - fold_left - ids - ~init:(return ([], env, bindings)) - ~f:(fun (ids, env, bindings) id -> - let* env, bindings, id = rename env bindings id in - return (id :: ids, env, bindings)) - in - let ids = List.rev ids in - let exps = List.map exps ~f:(ac_expr env bindings) in - let* bindings_list = - List.fold2_exn - ids - exps - ~init:(return []) - ~f:(fun acc name expr -> - let* acc = acc in - let* expr = expr in - return ((name, expr) :: acc)) - in - let bindings_list = List.rev bindings_list in - return (env, bindings, Pe_Nonrec bindings_list) + let ids, exps = List.unzip bindings_list in + let* ids, env, bindings = + fold_left + ids + ~init:(return ([], env, bindings)) + ~f:(fun (ids, env, bindings) id -> + let* env, bindings, id = rename env bindings id in + return (id :: ids, env, bindings)) + in + let ids = List.rev ids in + let exps = List.map exps ~f:(ac_expr env bindings) in + let* bindings_list = + List.fold2_exn ids exps ~init:(return []) ~f:(fun acc name expr -> + let* acc = acc in + let* expr = expr in + return ((name, expr) :: acc)) + in + let bindings_list = List.rev bindings_list in + return (env, bindings, Pe_Nonrec bindings_list) | Pe_Rec bindings_list -> - let ids, exps = List.unzip bindings_list in - let* ids, env, bindings = - fold_left - ids - ~init:(return ([], env, bindings)) - ~f:(fun (ids, env, bindings) id -> - let* env, bindings, id = rename env bindings id in - return (id :: ids, env, bindings)) - in - let ids = List.rev ids in - let exps = List.map exps ~f:(ac_expr env bindings) in - let* bindings_list = - List.fold2_exn - ids - exps - ~init:(return []) - ~f:(fun acc name expr -> - let* acc = acc in - let* expr = expr in - return ((name, expr) :: acc)) - in - let bindings_list = List.rev bindings_list in - return (env, bindings, Pe_Rec bindings_list) + let ids, exps = List.unzip bindings_list in + let* ids, env, bindings = + fold_left + ids + ~init:(return ([], env, bindings)) + ~f:(fun (ids, env, bindings) id -> + let* env, bindings, id = rename env bindings id in + return (id :: ids, env, bindings)) + in + let ids = List.rev ids in + let exps = List.map exps ~f:(ac_expr env bindings) in + let* bindings_list = + List.fold2_exn ids exps ~init:(return []) ~f:(fun acc name expr -> + let* acc = acc in + let* expr = expr in + return ((name, expr) :: acc)) + in + let bindings_list = List.rev bindings_list in + return (env, bindings, Pe_Rec bindings_list) ;; + let ac_program program env = let rec helper env bindings = function | [] -> return [] @@ -124,4 +117,4 @@ let ac_program program env = let run_alpha_conv bindings init prog = run (ac_program prog (of_list builtins)) bindings init -;; \ No newline at end of file +;; diff --git a/FML/lib/anf/closure_conv.ml b/FML/lib/anf/closure_conv.ml new file mode 100644 index 000000000..67f644e07 --- /dev/null +++ b/FML/lib/anf/closure_conv.ml @@ -0,0 +1,164 @@ +(** Copyright 2024-2025, Dmitry Pilyuk, Aleksandr Rozhkov *) + +(** SPDX-License-Identifier: LGPL-2.1 *) + +open Pe_ast +open Common +open Base + +let rec free_vars binded = + let open StrSet in + function + | Pe_EConst _ | Pe_ENill | Pe_EUnit -> StrSet.empty + | Pe_EIdentifier id -> if find binded id then empty else singleton id + | Pe_EIf (e1, e2, e3) -> + union_list [ free_vars binded e1; free_vars binded e2; free_vars binded e3 ] + | Pe_EFun (args, body) -> + let binded = union binded (of_list args) in + free_vars binded body + | Pe_EApp (e1, e2) -> union (free_vars binded e1) (free_vars binded e2) + | Pe_ELet (NoRec, name, e1, e2) -> + union (free_vars binded e1) (free_vars (add binded name) e2) + | Pe_ELet (Rec, name, e1, e2) -> + let binded = add binded name in + union (free_vars binded e1) (free_vars binded e2) + (* hmmmmm....*) + | Pe_ECons (e1, e2) -> union (free_vars binded e1) (free_vars binded e2) + | Pe_ETuple es -> + List.fold es ~init:empty ~f:(fun acc e -> union acc (free_vars binded e)) +;; + +let make_apply expr args env = + List.fold args ~init:expr ~f:(fun acc name -> + let arg = + match StrMap.find env name with + | Some e -> e + | None -> Pe_EIdentifier name + in + Pe_EApp (acc, arg)) +;; + +let rec cc_expr global_env bindings = function + | Pe_EIdentifier id as v -> + (match StrMap.find bindings id with + | Some new_expr -> new_expr + | None -> v) + | Pe_EIf (e1, e2, e3) -> + let e1 = cc_expr global_env bindings e1 in + let e2 = cc_expr global_env bindings e2 in + let e3 = cc_expr global_env bindings e3 in + Pe_EIf (e1, e2, e3) + | Pe_EFun (args, body) as v -> + let fvs = free_vars global_env v |> StrSet.to_list in + let body = cc_expr global_env empty body in + let e = Pe_EFun (fvs @ args, body) in + make_apply e fvs bindings + | Pe_EApp (e1, e2) -> + let e1 = cc_expr global_env bindings e1 in + let e2 = cc_expr global_env bindings e2 in + Pe_EApp (e1, e2) + | Pe_ELet (NoRec, name, e1, e2) -> + let e1, env1 = + match e1 with + | Pe_EFun (args, body) -> + let fvs = StrSet.(to_list (diff (free_vars global_env body) (of_list args))) in + let body = cc_expr global_env empty body in + let e = Pe_EFun (fvs @ args, body) in + let apply = make_apply (Pe_EIdentifier name) fvs bindings in + e, StrMap.singleton name apply + | expr -> cc_expr global_env bindings expr, empty + in + let env2 = StrMap.merge_two bindings env1 in + let e2 = cc_expr global_env env2 e2 in + Pe_ELet (NoRec, name, e1, e2) + | Pe_ELet (Rec, name, e1, e2) -> + let e1, env1 = + match e1 with + | Pe_EFun (args, body) -> + let fvs = + StrSet.(to_list (diff (free_vars global_env body) (of_list (name :: args)))) + in + let apply = make_apply (Pe_EIdentifier name) fvs bindings in + let body = cc_expr global_env (StrMap.singleton name apply) body in + let e = Pe_EFun (fvs @ args, body) in + let apply = make_apply (Pe_EIdentifier name) fvs bindings in + e, StrMap.singleton name apply + | expr -> cc_expr global_env bindings expr, empty + in + let env2 = StrMap.merge_two bindings env1 in + let e2 = cc_expr global_env env2 e2 in + Pe_ELet (Rec, name, e1, e2) + | Pe_ECons (e1, e2) -> + let e1 = cc_expr global_env bindings e1 in + let e2 = cc_expr global_env bindings e2 in + Pe_ECons (e1, e2) + | Pe_ETuple el -> + let el = List.map el ~f:(cc_expr global_env bindings) in + Pe_ETuple el + | c -> c +;; + +let cc_nonrec global_env decl_list = + let f1 (decl_acc, env) (name, expr) = + match expr with + | Pe_EFun (args, body) -> + let fvs = StrSet.(to_list (diff (free_vars global_env body) (of_list args))) in + let body = cc_expr global_env empty body in + let e = Pe_EFun (fvs @ args, body) in + (name, e) :: decl_acc, StrSet.add env name + | expr -> (name, cc_expr global_env empty expr) :: decl_acc, StrSet.add env name + in + List.fold decl_list ~init:([], global_env) ~f:f1 +;; + +let cc_rec global_env prev_env cl = + let ids = List.map cl ~f:fst in + let f1 (free, env) (name, expr) = + match expr with + | Pe_EFun (args, body) -> + let remove = StrSet.union (StrSet.of_list ids) (StrSet.of_list args) in + let fvs = StrSet.diff (free_vars global_env body) remove |> StrSet.to_list in + let bind = make_apply (Pe_EIdentifier name) fvs prev_env in + let env = StrMap.update env name ~f:(fun _ -> bind) in + fvs :: free, env + | _ -> [] :: free, env + in + let fvs, env = List.fold cl ~init:([], prev_env) ~f:f1 in + let fvs = List.rev fvs in + let to_fold = List.zip_exn cl fvs in + let f1 decl_acc ((name, e), free) = + match e with + | Pe_EFun (args, body) -> + let new_body = cc_expr global_env empty body in + let efun = Pe_EFun (free @ args, new_body) in + (name, efun) :: decl_acc + | _ -> + let e = cc_expr global_env env e in + (name, e) :: decl_acc + in + let cl = List.fold to_fold ~init:[] ~f:f1 in + let cl = List.rev cl in + cl, env +;; + +let cc_declaration global_env = function + | Pe_Nonrec decl_list -> + let decl_list, env = cc_nonrec global_env decl_list in + env, Pe_Nonrec decl_list + | Pe_Rec decl_list -> + let ids = List.map decl_list ~f:fst in + let cl, _ = cc_rec global_env empty decl_list in + let env = List.fold ids ~init:global_env ~f:(fun acc name -> StrSet.add acc name) in + env, Pe_Rec cl +;; + +let run_cc ast = + let builtins = List.fold Common.builtins ~init:StrSet.empty ~f:StrSet.add in + let rec helper last_env = function + | [] -> [] + | hd :: tl -> + let env, ast = cc_declaration last_env hd in + ast :: helper env tl + in + helper builtins ast +;; diff --git a/FML/lib/anf/common.ml b/FML/lib/anf/common.ml index 72212203b..132dd4081 100644 --- a/FML/lib/anf/common.ml +++ b/FML/lib/anf/common.ml @@ -31,11 +31,13 @@ let builtins = ; "( != )" ; "( && )" ; "( || )" + ; "not" ; "print_int" ; "list_head" ; "list_tail" ; "list_len" ; "tuple_element" + ; "is_empty" ; "fail_match" ] ;; @@ -120,10 +122,9 @@ module MonadCounter = struct ;; end -let rec get_binds_pat = - function +let rec get_binds_pat = function | PConstraint (pat, _) -> get_binds_pat pat - | PAny | PConst _ | PNill | PUnit -> StrSet.empty + | PAny | PConst _ | PNill | PUnit -> StrSet.empty | PIdentifier ident -> StrSet.singleton ident | PCons (p1, p2) -> StrSet.union (get_binds_pat p1) (get_binds_pat p2) | PTuple pl -> @@ -139,4 +140,5 @@ let make_condition checks e1 e2 = Pe_EIf (cond, e1, e2) ;; -let get_id i = "a" ^ Int.to_string i \ No newline at end of file +let get_id i = "a" ^ Int.to_string i +let empty = Base.Map.empty (module Base.String) diff --git a/FML/lib/dune b/FML/lib/dune index 1baeaced1..1efee1c46 100644 --- a/FML/lib/dune +++ b/FML/lib/dune @@ -13,7 +13,8 @@ Pattern_elim Common Pe_ast - Alpha_conv) + Alpha_conv + Closure_conv) (modules_without_implementation inf_errors) (libraries base angstrom) (preprocess diff --git a/FML/tests/closure_conv_manytest.t b/FML/tests/closure_conv_manytest.t new file mode 100644 index 000000000..633df5d47 --- /dev/null +++ b/FML/tests/closure_conv_manytest.t @@ -0,0 +1,275 @@ + $ ./closure_conv_runner.exe < manytests/typed/001fac.ml + let rec fac = (fun n -> if ((( <= ) n) 1) + then 1 + else ((( * ) n) (fac ((( - ) n) 1)))) + + let main = let () = (print_int (fac 4)) in + 0 + + $ ./closure_conv_runner.exe < manytests/typed/002fac.ml + let rec fac_cps = (fun n k -> if ((( = ) n) 1) + then (k 1) + else ((fac_cps ((( - ) n) 1)) (((fun k n p -> (k ((( * ) p) n))) k) n))) + + let main = let () = (print_int ((fac_cps 4) (fun a0 -> a0))) in + 0 + + $ ./closure_conv_runner.exe < manytests/typed/003fib.ml + let rec fib_acc = (fun a b n -> if ((( = ) n) 1) + then b + else let n1 = ((( - ) n) 1) in + let ab = ((( + ) a) b) in + (((fib_acc b) ab) n1)) + + let rec fib = (fun n -> if ((( < ) n) 2) + then n + else ((( + ) (fib ((( - ) n) 1))) (fib ((( - ) n) 2)))) + + let main = let () = (print_int (((fib_acc 0) 1) 4)) in + let () = (print_int (fib 4)) in + 0 + + $ ./closure_conv_runner.exe < manytests/typed/004manyargs.ml + let wrap = (fun f -> if ((( = ) 1) 1) + then f + else f) + + let test3 = (fun a b c -> let a0 = (print_int a) in + let a1 = (print_int b) in + let a2 = (print_int c) in + 0) + + let test10 = (fun a b c d e f g h i j -> ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) a) b)) c)) d)) e)) f)) g)) h)) i)) j)) + + let main = let rez = (((((((((((wrap test10) 1) 10) 100) 1000) 10000) 100000) 1000000) 10000000) 100000000) 1000000000) in + let () = (print_int rez) in + let temp2 = ((((wrap test3) 1) 10) 100) in + 0 + + $ ./closure_conv_runner.exe < manytests/typed/005fix.ml + let rec fix = (fun f x -> ((f (fix f)) x)) + + let fac = (fun self n -> if ((( <= ) n) 1) + then 1 + else ((( * ) n) (self ((( - ) n) 1)))) + + let main = let () = (print_int ((fix fac) 6)) in + 0 + + $ ./closure_conv_runner.exe < manytests/typed/006partial.ml + let foo = (fun b -> if b + then (fun a0 -> ((( + ) a0) 2)) + else (fun a1 -> ((( * ) a1) 10))) + + let a2 = (fun a2 x -> ((a2 true) ((a2 false) ((a2 true) ((a2 false) x))))) + + let main = let () = (print_int (a2 11)) in + 0 + + $ ./closure_conv_runner.exe < manytests/typed/006partial2.ml + let foo = (fun a b c -> let () = (print_int a) in + let () = (print_int b) in + let () = (print_int c) in + ((( + ) a) ((( * ) b) c))) + + let main = let a0 = (foo 1) in + let a1 = (a0 2) in + let a2 = (a1 3) in + let () = (print_int a2) in + 0 + $ ./closure_conv_runner.exe < manytests/typed/006partial3.ml + let foo = (fun a -> let () = (print_int a) in + (fun b -> let () = (print_int b) in + (fun c -> (print_int c)))) + + let main = let () = (((foo 4) 8) 9) in + 0 + $ ./closure_conv_runner.exe < manytests/typed/007order.ml + let _start = (fun a0 a1 a a2 b _c a3 d __ -> let a4 = (a0, a1, a2, a3) in + let () = (print_int ((( + ) a) b)) in + let () = (print_int __) in + ((( + ) ((( / ) ((( * ) a) b)) _c)) d)) + + let main = (print_int (((((((((_start (print_int 1)) (print_int 2)) 3) (print_int 4)) 100) 1000) (print_int (( ~- ) 1))) 10000) (( ~- ) 555555))) + $ ./closure_conv_runner.exe < manytests/typed/008ascription.ml + let addi = (fun f g x -> ((f x) (g x))) + + let main = let () = (print_int (((addi (fun x b -> if b + then ((( + ) x) 1) + else ((( * ) x) 2))) (fun _start -> ((( = ) ((( / ) _start) 2)) 0))) 4)) in + 0 + + $ ./closure_conv_runner.exe < manytests/typed/009let_poly.ml + let temp = let f = (fun x -> x) in + ((f 1), (f true)) + + $ ./closure_conv_runner.exe < manytests/typed/011mapcps.ml + let rec map = (fun f xs k -> if (is_empty xs) + then (k []) + else if (not (is_empty xs)) + then let h = (list_head xs) in + let tl = (list_tail xs) in + (((map f) tl) ((((fun f h k a0 -> (k ((f h)::a0))) f) h) k)) + else fail_match) + + let rec iter = (fun f xs -> if (is_empty xs) + then () + else if (not (is_empty xs)) + then let h = (list_head xs) in + let tl = (list_tail xs) in + let w = (f h) in + ((iter f) tl) + else fail_match) + + let main = ((iter print_int) (((map (fun x -> ((( + ) x) 1))) (1::(2::(3::[])))) (fun x -> x))) + $ ./closure_conv_runner.exe < manytests/typed/012fibcps.ml + let rec fib = (fun n k -> if ((( < ) n) 2) + then (k n) + else ((fib ((( - ) n) 1)) ((((fun fib k n a -> ((fib ((( - ) n) 2)) (((fun a k b -> (k ((( + ) a) b))) a) k))) fib) k) n))) + + let main = (print_int ((fib 6) (fun x -> x))) + $ ./closure_conv_runner.exe < manytests/typed/013foldfoldr.ml + let id = (fun x -> x) + + let rec fold_right = (fun f acc xs -> if (is_empty xs) + then acc + else if (not (is_empty xs)) + then let h = (list_head xs) in + let tl = (list_tail xs) in + ((f h) (((fold_right f) acc) tl)) + else fail_match) + + let foldl = (fun f a bs -> ((((fold_right ((fun f b g x -> (g ((f x) b))) f)) id) bs) a)) + + let main = (print_int (((foldl (fun x y -> ((( * ) x) y))) 1) (1::(2::(3::[]))))) + + $ ./closure_conv_runner.exe < manytests/typed/015tuples.ml + let rec fix = (fun f x -> ((f (fix f)) x)) + + let map = (fun f p -> let a = ((tuple_element p) 0) in + let b = ((tuple_element p) 1) in + ((f a), (f b))) + + let fixpoly = (fun l -> ((fix (fun self a0 -> ((map (((fun a0 self li x -> ((li (self a0)) x)) a0) self)) a0))) l)) + + let feven = (fun ( == ) p n -> let e = ((tuple_element p) 0) in + let o = ((tuple_element p) 1) in + if ((( == ) n) 0) + then 1 + else (o ((( - ) n) 1))) + + let fodd = (fun ( == ) p n -> let e = ((tuple_element p) 0) in + let o = ((tuple_element p) 1) in + if ((( == ) n) 0) + then 0 + else (e ((( - ) n) 1))) + + let tie = (fixpoly (feven, fodd)) + + let rec meven = (fun n -> if ((( = ) n) 0) + then 1 + else (modd ((( - ) n) 1))) + and modd = (fun n -> if ((( = ) n) 0) + then 1 + else (meven ((( - ) n) 1))) + + let main = let () = (print_int (modd 1)) in + let () = (print_int (meven 2)) in + let even = ((tuple_element tie) 0) in + let odd = ((tuple_element tie) 1) in + let () = (print_int (odd 3)) in + let () = (print_int (even 4)) in + 0 + + $ ./closure_conv_runner.exe < manytests/typed/016lists.ml + let rec length = (fun xs -> if (is_empty xs) + then 0 + else if (not (is_empty xs)) + then let h = (list_head xs) in + let tl = (list_tail xs) in + ((( + ) 1) (length tl)) + else fail_match) + + let length_tail = let rec helper = (fun acc xs -> if (is_empty xs) + then acc + else if (not (is_empty xs)) + then let h = (list_head xs) in + let tl = (list_tail xs) in + ((helper ((( + ) acc) 1)) tl) + else fail_match) in + (helper 0) + + let rec map = (fun f xs -> if (is_empty xs) + then [] + else if ((( && ) (not (is_empty xs))) (is_empty (list_tail xs))) + then let a = (list_head xs) in + ((f a)::[]) + else if ((( && ) (not (is_empty xs))) (is_empty (list_tail (list_tail xs)))) + then let a = (list_head xs) in + let b = (list_head (list_tail xs)) in + ((f a)::((f b)::[])) + else if ((( && ) (not (is_empty xs))) (is_empty (list_tail (list_tail (list_tail xs))))) + then let a = (list_head xs) in + let b = (list_head (list_tail xs)) in + let c = (list_head (list_tail (list_tail xs))) in + ((f a)::((f b)::((f c)::[]))) + else if (not (is_empty xs)) + then let a = (list_head xs) in + let b = (list_head (list_tail xs)) in + let c = (list_head (list_tail (list_tail xs))) in + let d = (list_head (list_tail (list_tail (list_tail xs)))) in + let tl = (list_tail (list_tail (list_tail (list_tail xs)))) in + ((f a)::((f b)::((f c)::((f d)::((map f) tl))))) + else fail_match) + + let rec append = (fun xs ys -> if (is_empty xs) + then ys + else if (not (is_empty xs)) + then let x = (list_head xs) in + let a0 = (list_tail xs) in + (x::((append a0) ys)) + else fail_match) + + let concat = let rec helper = (fun xs -> if (is_empty xs) + then [] + else if (not (is_empty xs)) + then let h = (list_head xs) in + let tl = (list_tail xs) in + ((append h) (helper tl)) + else fail_match) in + helper + + let rec iter = (fun f xs -> if (is_empty xs) + then () + else if (not (is_empty xs)) + then let h = (list_head xs) in + let tl = (list_tail xs) in + let () = (f h) in + ((iter f) tl) + else fail_match) + + let rec cartesian = (fun xs ys -> if (is_empty xs) + then [] + else if (not (is_empty xs)) + then let h = (list_head xs) in + let tl = (list_tail xs) in + ((append ((map ((fun h a -> (h, a)) h)) ys)) ((cartesian tl) ys)) + else fail_match) + + let main = let () = ((iter print_int) (1::(2::(3::[])))) in + let () = (print_int (length ((cartesian (1::(2::[]))) (1::(2::(3::(4::[]))))))) in + 0 + + $ ./closure_conv_runner.exe < manytests/do_not_type/001.ml + Infer error: + $ ./closure_conv_runner.exe < manytests/do_not_type/002if.ml + Infer error: + $ ./closure_conv_runner.exe < manytests/do_not_type/003occurs.ml + Infer error: + + $ ./closure_conv_runner.exe < manytests/do_not_type/004let_poly.ml + Infer error: + + $ ./closure_conv_runner.exe < manytests/do_not_type/015tuples.ml + Infer error: + diff --git a/FML/tests/closure_conv_runner.ml b/FML/tests/closure_conv_runner.ml new file mode 100644 index 000000000..4d3ab9f26 --- /dev/null +++ b/FML/tests/closure_conv_runner.ml @@ -0,0 +1,28 @@ +(** Copyright 2024-2025, Dmitry Pilyuk, Aleksandr Rozhkov *) + +(** SPDX-License-Identifier: LGPL-2.1 *) + +open Fml_lib.Parser +open Fml_lib.Inferencer +open Fml_lib.Pattern_elim +open Fml_lib.Alpha_conv +open Fml_lib.Closure_conv + +let () = + let input = Stdio.In_channel.input_all Stdlib.stdin in + let parse_and_infer input = + match parse input with + | Ok parsed -> + (match run_program_inferencer parsed with + | Ok _ -> Ok parsed + | Error _ -> Error (Format.asprintf "Infer error:")) + | Error e -> Error (Format.sprintf "Parsing error: %s" e) + in + match parse_and_infer input with + | Ok ast -> + let bind, cnt, ast = run_pe ast in + let _, _, ast = run_alpha_conv bind cnt ast in + let ast = run_cc ast in + Format.printf "%a" pp_pe_structure ast + | Error message -> Format.printf "%s" message +;; diff --git a/FML/tests/dune b/FML/tests/dune index d5facd44e..7ac629a9b 100644 --- a/FML/tests/dune +++ b/FML/tests/dune @@ -26,12 +26,18 @@ (modules pe_runner) (libraries fml_lib stdio)) - (executable +(executable (name alpha_conv_runner) (public_name alpha_conv_runner) (modules alpha_conv_runner) (libraries fml_lib stdio)) +(executable + (name closure_conv_runner) + (public_name closure_conv_runner) + (modules closure_conv_runner) + (libraries fml_lib stdio)) + (cram (applies_to parser_manytests) (deps @@ -134,4 +140,30 @@ manytests/typed/012fibcps.ml manytests/typed/013foldfoldr.ml manytests/typed/015tuples.ml - manytests/typed/016lists.ml)) \ No newline at end of file + manytests/typed/016lists.ml)) + +(cram + (applies_to closure_conv_manytest) + (deps + ./closure_conv_runner.exe + manytests/do_not_type/001.ml + manytests/do_not_type/002if.ml + manytests/do_not_type/003occurs.ml + manytests/do_not_type/004let_poly.ml + manytests/do_not_type/015tuples.ml + manytests/typed/001fac.ml + manytests/typed/002fac.ml + manytests/typed/003fib.ml + manytests/typed/004manyargs.ml + manytests/typed/005fix.ml + manytests/typed/006partial.ml + manytests/typed/006partial2.ml + manytests/typed/006partial3.ml + manytests/typed/007order.ml + manytests/typed/008ascription.ml + manytests/typed/009let_poly.ml + manytests/typed/011mapcps.ml + manytests/typed/012fibcps.ml + manytests/typed/013foldfoldr.ml + manytests/typed/015tuples.ml + manytests/typed/016lists.ml)) From 2807fd0a05ed6f1f6da099d2875c8cba93ae59a0 Mon Sep 17 00:00:00 2001 From: RozhkovAleksandr Date: Sat, 8 Mar 2025 15:24:09 +0300 Subject: [PATCH 14/92] add ll beta version --- FML/lib/anf/common.ml | 1 + FML/lib/anf/lambda_lifting.ml | 99 +++++++++++++++++++++++++++++++++++ FML/lib/dune | 4 +- FML/tests/dune | 8 ++- 4 files changed, 110 insertions(+), 2 deletions(-) create mode 100644 FML/lib/anf/lambda_lifting.ml diff --git a/FML/lib/anf/common.ml b/FML/lib/anf/common.ml index 132dd4081..95eaaeec9 100644 --- a/FML/lib/anf/common.ml +++ b/FML/lib/anf/common.ml @@ -6,6 +6,7 @@ open Base open Ast open Pe_ast +let empty = Base.Map.empty (module Base.String) module StrMap = struct type 'a t = (string, 'a, String.comparator_witness) Map.t diff --git a/FML/lib/anf/lambda_lifting.ml b/FML/lib/anf/lambda_lifting.ml new file mode 100644 index 000000000..14c47e098 --- /dev/null +++ b/FML/lib/anf/lambda_lifting.ml @@ -0,0 +1,99 @@ +(** Copyright 2024-2025, Dmitry Pilyuk, Aleksandr Rozhkov *) + +(** SPDX-License-Identifier: LGPL-2.1 *) + + +open Base +open Pe_ast +open Common +open Common.MonadCounter + +let rec ll_expr env = function + | Pe_EUnit -> return ([], Pe_EUnit) + | Pe_ENill -> return ([], Pe_ENill) + | Pe_EConst _ as v -> return ([], v) + | Pe_EIdentifier id as v -> + (match Map.find env id with + | Some x -> return ([], Pe_EIdentifier x) + | None -> return ([], v)) + | Pe_EApp (e1, e2) -> + let* str1, e1 = ll_expr env e1 in + let* sl2, e2 = ll_expr env e2 in + return (str1 @ sl2, Pe_EApp (e1, e2)) + | Pe_EIf (e1, e2, e3) -> + let* str1, e1 = ll_expr env e1 in + let* str2, e2 = ll_expr env e2 in + let* str3, e3 = ll_expr env e3 in + return (str1 @ str2 @ str3, Pe_EIf (e1, e2, e3)) + | Pe_EFun (args, body) -> + let* fresh = fresh >>| get_id in + let new_env = List.fold args ~init:env ~f:Map.remove in + let* _, body = ll_expr new_env body in + return ([Pe_Nonrec [(fresh, Pe_EFun (args, body))]], Pe_EIdentifier fresh) + | Pe_ECons (e1, e2) -> + let* str1, e1 = ll_expr env e1 in + let* str2, e2 = ll_expr env e2 in + return (str1 @ str2, Pe_ECons (e1, e2)) + | Pe_ETuple e_list -> + let* t = map e_list ~f:(ll_expr env) in + let str, el = List.unzip t in + return (List.concat str, Pe_ETuple el) + | Pe_ELet (rec_flag, name, e1, e2) -> + let* str1, e1 = ll_inner env e1 in + (match rec_flag with + | NoRec -> + (match e1 with + | Pe_EFun _ -> + let* fresh_name = fresh >>| get_id in + let bindings = Map.set env ~key:name ~data:fresh_name in + let* str2, e2 = ll_expr bindings e2 in + return (str1 @ str2, Pe_ELet(rec_flag, name, e1, e2)) + | _ -> + let* str2, e2 = ll_expr env e2 in + return (str1 @ str2, Pe_ELet (rec_flag, name, e1, e2))) + | Rec -> + let env = Map.set env ~key:name ~data:name in + let* str2, e2 = ll_expr env e2 in + return (str1 @ str2, Pe_ELet(rec_flag, name, e1, e2)) + ) + +and ll_inner env = function + | Pe_EFun (args, body) -> + let env = List.fold args ~init:env ~f:Map.remove in + let* str, body = ll_expr env body in + return (str, Pe_EFun (args, body)) + | e -> + let* str, e = ll_expr env e in + return (str, e) +;; +let ll_str_item = function + | Pe_Nonrec bindings -> + let* lifted_bindings = + map bindings ~f:(fun (name, e) -> + let* str, new_e = ll_inner empty e in + return (str, (name, new_e))) + in + let strs, new_bindings = List.unzip lifted_bindings in + return (List.concat strs @ [ Pe_Nonrec new_bindings ]) + + | Pe_Rec bindings -> + let* lifted_bindings = + map bindings ~f:(fun (name, e) -> + let* str, new_e = ll_inner empty e in + return (str, (name, new_e))) + in + let strs, new_bindings = List.unzip lifted_bindings in + return (List.concat strs @ [ Pe_Rec new_bindings ]) + +let ll_structure structure = + let rec helper = function + | [] -> return [] + | hd :: tl -> + let* str1 = ll_str_item hd in + let* str2 = helper tl in + return @@ str1 @ str2 + in + helper structure +;; + +let run_ll bindings init_num p = run (ll_structure p) bindings init_num \ No newline at end of file diff --git a/FML/lib/dune b/FML/lib/dune index 1efee1c46..523a294ec 100644 --- a/FML/lib/dune +++ b/FML/lib/dune @@ -14,7 +14,9 @@ Common Pe_ast Alpha_conv - Closure_conv) + Closure_conv + Lambda_lifting + ) (modules_without_implementation inf_errors) (libraries base angstrom) (preprocess diff --git a/FML/tests/dune b/FML/tests/dune index 7ac629a9b..4cdfe1f57 100644 --- a/FML/tests/dune +++ b/FML/tests/dune @@ -38,6 +38,12 @@ (modules closure_conv_runner) (libraries fml_lib stdio)) + (executable + (name closure_conv_runner) + (public_name closure_conv_runner) + (modules closure_conv_runner) + (libraries fml_lib stdio)) + (cram (applies_to parser_manytests) (deps @@ -142,7 +148,6 @@ manytests/typed/015tuples.ml manytests/typed/016lists.ml)) -(cram (applies_to closure_conv_manytest) (deps ./closure_conv_runner.exe @@ -167,3 +172,4 @@ manytests/typed/013foldfoldr.ml manytests/typed/015tuples.ml manytests/typed/016lists.ml)) + From 3463a1cb692735823a1ff8d615f3a255c3368109 Mon Sep 17 00:00:00 2001 From: RozhkovAleksandr Date: Sat, 8 Mar 2025 15:38:00 +0300 Subject: [PATCH 15/92] fix bugs --- FML/lib/anf/anf_ast.ml | 0 FML/lib/anf/common.ml | 1 - FML/lib/dune | 3 +- FML/tests/dune | 34 ++- FML/tests/lambda_lifting_manytests.t | 307 +++++++++++++++++++++++++++ FML/tests/lambda_lifting_runner.ml | 31 +++ 6 files changed, 369 insertions(+), 7 deletions(-) create mode 100644 FML/lib/anf/anf_ast.ml create mode 100644 FML/tests/lambda_lifting_manytests.t create mode 100644 FML/tests/lambda_lifting_runner.ml diff --git a/FML/lib/anf/anf_ast.ml b/FML/lib/anf/anf_ast.ml new file mode 100644 index 000000000..e69de29bb diff --git a/FML/lib/anf/common.ml b/FML/lib/anf/common.ml index 95eaaeec9..132dd4081 100644 --- a/FML/lib/anf/common.ml +++ b/FML/lib/anf/common.ml @@ -6,7 +6,6 @@ open Base open Ast open Pe_ast -let empty = Base.Map.empty (module Base.String) module StrMap = struct type 'a t = (string, 'a, String.comparator_witness) Map.t diff --git a/FML/lib/dune b/FML/lib/dune index 523a294ec..b81fa7dcf 100644 --- a/FML/lib/dune +++ b/FML/lib/dune @@ -15,8 +15,7 @@ Pe_ast Alpha_conv Closure_conv - Lambda_lifting - ) + Lambda_lifting) (modules_without_implementation inf_errors) (libraries base angstrom) (preprocess diff --git a/FML/tests/dune b/FML/tests/dune index 4cdfe1f57..66d52aa37 100644 --- a/FML/tests/dune +++ b/FML/tests/dune @@ -38,10 +38,10 @@ (modules closure_conv_runner) (libraries fml_lib stdio)) - (executable - (name closure_conv_runner) - (public_name closure_conv_runner) - (modules closure_conv_runner) +(executable + (name lambda_lifting_runner) + (public_name lambda_lifting_runner) + (modules lambda_lifting_runner) (libraries fml_lib stdio)) (cram @@ -148,6 +148,7 @@ manytests/typed/015tuples.ml manytests/typed/016lists.ml)) +(cram (applies_to closure_conv_manytest) (deps ./closure_conv_runner.exe @@ -173,3 +174,28 @@ manytests/typed/015tuples.ml manytests/typed/016lists.ml)) +(cram + (applies_to lambda_lifting_manytests) + (deps + ./lambda_lifting_runner.exe + manytests/do_not_type/001.ml + manytests/do_not_type/002if.ml + manytests/do_not_type/003occurs.ml + manytests/do_not_type/004let_poly.ml + manytests/do_not_type/015tuples.ml + manytests/typed/001fac.ml + manytests/typed/002fac.ml + manytests/typed/003fib.ml + manytests/typed/004manyargs.ml + manytests/typed/005fix.ml + manytests/typed/006partial.ml + manytests/typed/006partial2.ml + manytests/typed/006partial3.ml + manytests/typed/007order.ml + manytests/typed/008ascription.ml + manytests/typed/009let_poly.ml + manytests/typed/011mapcps.ml + manytests/typed/012fibcps.ml + manytests/typed/013foldfoldr.ml + manytests/typed/015tuples.ml + manytests/typed/016lists.ml)) diff --git a/FML/tests/lambda_lifting_manytests.t b/FML/tests/lambda_lifting_manytests.t new file mode 100644 index 000000000..b17675e4a --- /dev/null +++ b/FML/tests/lambda_lifting_manytests.t @@ -0,0 +1,307 @@ + $ ./lambda_lifting_runner.exe < manytests/typed/001fac.ml + let rec fac = (fun n -> if ((( <= ) n) 1) + then 1 + else ((( * ) n) (fac ((( - ) n) 1)))) + + let main = let () = (print_int (fac 4)) in + 0 + + $ ./lambda_lifting_runner.exe < manytests/typed/002fac.ml + let a1 = (fun k n p -> (k ((( * ) p) n))) + + let rec fac_cps = (fun n k -> if ((( = ) n) 1) + then (k 1) + else ((fac_cps ((( - ) n) 1)) ((a1 k) n))) + + let a2 = (fun a0 -> a0) + + let main = let () = (print_int ((fac_cps 4) a2)) in + 0 + + $ ./lambda_lifting_runner.exe < manytests/typed/003fib.ml + let rec fib_acc = (fun a b n -> if ((( = ) n) 1) + then b + else let n1 = ((( - ) n) 1) in + let ab = ((( + ) a) b) in + (((fib_acc b) ab) n1)) + + let rec fib = (fun n -> if ((( < ) n) 2) + then n + else ((( + ) (fib ((( - ) n) 1))) (fib ((( - ) n) 2)))) + + let main = let () = (print_int (((fib_acc 0) 1) 4)) in + let () = (print_int (fib 4)) in + 0 + + $ ./lambda_lifting_runner.exe < manytests/typed/004manyargs.ml + let wrap = (fun f -> if ((( = ) 1) 1) + then f + else f) + + let test3 = (fun a b c -> let a0 = (print_int a) in + let a1 = (print_int b) in + let a2 = (print_int c) in + 0) + + let test10 = (fun a b c d e f g h i j -> ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) a) b)) c)) d)) e)) f)) g)) h)) i)) j)) + + let main = let rez = (((((((((((wrap test10) 1) 10) 100) 1000) 10000) 100000) 1000000) 10000000) 100000000) 1000000000) in + let () = (print_int rez) in + let temp2 = ((((wrap test3) 1) 10) 100) in + 0 + + $ ./lambda_lifting_runner.exe < manytests/typed/005fix.ml + let rec fix = (fun f x -> ((f (fix f)) x)) + + let fac = (fun self n -> if ((( <= ) n) 1) + then 1 + else ((( * ) n) (self ((( - ) n) 1)))) + + let main = let () = (print_int ((fix fac) 6)) in + 0 + + $ ./lambda_lifting_runner.exe < manytests/typed/006partial.ml + let a3 = (fun a0 -> ((( + ) a0) 2)) + + let a4 = (fun a1 -> ((( * ) a1) 10)) + + let foo = (fun b -> if b + then a3 + else a4) + + let a2 = (fun a2 x -> ((a2 true) ((a2 false) ((a2 true) ((a2 false) x))))) + + let main = let () = (print_int (a2 11)) in + 0 + + $ ./lambda_lifting_runner.exe < manytests/typed/006partial2.ml + let foo = (fun a b c -> let () = (print_int a) in + let () = (print_int b) in + let () = (print_int c) in + ((( + ) a) ((( * ) b) c))) + + let main = let a0 = (foo 1) in + let a1 = (a0 2) in + let a2 = (a1 3) in + let () = (print_int a2) in + 0 + $ ./lambda_lifting_runner.exe < manytests/typed/006partial3.ml + let a0 = (fun b -> let () = (print_int b) in + a1) + + let foo = (fun a -> let () = (print_int a) in + a0) + + let main = let () = (((foo 4) 8) 9) in + 0 + $ ./lambda_lifting_runner.exe < manytests/typed/007order.ml + let _start = (fun a0 a1 a a2 b _c a3 d __ -> let a4 = (a0, a1, a2, a3) in + let () = (print_int ((( + ) a) b)) in + let () = (print_int __) in + ((( + ) ((( / ) ((( * ) a) b)) _c)) d)) + + let main = (print_int (((((((((_start (print_int 1)) (print_int 2)) 3) (print_int 4)) 100) 1000) (print_int (( ~- ) 1))) 10000) (( ~- ) 555555))) + $ ./lambda_lifting_runner.exe < manytests/typed/008ascription.ml + let addi = (fun f g x -> ((f x) (g x))) + + let a0 = (fun x b -> if b + then ((( + ) x) 1) + else ((( * ) x) 2)) + + let a1 = (fun _start -> ((( = ) ((( / ) _start) 2)) 0)) + + let main = let () = (print_int (((addi a0) a1) 4)) in + 0 + + $ ./lambda_lifting_runner.exe < manytests/typed/009let_poly.ml + let temp = let f = (fun x -> x) in + ((a0 1), (a0 true)) + + $ ./lambda_lifting_runner.exe < manytests/typed/011mapcps.ml + let a1 = (fun f h k a0 -> (k ((f h)::a0))) + + let rec map = (fun f xs k -> if (is_empty xs) + then (k []) + else if (not (is_empty xs)) + then let h = (list_head xs) in + let tl = (list_tail xs) in + (((map f) tl) (((a1 f) h) k)) + else fail_match) + + let rec iter = (fun f xs -> if (is_empty xs) + then () + else if (not (is_empty xs)) + then let h = (list_head xs) in + let tl = (list_tail xs) in + let w = (f h) in + ((iter f) tl) + else fail_match) + + let a2 = (fun x -> ((( + ) x) 1)) + + let a3 = (fun x -> x) + + let main = ((iter print_int) (((map a2) (1::(2::(3::[])))) a3)) + $ ./lambda_lifting_runner.exe < manytests/typed/012fibcps.ml + let a0 = (fun fib k n a -> ((fib ((( - ) n) 2)) ((a1 a) k))) + + let rec fib = (fun n k -> if ((( < ) n) 2) + then (k n) + else ((fib ((( - ) n) 1)) (((a0 fib) k) n))) + + let a2 = (fun x -> x) + + let main = (print_int ((fib 6) a2)) + $ ./lambda_lifting_runner.exe < manytests/typed/013foldfoldr.ml + let id = (fun x -> x) + + let rec fold_right = (fun f acc xs -> if (is_empty xs) + then acc + else if (not (is_empty xs)) + then let h = (list_head xs) in + let tl = (list_tail xs) in + ((f h) (((fold_right f) acc) tl)) + else fail_match) + + let a0 = (fun f b g x -> (g ((f x) b))) + + let foldl = (fun f a bs -> ((((fold_right (a0 f)) id) bs) a)) + + let a1 = (fun x y -> ((( * ) x) y)) + + let main = (print_int (((foldl a1) 1) (1::(2::(3::[]))))) + + $ ./lambda_lifting_runner.exe < manytests/typed/015tuples.ml + let rec fix = (fun f x -> ((f (fix f)) x)) + + let map = (fun f p -> let a = ((tuple_element p) 0) in + let b = ((tuple_element p) 1) in + ((f a), (f b))) + + let a1 = (fun self a0 -> ((map ((a2 a0) self)) a0)) + + let fixpoly = (fun l -> ((fix a1) l)) + + let feven = (fun ( == ) p n -> let e = ((tuple_element p) 0) in + let o = ((tuple_element p) 1) in + if ((( == ) n) 0) + then 1 + else (o ((( - ) n) 1))) + + let fodd = (fun ( == ) p n -> let e = ((tuple_element p) 0) in + let o = ((tuple_element p) 1) in + if ((( == ) n) 0) + then 0 + else (e ((( - ) n) 1))) + + let tie = (fixpoly (feven, fodd)) + + let rec meven = (fun n -> if ((( = ) n) 0) + then 1 + else (modd ((( - ) n) 1))) + and modd = (fun n -> if ((( = ) n) 0) + then 1 + else (meven ((( - ) n) 1))) + + let main = let () = (print_int (modd 1)) in + let () = (print_int (meven 2)) in + let even = ((tuple_element tie) 0) in + let odd = ((tuple_element tie) 1) in + let () = (print_int (odd 3)) in + let () = (print_int (even 4)) in + 0 + + $ ./lambda_lifting_runner.exe < manytests/typed/016lists.ml + let rec length = (fun xs -> if (is_empty xs) + then 0 + else if (not (is_empty xs)) + then let h = (list_head xs) in + let tl = (list_tail xs) in + ((( + ) 1) (length tl)) + else fail_match) + + let length_tail = let rec helper = (fun acc xs -> if (is_empty xs) + then acc + else if (not (is_empty xs)) + then let h = (list_head xs) in + let tl = (list_tail xs) in + ((helper ((( + ) acc) 1)) tl) + else fail_match) in + (helper 0) + + let rec map = (fun f xs -> if (is_empty xs) + then [] + else if ((( && ) (not (is_empty xs))) (is_empty (list_tail xs))) + then let a = (list_head xs) in + ((f a)::[]) + else if ((( && ) (not (is_empty xs))) (is_empty (list_tail (list_tail xs)))) + then let a = (list_head xs) in + let b = (list_head (list_tail xs)) in + ((f a)::((f b)::[])) + else if ((( && ) (not (is_empty xs))) (is_empty (list_tail (list_tail (list_tail xs))))) + then let a = (list_head xs) in + let b = (list_head (list_tail xs)) in + let c = (list_head (list_tail (list_tail xs))) in + ((f a)::((f b)::((f c)::[]))) + else if (not (is_empty xs)) + then let a = (list_head xs) in + let b = (list_head (list_tail xs)) in + let c = (list_head (list_tail (list_tail xs))) in + let d = (list_head (list_tail (list_tail (list_tail xs)))) in + let tl = (list_tail (list_tail (list_tail (list_tail xs)))) in + ((f a)::((f b)::((f c)::((f d)::((map f) tl))))) + else fail_match) + + let rec append = (fun xs ys -> if (is_empty xs) + then ys + else if (not (is_empty xs)) + then let x = (list_head xs) in + let a0 = (list_tail xs) in + (x::((append a0) ys)) + else fail_match) + + let concat = let rec helper = (fun xs -> if (is_empty xs) + then [] + else if (not (is_empty xs)) + then let h = (list_head xs) in + let tl = (list_tail xs) in + ((append h) (helper tl)) + else fail_match) in + helper + + let rec iter = (fun f xs -> if (is_empty xs) + then () + else if (not (is_empty xs)) + then let h = (list_head xs) in + let tl = (list_tail xs) in + let () = (f h) in + ((iter f) tl) + else fail_match) + + let a1 = (fun h a -> (h, a)) + + let rec cartesian = (fun xs ys -> if (is_empty xs) + then [] + else if (not (is_empty xs)) + then let h = (list_head xs) in + let tl = (list_tail xs) in + ((append ((map (a1 h)) ys)) ((cartesian tl) ys)) + else fail_match) + + let main = let () = ((iter print_int) (1::(2::(3::[])))) in + let () = (print_int (length ((cartesian (1::(2::[]))) (1::(2::(3::(4::[]))))))) in + 0 + + $ ./lambda_lifting_runner.exe < manytests/do_not_type/001.ml + Infer error: + $ ./lambda_lifting_runner.exe < manytests/do_not_type/002if.ml + Infer error: + $ ./lambda_lifting_runner.exe < manytests/do_not_type/003occurs.ml + Infer error: + + $ ./lambda_lifting_runner.exe < manytests/do_not_type/004let_poly.ml + Infer error: + + $ ./lambda_lifting_runner.exe < manytests/do_not_type/015tuples.ml + Infer error: + diff --git a/FML/tests/lambda_lifting_runner.ml b/FML/tests/lambda_lifting_runner.ml new file mode 100644 index 000000000..bff871164 --- /dev/null +++ b/FML/tests/lambda_lifting_runner.ml @@ -0,0 +1,31 @@ +(** Copyright 2024-2025, Dmitry Pilyuk, Aleksandr Rozhkov *) + +(** SPDX-License-Identifier: LGPL-2.1 *) + +open Fml_lib.Parser +open Fml_lib.Inferencer +open Fml_lib.Pattern_elim +open Fml_lib.Alpha_conv +open Fml_lib.Lambda_lifting +open Fml_lib.Closure_conv + + +let () = + let input = Stdio.In_channel.input_all Stdlib.stdin in + let parse_and_infer input = + match parse input with + | Ok parsed -> + (match run_program_inferencer parsed with + | Ok _ -> Ok parsed + | Error _ -> Error (Format.asprintf "Infer error:" )) + | Error e -> Error (Format.sprintf "Parsing error: %s" e) + in + match parse_and_infer input with + | Ok ast -> + let bind, cnt, ast = run_pe ast in + let bind, cnt, ast = run_alpha_conv bind cnt ast in + let ast = run_cc ast in + let _, _, ast = run_ll bind cnt ast in + Format.printf "%a" pp_pe_structure ast + | Error message -> Format.printf "%s" message +;; From 5f038dcfa5e6dfeeffc494aae5e87d26a1279529 Mon Sep 17 00:00:00 2001 From: RozhkovAleksandr Date: Sat, 8 Mar 2025 17:07:50 +0300 Subject: [PATCH 16/92] oops --- FML/lib/anf/lambda_lifting.ml | 17 ++++++++--------- FML/tests/lambda_lifting_manytests.t | 18 ++++++++++-------- 2 files changed, 18 insertions(+), 17 deletions(-) diff --git a/FML/lib/anf/lambda_lifting.ml b/FML/lib/anf/lambda_lifting.ml index 14c47e098..1a76eeb67 100644 --- a/FML/lib/anf/lambda_lifting.ml +++ b/FML/lib/anf/lambda_lifting.ml @@ -38,11 +38,15 @@ let rec ll_expr env = function let* t = map e_list ~f:(ll_expr env) in let str, el = List.unzip t in return (List.concat str, Pe_ETuple el) - | Pe_ELet (rec_flag, name, e1, e2) -> + | Pe_ELet (Rec, name, e1, e2) -> let* str1, e1 = ll_inner env e1 in - (match rec_flag with - | NoRec -> - (match e1 with + let* fresh_name = fresh >>| get_id in + let env = Map.set env ~key:name ~data:fresh_name in + let* str2, _ = ll_expr env e2 in + return (str1 @ [ Pe_Rec [(fresh_name, e1)] ] @ str2, Pe_EIdentifier fresh_name) + | Pe_ELet (rec_flag, name, e1, e2) -> + let* str1, e1 = ll_inner env e1 in + (match e1 with | Pe_EFun _ -> let* fresh_name = fresh >>| get_id in let bindings = Map.set env ~key:name ~data:fresh_name in @@ -51,11 +55,6 @@ let rec ll_expr env = function | _ -> let* str2, e2 = ll_expr env e2 in return (str1 @ str2, Pe_ELet (rec_flag, name, e1, e2))) - | Rec -> - let env = Map.set env ~key:name ~data:name in - let* str2, e2 = ll_expr env e2 in - return (str1 @ str2, Pe_ELet(rec_flag, name, e1, e2)) - ) and ll_inner env = function | Pe_EFun (args, body) -> diff --git a/FML/tests/lambda_lifting_manytests.t b/FML/tests/lambda_lifting_manytests.t index b17675e4a..c6d2c6739 100644 --- a/FML/tests/lambda_lifting_manytests.t +++ b/FML/tests/lambda_lifting_manytests.t @@ -220,14 +220,15 @@ ((( + ) 1) (length tl)) else fail_match) - let length_tail = let rec helper = (fun acc xs -> if (is_empty xs) + let rec a1 = (fun acc xs -> if (is_empty xs) then acc else if (not (is_empty xs)) then let h = (list_head xs) in let tl = (list_tail xs) in ((helper ((( + ) acc) 1)) tl) - else fail_match) in - (helper 0) + else fail_match) + + let length_tail = a1 let rec map = (fun f xs -> if (is_empty xs) then [] @@ -260,14 +261,15 @@ (x::((append a0) ys)) else fail_match) - let concat = let rec helper = (fun xs -> if (is_empty xs) + let rec a2 = (fun xs -> if (is_empty xs) then [] else if (not (is_empty xs)) then let h = (list_head xs) in let tl = (list_tail xs) in ((append h) (helper tl)) - else fail_match) in - helper + else fail_match) + + let concat = a2 let rec iter = (fun f xs -> if (is_empty xs) then () @@ -278,14 +280,14 @@ ((iter f) tl) else fail_match) - let a1 = (fun h a -> (h, a)) + let a3 = (fun h a -> (h, a)) let rec cartesian = (fun xs ys -> if (is_empty xs) then [] else if (not (is_empty xs)) then let h = (list_head xs) in let tl = (list_tail xs) in - ((append ((map (a1 h)) ys)) ((cartesian tl) ys)) + ((append ((map (a3 h)) ys)) ((cartesian tl) ys)) else fail_match) let main = let () = ((iter print_int) (1::(2::(3::[])))) in From 037f9959767fc3b94f969668fb66007974a389c9 Mon Sep 17 00:00:00 2001 From: RozhkovAleksandr Date: Sat, 8 Mar 2025 17:19:54 +0300 Subject: [PATCH 17/92] fix bug with fack --- FML/lib/anf/lambda_lifting.ml | 4 ++-- FML/tests/lambda_lifting_manytests.t | 21 +++++++++++++++++++-- 2 files changed, 21 insertions(+), 4 deletions(-) diff --git a/FML/lib/anf/lambda_lifting.ml b/FML/lib/anf/lambda_lifting.ml index 1a76eeb67..08992ac0c 100644 --- a/FML/lib/anf/lambda_lifting.ml +++ b/FML/lib/anf/lambda_lifting.ml @@ -39,9 +39,9 @@ let rec ll_expr env = function let str, el = List.unzip t in return (List.concat str, Pe_ETuple el) | Pe_ELet (Rec, name, e1, e2) -> - let* str1, e1 = ll_inner env e1 in let* fresh_name = fresh >>| get_id in - let env = Map.set env ~key:name ~data:fresh_name in + let env = Map.set env ~key:name ~data:fresh_name in + let* str1, e1 = ll_inner env e1 in let* str2, _ = ll_expr env e2 in return (str1 @ [ Pe_Rec [(fresh_name, e1)] ] @ str2, Pe_EIdentifier fresh_name) | Pe_ELet (rec_flag, name, e1, e2) -> diff --git a/FML/tests/lambda_lifting_manytests.t b/FML/tests/lambda_lifting_manytests.t index c6d2c6739..c8f0b0b17 100644 --- a/FML/tests/lambda_lifting_manytests.t +++ b/FML/tests/lambda_lifting_manytests.t @@ -1,3 +1,20 @@ + $ ./lambda_lifting_runner.exe << EOF + > let fac n = + > let rec fack n k = + > if n<=1 then k 1 + > else fack (n - 1) ((fun k n m -> k (m * n)) k n) + > in + > fack n (fun x -> x) + > EOF + let a4 = (fun a1 a2 m -> (a1 ((( * ) m) a2))) + + let rec a3 = (fun a0 k -> if ((( <= ) a0) 1) + then (k 1) + else ((a3 ((( - ) a0) 1)) ((a4 k) a0))) + + let a5 = (fun x -> x) + + let fac = (fun n -> a3) $ ./lambda_lifting_runner.exe < manytests/typed/001fac.ml let rec fac = (fun n -> if ((( <= ) n) 1) then 1 @@ -225,7 +242,7 @@ else if (not (is_empty xs)) then let h = (list_head xs) in let tl = (list_tail xs) in - ((helper ((( + ) acc) 1)) tl) + ((a1 ((( + ) acc) 1)) tl) else fail_match) let length_tail = a1 @@ -266,7 +283,7 @@ else if (not (is_empty xs)) then let h = (list_head xs) in let tl = (list_tail xs) in - ((append h) (helper tl)) + ((append h) (a2 tl)) else fail_match) let concat = a2 From 04ff3bd5276f89b02904da5068a1abafe1d4a47b Mon Sep 17 00:00:00 2001 From: Dmitry Pilyuk Date: Sat, 8 Mar 2025 21:47:26 +0300 Subject: [PATCH 18/92] Fix lint problem --- FML/lib/anf/pattern_elim.ml | 22 +--------------------- 1 file changed, 1 insertion(+), 21 deletions(-) diff --git a/FML/lib/anf/pattern_elim.ml b/FML/lib/anf/pattern_elim.ml index 5350667cc..33435c9c5 100644 --- a/FML/lib/anf/pattern_elim.ml +++ b/FML/lib/anf/pattern_elim.ml @@ -23,10 +23,7 @@ let rec expr_to_str = function (expr_to_str e2) (expr_to_str e3) | Pe_EFun (args, e) -> - Format.sprintf - "(fun%s -> %s)" - (List.fold_left (fun acc name -> acc ^ " " ^ name) "" args) - (expr_to_str e) + Format.sprintf "(fun %s -> %s)" (String.concat " " args) (expr_to_str e) | Pe_EApp (e1, e2) -> Format.sprintf "(%s %s)" (expr_to_str e1) (expr_to_str e2) | Pe_ELet (NoRec, name, e1, e2) -> Format.sprintf "let %s = %s in\n%s" name (expr_to_str e1) (expr_to_str e2) @@ -101,23 +98,6 @@ let const_to_peconst const = open Base open MonadCounter -(* let check_pattern expr pat = - let rec helper expr = function - | PConstraint (p, _) -> helper expr p - | PConst c -> [ make_apply "( = )" expr (const_to_peconst c) ] - | PTuple pl -> - List.concat @@ List.mapi pl ~f:(fun i p -> helper (get_element expr (Tuple i)) p) - | PCons (l, r) -> - let l = helper (get_element expr Cons_head) l in - - let r = helper (get_element expr Cons_tail) r in - l @ r - | PNill -> [ Pe_EApp (Pe_EIdentifier "is_empty", expr) ] - | _ -> [] - in - helper expr pat -;; *) - let check_pattern expr pat = let rec helper add expr = function | PConstraint (p, _) -> helper add expr p From e780b7cbaf9ce596c58829ffe7259a5a63a16cd7 Mon Sep 17 00:00:00 2001 From: Dmitry Pilyuk Date: Sat, 8 Mar 2025 23:20:50 +0300 Subject: [PATCH 19/92] Add mli files --- FML/lib/anf/alpha_conv.mli | 12 +++++ FML/lib/anf/closure_conv.mli | 7 +++ FML/lib/anf/lambda_lifting.mli | 12 +++++ FML/lib/anf/pattern_elim.ml | 67 ----------------------- FML/lib/anf/pattern_elim.mli | 9 ++++ FML/lib/anf/pe_ast.ml | 67 +++++++++++++++++++++++ FML/lib/anf/pe_ast.mli | 34 ++++++++++++ FML/lib/ast/ast.mli | 87 ++++++++++++++++++++++++++++++ FML/tests/alpha_conv_runner.ml | 6 +-- FML/tests/closure_conv_runner.ml | 1 + FML/tests/lambda_lifting_runner.ml | 4 +- FML/tests/pe_runner.ml | 5 +- 12 files changed, 236 insertions(+), 75 deletions(-) create mode 100644 FML/lib/anf/alpha_conv.mli create mode 100644 FML/lib/anf/closure_conv.mli create mode 100644 FML/lib/anf/lambda_lifting.mli create mode 100644 FML/lib/anf/pattern_elim.mli create mode 100644 FML/lib/anf/pe_ast.mli create mode 100644 FML/lib/ast/ast.mli diff --git a/FML/lib/anf/alpha_conv.mli b/FML/lib/anf/alpha_conv.mli new file mode 100644 index 000000000..0bb404f60 --- /dev/null +++ b/FML/lib/anf/alpha_conv.mli @@ -0,0 +1,12 @@ +(** Copyright 2024-2025, Dmitry Pilyuk, Aleksandr Rozhkov *) + +(** SPDX-License-Identifier: LGPL-2.1 *) + +open Pe_ast +open Common + +val run_alpha_conv + : bindings + -> int + -> pe_declaration list + -> bindings * int * pe_declaration list diff --git a/FML/lib/anf/closure_conv.mli b/FML/lib/anf/closure_conv.mli new file mode 100644 index 000000000..96644aa60 --- /dev/null +++ b/FML/lib/anf/closure_conv.mli @@ -0,0 +1,7 @@ +(** Copyright 2024-2025, Dmitry Pilyuk, Aleksandr Rozhkov *) + +(** SPDX-License-Identifier: LGPL-2.1 *) + +open Pe_ast + +val run_cc : pe_declaration list -> pe_declaration list diff --git a/FML/lib/anf/lambda_lifting.mli b/FML/lib/anf/lambda_lifting.mli new file mode 100644 index 000000000..2ea22825b --- /dev/null +++ b/FML/lib/anf/lambda_lifting.mli @@ -0,0 +1,12 @@ +(** Copyright 2024-2025, Dmitry Pilyuk, Aleksandr Rozhkov *) + +(** SPDX-License-Identifier: LGPL-2.1 *) + +open Common +open Pe_ast + +val run_ll + : bindings + -> int + -> pe_declaration list + -> bindings * int * pe_declaration list diff --git a/FML/lib/anf/pattern_elim.ml b/FML/lib/anf/pattern_elim.ml index 33435c9c5..dbac24f60 100644 --- a/FML/lib/anf/pattern_elim.ml +++ b/FML/lib/anf/pattern_elim.ml @@ -6,73 +6,6 @@ open Ast open Pe_ast open Common -let const_to_str = function - | Pe_CBool b -> if b then "true" else "false" - | Pe_Cint i -> Format.sprintf "%i" i -;; - -let rec expr_to_str = function - | Pe_EUnit -> "()" - | Pe_ENill -> "[]" - | Pe_EIdentifier a -> a - | Pe_EConst c -> const_to_str c - | Pe_EIf (e1, e2, e3) -> - Format.sprintf - "if %s\nthen %s\nelse %s" - (expr_to_str e1) - (expr_to_str e2) - (expr_to_str e3) - | Pe_EFun (args, e) -> - Format.sprintf "(fun %s -> %s)" (String.concat " " args) (expr_to_str e) - | Pe_EApp (e1, e2) -> Format.sprintf "(%s %s)" (expr_to_str e1) (expr_to_str e2) - | Pe_ELet (NoRec, name, e1, e2) -> - Format.sprintf "let %s = %s in\n%s" name (expr_to_str e1) (expr_to_str e2) - | Pe_ELet (Rec, name1, e1, e2) -> - Format.sprintf "let rec %s = %s in\n%s" name1 (expr_to_str e1) (expr_to_str e2) - | Pe_ECons (e1, e2) -> Format.sprintf "(%s::%s)" (expr_to_str e1) (expr_to_str e2) - | Pe_ETuple e_list -> - Format.sprintf - "(%s)" - (expr_to_str (List.hd e_list) - ^ List.fold_left - (fun acc e -> acc ^ Format.sprintf ", %s" (expr_to_str e)) - "" - (List.tl e_list)) -;; - -let decl_to_str = function - | Pe_Nonrec decl_list -> - (match decl_list with - | [] -> "" - | (name, e) :: tl -> - Format.sprintf "let %s = %s" name (expr_to_str e) - ^ List.fold_left - (fun acc (name, e) -> - acc ^ Format.sprintf "\nlet %s = %s" name (expr_to_str e)) - "" - tl) - | Pe_Rec decl_list -> - (match decl_list with - | [] -> "" - | (name, e) :: tl -> - Format.sprintf "let rec %s = %s" name (expr_to_str e) - ^ List.fold_left - (fun acc (name, e) -> - acc ^ Format.sprintf "\nand %s = %s" name (expr_to_str e)) - "" - tl) -;; - -let pp_pe_structure ppf p = - let len = List.length p in - List.iteri - (fun i a -> - if i = len - 1 - then Format.fprintf ppf "%s" (decl_to_str a) - else Format.fprintf ppf "%s\n\n" (decl_to_str a)) - p -;; - type value_to_get = | Tuple of int | Cons_head diff --git a/FML/lib/anf/pattern_elim.mli b/FML/lib/anf/pattern_elim.mli new file mode 100644 index 000000000..40ece0139 --- /dev/null +++ b/FML/lib/anf/pattern_elim.mli @@ -0,0 +1,9 @@ +(** Copyright 2024-2025, Dmitry Pilyuk, Aleksandr Rozhkov *) + +(** SPDX-License-Identifier: LGPL-2.1 *) + +open Ast +open Pe_ast +open Common + +val run_pe : declaration list -> bindings * int * pe_declaration list diff --git a/FML/lib/anf/pe_ast.ml b/FML/lib/anf/pe_ast.ml index 62fc21c63..b9b674c82 100644 --- a/FML/lib/anf/pe_ast.ml +++ b/FML/lib/anf/pe_ast.ml @@ -27,3 +27,70 @@ type pe_declaration = | Pe_Rec of (string * pe_expr) list type pe_program = pe_declaration list + +let const_to_str = function + | Pe_CBool b -> if b then "true" else "false" + | Pe_Cint i -> Format.sprintf "%i" i +;; + +let rec expr_to_str = function + | Pe_EUnit -> "()" + | Pe_ENill -> "[]" + | Pe_EIdentifier a -> a + | Pe_EConst c -> const_to_str c + | Pe_EIf (e1, e2, e3) -> + Format.sprintf + "if %s\nthen %s\nelse %s" + (expr_to_str e1) + (expr_to_str e2) + (expr_to_str e3) + | Pe_EFun (args, e) -> + Format.sprintf "(fun %s -> %s)" (String.concat " " args) (expr_to_str e) + | Pe_EApp (e1, e2) -> Format.sprintf "(%s %s)" (expr_to_str e1) (expr_to_str e2) + | Pe_ELet (NoRec, name, e1, e2) -> + Format.sprintf "let %s = %s in\n%s" name (expr_to_str e1) (expr_to_str e2) + | Pe_ELet (Rec, name1, e1, e2) -> + Format.sprintf "let rec %s = %s in\n%s" name1 (expr_to_str e1) (expr_to_str e2) + | Pe_ECons (e1, e2) -> Format.sprintf "(%s::%s)" (expr_to_str e1) (expr_to_str e2) + | Pe_ETuple e_list -> + Format.sprintf + "(%s)" + (expr_to_str (List.hd e_list) + ^ List.fold_left + (fun acc e -> acc ^ Format.sprintf ", %s" (expr_to_str e)) + "" + (List.tl e_list)) +;; + +let decl_to_str = function + | Pe_Nonrec decl_list -> + (match decl_list with + | [] -> "" + | (name, e) :: tl -> + Format.sprintf "let %s = %s" name (expr_to_str e) + ^ List.fold_left + (fun acc (name, e) -> + acc ^ Format.sprintf "\nlet %s = %s" name (expr_to_str e)) + "" + tl) + | Pe_Rec decl_list -> + (match decl_list with + | [] -> "" + | (name, e) :: tl -> + Format.sprintf "let rec %s = %s" name (expr_to_str e) + ^ List.fold_left + (fun acc (name, e) -> + acc ^ Format.sprintf "\nand %s = %s" name (expr_to_str e)) + "" + tl) +;; + +let pp_pe_structure ppf p = + let len = List.length p in + List.iteri + (fun i a -> + if i = len - 1 + then Format.fprintf ppf "%s" (decl_to_str a) + else Format.fprintf ppf "%s\n\n" (decl_to_str a)) + p +;; diff --git a/FML/lib/anf/pe_ast.mli b/FML/lib/anf/pe_ast.mli new file mode 100644 index 000000000..f463de14c --- /dev/null +++ b/FML/lib/anf/pe_ast.mli @@ -0,0 +1,34 @@ +(** Copyright 2024-2025, Dmitry Pilyuk, Aleksandr Rozhkov *) + +(** SPDX-License-Identifier: LGPL-2.1 *) + +type rec_flag = + | Rec + | NoRec + +type pe_const = + | Pe_Cint of int + | Pe_CBool of bool + +type pe_expr = + | Pe_EUnit + | Pe_ENill + | Pe_EIdentifier of string + | Pe_EConst of pe_const + | Pe_EIf of pe_expr * pe_expr * pe_expr + | Pe_EFun of string list * pe_expr + | Pe_EApp of pe_expr * pe_expr + | Pe_ELet of rec_flag * string * pe_expr * pe_expr + | Pe_ECons of pe_expr * pe_expr + | Pe_ETuple of pe_expr list + +type pe_declaration = + | Pe_Nonrec of (string * pe_expr) list + | Pe_Rec of (string * pe_expr) list + +type pe_program = pe_declaration list + +val const_to_str : pe_const -> string +val expr_to_str : pe_expr -> string +val decl_to_str : pe_declaration -> string +val pp_pe_structure : Format.formatter -> pe_declaration list -> unit diff --git a/FML/lib/ast/ast.mli b/FML/lib/ast/ast.mli new file mode 100644 index 000000000..213c000b5 --- /dev/null +++ b/FML/lib/ast/ast.mli @@ -0,0 +1,87 @@ +(** Copyright 2024-2025, Dmitry Pilyuk, Aleksandr Rozhkov *) + +(** SPDX-License-Identifier: LGPL-2.1 *) + +type id = string [@@deriving show { with_path = false }] + +type const = + | CInt of int (** 1 *) + | CBool of bool (** true *) +[@@deriving show { with_path = false }] + +type rec_flag = + | Rec (** rec *) + | NoRec (** no rec annotation *) +[@@deriving show { with_path = false }] + +type type_annotation = + | AUnit (** : unit *) + | AInt (** : int *) + | ABool (** : bool *) + | AList of type_annotation (** : 'a list *) + | ATuple of type_annotation list (** : 'a * 'b *) + | AFunction of type_annotation * type_annotation (** : 'a -> 'b *) +[@@deriving show { with_path = false }] + +type pattern = + | PNill (** [] *) + | PAny (** _ *) + | PUnit (** () *) + | PConst of const (** 1 || true *) + | PIdentifier of id (** x *) + | PTuple of pattern list (** (x, y, z) *) + | PCons of pattern * pattern (** hd :: tl*) + | PConstraint of pattern * type_annotation (** P : type annotation *) +[@@deriving show { with_path = false }] + +type expression = + | EUnit (** () *) + | ENill (** [] *) + | EConstraint of expression * type_annotation (** E : type annotation *) + | EConst of const (** 1 || true*) + | EIdentifier of id (** x *) + | EApplication of expression * expression (** E1 E2*) + | EFun of pattern * expression (** fun P -> E*) + | ELetIn of rec_flag * pattern * expression * expression (** let f x = E1 *) + | ETuple of expression list (** (E1, E2, E3) *) + | EIf of expression * expression * expression (** if e1 then e2 else e3 *) + | ECons of expression * expression (** [a; b; c], a :: [b; c]*) + | EMatch of expression * (pattern * expression) list + (** match e with p1 -> e1 |...| pn -> en *) +[@@deriving show { with_path = false }] + +type single_declaration = DDeclaration of pattern * expression (** P = E*) +[@@deriving show { with_path = false }] + +type declaration = + | NoRecDecl of single_declaration list + (** let single_declaration (and single_declaration) *) + | RecDecl of single_declaration list + (** let rec single_declaration (and single_declaration) *) +[@@deriving show { with_path = false }] + +(** declaration;; declaration *) +type program = declaration list [@@deriving show { with_path = false }] + +(* Constructors for patterns *) +val cint : int -> const +val cbool : bool -> const +val pany : 'a -> pattern +val pnill : 'a -> pattern +val punit : 'a -> pattern +val pident : id -> pattern +val pconst : const -> pattern +val pcons : pattern -> pattern -> pattern +val ptuple : pattern list -> pattern +val pconstraint : pattern -> type_annotation -> pattern + +(* Constructors for expressions *) + +val econst : const -> expression +val eidentifier : id -> expression +val etuple : expression list -> expression +val efun : pattern -> expression -> expression +val econstraint : expression -> type_annotation -> expression + +(* Constructor for declaration *) +val ddeclaration : pattern -> expression -> single_declaration diff --git a/FML/tests/alpha_conv_runner.ml b/FML/tests/alpha_conv_runner.ml index 4e372c906..606dd6783 100644 --- a/FML/tests/alpha_conv_runner.ml +++ b/FML/tests/alpha_conv_runner.ml @@ -4,10 +4,10 @@ open Fml_lib.Parser open Fml_lib.Inferencer +open Fml_lib.Pe_ast open Fml_lib.Pattern_elim open Fml_lib.Alpha_conv - let () = let input = Stdio.In_channel.input_all Stdlib.stdin in let parse_and_infer input = @@ -15,7 +15,7 @@ let () = | Ok parsed -> (match run_program_inferencer parsed with | Ok _ -> Ok parsed - | Error _ -> Error (Format.asprintf "Infer error:" )) + | Error _ -> Error (Format.asprintf "Infer error:")) | Error e -> Error (Format.sprintf "Parsing error: %s" e) in match parse_and_infer input with @@ -24,4 +24,4 @@ let () = let _, _, ast = run_alpha_conv bind cnt ast in Format.printf "%a" pp_pe_structure ast | Error message -> Format.printf "%s" message -;; \ No newline at end of file +;; diff --git a/FML/tests/closure_conv_runner.ml b/FML/tests/closure_conv_runner.ml index 4d3ab9f26..56e7c1396 100644 --- a/FML/tests/closure_conv_runner.ml +++ b/FML/tests/closure_conv_runner.ml @@ -4,6 +4,7 @@ open Fml_lib.Parser open Fml_lib.Inferencer +open Fml_lib.Pe_ast open Fml_lib.Pattern_elim open Fml_lib.Alpha_conv open Fml_lib.Closure_conv diff --git a/FML/tests/lambda_lifting_runner.ml b/FML/tests/lambda_lifting_runner.ml index bff871164..a580f1945 100644 --- a/FML/tests/lambda_lifting_runner.ml +++ b/FML/tests/lambda_lifting_runner.ml @@ -4,12 +4,12 @@ open Fml_lib.Parser open Fml_lib.Inferencer +open Fml_lib.Pe_ast open Fml_lib.Pattern_elim open Fml_lib.Alpha_conv open Fml_lib.Lambda_lifting open Fml_lib.Closure_conv - let () = let input = Stdio.In_channel.input_all Stdlib.stdin in let parse_and_infer input = @@ -17,7 +17,7 @@ let () = | Ok parsed -> (match run_program_inferencer parsed with | Ok _ -> Ok parsed - | Error _ -> Error (Format.asprintf "Infer error:" )) + | Error _ -> Error (Format.asprintf "Infer error:")) | Error e -> Error (Format.sprintf "Parsing error: %s" e) in match parse_and_infer input with diff --git a/FML/tests/pe_runner.ml b/FML/tests/pe_runner.ml index fe0ae54a5..030e7de20 100644 --- a/FML/tests/pe_runner.ml +++ b/FML/tests/pe_runner.ml @@ -2,12 +2,11 @@ (** SPDX-License-Identifier: LGPL-2.1 *) - open Fml_lib.Parser open Fml_lib.Inferencer +open Fml_lib.Pe_ast open Fml_lib.Pattern_elim - let () = let input = Stdio.In_channel.input_all Stdlib.stdin in let parse_and_infer input = @@ -15,7 +14,7 @@ let () = | Ok parsed -> (match run_program_inferencer parsed with | Ok _ -> Ok parsed - | Error _ -> Error (Format.asprintf "Infer error:" )) + | Error _ -> Error (Format.asprintf "Infer error:")) | Error e -> Error (Format.sprintf "Parsing error: %s" e) in match parse_and_infer input with From ce93478217762955ab0c4d2ebde8b303089f5b22 Mon Sep 17 00:00:00 2001 From: Dmitry Pilyuk Date: Sun, 9 Mar 2025 01:42:25 +0300 Subject: [PATCH 20/92] Fix format --- FML/lib/anf/lambda_lifting.ml | 28 ++++++++++++++-------------- FML/lib/anf/pe_ast.mli | 32 ++++++++++++++++---------------- 2 files changed, 30 insertions(+), 30 deletions(-) diff --git a/FML/lib/anf/lambda_lifting.ml b/FML/lib/anf/lambda_lifting.ml index 08992ac0c..2e4530df1 100644 --- a/FML/lib/anf/lambda_lifting.ml +++ b/FML/lib/anf/lambda_lifting.ml @@ -2,7 +2,6 @@ (** SPDX-License-Identifier: LGPL-2.1 *) - open Base open Pe_ast open Common @@ -29,7 +28,7 @@ let rec ll_expr env = function let* fresh = fresh >>| get_id in let new_env = List.fold args ~init:env ~f:Map.remove in let* _, body = ll_expr new_env body in - return ([Pe_Nonrec [(fresh, Pe_EFun (args, body))]], Pe_EIdentifier fresh) + return ([ Pe_Nonrec [ fresh, Pe_EFun (args, body) ] ], Pe_EIdentifier fresh) | Pe_ECons (e1, e2) -> let* str1, e1 = ll_expr env e1 in let* str2, e2 = ll_expr env e2 in @@ -40,21 +39,21 @@ let rec ll_expr env = function return (List.concat str, Pe_ETuple el) | Pe_ELet (Rec, name, e1, e2) -> let* fresh_name = fresh >>| get_id in - let env = Map.set env ~key:name ~data:fresh_name in + let env = Map.set env ~key:name ~data:fresh_name in let* str1, e1 = ll_inner env e1 in let* str2, _ = ll_expr env e2 in - return (str1 @ [ Pe_Rec [(fresh_name, e1)] ] @ str2, Pe_EIdentifier fresh_name) + return (str1 @ [ Pe_Rec [ fresh_name, e1 ] ] @ str2, Pe_EIdentifier fresh_name) | Pe_ELet (rec_flag, name, e1, e2) -> let* str1, e1 = ll_inner env e1 in (match e1 with - | Pe_EFun _ -> - let* fresh_name = fresh >>| get_id in - let bindings = Map.set env ~key:name ~data:fresh_name in - let* str2, e2 = ll_expr bindings e2 in - return (str1 @ str2, Pe_ELet(rec_flag, name, e1, e2)) - | _ -> - let* str2, e2 = ll_expr env e2 in - return (str1 @ str2, Pe_ELet (rec_flag, name, e1, e2))) + | Pe_EFun _ -> + let* fresh_name = fresh >>| get_id in + let bindings = Map.set env ~key:name ~data:fresh_name in + let* str2, e2 = ll_expr bindings e2 in + return (str1 @ str2, Pe_ELet (rec_flag, name, e1, e2)) + | _ -> + let* str2, e2 = ll_expr env e2 in + return (str1 @ str2, Pe_ELet (rec_flag, name, e1, e2))) and ll_inner env = function | Pe_EFun (args, body) -> @@ -65,6 +64,7 @@ and ll_inner env = function let* str, e = ll_expr env e in return (str, e) ;; + let ll_str_item = function | Pe_Nonrec bindings -> let* lifted_bindings = @@ -74,7 +74,6 @@ let ll_str_item = function in let strs, new_bindings = List.unzip lifted_bindings in return (List.concat strs @ [ Pe_Nonrec new_bindings ]) - | Pe_Rec bindings -> let* lifted_bindings = map bindings ~f:(fun (name, e) -> @@ -83,6 +82,7 @@ let ll_str_item = function in let strs, new_bindings = List.unzip lifted_bindings in return (List.concat strs @ [ Pe_Rec new_bindings ]) +;; let ll_structure structure = let rec helper = function @@ -95,4 +95,4 @@ let ll_structure structure = helper structure ;; -let run_ll bindings init_num p = run (ll_structure p) bindings init_num \ No newline at end of file +let run_ll bindings init_num p = run (ll_structure p) bindings init_num diff --git a/FML/lib/anf/pe_ast.mli b/FML/lib/anf/pe_ast.mli index f463de14c..e6c32ae72 100644 --- a/FML/lib/anf/pe_ast.mli +++ b/FML/lib/anf/pe_ast.mli @@ -3,28 +3,28 @@ (** SPDX-License-Identifier: LGPL-2.1 *) type rec_flag = - | Rec - | NoRec + | Rec (** rec *) + | NoRec (** norec*) type pe_const = - | Pe_Cint of int - | Pe_CBool of bool + | Pe_Cint of int (** 1 *) + | Pe_CBool of bool (** true *) type pe_expr = - | Pe_EUnit - | Pe_ENill - | Pe_EIdentifier of string - | Pe_EConst of pe_const - | Pe_EIf of pe_expr * pe_expr * pe_expr - | Pe_EFun of string list * pe_expr - | Pe_EApp of pe_expr * pe_expr - | Pe_ELet of rec_flag * string * pe_expr * pe_expr - | Pe_ECons of pe_expr * pe_expr - | Pe_ETuple of pe_expr list + | Pe_EUnit (** () *) + | Pe_ENill (** [] *) + | Pe_EIdentifier of string (** x *) + | Pe_EConst of pe_const (** 1 || true *) + | Pe_EIf of pe_expr * pe_expr * pe_expr (** if E1 then E2 else E3*) + | Pe_EFun of string list * pe_expr (** fun x y -> E *) + | Pe_EApp of pe_expr * pe_expr (** E1 E2 *) + | Pe_ELet of rec_flag * string * pe_expr * pe_expr (** let (rec) f = E1 in E2 *) + | Pe_ECons of pe_expr * pe_expr (** E1 :: E2 *) + | Pe_ETuple of pe_expr list (** (E1, E2, E3) *) type pe_declaration = - | Pe_Nonrec of (string * pe_expr) list - | Pe_Rec of (string * pe_expr) list + | Pe_Nonrec of (string * pe_expr) list (** (let f1 = E1 (and f2 = E2) *) + | Pe_Rec of (string * pe_expr) list (** (let rec f1 = E1 (and f2 = E2) *) type pe_program = pe_declaration list From 722181b740b3f6da3a5b158f22bfb263bfd6d2cb Mon Sep 17 00:00:00 2001 From: Dmitry Pilyuk Date: Sun, 9 Mar 2025 01:58:53 +0300 Subject: [PATCH 21/92] Update tests --- FML/tests/alpha_conv_manytest.t | 4 ++-- FML/tests/closure_conv_manytest.t | 8 ++++---- FML/tests/lambda_lifting_manytests.t | 8 ++++---- FML/tests/parser_manytests.t | 4 ++-- FML/tests/pe_manytests.t | 4 ++-- 5 files changed, 14 insertions(+), 14 deletions(-) diff --git a/FML/tests/alpha_conv_manytest.t b/FML/tests/alpha_conv_manytest.t index 11477cd97..4773a61ad 100644 --- a/FML/tests/alpha_conv_manytest.t +++ b/FML/tests/alpha_conv_manytest.t @@ -154,13 +154,13 @@ let feven = (fun p n -> let e = ((tuple_element p) 0) in let o = ((tuple_element p) 1) in - if ((( == ) n) 0) + if ((( = ) n) 0) then 1 else (o ((( - ) n) 1))) let fodd = (fun p n -> let e = ((tuple_element p) 0) in let o = ((tuple_element p) 1) in - if ((( == ) n) 0) + if ((( = ) n) 0) then 0 else (e ((( - ) n) 1))) diff --git a/FML/tests/closure_conv_manytest.t b/FML/tests/closure_conv_manytest.t index 633df5d47..1bf0b5cd2 100644 --- a/FML/tests/closure_conv_manytest.t +++ b/FML/tests/closure_conv_manytest.t @@ -152,15 +152,15 @@ let fixpoly = (fun l -> ((fix (fun self a0 -> ((map (((fun a0 self li x -> ((li (self a0)) x)) a0) self)) a0))) l)) - let feven = (fun ( == ) p n -> let e = ((tuple_element p) 0) in + let feven = (fun p n -> let e = ((tuple_element p) 0) in let o = ((tuple_element p) 1) in - if ((( == ) n) 0) + if ((( = ) n) 0) then 1 else (o ((( - ) n) 1))) - let fodd = (fun ( == ) p n -> let e = ((tuple_element p) 0) in + let fodd = (fun p n -> let e = ((tuple_element p) 0) in let o = ((tuple_element p) 1) in - if ((( == ) n) 0) + if ((( = ) n) 0) then 0 else (e ((( - ) n) 1))) diff --git a/FML/tests/lambda_lifting_manytests.t b/FML/tests/lambda_lifting_manytests.t index c8f0b0b17..57958af55 100644 --- a/FML/tests/lambda_lifting_manytests.t +++ b/FML/tests/lambda_lifting_manytests.t @@ -199,15 +199,15 @@ let fixpoly = (fun l -> ((fix a1) l)) - let feven = (fun ( == ) p n -> let e = ((tuple_element p) 0) in + let feven = (fun p n -> let e = ((tuple_element p) 0) in let o = ((tuple_element p) 1) in - if ((( == ) n) 0) + if ((( = ) n) 0) then 1 else (o ((( - ) n) 1))) - let fodd = (fun ( == ) p n -> let e = ((tuple_element p) 0) in + let fodd = (fun p n -> let e = ((tuple_element p) 0) in let o = ((tuple_element p) 1) in - if ((( == ) n) 0) + if ((( = ) n) 0) then 0 else (e ((( - ) n) 1))) diff --git a/FML/tests/parser_manytests.t b/FML/tests/parser_manytests.t index 9844eeba2..8f63ffa06 100644 --- a/FML/tests/parser_manytests.t +++ b/FML/tests/parser_manytests.t @@ -944,7 +944,7 @@ (EIdentifier "p"), (EIf ( (EApplication ( - (EApplication ((EIdentifier "( == )"), + (EApplication ((EIdentifier "( = )"), (EIdentifier "n"))), (EConst (CInt 0)))), (EConst (CInt 1)), @@ -969,7 +969,7 @@ (EIdentifier "p"), (EIf ( (EApplication ( - (EApplication ((EIdentifier "( == )"), + (EApplication ((EIdentifier "( = )"), (EIdentifier "n"))), (EConst (CInt 0)))), (EConst (CInt 0)), diff --git a/FML/tests/pe_manytests.t b/FML/tests/pe_manytests.t index 74f4fde83..9c91b7b56 100644 --- a/FML/tests/pe_manytests.t +++ b/FML/tests/pe_manytests.t @@ -154,13 +154,13 @@ let feven = (fun p n -> let e = ((tuple_element p) 0) in let o = ((tuple_element p) 1) in - if ((( == ) n) 0) + if ((( = ) n) 0) then 1 else (o ((( - ) n) 1))) let fodd = (fun p n -> let e = ((tuple_element p) 0) in let o = ((tuple_element p) 1) in - if ((( == ) n) 0) + if ((( = ) n) 0) then 0 else (e ((( - ) n) 1))) From 81ee04b4d70d809f3220c90cb58cd8099f566c18 Mon Sep 17 00:00:00 2001 From: Dmitry Pilyuk Date: Sun, 9 Mar 2025 02:54:53 +0300 Subject: [PATCH 22/92] WIP ANF --- FML/lib/anf/anf.ml | 26 ++++++++++++++++++++++++++ FML/lib/anf/anf_ast.ml | 32 ++++++++++++++++++++++++++++++++ FML/lib/dune | 4 +++- 3 files changed, 61 insertions(+), 1 deletion(-) create mode 100644 FML/lib/anf/anf.ml diff --git a/FML/lib/anf/anf.ml b/FML/lib/anf/anf.ml new file mode 100644 index 000000000..9f481f449 --- /dev/null +++ b/FML/lib/anf/anf.ml @@ -0,0 +1,26 @@ +(** Copyright 2024-2025, Dmitry Pilyuk, Aleksandr Rozhkov *) + +(** SPDX-License-Identifier: LGPL-2.1 *) + +open Pe_ast +open Anf_ast +open Common +open Common.MonadCounter + +let const_to_immexpr = function + | Pe_Cint n -> ImmInt n + | Pe_CBool v -> ImmBool v +;; + +let rec to_immexpr = function + | Pe_EConst c -> return ([], const_to_immexpr c) + | Pe_EIdentifier name -> return ([], imm_id name) + | e -> + let* fresh = fresh >>| get_id in + let* binds1, e = to_cexp e in + return (binds1 @ [ fresh, e ], imm_id fresh) + +and to_cexp = function + | Pe_EIdentifier name -> return ([], cimmexpr @@ imm_id name) + | Pe_EConst c -> return ([], cimmexpr @@ const_to_immexpr c) +;; diff --git a/FML/lib/anf/anf_ast.ml b/FML/lib/anf/anf_ast.ml index e69de29bb..6000c942a 100644 --- a/FML/lib/anf/anf_ast.ml +++ b/FML/lib/anf/anf_ast.ml @@ -0,0 +1,32 @@ +(** Copyright 2024-2025, Dmitry Pilyuk, Aleksandr Rozhkov *) + +(** SPDX-License-Identifier: LGPL-2.1 *) + +type immexpr = + | ImmInt of int + | ImmIdentifier of string + | ImmBool of bool + | ImmUnit + | ImmNill + | ImmTuple of immexpr list + +type cexpr = + | CEApply of cexpr * cexpr + | CEIf of immexpr * aexpr * aexpr + | CECons of immexpr * immexpr + | CImmExpr of immexpr + +and aexpr = + | ALetIn of string * cexpr * aexpr + | ACExpr of cexpr + +type anf_binding = ALet of string * string list * aexpr + +type anf_decl = + | ADNoRec of anf_binding + | ADREC of anf_binding list + +type anf_prog = anf_decl list + +let imm_id id = ImmIdentifier id +let cimmexpr immexpr = CImmExpr immexpr diff --git a/FML/lib/dune b/FML/lib/dune index b81fa7dcf..aef919537 100644 --- a/FML/lib/dune +++ b/FML/lib/dune @@ -15,7 +15,9 @@ Pe_ast Alpha_conv Closure_conv - Lambda_lifting) + Lambda_lifting + Anf_ast + Anf) (modules_without_implementation inf_errors) (libraries base angstrom) (preprocess From fafce86346ded584734cd485035a4dcf060b4860 Mon Sep 17 00:00:00 2001 From: RozhkovAleksandr Date: Sun, 9 Mar 2025 17:27:25 +0300 Subject: [PATCH 23/92] anf barely --- FML/lib/anf/anf.ml | 134 +++++++++++++++++++++++++++++++++----- FML/lib/anf/anf_ast.ml | 69 +++++++++++++++++++- FML/tests/anf_manytests.t | 0 FML/tests/anf_runner.ml | 36 ++++++++++ FML/tests/dune | 32 +++++++++ 5 files changed, 254 insertions(+), 17 deletions(-) create mode 100644 FML/tests/anf_manytests.t create mode 100644 FML/tests/anf_runner.ml diff --git a/FML/lib/anf/anf.ml b/FML/lib/anf/anf.ml index 9f481f449..7f2140a74 100644 --- a/FML/lib/anf/anf.ml +++ b/FML/lib/anf/anf.ml @@ -1,26 +1,130 @@ -(** Copyright 2024-2025, Dmitry Pilyuk, Aleksandr Rozhkov *) - -(** SPDX-License-Identifier: LGPL-2.1 *) - -open Pe_ast -open Anf_ast open Common +open Anf_ast +open Pe_ast +open Base open Common.MonadCounter -let const_to_immexpr = function - | Pe_Cint n -> ImmInt n - | Pe_CBool v -> ImmBool v +let cexp_app e e_list = CEApply (e, e_list) +let cexp_ite i t e = CEIf (i, t, e) +let cexp_cons aexp1 aexp2 = CECons (aexp1, aexp2) +let aexpr_let_in name cexp exp = ALetIn (name, cexp, exp) +let aexpr_complex cexp = ACExpr cexp + +let imm_int int_ = ImmInt int_ +let imm_bool bool_ = ImmBool bool_ +let imm_var var_ = ImmIdentifier var_ +let imm_tuple lst_ = ImmTuple lst_ +let const_to_immexp = function + | Pe_Cint i -> ImmInt i + | Pe_CBool b -> ImmBool b ;; -let rec to_immexpr = function - | Pe_EConst c -> return ([], const_to_immexpr c) - | Pe_EIdentifier name -> return ([], imm_id name) + +let rec to_immexp = function + | Pe_EIdentifier v -> return ([], imm_var v) + | Pe_EConst c -> return ([], const_to_immexp c) + | Pe_EUnit -> return ([], ImmUnit) + | Pe_ENill -> return ([], ImmNill) | e -> let* fresh = fresh >>| get_id in let* binds1, e = to_cexp e in - return (binds1 @ [ fresh, e ], imm_id fresh) + return (binds1 @ [ fresh, e ], imm_var fresh) and to_cexp = function - | Pe_EIdentifier name -> return ([], cimmexpr @@ imm_id name) - | Pe_EConst c -> return ([], cimmexpr @@ const_to_immexpr c) + | Pe_EUnit -> return ([], cimmexpr @@ ImmUnit) + | Pe_ENill -> return ([], cimmexpr @@ ImmNill) + | Pe_EConst c -> return ([], cimmexpr @@ const_to_immexp c) + | Pe_EIdentifier v -> return ([], cimmexpr @@ imm_var v) + | Pe_EApp (e1, e2) -> app_to_cexp e1 e2 + | Pe_ELet (NoRec, name, e1, e2) -> + let* binds1, e1 = to_cexp e1 in + let* binds2, e2 = to_cexp e2 in + return (binds1 @ [ name, e1 ] @ binds2, e2) + | Pe_EIf (e1, e2, e3) -> + let* binds, e1 = to_immexp e1 in + let* e2 = to_exp e2 in + let* e3 = to_exp e3 in + return (binds, cexp_ite e1 e2 e3) + | Pe_ETuple e_list -> + let* binds, e_list = map e_list ~f:to_immexp >>| List.unzip in + return (List.concat binds, cimmexpr @@ imm_tuple e_list) + | Pe_ECons (e1, e2) -> + let* binds1, e1 = to_immexp e1 in + let* binds2, e2 = to_immexp e2 in + return (binds1 @ binds2, cexp_cons e1 e2) + | _ -> return ([], cimmexpr @@ ImmUnit) + +and app_to_cexp e1 e2 = + let rec helper = function + | Pe_EApp (e1, e2) -> + let f, args_e = helper e1 in + f, e2 :: args_e + | e -> e, [] + in + let to_app, args_e = helper @@ Pe_EApp (e1, e2) in + let args_e = List.rev args_e in + let f1 acc expr = + let cur_exprs, cur_binds = acc in + match expr with + | Pe_EIdentifier v -> return (imm_var v :: cur_exprs, cur_binds) + | Pe_EConst c -> return (const_to_immexp c :: cur_exprs, cur_binds) + | _ -> + let* fresh = fresh >>| get_id in + let* new_binds, f_cexp = to_cexp expr in + return (imm_var fresh :: cur_exprs, new_binds @ [ fresh, f_cexp ] @ cur_binds) + in + let* exprs, binds = fold_left (to_app :: args_e) ~init:(return ([], [])) ~f:f1 in + let exprs = List.rev exprs in + match List.hd_exn exprs with + | ImmIdentifier to_app -> + let args_e = List.tl_exn exprs in + return (binds, cexp_app to_app args_e) + | _ -> failwith "Unexpected expression in application" + +and to_exp e = + let* binds, init = to_cexp e in + fold_right + binds + ~init:(return @@ aexpr_complex init) + ~f:(fun (name, cexp) acc -> return @@ aexpr_let_in name cexp acc) +;; + +let anf_str_item = function + | Pe_Nonrec decls -> + let* bindings = + map decls ~f:(fun (name, e) -> + match e with + | Pe_EFun (args, body) -> + let* new_body = to_exp body in + return (ADNoRec (ALet (name, args, new_body))) + | _ -> + let* new_e = to_exp e in + return (ADNoRec (ALet (name, [], new_e)))) + in + return bindings + | Pe_Rec decls -> + let* bindings = + map decls ~f:(fun (name, e) -> + match e with + | Pe_EFun (args, body) -> + let* new_body = to_exp body in + return (ALet (name, args, new_body)) + | _ -> + let* new_e = to_exp e in + return (ALet (name, [], new_e))) + in + return [ ADREC bindings ] ;; + +let anf_structure structure = + let rec helper = function + | [] -> return [] + | hd :: tl -> + let* d1 = anf_str_item hd in + let* d2 = helper tl in + return @@ d1 @ d2 + in + helper structure +;; + +let run_anf bindings init structure = run (anf_structure structure) bindings init \ No newline at end of file diff --git a/FML/lib/anf/anf_ast.ml b/FML/lib/anf/anf_ast.ml index 6000c942a..3b2c76c6a 100644 --- a/FML/lib/anf/anf_ast.ml +++ b/FML/lib/anf/anf_ast.ml @@ -11,7 +11,7 @@ type immexpr = | ImmTuple of immexpr list type cexpr = - | CEApply of cexpr * cexpr + | CEApply of string * immexpr list | CEIf of immexpr * aexpr * aexpr | CECons of immexpr * immexpr | CImmExpr of immexpr @@ -23,10 +23,75 @@ and aexpr = type anf_binding = ALet of string * string list * aexpr type anf_decl = - | ADNoRec of anf_binding + | ADNoRec of anf_binding | ADREC of anf_binding list type anf_prog = anf_decl list let imm_id id = ImmIdentifier id let cimmexpr immexpr = CImmExpr immexpr + + +let rec atom_to_str = function + | ImmInt i -> Int.to_string i + | ImmBool b -> Bool.to_string b + | ImmUnit -> "()" + | ImmIdentifier v -> v + | ImmNill -> "[]" + | ImmTuple l -> + Format.sprintf + "(%s)" + (atom_to_str (Base.List.hd_exn l) + ^ Base.List.fold_left + ~f:(fun acc e -> acc ^ Format.sprintf ", %s" (atom_to_str e)) + ~init:"" + (Base.List.tl_exn l)) +;; + +let rec cexp_to_str = function + | CImmExpr a -> atom_to_str a + | CEApply (a1, a_list) -> + Base.List.fold_left ~init:a1 ~f:(fun acc a -> "(" ^ acc ^ " " ^ atom_to_str a ^ ")") a_list + | CEIf (e1, e2, e3) -> + Format.sprintf + "if %s\nthen %s\nelse %s" + (atom_to_str e1) + (exp_to_str e2) + (exp_to_str e3) + | CECons (e1, e2) -> Format.sprintf "(%s::%s)" (atom_to_str e1) (atom_to_str e2) + +and exp_to_str = function + | ALetIn (name, c, e) -> + Format.sprintf "let %s = %s in\n%s" name (cexp_to_str c) (exp_to_str e) + | ACExpr e -> cexp_to_str e +;; + +let fun_to_str = function + | ALet (name, args, body) -> + Format.sprintf + "%s = %s" + (Base.List.fold args ~init:name ~f:(fun acc arg -> acc ^ " " ^ arg)) + (exp_to_str body) +;; + +let str_item_to_str = function + | ADNoRec (ALet (name, args, body)) -> + Format.sprintf "let %s" (fun_to_str (ALet (name, args, body))) + | ADREC func_list -> + let fun1 = Base.List.hd_exn func_list in + let tl = Base.List.tl_exn func_list in + Base.List.fold_left + tl + ~init:(Format.sprintf "let rec %s" (fun_to_str fun1)) + ~f:(fun acc fun1 -> acc ^ "\nand " ^ fun_to_str fun1) +;; + +let pp_anf_structure ppf p = + let len = List.length p in + Base.List.iteri + ~f:(fun i a -> + if i = len - 1 + then Format.sprintf ppf "%s" (str_item_to_str a) + else Format.sprintf ppf "%s\n\n" (str_item_to_str a)) + p +;; \ No newline at end of file diff --git a/FML/tests/anf_manytests.t b/FML/tests/anf_manytests.t new file mode 100644 index 000000000..e69de29bb diff --git a/FML/tests/anf_runner.ml b/FML/tests/anf_runner.ml new file mode 100644 index 000000000..fa4b7e8fb --- /dev/null +++ b/FML/tests/anf_runner.ml @@ -0,0 +1,36 @@ + +(** Copyright 2024-2025, Dmitry Pilyuk, Aleksandr Rozhkov *) + +(** SPDX-License-Identifier: LGPL-2.1 *) + +open Fml_lib.Parser +open Fml_lib.Inferencer +open Fml_lib.Pe_ast +open Fml_lib.Pattern_elim +open Fml_lib.Alpha_conv +open Fml_lib.Lambda_lifting +open Fml_lib.Closure_conv +open Fml_lib.Anf +open Fml_lib.Anf_ast + +let () = + let input = Stdio.In_channel.input_all Stdlib.stdin in + let parse_and_infer input = + match parse input with + | Ok parsed -> + (match run_program_inferencer parsed with + | Ok _ -> Ok parsed + | Error _ -> Error (Format.asprintf "Infer error:")) + | Error e -> Error (Format.sprintf "Parsing error: %s" e) + in + match parse_and_infer input with + | Ok ast -> + let bind, cnt, ast = run_pe ast in + let bind, cnt, ast = run_alpha_conv bind cnt ast in + let ast = run_cc ast in + let bind, cnt, ast = run_ll bind cnt ast in + let _, _, ast = run_anf bind cnt ast in + Format.printf "%a" pp_anf_structure ast + Format.printf "%a" pp_pe_structure ast + | Error message -> Format.printf "%s" message +;; diff --git a/FML/tests/dune b/FML/tests/dune index 66d52aa37..831095135 100644 --- a/FML/tests/dune +++ b/FML/tests/dune @@ -44,6 +44,12 @@ (modules lambda_lifting_runner) (libraries fml_lib stdio)) +(executable + (name anf_runner) + (public_name anf_runner) + (modules anf_runner) + (libraries fml_lib stdio)) + (cram (applies_to parser_manytests) (deps @@ -199,3 +205,29 @@ manytests/typed/013foldfoldr.ml manytests/typed/015tuples.ml manytests/typed/016lists.ml)) + +(cram + (applies_to anf_manytests) + (deps + ./anf_runner.exe + manytests/do_not_type/001.ml + manytests/do_not_type/002if.ml + manytests/do_not_type/003occurs.ml + manytests/do_not_type/004let_poly.ml + manytests/do_not_type/015tuples.ml + manytests/typed/001fac.ml + manytests/typed/002fac.ml + manytests/typed/003fib.ml + manytests/typed/004manyargs.ml + manytests/typed/005fix.ml + manytests/typed/006partial.ml + manytests/typed/006partial2.ml + manytests/typed/006partial3.ml + manytests/typed/007order.ml + manytests/typed/008ascription.ml + manytests/typed/009let_poly.ml + manytests/typed/011mapcps.ml + manytests/typed/012fibcps.ml + manytests/typed/013foldfoldr.ml + manytests/typed/015tuples.ml + manytests/typed/016lists.ml)) \ No newline at end of file From 4e504021958ea80e78a2a4dc93b175370588d250 Mon Sep 17 00:00:00 2001 From: Dmitry Pilyuk Date: Sun, 9 Mar 2025 17:59:20 +0300 Subject: [PATCH 24/92] Anf runner --- FML/lib/anf/anf.ml | 13 +- FML/lib/anf/anf_ast.ml | 23 +- FML/tests/anf_manytests.t | 515 ++++++++++++++++++++++++++++++ FML/tests/anf_runner.ml | 5 +- FML/tests/closure_conv_manytest.t | 12 + 5 files changed, 549 insertions(+), 19 deletions(-) diff --git a/FML/lib/anf/anf.ml b/FML/lib/anf/anf.ml index 7f2140a74..452569947 100644 --- a/FML/lib/anf/anf.ml +++ b/FML/lib/anf/anf.ml @@ -9,17 +9,16 @@ let cexp_ite i t e = CEIf (i, t, e) let cexp_cons aexp1 aexp2 = CECons (aexp1, aexp2) let aexpr_let_in name cexp exp = ALetIn (name, cexp, exp) let aexpr_complex cexp = ACExpr cexp - let imm_int int_ = ImmInt int_ let imm_bool bool_ = ImmBool bool_ let imm_var var_ = ImmIdentifier var_ let imm_tuple lst_ = ImmTuple lst_ + let const_to_immexp = function | Pe_Cint i -> ImmInt i | Pe_CBool b -> ImmBool b ;; - let rec to_immexp = function | Pe_EIdentifier v -> return ([], imm_var v) | Pe_EConst c -> return ([], const_to_immexp c) @@ -76,7 +75,7 @@ and app_to_cexp e1 e2 = let* exprs, binds = fold_left (to_app :: args_e) ~init:(return ([], [])) ~f:f1 in let exprs = List.rev exprs in match List.hd_exn exprs with - | ImmIdentifier to_app -> + | ImmIdentifier to_app -> let args_e = List.tl_exn exprs in return (binds, cexp_app to_app args_e) | _ -> failwith "Unexpected expression in application" @@ -96,12 +95,12 @@ let anf_str_item = function match e with | Pe_EFun (args, body) -> let* new_body = to_exp body in - return (ADNoRec (ALet (name, args, new_body))) + return (ALet (name, args, new_body)) | _ -> let* new_e = to_exp e in - return (ADNoRec (ALet (name, [], new_e)))) + return (ALet (name, [], new_e))) in - return bindings + return [ ADNoRec bindings ] | Pe_Rec decls -> let* bindings = map decls ~f:(fun (name, e) -> @@ -127,4 +126,4 @@ let anf_structure structure = helper structure ;; -let run_anf bindings init structure = run (anf_structure structure) bindings init \ No newline at end of file +let run_anf bindings init structure = run (anf_structure structure) bindings init diff --git a/FML/lib/anf/anf_ast.ml b/FML/lib/anf/anf_ast.ml index 3b2c76c6a..ab90b0ed9 100644 --- a/FML/lib/anf/anf_ast.ml +++ b/FML/lib/anf/anf_ast.ml @@ -23,7 +23,7 @@ and aexpr = type anf_binding = ALet of string * string list * aexpr type anf_decl = - | ADNoRec of anf_binding + | ADNoRec of anf_binding list | ADREC of anf_binding list type anf_prog = anf_decl list @@ -31,7 +31,6 @@ type anf_prog = anf_decl list let imm_id id = ImmIdentifier id let cimmexpr immexpr = CImmExpr immexpr - let rec atom_to_str = function | ImmInt i -> Int.to_string i | ImmBool b -> Bool.to_string b @@ -51,7 +50,10 @@ let rec atom_to_str = function let rec cexp_to_str = function | CImmExpr a -> atom_to_str a | CEApply (a1, a_list) -> - Base.List.fold_left ~init:a1 ~f:(fun acc a -> "(" ^ acc ^ " " ^ atom_to_str a ^ ")") a_list + Base.List.fold_left + ~init:a1 + ~f:(fun acc a -> "(" ^ acc ^ " " ^ atom_to_str a ^ ")") + a_list | CEIf (e1, e2, e3) -> Format.sprintf "if %s\nthen %s\nelse %s" @@ -75,8 +77,13 @@ let fun_to_str = function ;; let str_item_to_str = function - | ADNoRec (ALet (name, args, body)) -> - Format.sprintf "let %s" (fun_to_str (ALet (name, args, body))) + | ADNoRec func_list -> + let fun1 = Base.List.hd_exn func_list in + let tl = Base.List.tl_exn func_list in + Base.List.fold_left + tl + ~init:(Format.sprintf "let %s" (fun_to_str fun1)) + ~f:(fun acc fun1 -> acc ^ "\nand " ^ fun_to_str fun1) | ADREC func_list -> let fun1 = Base.List.hd_exn func_list in let tl = Base.List.tl_exn func_list in @@ -91,7 +98,7 @@ let pp_anf_structure ppf p = Base.List.iteri ~f:(fun i a -> if i = len - 1 - then Format.sprintf ppf "%s" (str_item_to_str a) - else Format.sprintf ppf "%s\n\n" (str_item_to_str a)) + then Format.fprintf ppf "%s" (str_item_to_str a) + else Format.fprintf ppf "%s\n\n" (str_item_to_str a)) p -;; \ No newline at end of file +;; diff --git a/FML/tests/anf_manytests.t b/FML/tests/anf_manytests.t index e69de29bb..8e3eea438 100644 --- a/FML/tests/anf_manytests.t +++ b/FML/tests/anf_manytests.t @@ -0,0 +1,515 @@ + $ ./anf_runner.exe << EOF + > let fac n = + > let rec fack n k = + > if n<=1 then k 1 + > else fack (n - 1) ((fun k n m -> k (m * n)) k n) + > in + > fack n (fun x -> x) + > EOF + let a4 a1 a2 m = let a6 = ((( * ) m) a2) in + (a1 a6) + + let rec a3 a0 k = let a7 = ((( <= ) a0) 1) in + if a7 + then (k 1) + else let a9 = ((a4 k) a0) in + let a8 = ((( - ) a0) 1) in + ((a3 a8) a9) + + let a5 x = x + + let fac n = a3 + $ ./anf_runner.exe < manytests/typed/001fac.ml + let rec fac n = let a0 = ((( <= ) n) 1) in + if a0 + then 1 + else let a2 = ((( - ) n) 1) in + let a1 = (fac a2) in + ((( * ) n) a1) + + let main = let a3 = (fac 4) in + let () = (print_int a3) in + 0 + + $ ./anf_runner.exe < manytests/typed/002fac.ml + let a1 k n p = let a3 = ((( * ) p) n) in + (k a3) + + let rec fac_cps n k = let a4 = ((( = ) n) 1) in + if a4 + then (k 1) + else let a6 = ((a1 k) n) in + let a5 = ((( - ) n) 1) in + ((fac_cps a5) a6) + + let a2 a0 = a0 + + let main = let a7 = ((fac_cps 4) a2) in + let () = (print_int a7) in + 0 + + $ ./anf_runner.exe < manytests/typed/003fib.ml + let rec fib_acc a b n = let a0 = ((( = ) n) 1) in + if a0 + then b + else let n1 = ((( - ) n) 1) in + let ab = ((( + ) a) b) in + (((fib_acc b) ab) n1) + + let rec fib n = let a1 = ((( < ) n) 2) in + if a1 + then n + else let a5 = ((( - ) n) 2) in + let a4 = (fib a5) in + let a3 = ((( - ) n) 1) in + let a2 = (fib a3) in + ((( + ) a2) a4) + + let main = let a6 = (((fib_acc 0) 1) 4) in + let () = (print_int a6) in + let a7 = (fib 4) in + let () = (print_int a7) in + 0 + + $ ./anf_runner.exe < manytests/typed/004manyargs.ml + let wrap f = let a3 = ((( = ) 1) 1) in + if a3 + then f + else f + + let test3 a b c = let a0 = (print_int a) in + let a1 = (print_int b) in + let a2 = (print_int c) in + 0 + + let test10 a b c d e f g h i j = let a11 = ((( + ) a) b) in + let a10 = ((( + ) a11) c) in + let a9 = ((( + ) a10) d) in + let a8 = ((( + ) a9) e) in + let a7 = ((( + ) a8) f) in + let a6 = ((( + ) a7) g) in + let a5 = ((( + ) a6) h) in + let a4 = ((( + ) a5) i) in + ((( + ) a4) j) + + let main = let rez = (((((((((((wrap test10) 1) 10) 100) 1000) 10000) 100000) 1000000) 10000000) 100000000) 1000000000) in + let () = (print_int rez) in + let temp2 = ((((wrap test3) 1) 10) 100) in + 0 + + $ ./anf_runner.exe < manytests/typed/005fix.ml + let rec fix f x = let a0 = (fix f) in + ((f a0) x) + + let fac self n = let a1 = ((( <= ) n) 1) in + if a1 + then 1 + else let a3 = ((( - ) n) 1) in + let a2 = (self a3) in + ((( * ) n) a2) + + let main = let a4 = ((fix fac) 6) in + let () = (print_int a4) in + 0 + + $ ./anf_runner.exe < manytests/typed/006partial.ml + let a3 a0 = ((( + ) a0) 2) + + let a4 a1 = ((( * ) a1) 10) + + let foo b = if b + then a3 + else a4 + + let a2 a2 x = let a7 = ((a2 false) x) in + let a6 = ((a2 true) a7) in + let a5 = ((a2 false) a6) in + ((a2 true) a5) + + let main = let a8 = (a2 11) in + let () = (print_int a8) in + 0 + + $ ./anf_runner.exe < manytests/typed/006partial2.ml + let foo a b c = let () = (print_int a) in + let () = (print_int b) in + let () = (print_int c) in + let a3 = ((( * ) b) c) in + ((( + ) a) a3) + + let main = let a0 = (foo 1) in + let a1 = (a0 2) in + let a2 = (a1 3) in + let () = (print_int a2) in + 0 + $ ./anf_runner.exe < manytests/typed/006partial3.ml + let a0 b = let () = (print_int b) in + a1 + + let foo a = let () = (print_int a) in + a0 + + let main = let () = (((foo 4) 8) 9) in + 0 + $ ./anf_runner.exe < manytests/typed/007order.ml + let _start a0 a1 a a2 b _c a3 d __ = let a4 = (a0, a1, a2, a3) in + let a5 = ((( + ) a) b) in + let () = (print_int a5) in + let () = (print_int __) in + let a7 = ((( * ) a) b) in + let a6 = ((( / ) a7) _c) in + ((( + ) a6) d) + + let main = let a14 = (( ~- ) 555555) in + let a13 = (( ~- ) 1) in + let a12 = (print_int a13) in + let a11 = (print_int 4) in + let a10 = (print_int 2) in + let a9 = (print_int 1) in + let a8 = (((((((((_start a9) a10) 3) a11) 100) 1000) a12) 10000) a14) in + (print_int a8) + $ ./anf_runner.exe < manytests/typed/008ascription.ml + let addi f g x = let a2 = (g x) in + ((f x) a2) + + let a0 x b = if b + then ((( + ) x) 1) + else ((( * ) x) 2) + + let a1 _start = let a3 = ((( / ) _start) 2) in + ((( = ) a3) 0) + + let main = let a4 = (((addi a0) a1) 4) in + let () = (print_int a4) in + 0 + + $ ./anf_runner.exe < manytests/typed/009let_poly.ml + let temp = let f = () in + let a1 = (a0 1) in + let a2 = (a0 true) in + (a1, a2) + + $ ./anf_runner.exe < manytests/typed/011mapcps.ml + let a1 f h k a0 = let a5 = (f h) in + let a4 = (a5::a0) in + (k a4) + + let rec map f xs k = let a6 = (is_empty xs) in + if a6 + then let a7 = [] in + (k a7) + else let a9 = (is_empty xs) in + let a8 = (not a9) in + if a8 + then let h = (list_head xs) in + let tl = (list_tail xs) in + let a10 = (((a1 f) h) k) in + (((map f) tl) a10) + else fail_match + + let rec iter f xs = let a11 = (is_empty xs) in + if a11 + then () + else let a13 = (is_empty xs) in + let a12 = (not a13) in + if a12 + then let h = (list_head xs) in + let tl = (list_tail xs) in + let w = (f h) in + ((iter f) tl) + else fail_match + + let a2 x = ((( + ) x) 1) + + let a3 x = x + + let main = let a17 = (3::[]) in + let a16 = (2::a17) in + let a15 = (1::a16) in + let a14 = (((map a2) a15) a3) in + ((iter print_int) a14) + $ ./anf_runner.exe < manytests/typed/012fibcps.ml + let a0 fib k n a = let a4 = ((a1 a) k) in + let a3 = ((( - ) n) 2) in + ((fib a3) a4) + + let rec fib n k = let a5 = ((( < ) n) 2) in + if a5 + then (k n) + else let a7 = (((a0 fib) k) n) in + let a6 = ((( - ) n) 1) in + ((fib a6) a7) + + let a2 x = x + + let main = let a8 = ((fib 6) a2) in + (print_int a8) + $ ./anf_runner.exe < manytests/typed/013foldfoldr.ml + let id x = x + + let rec fold_right f acc xs = let a2 = (is_empty xs) in + if a2 + then acc + else let a4 = (is_empty xs) in + let a3 = (not a4) in + if a3 + then let h = (list_head xs) in + let tl = (list_tail xs) in + let a5 = (((fold_right f) acc) tl) in + ((f h) a5) + else fail_match + + let a0 f b g x = let a6 = ((f x) b) in + (g a6) + + let foldl f a bs = let a7 = (a0 f) in + ((((fold_right a7) id) bs) a) + + let a1 x y = ((( * ) x) y) + + let main = let a11 = (3::[]) in + let a10 = (2::a11) in + let a9 = (1::a10) in + let a8 = (((foldl a1) 1) a9) in + (print_int a8) + + $ ./anf_runner.exe < manytests/typed/015tuples.ml + let rec fix f x = let a3 = (fix f) in + ((f a3) x) + + let map f p = let a = ((tuple_element p) 0) in + let b = ((tuple_element p) 1) in + let a4 = (f a) in + let a5 = (f b) in + (a4, a5) + + let a1 self a0 = let a6 = ((a2 a0) self) in + ((map a6) a0) + + let fixpoly l = ((fix a1) l) + + let feven p n = let e = ((tuple_element p) 0) in + let o = ((tuple_element p) 1) in + let a7 = ((( = ) n) 0) in + if a7 + then 1 + else let a8 = ((( - ) n) 1) in + (o a8) + + let fodd p n = let e = ((tuple_element p) 0) in + let o = ((tuple_element p) 1) in + let a9 = ((( = ) n) 0) in + if a9 + then 0 + else let a10 = ((( - ) n) 1) in + (e a10) + + let tie = let a11 = (feven, fodd) in + (fixpoly a11) + + let rec meven n = let a12 = ((( = ) n) 0) in + if a12 + then 1 + else let a13 = ((( - ) n) 1) in + (modd a13) + and modd n = let a14 = ((( = ) n) 0) in + if a14 + then 1 + else let a15 = ((( - ) n) 1) in + (meven a15) + + let main = let a16 = (modd 1) in + let () = (print_int a16) in + let a17 = (meven 2) in + let () = (print_int a17) in + let even = ((tuple_element tie) 0) in + let odd = ((tuple_element tie) 1) in + let a18 = (odd 3) in + let () = (print_int a18) in + let a19 = (even 4) in + let () = (print_int a19) in + 0 + + $ ./anf_runner.exe < manytests/typed/016lists.ml + let rec length xs = let a4 = (is_empty xs) in + if a4 + then 0 + else let a6 = (is_empty xs) in + let a5 = (not a6) in + if a5 + then let h = (list_head xs) in + let tl = (list_tail xs) in + let a7 = (length tl) in + ((( + ) 1) a7) + else fail_match + + let rec a1 acc xs = let a8 = (is_empty xs) in + if a8 + then acc + else let a10 = (is_empty xs) in + let a9 = (not a10) in + if a9 + then let h = (list_head xs) in + let tl = (list_tail xs) in + let a11 = ((( + ) acc) 1) in + ((a1 a11) tl) + else fail_match + + let length_tail = a1 + + let rec map f xs = let a12 = (is_empty xs) in + if a12 + then [] + else let a17 = (list_tail xs) in + let a16 = (is_empty a17) in + let a15 = (is_empty xs) in + let a14 = (not a15) in + let a13 = ((( && ) a14) a16) in + if a13 + then let a = (list_head xs) in + let a18 = (f a) in + (a18::[]) + else let a24 = (list_tail xs) in + let a23 = (list_tail a24) in + let a22 = (is_empty a23) in + let a21 = (is_empty xs) in + let a20 = (not a21) in + let a19 = ((( && ) a20) a22) in + if a19 + then let a = (list_head xs) in + let a25 = (list_tail xs) in + let b = (list_head a25) in + let a26 = (f a) in + let a28 = (f b) in + let a27 = (a28::[]) in + (a26::a27) + else let a35 = (list_tail xs) in + let a34 = (list_tail a35) in + let a33 = (list_tail a34) in + let a32 = (is_empty a33) in + let a31 = (is_empty xs) in + let a30 = (not a31) in + let a29 = ((( && ) a30) a32) in + if a29 + then let a = (list_head xs) in + let a36 = (list_tail xs) in + let b = (list_head a36) in + let a38 = (list_tail xs) in + let a37 = (list_tail a38) in + let c = (list_head a37) in + let a39 = (f a) in + let a41 = (f b) in + let a43 = (f c) in + let a42 = (a43::[]) in + let a40 = (a41::a42) in + (a39::a40) + else let a45 = (is_empty xs) in + let a44 = (not a45) in + if a44 + then let a = (list_head xs) in + let a46 = (list_tail xs) in + let b = (list_head a46) in + let a48 = (list_tail xs) in + let a47 = (list_tail a48) in + let c = (list_head a47) in + let a51 = (list_tail xs) in + let a50 = (list_tail a51) in + let a49 = (list_tail a50) in + let d = (list_head a49) in + let a54 = (list_tail xs) in + let a53 = (list_tail a54) in + let a52 = (list_tail a53) in + let tl = (list_tail a52) in + let a55 = (f a) in + let a57 = (f b) in + let a59 = (f c) in + let a61 = (f d) in + let a62 = ((map f) tl) in + let a60 = (a61::a62) in + let a58 = (a59::a60) in + let a56 = (a57::a58) in + (a55::a56) + else fail_match + + let rec append xs ys = let a63 = (is_empty xs) in + if a63 + then ys + else let a65 = (is_empty xs) in + let a64 = (not a65) in + if a64 + then let x = (list_head xs) in + let a0 = (list_tail xs) in + let a66 = ((append a0) ys) in + (x::a66) + else fail_match + + let rec a2 xs = let a67 = (is_empty xs) in + if a67 + then [] + else let a69 = (is_empty xs) in + let a68 = (not a69) in + if a68 + then let h = (list_head xs) in + let tl = (list_tail xs) in + let a70 = (a2 tl) in + ((append h) a70) + else fail_match + + let concat = a2 + + let rec iter f xs = let a71 = (is_empty xs) in + if a71 + then () + else let a73 = (is_empty xs) in + let a72 = (not a73) in + if a72 + then let h = (list_head xs) in + let tl = (list_tail xs) in + let () = (f h) in + ((iter f) tl) + else fail_match + + let a3 h a = (h, a) + + let rec cartesian xs ys = let a74 = (is_empty xs) in + if a74 + then [] + else let a76 = (is_empty xs) in + let a75 = (not a76) in + if a75 + then let h = (list_head xs) in + let tl = (list_tail xs) in + let a79 = ((cartesian tl) ys) in + let a78 = (a3 h) in + let a77 = ((map a78) ys) in + ((append a77) a79) + else fail_match + + let main = let a82 = (3::[]) in + let a81 = (2::a82) in + let a80 = (1::a81) in + let () = ((iter print_int) a80) in + let a90 = (4::[]) in + let a89 = (3::a90) in + let a88 = (2::a89) in + let a87 = (1::a88) in + let a86 = (2::[]) in + let a85 = (1::a86) in + let a84 = ((cartesian a85) a87) in + let a83 = (length a84) in + let () = (print_int a83) in + 0 + + $ ./anf_runner.exe < manytests/do_not_type/001.ml + Infer error: + $ ./anf_runner.exe < manytests/do_not_type/002if.ml + Infer error: + $ ./anf_runner.exe < manytests/do_not_type/003occurs.ml + Infer error: + + $ ./anf_runner.exe < manytests/do_not_type/004let_poly.ml + Infer error: + + $ ./anf_runner.exe < manytests/do_not_type/015tuples.ml + Infer error: + diff --git a/FML/tests/anf_runner.ml b/FML/tests/anf_runner.ml index fa4b7e8fb..1cd317d16 100644 --- a/FML/tests/anf_runner.ml +++ b/FML/tests/anf_runner.ml @@ -1,11 +1,9 @@ - (** Copyright 2024-2025, Dmitry Pilyuk, Aleksandr Rozhkov *) (** SPDX-License-Identifier: LGPL-2.1 *) open Fml_lib.Parser open Fml_lib.Inferencer -open Fml_lib.Pe_ast open Fml_lib.Pattern_elim open Fml_lib.Alpha_conv open Fml_lib.Lambda_lifting @@ -28,9 +26,8 @@ let () = let bind, cnt, ast = run_pe ast in let bind, cnt, ast = run_alpha_conv bind cnt ast in let ast = run_cc ast in - let bind, cnt, ast = run_ll bind cnt ast in + let bind, cnt, ast = run_ll bind cnt ast in let _, _, ast = run_anf bind cnt ast in Format.printf "%a" pp_anf_structure ast - Format.printf "%a" pp_pe_structure ast | Error message -> Format.printf "%s" message ;; diff --git a/FML/tests/closure_conv_manytest.t b/FML/tests/closure_conv_manytest.t index 1bf0b5cd2..727353364 100644 --- a/FML/tests/closure_conv_manytest.t +++ b/FML/tests/closure_conv_manytest.t @@ -1,3 +1,15 @@ + $ ./closure_conv_runner.exe << EOF + > let fac n = + > let rec fack n k = + > if n<=1 then k 1 + > else fack (n - 1) ((fun k n m -> k (m * n)) k n) + > in + > fack n (fun x -> x) + > EOF + let fac = (fun n -> let rec fack = (fun a0 k -> if ((( <= ) a0) 1) + then (k 1) + else ((fack ((( - ) a0) 1)) (((fun a1 a2 m -> (a1 ((( * ) m) a2))) k) a0))) in + ((fack n) (fun x -> x))) $ ./closure_conv_runner.exe < manytests/typed/001fac.ml let rec fac = (fun n -> if ((( <= ) n) 1) then 1 From 09691c21a4b1c9408e18f210c01b635f12d195df Mon Sep 17 00:00:00 2001 From: RozhkovAleksandr Date: Sun, 9 Mar 2025 18:20:58 +0300 Subject: [PATCH 25/92] fix ll let --- FML/lib/anf/anf_ast.ml | 2 +- FML/lib/anf/lambda_lifting.ml | 10 +++++----- FML/tests/alpha_conv_manytest.t | 12 ++++++++++++ FML/tests/anf_runner.ml | 2 +- FML/tests/lambda_lifting_manytests.t | 9 +++++---- 5 files changed, 24 insertions(+), 11 deletions(-) diff --git a/FML/lib/anf/anf_ast.ml b/FML/lib/anf/anf_ast.ml index ab90b0ed9..10bb6d91f 100644 --- a/FML/lib/anf/anf_ast.ml +++ b/FML/lib/anf/anf_ast.ml @@ -101,4 +101,4 @@ let pp_anf_structure ppf p = then Format.fprintf ppf "%s" (str_item_to_str a) else Format.fprintf ppf "%s\n\n" (str_item_to_str a)) p -;; +;; \ No newline at end of file diff --git a/FML/lib/anf/lambda_lifting.ml b/FML/lib/anf/lambda_lifting.ml index 2e4530df1..b34bb85e6 100644 --- a/FML/lib/anf/lambda_lifting.ml +++ b/FML/lib/anf/lambda_lifting.ml @@ -41,19 +41,19 @@ let rec ll_expr env = function let* fresh_name = fresh >>| get_id in let env = Map.set env ~key:name ~data:fresh_name in let* str1, e1 = ll_inner env e1 in - let* str2, _ = ll_expr env e2 in - return (str1 @ [ Pe_Rec [ fresh_name, e1 ] ] @ str2, Pe_EIdentifier fresh_name) - | Pe_ELet (rec_flag, name, e1, e2) -> + let* str2, e2 = ll_expr env e2 in + return (str1 @ [ Pe_Rec [ fresh_name, e1 ] ] @ str2, e2) +| Pe_ELet (NoRec, name, e1, e2) -> let* str1, e1 = ll_inner env e1 in (match e1 with | Pe_EFun _ -> let* fresh_name = fresh >>| get_id in let bindings = Map.set env ~key:name ~data:fresh_name in let* str2, e2 = ll_expr bindings e2 in - return (str1 @ str2, Pe_ELet (rec_flag, name, e1, e2)) + return (str1 @ [ Pe_Nonrec [ fresh_name, e1 ] ] @ str2, e2) | _ -> let* str2, e2 = ll_expr env e2 in - return (str1 @ str2, Pe_ELet (rec_flag, name, e1, e2))) + return (str1 @ str2, Pe_ELet (NoRec, name, e1, e2))) and ll_inner env = function | Pe_EFun (args, body) -> diff --git a/FML/tests/alpha_conv_manytest.t b/FML/tests/alpha_conv_manytest.t index 4773a61ad..0898818ad 100644 --- a/FML/tests/alpha_conv_manytest.t +++ b/FML/tests/alpha_conv_manytest.t @@ -1,3 +1,15 @@ + $ ./alpha_conv_runner.exe << EOF + > let fac n = + > let rec fack n k = + > if n<=1 then k 1 + > else fack (n - 1) ((fun k n m -> k (m * n)) k n) + > in + > fack n (fun x -> x) + > EOF + let fac = (fun n -> let rec fack = (fun a0 k -> if ((( <= ) a0) 1) + then (k 1) + else ((fack ((( - ) a0) 1)) (((fun a1 a2 m -> (a1 ((( * ) m) a2))) k) a0))) in + ((fack n) (fun x -> x))) $ ./alpha_conv_runner.exe < manytests/typed/001fac.ml let rec fac = (fun n -> if ((( <= ) n) 1) then 1 diff --git a/FML/tests/anf_runner.ml b/FML/tests/anf_runner.ml index 1cd317d16..627ef3802 100644 --- a/FML/tests/anf_runner.ml +++ b/FML/tests/anf_runner.ml @@ -30,4 +30,4 @@ let () = let _, _, ast = run_anf bind cnt ast in Format.printf "%a" pp_anf_structure ast | Error message -> Format.printf "%s" message -;; +;; \ No newline at end of file diff --git a/FML/tests/lambda_lifting_manytests.t b/FML/tests/lambda_lifting_manytests.t index 57958af55..5ad63654d 100644 --- a/FML/tests/lambda_lifting_manytests.t +++ b/FML/tests/lambda_lifting_manytests.t @@ -14,7 +14,7 @@ let a5 = (fun x -> x) - let fac = (fun n -> a3) + let fac = (fun n -> ((a3 n) a5)) $ ./lambda_lifting_runner.exe < manytests/typed/001fac.ml let rec fac = (fun n -> if ((( <= ) n) 1) then 1 @@ -131,8 +131,9 @@ 0 $ ./lambda_lifting_runner.exe < manytests/typed/009let_poly.ml - let temp = let f = (fun x -> x) in - ((a0 1), (a0 true)) + let a0 = (fun x -> x) + + let temp = ((a0 1), (a0 true)) $ ./lambda_lifting_runner.exe < manytests/typed/011mapcps.ml let a1 = (fun f h k a0 -> (k ((f h)::a0))) @@ -245,7 +246,7 @@ ((a1 ((( + ) acc) 1)) tl) else fail_match) - let length_tail = a1 + let length_tail = (a1 0) let rec map = (fun f xs -> if (is_empty xs) then [] From 228ba8028106108af429bbe7f79a4d8531ff5acf Mon Sep 17 00:00:00 2001 From: Dmitry Pilyuk Date: Sun, 9 Mar 2025 20:33:54 +0300 Subject: [PATCH 26/92] Some fixes --- FML/lib/anf/alpha_conv.mli | 6 +- FML/lib/anf/anf.ml | 8 +- FML/lib/anf/anf_ast.ml | 37 +- FML/lib/anf/closure_conv.mli | 2 +- FML/lib/anf/common.ml | 1 - FML/lib/anf/lambda_lifting.ml | 2 +- FML/lib/anf/lambda_lifting.mli | 6 +- FML/lib/anf/pattern_elim.ml | 9 +- FML/lib/anf/pattern_elim.mli | 2 +- FML/lib/anf/pe_ast.ml | 2 +- FML/lib/anf/pe_ast.mli | 2 +- FML/tests/alpha_conv_runner.ml | 2 +- FML/tests/anf_manytests.t | 591 +++++++++++++++-------------- FML/tests/anf_runner.ml | 4 +- FML/tests/closure_conv_runner.ml | 2 +- FML/tests/dune | 2 +- FML/tests/lambda_lifting_runner.ml | 2 +- FML/tests/pe_runner.ml | 2 +- 18 files changed, 331 insertions(+), 351 deletions(-) diff --git a/FML/lib/anf/alpha_conv.mli b/FML/lib/anf/alpha_conv.mli index 0bb404f60..6384603c4 100644 --- a/FML/lib/anf/alpha_conv.mli +++ b/FML/lib/anf/alpha_conv.mli @@ -5,8 +5,4 @@ open Pe_ast open Common -val run_alpha_conv - : bindings - -> int - -> pe_declaration list - -> bindings * int * pe_declaration list +val run_alpha_conv : bindings -> int -> pe_program -> bindings * int * pe_program diff --git a/FML/lib/anf/anf.ml b/FML/lib/anf/anf.ml index 452569947..abab2b188 100644 --- a/FML/lib/anf/anf.ml +++ b/FML/lib/anf/anf.ml @@ -1,3 +1,7 @@ +(** Copyright 2024-2025, Dmitry Pilyuk, Aleksandr Rozhkov *) + +(** SPDX-License-Identifier: LGPL-2.1 *) + open Common open Anf_ast open Pe_ast @@ -88,7 +92,7 @@ and to_exp e = ~f:(fun (name, cexp) acc -> return @@ aexpr_let_in name cexp acc) ;; -let anf_str_item = function +let anf_declaranion = function | Pe_Nonrec decls -> let* bindings = map decls ~f:(fun (name, e) -> @@ -119,7 +123,7 @@ let anf_structure structure = let rec helper = function | [] -> return [] | hd :: tl -> - let* d1 = anf_str_item hd in + let* d1 = anf_declaranion hd in let* d2 = helper tl in return @@ d1 @ d2 in diff --git a/FML/lib/anf/anf_ast.ml b/FML/lib/anf/anf_ast.ml index 10bb6d91f..ac38eef45 100644 --- a/FML/lib/anf/anf_ast.ml +++ b/FML/lib/anf/anf_ast.ml @@ -49,11 +49,7 @@ let rec atom_to_str = function let rec cexp_to_str = function | CImmExpr a -> atom_to_str a - | CEApply (a1, a_list) -> - Base.List.fold_left - ~init:a1 - ~f:(fun acc a -> "(" ^ acc ^ " " ^ atom_to_str a ^ ")") - a_list + | CEApply (a1, a_list) -> String.concat " " (a1 :: List.map atom_to_str a_list) | CEIf (e1, e2, e3) -> Format.sprintf "if %s\nthen %s\nelse %s" @@ -70,35 +66,24 @@ and exp_to_str = function let fun_to_str = function | ALet (name, args, body) -> - Format.sprintf - "%s = %s" - (Base.List.fold args ~init:name ~f:(fun acc arg -> acc ^ " " ^ arg)) - (exp_to_str body) + Format.sprintf "%s = %s" (String.concat " " (name :: args)) (exp_to_str body) ;; -let str_item_to_str = function +let declaration_to_str = function | ADNoRec func_list -> - let fun1 = Base.List.hd_exn func_list in - let tl = Base.List.tl_exn func_list in - Base.List.fold_left - tl - ~init:(Format.sprintf "let %s" (fun_to_str fun1)) - ~f:(fun acc fun1 -> acc ^ "\nand " ^ fun_to_str fun1) + let funs = List.map fun_to_str func_list in + "let " ^ String.concat "\nand " funs | ADREC func_list -> - let fun1 = Base.List.hd_exn func_list in - let tl = Base.List.tl_exn func_list in - Base.List.fold_left - tl - ~init:(Format.sprintf "let rec %s" (fun_to_str fun1)) - ~f:(fun acc fun1 -> acc ^ "\nand " ^ fun_to_str fun1) + let funs = List.map fun_to_str func_list in + "let rec " ^ String.concat "\nand " funs ;; -let pp_anf_structure ppf p = +let pp_anf_program ppf p = let len = List.length p in Base.List.iteri ~f:(fun i a -> if i = len - 1 - then Format.fprintf ppf "%s" (str_item_to_str a) - else Format.fprintf ppf "%s\n\n" (str_item_to_str a)) + then Format.fprintf ppf "%s" (declaration_to_str a) + else Format.fprintf ppf "%s\n\n" (declaration_to_str a)) p -;; \ No newline at end of file +;; diff --git a/FML/lib/anf/closure_conv.mli b/FML/lib/anf/closure_conv.mli index 96644aa60..a2c191313 100644 --- a/FML/lib/anf/closure_conv.mli +++ b/FML/lib/anf/closure_conv.mli @@ -4,4 +4,4 @@ open Pe_ast -val run_cc : pe_declaration list -> pe_declaration list +val run_cc : pe_program -> pe_program diff --git a/FML/lib/anf/common.ml b/FML/lib/anf/common.ml index 132dd4081..4d3fcbf64 100644 --- a/FML/lib/anf/common.ml +++ b/FML/lib/anf/common.ml @@ -35,7 +35,6 @@ let builtins = ; "print_int" ; "list_head" ; "list_tail" - ; "list_len" ; "tuple_element" ; "is_empty" ; "fail_match" diff --git a/FML/lib/anf/lambda_lifting.ml b/FML/lib/anf/lambda_lifting.ml index b34bb85e6..1a71ea41b 100644 --- a/FML/lib/anf/lambda_lifting.ml +++ b/FML/lib/anf/lambda_lifting.ml @@ -43,7 +43,7 @@ let rec ll_expr env = function let* str1, e1 = ll_inner env e1 in let* str2, e2 = ll_expr env e2 in return (str1 @ [ Pe_Rec [ fresh_name, e1 ] ] @ str2, e2) -| Pe_ELet (NoRec, name, e1, e2) -> + | Pe_ELet (NoRec, name, e1, e2) -> let* str1, e1 = ll_inner env e1 in (match e1 with | Pe_EFun _ -> diff --git a/FML/lib/anf/lambda_lifting.mli b/FML/lib/anf/lambda_lifting.mli index 2ea22825b..4aa536a88 100644 --- a/FML/lib/anf/lambda_lifting.mli +++ b/FML/lib/anf/lambda_lifting.mli @@ -5,8 +5,4 @@ open Common open Pe_ast -val run_ll - : bindings - -> int - -> pe_declaration list - -> bindings * int * pe_declaration list +val run_ll : bindings -> int -> pe_program -> bindings * int * pe_program diff --git a/FML/lib/anf/pattern_elim.ml b/FML/lib/anf/pattern_elim.ml index dbac24f60..587f43dd1 100644 --- a/FML/lib/anf/pattern_elim.ml +++ b/FML/lib/anf/pattern_elim.ml @@ -219,7 +219,7 @@ and pe_match to_match = function | _ -> return @@ Pe_EIdentifier "fail_match" ;; -let pe_program = function +let pe_declaration = function | NoRecDecl decl_list -> let* decls = map decl_list ~f:(fun (Ast.DDeclaration (pat, e)) -> @@ -239,16 +239,15 @@ let pe_program = function match pat with | PIdentifier v -> return (v, e) | _ -> return ("()", e)) - (* TODO: более информативное сообщение *) in return (Pe_Rec decls) ;; -let pe_structure program = +let pe_prog program = let rec helper = function | [] -> return [] | hd :: tl -> - let* hd = pe_program hd in + let* hd = pe_declaration hd in let* tl = helper tl in return @@ (hd :: tl) in @@ -307,4 +306,4 @@ let create_bundle structure = Set.filter_map (module Int) idents ~f:make_id ;; -let run_pe structure = run (pe_structure structure) (create_bundle structure) 0 +let run_pe program = run (pe_prog program) (create_bundle program) 0 diff --git a/FML/lib/anf/pattern_elim.mli b/FML/lib/anf/pattern_elim.mli index 40ece0139..bb72d6a97 100644 --- a/FML/lib/anf/pattern_elim.mli +++ b/FML/lib/anf/pattern_elim.mli @@ -6,4 +6,4 @@ open Ast open Pe_ast open Common -val run_pe : declaration list -> bindings * int * pe_declaration list +val run_pe : program -> bindings * int * pe_program diff --git a/FML/lib/anf/pe_ast.ml b/FML/lib/anf/pe_ast.ml index b9b674c82..e3587734f 100644 --- a/FML/lib/anf/pe_ast.ml +++ b/FML/lib/anf/pe_ast.ml @@ -85,7 +85,7 @@ let decl_to_str = function tl) ;; -let pp_pe_structure ppf p = +let pp_pe_program ppf p = let len = List.length p in List.iteri (fun i a -> diff --git a/FML/lib/anf/pe_ast.mli b/FML/lib/anf/pe_ast.mli index e6c32ae72..6ff80376c 100644 --- a/FML/lib/anf/pe_ast.mli +++ b/FML/lib/anf/pe_ast.mli @@ -31,4 +31,4 @@ type pe_program = pe_declaration list val const_to_str : pe_const -> string val expr_to_str : pe_expr -> string val decl_to_str : pe_declaration -> string -val pp_pe_structure : Format.formatter -> pe_declaration list -> unit +val pp_pe_program : Format.formatter -> pe_program -> unit diff --git a/FML/tests/alpha_conv_runner.ml b/FML/tests/alpha_conv_runner.ml index 606dd6783..ae454d99a 100644 --- a/FML/tests/alpha_conv_runner.ml +++ b/FML/tests/alpha_conv_runner.ml @@ -22,6 +22,6 @@ let () = | Ok ast -> let bind, cnt, ast = run_pe ast in let _, _, ast = run_alpha_conv bind cnt ast in - Format.printf "%a" pp_pe_structure ast + Format.printf "%a" pp_pe_program ast | Error message -> Format.printf "%s" message ;; diff --git a/FML/tests/anf_manytests.t b/FML/tests/anf_manytests.t index 8e3eea438..a6190c787 100644 --- a/FML/tests/anf_manytests.t +++ b/FML/tests/anf_manytests.t @@ -6,498 +6,499 @@ > in > fack n (fun x -> x) > EOF - let a4 a1 a2 m = let a6 = ((( * ) m) a2) in - (a1 a6) + let a4 a1 a2 m = let a6 = ( * ) m a2 in + a1 a6 - let rec a3 a0 k = let a7 = ((( <= ) a0) 1) in + let rec a3 a0 k = let a7 = ( <= ) a0 1 in if a7 - then (k 1) - else let a9 = ((a4 k) a0) in - let a8 = ((( - ) a0) 1) in - ((a3 a8) a9) + then k 1 + else let a9 = a4 k a0 in + let a8 = ( - ) a0 1 in + a3 a8 a9 let a5 x = x - let fac n = a3 + let fac n = a3 n a5 $ ./anf_runner.exe < manytests/typed/001fac.ml - let rec fac n = let a0 = ((( <= ) n) 1) in + let rec fac n = let a0 = ( <= ) n 1 in if a0 then 1 - else let a2 = ((( - ) n) 1) in - let a1 = (fac a2) in - ((( * ) n) a1) + else let a2 = ( - ) n 1 in + let a1 = fac a2 in + ( * ) n a1 - let main = let a3 = (fac 4) in - let () = (print_int a3) in + let main = let a3 = fac 4 in + let () = print_int a3 in 0 $ ./anf_runner.exe < manytests/typed/002fac.ml - let a1 k n p = let a3 = ((( * ) p) n) in - (k a3) + let a1 k n p = let a3 = ( * ) p n in + k a3 - let rec fac_cps n k = let a4 = ((( = ) n) 1) in + let rec fac_cps n k = let a4 = ( = ) n 1 in if a4 - then (k 1) - else let a6 = ((a1 k) n) in - let a5 = ((( - ) n) 1) in - ((fac_cps a5) a6) + then k 1 + else let a6 = a1 k n in + let a5 = ( - ) n 1 in + fac_cps a5 a6 let a2 a0 = a0 - let main = let a7 = ((fac_cps 4) a2) in - let () = (print_int a7) in + let main = let a7 = fac_cps 4 a2 in + let () = print_int a7 in 0 $ ./anf_runner.exe < manytests/typed/003fib.ml - let rec fib_acc a b n = let a0 = ((( = ) n) 1) in + let rec fib_acc a b n = let a0 = ( = ) n 1 in if a0 then b - else let n1 = ((( - ) n) 1) in - let ab = ((( + ) a) b) in - (((fib_acc b) ab) n1) + else let n1 = ( - ) n 1 in + let ab = ( + ) a b in + fib_acc b ab n1 - let rec fib n = let a1 = ((( < ) n) 2) in + let rec fib n = let a1 = ( < ) n 2 in if a1 then n - else let a5 = ((( - ) n) 2) in - let a4 = (fib a5) in - let a3 = ((( - ) n) 1) in - let a2 = (fib a3) in - ((( + ) a2) a4) - - let main = let a6 = (((fib_acc 0) 1) 4) in - let () = (print_int a6) in - let a7 = (fib 4) in - let () = (print_int a7) in + else let a5 = ( - ) n 2 in + let a4 = fib a5 in + let a3 = ( - ) n 1 in + let a2 = fib a3 in + ( + ) a2 a4 + + let main = let a6 = fib_acc 0 1 4 in + let () = print_int a6 in + let a7 = fib 4 in + let () = print_int a7 in 0 $ ./anf_runner.exe < manytests/typed/004manyargs.ml - let wrap f = let a3 = ((( = ) 1) 1) in + let wrap f = let a3 = ( = ) 1 1 in if a3 then f else f - let test3 a b c = let a0 = (print_int a) in - let a1 = (print_int b) in - let a2 = (print_int c) in + let test3 a b c = let a0 = print_int a in + let a1 = print_int b in + let a2 = print_int c in 0 - let test10 a b c d e f g h i j = let a11 = ((( + ) a) b) in - let a10 = ((( + ) a11) c) in - let a9 = ((( + ) a10) d) in - let a8 = ((( + ) a9) e) in - let a7 = ((( + ) a8) f) in - let a6 = ((( + ) a7) g) in - let a5 = ((( + ) a6) h) in - let a4 = ((( + ) a5) i) in - ((( + ) a4) j) - - let main = let rez = (((((((((((wrap test10) 1) 10) 100) 1000) 10000) 100000) 1000000) 10000000) 100000000) 1000000000) in - let () = (print_int rez) in - let temp2 = ((((wrap test3) 1) 10) 100) in + let test10 a b c d e f g h i j = let a11 = ( + ) a b in + let a10 = ( + ) a11 c in + let a9 = ( + ) a10 d in + let a8 = ( + ) a9 e in + let a7 = ( + ) a8 f in + let a6 = ( + ) a7 g in + let a5 = ( + ) a6 h in + let a4 = ( + ) a5 i in + ( + ) a4 j + + let main = let rez = wrap test10 1 10 100 1000 10000 100000 1000000 10000000 100000000 1000000000 in + let () = print_int rez in + let temp2 = wrap test3 1 10 100 in 0 $ ./anf_runner.exe < manytests/typed/005fix.ml - let rec fix f x = let a0 = (fix f) in - ((f a0) x) + let rec fix f x = let a0 = fix f in + f a0 x - let fac self n = let a1 = ((( <= ) n) 1) in + let fac self n = let a1 = ( <= ) n 1 in if a1 then 1 - else let a3 = ((( - ) n) 1) in - let a2 = (self a3) in - ((( * ) n) a2) + else let a3 = ( - ) n 1 in + let a2 = self a3 in + ( * ) n a2 - let main = let a4 = ((fix fac) 6) in - let () = (print_int a4) in + let main = let a4 = fix fac 6 in + let () = print_int a4 in 0 $ ./anf_runner.exe < manytests/typed/006partial.ml - let a3 a0 = ((( + ) a0) 2) + let a3 a0 = ( + ) a0 2 - let a4 a1 = ((( * ) a1) 10) + let a4 a1 = ( * ) a1 10 let foo b = if b then a3 else a4 - let a2 a2 x = let a7 = ((a2 false) x) in - let a6 = ((a2 true) a7) in - let a5 = ((a2 false) a6) in - ((a2 true) a5) + let a2 a2 x = let a7 = a2 false x in + let a6 = a2 true a7 in + let a5 = a2 false a6 in + a2 true a5 - let main = let a8 = (a2 11) in - let () = (print_int a8) in + let main = let a8 = a2 11 in + let () = print_int a8 in 0 $ ./anf_runner.exe < manytests/typed/006partial2.ml - let foo a b c = let () = (print_int a) in - let () = (print_int b) in - let () = (print_int c) in - let a3 = ((( * ) b) c) in - ((( + ) a) a3) - - let main = let a0 = (foo 1) in - let a1 = (a0 2) in - let a2 = (a1 3) in - let () = (print_int a2) in + let foo a b c = let () = print_int a in + let () = print_int b in + let () = print_int c in + let a3 = ( * ) b c in + ( + ) a a3 + + let main = let a0 = foo 1 in + let a1 = a0 2 in + let a2 = a1 3 in + let () = print_int a2 in 0 $ ./anf_runner.exe < manytests/typed/006partial3.ml - let a0 b = let () = (print_int b) in + let a0 b = let () = print_int b in a1 - let foo a = let () = (print_int a) in + let foo a = let () = print_int a in a0 - let main = let () = (((foo 4) 8) 9) in + let main = let () = foo 4 8 9 in 0 $ ./anf_runner.exe < manytests/typed/007order.ml let _start a0 a1 a a2 b _c a3 d __ = let a4 = (a0, a1, a2, a3) in - let a5 = ((( + ) a) b) in - let () = (print_int a5) in - let () = (print_int __) in - let a7 = ((( * ) a) b) in - let a6 = ((( / ) a7) _c) in - ((( + ) a6) d) - - let main = let a14 = (( ~- ) 555555) in - let a13 = (( ~- ) 1) in - let a12 = (print_int a13) in - let a11 = (print_int 4) in - let a10 = (print_int 2) in - let a9 = (print_int 1) in - let a8 = (((((((((_start a9) a10) 3) a11) 100) 1000) a12) 10000) a14) in - (print_int a8) + let a5 = ( + ) a b in + let () = print_int a5 in + let () = print_int __ in + let a7 = ( * ) a b in + let a6 = ( / ) a7 _c in + ( + ) a6 d + + let main = let a14 = ( ~- ) 555555 in + let a13 = ( ~- ) 1 in + let a12 = print_int a13 in + let a11 = print_int 4 in + let a10 = print_int 2 in + let a9 = print_int 1 in + let a8 = _start a9 a10 3 a11 100 1000 a12 10000 a14 in + print_int a8 $ ./anf_runner.exe < manytests/typed/008ascription.ml - let addi f g x = let a2 = (g x) in - ((f x) a2) + let addi f g x = let a2 = g x in + f x a2 let a0 x b = if b - then ((( + ) x) 1) - else ((( * ) x) 2) + then ( + ) x 1 + else ( * ) x 2 - let a1 _start = let a3 = ((( / ) _start) 2) in - ((( = ) a3) 0) + let a1 _start = let a3 = ( / ) _start 2 in + ( = ) a3 0 - let main = let a4 = (((addi a0) a1) 4) in - let () = (print_int a4) in + let main = let a4 = addi a0 a1 4 in + let () = print_int a4 in 0 $ ./anf_runner.exe < manytests/typed/009let_poly.ml - let temp = let f = () in - let a1 = (a0 1) in - let a2 = (a0 true) in + let a0 x = x + + let temp = let a1 = a0 1 in + let a2 = a0 true in (a1, a2) $ ./anf_runner.exe < manytests/typed/011mapcps.ml - let a1 f h k a0 = let a5 = (f h) in + let a1 f h k a0 = let a5 = f h in let a4 = (a5::a0) in - (k a4) + k a4 - let rec map f xs k = let a6 = (is_empty xs) in + let rec map f xs k = let a6 = is_empty xs in if a6 then let a7 = [] in - (k a7) - else let a9 = (is_empty xs) in - let a8 = (not a9) in + k a7 + else let a9 = is_empty xs in + let a8 = not a9 in if a8 - then let h = (list_head xs) in - let tl = (list_tail xs) in - let a10 = (((a1 f) h) k) in - (((map f) tl) a10) + then let h = list_head xs in + let tl = list_tail xs in + let a10 = a1 f h k in + map f tl a10 else fail_match - let rec iter f xs = let a11 = (is_empty xs) in + let rec iter f xs = let a11 = is_empty xs in if a11 then () - else let a13 = (is_empty xs) in - let a12 = (not a13) in + else let a13 = is_empty xs in + let a12 = not a13 in if a12 - then let h = (list_head xs) in - let tl = (list_tail xs) in - let w = (f h) in - ((iter f) tl) + then let h = list_head xs in + let tl = list_tail xs in + let w = f h in + iter f tl else fail_match - let a2 x = ((( + ) x) 1) + let a2 x = ( + ) x 1 let a3 x = x let main = let a17 = (3::[]) in let a16 = (2::a17) in let a15 = (1::a16) in - let a14 = (((map a2) a15) a3) in - ((iter print_int) a14) + let a14 = map a2 a15 a3 in + iter print_int a14 $ ./anf_runner.exe < manytests/typed/012fibcps.ml - let a0 fib k n a = let a4 = ((a1 a) k) in - let a3 = ((( - ) n) 2) in - ((fib a3) a4) + let a0 fib k n a = let a4 = a1 a k in + let a3 = ( - ) n 2 in + fib a3 a4 - let rec fib n k = let a5 = ((( < ) n) 2) in + let rec fib n k = let a5 = ( < ) n 2 in if a5 - then (k n) - else let a7 = (((a0 fib) k) n) in - let a6 = ((( - ) n) 1) in - ((fib a6) a7) + then k n + else let a7 = a0 fib k n in + let a6 = ( - ) n 1 in + fib a6 a7 let a2 x = x - let main = let a8 = ((fib 6) a2) in - (print_int a8) + let main = let a8 = fib 6 a2 in + print_int a8 $ ./anf_runner.exe < manytests/typed/013foldfoldr.ml let id x = x - let rec fold_right f acc xs = let a2 = (is_empty xs) in + let rec fold_right f acc xs = let a2 = is_empty xs in if a2 then acc - else let a4 = (is_empty xs) in - let a3 = (not a4) in + else let a4 = is_empty xs in + let a3 = not a4 in if a3 - then let h = (list_head xs) in - let tl = (list_tail xs) in - let a5 = (((fold_right f) acc) tl) in - ((f h) a5) + then let h = list_head xs in + let tl = list_tail xs in + let a5 = fold_right f acc tl in + f h a5 else fail_match - let a0 f b g x = let a6 = ((f x) b) in - (g a6) + let a0 f b g x = let a6 = f x b in + g a6 - let foldl f a bs = let a7 = (a0 f) in - ((((fold_right a7) id) bs) a) + let foldl f a bs = let a7 = a0 f in + fold_right a7 id bs a - let a1 x y = ((( * ) x) y) + let a1 x y = ( * ) x y let main = let a11 = (3::[]) in let a10 = (2::a11) in let a9 = (1::a10) in - let a8 = (((foldl a1) 1) a9) in - (print_int a8) + let a8 = foldl a1 1 a9 in + print_int a8 $ ./anf_runner.exe < manytests/typed/015tuples.ml - let rec fix f x = let a3 = (fix f) in - ((f a3) x) + let rec fix f x = let a3 = fix f in + f a3 x - let map f p = let a = ((tuple_element p) 0) in - let b = ((tuple_element p) 1) in - let a4 = (f a) in - let a5 = (f b) in + let map f p = let a = tuple_element p 0 in + let b = tuple_element p 1 in + let a4 = f a in + let a5 = f b in (a4, a5) - let a1 self a0 = let a6 = ((a2 a0) self) in - ((map a6) a0) + let a1 self a0 = let a6 = a2 a0 self in + map a6 a0 - let fixpoly l = ((fix a1) l) + let fixpoly l = fix a1 l - let feven p n = let e = ((tuple_element p) 0) in - let o = ((tuple_element p) 1) in - let a7 = ((( = ) n) 0) in + let feven p n = let e = tuple_element p 0 in + let o = tuple_element p 1 in + let a7 = ( = ) n 0 in if a7 then 1 - else let a8 = ((( - ) n) 1) in - (o a8) + else let a8 = ( - ) n 1 in + o a8 - let fodd p n = let e = ((tuple_element p) 0) in - let o = ((tuple_element p) 1) in - let a9 = ((( = ) n) 0) in + let fodd p n = let e = tuple_element p 0 in + let o = tuple_element p 1 in + let a9 = ( = ) n 0 in if a9 then 0 - else let a10 = ((( - ) n) 1) in - (e a10) + else let a10 = ( - ) n 1 in + e a10 let tie = let a11 = (feven, fodd) in - (fixpoly a11) + fixpoly a11 - let rec meven n = let a12 = ((( = ) n) 0) in + let rec meven n = let a12 = ( = ) n 0 in if a12 then 1 - else let a13 = ((( - ) n) 1) in - (modd a13) - and modd n = let a14 = ((( = ) n) 0) in + else let a13 = ( - ) n 1 in + modd a13 + and modd n = let a14 = ( = ) n 0 in if a14 then 1 - else let a15 = ((( - ) n) 1) in - (meven a15) - - let main = let a16 = (modd 1) in - let () = (print_int a16) in - let a17 = (meven 2) in - let () = (print_int a17) in - let even = ((tuple_element tie) 0) in - let odd = ((tuple_element tie) 1) in - let a18 = (odd 3) in - let () = (print_int a18) in - let a19 = (even 4) in - let () = (print_int a19) in + else let a15 = ( - ) n 1 in + meven a15 + + let main = let a16 = modd 1 in + let () = print_int a16 in + let a17 = meven 2 in + let () = print_int a17 in + let even = tuple_element tie 0 in + let odd = tuple_element tie 1 in + let a18 = odd 3 in + let () = print_int a18 in + let a19 = even 4 in + let () = print_int a19 in 0 $ ./anf_runner.exe < manytests/typed/016lists.ml - let rec length xs = let a4 = (is_empty xs) in + let rec length xs = let a4 = is_empty xs in if a4 then 0 - else let a6 = (is_empty xs) in - let a5 = (not a6) in + else let a6 = is_empty xs in + let a5 = not a6 in if a5 - then let h = (list_head xs) in - let tl = (list_tail xs) in - let a7 = (length tl) in - ((( + ) 1) a7) + then let h = list_head xs in + let tl = list_tail xs in + let a7 = length tl in + ( + ) 1 a7 else fail_match - let rec a1 acc xs = let a8 = (is_empty xs) in + let rec a1 acc xs = let a8 = is_empty xs in if a8 then acc - else let a10 = (is_empty xs) in - let a9 = (not a10) in + else let a10 = is_empty xs in + let a9 = not a10 in if a9 - then let h = (list_head xs) in - let tl = (list_tail xs) in - let a11 = ((( + ) acc) 1) in - ((a1 a11) tl) + then let h = list_head xs in + let tl = list_tail xs in + let a11 = ( + ) acc 1 in + a1 a11 tl else fail_match - let length_tail = a1 + let length_tail = a1 0 - let rec map f xs = let a12 = (is_empty xs) in + let rec map f xs = let a12 = is_empty xs in if a12 then [] - else let a17 = (list_tail xs) in - let a16 = (is_empty a17) in - let a15 = (is_empty xs) in - let a14 = (not a15) in - let a13 = ((( && ) a14) a16) in + else let a17 = list_tail xs in + let a16 = is_empty a17 in + let a15 = is_empty xs in + let a14 = not a15 in + let a13 = ( && ) a14 a16 in if a13 - then let a = (list_head xs) in - let a18 = (f a) in + then let a = list_head xs in + let a18 = f a in (a18::[]) - else let a24 = (list_tail xs) in - let a23 = (list_tail a24) in - let a22 = (is_empty a23) in - let a21 = (is_empty xs) in - let a20 = (not a21) in - let a19 = ((( && ) a20) a22) in + else let a24 = list_tail xs in + let a23 = list_tail a24 in + let a22 = is_empty a23 in + let a21 = is_empty xs in + let a20 = not a21 in + let a19 = ( && ) a20 a22 in if a19 - then let a = (list_head xs) in - let a25 = (list_tail xs) in - let b = (list_head a25) in - let a26 = (f a) in - let a28 = (f b) in + then let a = list_head xs in + let a25 = list_tail xs in + let b = list_head a25 in + let a26 = f a in + let a28 = f b in let a27 = (a28::[]) in (a26::a27) - else let a35 = (list_tail xs) in - let a34 = (list_tail a35) in - let a33 = (list_tail a34) in - let a32 = (is_empty a33) in - let a31 = (is_empty xs) in - let a30 = (not a31) in - let a29 = ((( && ) a30) a32) in + else let a35 = list_tail xs in + let a34 = list_tail a35 in + let a33 = list_tail a34 in + let a32 = is_empty a33 in + let a31 = is_empty xs in + let a30 = not a31 in + let a29 = ( && ) a30 a32 in if a29 - then let a = (list_head xs) in - let a36 = (list_tail xs) in - let b = (list_head a36) in - let a38 = (list_tail xs) in - let a37 = (list_tail a38) in - let c = (list_head a37) in - let a39 = (f a) in - let a41 = (f b) in - let a43 = (f c) in + then let a = list_head xs in + let a36 = list_tail xs in + let b = list_head a36 in + let a38 = list_tail xs in + let a37 = list_tail a38 in + let c = list_head a37 in + let a39 = f a in + let a41 = f b in + let a43 = f c in let a42 = (a43::[]) in let a40 = (a41::a42) in (a39::a40) - else let a45 = (is_empty xs) in - let a44 = (not a45) in + else let a45 = is_empty xs in + let a44 = not a45 in if a44 - then let a = (list_head xs) in - let a46 = (list_tail xs) in - let b = (list_head a46) in - let a48 = (list_tail xs) in - let a47 = (list_tail a48) in - let c = (list_head a47) in - let a51 = (list_tail xs) in - let a50 = (list_tail a51) in - let a49 = (list_tail a50) in - let d = (list_head a49) in - let a54 = (list_tail xs) in - let a53 = (list_tail a54) in - let a52 = (list_tail a53) in - let tl = (list_tail a52) in - let a55 = (f a) in - let a57 = (f b) in - let a59 = (f c) in - let a61 = (f d) in - let a62 = ((map f) tl) in + then let a = list_head xs in + let a46 = list_tail xs in + let b = list_head a46 in + let a48 = list_tail xs in + let a47 = list_tail a48 in + let c = list_head a47 in + let a51 = list_tail xs in + let a50 = list_tail a51 in + let a49 = list_tail a50 in + let d = list_head a49 in + let a54 = list_tail xs in + let a53 = list_tail a54 in + let a52 = list_tail a53 in + let tl = list_tail a52 in + let a55 = f a in + let a57 = f b in + let a59 = f c in + let a61 = f d in + let a62 = map f tl in let a60 = (a61::a62) in let a58 = (a59::a60) in let a56 = (a57::a58) in (a55::a56) else fail_match - let rec append xs ys = let a63 = (is_empty xs) in + let rec append xs ys = let a63 = is_empty xs in if a63 then ys - else let a65 = (is_empty xs) in - let a64 = (not a65) in + else let a65 = is_empty xs in + let a64 = not a65 in if a64 - then let x = (list_head xs) in - let a0 = (list_tail xs) in - let a66 = ((append a0) ys) in + then let x = list_head xs in + let a0 = list_tail xs in + let a66 = append a0 ys in (x::a66) else fail_match - let rec a2 xs = let a67 = (is_empty xs) in + let rec a2 xs = let a67 = is_empty xs in if a67 then [] - else let a69 = (is_empty xs) in - let a68 = (not a69) in + else let a69 = is_empty xs in + let a68 = not a69 in if a68 - then let h = (list_head xs) in - let tl = (list_tail xs) in - let a70 = (a2 tl) in - ((append h) a70) + then let h = list_head xs in + let tl = list_tail xs in + let a70 = a2 tl in + append h a70 else fail_match let concat = a2 - let rec iter f xs = let a71 = (is_empty xs) in + let rec iter f xs = let a71 = is_empty xs in if a71 then () - else let a73 = (is_empty xs) in - let a72 = (not a73) in + else let a73 = is_empty xs in + let a72 = not a73 in if a72 - then let h = (list_head xs) in - let tl = (list_tail xs) in - let () = (f h) in - ((iter f) tl) + then let h = list_head xs in + let tl = list_tail xs in + let () = f h in + iter f tl else fail_match let a3 h a = (h, a) - let rec cartesian xs ys = let a74 = (is_empty xs) in + let rec cartesian xs ys = let a74 = is_empty xs in if a74 then [] - else let a76 = (is_empty xs) in - let a75 = (not a76) in + else let a76 = is_empty xs in + let a75 = not a76 in if a75 - then let h = (list_head xs) in - let tl = (list_tail xs) in - let a79 = ((cartesian tl) ys) in - let a78 = (a3 h) in - let a77 = ((map a78) ys) in - ((append a77) a79) + then let h = list_head xs in + let tl = list_tail xs in + let a79 = cartesian tl ys in + let a78 = a3 h in + let a77 = map a78 ys in + append a77 a79 else fail_match let main = let a82 = (3::[]) in let a81 = (2::a82) in let a80 = (1::a81) in - let () = ((iter print_int) a80) in + let () = iter print_int a80 in let a90 = (4::[]) in let a89 = (3::a90) in let a88 = (2::a89) in let a87 = (1::a88) in let a86 = (2::[]) in let a85 = (1::a86) in - let a84 = ((cartesian a85) a87) in - let a83 = (length a84) in - let () = (print_int a83) in + let a84 = cartesian a85 a87 in + let a83 = length a84 in + let () = print_int a83 in 0 $ ./anf_runner.exe < manytests/do_not_type/001.ml diff --git a/FML/tests/anf_runner.ml b/FML/tests/anf_runner.ml index 627ef3802..f0c983896 100644 --- a/FML/tests/anf_runner.ml +++ b/FML/tests/anf_runner.ml @@ -28,6 +28,6 @@ let () = let ast = run_cc ast in let bind, cnt, ast = run_ll bind cnt ast in let _, _, ast = run_anf bind cnt ast in - Format.printf "%a" pp_anf_structure ast + Format.printf "%a" pp_anf_program ast | Error message -> Format.printf "%s" message -;; \ No newline at end of file +;; diff --git a/FML/tests/closure_conv_runner.ml b/FML/tests/closure_conv_runner.ml index 56e7c1396..c38de4987 100644 --- a/FML/tests/closure_conv_runner.ml +++ b/FML/tests/closure_conv_runner.ml @@ -24,6 +24,6 @@ let () = let bind, cnt, ast = run_pe ast in let _, _, ast = run_alpha_conv bind cnt ast in let ast = run_cc ast in - Format.printf "%a" pp_pe_structure ast + Format.printf "%a" pp_pe_program ast | Error message -> Format.printf "%s" message ;; diff --git a/FML/tests/dune b/FML/tests/dune index 831095135..51e02550a 100644 --- a/FML/tests/dune +++ b/FML/tests/dune @@ -230,4 +230,4 @@ manytests/typed/012fibcps.ml manytests/typed/013foldfoldr.ml manytests/typed/015tuples.ml - manytests/typed/016lists.ml)) \ No newline at end of file + manytests/typed/016lists.ml)) diff --git a/FML/tests/lambda_lifting_runner.ml b/FML/tests/lambda_lifting_runner.ml index a580f1945..f1ed8fe27 100644 --- a/FML/tests/lambda_lifting_runner.ml +++ b/FML/tests/lambda_lifting_runner.ml @@ -26,6 +26,6 @@ let () = let bind, cnt, ast = run_alpha_conv bind cnt ast in let ast = run_cc ast in let _, _, ast = run_ll bind cnt ast in - Format.printf "%a" pp_pe_structure ast + Format.printf "%a" pp_pe_program ast | Error message -> Format.printf "%s" message ;; diff --git a/FML/tests/pe_runner.ml b/FML/tests/pe_runner.ml index 030e7de20..2c78a8146 100644 --- a/FML/tests/pe_runner.ml +++ b/FML/tests/pe_runner.ml @@ -20,6 +20,6 @@ let () = match parse_and_infer input with | Ok ast -> let _, _, converted = run_pe ast in - Format.printf "%a" pp_pe_structure converted + Format.printf "%a" pp_pe_program converted | Error message -> Format.printf "%s" message ;; From 15a8d8c8bffbe0c8217b83c15bf6976caefe5962 Mon Sep 17 00:00:00 2001 From: Dmitry Pilyuk Date: Mon, 10 Mar 2025 22:54:53 +0300 Subject: [PATCH 27/92] Fix alpha convertion --- FML/lib/anf/alpha_conv.ml | 26 +++++++++----------------- FML/tests/alpha_conv_manytest.t | 8 ++++---- FML/tests/anf_manytests.t | 20 ++++++++++---------- FML/tests/closure_conv_manytest.t | 8 ++++---- FML/tests/lambda_lifting_manytests.t | 12 ++++++------ 5 files changed, 33 insertions(+), 41 deletions(-) diff --git a/FML/lib/anf/alpha_conv.ml b/FML/lib/anf/alpha_conv.ml index f7b720064..2a38ebf79 100644 --- a/FML/lib/anf/alpha_conv.ml +++ b/FML/lib/anf/alpha_conv.ml @@ -63,25 +63,17 @@ and rename env binds name = let ac_declaration env bindings = function | Pe_Nonrec bindings_list -> - let ids, exps = List.unzip bindings_list in - let* ids, env, bindings = - fold_left - ids + let* decls, env, bindings = + List.fold_left + bindings_list ~init:(return ([], env, bindings)) - ~f:(fun (ids, env, bindings) id -> - let* env, bindings, id = rename env bindings id in - return (id :: ids, env, bindings)) - in - let ids = List.rev ids in - let exps = List.map exps ~f:(ac_expr env bindings) in - let* bindings_list = - List.fold2_exn ids exps ~init:(return []) ~f:(fun acc name expr -> - let* acc = acc in - let* expr = expr in - return ((name, expr) :: acc)) + ~f:(fun acc (name, expr) -> + let* acc_decls, acc_env, acc_bindings = acc in + let* new_env, new_bindings, new_name = rename acc_env acc_bindings name in + let* e = ac_expr env bindings expr in + return ((new_name, e) :: acc_decls, new_env, new_bindings)) in - let bindings_list = List.rev bindings_list in - return (env, bindings, Pe_Nonrec bindings_list) + return (env, bindings, Pe_Nonrec (List.rev decls)) | Pe_Rec bindings_list -> let ids, exps = List.unzip bindings_list in let* ids, env, bindings = diff --git a/FML/tests/alpha_conv_manytest.t b/FML/tests/alpha_conv_manytest.t index 0898818ad..294cffa24 100644 --- a/FML/tests/alpha_conv_manytest.t +++ b/FML/tests/alpha_conv_manytest.t @@ -70,12 +70,12 @@ $ ./alpha_conv_runner.exe < manytests/typed/006partial.ml let foo = (fun b -> if b - then (fun a0 -> ((( + ) a0) 2)) - else (fun a1 -> ((( * ) a1) 10))) + then (fun foo -> ((( + ) foo) 2)) + else (fun foo -> ((( * ) foo) 10))) - let a2 = (fun x -> ((a2 true) ((a2 false) ((a2 true) ((a2 false) x))))) + let a0 = (fun x -> ((foo true) ((foo false) ((foo true) ((foo false) x))))) - let main = let () = (print_int (a2 11)) in + let main = let () = (print_int (a0 11)) in 0 $ ./alpha_conv_runner.exe < manytests/typed/006partial2.ml diff --git a/FML/tests/anf_manytests.t b/FML/tests/anf_manytests.t index a6190c787..339296633 100644 --- a/FML/tests/anf_manytests.t +++ b/FML/tests/anf_manytests.t @@ -113,21 +113,21 @@ 0 $ ./anf_runner.exe < manytests/typed/006partial.ml - let a3 a0 = ( + ) a0 2 + let a1 foo = ( + ) foo 2 - let a4 a1 = ( * ) a1 10 + let a2 foo = ( * ) foo 10 let foo b = if b - then a3 - else a4 + then a1 + else a2 - let a2 a2 x = let a7 = a2 false x in - let a6 = a2 true a7 in - let a5 = a2 false a6 in - a2 true a5 + let a0 x = let a5 = foo false x in + let a4 = foo true a5 in + let a3 = foo false a4 in + foo true a3 - let main = let a8 = a2 11 in - let () = print_int a8 in + let main = let a6 = a0 11 in + let () = print_int a6 in 0 $ ./anf_runner.exe < manytests/typed/006partial2.ml diff --git a/FML/tests/closure_conv_manytest.t b/FML/tests/closure_conv_manytest.t index 727353364..9f91dd0d9 100644 --- a/FML/tests/closure_conv_manytest.t +++ b/FML/tests/closure_conv_manytest.t @@ -70,12 +70,12 @@ $ ./closure_conv_runner.exe < manytests/typed/006partial.ml let foo = (fun b -> if b - then (fun a0 -> ((( + ) a0) 2)) - else (fun a1 -> ((( * ) a1) 10))) + then (fun foo -> ((( + ) foo) 2)) + else (fun foo -> ((( * ) foo) 10))) - let a2 = (fun a2 x -> ((a2 true) ((a2 false) ((a2 true) ((a2 false) x))))) + let a0 = (fun x -> ((foo true) ((foo false) ((foo true) ((foo false) x))))) - let main = let () = (print_int (a2 11)) in + let main = let () = (print_int (a0 11)) in 0 $ ./closure_conv_runner.exe < manytests/typed/006partial2.ml diff --git a/FML/tests/lambda_lifting_manytests.t b/FML/tests/lambda_lifting_manytests.t index 5ad63654d..40071e37b 100644 --- a/FML/tests/lambda_lifting_manytests.t +++ b/FML/tests/lambda_lifting_manytests.t @@ -78,17 +78,17 @@ 0 $ ./lambda_lifting_runner.exe < manytests/typed/006partial.ml - let a3 = (fun a0 -> ((( + ) a0) 2)) + let a1 = (fun foo -> ((( + ) foo) 2)) - let a4 = (fun a1 -> ((( * ) a1) 10)) + let a2 = (fun foo -> ((( * ) foo) 10)) let foo = (fun b -> if b - then a3 - else a4) + then a1 + else a2) - let a2 = (fun a2 x -> ((a2 true) ((a2 false) ((a2 true) ((a2 false) x))))) + let a0 = (fun x -> ((foo true) ((foo false) ((foo true) ((foo false) x))))) - let main = let () = (print_int (a2 11)) in + let main = let () = (print_int (a0 11)) in 0 $ ./lambda_lifting_runner.exe < manytests/typed/006partial2.ml From 08ff5a53f064739b5c120fb8d74aa5393ddfeeb4 Mon Sep 17 00:00:00 2001 From: Dmitry Pilyuk Date: Mon, 10 Mar 2025 23:59:39 +0300 Subject: [PATCH 28/92] Improve anf runner --- FML/tests/anf_runner.ml | 12 +++++++++--- 1 file changed, 9 insertions(+), 3 deletions(-) diff --git a/FML/tests/anf_runner.ml b/FML/tests/anf_runner.ml index f0c983896..87bac0bf8 100644 --- a/FML/tests/anf_runner.ml +++ b/FML/tests/anf_runner.ml @@ -4,6 +4,7 @@ open Fml_lib.Parser open Fml_lib.Inferencer +open Fml_lib.Inf_pprint open Fml_lib.Pattern_elim open Fml_lib.Alpha_conv open Fml_lib.Lambda_lifting @@ -17,17 +18,22 @@ let () = match parse input with | Ok parsed -> (match run_program_inferencer parsed with - | Ok _ -> Ok parsed + | Ok types -> Ok (parsed, types) | Error _ -> Error (Format.asprintf "Infer error:")) | Error e -> Error (Format.sprintf "Parsing error: %s" e) in match parse_and_infer input with - | Ok ast -> + | Ok (ast, _) -> let bind, cnt, ast = run_pe ast in let bind, cnt, ast = run_alpha_conv bind cnt ast in let ast = run_cc ast in let bind, cnt, ast = run_ll bind cnt ast in let _, _, ast = run_anf bind cnt ast in - Format.printf "%a" pp_anf_program ast + let result = Format.asprintf "%a" pp_anf_program ast in + let () = Format.printf "%a" pp_anf_program ast in + let () = Format.printf "\nТипы после приведения в ANF:\n" in + (match parse_and_infer result with + | Ok (_, (env, names_list)) -> print_program_type env names_list + | Error e -> Format.printf "%s" e) | Error message -> Format.printf "%s" message ;; From 6961314002fa62a00787eb48b86fcd8ba1c4db40 Mon Sep 17 00:00:00 2001 From: Dmitry Pilyuk Date: Tue, 11 Mar 2025 02:35:06 +0300 Subject: [PATCH 29/92] Fix LL --- FML/lib/anf/lambda_lifting.ml | 4 +- FML/tests/anf_manytests.t | 327 +++++++++------------------ FML/tests/anf_runner.ml | 2 +- FML/tests/lambda_lifting_manytests.t | 6 + 4 files changed, 116 insertions(+), 223 deletions(-) diff --git a/FML/lib/anf/lambda_lifting.ml b/FML/lib/anf/lambda_lifting.ml index 1a71ea41b..95096c9d8 100644 --- a/FML/lib/anf/lambda_lifting.ml +++ b/FML/lib/anf/lambda_lifting.ml @@ -27,8 +27,8 @@ let rec ll_expr env = function | Pe_EFun (args, body) -> let* fresh = fresh >>| get_id in let new_env = List.fold args ~init:env ~f:Map.remove in - let* _, body = ll_expr new_env body in - return ([ Pe_Nonrec [ fresh, Pe_EFun (args, body) ] ], Pe_EIdentifier fresh) + let* str, body = ll_expr new_env body in + return (str @ [ Pe_Nonrec [ fresh, Pe_EFun (args, body) ] ], Pe_EIdentifier fresh) | Pe_ECons (e1, e2) -> let* str1, e1 = ll_expr env e1 in let* str2, e2 = ll_expr env e2 in diff --git a/FML/tests/anf_manytests.t b/FML/tests/anf_manytests.t index 339296633..08e546bdf 100644 --- a/FML/tests/anf_manytests.t +++ b/FML/tests/anf_manytests.t @@ -19,6 +19,11 @@ let a5 x = x let fac n = a3 n a5 + Типы после приведения в ANF: + val a4 : (int -> 'a) -> int -> int -> 'a + val a3 : int -> (int -> 'a) -> 'a + val a5 : 'a -> 'a + val fac : int -> int $ ./anf_runner.exe < manytests/typed/001fac.ml let rec fac n = let a0 = ( <= ) n 1 in if a0 @@ -30,6 +35,9 @@ let main = let a3 = fac 4 in let () = print_int a3 in 0 + Типы после приведения в ANF: + val fac : int -> int + val main : int $ ./anf_runner.exe < manytests/typed/002fac.ml let a1 k n p = let a3 = ( * ) p n in @@ -47,6 +55,11 @@ let main = let a7 = fac_cps 4 a2 in let () = print_int a7 in 0 + Типы после приведения в ANF: + val a1 : (int -> 'a) -> int -> int -> 'a + val fac_cps : int -> (int -> 'a) -> 'a + val a2 : 'a -> 'a + val main : int $ ./anf_runner.exe < manytests/typed/003fib.ml let rec fib_acc a b n = let a0 = ( = ) n 1 in @@ -70,6 +83,10 @@ let a7 = fib 4 in let () = print_int a7 in 0 + Типы после приведения в ANF: + val fib_acc : int -> int -> int -> int + val fib : int -> int + val main : int $ ./anf_runner.exe < manytests/typed/004manyargs.ml let wrap f = let a3 = ( = ) 1 1 in @@ -96,6 +113,11 @@ let () = print_int rez in let temp2 = wrap test3 1 10 100 in 0 + Типы после приведения в ANF: + val wrap : 'a -> 'a + val test3 : int -> int -> int -> int + val test10 : int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int + val main : int $ ./anf_runner.exe < manytests/typed/005fix.ml let rec fix f x = let a0 = fix f in @@ -111,6 +133,10 @@ let main = let a4 = fix fac 6 in let () = print_int a4 in 0 + Типы после приведения в ANF: + val fix : (('a -> 'b) -> 'a -> 'b) -> 'a -> 'b + val fac : (int -> int) -> int -> int + val main : int $ ./anf_runner.exe < manytests/typed/006partial.ml let a1 foo = ( + ) foo 2 @@ -129,6 +155,12 @@ let main = let a6 = a0 11 in let () = print_int a6 in 0 + Типы после приведения в ANF: + val a1 : int -> int + val a2 : int -> int + val foo : bool -> int -> int + val a0 : int -> int + val main : int $ ./anf_runner.exe < manytests/typed/006partial2.ml let foo a b c = let () = print_int a in @@ -142,7 +174,12 @@ let a2 = a1 3 in let () = print_int a2 in 0 + Типы после приведения в ANF: + val foo : int -> int -> int -> int + val main : int $ ./anf_runner.exe < manytests/typed/006partial3.ml + let a1 c = print_int c + let a0 b = let () = print_int b in a1 @@ -151,6 +188,11 @@ let main = let () = foo 4 8 9 in 0 + Типы после приведения в ANF: + val a1 : int -> unit + val a0 : int -> int -> unit + val foo : int -> int -> int -> unit + val main : int $ ./anf_runner.exe < manytests/typed/007order.ml let _start a0 a1 a a2 b _c a3 d __ = let a4 = (a0, a1, a2, a3) in let a5 = ( + ) a b in @@ -168,6 +210,9 @@ let a9 = print_int 1 in let a8 = _start a9 a10 3 a11 100 1000 a12 10000 a14 in print_int a8 + Типы после приведения в ANF: + val _start : 'a -> 'b -> int -> 'c -> int -> int -> 'd -> int -> int -> int + val main : unit $ ./anf_runner.exe < manytests/typed/008ascription.ml let addi f g x = let a2 = g x in f x a2 @@ -182,6 +227,11 @@ let main = let a4 = addi a0 a1 4 in let () = print_int a4 in 0 + Типы после приведения в ANF: + val addi : ('a -> 'b -> 'c) -> ('a -> 'b) -> 'a -> 'c + val a0 : int -> bool -> int + val a1 : int -> bool + val main : int $ ./anf_runner.exe < manytests/typed/009let_poly.ml let a0 x = x @@ -189,6 +239,9 @@ let temp = let a1 = a0 1 in let a2 = a0 true in (a1, a2) + Типы после приведения в ANF: + val a0 : 'a -> 'a + val temp : int * bool $ ./anf_runner.exe < manytests/typed/011mapcps.ml let a1 f h k a0 = let a5 = f h in @@ -229,22 +282,33 @@ let a15 = (1::a16) in let a14 = map a2 a15 a3 in iter print_int a14 + Типы после приведения в ANF: + Infer error. $ ./anf_runner.exe < manytests/typed/012fibcps.ml - let a0 fib k n a = let a4 = a1 a k in - let a3 = ( - ) n 2 in - fib a3 a4 + let a1 a k b = let a3 = ( + ) a b in + k a3 - let rec fib n k = let a5 = ( < ) n 2 in - if a5 + let a0 fib k n a = let a5 = a1 a k in + let a4 = ( - ) n 2 in + fib a4 a5 + + let rec fib n k = let a6 = ( < ) n 2 in + if a6 then k n - else let a7 = a0 fib k n in - let a6 = ( - ) n 1 in - fib a6 a7 + else let a8 = a0 fib k n in + let a7 = ( - ) n 1 in + fib a7 a8 let a2 x = x - let main = let a8 = fib 6 a2 in - print_int a8 + let main = let a9 = fib 6 a2 in + print_int a9 + Типы после приведения в ANF: + val a1 : int -> (int -> 'a) -> int -> 'a + val a0 : (int -> (int -> 'a) -> 'b) -> (int -> 'a) -> int -> int -> 'b + val fib : int -> (int -> 'a) -> 'a + val a2 : 'a -> 'a + val main : unit $ ./anf_runner.exe < manytests/typed/013foldfoldr.ml let id x = x @@ -273,6 +337,8 @@ let a9 = (1::a10) in let a8 = foldl a1 1 a9 in print_int a8 + Типы после приведения в ANF: + Infer error. $ ./anf_runner.exe < manytests/typed/015tuples.ml let rec fix f x = let a3 = fix f in @@ -284,233 +350,54 @@ let a5 = f b in (a4, a5) - let a1 self a0 = let a6 = a2 a0 self in - map a6 a0 + let a2 a0 self li x = let a6 = self a0 in + li a6 x + + let a1 self a0 = let a7 = a2 a0 self in + map a7 a0 let fixpoly l = fix a1 l let feven p n = let e = tuple_element p 0 in let o = tuple_element p 1 in - let a7 = ( = ) n 0 in - if a7 + let a8 = ( = ) n 0 in + if a8 then 1 - else let a8 = ( - ) n 1 in - o a8 + else let a9 = ( - ) n 1 in + o a9 let fodd p n = let e = tuple_element p 0 in let o = tuple_element p 1 in - let a9 = ( = ) n 0 in - if a9 + let a10 = ( = ) n 0 in + if a10 then 0 - else let a10 = ( - ) n 1 in - e a10 + else let a11 = ( - ) n 1 in + e a11 - let tie = let a11 = (feven, fodd) in - fixpoly a11 + let tie = let a12 = (feven, fodd) in + fixpoly a12 - let rec meven n = let a12 = ( = ) n 0 in - if a12 + let rec meven n = let a13 = ( = ) n 0 in + if a13 then 1 - else let a13 = ( - ) n 1 in - modd a13 - and modd n = let a14 = ( = ) n 0 in - if a14 + else let a14 = ( - ) n 1 in + modd a14 + and modd n = let a15 = ( = ) n 0 in + if a15 then 1 - else let a15 = ( - ) n 1 in - meven a15 + else let a16 = ( - ) n 1 in + meven a16 - let main = let a16 = modd 1 in - let () = print_int a16 in - let a17 = meven 2 in + let main = let a17 = modd 1 in let () = print_int a17 in + let a18 = meven 2 in + let () = print_int a18 in let even = tuple_element tie 0 in let odd = tuple_element tie 1 in - let a18 = odd 3 in - let () = print_int a18 in - let a19 = even 4 in + let a19 = odd 3 in let () = print_int a19 in + let a20 = even 4 in + let () = print_int a20 in 0 - - $ ./anf_runner.exe < manytests/typed/016lists.ml - let rec length xs = let a4 = is_empty xs in - if a4 - then 0 - else let a6 = is_empty xs in - let a5 = not a6 in - if a5 - then let h = list_head xs in - let tl = list_tail xs in - let a7 = length tl in - ( + ) 1 a7 - else fail_match - - let rec a1 acc xs = let a8 = is_empty xs in - if a8 - then acc - else let a10 = is_empty xs in - let a9 = not a10 in - if a9 - then let h = list_head xs in - let tl = list_tail xs in - let a11 = ( + ) acc 1 in - a1 a11 tl - else fail_match - - let length_tail = a1 0 - - let rec map f xs = let a12 = is_empty xs in - if a12 - then [] - else let a17 = list_tail xs in - let a16 = is_empty a17 in - let a15 = is_empty xs in - let a14 = not a15 in - let a13 = ( && ) a14 a16 in - if a13 - then let a = list_head xs in - let a18 = f a in - (a18::[]) - else let a24 = list_tail xs in - let a23 = list_tail a24 in - let a22 = is_empty a23 in - let a21 = is_empty xs in - let a20 = not a21 in - let a19 = ( && ) a20 a22 in - if a19 - then let a = list_head xs in - let a25 = list_tail xs in - let b = list_head a25 in - let a26 = f a in - let a28 = f b in - let a27 = (a28::[]) in - (a26::a27) - else let a35 = list_tail xs in - let a34 = list_tail a35 in - let a33 = list_tail a34 in - let a32 = is_empty a33 in - let a31 = is_empty xs in - let a30 = not a31 in - let a29 = ( && ) a30 a32 in - if a29 - then let a = list_head xs in - let a36 = list_tail xs in - let b = list_head a36 in - let a38 = list_tail xs in - let a37 = list_tail a38 in - let c = list_head a37 in - let a39 = f a in - let a41 = f b in - let a43 = f c in - let a42 = (a43::[]) in - let a40 = (a41::a42) in - (a39::a40) - else let a45 = is_empty xs in - let a44 = not a45 in - if a44 - then let a = list_head xs in - let a46 = list_tail xs in - let b = list_head a46 in - let a48 = list_tail xs in - let a47 = list_tail a48 in - let c = list_head a47 in - let a51 = list_tail xs in - let a50 = list_tail a51 in - let a49 = list_tail a50 in - let d = list_head a49 in - let a54 = list_tail xs in - let a53 = list_tail a54 in - let a52 = list_tail a53 in - let tl = list_tail a52 in - let a55 = f a in - let a57 = f b in - let a59 = f c in - let a61 = f d in - let a62 = map f tl in - let a60 = (a61::a62) in - let a58 = (a59::a60) in - let a56 = (a57::a58) in - (a55::a56) - else fail_match - - let rec append xs ys = let a63 = is_empty xs in - if a63 - then ys - else let a65 = is_empty xs in - let a64 = not a65 in - if a64 - then let x = list_head xs in - let a0 = list_tail xs in - let a66 = append a0 ys in - (x::a66) - else fail_match - - let rec a2 xs = let a67 = is_empty xs in - if a67 - then [] - else let a69 = is_empty xs in - let a68 = not a69 in - if a68 - then let h = list_head xs in - let tl = list_tail xs in - let a70 = a2 tl in - append h a70 - else fail_match - - let concat = a2 - - let rec iter f xs = let a71 = is_empty xs in - if a71 - then () - else let a73 = is_empty xs in - let a72 = not a73 in - if a72 - then let h = list_head xs in - let tl = list_tail xs in - let () = f h in - iter f tl - else fail_match - - let a3 h a = (h, a) - - let rec cartesian xs ys = let a74 = is_empty xs in - if a74 - then [] - else let a76 = is_empty xs in - let a75 = not a76 in - if a75 - then let h = list_head xs in - let tl = list_tail xs in - let a79 = cartesian tl ys in - let a78 = a3 h in - let a77 = map a78 ys in - append a77 a79 - else fail_match - - let main = let a82 = (3::[]) in - let a81 = (2::a82) in - let a80 = (1::a81) in - let () = iter print_int a80 in - let a90 = (4::[]) in - let a89 = (3::a90) in - let a88 = (2::a89) in - let a87 = (1::a88) in - let a86 = (2::[]) in - let a85 = (1::a86) in - let a84 = cartesian a85 a87 in - let a83 = length a84 in - let () = print_int a83 in - 0 - - $ ./anf_runner.exe < manytests/do_not_type/001.ml - Infer error: - $ ./anf_runner.exe < manytests/do_not_type/002if.ml - Infer error: - $ ./anf_runner.exe < manytests/do_not_type/003occurs.ml - Infer error: - - $ ./anf_runner.exe < manytests/do_not_type/004let_poly.ml - Infer error: - - $ ./anf_runner.exe < manytests/do_not_type/015tuples.ml - Infer error: - + Типы после приведения в ANF: + Infer error. diff --git a/FML/tests/anf_runner.ml b/FML/tests/anf_runner.ml index 87bac0bf8..00509e6b3 100644 --- a/FML/tests/anf_runner.ml +++ b/FML/tests/anf_runner.ml @@ -19,7 +19,7 @@ let () = | Ok parsed -> (match run_program_inferencer parsed with | Ok types -> Ok (parsed, types) - | Error _ -> Error (Format.asprintf "Infer error:")) + | Error _ -> Error (Format.asprintf "Infer error.")) | Error e -> Error (Format.sprintf "Parsing error: %s" e) in match parse_and_infer input with diff --git a/FML/tests/lambda_lifting_manytests.t b/FML/tests/lambda_lifting_manytests.t index 40071e37b..cf294901d 100644 --- a/FML/tests/lambda_lifting_manytests.t +++ b/FML/tests/lambda_lifting_manytests.t @@ -103,6 +103,8 @@ let () = (print_int a2) in 0 $ ./lambda_lifting_runner.exe < manytests/typed/006partial3.ml + let a1 = (fun c -> (print_int c)) + let a0 = (fun b -> let () = (print_int b) in a1) @@ -161,6 +163,8 @@ let main = ((iter print_int) (((map a2) (1::(2::(3::[])))) a3)) $ ./lambda_lifting_runner.exe < manytests/typed/012fibcps.ml + let a1 = (fun a k b -> (k ((( + ) a) b))) + let a0 = (fun fib k n a -> ((fib ((( - ) n) 2)) ((a1 a) k))) let rec fib = (fun n k -> if ((( < ) n) 2) @@ -196,6 +200,8 @@ let b = ((tuple_element p) 1) in ((f a), (f b))) + let a2 = (fun a0 self li x -> ((li (self a0)) x)) + let a1 = (fun self a0 -> ((map ((a2 a0) self)) a0)) let fixpoly = (fun l -> ((fix a1) l)) From 4202b0c491bce3b779816ff039d0346f15b39681 Mon Sep 17 00:00:00 2001 From: Dmitry Pilyuk Date: Mon, 10 Mar 2025 21:59:25 +0300 Subject: [PATCH 30/92] Init llvm module --- FML/lib/dune | 3 ++- FML/lib/llvm/codegen.ml | 5 +++++ FML/lib/llvm/runtime.c | 5 +++++ 3 files changed, 12 insertions(+), 1 deletion(-) create mode 100644 FML/lib/llvm/codegen.ml create mode 100644 FML/lib/llvm/runtime.c diff --git a/FML/lib/dune b/FML/lib/dune index aef919537..596df1de1 100644 --- a/FML/lib/dune +++ b/FML/lib/dune @@ -17,7 +17,8 @@ Closure_conv Lambda_lifting Anf_ast - Anf) + Anf + Codegen) (modules_without_implementation inf_errors) (libraries base angstrom) (preprocess diff --git a/FML/lib/llvm/codegen.ml b/FML/lib/llvm/codegen.ml new file mode 100644 index 000000000..7bd7a788b --- /dev/null +++ b/FML/lib/llvm/codegen.ml @@ -0,0 +1,5 @@ +(** Copyright 2024-2025, Dmitry Pilyuk, Aleksandr Rozhkov *) + +(** SPDX-License-Identifier: LGPL-2.1 *) + +open Llvm diff --git a/FML/lib/llvm/runtime.c b/FML/lib/llvm/runtime.c new file mode 100644 index 000000000..0d9b0bbdc --- /dev/null +++ b/FML/lib/llvm/runtime.c @@ -0,0 +1,5 @@ +typedef struct +{ + int64_t fun; + int64_t args_num; +} closure_t; From 9debdaca2fa833d7c3c4eef2904f15ab9ca0150a Mon Sep 17 00:00:00 2001 From: RozhkovAleksandr Date: Mon, 10 Mar 2025 23:28:19 +0300 Subject: [PATCH 31/92] add llvm dune and binops --- FML/lib/dune | 2 +- FML/lib/llvm/codegen.ml | 13 +++++++++++++ 2 files changed, 14 insertions(+), 1 deletion(-) diff --git a/FML/lib/dune b/FML/lib/dune index 596df1de1..3d8d6556c 100644 --- a/FML/lib/dune +++ b/FML/lib/dune @@ -20,7 +20,7 @@ Anf Codegen) (modules_without_implementation inf_errors) - (libraries base angstrom) + (libraries base angstrom llvm) (preprocess (pps ppx_deriving.show)) (instrumentation diff --git a/FML/lib/llvm/codegen.ml b/FML/lib/llvm/codegen.ml index 7bd7a788b..e05213443 100644 --- a/FML/lib/llvm/codegen.ml +++ b/FML/lib/llvm/codegen.ml @@ -3,3 +3,16 @@ (** SPDX-License-Identifier: LGPL-2.1 *) open Llvm +open Anf_ast + +let ctx = global_context () +let builder = builder ctx + +let compile_binop op x y = + match op with + | "( + )" -> build_add x y "add" builder + | "( - )" -> build_sub x y "sub" builder + | "( * )" -> build_mul x y "mul" builder + | "( / )" -> build_sdiv x y "div" builder + | _ -> failwith ("Invalid operator: " ^ op) +;; From 76992ac101091e1baf54c5b68c9efeef29235b7b Mon Sep 17 00:00:00 2001 From: Dmitry Pilyuk Date: Tue, 11 Mar 2025 12:57:56 +0300 Subject: [PATCH 32/92] WIP compiler of cexpr --- FML/lib/dune | 2 +- FML/lib/llvm/codegen.ml | 80 +++++++++++++++++++++++++++++++++++++++++ 2 files changed, 81 insertions(+), 1 deletion(-) diff --git a/FML/lib/dune b/FML/lib/dune index 3d8d6556c..8bda918ed 100644 --- a/FML/lib/dune +++ b/FML/lib/dune @@ -20,7 +20,7 @@ Anf Codegen) (modules_without_implementation inf_errors) - (libraries base angstrom llvm) + (libraries base angstrom llvm llvm.analysis llvm.executionengine) (preprocess (pps ppx_deriving.show)) (instrumentation diff --git a/FML/lib/llvm/codegen.ml b/FML/lib/llvm/codegen.ml index e05213443..f9f6ef573 100644 --- a/FML/lib/llvm/codegen.ml +++ b/FML/lib/llvm/codegen.ml @@ -5,8 +5,35 @@ open Llvm open Anf_ast +let sym_to_value : (string, llvalue) Hashtbl.t = Hashtbl.create 1 +let sym_to_type : (string, lltype) Hashtbl.t = Hashtbl.create 1 +let lookup_name name = Hashtbl.find_opt sym_to_value name +let lookup_type name = Hashtbl.find_opt sym_to_type name +let add_sym name value = Hashtbl.add sym_to_value name value +let add_type name ty = Hashtbl.add sym_to_type name ty + +let id_to_runtime_name = function + | "( + )" -> "add" + | "( - )" -> "sub" + | "( * )" -> "mul" + | "( / )" -> "divd" + | "( = )" -> "eq" + | "( != )" -> "neq" + | "( < )" -> "less" + | "( <= )" -> "leq" + | "( > )" -> "gre" + | "( >= )" -> "geq" + | "( && )" -> "and" + | "( || )" -> "or" + | other -> other +;; + let ctx = global_context () let builder = builder ctx +let module_ = create_module ctx "FML" +let target_triple = Llvm_target.Target.default_triple () +let () = Llvm.set_target_triple target_triple module_ +let i64_t = i64_type ctx let compile_binop op x y = match op with @@ -16,3 +43,56 @@ let compile_binop op x y = | "( / )" -> build_sdiv x y "div" builder | _ -> failwith ("Invalid operator: " ^ op) ;; + +let compile_immexpr = function + | ImmInt n -> const_int i64_t n + | ImmBool b -> const_int i64_t (Bool.to_int b) + | ImmUnit -> const_int i64_t 0 + | ImmIdentifier name -> + let name = id_to_runtime_name name in + (match lookup_function name module_ with + | Some f -> + let fun_ptr = build_ptrtoint f i64_t "" builder in + build_call + (function_type i64_t [| i64_t; i64_t |]) + (Option.get @@ lookup_function "create_closure" module_) + [| fun_ptr; const_int i64_t (Array.length (params f)); const_int i64_t 0 |] + "empty_closure" + builder + | None -> + (match lookup_global name module_ with + | Some g -> g + | None -> + (match lookup_name name with + | Some v -> v + | None -> failwith ("Unknown variable: " ^ name)))) + | _ -> failwith "Not implemented" +;; + +let rec compile_cexpr = function + | CImmExpr expr -> compile_immexpr expr + | CEApply (name, args) -> + let compiled_args = List.map compile_immexpr args in + (match lookup_function name module_ with + | Some f when Array.length (params f) = List.length args -> + build_call (type_of f) f (Array.of_list compiled_args) name builder + | Some f -> + let fun_ptr = build_ptrtoint f i64_t "" builder in + let cl = + build_call + (function_type i64_t [| i64_t; i64_t |]) + (Option.get @@ lookup_function "create_closure" module_) + [| fun_ptr; const_int i64_t (Array.length (params f)); const_int i64_t 0 |] + "closure" + builder + in + build_call + (var_arg_function_type i64_t [| i64_t; i64_t |]) + (Option.get (lookup_function "apply_args_to_closure" module_)) + (Array.of_list + ([ cl; const_int i64_t (List.length compiled_args) ] @ compiled_args)) + "applied_closure" + builder + | None -> failwith "Not a function") + | _ -> failwith "Not impemented" +;; From 8203f3d1316cb775929b40fc7385ef0732a6e2d3 Mon Sep 17 00:00:00 2001 From: Dmitry Pilyuk Date: Tue, 11 Mar 2025 14:37:10 +0300 Subject: [PATCH 33/92] Add compilation of if then else --- FML/lib/anf/common.ml | 10 +- FML/lib/anf/pattern_elim.ml | 23 +-- FML/lib/llvm/codegen.ml | 32 ++++ FML/tests/alpha_conv_manytest.t | 140 ++++++++--------- FML/tests/anf_manytests.t | 224 +++++++++++++++++++++++---- FML/tests/closure_conv_manytest.t | 140 ++++++++--------- FML/tests/lambda_lifting_manytests.t | 140 ++++++++--------- FML/tests/pe_manytests.t | 140 ++++++++--------- 8 files changed, 527 insertions(+), 322 deletions(-) diff --git a/FML/lib/anf/common.ml b/FML/lib/anf/common.ml index 4d3fcbf64..5a7a09387 100644 --- a/FML/lib/anf/common.ml +++ b/FML/lib/anf/common.ml @@ -33,11 +33,11 @@ let builtins = ; "( || )" ; "not" ; "print_int" - ; "list_head" - ; "list_tail" - ; "tuple_element" - ; "is_empty" - ; "fail_match" + ; "#list_head" + ; "#list_tail" + ; "#tuple_element" + ; "#is_empty" + ; "#fail_match" ] ;; diff --git a/FML/lib/anf/pattern_elim.ml b/FML/lib/anf/pattern_elim.ml index 587f43dd1..f7a9cf2aa 100644 --- a/FML/lib/anf/pattern_elim.ml +++ b/FML/lib/anf/pattern_elim.ml @@ -13,9 +13,10 @@ type value_to_get = | Other let get_element e = function - | Tuple i -> Pe_EApp (Pe_EApp (Pe_EIdentifier "tuple_element", e), Pe_EConst (Pe_Cint i)) - | Cons_head -> Pe_EApp (Pe_EIdentifier "list_head", e) - | Cons_tail -> Pe_EApp (Pe_EIdentifier "list_tail", e) + | Tuple i -> + Pe_EApp (Pe_EApp (Pe_EIdentifier "#tuple_element", e), Pe_EConst (Pe_Cint i)) + | Cons_head -> Pe_EApp (Pe_EIdentifier "#list_head", e) + | Cons_tail -> Pe_EApp (Pe_EIdentifier "#list_tail", e) | Other -> e ;; @@ -40,12 +41,12 @@ let check_pattern expr pat = @@ List.mapi pl ~f:(fun i p -> helper true (get_element expr (Tuple i)) p) | PCons (l, r) -> let check = - Pe_EApp (Pe_EIdentifier "not", Pe_EApp (Pe_EIdentifier "is_empty", expr)) + Pe_EApp (Pe_EIdentifier "not", Pe_EApp (Pe_EIdentifier "#is_empty", expr)) in let l = helper true (get_element expr Cons_head) l in let r = helper false (get_element expr Cons_tail) r in if add then (check :: l) @ r else l @ r - | PNill -> [ Pe_EApp (Pe_EIdentifier "is_empty", expr) ] + | PNill -> [ Pe_EApp (Pe_EIdentifier "#is_empty", expr) ] | _ -> [] in helper true expr pat @@ -146,7 +147,7 @@ let rec pe_expr = | 1 -> let pat = List.hd_exn pat_list in let to_match = Pe_EIdentifier (List.hd_exn args_to_match) in - let case_expr = make_case to_match pat new_body (Pe_EIdentifier "fail_match") in + let case_expr = make_case to_match pat new_body (Pe_EIdentifier "#fail_match") in return @@ Pe_EFun (new_args, case_expr) | _ -> let pat = PTuple pat_list in @@ -156,7 +157,7 @@ let rec pe_expr = in let* fresh_name = fresh >>| get_id in let case_expr = - make_case (Pe_EIdentifier fresh_name) pat new_body (Pe_EIdentifier "fail_match") + make_case (Pe_EIdentifier fresh_name) pat new_body (Pe_EIdentifier "#fail_match") in return @@ Pe_EFun (new_args, Pe_ELet (NoRec, fresh_name, to_match, case_expr))) | EMatch (e_last, case_list) -> @@ -176,12 +177,12 @@ let rec pe_expr = | _ -> (match e1 with | Pe_EIdentifier _ -> - let case_expr = make_case e1 pat e2 (Pe_EIdentifier "fail_match") in + let case_expr = make_case e1 pat e2 (Pe_EIdentifier "#fail_match") in return case_expr | _ -> let* fresh_name = fresh >>| get_id in let case_expr = - make_case (Pe_EIdentifier fresh_name) pat e2 (Pe_EIdentifier "fail_match") + make_case (Pe_EIdentifier fresh_name) pat e2 (Pe_EIdentifier "#fail_match") in return @@ Pe_ELet (NoRec, fresh_name, e1, case_expr))) | ELetIn (Rec, pat, e1, e2) -> @@ -193,7 +194,7 @@ let rec pe_expr = | _ -> let* fresh_name = fresh >>| get_id in let case_expr = - make_case (Pe_EIdentifier fresh_name) pat e2 (Pe_EIdentifier "fail_match") + make_case (Pe_EIdentifier fresh_name) pat e2 (Pe_EIdentifier "#fail_match") in return @@ Pe_ELet (Rec, fresh_name, e1, case_expr)) @@ -216,7 +217,7 @@ and pe_match to_match = function else let* match_e = pe_match to_match tl in return @@ make_condition checks let_in match_e - | _ -> return @@ Pe_EIdentifier "fail_match" + | _ -> return @@ Pe_EIdentifier "#fail_match" ;; let pe_declaration = function diff --git a/FML/lib/llvm/codegen.ml b/FML/lib/llvm/codegen.ml index f9f6ef573..45af8ddfd 100644 --- a/FML/lib/llvm/codegen.ml +++ b/FML/lib/llvm/codegen.ml @@ -94,5 +94,37 @@ let rec compile_cexpr = function "applied_closure" builder | None -> failwith "Not a function") + | CEIf (cond, then_e, else_e) -> + let cond_v = + build_icmp Icmp.Ne (compile_immexpr cond) (const_int i64_t 0) "cond_v" builder + in + let entry_block = insertion_block builder in + let parent = block_parent entry_block in + let then_block = append_block ctx "then" parent in + position_at_end then_block builder; + let then_ = compile_aexpr then_e in + let new_then_block = insertion_block builder in + let else_block = append_block ctx "else" parent in + position_at_end else_block builder; + let else_ = compile_aexpr else_e in + let new_else_block = insertion_block builder in + let merge_bb = append_block ctx "merge" parent in + position_at_end merge_bb builder; + let phi = build_phi [ then_, new_then_block; else_, new_else_block ] "phi" builder in + position_at_end entry_block builder; + let (_ : llvalue) = build_cond_br cond_v then_block else_block builder in + position_at_end new_then_block builder; + let (_ : llvalue) = build_br merge_bb builder in + position_at_end new_else_block builder; + let (_ : llvalue) = build_br merge_bb builder in + position_at_end merge_bb builder; + phi | _ -> failwith "Not impemented" + +and compile_aexpr = function + | ACExpr expr -> compile_cexpr expr + | ALetIn (name, ce, ae) -> + let v = compile_cexpr ce in + add_sym name v; + compile_aexpr ae ;; diff --git a/FML/tests/alpha_conv_manytest.t b/FML/tests/alpha_conv_manytest.t index 294cffa24..43726e5cd 100644 --- a/FML/tests/alpha_conv_manytest.t +++ b/FML/tests/alpha_conv_manytest.t @@ -116,22 +116,22 @@ ((f 1), (f true)) $ ./alpha_conv_runner.exe < manytests/typed/011mapcps.ml - let rec map = (fun f xs k -> if (is_empty xs) + let rec map = (fun f xs k -> if (#is_empty xs) then (k []) - else if (not (is_empty xs)) - then let h = (list_head xs) in - let tl = (list_tail xs) in + else if (not (#is_empty xs)) + then let h = (#list_head xs) in + let tl = (#list_tail xs) in (((map f) tl) (fun a0 -> (k ((f h)::a0)))) - else fail_match) + else #fail_match) - let rec iter = (fun f xs -> if (is_empty xs) + let rec iter = (fun f xs -> if (#is_empty xs) then () - else if (not (is_empty xs)) - then let h = (list_head xs) in - let tl = (list_tail xs) in + else if (not (#is_empty xs)) + then let h = (#list_head xs) in + let tl = (#list_tail xs) in let w = (f h) in ((iter f) tl) - else fail_match) + else #fail_match) let main = ((iter print_int) (((map (fun x -> ((( + ) x) 1))) (1::(2::(3::[])))) (fun x -> x))) $ ./alpha_conv_runner.exe < manytests/typed/012fibcps.ml @@ -143,13 +143,13 @@ $ ./alpha_conv_runner.exe < manytests/typed/013foldfoldr.ml let id = (fun x -> x) - let rec fold_right = (fun f acc xs -> if (is_empty xs) + let rec fold_right = (fun f acc xs -> if (#is_empty xs) then acc - else if (not (is_empty xs)) - then let h = (list_head xs) in - let tl = (list_tail xs) in + else if (not (#is_empty xs)) + then let h = (#list_head xs) in + let tl = (#list_tail xs) in ((f h) (((fold_right f) acc) tl)) - else fail_match) + else #fail_match) let foldl = (fun f a bs -> ((((fold_right (fun b g x -> (g ((f x) b)))) id) bs) a)) @@ -158,20 +158,20 @@ $ ./alpha_conv_runner.exe < manytests/typed/015tuples.ml let rec fix = (fun f x -> ((f (fix f)) x)) - let map = (fun f p -> let a = ((tuple_element p) 0) in - let b = ((tuple_element p) 1) in + let map = (fun f p -> let a = ((#tuple_element p) 0) in + let b = ((#tuple_element p) 1) in ((f a), (f b))) let fixpoly = (fun l -> ((fix (fun self a0 -> ((map (fun li x -> ((li (self a0)) x))) a0))) l)) - let feven = (fun p n -> let e = ((tuple_element p) 0) in - let o = ((tuple_element p) 1) in + let feven = (fun p n -> let e = ((#tuple_element p) 0) in + let o = ((#tuple_element p) 1) in if ((( = ) n) 0) then 1 else (o ((( - ) n) 1))) - let fodd = (fun p n -> let e = ((tuple_element p) 0) in - let o = ((tuple_element p) 1) in + let fodd = (fun p n -> let e = ((#tuple_element p) 0) in + let o = ((#tuple_element p) 1) in if ((( = ) n) 0) then 0 else (e ((( - ) n) 1))) @@ -187,86 +187,86 @@ let main = let () = (print_int (modd 1)) in let () = (print_int (meven 2)) in - let even = ((tuple_element tie) 0) in - let odd = ((tuple_element tie) 1) in + let even = ((#tuple_element tie) 0) in + let odd = ((#tuple_element tie) 1) in let () = (print_int (odd 3)) in let () = (print_int (even 4)) in 0 $ ./alpha_conv_runner.exe < manytests/typed/016lists.ml - let rec length = (fun xs -> if (is_empty xs) + let rec length = (fun xs -> if (#is_empty xs) then 0 - else if (not (is_empty xs)) - then let h = (list_head xs) in - let tl = (list_tail xs) in + else if (not (#is_empty xs)) + then let h = (#list_head xs) in + let tl = (#list_tail xs) in ((( + ) 1) (length tl)) - else fail_match) + else #fail_match) - let length_tail = let rec helper = (fun acc xs -> if (is_empty xs) + let length_tail = let rec helper = (fun acc xs -> if (#is_empty xs) then acc - else if (not (is_empty xs)) - then let h = (list_head xs) in - let tl = (list_tail xs) in + else if (not (#is_empty xs)) + then let h = (#list_head xs) in + let tl = (#list_tail xs) in ((helper ((( + ) acc) 1)) tl) - else fail_match) in + else #fail_match) in (helper 0) - let rec map = (fun f xs -> if (is_empty xs) + let rec map = (fun f xs -> if (#is_empty xs) then [] - else if ((( && ) (not (is_empty xs))) (is_empty (list_tail xs))) - then let a = (list_head xs) in + else if ((( && ) (not (#is_empty xs))) (#is_empty (#list_tail xs))) + then let a = (#list_head xs) in ((f a)::[]) - else if ((( && ) (not (is_empty xs))) (is_empty (list_tail (list_tail xs)))) - then let a = (list_head xs) in - let b = (list_head (list_tail xs)) in + else if ((( && ) (not (#is_empty xs))) (#is_empty (#list_tail (#list_tail xs)))) + then let a = (#list_head xs) in + let b = (#list_head (#list_tail xs)) in ((f a)::((f b)::[])) - else if ((( && ) (not (is_empty xs))) (is_empty (list_tail (list_tail (list_tail xs))))) - then let a = (list_head xs) in - let b = (list_head (list_tail xs)) in - let c = (list_head (list_tail (list_tail xs))) in + else if ((( && ) (not (#is_empty xs))) (#is_empty (#list_tail (#list_tail (#list_tail xs))))) + then let a = (#list_head xs) in + let b = (#list_head (#list_tail xs)) in + let c = (#list_head (#list_tail (#list_tail xs))) in ((f a)::((f b)::((f c)::[]))) - else if (not (is_empty xs)) - then let a = (list_head xs) in - let b = (list_head (list_tail xs)) in - let c = (list_head (list_tail (list_tail xs))) in - let d = (list_head (list_tail (list_tail (list_tail xs)))) in - let tl = (list_tail (list_tail (list_tail (list_tail xs)))) in + else if (not (#is_empty xs)) + then let a = (#list_head xs) in + let b = (#list_head (#list_tail xs)) in + let c = (#list_head (#list_tail (#list_tail xs))) in + let d = (#list_head (#list_tail (#list_tail (#list_tail xs)))) in + let tl = (#list_tail (#list_tail (#list_tail (#list_tail xs)))) in ((f a)::((f b)::((f c)::((f d)::((map f) tl))))) - else fail_match) + else #fail_match) - let rec append = (fun xs ys -> if (is_empty xs) + let rec append = (fun xs ys -> if (#is_empty xs) then ys - else if (not (is_empty xs)) - then let x = (list_head xs) in - let a0 = (list_tail xs) in + else if (not (#is_empty xs)) + then let x = (#list_head xs) in + let a0 = (#list_tail xs) in (x::((append a0) ys)) - else fail_match) + else #fail_match) - let concat = let rec helper = (fun xs -> if (is_empty xs) + let concat = let rec helper = (fun xs -> if (#is_empty xs) then [] - else if (not (is_empty xs)) - then let h = (list_head xs) in - let tl = (list_tail xs) in + else if (not (#is_empty xs)) + then let h = (#list_head xs) in + let tl = (#list_tail xs) in ((append h) (helper tl)) - else fail_match) in + else #fail_match) in helper - let rec iter = (fun f xs -> if (is_empty xs) + let rec iter = (fun f xs -> if (#is_empty xs) then () - else if (not (is_empty xs)) - then let h = (list_head xs) in - let tl = (list_tail xs) in + else if (not (#is_empty xs)) + then let h = (#list_head xs) in + let tl = (#list_tail xs) in let () = (f h) in ((iter f) tl) - else fail_match) + else #fail_match) - let rec cartesian = (fun xs ys -> if (is_empty xs) + let rec cartesian = (fun xs ys -> if (#is_empty xs) then [] - else if (not (is_empty xs)) - then let h = (list_head xs) in - let tl = (list_tail xs) in + else if (not (#is_empty xs)) + then let h = (#list_head xs) in + let tl = (#list_tail xs) in ((append ((map (fun a -> (h, a))) ys)) ((cartesian tl) ys)) - else fail_match) + else #fail_match) let main = let () = ((iter print_int) (1::(2::(3::[])))) in let () = (print_int (length ((cartesian (1::(2::[]))) (1::(2::(3::(4::[]))))))) in diff --git a/FML/tests/anf_manytests.t b/FML/tests/anf_manytests.t index 08e546bdf..12bfa406e 100644 --- a/FML/tests/anf_manytests.t +++ b/FML/tests/anf_manytests.t @@ -248,30 +248,30 @@ let a4 = (a5::a0) in k a4 - let rec map f xs k = let a6 = is_empty xs in + let rec map f xs k = let a6 = #is_empty xs in if a6 then let a7 = [] in k a7 - else let a9 = is_empty xs in + else let a9 = #is_empty xs in let a8 = not a9 in if a8 - then let h = list_head xs in - let tl = list_tail xs in + then let h = #list_head xs in + let tl = #list_tail xs in let a10 = a1 f h k in map f tl a10 - else fail_match + else #fail_match - let rec iter f xs = let a11 = is_empty xs in + let rec iter f xs = let a11 = #is_empty xs in if a11 then () - else let a13 = is_empty xs in + else let a13 = #is_empty xs in let a12 = not a13 in if a12 - then let h = list_head xs in - let tl = list_tail xs in + then let h = #list_head xs in + let tl = #list_tail xs in let w = f h in iter f tl - else fail_match + else #fail_match let a2 x = ( + ) x 1 @@ -283,7 +283,7 @@ let a14 = map a2 a15 a3 in iter print_int a14 Типы после приведения в ANF: - Infer error. + Parsing error: : end_of_input $ ./anf_runner.exe < manytests/typed/012fibcps.ml let a1 a k b = let a3 = ( + ) a b in k a3 @@ -312,17 +312,17 @@ $ ./anf_runner.exe < manytests/typed/013foldfoldr.ml let id x = x - let rec fold_right f acc xs = let a2 = is_empty xs in + let rec fold_right f acc xs = let a2 = #is_empty xs in if a2 then acc - else let a4 = is_empty xs in + else let a4 = #is_empty xs in let a3 = not a4 in if a3 - then let h = list_head xs in - let tl = list_tail xs in + then let h = #list_head xs in + let tl = #list_tail xs in let a5 = fold_right f acc tl in f h a5 - else fail_match + else #fail_match let a0 f b g x = let a6 = f x b in g a6 @@ -338,14 +338,14 @@ let a8 = foldl a1 1 a9 in print_int a8 Типы после приведения в ANF: - Infer error. + Parsing error: : end_of_input $ ./anf_runner.exe < manytests/typed/015tuples.ml let rec fix f x = let a3 = fix f in f a3 x - let map f p = let a = tuple_element p 0 in - let b = tuple_element p 1 in + let map f p = let a = #tuple_element p 0 in + let b = #tuple_element p 1 in let a4 = f a in let a5 = f b in (a4, a5) @@ -358,16 +358,16 @@ let fixpoly l = fix a1 l - let feven p n = let e = tuple_element p 0 in - let o = tuple_element p 1 in + let feven p n = let e = #tuple_element p 0 in + let o = #tuple_element p 1 in let a8 = ( = ) n 0 in if a8 then 1 else let a9 = ( - ) n 1 in o a9 - let fodd p n = let e = tuple_element p 0 in - let o = tuple_element p 1 in + let fodd p n = let e = #tuple_element p 0 in + let o = #tuple_element p 1 in let a10 = ( = ) n 0 in if a10 then 0 @@ -392,12 +392,184 @@ let () = print_int a17 in let a18 = meven 2 in let () = print_int a18 in - let even = tuple_element tie 0 in - let odd = tuple_element tie 1 in + let even = #tuple_element tie 0 in + let odd = #tuple_element tie 1 in let a19 = odd 3 in let () = print_int a19 in let a20 = even 4 in let () = print_int a20 in 0 Типы после приведения в ANF: - Infer error. + Parsing error: : end_of_input + + $ ./anf_runner.exe < manytests/typed/016lists.ml + let rec length xs = let a4 = #is_empty xs in + if a4 + then 0 + else let a6 = #is_empty xs in + let a5 = not a6 in + if a5 + then let h = #list_head xs in + let tl = #list_tail xs in + let a7 = length tl in + ( + ) 1 a7 + else #fail_match + + let rec a1 acc xs = let a8 = #is_empty xs in + if a8 + then acc + else let a10 = #is_empty xs in + let a9 = not a10 in + if a9 + then let h = #list_head xs in + let tl = #list_tail xs in + let a11 = ( + ) acc 1 in + a1 a11 tl + else #fail_match + + let length_tail = a1 0 + + let rec map f xs = let a12 = #is_empty xs in + if a12 + then [] + else let a17 = #list_tail xs in + let a16 = #is_empty a17 in + let a15 = #is_empty xs in + let a14 = not a15 in + let a13 = ( && ) a14 a16 in + if a13 + then let a = #list_head xs in + let a18 = f a in + (a18::[]) + else let a24 = #list_tail xs in + let a23 = #list_tail a24 in + let a22 = #is_empty a23 in + let a21 = #is_empty xs in + let a20 = not a21 in + let a19 = ( && ) a20 a22 in + if a19 + then let a = #list_head xs in + let a25 = #list_tail xs in + let b = #list_head a25 in + let a26 = f a in + let a28 = f b in + let a27 = (a28::[]) in + (a26::a27) + else let a35 = #list_tail xs in + let a34 = #list_tail a35 in + let a33 = #list_tail a34 in + let a32 = #is_empty a33 in + let a31 = #is_empty xs in + let a30 = not a31 in + let a29 = ( && ) a30 a32 in + if a29 + then let a = #list_head xs in + let a36 = #list_tail xs in + let b = #list_head a36 in + let a38 = #list_tail xs in + let a37 = #list_tail a38 in + let c = #list_head a37 in + let a39 = f a in + let a41 = f b in + let a43 = f c in + let a42 = (a43::[]) in + let a40 = (a41::a42) in + (a39::a40) + else let a45 = #is_empty xs in + let a44 = not a45 in + if a44 + then let a = #list_head xs in + let a46 = #list_tail xs in + let b = #list_head a46 in + let a48 = #list_tail xs in + let a47 = #list_tail a48 in + let c = #list_head a47 in + let a51 = #list_tail xs in + let a50 = #list_tail a51 in + let a49 = #list_tail a50 in + let d = #list_head a49 in + let a54 = #list_tail xs in + let a53 = #list_tail a54 in + let a52 = #list_tail a53 in + let tl = #list_tail a52 in + let a55 = f a in + let a57 = f b in + let a59 = f c in + let a61 = f d in + let a62 = map f tl in + let a60 = (a61::a62) in + let a58 = (a59::a60) in + let a56 = (a57::a58) in + (a55::a56) + else #fail_match + + let rec append xs ys = let a63 = #is_empty xs in + if a63 + then ys + else let a65 = #is_empty xs in + let a64 = not a65 in + if a64 + then let x = #list_head xs in + let a0 = #list_tail xs in + let a66 = append a0 ys in + (x::a66) + else #fail_match + + let rec a2 xs = let a67 = #is_empty xs in + if a67 + then [] + else let a69 = #is_empty xs in + let a68 = not a69 in + if a68 + then let h = #list_head xs in + let tl = #list_tail xs in + let a70 = a2 tl in + append h a70 + else #fail_match + + let concat = a2 + + let rec iter f xs = let a71 = #is_empty xs in + if a71 + then () + else let a73 = #is_empty xs in + let a72 = not a73 in + if a72 + then let h = #list_head xs in + let tl = #list_tail xs in + let () = f h in + iter f tl + else #fail_match + + let a3 h a = (h, a) + + let rec cartesian xs ys = let a74 = #is_empty xs in + if a74 + then [] + else let a76 = #is_empty xs in + let a75 = not a76 in + if a75 + then let h = #list_head xs in + let tl = #list_tail xs in + let a79 = cartesian tl ys in + let a78 = a3 h in + let a77 = map a78 ys in + append a77 a79 + else #fail_match + + let main = let a82 = (3::[]) in + let a81 = (2::a82) in + let a80 = (1::a81) in + let () = iter print_int a80 in + let a90 = (4::[]) in + let a89 = (3::a90) in + let a88 = (2::a89) in + let a87 = (1::a88) in + let a86 = (2::[]) in + let a85 = (1::a86) in + let a84 = cartesian a85 a87 in + let a83 = length a84 in + let () = print_int a83 in + 0 + Типы после приведения в ANF: + Parsing error: : string diff --git a/FML/tests/closure_conv_manytest.t b/FML/tests/closure_conv_manytest.t index 9f91dd0d9..fa10dc8a0 100644 --- a/FML/tests/closure_conv_manytest.t +++ b/FML/tests/closure_conv_manytest.t @@ -116,22 +116,22 @@ ((f 1), (f true)) $ ./closure_conv_runner.exe < manytests/typed/011mapcps.ml - let rec map = (fun f xs k -> if (is_empty xs) + let rec map = (fun f xs k -> if (#is_empty xs) then (k []) - else if (not (is_empty xs)) - then let h = (list_head xs) in - let tl = (list_tail xs) in + else if (not (#is_empty xs)) + then let h = (#list_head xs) in + let tl = (#list_tail xs) in (((map f) tl) ((((fun f h k a0 -> (k ((f h)::a0))) f) h) k)) - else fail_match) + else #fail_match) - let rec iter = (fun f xs -> if (is_empty xs) + let rec iter = (fun f xs -> if (#is_empty xs) then () - else if (not (is_empty xs)) - then let h = (list_head xs) in - let tl = (list_tail xs) in + else if (not (#is_empty xs)) + then let h = (#list_head xs) in + let tl = (#list_tail xs) in let w = (f h) in ((iter f) tl) - else fail_match) + else #fail_match) let main = ((iter print_int) (((map (fun x -> ((( + ) x) 1))) (1::(2::(3::[])))) (fun x -> x))) $ ./closure_conv_runner.exe < manytests/typed/012fibcps.ml @@ -143,13 +143,13 @@ $ ./closure_conv_runner.exe < manytests/typed/013foldfoldr.ml let id = (fun x -> x) - let rec fold_right = (fun f acc xs -> if (is_empty xs) + let rec fold_right = (fun f acc xs -> if (#is_empty xs) then acc - else if (not (is_empty xs)) - then let h = (list_head xs) in - let tl = (list_tail xs) in + else if (not (#is_empty xs)) + then let h = (#list_head xs) in + let tl = (#list_tail xs) in ((f h) (((fold_right f) acc) tl)) - else fail_match) + else #fail_match) let foldl = (fun f a bs -> ((((fold_right ((fun f b g x -> (g ((f x) b))) f)) id) bs) a)) @@ -158,20 +158,20 @@ $ ./closure_conv_runner.exe < manytests/typed/015tuples.ml let rec fix = (fun f x -> ((f (fix f)) x)) - let map = (fun f p -> let a = ((tuple_element p) 0) in - let b = ((tuple_element p) 1) in + let map = (fun f p -> let a = ((#tuple_element p) 0) in + let b = ((#tuple_element p) 1) in ((f a), (f b))) let fixpoly = (fun l -> ((fix (fun self a0 -> ((map (((fun a0 self li x -> ((li (self a0)) x)) a0) self)) a0))) l)) - let feven = (fun p n -> let e = ((tuple_element p) 0) in - let o = ((tuple_element p) 1) in + let feven = (fun p n -> let e = ((#tuple_element p) 0) in + let o = ((#tuple_element p) 1) in if ((( = ) n) 0) then 1 else (o ((( - ) n) 1))) - let fodd = (fun p n -> let e = ((tuple_element p) 0) in - let o = ((tuple_element p) 1) in + let fodd = (fun p n -> let e = ((#tuple_element p) 0) in + let o = ((#tuple_element p) 1) in if ((( = ) n) 0) then 0 else (e ((( - ) n) 1))) @@ -187,86 +187,86 @@ let main = let () = (print_int (modd 1)) in let () = (print_int (meven 2)) in - let even = ((tuple_element tie) 0) in - let odd = ((tuple_element tie) 1) in + let even = ((#tuple_element tie) 0) in + let odd = ((#tuple_element tie) 1) in let () = (print_int (odd 3)) in let () = (print_int (even 4)) in 0 $ ./closure_conv_runner.exe < manytests/typed/016lists.ml - let rec length = (fun xs -> if (is_empty xs) + let rec length = (fun xs -> if (#is_empty xs) then 0 - else if (not (is_empty xs)) - then let h = (list_head xs) in - let tl = (list_tail xs) in + else if (not (#is_empty xs)) + then let h = (#list_head xs) in + let tl = (#list_tail xs) in ((( + ) 1) (length tl)) - else fail_match) + else #fail_match) - let length_tail = let rec helper = (fun acc xs -> if (is_empty xs) + let length_tail = let rec helper = (fun acc xs -> if (#is_empty xs) then acc - else if (not (is_empty xs)) - then let h = (list_head xs) in - let tl = (list_tail xs) in + else if (not (#is_empty xs)) + then let h = (#list_head xs) in + let tl = (#list_tail xs) in ((helper ((( + ) acc) 1)) tl) - else fail_match) in + else #fail_match) in (helper 0) - let rec map = (fun f xs -> if (is_empty xs) + let rec map = (fun f xs -> if (#is_empty xs) then [] - else if ((( && ) (not (is_empty xs))) (is_empty (list_tail xs))) - then let a = (list_head xs) in + else if ((( && ) (not (#is_empty xs))) (#is_empty (#list_tail xs))) + then let a = (#list_head xs) in ((f a)::[]) - else if ((( && ) (not (is_empty xs))) (is_empty (list_tail (list_tail xs)))) - then let a = (list_head xs) in - let b = (list_head (list_tail xs)) in + else if ((( && ) (not (#is_empty xs))) (#is_empty (#list_tail (#list_tail xs)))) + then let a = (#list_head xs) in + let b = (#list_head (#list_tail xs)) in ((f a)::((f b)::[])) - else if ((( && ) (not (is_empty xs))) (is_empty (list_tail (list_tail (list_tail xs))))) - then let a = (list_head xs) in - let b = (list_head (list_tail xs)) in - let c = (list_head (list_tail (list_tail xs))) in + else if ((( && ) (not (#is_empty xs))) (#is_empty (#list_tail (#list_tail (#list_tail xs))))) + then let a = (#list_head xs) in + let b = (#list_head (#list_tail xs)) in + let c = (#list_head (#list_tail (#list_tail xs))) in ((f a)::((f b)::((f c)::[]))) - else if (not (is_empty xs)) - then let a = (list_head xs) in - let b = (list_head (list_tail xs)) in - let c = (list_head (list_tail (list_tail xs))) in - let d = (list_head (list_tail (list_tail (list_tail xs)))) in - let tl = (list_tail (list_tail (list_tail (list_tail xs)))) in + else if (not (#is_empty xs)) + then let a = (#list_head xs) in + let b = (#list_head (#list_tail xs)) in + let c = (#list_head (#list_tail (#list_tail xs))) in + let d = (#list_head (#list_tail (#list_tail (#list_tail xs)))) in + let tl = (#list_tail (#list_tail (#list_tail (#list_tail xs)))) in ((f a)::((f b)::((f c)::((f d)::((map f) tl))))) - else fail_match) + else #fail_match) - let rec append = (fun xs ys -> if (is_empty xs) + let rec append = (fun xs ys -> if (#is_empty xs) then ys - else if (not (is_empty xs)) - then let x = (list_head xs) in - let a0 = (list_tail xs) in + else if (not (#is_empty xs)) + then let x = (#list_head xs) in + let a0 = (#list_tail xs) in (x::((append a0) ys)) - else fail_match) + else #fail_match) - let concat = let rec helper = (fun xs -> if (is_empty xs) + let concat = let rec helper = (fun xs -> if (#is_empty xs) then [] - else if (not (is_empty xs)) - then let h = (list_head xs) in - let tl = (list_tail xs) in + else if (not (#is_empty xs)) + then let h = (#list_head xs) in + let tl = (#list_tail xs) in ((append h) (helper tl)) - else fail_match) in + else #fail_match) in helper - let rec iter = (fun f xs -> if (is_empty xs) + let rec iter = (fun f xs -> if (#is_empty xs) then () - else if (not (is_empty xs)) - then let h = (list_head xs) in - let tl = (list_tail xs) in + else if (not (#is_empty xs)) + then let h = (#list_head xs) in + let tl = (#list_tail xs) in let () = (f h) in ((iter f) tl) - else fail_match) + else #fail_match) - let rec cartesian = (fun xs ys -> if (is_empty xs) + let rec cartesian = (fun xs ys -> if (#is_empty xs) then [] - else if (not (is_empty xs)) - then let h = (list_head xs) in - let tl = (list_tail xs) in + else if (not (#is_empty xs)) + then let h = (#list_head xs) in + let tl = (#list_tail xs) in ((append ((map ((fun h a -> (h, a)) h)) ys)) ((cartesian tl) ys)) - else fail_match) + else #fail_match) let main = let () = ((iter print_int) (1::(2::(3::[])))) in let () = (print_int (length ((cartesian (1::(2::[]))) (1::(2::(3::(4::[]))))))) in diff --git a/FML/tests/lambda_lifting_manytests.t b/FML/tests/lambda_lifting_manytests.t index cf294901d..5a0f16c32 100644 --- a/FML/tests/lambda_lifting_manytests.t +++ b/FML/tests/lambda_lifting_manytests.t @@ -140,22 +140,22 @@ $ ./lambda_lifting_runner.exe < manytests/typed/011mapcps.ml let a1 = (fun f h k a0 -> (k ((f h)::a0))) - let rec map = (fun f xs k -> if (is_empty xs) + let rec map = (fun f xs k -> if (#is_empty xs) then (k []) - else if (not (is_empty xs)) - then let h = (list_head xs) in - let tl = (list_tail xs) in + else if (not (#is_empty xs)) + then let h = (#list_head xs) in + let tl = (#list_tail xs) in (((map f) tl) (((a1 f) h) k)) - else fail_match) + else #fail_match) - let rec iter = (fun f xs -> if (is_empty xs) + let rec iter = (fun f xs -> if (#is_empty xs) then () - else if (not (is_empty xs)) - then let h = (list_head xs) in - let tl = (list_tail xs) in + else if (not (#is_empty xs)) + then let h = (#list_head xs) in + let tl = (#list_tail xs) in let w = (f h) in ((iter f) tl) - else fail_match) + else #fail_match) let a2 = (fun x -> ((( + ) x) 1)) @@ -177,13 +177,13 @@ $ ./lambda_lifting_runner.exe < manytests/typed/013foldfoldr.ml let id = (fun x -> x) - let rec fold_right = (fun f acc xs -> if (is_empty xs) + let rec fold_right = (fun f acc xs -> if (#is_empty xs) then acc - else if (not (is_empty xs)) - then let h = (list_head xs) in - let tl = (list_tail xs) in + else if (not (#is_empty xs)) + then let h = (#list_head xs) in + let tl = (#list_tail xs) in ((f h) (((fold_right f) acc) tl)) - else fail_match) + else #fail_match) let a0 = (fun f b g x -> (g ((f x) b))) @@ -196,8 +196,8 @@ $ ./lambda_lifting_runner.exe < manytests/typed/015tuples.ml let rec fix = (fun f x -> ((f (fix f)) x)) - let map = (fun f p -> let a = ((tuple_element p) 0) in - let b = ((tuple_element p) 1) in + let map = (fun f p -> let a = ((#tuple_element p) 0) in + let b = ((#tuple_element p) 1) in ((f a), (f b))) let a2 = (fun a0 self li x -> ((li (self a0)) x)) @@ -206,14 +206,14 @@ let fixpoly = (fun l -> ((fix a1) l)) - let feven = (fun p n -> let e = ((tuple_element p) 0) in - let o = ((tuple_element p) 1) in + let feven = (fun p n -> let e = ((#tuple_element p) 0) in + let o = ((#tuple_element p) 1) in if ((( = ) n) 0) then 1 else (o ((( - ) n) 1))) - let fodd = (fun p n -> let e = ((tuple_element p) 0) in - let o = ((tuple_element p) 1) in + let fodd = (fun p n -> let e = ((#tuple_element p) 0) in + let o = ((#tuple_element p) 1) in if ((( = ) n) 0) then 0 else (e ((( - ) n) 1))) @@ -229,90 +229,90 @@ let main = let () = (print_int (modd 1)) in let () = (print_int (meven 2)) in - let even = ((tuple_element tie) 0) in - let odd = ((tuple_element tie) 1) in + let even = ((#tuple_element tie) 0) in + let odd = ((#tuple_element tie) 1) in let () = (print_int (odd 3)) in let () = (print_int (even 4)) in 0 $ ./lambda_lifting_runner.exe < manytests/typed/016lists.ml - let rec length = (fun xs -> if (is_empty xs) + let rec length = (fun xs -> if (#is_empty xs) then 0 - else if (not (is_empty xs)) - then let h = (list_head xs) in - let tl = (list_tail xs) in + else if (not (#is_empty xs)) + then let h = (#list_head xs) in + let tl = (#list_tail xs) in ((( + ) 1) (length tl)) - else fail_match) + else #fail_match) - let rec a1 = (fun acc xs -> if (is_empty xs) + let rec a1 = (fun acc xs -> if (#is_empty xs) then acc - else if (not (is_empty xs)) - then let h = (list_head xs) in - let tl = (list_tail xs) in + else if (not (#is_empty xs)) + then let h = (#list_head xs) in + let tl = (#list_tail xs) in ((a1 ((( + ) acc) 1)) tl) - else fail_match) + else #fail_match) let length_tail = (a1 0) - let rec map = (fun f xs -> if (is_empty xs) + let rec map = (fun f xs -> if (#is_empty xs) then [] - else if ((( && ) (not (is_empty xs))) (is_empty (list_tail xs))) - then let a = (list_head xs) in + else if ((( && ) (not (#is_empty xs))) (#is_empty (#list_tail xs))) + then let a = (#list_head xs) in ((f a)::[]) - else if ((( && ) (not (is_empty xs))) (is_empty (list_tail (list_tail xs)))) - then let a = (list_head xs) in - let b = (list_head (list_tail xs)) in + else if ((( && ) (not (#is_empty xs))) (#is_empty (#list_tail (#list_tail xs)))) + then let a = (#list_head xs) in + let b = (#list_head (#list_tail xs)) in ((f a)::((f b)::[])) - else if ((( && ) (not (is_empty xs))) (is_empty (list_tail (list_tail (list_tail xs))))) - then let a = (list_head xs) in - let b = (list_head (list_tail xs)) in - let c = (list_head (list_tail (list_tail xs))) in + else if ((( && ) (not (#is_empty xs))) (#is_empty (#list_tail (#list_tail (#list_tail xs))))) + then let a = (#list_head xs) in + let b = (#list_head (#list_tail xs)) in + let c = (#list_head (#list_tail (#list_tail xs))) in ((f a)::((f b)::((f c)::[]))) - else if (not (is_empty xs)) - then let a = (list_head xs) in - let b = (list_head (list_tail xs)) in - let c = (list_head (list_tail (list_tail xs))) in - let d = (list_head (list_tail (list_tail (list_tail xs)))) in - let tl = (list_tail (list_tail (list_tail (list_tail xs)))) in + else if (not (#is_empty xs)) + then let a = (#list_head xs) in + let b = (#list_head (#list_tail xs)) in + let c = (#list_head (#list_tail (#list_tail xs))) in + let d = (#list_head (#list_tail (#list_tail (#list_tail xs)))) in + let tl = (#list_tail (#list_tail (#list_tail (#list_tail xs)))) in ((f a)::((f b)::((f c)::((f d)::((map f) tl))))) - else fail_match) + else #fail_match) - let rec append = (fun xs ys -> if (is_empty xs) + let rec append = (fun xs ys -> if (#is_empty xs) then ys - else if (not (is_empty xs)) - then let x = (list_head xs) in - let a0 = (list_tail xs) in + else if (not (#is_empty xs)) + then let x = (#list_head xs) in + let a0 = (#list_tail xs) in (x::((append a0) ys)) - else fail_match) + else #fail_match) - let rec a2 = (fun xs -> if (is_empty xs) + let rec a2 = (fun xs -> if (#is_empty xs) then [] - else if (not (is_empty xs)) - then let h = (list_head xs) in - let tl = (list_tail xs) in + else if (not (#is_empty xs)) + then let h = (#list_head xs) in + let tl = (#list_tail xs) in ((append h) (a2 tl)) - else fail_match) + else #fail_match) let concat = a2 - let rec iter = (fun f xs -> if (is_empty xs) + let rec iter = (fun f xs -> if (#is_empty xs) then () - else if (not (is_empty xs)) - then let h = (list_head xs) in - let tl = (list_tail xs) in + else if (not (#is_empty xs)) + then let h = (#list_head xs) in + let tl = (#list_tail xs) in let () = (f h) in ((iter f) tl) - else fail_match) + else #fail_match) let a3 = (fun h a -> (h, a)) - let rec cartesian = (fun xs ys -> if (is_empty xs) + let rec cartesian = (fun xs ys -> if (#is_empty xs) then [] - else if (not (is_empty xs)) - then let h = (list_head xs) in - let tl = (list_tail xs) in + else if (not (#is_empty xs)) + then let h = (#list_head xs) in + let tl = (#list_tail xs) in ((append ((map (a3 h)) ys)) ((cartesian tl) ys)) - else fail_match) + else #fail_match) let main = let () = ((iter print_int) (1::(2::(3::[])))) in let () = (print_int (length ((cartesian (1::(2::[]))) (1::(2::(3::(4::[]))))))) in diff --git a/FML/tests/pe_manytests.t b/FML/tests/pe_manytests.t index 9c91b7b56..cad798fe1 100644 --- a/FML/tests/pe_manytests.t +++ b/FML/tests/pe_manytests.t @@ -104,22 +104,22 @@ ((f 1), (f true)) $ ./pe_runner.exe < manytests/typed/011mapcps.ml - let rec map = (fun f xs k -> if (is_empty xs) + let rec map = (fun f xs k -> if (#is_empty xs) then (k []) - else if (not (is_empty xs)) - then let h = (list_head xs) in - let tl = (list_tail xs) in + else if (not (#is_empty xs)) + then let h = (#list_head xs) in + let tl = (#list_tail xs) in (((map f) tl) (fun tl -> (k ((f h)::tl)))) - else fail_match) + else #fail_match) - let rec iter = (fun f xs -> if (is_empty xs) + let rec iter = (fun f xs -> if (#is_empty xs) then () - else if (not (is_empty xs)) - then let h = (list_head xs) in - let tl = (list_tail xs) in + else if (not (#is_empty xs)) + then let h = (#list_head xs) in + let tl = (#list_tail xs) in let w = (f h) in ((iter f) tl) - else fail_match) + else #fail_match) let main = ((iter print_int) (((map (fun x -> ((( + ) x) 1))) (1::(2::(3::[])))) (fun x -> x))) $ ./pe_runner.exe < manytests/typed/012fibcps.ml @@ -131,13 +131,13 @@ $ ./pe_runner.exe < manytests/typed/013foldfoldr.ml let id = (fun x -> x) - let rec fold_right = (fun f acc xs -> if (is_empty xs) + let rec fold_right = (fun f acc xs -> if (#is_empty xs) then acc - else if (not (is_empty xs)) - then let h = (list_head xs) in - let tl = (list_tail xs) in + else if (not (#is_empty xs)) + then let h = (#list_head xs) in + let tl = (#list_tail xs) in ((f h) (((fold_right f) acc) tl)) - else fail_match) + else #fail_match) let foldl = (fun f a bs -> ((((fold_right (fun b g x -> (g ((f x) b)))) id) bs) a)) @@ -146,20 +146,20 @@ $ ./pe_runner.exe < manytests/typed/015tuples.ml let rec fix = (fun f x -> ((f (fix f)) x)) - let map = (fun f p -> let a = ((tuple_element p) 0) in - let b = ((tuple_element p) 1) in + let map = (fun f p -> let a = ((#tuple_element p) 0) in + let b = ((#tuple_element p) 1) in ((f a), (f b))) let fixpoly = (fun l -> ((fix (fun self l -> ((map (fun li x -> ((li (self l)) x))) l))) l)) - let feven = (fun p n -> let e = ((tuple_element p) 0) in - let o = ((tuple_element p) 1) in + let feven = (fun p n -> let e = ((#tuple_element p) 0) in + let o = ((#tuple_element p) 1) in if ((( = ) n) 0) then 1 else (o ((( - ) n) 1))) - let fodd = (fun p n -> let e = ((tuple_element p) 0) in - let o = ((tuple_element p) 1) in + let fodd = (fun p n -> let e = ((#tuple_element p) 0) in + let o = ((#tuple_element p) 1) in if ((( = ) n) 0) then 0 else (e ((( - ) n) 1))) @@ -175,86 +175,86 @@ let main = let () = (print_int (modd 1)) in let () = (print_int (meven 2)) in - let even = ((tuple_element tie) 0) in - let odd = ((tuple_element tie) 1) in + let even = ((#tuple_element tie) 0) in + let odd = ((#tuple_element tie) 1) in let () = (print_int (odd 3)) in let () = (print_int (even 4)) in 0 $ ./pe_runner.exe < manytests/typed/016lists.ml - let rec length = (fun xs -> if (is_empty xs) + let rec length = (fun xs -> if (#is_empty xs) then 0 - else if (not (is_empty xs)) - then let h = (list_head xs) in - let tl = (list_tail xs) in + else if (not (#is_empty xs)) + then let h = (#list_head xs) in + let tl = (#list_tail xs) in ((( + ) 1) (length tl)) - else fail_match) + else #fail_match) - let length_tail = let rec helper = (fun acc xs -> if (is_empty xs) + let length_tail = let rec helper = (fun acc xs -> if (#is_empty xs) then acc - else if (not (is_empty xs)) - then let h = (list_head xs) in - let tl = (list_tail xs) in + else if (not (#is_empty xs)) + then let h = (#list_head xs) in + let tl = (#list_tail xs) in ((helper ((( + ) acc) 1)) tl) - else fail_match) in + else #fail_match) in (helper 0) - let rec map = (fun f xs -> if (is_empty xs) + let rec map = (fun f xs -> if (#is_empty xs) then [] - else if ((( && ) (not (is_empty xs))) (is_empty (list_tail xs))) - then let a = (list_head xs) in + else if ((( && ) (not (#is_empty xs))) (#is_empty (#list_tail xs))) + then let a = (#list_head xs) in ((f a)::[]) - else if ((( && ) (not (is_empty xs))) (is_empty (list_tail (list_tail xs)))) - then let a = (list_head xs) in - let b = (list_head (list_tail xs)) in + else if ((( && ) (not (#is_empty xs))) (#is_empty (#list_tail (#list_tail xs)))) + then let a = (#list_head xs) in + let b = (#list_head (#list_tail xs)) in ((f a)::((f b)::[])) - else if ((( && ) (not (is_empty xs))) (is_empty (list_tail (list_tail (list_tail xs))))) - then let a = (list_head xs) in - let b = (list_head (list_tail xs)) in - let c = (list_head (list_tail (list_tail xs))) in + else if ((( && ) (not (#is_empty xs))) (#is_empty (#list_tail (#list_tail (#list_tail xs))))) + then let a = (#list_head xs) in + let b = (#list_head (#list_tail xs)) in + let c = (#list_head (#list_tail (#list_tail xs))) in ((f a)::((f b)::((f c)::[]))) - else if (not (is_empty xs)) - then let a = (list_head xs) in - let b = (list_head (list_tail xs)) in - let c = (list_head (list_tail (list_tail xs))) in - let d = (list_head (list_tail (list_tail (list_tail xs)))) in - let tl = (list_tail (list_tail (list_tail (list_tail xs)))) in + else if (not (#is_empty xs)) + then let a = (#list_head xs) in + let b = (#list_head (#list_tail xs)) in + let c = (#list_head (#list_tail (#list_tail xs))) in + let d = (#list_head (#list_tail (#list_tail (#list_tail xs)))) in + let tl = (#list_tail (#list_tail (#list_tail (#list_tail xs)))) in ((f a)::((f b)::((f c)::((f d)::((map f) tl))))) - else fail_match) + else #fail_match) - let rec append = (fun xs ys -> if (is_empty xs) + let rec append = (fun xs ys -> if (#is_empty xs) then ys - else if (not (is_empty xs)) - then let x = (list_head xs) in - let xs = (list_tail xs) in + else if (not (#is_empty xs)) + then let x = (#list_head xs) in + let xs = (#list_tail xs) in (x::((append xs) ys)) - else fail_match) + else #fail_match) - let concat = let rec helper = (fun xs -> if (is_empty xs) + let concat = let rec helper = (fun xs -> if (#is_empty xs) then [] - else if (not (is_empty xs)) - then let h = (list_head xs) in - let tl = (list_tail xs) in + else if (not (#is_empty xs)) + then let h = (#list_head xs) in + let tl = (#list_tail xs) in ((append h) (helper tl)) - else fail_match) in + else #fail_match) in helper - let rec iter = (fun f xs -> if (is_empty xs) + let rec iter = (fun f xs -> if (#is_empty xs) then () - else if (not (is_empty xs)) - then let h = (list_head xs) in - let tl = (list_tail xs) in + else if (not (#is_empty xs)) + then let h = (#list_head xs) in + let tl = (#list_tail xs) in let () = (f h) in ((iter f) tl) - else fail_match) + else #fail_match) - let rec cartesian = (fun xs ys -> if (is_empty xs) + let rec cartesian = (fun xs ys -> if (#is_empty xs) then [] - else if (not (is_empty xs)) - then let h = (list_head xs) in - let tl = (list_tail xs) in + else if (not (#is_empty xs)) + then let h = (#list_head xs) in + let tl = (#list_tail xs) in ((append ((map (fun a -> (h, a))) ys)) ((cartesian tl) ys)) - else fail_match) + else #fail_match) let main = let () = ((iter print_int) (1::(2::(3::[])))) in let () = (print_int (length ((cartesian (1::(2::[]))) (1::(2::(3::(4::[]))))))) in From 61a3d91789d6492b988f84c347e4d661e1ceef97 Mon Sep 17 00:00:00 2001 From: RozhkovAleksandr Date: Tue, 11 Mar 2025 19:04:05 +0300 Subject: [PATCH 34/92] fix maybe --- FML/lib/llvm/codegen.ml | 77 +++++++++++++++++++++++++++++++++++++++++ 1 file changed, 77 insertions(+) diff --git a/FML/lib/llvm/codegen.ml b/FML/lib/llvm/codegen.ml index 45af8ddfd..8de18d5b0 100644 --- a/FML/lib/llvm/codegen.ml +++ b/FML/lib/llvm/codegen.ml @@ -128,3 +128,80 @@ and compile_aexpr = function add_sym name v; compile_aexpr ae ;; + +let declare_func name args = + let arg_types = Array.make (List.length args) i64_t in + let func_type = function_type i64_t arg_types in + declare_function name func_type module_ +;; + +let compile_anf_binding (ALet (name, args, body)) = + let func = declare_func name args in + let bb = append_block ctx "entry" func in + position_at_end bb builder; + + List.iteri (fun i arg_name -> + let arg_value = param func i in + set_value_name arg_name arg_value; + add_sym arg_name arg_value; + ) args; + + let body_val = compile_aexpr body in + let _ = build_ret body_val builder in + func +;; + + +let compile_anf_decl = function + | ADNoRec bindings -> + List.iter (fun binding -> ignore (compile_anf_binding binding)) bindings + | ADREC bindings -> + List.iter (fun (ALet (name, args, _)) -> ignore (declare_func name args)) bindings; + List.iter (fun binding -> ignore (compile_anf_binding binding)) bindings +;; + + + +let init_runtime () = + let runtime_ = + [ "create_closure", function_type i64_t [| i64_t; i64_t; i64_t |] + ; "apply_args_to_closure", var_arg_function_type i64_t [| i64_t; i64_t; i64_t |] + ; "print_int", function_type i64_t [| i64_t |] + ; "print_bool", function_type i64_t [| i64_t |] + ; "add", function_type i64_t [| i64_t; i64_t |] + ; "sub", function_type i64_t [| i64_t; i64_t |] + ; "mul", function_type i64_t [| i64_t; i64_t |] + ; "div", function_type i64_t [| i64_t; i64_t |] + ; "leq", function_type i64_t [| i64_t; i64_t |] + ; "less", function_type i64_t [| i64_t; i64_t |] + ; "geq", function_type i64_t [| i64_t; i64_t |] + ; "gre", function_type i64_t [| i64_t; i64_t |] + ; "eq", function_type i64_t [| i64_t; i64_t |] + ; "neq", function_type i64_t [| i64_t; i64_t |] + ; "and", function_type i64_t [| i64_t; i64_t |] + ; "or", function_type i64_t [| i64_t; i64_t |] + ; "fail_match", function_type i64_t [| i64_t |] + ] + in + List.iter (fun (name, ty) -> ignore (declare_function name ty module_)) runtime_ +;; + + +let create_main program = + let main_type = function_type i64_t [||] in + let main = declare_function "main" main_type module_ in + let bb = append_block ctx "entry" main in + position_at_end bb builder; + + init_runtime (); + + List.iter (fun decl -> ignore (compile_anf_decl decl)) program; + + let _ = build_ret (const_int i64_t 0) builder in + main +;; + +let compile_program program filename = + let _ = create_main program in + print_module filename module_ +;; \ No newline at end of file From adc44da6529293d1bc6635e1df5779904cd275ea Mon Sep 17 00:00:00 2001 From: Dmitry Pilyuk Date: Tue, 11 Mar 2025 21:15:06 +0300 Subject: [PATCH 35/92] Add runner --- FML/bin/bitecode.t | 2 + FML/bin/compiler.ml | 26 ++++++++ FML/bin/dune | 23 +++++++ FML/bin/manytests | 1 + FML/lib/llvm/codegen.ml | 61 ++++++++++++------- FML/lib/llvm/runtime.c | 131 ++++++++++++++++++++++++++++++++++++++-- 6 files changed, 217 insertions(+), 27 deletions(-) create mode 100644 FML/bin/bitecode.t create mode 100644 FML/bin/compiler.ml create mode 120000 FML/bin/manytests diff --git a/FML/bin/bitecode.t b/FML/bin/bitecode.t new file mode 100644 index 000000000..a85cdc019 --- /dev/null +++ b/FML/bin/bitecode.t @@ -0,0 +1,2 @@ + $ ./compiler.exe < manytests/typed/001fac.ml + $ cat < out.ll \ No newline at end of file diff --git a/FML/bin/compiler.ml b/FML/bin/compiler.ml new file mode 100644 index 000000000..fccde0bd0 --- /dev/null +++ b/FML/bin/compiler.ml @@ -0,0 +1,26 @@ +(** Copyright 2024-2025, Dmitry Pilyuk, Aleksandr Rozhkov *) + +(** SPDX-License-Identifier: LGPL-2.1 *) + +open Fml_lib + +let () = + let input = Stdio.In_channel.input_all Stdlib.stdin in + let parse_and_infer input = + match Parser.parse input with + | Ok parsed -> + (match Inferencer.run_program_inferencer parsed with + | Ok types -> Ok (parsed, types) + | Error _ -> Error (Format.asprintf "Infer error.")) + | Error e -> Error (Format.sprintf "Parsing error: %s" e) + in + match parse_and_infer input with + | Ok (ast, _) -> + let bind, cnt, ast = Pattern_elim.run_pe ast in + let bind, cnt, ast = Alpha_conv.run_alpha_conv bind cnt ast in + let ast = Closure_conv.run_cc ast in + let bind, cnt, ast = Lambda_lifting.run_ll bind cnt ast in + let _, _, ast = Anf.run_anf bind cnt ast in + Codegen.compile_program ast + | Error message -> Format.printf "%s" message +;; diff --git a/FML/bin/dune b/FML/bin/dune index e69de29bb..18329ffd0 100644 --- a/FML/bin/dune +++ b/FML/bin/dune @@ -0,0 +1,23 @@ +(executable + (name compiler) + (public_name compiler) + (modules compiler) + (libraries fml_lib stdio)) + +(cram + (applies_to bitecode) + (deps + ./compiler.exe + manytests/typed/001fac.ml + manytests/typed/002fac.ml + manytests/typed/003fib.ml + manytests/typed/004manyargs.ml + manytests/typed/005fix.ml + manytests/typed/006partial.ml + manytests/typed/006partial2.ml + manytests/typed/006partial3.ml + manytests/typed/007order.ml + manytests/typed/008ascription.ml + manytests/typed/009let_poly.ml + manytests/typed/015tuples.ml + manytests/typed/016lists.ml)) diff --git a/FML/bin/manytests b/FML/bin/manytests new file mode 120000 index 000000000..0bd48791d --- /dev/null +++ b/FML/bin/manytests @@ -0,0 +1 @@ +../../manytests \ No newline at end of file diff --git a/FML/lib/llvm/codegen.ml b/FML/lib/llvm/codegen.ml index 8de18d5b0..d5780b0a8 100644 --- a/FML/lib/llvm/codegen.ml +++ b/FML/lib/llvm/codegen.ml @@ -5,8 +5,8 @@ open Llvm open Anf_ast -let sym_to_value : (string, llvalue) Hashtbl.t = Hashtbl.create 1 -let sym_to_type : (string, lltype) Hashtbl.t = Hashtbl.create 1 +let sym_to_value : (string, llvalue) Hashtbl.t = Hashtbl.create 10 +let sym_to_type : (string, lltype) Hashtbl.t = Hashtbl.create 10 let lookup_name name = Hashtbl.find_opt sym_to_value name let lookup_type name = Hashtbl.find_opt sym_to_type name let add_sym name value = Hashtbl.add sym_to_value name value @@ -41,9 +41,31 @@ let compile_binop op x y = | "( - )" -> build_sub x y "sub" builder | "( * )" -> build_mul x y "mul" builder | "( / )" -> build_sdiv x y "div" builder + | "( = )" | "( == )" -> build_icmp Icmp.Eq x y "eq" builder + | "( <> )" | "( != )" -> build_icmp Icmp.Ne x y "ne" builder + | "( > )" -> build_icmp Icmp.Sgt x y "sgt" builder + | "( >= )" -> build_icmp Icmp.Sge x y "sge" builder + | "( < )" -> build_icmp Icmp.Slt x y "slt" builder + | "( <= )" -> build_icmp Icmp.Sle x y "sle" builder | _ -> failwith ("Invalid operator: " ^ op) ;; +let is_binop = function + | "( + )" + | "( - )" + | "( * )" + | "( / )" + | "( = )" + | "( == )" + | "( <> )" + | "( != )" + | "( > )" + | "( >= )" + | "( < )" + | "( <= )" -> true + | _ -> false +;; + let compile_immexpr = function | ImmInt n -> const_int i64_t n | ImmBool b -> const_int i64_t (Bool.to_int b) @@ -71,6 +93,8 @@ let compile_immexpr = function let rec compile_cexpr = function | CImmExpr expr -> compile_immexpr expr + | CEApply (name, [ arg1; arg2 ]) when is_binop name -> + compile_binop name (compile_immexpr arg1) (compile_immexpr arg2) | CEApply (name, args) -> let compiled_args = List.map compile_immexpr args in (match lookup_function name module_ with @@ -139,19 +163,17 @@ let compile_anf_binding (ALet (name, args, body)) = let func = declare_func name args in let bb = append_block ctx "entry" func in position_at_end bb builder; - - List.iteri (fun i arg_name -> - let arg_value = param func i in - set_value_name arg_name arg_value; - add_sym arg_name arg_value; - ) args; - + List.iteri + (fun i arg_name -> + let arg_value = param func i in + set_value_name arg_name arg_value; + add_sym arg_name arg_value) + args; let body_val = compile_aexpr body in let _ = build_ret body_val builder in func ;; - let compile_anf_decl = function | ADNoRec bindings -> List.iter (fun binding -> ignore (compile_anf_binding binding)) bindings @@ -160,14 +182,11 @@ let compile_anf_decl = function List.iter (fun binding -> ignore (compile_anf_binding binding)) bindings ;; - - -let init_runtime () = +let init_runtime = let runtime_ = [ "create_closure", function_type i64_t [| i64_t; i64_t; i64_t |] - ; "apply_args_to_closure", var_arg_function_type i64_t [| i64_t; i64_t; i64_t |] + ; "apply_args", var_arg_function_type i64_t [| i64_t; i64_t; i64_t |] ; "print_int", function_type i64_t [| i64_t |] - ; "print_bool", function_type i64_t [| i64_t |] ; "add", function_type i64_t [| i64_t; i64_t |] ; "sub", function_type i64_t [| i64_t; i64_t |] ; "mul", function_type i64_t [| i64_t; i64_t |] @@ -186,22 +205,18 @@ let init_runtime () = List.iter (fun (name, ty) -> ignore (declare_function name ty module_)) runtime_ ;; - let create_main program = let main_type = function_type i64_t [||] in let main = declare_function "main" main_type module_ in let bb = append_block ctx "entry" main in position_at_end bb builder; - - init_runtime (); - + init_runtime; List.iter (fun decl -> ignore (compile_anf_decl decl)) program; - let _ = build_ret (const_int i64_t 0) builder in main ;; -let compile_program program filename = +let compile_program program = let _ = create_main program in - print_module filename module_ -;; \ No newline at end of file + print_module "out.ll" module_ +;; diff --git a/FML/lib/llvm/runtime.c b/FML/lib/llvm/runtime.c index 0d9b0bbdc..ad07c5287 100644 --- a/FML/lib/llvm/runtime.c +++ b/FML/lib/llvm/runtime.c @@ -1,5 +1,128 @@ -typedef struct -{ - int64_t fun; - int64_t args_num; +#include +#include +#include +#include +#include + +typedef struct closure_t { + int64_t fun_ptr; + int64_t args_num; + int64_t args_applied; + int64_t applied_args[]; } closure_t; + +closure_t *create_closure(int64_t fun_ptr, int64_t args_num, + int64_t args_applied) { + size_t size = sizeof(closure_t) + args_num * sizeof(int64_t); + closure_t *clos = (closure_t *)malloc(size); + clos->fun_ptr = fun_ptr; + clos->args_num = args_num; + clos->args_applied = args_applied; + return clos; +} + +closure_t *empty_closure(int64_t fun_ptr, int64_t args_num) { + return create_closure(fun_ptr, args_num, 0); +} + +int64_t _copy_closure(closure_t *src_clos, int64_t new_args_num, + va_list *new_args) { + int64_t total_args_applied = src_clos->args_applied + new_args_num; + closure_t *new_clos = + create_closure(src_clos->fun_ptr, src_clos->args_num, total_args_applied); + + for (int i = 0; i < src_clos->args_applied; i++) { + new_clos->applied_args[i] = src_clos->applied_args[i]; + } + + for (int i = 0; i < new_args_num; i++) { + new_clos->applied_args[src_clos->args_applied + i] = + va_arg(*new_args, int64_t); + } + + return (int64_t)new_clos; +} + +int64_t call_closure(closure_t *closure, int64_t new_args_num, + va_list *new_args) { + size_t args_count = closure->args_num; + + ffi_cif cif; + ffi_type *arg_types[args_count]; + int64_t *args[args_count]; + + int64_t buffer_new_args[new_args_num]; + + for (int i = 0; i < args_count; ++i) { + arg_types[i] = &ffi_type_sint64; + if (i < closure->args_applied) { + args[i] = &(closure->applied_args[i]); + } else { + int na_num = i - closure->args_applied; + buffer_new_args[na_num] = va_arg(*new_args, int64_t); + args[i] = &(buffer_new_args[na_num]); + } + } + + int64_t res = 0; + + if (ffi_prep_cif(&cif, FFI_DEFAULT_ABI, args_count, &ffi_type_sint64, + arg_types) == FFI_OK) { + ffi_call(&cif, (void *)closure->fun_ptr, &res, (void **)args); + } else { + fprintf(stderr, "call_closure: Failed to prepare call interface\n"); + exit(1); + } + + return res; +} + +int64_t _apply_args_to_closure(closure_t *closure, int64_t new_args_num, + va_list *new_args) { + int64_t args_num_until_apply = closure->args_num - closure->args_applied; + + if (args_num_until_apply <= new_args_num) { + int64_t call_res = call_closure(closure, args_num_until_apply, new_args); + new_args_num -= args_num_until_apply; + if (new_args_num == 0) { + return call_res; + } else { + return _apply_args_to_closure((closure_t *)call_res, new_args_num, + new_args); + } + } else { + return _copy_closure(closure, new_args_num, new_args); + } +} + +int64_t apply_args(int64_t closure_ptr, int64_t new_args_num, ...) { + va_list new_args; + va_start(new_args, new_args_num); + int64_t res = + _apply_args_to_closure((closure_t *)closure_ptr, new_args_num, &new_args); + va_end(new_args); + return res; +} + +int64_t rt_add(int64_t x, int64_t y) { return x + y; } +int64_t rt_sub(int64_t x, int64_t y) { return x - y; } +int64_t rt_mul(int64_t x, int64_t y) { return x * y; } +int64_t rt_divd(int64_t x, int64_t y) { return x / y; } +int64_t rt_eq(int64_t x, int64_t y) { return x == y; } +int64_t rt_neq(int64_t x, int64_t y) { return x != y; } +int64_t rt_less(int64_t x, int64_t y) { return x < y; } +int64_t rt_leq(int64_t x, int64_t y) { return x <= y; } +int64_t rt_gre(int64_t x, int64_t y) { return x > y; } +int64_t rt_geq(int64_t x, int64_t y) { return x >= y; } +int64_t rt_and(int64_t x, int64_t y) { return x && y; } +int64_t rt_or(int64_t x, int64_t y) { return x || y; } + +int64_t print_int(int64_t x) { + printf("%ld\n", x); + return 0; +} + +int64_t fail_match(int64_t _) { + fprintf(stderr, "Match failure\n"); + exit(1); +} \ No newline at end of file From 0b28bc2367aae42ffbe7d529e7860c881df09ee5 Mon Sep 17 00:00:00 2001 From: Dmitry Pilyuk Date: Tue, 11 Mar 2025 21:49:20 +0300 Subject: [PATCH 36/92] fixes --- FML/lib/llvm/codegen.ml | 36 +++++++++++++++++++++--------------- 1 file changed, 21 insertions(+), 15 deletions(-) diff --git a/FML/lib/llvm/codegen.ml b/FML/lib/llvm/codegen.ml index d5780b0a8..89490c613 100644 --- a/FML/lib/llvm/codegen.ml +++ b/FML/lib/llvm/codegen.ml @@ -98,8 +98,8 @@ let rec compile_cexpr = function | CEApply (name, args) -> let compiled_args = List.map compile_immexpr args in (match lookup_function name module_ with - | Some f when Array.length (params f) = List.length args -> - build_call (type_of f) f (Array.of_list compiled_args) name builder + (* | Some f when Array.length (params f) = List.length args -> + build_call (type_of f) f (Array.of_list compiled_args) name builder *) | Some f -> let fun_ptr = build_ptrtoint f i64_t "" builder in let cl = @@ -112,7 +112,7 @@ let rec compile_cexpr = function in build_call (var_arg_function_type i64_t [| i64_t; i64_t |]) - (Option.get (lookup_function "apply_args_to_closure" module_)) + (Option.get (lookup_function "apply_args" module_)) (Array.of_list ([ cl; const_int i64_t (List.length compiled_args) ] @ compiled_args)) "applied_closure" @@ -160,18 +160,24 @@ let declare_func name args = ;; let compile_anf_binding (ALet (name, args, body)) = - let func = declare_func name args in - let bb = append_block ctx "entry" func in - position_at_end bb builder; - List.iteri - (fun i arg_name -> - let arg_value = param func i in - set_value_name arg_name arg_value; - add_sym arg_name arg_value) - args; - let body_val = compile_aexpr body in - let _ = build_ret body_val builder in - func + if List.length args = 0 + then ( + let body = compile_aexpr body in + let gvar = define_global name (const_int i64_t 0) module_ in + ignore (build_store body gvar builder)) + else ( + let func = declare_func name args in + let bb = append_block ctx "entry" func in + position_at_end bb builder; + List.iteri + (fun i arg_name -> + let arg_value = param func i in + set_value_name arg_name arg_value; + add_sym arg_name arg_value) + args; + let body_val = compile_aexpr body in + let _ = build_ret body_val builder in + ignore func) ;; let compile_anf_decl = function From 392baccd6983f97e9958fbf49a7f59f7490a6b8a Mon Sep 17 00:00:00 2001 From: Dmitry Pilyuk Date: Tue, 11 Mar 2025 22:11:22 +0300 Subject: [PATCH 37/92] Add exec tests --- FML/bin/dune | 19 ++++++ FML/bin/llvm_exec.t | 5 ++ FML/bin/runtime.c | 128 ++++++++++++++++++++++++++++++++++++++++ FML/lib/llvm/codegen.ml | 12 ++-- 4 files changed, 158 insertions(+), 6 deletions(-) create mode 100644 FML/bin/llvm_exec.t create mode 100644 FML/bin/runtime.c diff --git a/FML/bin/dune b/FML/bin/dune index 18329ffd0..05fe320ec 100644 --- a/FML/bin/dune +++ b/FML/bin/dune @@ -21,3 +21,22 @@ manytests/typed/009let_poly.ml manytests/typed/015tuples.ml manytests/typed/016lists.ml)) + +(cram + (applies_to llvm_exec) + (deps + runtime.c + ./compiler.exe + manytests/typed/001fac.ml + manytests/typed/002fac.ml + manytests/typed/003fib.ml + manytests/typed/004manyargs.ml + manytests/typed/005fix.ml + manytests/typed/006partial.ml + manytests/typed/006partial2.ml + manytests/typed/006partial3.ml + manytests/typed/007order.ml + manytests/typed/008ascription.ml + manytests/typed/009let_poly.ml + manytests/typed/015tuples.ml + manytests/typed/016lists.ml)) diff --git a/FML/bin/llvm_exec.t b/FML/bin/llvm_exec.t new file mode 100644 index 000000000..38de41563 --- /dev/null +++ b/FML/bin/llvm_exec.t @@ -0,0 +1,5 @@ + $ clang-16 -c runtime.c -o runtime.o + + $ ./compiler.exe < manytests/typed/001fac.ml + $ clang-16 out.ll runtime.o -lffi -o 001fac + $ ./001fac \ No newline at end of file diff --git a/FML/bin/runtime.c b/FML/bin/runtime.c new file mode 100644 index 000000000..ad07c5287 --- /dev/null +++ b/FML/bin/runtime.c @@ -0,0 +1,128 @@ +#include +#include +#include +#include +#include + +typedef struct closure_t { + int64_t fun_ptr; + int64_t args_num; + int64_t args_applied; + int64_t applied_args[]; +} closure_t; + +closure_t *create_closure(int64_t fun_ptr, int64_t args_num, + int64_t args_applied) { + size_t size = sizeof(closure_t) + args_num * sizeof(int64_t); + closure_t *clos = (closure_t *)malloc(size); + clos->fun_ptr = fun_ptr; + clos->args_num = args_num; + clos->args_applied = args_applied; + return clos; +} + +closure_t *empty_closure(int64_t fun_ptr, int64_t args_num) { + return create_closure(fun_ptr, args_num, 0); +} + +int64_t _copy_closure(closure_t *src_clos, int64_t new_args_num, + va_list *new_args) { + int64_t total_args_applied = src_clos->args_applied + new_args_num; + closure_t *new_clos = + create_closure(src_clos->fun_ptr, src_clos->args_num, total_args_applied); + + for (int i = 0; i < src_clos->args_applied; i++) { + new_clos->applied_args[i] = src_clos->applied_args[i]; + } + + for (int i = 0; i < new_args_num; i++) { + new_clos->applied_args[src_clos->args_applied + i] = + va_arg(*new_args, int64_t); + } + + return (int64_t)new_clos; +} + +int64_t call_closure(closure_t *closure, int64_t new_args_num, + va_list *new_args) { + size_t args_count = closure->args_num; + + ffi_cif cif; + ffi_type *arg_types[args_count]; + int64_t *args[args_count]; + + int64_t buffer_new_args[new_args_num]; + + for (int i = 0; i < args_count; ++i) { + arg_types[i] = &ffi_type_sint64; + if (i < closure->args_applied) { + args[i] = &(closure->applied_args[i]); + } else { + int na_num = i - closure->args_applied; + buffer_new_args[na_num] = va_arg(*new_args, int64_t); + args[i] = &(buffer_new_args[na_num]); + } + } + + int64_t res = 0; + + if (ffi_prep_cif(&cif, FFI_DEFAULT_ABI, args_count, &ffi_type_sint64, + arg_types) == FFI_OK) { + ffi_call(&cif, (void *)closure->fun_ptr, &res, (void **)args); + } else { + fprintf(stderr, "call_closure: Failed to prepare call interface\n"); + exit(1); + } + + return res; +} + +int64_t _apply_args_to_closure(closure_t *closure, int64_t new_args_num, + va_list *new_args) { + int64_t args_num_until_apply = closure->args_num - closure->args_applied; + + if (args_num_until_apply <= new_args_num) { + int64_t call_res = call_closure(closure, args_num_until_apply, new_args); + new_args_num -= args_num_until_apply; + if (new_args_num == 0) { + return call_res; + } else { + return _apply_args_to_closure((closure_t *)call_res, new_args_num, + new_args); + } + } else { + return _copy_closure(closure, new_args_num, new_args); + } +} + +int64_t apply_args(int64_t closure_ptr, int64_t new_args_num, ...) { + va_list new_args; + va_start(new_args, new_args_num); + int64_t res = + _apply_args_to_closure((closure_t *)closure_ptr, new_args_num, &new_args); + va_end(new_args); + return res; +} + +int64_t rt_add(int64_t x, int64_t y) { return x + y; } +int64_t rt_sub(int64_t x, int64_t y) { return x - y; } +int64_t rt_mul(int64_t x, int64_t y) { return x * y; } +int64_t rt_divd(int64_t x, int64_t y) { return x / y; } +int64_t rt_eq(int64_t x, int64_t y) { return x == y; } +int64_t rt_neq(int64_t x, int64_t y) { return x != y; } +int64_t rt_less(int64_t x, int64_t y) { return x < y; } +int64_t rt_leq(int64_t x, int64_t y) { return x <= y; } +int64_t rt_gre(int64_t x, int64_t y) { return x > y; } +int64_t rt_geq(int64_t x, int64_t y) { return x >= y; } +int64_t rt_and(int64_t x, int64_t y) { return x && y; } +int64_t rt_or(int64_t x, int64_t y) { return x || y; } + +int64_t print_int(int64_t x) { + printf("%ld\n", x); + return 0; +} + +int64_t fail_match(int64_t _) { + fprintf(stderr, "Match failure\n"); + exit(1); +} \ No newline at end of file diff --git a/FML/lib/llvm/codegen.ml b/FML/lib/llvm/codegen.ml index 89490c613..bed06a56f 100644 --- a/FML/lib/llvm/codegen.ml +++ b/FML/lib/llvm/codegen.ml @@ -160,7 +160,7 @@ let declare_func name args = ;; let compile_anf_binding (ALet (name, args, body)) = - if List.length args = 0 + if List.length args = 0 && name <> "main" then ( let body = compile_aexpr body in let gvar = define_global name (const_int i64_t 0) module_ in @@ -212,14 +212,14 @@ let init_runtime = ;; let create_main program = - let main_type = function_type i64_t [||] in - let main = declare_function "main" main_type module_ in - let bb = append_block ctx "entry" main in - position_at_end bb builder; + (* let main_type = function_type i64_t [||] in + let main = declare_function "main" main_type module_ in + let bb = append_block ctx "entry" main in + position_at_end bb builder; *) init_runtime; List.iter (fun decl -> ignore (compile_anf_decl decl)) program; let _ = build_ret (const_int i64_t 0) builder in - main + () ;; let compile_program program = From e8f3c1404cfe662e11504f432be7414a309c8cba Mon Sep 17 00:00:00 2001 From: Dmitry Pilyuk Date: Tue, 11 Mar 2025 22:18:41 +0300 Subject: [PATCH 38/92] fix type --- FML/lib/llvm/codegen.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/FML/lib/llvm/codegen.ml b/FML/lib/llvm/codegen.ml index bed06a56f..b95b63230 100644 --- a/FML/lib/llvm/codegen.ml +++ b/FML/lib/llvm/codegen.ml @@ -119,9 +119,9 @@ let rec compile_cexpr = function builder | None -> failwith "Not a function") | CEIf (cond, then_e, else_e) -> - let cond_v = - build_icmp Icmp.Ne (compile_immexpr cond) (const_int i64_t 0) "cond_v" builder - in + (* let cond_v = + build_icmp Icmp.Ne (compile_immexpr cond) (const_int i64_t 0) "cond_v" builder *) + let cond_v = compile_immexpr in let entry_block = insertion_block builder in let parent = block_parent entry_block in let then_block = append_block ctx "then" parent in From de464b26c034880c7073a0306ce1d7512e878e6c Mon Sep 17 00:00:00 2001 From: Dmitry Pilyuk Date: Tue, 11 Mar 2025 22:31:07 +0300 Subject: [PATCH 39/92] Fix exception --- FML/lib/llvm/codegen.ml | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/FML/lib/llvm/codegen.ml b/FML/lib/llvm/codegen.ml index b95b63230..d93f65970 100644 --- a/FML/lib/llvm/codegen.ml +++ b/FML/lib/llvm/codegen.ml @@ -117,11 +117,17 @@ let rec compile_cexpr = function ([ cl; const_int i64_t (List.length compiled_args) ] @ compiled_args)) "applied_closure" builder - | None -> failwith "Not a function") + | None -> + (match lookup_global name module_ with + | Some g -> g + | None -> + (match lookup_name name with + | Some v -> v + | None -> failwith ("Unknown variable: " ^ name)))) | CEIf (cond, then_e, else_e) -> (* let cond_v = build_icmp Icmp.Ne (compile_immexpr cond) (const_int i64_t 0) "cond_v" builder *) - let cond_v = compile_immexpr in + let cond_v = compile_immexpr cond in let entry_block = insertion_block builder in let parent = block_parent entry_block in let then_block = append_block ctx "then" parent in From efe194d0b0516853e6a2683937b985c7cae2b393 Mon Sep 17 00:00:00 2001 From: Dmitry Pilyuk Date: Tue, 11 Mar 2025 22:57:26 +0300 Subject: [PATCH 40/92] Fix apply --- FML/lib/llvm/codegen.ml | 27 +++++++++++++++++++-------- 1 file changed, 19 insertions(+), 8 deletions(-) diff --git a/FML/lib/llvm/codegen.ml b/FML/lib/llvm/codegen.ml index d93f65970..2303a5575 100644 --- a/FML/lib/llvm/codegen.ml +++ b/FML/lib/llvm/codegen.ml @@ -100,7 +100,16 @@ let rec compile_cexpr = function (match lookup_function name module_ with (* | Some f when Array.length (params f) = List.length args -> build_call (type_of f) f (Array.of_list compiled_args) name builder *) - | Some f -> + | Some _ -> + let f = compile_immexpr (ImmIdentifier name) in + build_call + (var_arg_function_type i64_t [| i64_t; i64_t |]) + (Option.get (lookup_function "apply_args" module_)) + (Array.of_list + ([ f; const_int i64_t (List.length compiled_args) ] @ compiled_args)) + "applied_closure" + builder + (* | Some f -> let fun_ptr = build_ptrtoint f i64_t "" builder in let cl = build_call @@ -116,14 +125,16 @@ let rec compile_cexpr = function (Array.of_list ([ cl; const_int i64_t (List.length compiled_args) ] @ compiled_args)) "applied_closure" - builder + builder *) | None -> - (match lookup_global name module_ with - | Some g -> g - | None -> - (match lookup_name name with - | Some v -> v - | None -> failwith ("Unknown variable: " ^ name)))) + let f = compile_immexpr (ImmIdentifier name) in + build_call + (var_arg_function_type i64_t [| i64_t; i64_t |]) + (Option.get (lookup_function "apply_args" module_)) + (Array.of_list + ([ f; const_int i64_t (List.length compiled_args) ] @ compiled_args)) + "applied_closure" + builder) | CEIf (cond, then_e, else_e) -> (* let cond_v = build_icmp Icmp.Ne (compile_immexpr cond) (const_int i64_t 0) "cond_v" builder *) From 144cd41a19e6917cd3332a0b5f898691bb0dbe5a Mon Sep 17 00:00:00 2001 From: RozhkovAleksandr Date: Tue, 11 Mar 2025 23:07:04 +0300 Subject: [PATCH 41/92] fix all bugs --- FML/bin/bitecode.t | 86 ++++++++++++++++++++++++++++++++++++++++- FML/bin/dune | 1 + FML/bin/llvm_exec.t | 57 ++++++++++++++++++++++++++- FML/lib/llvm/codegen.ml | 64 +++++++++++++++--------------- 4 files changed, 173 insertions(+), 35 deletions(-) diff --git a/FML/bin/bitecode.t b/FML/bin/bitecode.t index a85cdc019..dd4c92fde 100644 --- a/FML/bin/bitecode.t +++ b/FML/bin/bitecode.t @@ -1,2 +1,84 @@ - $ ./compiler.exe < manytests/typed/001fac.ml - $ cat < out.ll \ No newline at end of file + $ ./compiler.exe < manytests/typed/002fac.ml + $ cat < out.ll + ; ModuleID = 'FML' + source_filename = "FML" + target triple = "x86_64-pc-linux-gnu" + + declare i64 @create_closure(i64, i64, i64) + + declare i64 @apply_args(i64, i64, i64, ...) + + declare i64 @print_int(i64) + + declare i64 @rt_add(i64, i64) + + declare i64 @rt_sub(i64, i64) + + declare i64 @rt_mul(i64, i64) + + declare i64 @rt_div(i64, i64) + + declare i64 @rt_leq(i64, i64) + + declare i64 @rt_less(i64, i64) + + declare i64 @rt_geq(i64, i64) + + declare i64 @rt_gre(i64, i64) + + declare i64 @rt_eq(i64, i64) + + declare i64 @rt_neq(i64, i64) + + declare i64 @rt_and(i64, i64) + + declare i64 @rt_or(i64, i64) + + declare i64 @fail_match(i64) + + define i64 @a1(i64 %k, i64 %n, i64 %p) { + entry: + %mul = mul i64 %p, %n + %applied_closure = call i64 (i64, i64, ...) @apply_args(i64 %k, i64 1, i64 %mul) + ret i64 %applied_closure + } + + define i64 @fac_cps(i64 %n, i64 %k) { + entry: + %empty_closure = call i64 @create_closure(i64 ptrtoint (ptr @rt_eq to i64), i64 2, i64 0) + %applied_closure = call i64 (i64, i64, ...) @apply_args(i64 %empty_closure, i64 2, i64 %n, i64 1) + %cond_v = icmp ne i64 %applied_closure, 0 + br i1 %cond_v, label %then, label %else + + then: ; preds = %entry + %applied_closure1 = call i64 (i64, i64, ...) @apply_args(i64 %k, i64 1, i64 1) + br label %merge + + else: ; preds = %entry + %empty_closure2 = call i64 @create_closure(i64 ptrtoint (ptr @a1 to i64), i64 3, i64 0) + %applied_closure3 = call i64 (i64, i64, ...) @apply_args(i64 %empty_closure2, i64 2, i64 %k, i64 %n) + %sub = sub i64 %n, 1 + %empty_closure4 = call i64 @create_closure(i64 ptrtoint (ptr @fac_cps to i64), i64 2, i64 0) + %applied_closure5 = call i64 (i64, i64, ...) @apply_args(i64 %empty_closure4, i64 2, i64 %sub, i64 %applied_closure3) + br label %merge + + merge: ; preds = %else, %then + %phi = phi i64 [ %applied_closure1, %then ], [ %applied_closure5, %else ] + ret i64 %phi + } + + define i64 @a2(i64 %a0) { + entry: + ret i64 %a0 + } + + define i64 @main() { + entry: + %empty_closure = call i64 @create_closure(i64 ptrtoint (ptr @a2 to i64), i64 1, i64 0) + %empty_closure1 = call i64 @create_closure(i64 ptrtoint (ptr @fac_cps to i64), i64 2, i64 0) + %applied_closure = call i64 (i64, i64, ...) @apply_args(i64 %empty_closure1, i64 2, i64 4, i64 %empty_closure) + %empty_closure2 = call i64 @create_closure(i64 ptrtoint (ptr @print_int to i64), i64 1, i64 0) + %applied_closure3 = call i64 (i64, i64, ...) @apply_args(i64 %empty_closure2, i64 1, i64 %applied_closure) + ret i64 0 + ret i64 0 + } diff --git a/FML/bin/dune b/FML/bin/dune index 05fe320ec..c2a65ab9d 100644 --- a/FML/bin/dune +++ b/FML/bin/dune @@ -38,5 +38,6 @@ manytests/typed/007order.ml manytests/typed/008ascription.ml manytests/typed/009let_poly.ml + manytests/typed/012fibcps.ml manytests/typed/015tuples.ml manytests/typed/016lists.ml)) diff --git a/FML/bin/llvm_exec.t b/FML/bin/llvm_exec.t index 38de41563..40d9fa1a1 100644 --- a/FML/bin/llvm_exec.t +++ b/FML/bin/llvm_exec.t @@ -2,4 +2,59 @@ $ ./compiler.exe < manytests/typed/001fac.ml $ clang-16 out.ll runtime.o -lffi -o 001fac - $ ./001fac \ No newline at end of file + $ ./001fac + 24 + + $ ./compiler.exe < manytests/typed/002fac.ml + $ clang-16 out.ll runtime.o -lffi -o 002fac + $ ./002fac + 24 + + $ ./compiler.exe < manytests/typed/003fib.ml + $ clang-16 out.ll runtime.o -lffi -o 003fib + $ ./003fib + 3 + 3 + + $ ./compiler.exe < manytests/typed/004manyargs.ml + $ clang-16 out.ll runtime.o -lffi -o 004manyargs + $ ./004manyargs + 1111111111 + 1 + 10 + 100 + + $ ./compiler.exe < manytests/typed/005fix.ml + $ clang-16 out.ll runtime.o -lffi -o 005fix + $ ./005fix + 720 + + $ ./compiler.exe < manytests/typed/006partial.ml + $ clang-16 out.ll runtime.o -lffi -o 006partial + $ ./006partial + 1122 + + $ ./compiler.exe < manytests/typed/006partial2.ml + $ clang-16 out.ll runtime.o -lffi -o 006partial2 + $ ./006partial2 + 1 + 2 + 3 + 7 + + $ ./compiler.exe < manytests/typed/006partial3.ml + $ clang-16 out.ll runtime.o -lffi -o 006partial3 + $ ./006partial3 + 4 + 8 + 9 + + $ ./compiler.exe < manytests/typed/008ascription.ml + $ clang-16 out.ll runtime.o -lffi -o 008ascription + $ ./008ascription + 8 + + $ ./compiler.exe < manytests/typed/012fibcps.ml + $ clang-16 out.ll runtime.o -lffi -o 012fibcps + $ ./012fibcps + 8 diff --git a/FML/lib/llvm/codegen.ml b/FML/lib/llvm/codegen.ml index 2303a5575..6d818574f 100644 --- a/FML/lib/llvm/codegen.ml +++ b/FML/lib/llvm/codegen.ml @@ -13,18 +13,18 @@ let add_sym name value = Hashtbl.add sym_to_value name value let add_type name ty = Hashtbl.add sym_to_type name ty let id_to_runtime_name = function - | "( + )" -> "add" - | "( - )" -> "sub" - | "( * )" -> "mul" - | "( / )" -> "divd" - | "( = )" -> "eq" - | "( != )" -> "neq" - | "( < )" -> "less" - | "( <= )" -> "leq" - | "( > )" -> "gre" - | "( >= )" -> "geq" - | "( && )" -> "and" - | "( || )" -> "or" + | "( + )" -> "rt_add" + | "( - )" -> "rt_sub" + | "( * )" -> "rt_mul" + | "( / )" -> "rt_divd" + | "( = )" -> "rt_eq" + | "( != )" -> "rt_neq" + | "( < )" -> "rt_less" + | "( <= )" -> "rt_leq" + | "( > )" -> "rt_gre" + | "( >= )" -> "rt_geq" + | "( && )" -> "rt_and" + | "( || )" -> "rt_or" | other -> other ;; @@ -41,12 +41,12 @@ let compile_binop op x y = | "( - )" -> build_sub x y "sub" builder | "( * )" -> build_mul x y "mul" builder | "( / )" -> build_sdiv x y "div" builder - | "( = )" | "( == )" -> build_icmp Icmp.Eq x y "eq" builder + (* | "( = )" | "( == )" -> build_icmp Icmp.Eq x y "eq" builder | "( <> )" | "( != )" -> build_icmp Icmp.Ne x y "ne" builder | "( > )" -> build_icmp Icmp.Sgt x y "sgt" builder | "( >= )" -> build_icmp Icmp.Sge x y "sge" builder | "( < )" -> build_icmp Icmp.Slt x y "slt" builder - | "( <= )" -> build_icmp Icmp.Sle x y "sle" builder + | "( <= )" -> build_icmp Icmp.Sle x y "sle" builder *) | _ -> failwith ("Invalid operator: " ^ op) ;; @@ -54,15 +54,15 @@ let is_binop = function | "( + )" | "( - )" | "( * )" - | "( / )" - | "( = )" + | "( / )" -> true + (* | "( = )" | "( == )" | "( <> )" | "( != )" | "( > )" | "( >= )" | "( < )" - | "( <= )" -> true + | "( <= )" -> true *) | _ -> false ;; @@ -136,9 +136,9 @@ let rec compile_cexpr = function "applied_closure" builder) | CEIf (cond, then_e, else_e) -> - (* let cond_v = - build_icmp Icmp.Ne (compile_immexpr cond) (const_int i64_t 0) "cond_v" builder *) - let cond_v = compile_immexpr cond in + let cond_v = + build_icmp Icmp.Ne (compile_immexpr cond) (const_int i64_t 0) "cond_v" builder in + (* let cond_v = compile_immexpr cond in *) let entry_block = insertion_block builder in let parent = block_parent entry_block in let then_block = append_block ctx "then" parent in @@ -210,18 +210,18 @@ let init_runtime = [ "create_closure", function_type i64_t [| i64_t; i64_t; i64_t |] ; "apply_args", var_arg_function_type i64_t [| i64_t; i64_t; i64_t |] ; "print_int", function_type i64_t [| i64_t |] - ; "add", function_type i64_t [| i64_t; i64_t |] - ; "sub", function_type i64_t [| i64_t; i64_t |] - ; "mul", function_type i64_t [| i64_t; i64_t |] - ; "div", function_type i64_t [| i64_t; i64_t |] - ; "leq", function_type i64_t [| i64_t; i64_t |] - ; "less", function_type i64_t [| i64_t; i64_t |] - ; "geq", function_type i64_t [| i64_t; i64_t |] - ; "gre", function_type i64_t [| i64_t; i64_t |] - ; "eq", function_type i64_t [| i64_t; i64_t |] - ; "neq", function_type i64_t [| i64_t; i64_t |] - ; "and", function_type i64_t [| i64_t; i64_t |] - ; "or", function_type i64_t [| i64_t; i64_t |] + ; "rt_add", function_type i64_t [| i64_t; i64_t |] + ; "rt_sub", function_type i64_t [| i64_t; i64_t |] + ; "rt_mul", function_type i64_t [| i64_t; i64_t |] + ; "rt_div", function_type i64_t [| i64_t; i64_t |] + ; "rt_leq", function_type i64_t [| i64_t; i64_t |] + ; "rt_less", function_type i64_t [| i64_t; i64_t |] + ; "rt_geq", function_type i64_t [| i64_t; i64_t |] + ; "rt_gre", function_type i64_t [| i64_t; i64_t |] + ; "rt_eq", function_type i64_t [| i64_t; i64_t |] + ; "rt_neq", function_type i64_t [| i64_t; i64_t |] + ; "rt_and", function_type i64_t [| i64_t; i64_t |] + ; "rt_or", function_type i64_t [| i64_t; i64_t |] ; "fail_match", function_type i64_t [| i64_t |] ] in From 10428ced4df48c0df08b45ce94ddeac13f73dadc Mon Sep 17 00:00:00 2001 From: RozhkovAleksandr Date: Tue, 11 Mar 2025 23:12:21 +0300 Subject: [PATCH 42/92] add some tests --- FML/bin/bitecode.t | 70 ++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 70 insertions(+) diff --git a/FML/bin/bitecode.t b/FML/bin/bitecode.t index dd4c92fde..3b26797ca 100644 --- a/FML/bin/bitecode.t +++ b/FML/bin/bitecode.t @@ -1,3 +1,73 @@ + $ ./compiler.exe < manytests/typed/001fac.ml + $ cat < out.ll + ; ModuleID = 'FML' + source_filename = "FML" + target triple = "x86_64-pc-linux-gnu" + + declare i64 @create_closure(i64, i64, i64) + + declare i64 @apply_args(i64, i64, i64, ...) + + declare i64 @print_int(i64) + + declare i64 @rt_add(i64, i64) + + declare i64 @rt_sub(i64, i64) + + declare i64 @rt_mul(i64, i64) + + declare i64 @rt_div(i64, i64) + + declare i64 @rt_leq(i64, i64) + + declare i64 @rt_less(i64, i64) + + declare i64 @rt_geq(i64, i64) + + declare i64 @rt_gre(i64, i64) + + declare i64 @rt_eq(i64, i64) + + declare i64 @rt_neq(i64, i64) + + declare i64 @rt_and(i64, i64) + + declare i64 @rt_or(i64, i64) + + declare i64 @fail_match(i64) + + define i64 @fac(i64 %n) { + entry: + %empty_closure = call i64 @create_closure(i64 ptrtoint (ptr @rt_leq to i64), i64 2, i64 0) + %applied_closure = call i64 (i64, i64, ...) @apply_args(i64 %empty_closure, i64 2, i64 %n, i64 1) + %cond_v = icmp ne i64 %applied_closure, 0 + br i1 %cond_v, label %then, label %else + + then: ; preds = %entry + br label %merge + + else: ; preds = %entry + %sub = sub i64 %n, 1 + %empty_closure1 = call i64 @create_closure(i64 ptrtoint (ptr @fac to i64), i64 1, i64 0) + %applied_closure2 = call i64 (i64, i64, ...) @apply_args(i64 %empty_closure1, i64 1, i64 %sub) + %mul = mul i64 %n, %applied_closure2 + br label %merge + + merge: ; preds = %else, %then + %phi = phi i64 [ 1, %then ], [ %mul, %else ] + ret i64 %phi + } + + define i64 @main() { + entry: + %empty_closure = call i64 @create_closure(i64 ptrtoint (ptr @fac to i64), i64 1, i64 0) + %applied_closure = call i64 (i64, i64, ...) @apply_args(i64 %empty_closure, i64 1, i64 4) + %empty_closure1 = call i64 @create_closure(i64 ptrtoint (ptr @print_int to i64), i64 1, i64 0) + %applied_closure2 = call i64 (i64, i64, ...) @apply_args(i64 %empty_closure1, i64 1, i64 %applied_closure) + ret i64 0 + ret i64 0 + } + $ ./compiler.exe < manytests/typed/002fac.ml $ cat < out.ll ; ModuleID = 'FML' From f1fefcbd182e32653a0c8732e5e1b3c8c1f86687 Mon Sep 17 00:00:00 2001 From: RozhkovAleksandr Date: Tue, 11 Mar 2025 23:24:54 +0300 Subject: [PATCH 43/92] clean code --- FML/lib/anf/closure_conv.ml | 1 - 1 file changed, 1 deletion(-) diff --git a/FML/lib/anf/closure_conv.ml b/FML/lib/anf/closure_conv.ml index 67f644e07..d8fa688b3 100644 --- a/FML/lib/anf/closure_conv.ml +++ b/FML/lib/anf/closure_conv.ml @@ -22,7 +22,6 @@ let rec free_vars binded = | Pe_ELet (Rec, name, e1, e2) -> let binded = add binded name in union (free_vars binded e1) (free_vars binded e2) - (* hmmmmm....*) | Pe_ECons (e1, e2) -> union (free_vars binded e1) (free_vars binded e2) | Pe_ETuple es -> List.fold es ~init:empty ~f:(fun acc e -> union acc (free_vars binded e)) From 9196ce47ae7499f48199ae1b3cf3dedade0cd73f Mon Sep 17 00:00:00 2001 From: Dmitry Pilyuk Date: Wed, 12 Mar 2025 00:29:42 +0300 Subject: [PATCH 44/92] Improve not partial apply --- FML/bin/bitecode.t | 40 ++++++------- FML/lib/llvm/codegen.ml | 72 ++++++---------------- FML/lib/llvm/runtime.c | 128 ---------------------------------------- 3 files changed, 36 insertions(+), 204 deletions(-) delete mode 100644 FML/lib/llvm/runtime.c diff --git a/FML/bin/bitecode.t b/FML/bin/bitecode.t index 3b26797ca..0a210c67d 100644 --- a/FML/bin/bitecode.t +++ b/FML/bin/bitecode.t @@ -38,9 +38,9 @@ define i64 @fac(i64 %n) { entry: - %empty_closure = call i64 @create_closure(i64 ptrtoint (ptr @rt_leq to i64), i64 2, i64 0) - %applied_closure = call i64 (i64, i64, ...) @apply_args(i64 %empty_closure, i64 2, i64 %n, i64 1) - %cond_v = icmp ne i64 %applied_closure, 0 + %sle = icmp sle i64 %n, 1 + %sle_i64t = zext i1 %sle to i64 + %cond_v = icmp ne i64 %sle_i64t, 0 br i1 %cond_v, label %then, label %else then: ; preds = %entry @@ -48,9 +48,8 @@ else: ; preds = %entry %sub = sub i64 %n, 1 - %empty_closure1 = call i64 @create_closure(i64 ptrtoint (ptr @fac to i64), i64 1, i64 0) - %applied_closure2 = call i64 (i64, i64, ...) @apply_args(i64 %empty_closure1, i64 1, i64 %sub) - %mul = mul i64 %n, %applied_closure2 + %call = call i64 @fac(i64 %sub) + %mul = mul i64 %n, %call br label %merge merge: ; preds = %else, %then @@ -60,10 +59,8 @@ define i64 @main() { entry: - %empty_closure = call i64 @create_closure(i64 ptrtoint (ptr @fac to i64), i64 1, i64 0) - %applied_closure = call i64 (i64, i64, ...) @apply_args(i64 %empty_closure, i64 1, i64 4) - %empty_closure1 = call i64 @create_closure(i64 ptrtoint (ptr @print_int to i64), i64 1, i64 0) - %applied_closure2 = call i64 (i64, i64, ...) @apply_args(i64 %empty_closure1, i64 1, i64 %applied_closure) + %call = call i64 @fac(i64 4) + %call1 = call i64 @print_int(i64 %call) ret i64 0 ret i64 0 } @@ -115,25 +112,24 @@ define i64 @fac_cps(i64 %n, i64 %k) { entry: - %empty_closure = call i64 @create_closure(i64 ptrtoint (ptr @rt_eq to i64), i64 2, i64 0) - %applied_closure = call i64 (i64, i64, ...) @apply_args(i64 %empty_closure, i64 2, i64 %n, i64 1) - %cond_v = icmp ne i64 %applied_closure, 0 + %eq = icmp eq i64 %n, 1 + %eq_i64t = zext i1 %eq to i64 + %cond_v = icmp ne i64 %eq_i64t, 0 br i1 %cond_v, label %then, label %else then: ; preds = %entry - %applied_closure1 = call i64 (i64, i64, ...) @apply_args(i64 %k, i64 1, i64 1) + %applied_closure = call i64 (i64, i64, ...) @apply_args(i64 %k, i64 1, i64 1) br label %merge else: ; preds = %entry - %empty_closure2 = call i64 @create_closure(i64 ptrtoint (ptr @a1 to i64), i64 3, i64 0) - %applied_closure3 = call i64 (i64, i64, ...) @apply_args(i64 %empty_closure2, i64 2, i64 %k, i64 %n) + %empty_closure = call i64 @create_closure(i64 ptrtoint (ptr @a1 to i64), i64 3, i64 0) + %applied_closure1 = call i64 (i64, i64, ...) @apply_args(i64 %empty_closure, i64 2, i64 %k, i64 %n) %sub = sub i64 %n, 1 - %empty_closure4 = call i64 @create_closure(i64 ptrtoint (ptr @fac_cps to i64), i64 2, i64 0) - %applied_closure5 = call i64 (i64, i64, ...) @apply_args(i64 %empty_closure4, i64 2, i64 %sub, i64 %applied_closure3) + %call = call i64 @fac_cps(i64 %sub, i64 %applied_closure1) br label %merge merge: ; preds = %else, %then - %phi = phi i64 [ %applied_closure1, %then ], [ %applied_closure5, %else ] + %phi = phi i64 [ %applied_closure, %then ], [ %call, %else ] ret i64 %phi } @@ -145,10 +141,8 @@ define i64 @main() { entry: %empty_closure = call i64 @create_closure(i64 ptrtoint (ptr @a2 to i64), i64 1, i64 0) - %empty_closure1 = call i64 @create_closure(i64 ptrtoint (ptr @fac_cps to i64), i64 2, i64 0) - %applied_closure = call i64 (i64, i64, ...) @apply_args(i64 %empty_closure1, i64 2, i64 4, i64 %empty_closure) - %empty_closure2 = call i64 @create_closure(i64 ptrtoint (ptr @print_int to i64), i64 1, i64 0) - %applied_closure3 = call i64 (i64, i64, ...) @apply_args(i64 %empty_closure2, i64 1, i64 %applied_closure) + %call = call i64 @fac_cps(i64 4, i64 %empty_closure) + %call1 = call i64 @print_int(i64 %call) ret i64 0 ret i64 0 } diff --git a/FML/lib/llvm/codegen.ml b/FML/lib/llvm/codegen.ml index 6d818574f..d1073166a 100644 --- a/FML/lib/llvm/codegen.ml +++ b/FML/lib/llvm/codegen.ml @@ -41,28 +41,23 @@ let compile_binop op x y = | "( - )" -> build_sub x y "sub" builder | "( * )" -> build_mul x y "mul" builder | "( / )" -> build_sdiv x y "div" builder - (* | "( = )" | "( == )" -> build_icmp Icmp.Eq x y "eq" builder - | "( <> )" | "( != )" -> build_icmp Icmp.Ne x y "ne" builder - | "( > )" -> build_icmp Icmp.Sgt x y "sgt" builder - | "( >= )" -> build_icmp Icmp.Sge x y "sge" builder - | "( < )" -> build_icmp Icmp.Slt x y "slt" builder - | "( <= )" -> build_icmp Icmp.Sle x y "sle" builder *) + | "( = )" | "( == )" -> + build_zext (build_icmp Icmp.Eq x y "eq" builder) i64_t "eq_i64t" builder + | "( <> )" | "( != )" -> + build_zext (build_icmp Icmp.Ne x y "ne" builder) i64_t "ne_i64t" builder + | "( > )" -> build_zext (build_icmp Icmp.Sgt x y "sgt" builder) i64_t "sgt_i64t" builder + | "( >= )" -> + build_zext (build_icmp Icmp.Sge x y "sge" builder) i64_t "sge_i64t" builder + | "( < )" -> build_zext (build_icmp Icmp.Slt x y "slt" builder) i64_t "slt_i64t" builder + | "( <= )" -> + build_zext (build_icmp Icmp.Sle x y "sle" builder) i64_t "sle_i64t" builder | _ -> failwith ("Invalid operator: " ^ op) ;; let is_binop = function - | "( + )" - | "( - )" - | "( * )" - | "( / )" -> true - (* | "( = )" - | "( == )" - | "( <> )" - | "( != )" - | "( > )" - | "( >= )" - | "( < )" - | "( <= )" -> true *) + | "( + )" | "( - )" | "( * )" | "( / )" -> true + | "( = )" | "( == )" | "( <> )" | "( != )" | "( > )" | "( >= )" | "( < )" | "( <= )" -> + true | _ -> false ;; @@ -98,35 +93,10 @@ let rec compile_cexpr = function | CEApply (name, args) -> let compiled_args = List.map compile_immexpr args in (match lookup_function name module_ with - (* | Some f when Array.length (params f) = List.length args -> - build_call (type_of f) f (Array.of_list compiled_args) name builder *) - | Some _ -> - let f = compile_immexpr (ImmIdentifier name) in - build_call - (var_arg_function_type i64_t [| i64_t; i64_t |]) - (Option.get (lookup_function "apply_args" module_)) - (Array.of_list - ([ f; const_int i64_t (List.length compiled_args) ] @ compiled_args)) - "applied_closure" - builder - (* | Some f -> - let fun_ptr = build_ptrtoint f i64_t "" builder in - let cl = - build_call - (function_type i64_t [| i64_t; i64_t |]) - (Option.get @@ lookup_function "create_closure" module_) - [| fun_ptr; const_int i64_t (Array.length (params f)); const_int i64_t 0 |] - "closure" - builder - in - build_call - (var_arg_function_type i64_t [| i64_t; i64_t |]) - (Option.get (lookup_function "apply_args" module_)) - (Array.of_list - ([ cl; const_int i64_t (List.length compiled_args) ] @ compiled_args)) - "applied_closure" - builder *) - | None -> + | Some f when Array.length (params f) = List.length args -> + let func_type = function_type i64_t (Array.make (List.length args) i64_t) in + build_call func_type f (Array.of_list compiled_args) "call" builder + | _ -> let f = compile_immexpr (ImmIdentifier name) in build_call (var_arg_function_type i64_t [| i64_t; i64_t |]) @@ -137,8 +107,8 @@ let rec compile_cexpr = function builder) | CEIf (cond, then_e, else_e) -> let cond_v = - build_icmp Icmp.Ne (compile_immexpr cond) (const_int i64_t 0) "cond_v" builder in - (* let cond_v = compile_immexpr cond in *) + build_icmp Icmp.Ne (compile_immexpr cond) (const_int i64_t 0) "cond_v" builder + in let entry_block = insertion_block builder in let parent = block_parent entry_block in let then_block = append_block ctx "then" parent in @@ -229,10 +199,6 @@ let init_runtime = ;; let create_main program = - (* let main_type = function_type i64_t [||] in - let main = declare_function "main" main_type module_ in - let bb = append_block ctx "entry" main in - position_at_end bb builder; *) init_runtime; List.iter (fun decl -> ignore (compile_anf_decl decl)) program; let _ = build_ret (const_int i64_t 0) builder in diff --git a/FML/lib/llvm/runtime.c b/FML/lib/llvm/runtime.c deleted file mode 100644 index ad07c5287..000000000 --- a/FML/lib/llvm/runtime.c +++ /dev/null @@ -1,128 +0,0 @@ -#include -#include -#include -#include -#include - -typedef struct closure_t { - int64_t fun_ptr; - int64_t args_num; - int64_t args_applied; - int64_t applied_args[]; -} closure_t; - -closure_t *create_closure(int64_t fun_ptr, int64_t args_num, - int64_t args_applied) { - size_t size = sizeof(closure_t) + args_num * sizeof(int64_t); - closure_t *clos = (closure_t *)malloc(size); - clos->fun_ptr = fun_ptr; - clos->args_num = args_num; - clos->args_applied = args_applied; - return clos; -} - -closure_t *empty_closure(int64_t fun_ptr, int64_t args_num) { - return create_closure(fun_ptr, args_num, 0); -} - -int64_t _copy_closure(closure_t *src_clos, int64_t new_args_num, - va_list *new_args) { - int64_t total_args_applied = src_clos->args_applied + new_args_num; - closure_t *new_clos = - create_closure(src_clos->fun_ptr, src_clos->args_num, total_args_applied); - - for (int i = 0; i < src_clos->args_applied; i++) { - new_clos->applied_args[i] = src_clos->applied_args[i]; - } - - for (int i = 0; i < new_args_num; i++) { - new_clos->applied_args[src_clos->args_applied + i] = - va_arg(*new_args, int64_t); - } - - return (int64_t)new_clos; -} - -int64_t call_closure(closure_t *closure, int64_t new_args_num, - va_list *new_args) { - size_t args_count = closure->args_num; - - ffi_cif cif; - ffi_type *arg_types[args_count]; - int64_t *args[args_count]; - - int64_t buffer_new_args[new_args_num]; - - for (int i = 0; i < args_count; ++i) { - arg_types[i] = &ffi_type_sint64; - if (i < closure->args_applied) { - args[i] = &(closure->applied_args[i]); - } else { - int na_num = i - closure->args_applied; - buffer_new_args[na_num] = va_arg(*new_args, int64_t); - args[i] = &(buffer_new_args[na_num]); - } - } - - int64_t res = 0; - - if (ffi_prep_cif(&cif, FFI_DEFAULT_ABI, args_count, &ffi_type_sint64, - arg_types) == FFI_OK) { - ffi_call(&cif, (void *)closure->fun_ptr, &res, (void **)args); - } else { - fprintf(stderr, "call_closure: Failed to prepare call interface\n"); - exit(1); - } - - return res; -} - -int64_t _apply_args_to_closure(closure_t *closure, int64_t new_args_num, - va_list *new_args) { - int64_t args_num_until_apply = closure->args_num - closure->args_applied; - - if (args_num_until_apply <= new_args_num) { - int64_t call_res = call_closure(closure, args_num_until_apply, new_args); - new_args_num -= args_num_until_apply; - if (new_args_num == 0) { - return call_res; - } else { - return _apply_args_to_closure((closure_t *)call_res, new_args_num, - new_args); - } - } else { - return _copy_closure(closure, new_args_num, new_args); - } -} - -int64_t apply_args(int64_t closure_ptr, int64_t new_args_num, ...) { - va_list new_args; - va_start(new_args, new_args_num); - int64_t res = - _apply_args_to_closure((closure_t *)closure_ptr, new_args_num, &new_args); - va_end(new_args); - return res; -} - -int64_t rt_add(int64_t x, int64_t y) { return x + y; } -int64_t rt_sub(int64_t x, int64_t y) { return x - y; } -int64_t rt_mul(int64_t x, int64_t y) { return x * y; } -int64_t rt_divd(int64_t x, int64_t y) { return x / y; } -int64_t rt_eq(int64_t x, int64_t y) { return x == y; } -int64_t rt_neq(int64_t x, int64_t y) { return x != y; } -int64_t rt_less(int64_t x, int64_t y) { return x < y; } -int64_t rt_leq(int64_t x, int64_t y) { return x <= y; } -int64_t rt_gre(int64_t x, int64_t y) { return x > y; } -int64_t rt_geq(int64_t x, int64_t y) { return x >= y; } -int64_t rt_and(int64_t x, int64_t y) { return x && y; } -int64_t rt_or(int64_t x, int64_t y) { return x || y; } - -int64_t print_int(int64_t x) { - printf("%ld\n", x); - return 0; -} - -int64_t fail_match(int64_t _) { - fprintf(stderr, "Match failure\n"); - exit(1); -} \ No newline at end of file From 7f5f471501d283b4f275e9ccf5ebe185f268576a Mon Sep 17 00:00:00 2001 From: Dmitry Pilyuk Date: Wed, 12 Mar 2025 00:51:50 +0300 Subject: [PATCH 45/92] Fix double ret in main --- FML/bin/bitecode.t | 2 -- FML/lib/llvm/codegen.ml | 4 +--- 2 files changed, 1 insertion(+), 5 deletions(-) diff --git a/FML/bin/bitecode.t b/FML/bin/bitecode.t index 0a210c67d..48b4f2555 100644 --- a/FML/bin/bitecode.t +++ b/FML/bin/bitecode.t @@ -62,7 +62,6 @@ %call = call i64 @fac(i64 4) %call1 = call i64 @print_int(i64 %call) ret i64 0 - ret i64 0 } $ ./compiler.exe < manytests/typed/002fac.ml @@ -144,5 +143,4 @@ %call = call i64 @fac_cps(i64 4, i64 %empty_closure) %call1 = call i64 @print_int(i64 %call) ret i64 0 - ret i64 0 } diff --git a/FML/lib/llvm/codegen.ml b/FML/lib/llvm/codegen.ml index d1073166a..38ef3b9d4 100644 --- a/FML/lib/llvm/codegen.ml +++ b/FML/lib/llvm/codegen.ml @@ -200,9 +200,7 @@ let init_runtime = let create_main program = init_runtime; - List.iter (fun decl -> ignore (compile_anf_decl decl)) program; - let _ = build_ret (const_int i64_t 0) builder in - () + List.iter (fun decl -> ignore (compile_anf_decl decl)) program ;; let compile_program program = From 5ed69cc23184c78fa951b1e464826d3c4fab7fbf Mon Sep 17 00:00:00 2001 From: Dmitry Pilyuk Date: Wed, 12 Mar 2025 15:26:05 +0300 Subject: [PATCH 46/92] fix identifiers --- FML/lib/anf/pattern_elim.ml | 23 ++- FML/tests/alpha_conv_manytest.t | 140 ++++++++--------- FML/tests/anf_manytests.t | 224 ++++----------------------- FML/tests/closure_conv_manytest.t | 152 +++++++++--------- FML/tests/lambda_lifting_manytests.t | 148 +++++++++--------- FML/tests/pe_manytests.t | 140 ++++++++--------- 6 files changed, 327 insertions(+), 500 deletions(-) diff --git a/FML/lib/anf/pattern_elim.ml b/FML/lib/anf/pattern_elim.ml index f7a9cf2aa..587f43dd1 100644 --- a/FML/lib/anf/pattern_elim.ml +++ b/FML/lib/anf/pattern_elim.ml @@ -13,10 +13,9 @@ type value_to_get = | Other let get_element e = function - | Tuple i -> - Pe_EApp (Pe_EApp (Pe_EIdentifier "#tuple_element", e), Pe_EConst (Pe_Cint i)) - | Cons_head -> Pe_EApp (Pe_EIdentifier "#list_head", e) - | Cons_tail -> Pe_EApp (Pe_EIdentifier "#list_tail", e) + | Tuple i -> Pe_EApp (Pe_EApp (Pe_EIdentifier "tuple_element", e), Pe_EConst (Pe_Cint i)) + | Cons_head -> Pe_EApp (Pe_EIdentifier "list_head", e) + | Cons_tail -> Pe_EApp (Pe_EIdentifier "list_tail", e) | Other -> e ;; @@ -41,12 +40,12 @@ let check_pattern expr pat = @@ List.mapi pl ~f:(fun i p -> helper true (get_element expr (Tuple i)) p) | PCons (l, r) -> let check = - Pe_EApp (Pe_EIdentifier "not", Pe_EApp (Pe_EIdentifier "#is_empty", expr)) + Pe_EApp (Pe_EIdentifier "not", Pe_EApp (Pe_EIdentifier "is_empty", expr)) in let l = helper true (get_element expr Cons_head) l in let r = helper false (get_element expr Cons_tail) r in if add then (check :: l) @ r else l @ r - | PNill -> [ Pe_EApp (Pe_EIdentifier "#is_empty", expr) ] + | PNill -> [ Pe_EApp (Pe_EIdentifier "is_empty", expr) ] | _ -> [] in helper true expr pat @@ -147,7 +146,7 @@ let rec pe_expr = | 1 -> let pat = List.hd_exn pat_list in let to_match = Pe_EIdentifier (List.hd_exn args_to_match) in - let case_expr = make_case to_match pat new_body (Pe_EIdentifier "#fail_match") in + let case_expr = make_case to_match pat new_body (Pe_EIdentifier "fail_match") in return @@ Pe_EFun (new_args, case_expr) | _ -> let pat = PTuple pat_list in @@ -157,7 +156,7 @@ let rec pe_expr = in let* fresh_name = fresh >>| get_id in let case_expr = - make_case (Pe_EIdentifier fresh_name) pat new_body (Pe_EIdentifier "#fail_match") + make_case (Pe_EIdentifier fresh_name) pat new_body (Pe_EIdentifier "fail_match") in return @@ Pe_EFun (new_args, Pe_ELet (NoRec, fresh_name, to_match, case_expr))) | EMatch (e_last, case_list) -> @@ -177,12 +176,12 @@ let rec pe_expr = | _ -> (match e1 with | Pe_EIdentifier _ -> - let case_expr = make_case e1 pat e2 (Pe_EIdentifier "#fail_match") in + let case_expr = make_case e1 pat e2 (Pe_EIdentifier "fail_match") in return case_expr | _ -> let* fresh_name = fresh >>| get_id in let case_expr = - make_case (Pe_EIdentifier fresh_name) pat e2 (Pe_EIdentifier "#fail_match") + make_case (Pe_EIdentifier fresh_name) pat e2 (Pe_EIdentifier "fail_match") in return @@ Pe_ELet (NoRec, fresh_name, e1, case_expr))) | ELetIn (Rec, pat, e1, e2) -> @@ -194,7 +193,7 @@ let rec pe_expr = | _ -> let* fresh_name = fresh >>| get_id in let case_expr = - make_case (Pe_EIdentifier fresh_name) pat e2 (Pe_EIdentifier "#fail_match") + make_case (Pe_EIdentifier fresh_name) pat e2 (Pe_EIdentifier "fail_match") in return @@ Pe_ELet (Rec, fresh_name, e1, case_expr)) @@ -217,7 +216,7 @@ and pe_match to_match = function else let* match_e = pe_match to_match tl in return @@ make_condition checks let_in match_e - | _ -> return @@ Pe_EIdentifier "#fail_match" + | _ -> return @@ Pe_EIdentifier "fail_match" ;; let pe_declaration = function diff --git a/FML/tests/alpha_conv_manytest.t b/FML/tests/alpha_conv_manytest.t index 43726e5cd..294cffa24 100644 --- a/FML/tests/alpha_conv_manytest.t +++ b/FML/tests/alpha_conv_manytest.t @@ -116,22 +116,22 @@ ((f 1), (f true)) $ ./alpha_conv_runner.exe < manytests/typed/011mapcps.ml - let rec map = (fun f xs k -> if (#is_empty xs) + let rec map = (fun f xs k -> if (is_empty xs) then (k []) - else if (not (#is_empty xs)) - then let h = (#list_head xs) in - let tl = (#list_tail xs) in + else if (not (is_empty xs)) + then let h = (list_head xs) in + let tl = (list_tail xs) in (((map f) tl) (fun a0 -> (k ((f h)::a0)))) - else #fail_match) + else fail_match) - let rec iter = (fun f xs -> if (#is_empty xs) + let rec iter = (fun f xs -> if (is_empty xs) then () - else if (not (#is_empty xs)) - then let h = (#list_head xs) in - let tl = (#list_tail xs) in + else if (not (is_empty xs)) + then let h = (list_head xs) in + let tl = (list_tail xs) in let w = (f h) in ((iter f) tl) - else #fail_match) + else fail_match) let main = ((iter print_int) (((map (fun x -> ((( + ) x) 1))) (1::(2::(3::[])))) (fun x -> x))) $ ./alpha_conv_runner.exe < manytests/typed/012fibcps.ml @@ -143,13 +143,13 @@ $ ./alpha_conv_runner.exe < manytests/typed/013foldfoldr.ml let id = (fun x -> x) - let rec fold_right = (fun f acc xs -> if (#is_empty xs) + let rec fold_right = (fun f acc xs -> if (is_empty xs) then acc - else if (not (#is_empty xs)) - then let h = (#list_head xs) in - let tl = (#list_tail xs) in + else if (not (is_empty xs)) + then let h = (list_head xs) in + let tl = (list_tail xs) in ((f h) (((fold_right f) acc) tl)) - else #fail_match) + else fail_match) let foldl = (fun f a bs -> ((((fold_right (fun b g x -> (g ((f x) b)))) id) bs) a)) @@ -158,20 +158,20 @@ $ ./alpha_conv_runner.exe < manytests/typed/015tuples.ml let rec fix = (fun f x -> ((f (fix f)) x)) - let map = (fun f p -> let a = ((#tuple_element p) 0) in - let b = ((#tuple_element p) 1) in + let map = (fun f p -> let a = ((tuple_element p) 0) in + let b = ((tuple_element p) 1) in ((f a), (f b))) let fixpoly = (fun l -> ((fix (fun self a0 -> ((map (fun li x -> ((li (self a0)) x))) a0))) l)) - let feven = (fun p n -> let e = ((#tuple_element p) 0) in - let o = ((#tuple_element p) 1) in + let feven = (fun p n -> let e = ((tuple_element p) 0) in + let o = ((tuple_element p) 1) in if ((( = ) n) 0) then 1 else (o ((( - ) n) 1))) - let fodd = (fun p n -> let e = ((#tuple_element p) 0) in - let o = ((#tuple_element p) 1) in + let fodd = (fun p n -> let e = ((tuple_element p) 0) in + let o = ((tuple_element p) 1) in if ((( = ) n) 0) then 0 else (e ((( - ) n) 1))) @@ -187,86 +187,86 @@ let main = let () = (print_int (modd 1)) in let () = (print_int (meven 2)) in - let even = ((#tuple_element tie) 0) in - let odd = ((#tuple_element tie) 1) in + let even = ((tuple_element tie) 0) in + let odd = ((tuple_element tie) 1) in let () = (print_int (odd 3)) in let () = (print_int (even 4)) in 0 $ ./alpha_conv_runner.exe < manytests/typed/016lists.ml - let rec length = (fun xs -> if (#is_empty xs) + let rec length = (fun xs -> if (is_empty xs) then 0 - else if (not (#is_empty xs)) - then let h = (#list_head xs) in - let tl = (#list_tail xs) in + else if (not (is_empty xs)) + then let h = (list_head xs) in + let tl = (list_tail xs) in ((( + ) 1) (length tl)) - else #fail_match) + else fail_match) - let length_tail = let rec helper = (fun acc xs -> if (#is_empty xs) + let length_tail = let rec helper = (fun acc xs -> if (is_empty xs) then acc - else if (not (#is_empty xs)) - then let h = (#list_head xs) in - let tl = (#list_tail xs) in + else if (not (is_empty xs)) + then let h = (list_head xs) in + let tl = (list_tail xs) in ((helper ((( + ) acc) 1)) tl) - else #fail_match) in + else fail_match) in (helper 0) - let rec map = (fun f xs -> if (#is_empty xs) + let rec map = (fun f xs -> if (is_empty xs) then [] - else if ((( && ) (not (#is_empty xs))) (#is_empty (#list_tail xs))) - then let a = (#list_head xs) in + else if ((( && ) (not (is_empty xs))) (is_empty (list_tail xs))) + then let a = (list_head xs) in ((f a)::[]) - else if ((( && ) (not (#is_empty xs))) (#is_empty (#list_tail (#list_tail xs)))) - then let a = (#list_head xs) in - let b = (#list_head (#list_tail xs)) in + else if ((( && ) (not (is_empty xs))) (is_empty (list_tail (list_tail xs)))) + then let a = (list_head xs) in + let b = (list_head (list_tail xs)) in ((f a)::((f b)::[])) - else if ((( && ) (not (#is_empty xs))) (#is_empty (#list_tail (#list_tail (#list_tail xs))))) - then let a = (#list_head xs) in - let b = (#list_head (#list_tail xs)) in - let c = (#list_head (#list_tail (#list_tail xs))) in + else if ((( && ) (not (is_empty xs))) (is_empty (list_tail (list_tail (list_tail xs))))) + then let a = (list_head xs) in + let b = (list_head (list_tail xs)) in + let c = (list_head (list_tail (list_tail xs))) in ((f a)::((f b)::((f c)::[]))) - else if (not (#is_empty xs)) - then let a = (#list_head xs) in - let b = (#list_head (#list_tail xs)) in - let c = (#list_head (#list_tail (#list_tail xs))) in - let d = (#list_head (#list_tail (#list_tail (#list_tail xs)))) in - let tl = (#list_tail (#list_tail (#list_tail (#list_tail xs)))) in + else if (not (is_empty xs)) + then let a = (list_head xs) in + let b = (list_head (list_tail xs)) in + let c = (list_head (list_tail (list_tail xs))) in + let d = (list_head (list_tail (list_tail (list_tail xs)))) in + let tl = (list_tail (list_tail (list_tail (list_tail xs)))) in ((f a)::((f b)::((f c)::((f d)::((map f) tl))))) - else #fail_match) + else fail_match) - let rec append = (fun xs ys -> if (#is_empty xs) + let rec append = (fun xs ys -> if (is_empty xs) then ys - else if (not (#is_empty xs)) - then let x = (#list_head xs) in - let a0 = (#list_tail xs) in + else if (not (is_empty xs)) + then let x = (list_head xs) in + let a0 = (list_tail xs) in (x::((append a0) ys)) - else #fail_match) + else fail_match) - let concat = let rec helper = (fun xs -> if (#is_empty xs) + let concat = let rec helper = (fun xs -> if (is_empty xs) then [] - else if (not (#is_empty xs)) - then let h = (#list_head xs) in - let tl = (#list_tail xs) in + else if (not (is_empty xs)) + then let h = (list_head xs) in + let tl = (list_tail xs) in ((append h) (helper tl)) - else #fail_match) in + else fail_match) in helper - let rec iter = (fun f xs -> if (#is_empty xs) + let rec iter = (fun f xs -> if (is_empty xs) then () - else if (not (#is_empty xs)) - then let h = (#list_head xs) in - let tl = (#list_tail xs) in + else if (not (is_empty xs)) + then let h = (list_head xs) in + let tl = (list_tail xs) in let () = (f h) in ((iter f) tl) - else #fail_match) + else fail_match) - let rec cartesian = (fun xs ys -> if (#is_empty xs) + let rec cartesian = (fun xs ys -> if (is_empty xs) then [] - else if (not (#is_empty xs)) - then let h = (#list_head xs) in - let tl = (#list_tail xs) in + else if (not (is_empty xs)) + then let h = (list_head xs) in + let tl = (list_tail xs) in ((append ((map (fun a -> (h, a))) ys)) ((cartesian tl) ys)) - else #fail_match) + else fail_match) let main = let () = ((iter print_int) (1::(2::(3::[])))) in let () = (print_int (length ((cartesian (1::(2::[]))) (1::(2::(3::(4::[]))))))) in diff --git a/FML/tests/anf_manytests.t b/FML/tests/anf_manytests.t index 12bfa406e..5de942fc6 100644 --- a/FML/tests/anf_manytests.t +++ b/FML/tests/anf_manytests.t @@ -248,30 +248,30 @@ let a4 = (a5::a0) in k a4 - let rec map f xs k = let a6 = #is_empty xs in + let rec map fail_match is_empty list_head list_tail f xs k = let a6 = is_empty xs in if a6 then let a7 = [] in k a7 - else let a9 = #is_empty xs in + else let a9 = is_empty xs in let a8 = not a9 in if a8 - then let h = #list_head xs in - let tl = #list_tail xs in + then let h = list_head xs in + let tl = list_tail xs in let a10 = a1 f h k in map f tl a10 - else #fail_match + else fail_match - let rec iter f xs = let a11 = #is_empty xs in + let rec iter fail_match is_empty list_head list_tail f xs = let a11 = is_empty xs in if a11 then () - else let a13 = #is_empty xs in + else let a13 = is_empty xs in let a12 = not a13 in if a12 - then let h = #list_head xs in - let tl = #list_tail xs in + then let h = list_head xs in + let tl = list_tail xs in let w = f h in iter f tl - else #fail_match + else fail_match let a2 x = ( + ) x 1 @@ -283,7 +283,7 @@ let a14 = map a2 a15 a3 in iter print_int a14 Типы после приведения в ANF: - Parsing error: : end_of_input + Infer error. $ ./anf_runner.exe < manytests/typed/012fibcps.ml let a1 a k b = let a3 = ( + ) a b in k a3 @@ -312,17 +312,17 @@ $ ./anf_runner.exe < manytests/typed/013foldfoldr.ml let id x = x - let rec fold_right f acc xs = let a2 = #is_empty xs in + let rec fold_right fail_match is_empty list_head list_tail f acc xs = let a2 = is_empty xs in if a2 then acc - else let a4 = #is_empty xs in + else let a4 = is_empty xs in let a3 = not a4 in if a3 - then let h = #list_head xs in - let tl = #list_tail xs in + then let h = list_head xs in + let tl = list_tail xs in let a5 = fold_right f acc tl in f h a5 - else #fail_match + else fail_match let a0 f b g x = let a6 = f x b in g a6 @@ -338,14 +338,14 @@ let a8 = foldl a1 1 a9 in print_int a8 Типы после приведения в ANF: - Parsing error: : end_of_input + Infer error. $ ./anf_runner.exe < manytests/typed/015tuples.ml let rec fix f x = let a3 = fix f in f a3 x - let map f p = let a = #tuple_element p 0 in - let b = #tuple_element p 1 in + let map tuple_element f p = let a = tuple_element p 0 in + let b = tuple_element p 1 in let a4 = f a in let a5 = f b in (a4, a5) @@ -358,16 +358,16 @@ let fixpoly l = fix a1 l - let feven p n = let e = #tuple_element p 0 in - let o = #tuple_element p 1 in + let feven tuple_element p n = let e = tuple_element p 0 in + let o = tuple_element p 1 in let a8 = ( = ) n 0 in if a8 then 1 else let a9 = ( - ) n 1 in o a9 - let fodd p n = let e = #tuple_element p 0 in - let o = #tuple_element p 1 in + let fodd tuple_element p n = let e = tuple_element p 0 in + let o = tuple_element p 1 in let a10 = ( = ) n 0 in if a10 then 0 @@ -392,184 +392,12 @@ let () = print_int a17 in let a18 = meven 2 in let () = print_int a18 in - let even = #tuple_element tie 0 in - let odd = #tuple_element tie 1 in + let even = tuple_element tie 0 in + let odd = tuple_element tie 1 in let a19 = odd 3 in let () = print_int a19 in let a20 = even 4 in let () = print_int a20 in 0 Типы после приведения в ANF: - Parsing error: : end_of_input - - $ ./anf_runner.exe < manytests/typed/016lists.ml - let rec length xs = let a4 = #is_empty xs in - if a4 - then 0 - else let a6 = #is_empty xs in - let a5 = not a6 in - if a5 - then let h = #list_head xs in - let tl = #list_tail xs in - let a7 = length tl in - ( + ) 1 a7 - else #fail_match - - let rec a1 acc xs = let a8 = #is_empty xs in - if a8 - then acc - else let a10 = #is_empty xs in - let a9 = not a10 in - if a9 - then let h = #list_head xs in - let tl = #list_tail xs in - let a11 = ( + ) acc 1 in - a1 a11 tl - else #fail_match - - let length_tail = a1 0 - - let rec map f xs = let a12 = #is_empty xs in - if a12 - then [] - else let a17 = #list_tail xs in - let a16 = #is_empty a17 in - let a15 = #is_empty xs in - let a14 = not a15 in - let a13 = ( && ) a14 a16 in - if a13 - then let a = #list_head xs in - let a18 = f a in - (a18::[]) - else let a24 = #list_tail xs in - let a23 = #list_tail a24 in - let a22 = #is_empty a23 in - let a21 = #is_empty xs in - let a20 = not a21 in - let a19 = ( && ) a20 a22 in - if a19 - then let a = #list_head xs in - let a25 = #list_tail xs in - let b = #list_head a25 in - let a26 = f a in - let a28 = f b in - let a27 = (a28::[]) in - (a26::a27) - else let a35 = #list_tail xs in - let a34 = #list_tail a35 in - let a33 = #list_tail a34 in - let a32 = #is_empty a33 in - let a31 = #is_empty xs in - let a30 = not a31 in - let a29 = ( && ) a30 a32 in - if a29 - then let a = #list_head xs in - let a36 = #list_tail xs in - let b = #list_head a36 in - let a38 = #list_tail xs in - let a37 = #list_tail a38 in - let c = #list_head a37 in - let a39 = f a in - let a41 = f b in - let a43 = f c in - let a42 = (a43::[]) in - let a40 = (a41::a42) in - (a39::a40) - else let a45 = #is_empty xs in - let a44 = not a45 in - if a44 - then let a = #list_head xs in - let a46 = #list_tail xs in - let b = #list_head a46 in - let a48 = #list_tail xs in - let a47 = #list_tail a48 in - let c = #list_head a47 in - let a51 = #list_tail xs in - let a50 = #list_tail a51 in - let a49 = #list_tail a50 in - let d = #list_head a49 in - let a54 = #list_tail xs in - let a53 = #list_tail a54 in - let a52 = #list_tail a53 in - let tl = #list_tail a52 in - let a55 = f a in - let a57 = f b in - let a59 = f c in - let a61 = f d in - let a62 = map f tl in - let a60 = (a61::a62) in - let a58 = (a59::a60) in - let a56 = (a57::a58) in - (a55::a56) - else #fail_match - - let rec append xs ys = let a63 = #is_empty xs in - if a63 - then ys - else let a65 = #is_empty xs in - let a64 = not a65 in - if a64 - then let x = #list_head xs in - let a0 = #list_tail xs in - let a66 = append a0 ys in - (x::a66) - else #fail_match - - let rec a2 xs = let a67 = #is_empty xs in - if a67 - then [] - else let a69 = #is_empty xs in - let a68 = not a69 in - if a68 - then let h = #list_head xs in - let tl = #list_tail xs in - let a70 = a2 tl in - append h a70 - else #fail_match - - let concat = a2 - - let rec iter f xs = let a71 = #is_empty xs in - if a71 - then () - else let a73 = #is_empty xs in - let a72 = not a73 in - if a72 - then let h = #list_head xs in - let tl = #list_tail xs in - let () = f h in - iter f tl - else #fail_match - - let a3 h a = (h, a) - - let rec cartesian xs ys = let a74 = #is_empty xs in - if a74 - then [] - else let a76 = #is_empty xs in - let a75 = not a76 in - if a75 - then let h = #list_head xs in - let tl = #list_tail xs in - let a79 = cartesian tl ys in - let a78 = a3 h in - let a77 = map a78 ys in - append a77 a79 - else #fail_match - - let main = let a82 = (3::[]) in - let a81 = (2::a82) in - let a80 = (1::a81) in - let () = iter print_int a80 in - let a90 = (4::[]) in - let a89 = (3::a90) in - let a88 = (2::a89) in - let a87 = (1::a88) in - let a86 = (2::[]) in - let a85 = (1::a86) in - let a84 = cartesian a85 a87 in - let a83 = length a84 in - let () = print_int a83 in - 0 - Типы после приведения в ANF: - Parsing error: : string + Infer error. diff --git a/FML/tests/closure_conv_manytest.t b/FML/tests/closure_conv_manytest.t index fa10dc8a0..e793c57cc 100644 --- a/FML/tests/closure_conv_manytest.t +++ b/FML/tests/closure_conv_manytest.t @@ -116,22 +116,22 @@ ((f 1), (f true)) $ ./closure_conv_runner.exe < manytests/typed/011mapcps.ml - let rec map = (fun f xs k -> if (#is_empty xs) + let rec map = (fun fail_match is_empty list_head list_tail f xs k -> if (is_empty xs) then (k []) - else if (not (#is_empty xs)) - then let h = (#list_head xs) in - let tl = (#list_tail xs) in + else if (not (is_empty xs)) + then let h = (list_head xs) in + let tl = (list_tail xs) in (((map f) tl) ((((fun f h k a0 -> (k ((f h)::a0))) f) h) k)) - else #fail_match) + else fail_match) - let rec iter = (fun f xs -> if (#is_empty xs) + let rec iter = (fun fail_match is_empty list_head list_tail f xs -> if (is_empty xs) then () - else if (not (#is_empty xs)) - then let h = (#list_head xs) in - let tl = (#list_tail xs) in + else if (not (is_empty xs)) + then let h = (list_head xs) in + let tl = (list_tail xs) in let w = (f h) in ((iter f) tl) - else #fail_match) + else fail_match) let main = ((iter print_int) (((map (fun x -> ((( + ) x) 1))) (1::(2::(3::[])))) (fun x -> x))) $ ./closure_conv_runner.exe < manytests/typed/012fibcps.ml @@ -143,13 +143,13 @@ $ ./closure_conv_runner.exe < manytests/typed/013foldfoldr.ml let id = (fun x -> x) - let rec fold_right = (fun f acc xs -> if (#is_empty xs) + let rec fold_right = (fun fail_match is_empty list_head list_tail f acc xs -> if (is_empty xs) then acc - else if (not (#is_empty xs)) - then let h = (#list_head xs) in - let tl = (#list_tail xs) in + else if (not (is_empty xs)) + then let h = (list_head xs) in + let tl = (list_tail xs) in ((f h) (((fold_right f) acc) tl)) - else #fail_match) + else fail_match) let foldl = (fun f a bs -> ((((fold_right ((fun f b g x -> (g ((f x) b))) f)) id) bs) a)) @@ -158,20 +158,20 @@ $ ./closure_conv_runner.exe < manytests/typed/015tuples.ml let rec fix = (fun f x -> ((f (fix f)) x)) - let map = (fun f p -> let a = ((#tuple_element p) 0) in - let b = ((#tuple_element p) 1) in + let map = (fun tuple_element f p -> let a = ((tuple_element p) 0) in + let b = ((tuple_element p) 1) in ((f a), (f b))) let fixpoly = (fun l -> ((fix (fun self a0 -> ((map (((fun a0 self li x -> ((li (self a0)) x)) a0) self)) a0))) l)) - let feven = (fun p n -> let e = ((#tuple_element p) 0) in - let o = ((#tuple_element p) 1) in + let feven = (fun tuple_element p n -> let e = ((tuple_element p) 0) in + let o = ((tuple_element p) 1) in if ((( = ) n) 0) then 1 else (o ((( - ) n) 1))) - let fodd = (fun p n -> let e = ((#tuple_element p) 0) in - let o = ((#tuple_element p) 1) in + let fodd = (fun tuple_element p n -> let e = ((tuple_element p) 0) in + let o = ((tuple_element p) 1) in if ((( = ) n) 0) then 0 else (e ((( - ) n) 1))) @@ -187,86 +187,86 @@ let main = let () = (print_int (modd 1)) in let () = (print_int (meven 2)) in - let even = ((#tuple_element tie) 0) in - let odd = ((#tuple_element tie) 1) in + let even = ((tuple_element tie) 0) in + let odd = ((tuple_element tie) 1) in let () = (print_int (odd 3)) in let () = (print_int (even 4)) in 0 $ ./closure_conv_runner.exe < manytests/typed/016lists.ml - let rec length = (fun xs -> if (#is_empty xs) + let rec length = (fun fail_match is_empty list_head list_tail xs -> if (is_empty xs) then 0 - else if (not (#is_empty xs)) - then let h = (#list_head xs) in - let tl = (#list_tail xs) in + else if (not (is_empty xs)) + then let h = (list_head xs) in + let tl = (list_tail xs) in ((( + ) 1) (length tl)) - else #fail_match) + else fail_match) - let length_tail = let rec helper = (fun acc xs -> if (#is_empty xs) + let length_tail = let rec helper = (fun fail_match is_empty list_head list_tail acc xs -> if (is_empty xs) then acc - else if (not (#is_empty xs)) - then let h = (#list_head xs) in - let tl = (#list_tail xs) in - ((helper ((( + ) acc) 1)) tl) - else #fail_match) in - (helper 0) - - let rec map = (fun f xs -> if (#is_empty xs) + else if (not (is_empty xs)) + then let h = (list_head xs) in + let tl = (list_tail xs) in + ((((((helper fail_match) is_empty) list_head) list_tail) ((( + ) acc) 1)) tl) + else fail_match) in + (((((helper fail_match) is_empty) list_head) list_tail) 0) + + let rec map = (fun fail_match is_empty list_head list_tail f xs -> if (is_empty xs) then [] - else if ((( && ) (not (#is_empty xs))) (#is_empty (#list_tail xs))) - then let a = (#list_head xs) in + else if ((( && ) (not (is_empty xs))) (is_empty (list_tail xs))) + then let a = (list_head xs) in ((f a)::[]) - else if ((( && ) (not (#is_empty xs))) (#is_empty (#list_tail (#list_tail xs)))) - then let a = (#list_head xs) in - let b = (#list_head (#list_tail xs)) in + else if ((( && ) (not (is_empty xs))) (is_empty (list_tail (list_tail xs)))) + then let a = (list_head xs) in + let b = (list_head (list_tail xs)) in ((f a)::((f b)::[])) - else if ((( && ) (not (#is_empty xs))) (#is_empty (#list_tail (#list_tail (#list_tail xs))))) - then let a = (#list_head xs) in - let b = (#list_head (#list_tail xs)) in - let c = (#list_head (#list_tail (#list_tail xs))) in + else if ((( && ) (not (is_empty xs))) (is_empty (list_tail (list_tail (list_tail xs))))) + then let a = (list_head xs) in + let b = (list_head (list_tail xs)) in + let c = (list_head (list_tail (list_tail xs))) in ((f a)::((f b)::((f c)::[]))) - else if (not (#is_empty xs)) - then let a = (#list_head xs) in - let b = (#list_head (#list_tail xs)) in - let c = (#list_head (#list_tail (#list_tail xs))) in - let d = (#list_head (#list_tail (#list_tail (#list_tail xs)))) in - let tl = (#list_tail (#list_tail (#list_tail (#list_tail xs)))) in + else if (not (is_empty xs)) + then let a = (list_head xs) in + let b = (list_head (list_tail xs)) in + let c = (list_head (list_tail (list_tail xs))) in + let d = (list_head (list_tail (list_tail (list_tail xs)))) in + let tl = (list_tail (list_tail (list_tail (list_tail xs)))) in ((f a)::((f b)::((f c)::((f d)::((map f) tl))))) - else #fail_match) + else fail_match) - let rec append = (fun xs ys -> if (#is_empty xs) + let rec append = (fun fail_match is_empty list_head list_tail xs ys -> if (is_empty xs) then ys - else if (not (#is_empty xs)) - then let x = (#list_head xs) in - let a0 = (#list_tail xs) in + else if (not (is_empty xs)) + then let x = (list_head xs) in + let a0 = (list_tail xs) in (x::((append a0) ys)) - else #fail_match) + else fail_match) - let concat = let rec helper = (fun xs -> if (#is_empty xs) + let concat = let rec helper = (fun fail_match is_empty list_head list_tail xs -> if (is_empty xs) then [] - else if (not (#is_empty xs)) - then let h = (#list_head xs) in - let tl = (#list_tail xs) in - ((append h) (helper tl)) - else #fail_match) in - helper - - let rec iter = (fun f xs -> if (#is_empty xs) + else if (not (is_empty xs)) + then let h = (list_head xs) in + let tl = (list_tail xs) in + ((append h) (((((helper fail_match) is_empty) list_head) list_tail) tl)) + else fail_match) in + ((((helper fail_match) is_empty) list_head) list_tail) + + let rec iter = (fun fail_match is_empty list_head list_tail f xs -> if (is_empty xs) then () - else if (not (#is_empty xs)) - then let h = (#list_head xs) in - let tl = (#list_tail xs) in + else if (not (is_empty xs)) + then let h = (list_head xs) in + let tl = (list_tail xs) in let () = (f h) in ((iter f) tl) - else #fail_match) + else fail_match) - let rec cartesian = (fun xs ys -> if (#is_empty xs) + let rec cartesian = (fun fail_match is_empty list_head list_tail xs ys -> if (is_empty xs) then [] - else if (not (#is_empty xs)) - then let h = (#list_head xs) in - let tl = (#list_tail xs) in + else if (not (is_empty xs)) + then let h = (list_head xs) in + let tl = (list_tail xs) in ((append ((map ((fun h a -> (h, a)) h)) ys)) ((cartesian tl) ys)) - else #fail_match) + else fail_match) let main = let () = ((iter print_int) (1::(2::(3::[])))) in let () = (print_int (length ((cartesian (1::(2::[]))) (1::(2::(3::(4::[]))))))) in diff --git a/FML/tests/lambda_lifting_manytests.t b/FML/tests/lambda_lifting_manytests.t index 5a0f16c32..fc708ed8b 100644 --- a/FML/tests/lambda_lifting_manytests.t +++ b/FML/tests/lambda_lifting_manytests.t @@ -140,22 +140,22 @@ $ ./lambda_lifting_runner.exe < manytests/typed/011mapcps.ml let a1 = (fun f h k a0 -> (k ((f h)::a0))) - let rec map = (fun f xs k -> if (#is_empty xs) + let rec map = (fun fail_match is_empty list_head list_tail f xs k -> if (is_empty xs) then (k []) - else if (not (#is_empty xs)) - then let h = (#list_head xs) in - let tl = (#list_tail xs) in + else if (not (is_empty xs)) + then let h = (list_head xs) in + let tl = (list_tail xs) in (((map f) tl) (((a1 f) h) k)) - else #fail_match) + else fail_match) - let rec iter = (fun f xs -> if (#is_empty xs) + let rec iter = (fun fail_match is_empty list_head list_tail f xs -> if (is_empty xs) then () - else if (not (#is_empty xs)) - then let h = (#list_head xs) in - let tl = (#list_tail xs) in + else if (not (is_empty xs)) + then let h = (list_head xs) in + let tl = (list_tail xs) in let w = (f h) in ((iter f) tl) - else #fail_match) + else fail_match) let a2 = (fun x -> ((( + ) x) 1)) @@ -177,13 +177,13 @@ $ ./lambda_lifting_runner.exe < manytests/typed/013foldfoldr.ml let id = (fun x -> x) - let rec fold_right = (fun f acc xs -> if (#is_empty xs) + let rec fold_right = (fun fail_match is_empty list_head list_tail f acc xs -> if (is_empty xs) then acc - else if (not (#is_empty xs)) - then let h = (#list_head xs) in - let tl = (#list_tail xs) in + else if (not (is_empty xs)) + then let h = (list_head xs) in + let tl = (list_tail xs) in ((f h) (((fold_right f) acc) tl)) - else #fail_match) + else fail_match) let a0 = (fun f b g x -> (g ((f x) b))) @@ -196,8 +196,8 @@ $ ./lambda_lifting_runner.exe < manytests/typed/015tuples.ml let rec fix = (fun f x -> ((f (fix f)) x)) - let map = (fun f p -> let a = ((#tuple_element p) 0) in - let b = ((#tuple_element p) 1) in + let map = (fun tuple_element f p -> let a = ((tuple_element p) 0) in + let b = ((tuple_element p) 1) in ((f a), (f b))) let a2 = (fun a0 self li x -> ((li (self a0)) x)) @@ -206,14 +206,14 @@ let fixpoly = (fun l -> ((fix a1) l)) - let feven = (fun p n -> let e = ((#tuple_element p) 0) in - let o = ((#tuple_element p) 1) in + let feven = (fun tuple_element p n -> let e = ((tuple_element p) 0) in + let o = ((tuple_element p) 1) in if ((( = ) n) 0) then 1 else (o ((( - ) n) 1))) - let fodd = (fun p n -> let e = ((#tuple_element p) 0) in - let o = ((#tuple_element p) 1) in + let fodd = (fun tuple_element p n -> let e = ((tuple_element p) 0) in + let o = ((tuple_element p) 1) in if ((( = ) n) 0) then 0 else (e ((( - ) n) 1))) @@ -229,90 +229,90 @@ let main = let () = (print_int (modd 1)) in let () = (print_int (meven 2)) in - let even = ((#tuple_element tie) 0) in - let odd = ((#tuple_element tie) 1) in + let even = ((tuple_element tie) 0) in + let odd = ((tuple_element tie) 1) in let () = (print_int (odd 3)) in let () = (print_int (even 4)) in 0 $ ./lambda_lifting_runner.exe < manytests/typed/016lists.ml - let rec length = (fun xs -> if (#is_empty xs) + let rec length = (fun fail_match is_empty list_head list_tail xs -> if (is_empty xs) then 0 - else if (not (#is_empty xs)) - then let h = (#list_head xs) in - let tl = (#list_tail xs) in + else if (not (is_empty xs)) + then let h = (list_head xs) in + let tl = (list_tail xs) in ((( + ) 1) (length tl)) - else #fail_match) + else fail_match) - let rec a1 = (fun acc xs -> if (#is_empty xs) + let rec a1 = (fun fail_match is_empty list_head list_tail acc xs -> if (is_empty xs) then acc - else if (not (#is_empty xs)) - then let h = (#list_head xs) in - let tl = (#list_tail xs) in - ((a1 ((( + ) acc) 1)) tl) - else #fail_match) + else if (not (is_empty xs)) + then let h = (list_head xs) in + let tl = (list_tail xs) in + ((((((a1 fail_match) is_empty) list_head) list_tail) ((( + ) acc) 1)) tl) + else fail_match) - let length_tail = (a1 0) + let length_tail = (((((a1 fail_match) is_empty) list_head) list_tail) 0) - let rec map = (fun f xs -> if (#is_empty xs) + let rec map = (fun fail_match is_empty list_head list_tail f xs -> if (is_empty xs) then [] - else if ((( && ) (not (#is_empty xs))) (#is_empty (#list_tail xs))) - then let a = (#list_head xs) in + else if ((( && ) (not (is_empty xs))) (is_empty (list_tail xs))) + then let a = (list_head xs) in ((f a)::[]) - else if ((( && ) (not (#is_empty xs))) (#is_empty (#list_tail (#list_tail xs)))) - then let a = (#list_head xs) in - let b = (#list_head (#list_tail xs)) in + else if ((( && ) (not (is_empty xs))) (is_empty (list_tail (list_tail xs)))) + then let a = (list_head xs) in + let b = (list_head (list_tail xs)) in ((f a)::((f b)::[])) - else if ((( && ) (not (#is_empty xs))) (#is_empty (#list_tail (#list_tail (#list_tail xs))))) - then let a = (#list_head xs) in - let b = (#list_head (#list_tail xs)) in - let c = (#list_head (#list_tail (#list_tail xs))) in + else if ((( && ) (not (is_empty xs))) (is_empty (list_tail (list_tail (list_tail xs))))) + then let a = (list_head xs) in + let b = (list_head (list_tail xs)) in + let c = (list_head (list_tail (list_tail xs))) in ((f a)::((f b)::((f c)::[]))) - else if (not (#is_empty xs)) - then let a = (#list_head xs) in - let b = (#list_head (#list_tail xs)) in - let c = (#list_head (#list_tail (#list_tail xs))) in - let d = (#list_head (#list_tail (#list_tail (#list_tail xs)))) in - let tl = (#list_tail (#list_tail (#list_tail (#list_tail xs)))) in + else if (not (is_empty xs)) + then let a = (list_head xs) in + let b = (list_head (list_tail xs)) in + let c = (list_head (list_tail (list_tail xs))) in + let d = (list_head (list_tail (list_tail (list_tail xs)))) in + let tl = (list_tail (list_tail (list_tail (list_tail xs)))) in ((f a)::((f b)::((f c)::((f d)::((map f) tl))))) - else #fail_match) + else fail_match) - let rec append = (fun xs ys -> if (#is_empty xs) + let rec append = (fun fail_match is_empty list_head list_tail xs ys -> if (is_empty xs) then ys - else if (not (#is_empty xs)) - then let x = (#list_head xs) in - let a0 = (#list_tail xs) in + else if (not (is_empty xs)) + then let x = (list_head xs) in + let a0 = (list_tail xs) in (x::((append a0) ys)) - else #fail_match) + else fail_match) - let rec a2 = (fun xs -> if (#is_empty xs) + let rec a2 = (fun fail_match is_empty list_head list_tail xs -> if (is_empty xs) then [] - else if (not (#is_empty xs)) - then let h = (#list_head xs) in - let tl = (#list_tail xs) in - ((append h) (a2 tl)) - else #fail_match) + else if (not (is_empty xs)) + then let h = (list_head xs) in + let tl = (list_tail xs) in + ((append h) (((((a2 fail_match) is_empty) list_head) list_tail) tl)) + else fail_match) - let concat = a2 + let concat = ((((a2 fail_match) is_empty) list_head) list_tail) - let rec iter = (fun f xs -> if (#is_empty xs) + let rec iter = (fun fail_match is_empty list_head list_tail f xs -> if (is_empty xs) then () - else if (not (#is_empty xs)) - then let h = (#list_head xs) in - let tl = (#list_tail xs) in + else if (not (is_empty xs)) + then let h = (list_head xs) in + let tl = (list_tail xs) in let () = (f h) in ((iter f) tl) - else #fail_match) + else fail_match) let a3 = (fun h a -> (h, a)) - let rec cartesian = (fun xs ys -> if (#is_empty xs) + let rec cartesian = (fun fail_match is_empty list_head list_tail xs ys -> if (is_empty xs) then [] - else if (not (#is_empty xs)) - then let h = (#list_head xs) in - let tl = (#list_tail xs) in + else if (not (is_empty xs)) + then let h = (list_head xs) in + let tl = (list_tail xs) in ((append ((map (a3 h)) ys)) ((cartesian tl) ys)) - else #fail_match) + else fail_match) let main = let () = ((iter print_int) (1::(2::(3::[])))) in let () = (print_int (length ((cartesian (1::(2::[]))) (1::(2::(3::(4::[]))))))) in diff --git a/FML/tests/pe_manytests.t b/FML/tests/pe_manytests.t index cad798fe1..9c91b7b56 100644 --- a/FML/tests/pe_manytests.t +++ b/FML/tests/pe_manytests.t @@ -104,22 +104,22 @@ ((f 1), (f true)) $ ./pe_runner.exe < manytests/typed/011mapcps.ml - let rec map = (fun f xs k -> if (#is_empty xs) + let rec map = (fun f xs k -> if (is_empty xs) then (k []) - else if (not (#is_empty xs)) - then let h = (#list_head xs) in - let tl = (#list_tail xs) in + else if (not (is_empty xs)) + then let h = (list_head xs) in + let tl = (list_tail xs) in (((map f) tl) (fun tl -> (k ((f h)::tl)))) - else #fail_match) + else fail_match) - let rec iter = (fun f xs -> if (#is_empty xs) + let rec iter = (fun f xs -> if (is_empty xs) then () - else if (not (#is_empty xs)) - then let h = (#list_head xs) in - let tl = (#list_tail xs) in + else if (not (is_empty xs)) + then let h = (list_head xs) in + let tl = (list_tail xs) in let w = (f h) in ((iter f) tl) - else #fail_match) + else fail_match) let main = ((iter print_int) (((map (fun x -> ((( + ) x) 1))) (1::(2::(3::[])))) (fun x -> x))) $ ./pe_runner.exe < manytests/typed/012fibcps.ml @@ -131,13 +131,13 @@ $ ./pe_runner.exe < manytests/typed/013foldfoldr.ml let id = (fun x -> x) - let rec fold_right = (fun f acc xs -> if (#is_empty xs) + let rec fold_right = (fun f acc xs -> if (is_empty xs) then acc - else if (not (#is_empty xs)) - then let h = (#list_head xs) in - let tl = (#list_tail xs) in + else if (not (is_empty xs)) + then let h = (list_head xs) in + let tl = (list_tail xs) in ((f h) (((fold_right f) acc) tl)) - else #fail_match) + else fail_match) let foldl = (fun f a bs -> ((((fold_right (fun b g x -> (g ((f x) b)))) id) bs) a)) @@ -146,20 +146,20 @@ $ ./pe_runner.exe < manytests/typed/015tuples.ml let rec fix = (fun f x -> ((f (fix f)) x)) - let map = (fun f p -> let a = ((#tuple_element p) 0) in - let b = ((#tuple_element p) 1) in + let map = (fun f p -> let a = ((tuple_element p) 0) in + let b = ((tuple_element p) 1) in ((f a), (f b))) let fixpoly = (fun l -> ((fix (fun self l -> ((map (fun li x -> ((li (self l)) x))) l))) l)) - let feven = (fun p n -> let e = ((#tuple_element p) 0) in - let o = ((#tuple_element p) 1) in + let feven = (fun p n -> let e = ((tuple_element p) 0) in + let o = ((tuple_element p) 1) in if ((( = ) n) 0) then 1 else (o ((( - ) n) 1))) - let fodd = (fun p n -> let e = ((#tuple_element p) 0) in - let o = ((#tuple_element p) 1) in + let fodd = (fun p n -> let e = ((tuple_element p) 0) in + let o = ((tuple_element p) 1) in if ((( = ) n) 0) then 0 else (e ((( - ) n) 1))) @@ -175,86 +175,86 @@ let main = let () = (print_int (modd 1)) in let () = (print_int (meven 2)) in - let even = ((#tuple_element tie) 0) in - let odd = ((#tuple_element tie) 1) in + let even = ((tuple_element tie) 0) in + let odd = ((tuple_element tie) 1) in let () = (print_int (odd 3)) in let () = (print_int (even 4)) in 0 $ ./pe_runner.exe < manytests/typed/016lists.ml - let rec length = (fun xs -> if (#is_empty xs) + let rec length = (fun xs -> if (is_empty xs) then 0 - else if (not (#is_empty xs)) - then let h = (#list_head xs) in - let tl = (#list_tail xs) in + else if (not (is_empty xs)) + then let h = (list_head xs) in + let tl = (list_tail xs) in ((( + ) 1) (length tl)) - else #fail_match) + else fail_match) - let length_tail = let rec helper = (fun acc xs -> if (#is_empty xs) + let length_tail = let rec helper = (fun acc xs -> if (is_empty xs) then acc - else if (not (#is_empty xs)) - then let h = (#list_head xs) in - let tl = (#list_tail xs) in + else if (not (is_empty xs)) + then let h = (list_head xs) in + let tl = (list_tail xs) in ((helper ((( + ) acc) 1)) tl) - else #fail_match) in + else fail_match) in (helper 0) - let rec map = (fun f xs -> if (#is_empty xs) + let rec map = (fun f xs -> if (is_empty xs) then [] - else if ((( && ) (not (#is_empty xs))) (#is_empty (#list_tail xs))) - then let a = (#list_head xs) in + else if ((( && ) (not (is_empty xs))) (is_empty (list_tail xs))) + then let a = (list_head xs) in ((f a)::[]) - else if ((( && ) (not (#is_empty xs))) (#is_empty (#list_tail (#list_tail xs)))) - then let a = (#list_head xs) in - let b = (#list_head (#list_tail xs)) in + else if ((( && ) (not (is_empty xs))) (is_empty (list_tail (list_tail xs)))) + then let a = (list_head xs) in + let b = (list_head (list_tail xs)) in ((f a)::((f b)::[])) - else if ((( && ) (not (#is_empty xs))) (#is_empty (#list_tail (#list_tail (#list_tail xs))))) - then let a = (#list_head xs) in - let b = (#list_head (#list_tail xs)) in - let c = (#list_head (#list_tail (#list_tail xs))) in + else if ((( && ) (not (is_empty xs))) (is_empty (list_tail (list_tail (list_tail xs))))) + then let a = (list_head xs) in + let b = (list_head (list_tail xs)) in + let c = (list_head (list_tail (list_tail xs))) in ((f a)::((f b)::((f c)::[]))) - else if (not (#is_empty xs)) - then let a = (#list_head xs) in - let b = (#list_head (#list_tail xs)) in - let c = (#list_head (#list_tail (#list_tail xs))) in - let d = (#list_head (#list_tail (#list_tail (#list_tail xs)))) in - let tl = (#list_tail (#list_tail (#list_tail (#list_tail xs)))) in + else if (not (is_empty xs)) + then let a = (list_head xs) in + let b = (list_head (list_tail xs)) in + let c = (list_head (list_tail (list_tail xs))) in + let d = (list_head (list_tail (list_tail (list_tail xs)))) in + let tl = (list_tail (list_tail (list_tail (list_tail xs)))) in ((f a)::((f b)::((f c)::((f d)::((map f) tl))))) - else #fail_match) + else fail_match) - let rec append = (fun xs ys -> if (#is_empty xs) + let rec append = (fun xs ys -> if (is_empty xs) then ys - else if (not (#is_empty xs)) - then let x = (#list_head xs) in - let xs = (#list_tail xs) in + else if (not (is_empty xs)) + then let x = (list_head xs) in + let xs = (list_tail xs) in (x::((append xs) ys)) - else #fail_match) + else fail_match) - let concat = let rec helper = (fun xs -> if (#is_empty xs) + let concat = let rec helper = (fun xs -> if (is_empty xs) then [] - else if (not (#is_empty xs)) - then let h = (#list_head xs) in - let tl = (#list_tail xs) in + else if (not (is_empty xs)) + then let h = (list_head xs) in + let tl = (list_tail xs) in ((append h) (helper tl)) - else #fail_match) in + else fail_match) in helper - let rec iter = (fun f xs -> if (#is_empty xs) + let rec iter = (fun f xs -> if (is_empty xs) then () - else if (not (#is_empty xs)) - then let h = (#list_head xs) in - let tl = (#list_tail xs) in + else if (not (is_empty xs)) + then let h = (list_head xs) in + let tl = (list_tail xs) in let () = (f h) in ((iter f) tl) - else #fail_match) + else fail_match) - let rec cartesian = (fun xs ys -> if (#is_empty xs) + let rec cartesian = (fun xs ys -> if (is_empty xs) then [] - else if (not (#is_empty xs)) - then let h = (#list_head xs) in - let tl = (#list_tail xs) in + else if (not (is_empty xs)) + then let h = (list_head xs) in + let tl = (list_tail xs) in ((append ((map (fun a -> (h, a))) ys)) ((cartesian tl) ys)) - else #fail_match) + else fail_match) let main = let () = ((iter print_int) (1::(2::(3::[])))) in let () = (print_int (length ((cartesian (1::(2::[]))) (1::(2::(3::(4::[]))))))) in From 8329933ec669191045006d6664cd6877cba65782 Mon Sep 17 00:00:00 2001 From: Dmitry Pilyuk Date: Thu, 13 Mar 2025 00:37:59 +0300 Subject: [PATCH 47/92] fix anf inference --- FML/lib/anf/anf_ast.ml | 4 +- FML/lib/anf/common.ml | 10 +- FML/lib/inferencer/inferencer.ml | 7 + FML/tests/anf_manytests.t | 297 ++++++++++++++++++++++++++- FML/tests/closure_conv_manytest.t | 34 +-- FML/tests/lambda_lifting_manytests.t | 34 +-- 6 files changed, 336 insertions(+), 50 deletions(-) diff --git a/FML/lib/anf/anf_ast.ml b/FML/lib/anf/anf_ast.ml index ac38eef45..e925eba0a 100644 --- a/FML/lib/anf/anf_ast.ml +++ b/FML/lib/anf/anf_ast.ml @@ -72,10 +72,10 @@ let fun_to_str = function let declaration_to_str = function | ADNoRec func_list -> let funs = List.map fun_to_str func_list in - "let " ^ String.concat "\nand " funs + "let " ^ String.concat "\nand " funs ^ "\n;;" | ADREC func_list -> let funs = List.map fun_to_str func_list in - "let rec " ^ String.concat "\nand " funs + "let rec " ^ String.concat "\nand " funs ^ "\n;;" ;; let pp_anf_program ppf p = diff --git a/FML/lib/anf/common.ml b/FML/lib/anf/common.ml index 5a7a09387..4d3fcbf64 100644 --- a/FML/lib/anf/common.ml +++ b/FML/lib/anf/common.ml @@ -33,11 +33,11 @@ let builtins = ; "( || )" ; "not" ; "print_int" - ; "#list_head" - ; "#list_tail" - ; "#tuple_element" - ; "#is_empty" - ; "#fail_match" + ; "list_head" + ; "list_tail" + ; "tuple_element" + ; "is_empty" + ; "fail_match" ] ;; diff --git a/FML/lib/inferencer/inferencer.ml b/FML/lib/inferencer/inferencer.ml index 95ac1290a..b9bc74d58 100644 --- a/FML/lib/inferencer/inferencer.ml +++ b/FML/lib/inferencer/inferencer.ml @@ -642,6 +642,8 @@ let start_env = ; "( - )", TFunction (TInt, TFunction (TInt, TInt)) ; "( / )", TFunction (TInt, TFunction (TInt, TInt)) ; "( * )", TFunction (TInt, TFunction (TInt, TInt)) + ; "( && )", TFunction (TBool, TFunction (TBool, TBool)) + ; "( || )", TFunction (TBool, TFunction (TBool, TBool)) ; "( < )", TFunction (TVar 1, TFunction (TVar 1, TBool)) ; "( > )", TFunction (TVar 1, TFunction (TVar 1, TBool)) ; "( <= )", TFunction (TVar 1, TFunction (TVar 1, TBool)) @@ -653,6 +655,11 @@ let start_env = ; "( ~+ )", TFunction (TInt, TInt) ; "not", TFunction (TBool, TBool) ; "print_int", TFunction (TInt, TUnit) + ; "is_empty", TFunction (TList (TVar 1), TBool) + ; "list_head", TFunction (TList (TVar 1), TVar 1) + ; "list_tail", TFunction (TList (TVar 1), TList (TVar 1)) + ; "tuple_element", TFunction (TVar 1, TVar 2) + ; "fail_match", TVar 1 ] in let env = TypeEnv.empty in diff --git a/FML/tests/anf_manytests.t b/FML/tests/anf_manytests.t index 5de942fc6..06c9654fd 100644 --- a/FML/tests/anf_manytests.t +++ b/FML/tests/anf_manytests.t @@ -8,6 +8,7 @@ > EOF let a4 a1 a2 m = let a6 = ( * ) m a2 in a1 a6 + ;; let rec a3 a0 k = let a7 = ( <= ) a0 1 in if a7 @@ -15,10 +16,13 @@ else let a9 = a4 k a0 in let a8 = ( - ) a0 1 in a3 a8 a9 + ;; let a5 x = x + ;; let fac n = a3 n a5 + ;; Типы после приведения в ANF: val a4 : (int -> 'a) -> int -> int -> 'a val a3 : int -> (int -> 'a) -> 'a @@ -31,10 +35,12 @@ else let a2 = ( - ) n 1 in let a1 = fac a2 in ( * ) n a1 + ;; let main = let a3 = fac 4 in let () = print_int a3 in 0 + ;; Типы после приведения в ANF: val fac : int -> int val main : int @@ -42,6 +48,7 @@ $ ./anf_runner.exe < manytests/typed/002fac.ml let a1 k n p = let a3 = ( * ) p n in k a3 + ;; let rec fac_cps n k = let a4 = ( = ) n 1 in if a4 @@ -49,12 +56,15 @@ else let a6 = a1 k n in let a5 = ( - ) n 1 in fac_cps a5 a6 + ;; let a2 a0 = a0 + ;; let main = let a7 = fac_cps 4 a2 in let () = print_int a7 in 0 + ;; Типы после приведения в ANF: val a1 : (int -> 'a) -> int -> int -> 'a val fac_cps : int -> (int -> 'a) -> 'a @@ -68,6 +78,7 @@ else let n1 = ( - ) n 1 in let ab = ( + ) a b in fib_acc b ab n1 + ;; let rec fib n = let a1 = ( < ) n 2 in if a1 @@ -77,12 +88,14 @@ let a3 = ( - ) n 1 in let a2 = fib a3 in ( + ) a2 a4 + ;; let main = let a6 = fib_acc 0 1 4 in let () = print_int a6 in let a7 = fib 4 in let () = print_int a7 in 0 + ;; Типы после приведения в ANF: val fib_acc : int -> int -> int -> int val fib : int -> int @@ -93,11 +106,13 @@ if a3 then f else f + ;; let test3 a b c = let a0 = print_int a in let a1 = print_int b in let a2 = print_int c in 0 + ;; let test10 a b c d e f g h i j = let a11 = ( + ) a b in let a10 = ( + ) a11 c in @@ -108,11 +123,13 @@ let a5 = ( + ) a6 h in let a4 = ( + ) a5 i in ( + ) a4 j + ;; let main = let rez = wrap test10 1 10 100 1000 10000 100000 1000000 10000000 100000000 1000000000 in let () = print_int rez in let temp2 = wrap test3 1 10 100 in 0 + ;; Типы после приведения в ANF: val wrap : 'a -> 'a val test3 : int -> int -> int -> int @@ -122,6 +139,7 @@ $ ./anf_runner.exe < manytests/typed/005fix.ml let rec fix f x = let a0 = fix f in f a0 x + ;; let fac self n = let a1 = ( <= ) n 1 in if a1 @@ -129,10 +147,12 @@ else let a3 = ( - ) n 1 in let a2 = self a3 in ( * ) n a2 + ;; let main = let a4 = fix fac 6 in let () = print_int a4 in 0 + ;; Типы после приведения в ANF: val fix : (('a -> 'b) -> 'a -> 'b) -> 'a -> 'b val fac : (int -> int) -> int -> int @@ -140,21 +160,26 @@ $ ./anf_runner.exe < manytests/typed/006partial.ml let a1 foo = ( + ) foo 2 + ;; let a2 foo = ( * ) foo 10 + ;; let foo b = if b then a1 else a2 + ;; let a0 x = let a5 = foo false x in let a4 = foo true a5 in let a3 = foo false a4 in foo true a3 + ;; let main = let a6 = a0 11 in let () = print_int a6 in 0 + ;; Типы после приведения в ANF: val a1 : int -> int val a2 : int -> int @@ -168,26 +193,32 @@ let () = print_int c in let a3 = ( * ) b c in ( + ) a a3 + ;; let main = let a0 = foo 1 in let a1 = a0 2 in let a2 = a1 3 in let () = print_int a2 in 0 + ;; Типы после приведения в ANF: val foo : int -> int -> int -> int val main : int $ ./anf_runner.exe < manytests/typed/006partial3.ml let a1 c = print_int c + ;; let a0 b = let () = print_int b in a1 + ;; let foo a = let () = print_int a in a0 + ;; let main = let () = foo 4 8 9 in 0 + ;; Типы после приведения в ANF: val a1 : int -> unit val a0 : int -> int -> unit @@ -201,6 +232,7 @@ let a7 = ( * ) a b in let a6 = ( / ) a7 _c in ( + ) a6 d + ;; let main = let a14 = ( ~- ) 555555 in let a13 = ( ~- ) 1 in @@ -210,23 +242,28 @@ let a9 = print_int 1 in let a8 = _start a9 a10 3 a11 100 1000 a12 10000 a14 in print_int a8 + ;; Типы после приведения в ANF: val _start : 'a -> 'b -> int -> 'c -> int -> int -> 'd -> int -> int -> int val main : unit $ ./anf_runner.exe < manytests/typed/008ascription.ml let addi f g x = let a2 = g x in f x a2 + ;; let a0 x b = if b then ( + ) x 1 else ( * ) x 2 + ;; let a1 _start = let a3 = ( / ) _start 2 in ( = ) a3 0 + ;; let main = let a4 = addi a0 a1 4 in let () = print_int a4 in 0 + ;; Типы после приведения в ANF: val addi : ('a -> 'b -> 'c) -> ('a -> 'b) -> 'a -> 'c val a0 : int -> bool -> int @@ -235,10 +272,12 @@ $ ./anf_runner.exe < manytests/typed/009let_poly.ml let a0 x = x + ;; let temp = let a1 = a0 1 in let a2 = a0 true in (a1, a2) + ;; Типы после приведения в ANF: val a0 : 'a -> 'a val temp : int * bool @@ -247,8 +286,9 @@ let a1 f h k a0 = let a5 = f h in let a4 = (a5::a0) in k a4 + ;; - let rec map fail_match is_empty list_head list_tail f xs k = let a6 = is_empty xs in + let rec map f xs k = let a6 = is_empty xs in if a6 then let a7 = [] in k a7 @@ -260,8 +300,9 @@ let a10 = a1 f h k in map f tl a10 else fail_match + ;; - let rec iter fail_match is_empty list_head list_tail f xs = let a11 = is_empty xs in + let rec iter f xs = let a11 = is_empty xs in if a11 then () else let a13 = is_empty xs in @@ -272,25 +313,36 @@ let w = f h in iter f tl else fail_match + ;; let a2 x = ( + ) x 1 + ;; let a3 x = x + ;; let main = let a17 = (3::[]) in let a16 = (2::a17) in let a15 = (1::a16) in let a14 = map a2 a15 a3 in iter print_int a14 + ;; Типы после приведения в ANF: - Infer error. + val a1 : ('a -> 'b) -> 'a -> ('b list -> 'c) -> 'b list -> 'c + val map : ('a -> 'b) -> 'a list -> ('b list -> 'c) -> 'c + val iter : ('a -> 'b) -> 'a list -> unit + val a2 : int -> int + val a3 : 'a -> 'a + val main : unit $ ./anf_runner.exe < manytests/typed/012fibcps.ml let a1 a k b = let a3 = ( + ) a b in k a3 + ;; let a0 fib k n a = let a5 = a1 a k in let a4 = ( - ) n 2 in fib a4 a5 + ;; let rec fib n k = let a6 = ( < ) n 2 in if a6 @@ -298,11 +350,14 @@ else let a8 = a0 fib k n in let a7 = ( - ) n 1 in fib a7 a8 + ;; let a2 x = x + ;; let main = let a9 = fib 6 a2 in print_int a9 + ;; Типы после приведения в ANF: val a1 : int -> (int -> 'a) -> int -> 'a val a0 : (int -> (int -> 'a) -> 'b) -> (int -> 'a) -> int -> int -> 'b @@ -311,8 +366,9 @@ val main : unit $ ./anf_runner.exe < manytests/typed/013foldfoldr.ml let id x = x + ;; - let rec fold_right fail_match is_empty list_head list_tail f acc xs = let a2 = is_empty xs in + let rec fold_right f acc xs = let a2 = is_empty xs in if a2 then acc else let a4 = is_empty xs in @@ -323,59 +379,77 @@ let a5 = fold_right f acc tl in f h a5 else fail_match + ;; let a0 f b g x = let a6 = f x b in g a6 + ;; let foldl f a bs = let a7 = a0 f in fold_right a7 id bs a + ;; let a1 x y = ( * ) x y + ;; let main = let a11 = (3::[]) in let a10 = (2::a11) in let a9 = (1::a10) in let a8 = foldl a1 1 a9 in print_int a8 + ;; Типы после приведения в ANF: - Infer error. + val id : 'a -> 'a + val fold_right : ('a -> 'b -> 'b) -> 'b -> 'a list -> 'b + val a0 : ('a -> 'b -> 'c) -> 'b -> ('c -> 'd) -> 'a -> 'd + val foldl : ('a -> 'b -> 'a) -> 'a -> 'b list -> 'a + val a1 : int -> int -> int + val main : unit $ ./anf_runner.exe < manytests/typed/015tuples.ml let rec fix f x = let a3 = fix f in f a3 x + ;; - let map tuple_element f p = let a = tuple_element p 0 in + let map f p = let a = tuple_element p 0 in let b = tuple_element p 1 in let a4 = f a in let a5 = f b in (a4, a5) + ;; let a2 a0 self li x = let a6 = self a0 in li a6 x + ;; let a1 self a0 = let a7 = a2 a0 self in map a7 a0 + ;; let fixpoly l = fix a1 l + ;; - let feven tuple_element p n = let e = tuple_element p 0 in + let feven p n = let e = tuple_element p 0 in let o = tuple_element p 1 in let a8 = ( = ) n 0 in if a8 then 1 else let a9 = ( - ) n 1 in o a9 + ;; - let fodd tuple_element p n = let e = tuple_element p 0 in + let fodd p n = let e = tuple_element p 0 in let o = tuple_element p 1 in let a10 = ( = ) n 0 in if a10 then 0 else let a11 = ( - ) n 1 in e a11 + ;; let tie = let a12 = (feven, fodd) in fixpoly a12 + ;; let rec meven n = let a13 = ( = ) n 0 in if a13 @@ -387,6 +461,7 @@ then 1 else let a16 = ( - ) n 1 in meven a16 + ;; let main = let a17 = modd 1 in let () = print_int a17 in @@ -399,5 +474,209 @@ let a20 = even 4 in let () = print_int a20 in 0 + ;; Типы после приведения в ANF: - Infer error. + val fix : (('a -> 'b) -> 'a -> 'b) -> 'a -> 'b + val map : ('a -> 'b) -> 'c -> 'b * 'b + val a2 : 'a -> ('a -> 'b) -> ('b -> 'c -> 'd) -> 'c -> 'd + val a1 : ('a -> 'b) -> 'a -> ('c -> 'd) * ('c -> 'd) + val fixpoly : 'a -> ('b -> 'c) * ('b -> 'c) + val feven : 'a -> int -> int + val fodd : 'a -> int -> int + val tie : ('a -> 'b) * ('a -> 'b) + val meven : int -> int + val modd : int -> int + val main : int + + $ ./anf_runner.exe < manytests/typed/016lists.ml + let rec length xs = let a4 = is_empty xs in + if a4 + then 0 + else let a6 = is_empty xs in + let a5 = not a6 in + if a5 + then let h = list_head xs in + let tl = list_tail xs in + let a7 = length tl in + ( + ) 1 a7 + else fail_match + ;; + + let rec a1 acc xs = let a8 = is_empty xs in + if a8 + then acc + else let a10 = is_empty xs in + let a9 = not a10 in + if a9 + then let h = list_head xs in + let tl = list_tail xs in + let a11 = ( + ) acc 1 in + a1 a11 tl + else fail_match + ;; + + let length_tail = a1 0 + ;; + + let rec map f xs = let a12 = is_empty xs in + if a12 + then [] + else let a17 = list_tail xs in + let a16 = is_empty a17 in + let a15 = is_empty xs in + let a14 = not a15 in + let a13 = ( && ) a14 a16 in + if a13 + then let a = list_head xs in + let a18 = f a in + (a18::[]) + else let a24 = list_tail xs in + let a23 = list_tail a24 in + let a22 = is_empty a23 in + let a21 = is_empty xs in + let a20 = not a21 in + let a19 = ( && ) a20 a22 in + if a19 + then let a = list_head xs in + let a25 = list_tail xs in + let b = list_head a25 in + let a26 = f a in + let a28 = f b in + let a27 = (a28::[]) in + (a26::a27) + else let a35 = list_tail xs in + let a34 = list_tail a35 in + let a33 = list_tail a34 in + let a32 = is_empty a33 in + let a31 = is_empty xs in + let a30 = not a31 in + let a29 = ( && ) a30 a32 in + if a29 + then let a = list_head xs in + let a36 = list_tail xs in + let b = list_head a36 in + let a38 = list_tail xs in + let a37 = list_tail a38 in + let c = list_head a37 in + let a39 = f a in + let a41 = f b in + let a43 = f c in + let a42 = (a43::[]) in + let a40 = (a41::a42) in + (a39::a40) + else let a45 = is_empty xs in + let a44 = not a45 in + if a44 + then let a = list_head xs in + let a46 = list_tail xs in + let b = list_head a46 in + let a48 = list_tail xs in + let a47 = list_tail a48 in + let c = list_head a47 in + let a51 = list_tail xs in + let a50 = list_tail a51 in + let a49 = list_tail a50 in + let d = list_head a49 in + let a54 = list_tail xs in + let a53 = list_tail a54 in + let a52 = list_tail a53 in + let tl = list_tail a52 in + let a55 = f a in + let a57 = f b in + let a59 = f c in + let a61 = f d in + let a62 = map f tl in + let a60 = (a61::a62) in + let a58 = (a59::a60) in + let a56 = (a57::a58) in + (a55::a56) + else fail_match + ;; + + let rec append xs ys = let a63 = is_empty xs in + if a63 + then ys + else let a65 = is_empty xs in + let a64 = not a65 in + if a64 + then let x = list_head xs in + let a0 = list_tail xs in + let a66 = append a0 ys in + (x::a66) + else fail_match + ;; + + let rec a2 xs = let a67 = is_empty xs in + if a67 + then [] + else let a69 = is_empty xs in + let a68 = not a69 in + if a68 + then let h = list_head xs in + let tl = list_tail xs in + let a70 = a2 tl in + append h a70 + else fail_match + ;; + + let concat = a2 + ;; + + let rec iter f xs = let a71 = is_empty xs in + if a71 + then () + else let a73 = is_empty xs in + let a72 = not a73 in + if a72 + then let h = list_head xs in + let tl = list_tail xs in + let () = f h in + iter f tl + else fail_match + ;; + + let a3 h a = (h, a) + ;; + + let rec cartesian xs ys = let a74 = is_empty xs in + if a74 + then [] + else let a76 = is_empty xs in + let a75 = not a76 in + if a75 + then let h = list_head xs in + let tl = list_tail xs in + let a79 = cartesian tl ys in + let a78 = a3 h in + let a77 = map a78 ys in + append a77 a79 + else fail_match + ;; + + let main = let a82 = (3::[]) in + let a81 = (2::a82) in + let a80 = (1::a81) in + let () = iter print_int a80 in + let a90 = (4::[]) in + let a89 = (3::a90) in + let a88 = (2::a89) in + let a87 = (1::a88) in + let a86 = (2::[]) in + let a85 = (1::a86) in + let a84 = cartesian a85 a87 in + let a83 = length a84 in + let () = print_int a83 in + 0 + ;; + Типы после приведения в ANF: + val length : 'a list -> int + val a1 : int -> 'a list -> int + val length_tail : 'a list -> int + val map : ('a -> 'b) -> 'a list -> 'b list + val append : 'a list -> 'a list -> 'a list + val a2 : 'a list list -> 'a list + val concat : 'a list list -> 'a list + val iter : ('a -> unit) -> 'a list -> unit + val a3 : 'a -> 'b -> 'a * 'b + val cartesian : 'a list -> 'b list -> 'a * 'b list + val main : int diff --git a/FML/tests/closure_conv_manytest.t b/FML/tests/closure_conv_manytest.t index e793c57cc..9f91dd0d9 100644 --- a/FML/tests/closure_conv_manytest.t +++ b/FML/tests/closure_conv_manytest.t @@ -116,7 +116,7 @@ ((f 1), (f true)) $ ./closure_conv_runner.exe < manytests/typed/011mapcps.ml - let rec map = (fun fail_match is_empty list_head list_tail f xs k -> if (is_empty xs) + let rec map = (fun f xs k -> if (is_empty xs) then (k []) else if (not (is_empty xs)) then let h = (list_head xs) in @@ -124,7 +124,7 @@ (((map f) tl) ((((fun f h k a0 -> (k ((f h)::a0))) f) h) k)) else fail_match) - let rec iter = (fun fail_match is_empty list_head list_tail f xs -> if (is_empty xs) + let rec iter = (fun f xs -> if (is_empty xs) then () else if (not (is_empty xs)) then let h = (list_head xs) in @@ -143,7 +143,7 @@ $ ./closure_conv_runner.exe < manytests/typed/013foldfoldr.ml let id = (fun x -> x) - let rec fold_right = (fun fail_match is_empty list_head list_tail f acc xs -> if (is_empty xs) + let rec fold_right = (fun f acc xs -> if (is_empty xs) then acc else if (not (is_empty xs)) then let h = (list_head xs) in @@ -158,19 +158,19 @@ $ ./closure_conv_runner.exe < manytests/typed/015tuples.ml let rec fix = (fun f x -> ((f (fix f)) x)) - let map = (fun tuple_element f p -> let a = ((tuple_element p) 0) in + let map = (fun f p -> let a = ((tuple_element p) 0) in let b = ((tuple_element p) 1) in ((f a), (f b))) let fixpoly = (fun l -> ((fix (fun self a0 -> ((map (((fun a0 self li x -> ((li (self a0)) x)) a0) self)) a0))) l)) - let feven = (fun tuple_element p n -> let e = ((tuple_element p) 0) in + let feven = (fun p n -> let e = ((tuple_element p) 0) in let o = ((tuple_element p) 1) in if ((( = ) n) 0) then 1 else (o ((( - ) n) 1))) - let fodd = (fun tuple_element p n -> let e = ((tuple_element p) 0) in + let fodd = (fun p n -> let e = ((tuple_element p) 0) in let o = ((tuple_element p) 1) in if ((( = ) n) 0) then 0 @@ -194,7 +194,7 @@ 0 $ ./closure_conv_runner.exe < manytests/typed/016lists.ml - let rec length = (fun fail_match is_empty list_head list_tail xs -> if (is_empty xs) + let rec length = (fun xs -> if (is_empty xs) then 0 else if (not (is_empty xs)) then let h = (list_head xs) in @@ -202,16 +202,16 @@ ((( + ) 1) (length tl)) else fail_match) - let length_tail = let rec helper = (fun fail_match is_empty list_head list_tail acc xs -> if (is_empty xs) + let length_tail = let rec helper = (fun acc xs -> if (is_empty xs) then acc else if (not (is_empty xs)) then let h = (list_head xs) in let tl = (list_tail xs) in - ((((((helper fail_match) is_empty) list_head) list_tail) ((( + ) acc) 1)) tl) + ((helper ((( + ) acc) 1)) tl) else fail_match) in - (((((helper fail_match) is_empty) list_head) list_tail) 0) + (helper 0) - let rec map = (fun fail_match is_empty list_head list_tail f xs -> if (is_empty xs) + let rec map = (fun f xs -> if (is_empty xs) then [] else if ((( && ) (not (is_empty xs))) (is_empty (list_tail xs))) then let a = (list_head xs) in @@ -234,7 +234,7 @@ ((f a)::((f b)::((f c)::((f d)::((map f) tl))))) else fail_match) - let rec append = (fun fail_match is_empty list_head list_tail xs ys -> if (is_empty xs) + let rec append = (fun xs ys -> if (is_empty xs) then ys else if (not (is_empty xs)) then let x = (list_head xs) in @@ -242,16 +242,16 @@ (x::((append a0) ys)) else fail_match) - let concat = let rec helper = (fun fail_match is_empty list_head list_tail xs -> if (is_empty xs) + let concat = let rec helper = (fun xs -> if (is_empty xs) then [] else if (not (is_empty xs)) then let h = (list_head xs) in let tl = (list_tail xs) in - ((append h) (((((helper fail_match) is_empty) list_head) list_tail) tl)) + ((append h) (helper tl)) else fail_match) in - ((((helper fail_match) is_empty) list_head) list_tail) + helper - let rec iter = (fun fail_match is_empty list_head list_tail f xs -> if (is_empty xs) + let rec iter = (fun f xs -> if (is_empty xs) then () else if (not (is_empty xs)) then let h = (list_head xs) in @@ -260,7 +260,7 @@ ((iter f) tl) else fail_match) - let rec cartesian = (fun fail_match is_empty list_head list_tail xs ys -> if (is_empty xs) + let rec cartesian = (fun xs ys -> if (is_empty xs) then [] else if (not (is_empty xs)) then let h = (list_head xs) in diff --git a/FML/tests/lambda_lifting_manytests.t b/FML/tests/lambda_lifting_manytests.t index fc708ed8b..cf294901d 100644 --- a/FML/tests/lambda_lifting_manytests.t +++ b/FML/tests/lambda_lifting_manytests.t @@ -140,7 +140,7 @@ $ ./lambda_lifting_runner.exe < manytests/typed/011mapcps.ml let a1 = (fun f h k a0 -> (k ((f h)::a0))) - let rec map = (fun fail_match is_empty list_head list_tail f xs k -> if (is_empty xs) + let rec map = (fun f xs k -> if (is_empty xs) then (k []) else if (not (is_empty xs)) then let h = (list_head xs) in @@ -148,7 +148,7 @@ (((map f) tl) (((a1 f) h) k)) else fail_match) - let rec iter = (fun fail_match is_empty list_head list_tail f xs -> if (is_empty xs) + let rec iter = (fun f xs -> if (is_empty xs) then () else if (not (is_empty xs)) then let h = (list_head xs) in @@ -177,7 +177,7 @@ $ ./lambda_lifting_runner.exe < manytests/typed/013foldfoldr.ml let id = (fun x -> x) - let rec fold_right = (fun fail_match is_empty list_head list_tail f acc xs -> if (is_empty xs) + let rec fold_right = (fun f acc xs -> if (is_empty xs) then acc else if (not (is_empty xs)) then let h = (list_head xs) in @@ -196,7 +196,7 @@ $ ./lambda_lifting_runner.exe < manytests/typed/015tuples.ml let rec fix = (fun f x -> ((f (fix f)) x)) - let map = (fun tuple_element f p -> let a = ((tuple_element p) 0) in + let map = (fun f p -> let a = ((tuple_element p) 0) in let b = ((tuple_element p) 1) in ((f a), (f b))) @@ -206,13 +206,13 @@ let fixpoly = (fun l -> ((fix a1) l)) - let feven = (fun tuple_element p n -> let e = ((tuple_element p) 0) in + let feven = (fun p n -> let e = ((tuple_element p) 0) in let o = ((tuple_element p) 1) in if ((( = ) n) 0) then 1 else (o ((( - ) n) 1))) - let fodd = (fun tuple_element p n -> let e = ((tuple_element p) 0) in + let fodd = (fun p n -> let e = ((tuple_element p) 0) in let o = ((tuple_element p) 1) in if ((( = ) n) 0) then 0 @@ -236,7 +236,7 @@ 0 $ ./lambda_lifting_runner.exe < manytests/typed/016lists.ml - let rec length = (fun fail_match is_empty list_head list_tail xs -> if (is_empty xs) + let rec length = (fun xs -> if (is_empty xs) then 0 else if (not (is_empty xs)) then let h = (list_head xs) in @@ -244,17 +244,17 @@ ((( + ) 1) (length tl)) else fail_match) - let rec a1 = (fun fail_match is_empty list_head list_tail acc xs -> if (is_empty xs) + let rec a1 = (fun acc xs -> if (is_empty xs) then acc else if (not (is_empty xs)) then let h = (list_head xs) in let tl = (list_tail xs) in - ((((((a1 fail_match) is_empty) list_head) list_tail) ((( + ) acc) 1)) tl) + ((a1 ((( + ) acc) 1)) tl) else fail_match) - let length_tail = (((((a1 fail_match) is_empty) list_head) list_tail) 0) + let length_tail = (a1 0) - let rec map = (fun fail_match is_empty list_head list_tail f xs -> if (is_empty xs) + let rec map = (fun f xs -> if (is_empty xs) then [] else if ((( && ) (not (is_empty xs))) (is_empty (list_tail xs))) then let a = (list_head xs) in @@ -277,7 +277,7 @@ ((f a)::((f b)::((f c)::((f d)::((map f) tl))))) else fail_match) - let rec append = (fun fail_match is_empty list_head list_tail xs ys -> if (is_empty xs) + let rec append = (fun xs ys -> if (is_empty xs) then ys else if (not (is_empty xs)) then let x = (list_head xs) in @@ -285,17 +285,17 @@ (x::((append a0) ys)) else fail_match) - let rec a2 = (fun fail_match is_empty list_head list_tail xs -> if (is_empty xs) + let rec a2 = (fun xs -> if (is_empty xs) then [] else if (not (is_empty xs)) then let h = (list_head xs) in let tl = (list_tail xs) in - ((append h) (((((a2 fail_match) is_empty) list_head) list_tail) tl)) + ((append h) (a2 tl)) else fail_match) - let concat = ((((a2 fail_match) is_empty) list_head) list_tail) + let concat = a2 - let rec iter = (fun fail_match is_empty list_head list_tail f xs -> if (is_empty xs) + let rec iter = (fun f xs -> if (is_empty xs) then () else if (not (is_empty xs)) then let h = (list_head xs) in @@ -306,7 +306,7 @@ let a3 = (fun h a -> (h, a)) - let rec cartesian = (fun fail_match is_empty list_head list_tail xs ys -> if (is_empty xs) + let rec cartesian = (fun xs ys -> if (is_empty xs) then [] else if (not (is_empty xs)) then let h = (list_head xs) in From 0c58bd2152a7dc298d94eb1db1273367e9ae14f5 Mon Sep 17 00:00:00 2001 From: Kakadu Date: Mon, 24 Mar 2025 15:53:03 +0300 Subject: [PATCH 48/92] Typechecker fails Signed-off-by: Kakadu --- FML/tests/anf_manytests.t | 21 +++++++++++++++++++++ 1 file changed, 21 insertions(+) diff --git a/FML/tests/anf_manytests.t b/FML/tests/anf_manytests.t index 06c9654fd..e38b7175a 100644 --- a/FML/tests/anf_manytests.t +++ b/FML/tests/anf_manytests.t @@ -364,6 +364,27 @@ val fib : int -> (int -> 'a) -> 'a val a2 : 'a -> 'a val main : unit + $ ./anf_runner.exe << EOF + > let is_empty x = x+1 + > let rec length xs = match xs with + > | [] -> 0 + > | _::tl -> 1 + length xs + > EOF + let a0 x = ( + ) x 1 + ;; + + let rec length xs = let a1 = a0 xs in + if a1 + then 0 + else let a3 = a0 xs in + let a2 = not a3 in + if a2 + then let _ = list_head xs in + let tl = list_tail xs in + let a4 = length xs in + ( + ) 1 a4 + else fail_match + ;; $ ./anf_runner.exe < manytests/typed/013foldfoldr.ml let id x = x ;; From bcf0a2bb4f026731b607b5f51791792c35239c19 Mon Sep 17 00:00:00 2001 From: Dmitry Pilyuk Date: Mon, 24 Mar 2025 17:25:38 +0300 Subject: [PATCH 49/92] Fix type of tuple_element func --- FML/lib/inferencer/inferencer.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/FML/lib/inferencer/inferencer.ml b/FML/lib/inferencer/inferencer.ml index b9bc74d58..f7eaa96f4 100644 --- a/FML/lib/inferencer/inferencer.ml +++ b/FML/lib/inferencer/inferencer.ml @@ -658,7 +658,7 @@ let start_env = ; "is_empty", TFunction (TList (TVar 1), TBool) ; "list_head", TFunction (TList (TVar 1), TVar 1) ; "list_tail", TFunction (TList (TVar 1), TList (TVar 1)) - ; "tuple_element", TFunction (TVar 1, TVar 2) + ; "tuple_element", TFunction (TVar 1, TFunction (TInt, TVar 2)) ; "fail_match", TVar 1 ] in From 8f9032c877afe5226b33ef63cb75474f189bfa63 Mon Sep 17 00:00:00 2001 From: Dmitry Pilyuk Date: Sun, 30 Mar 2025 17:02:06 +0300 Subject: [PATCH 50/92] Rework alpha_conv --- FML/lib/anf/a_conv.ml | 201 +++++ FML/lib/dune | 1 + FML/tests/a_conv_manytest.t | 1390 +++++++++++++++++++++++++++++++ FML/tests/a_conv_runner.ml | 25 + FML/tests/alpha_conv_manytest.t | 10 + FML/tests/anf_manytests.t | 2 + FML/tests/dune | 32 + FML/tests/pe_manytests.t | 10 + 8 files changed, 1671 insertions(+) create mode 100644 FML/lib/anf/a_conv.ml create mode 100644 FML/tests/a_conv_manytest.t create mode 100644 FML/tests/a_conv_runner.ml diff --git a/FML/lib/anf/a_conv.ml b/FML/lib/anf/a_conv.ml new file mode 100644 index 000000000..03d3102af --- /dev/null +++ b/FML/lib/anf/a_conv.ml @@ -0,0 +1,201 @@ +(** Copyright 2024-2025, Dmitry Pilyuk, Aleksandr Rozhkov *) + +(** SPDX-License-Identifier: LGPL-2.1 *) + +open Base +open Ast +open Common + +module StateMonad : sig + include Base.Monad.Infix + + val return : 'a -> 'a t + val ( let* ) : 'a t -> ('a -> 'b t) -> 'b t + + module RList : sig + val fold_left : 'a list -> init:'b t -> f:('b -> 'a -> 'b t) -> 'b t + end + + module RMap : sig + val fold_left + : ('a, 'b, 'c) Base.Map.t + -> init:'d t + -> f:('a -> 'b -> 'd -> 'd t) + -> 'd t + end + + val fresh : int t + val run : 'a t -> 'a +end = struct + type 'a t = int -> int * 'a (* State and Result monad composition *) + + let ( >>= ) : 'a 'b. 'a t -> ('a -> 'b t) -> 'b t = + fun m f s -> + let s', v' = m s in + f v' s' + ;; + + let ( >>| ) : 'a 'b. 'a t -> ('a -> 'b) -> 'b t = + fun m f s -> + let s', x = m s in + s', f x + ;; + + let return v last = last, v + let bind x ~f = x >>= f + let fresh last = last + 1, last (* Get new state *) + let ( let* ) x f = bind x ~f (* Syntax sugar for bind *) + + module RMap = struct + (* Classic map folding. *) + let fold_left mp ~init ~f = + Base.Map.fold mp ~init ~f:(fun ~key ~data acc -> + let* acc = acc in + f key data acc) + ;; + end + + module RList = struct + (* Classic list folding. *) + let fold_left lt ~init ~f = + Base.List.fold_left lt ~init ~f:(fun acc item -> + let* acc = acc in + f acc item) + ;; + end + + (* Run and get the internal value. *) + let run m = snd (m 0) +end + +open StateMonad + +let get_new_id n name = String.concat [ name; "_ac"; Int.to_string n ] + +let rec ac_pattern env bindings = function + | PIdentifier name as pat -> + if StrSet.find env name + then + let* fr = fresh in + let id = get_new_id fr name in + return + (StrSet.add env id, StrMap.update bindings name ~f:(fun _ -> id), PIdentifier id) + else return (StrSet.add env name, bindings, pat) + | PConstraint (pat, _) -> ac_pattern env bindings pat + | PCons (hd, tl) -> + let* env', bindings', hd_pat = ac_pattern env bindings hd in + let* env'', bindings'', tl_pat = ac_pattern env' bindings' tl in + return (env'', bindings'', PCons (hd_pat, tl_pat)) + | PTuple ps -> + let* env, bindings, ps = + RList.fold_left + ps + ~init:(return (env, bindings, [])) + ~f:(fun (e, b, ps) p -> + let* env, bindings, pat = ac_pattern e b p in + return (env, bindings, pat :: ps)) + in + return (env, bindings, PTuple (List.rev ps)) + | pat -> return (env, bindings, pat) +;; + +let rec ac_expr env bindings = function + | EConst c -> return @@ EConst c + | ENill -> return ENill + | EUnit -> return EUnit + | EConstraint (e, t) -> + let* expr = ac_expr env bindings e in + return @@ EConstraint (expr, t) + | EIdentifier id as expr -> + (match StrMap.find bindings id with + | Some new_id -> return @@ EIdentifier new_id + | None -> return expr) + | ELetIn (NoRec, pat, e1, e2) -> + let* e1' = ac_expr env bindings e1 in + let* env', bindings', pat' = ac_pattern env bindings pat in + let* e2' = ac_expr env' bindings' e2 in + return @@ ELetIn (NoRec, pat', e1', e2') + | ELetIn (Rec, pat, e1, e2) -> + let* env', bindings', pat' = ac_pattern env bindings pat in + let* e1' = ac_expr env' bindings' e1 in + let* e2' = ac_expr env' bindings' e2 in + return @@ ELetIn (Rec, pat', e1', e2') + | EApplication (e1, e2) -> + let* e1' = ac_expr env bindings e1 in + let* e2' = ac_expr env bindings e2 in + return (EApplication (e1', e2')) + | ECons (e1, e2) -> + let* e1' = ac_expr env bindings e1 in + let* e2' = ac_expr env bindings e2 in + return (ECons (e1', e2')) + | EFun (pat, expr) -> + let* env', bindings', pat' = ac_pattern env bindings pat in + let* expr' = ac_expr env' bindings' expr in + return @@ EFun (pat', expr') + | EIf (e_if, e_then, e_else) -> + let* e_if' = ac_expr env bindings e_if in + let* e_then' = ac_expr env bindings e_then in + let* e_else' = ac_expr env bindings e_else in + return @@ EIf (e_if', e_then', e_else') + | ETuple exprs -> + let* l = + RList.fold_left exprs ~init:(return []) ~f:(fun acc expr -> + let* e = ac_expr env bindings expr in + return @@ (e :: acc)) + in + return @@ ETuple (List.rev l) + | EMatch (expr, cases) -> + let* expr' = ac_expr env bindings expr in + let* cases' = + RList.fold_left cases ~init:(return []) ~f:(fun acc (pat, expr) -> + let* env', bindings', pat' = ac_pattern env bindings pat in + let* expr' = ac_expr env' bindings' expr in + return ((pat', expr') :: acc)) + in + return @@ EMatch (expr', List.rev cases') +;; + +let ac_decls env bindings = function + | NoRecDecl decls -> + let* env, bindings, decls = + RList.fold_left + decls + ~init:(return (env, bindings, [])) + ~f:(fun (new_env, new_bindings, decl_list) (DDeclaration (pat, expr)) -> + let* env', bindings', pat' = ac_pattern new_env new_bindings pat in + let* expr' = ac_expr env bindings expr in + return (env', bindings', DDeclaration (pat', expr') :: decl_list)) + in + return (env, bindings, NoRecDecl (List.rev decls)) + | RecDecl decls -> + let* env', bindings', decls' = + RList.fold_left + decls + ~init:(return (env, bindings, [])) + ~f:(fun (new_env, new_bindings, acc_decls) (DDeclaration (pat, expr)) -> + let* env', bindings', pat' = ac_pattern new_env new_bindings pat in + return (env', bindings', DDeclaration (pat', expr) :: acc_decls)) + in + let* env, bindings, decls = + RList.fold_left + decls' + ~init:(return (env', bindings', [])) + ~f:(fun (env, bindings, acc_decls) (DDeclaration (pat, expr)) -> + let* expr' = ac_expr env bindings expr in + return (env', bindings', DDeclaration (pat, expr') :: acc_decls)) + in + return (env, bindings, RecDecl decls) +;; + +let ac_program ast = + run + (let* _, _, decls = + RList.fold_left + ast + ~init:(return (StrSet.of_list builtins, StrMap.empty, [])) + ~f:(fun (env, bindings, decls) decl -> + let* new_env, new_bindings, new_decl = ac_decls env bindings decl in + return (new_env, new_bindings, new_decl :: decls)) + in + return @@ List.rev decls) +;; diff --git a/FML/lib/dune b/FML/lib/dune index 8bda918ed..511ccfd8e 100644 --- a/FML/lib/dune +++ b/FML/lib/dune @@ -14,6 +14,7 @@ Common Pe_ast Alpha_conv + A_conv Closure_conv Lambda_lifting Anf_ast diff --git a/FML/tests/a_conv_manytest.t b/FML/tests/a_conv_manytest.t new file mode 100644 index 000000000..b926d0cf5 --- /dev/null +++ b/FML/tests/a_conv_manytest.t @@ -0,0 +1,1390 @@ + $ ./a_conv_runner.exe << EOF + > let is_empty x = x+1 + > let rec length xs = match xs with + > | [] -> 0 + > | _::tl -> 1 + length xs + > EOF + [(NoRecDecl + [(DDeclaration ((PIdentifier "is_empty_ac0"), + (EFun ((PIdentifier "x"), + (EApplication ( + (EApplication ((EIdentifier "( + )"), (EIdentifier "x"))), + (EConst (CInt 1)))) + )) + )) + ]); + (RecDecl + [(DDeclaration ((PIdentifier "length"), + (EFun ((PIdentifier "xs"), + (EMatch ((EIdentifier "xs"), + [(PNill, (EConst (CInt 0))); + ((PCons ((PIdentifier "_"), (PIdentifier "tl"))), + (EApplication ( + (EApplication ((EIdentifier "( + )"), (EConst (CInt 1)) + )), + (EApplication ((EIdentifier "length"), + (EIdentifier "xs"))) + ))) + ] + )) + )) + )) + ]) + ] + + $ ./a_conv_runner.exe << EOF + > let fac n = + > let rec fack n k = + > if n<=1 then k 1 + > else fack (n - 1) ((fun k n m -> k (m * n)) k n) + > in + > fack n (fun x -> x) + > EOF + [(NoRecDecl + [(DDeclaration ((PIdentifier "fac"), + (EFun ((PIdentifier "n"), + (ELetIn (Rec, (PIdentifier "fack"), + (EFun ((PIdentifier "n_ac0"), + (EFun ((PIdentifier "k"), + (EIf ( + (EApplication ( + (EApplication ((EIdentifier "( <= )"), + (EIdentifier "n_ac0"))), + (EConst (CInt 1)))), + (EApplication ((EIdentifier "k"), (EConst (CInt 1)))), + (EApplication ( + (EApplication ((EIdentifier "fack"), + (EApplication ( + (EApplication ((EIdentifier "( - )"), + (EIdentifier "n_ac0"))), + (EConst (CInt 1)))) + )), + (EApplication ( + (EApplication ( + (EFun ((PIdentifier "k_ac1"), + (EFun ((PIdentifier "n_ac2"), + (EFun ((PIdentifier "m"), + (EApplication ( + (EIdentifier "k_ac1"), + (EApplication ( + (EApplication ( + (EIdentifier "( * )"), + (EIdentifier "m"))), + (EIdentifier "n_ac2"))) + )) + )) + )) + )), + (EIdentifier "k"))), + (EIdentifier "n_ac0"))) + )) + )) + )) + )), + (EApplication ( + (EApplication ((EIdentifier "fack"), (EIdentifier "n"))), + (EFun ((PIdentifier "x"), (EIdentifier "x"))))) + )) + )) + )) + ]) + ] + $ ./a_conv_runner.exe < manytests/typed/001fac.ml + [(RecDecl + [(DDeclaration ((PIdentifier "fac"), + (EFun ((PIdentifier "n"), + (EIf ( + (EApplication ( + (EApplication ((EIdentifier "( <= )"), (EIdentifier "n"))), + (EConst (CInt 1)))), + (EConst (CInt 1)), + (EApplication ( + (EApplication ((EIdentifier "( * )"), (EIdentifier "n"))), + (EApplication ((EIdentifier "fac"), + (EApplication ( + (EApplication ((EIdentifier "( - )"), + (EIdentifier "n"))), + (EConst (CInt 1)))) + )) + )) + )) + )) + )) + ]); + (NoRecDecl + [(DDeclaration ((PIdentifier "main"), + (ELetIn (NoRec, PUnit, + (EApplication ((EIdentifier "print_int"), + (EApplication ((EIdentifier "fac"), (EConst (CInt 4)))))), + (EConst (CInt 0)))) + )) + ]) + ] + + $ ./a_conv_runner.exe < manytests/typed/002fac.ml + [(RecDecl + [(DDeclaration ((PIdentifier "fac_cps"), + (EFun ((PIdentifier "n"), + (EFun ((PIdentifier "k"), + (EIf ( + (EApplication ( + (EApplication ((EIdentifier "( = )"), (EIdentifier "n"))), + (EConst (CInt 1)))), + (EApplication ((EIdentifier "k"), (EConst (CInt 1)))), + (EApplication ( + (EApplication ((EIdentifier "fac_cps"), + (EApplication ( + (EApplication ((EIdentifier "( - )"), + (EIdentifier "n"))), + (EConst (CInt 1)))) + )), + (EFun ((PIdentifier "p"), + (EApplication ((EIdentifier "k"), + (EApplication ( + (EApplication ((EIdentifier "( * )"), + (EIdentifier "p"))), + (EIdentifier "n"))) + )) + )) + )) + )) + )) + )) + )) + ]); + (NoRecDecl + [(DDeclaration ((PIdentifier "main"), + (ELetIn (NoRec, PUnit, + (EApplication ((EIdentifier "print_int"), + (EApplication ( + (EApplication ((EIdentifier "fac_cps"), (EConst (CInt 4)))), + (EFun ((PIdentifier "print_int_ac0"), + (EIdentifier "print_int_ac0"))) + )) + )), + (EConst (CInt 0)))) + )) + ]) + ] + + $ ./a_conv_runner.exe < manytests/typed/003fib.ml + [(RecDecl + [(DDeclaration ((PIdentifier "fib_acc"), + (EFun ((PIdentifier "a"), + (EFun ((PIdentifier "b"), + (EFun ((PIdentifier "n"), + (EIf ( + (EApplication ( + (EApplication ((EIdentifier "( = )"), + (EIdentifier "n"))), + (EConst (CInt 1)))), + (EIdentifier "b"), + (ELetIn (NoRec, (PIdentifier "n1"), + (EApplication ( + (EApplication ((EIdentifier "( - )"), + (EIdentifier "n"))), + (EConst (CInt 1)))), + (ELetIn (NoRec, (PIdentifier "ab"), + (EApplication ( + (EApplication ((EIdentifier "( + )"), + (EIdentifier "a"))), + (EIdentifier "b"))), + (EApplication ( + (EApplication ( + (EApplication ((EIdentifier "fib_acc"), + (EIdentifier "b"))), + (EIdentifier "ab"))), + (EIdentifier "n1"))) + )) + )) + )) + )) + )) + )) + )) + ]); + (RecDecl + [(DDeclaration ((PIdentifier "fib"), + (EFun ((PIdentifier "n"), + (EIf ( + (EApplication ( + (EApplication ((EIdentifier "( < )"), (EIdentifier "n"))), + (EConst (CInt 2)))), + (EIdentifier "n"), + (EApplication ( + (EApplication ((EIdentifier "( + )"), + (EApplication ((EIdentifier "fib"), + (EApplication ( + (EApplication ((EIdentifier "( - )"), + (EIdentifier "n"))), + (EConst (CInt 1)))) + )) + )), + (EApplication ((EIdentifier "fib"), + (EApplication ( + (EApplication ((EIdentifier "( - )"), + (EIdentifier "n"))), + (EConst (CInt 2)))) + )) + )) + )) + )) + )) + ]); + (NoRecDecl + [(DDeclaration ((PIdentifier "main"), + (ELetIn (NoRec, PUnit, + (EApplication ((EIdentifier "print_int"), + (EApplication ( + (EApplication ( + (EApplication ((EIdentifier "fib_acc"), + (EConst (CInt 0)))), + (EConst (CInt 1)))), + (EConst (CInt 4)))) + )), + (ELetIn (NoRec, PUnit, + (EApplication ((EIdentifier "print_int"), + (EApplication ((EIdentifier "fib"), (EConst (CInt 4)))))), + (EConst (CInt 0)))) + )) + )) + ]) + ] + + $ ./a_conv_runner.exe < manytests/typed/004manyargs.ml + [(NoRecDecl + [(DDeclaration ((PIdentifier "wrap"), + (EFun ((PIdentifier "f"), + (EIf ( + (EApplication ( + (EApplication ((EIdentifier "( = )"), (EConst (CInt 1)))), + (EConst (CInt 1)))), + (EIdentifier "f"), (EIdentifier "f"))) + )) + )) + ]); + (NoRecDecl + [(DDeclaration ((PIdentifier "test3"), + (EFun ((PIdentifier "a"), + (EFun ((PIdentifier "b"), + (EFun ((PIdentifier "c"), + (ELetIn (NoRec, (PIdentifier "a_ac0"), + (EApplication ((EIdentifier "print_int"), + (EIdentifier "a"))), + (ELetIn (NoRec, (PIdentifier "b_ac1"), + (EApplication ((EIdentifier "print_int"), + (EIdentifier "b"))), + (ELetIn (NoRec, (PIdentifier "c_ac2"), + (EApplication ((EIdentifier "print_int"), + (EIdentifier "c"))), + (EConst (CInt 0)))) + )) + )) + )) + )) + )) + )) + ]); + (NoRecDecl + [(DDeclaration ((PIdentifier "test10"), + (EFun ((PIdentifier "a"), + (EFun ((PIdentifier "b"), + (EFun ((PIdentifier "c"), + (EFun ((PIdentifier "d"), + (EFun ((PIdentifier "e"), + (EFun ((PIdentifier "f"), + (EFun ((PIdentifier "g"), + (EFun ((PIdentifier "h"), + (EFun ((PIdentifier "i"), + (EFun ((PIdentifier "j"), + (EApplication ( + (EApplication ( + (EIdentifier "( + )"), + (EApplication ( + (EApplication ( + (EIdentifier "( + )"), + (EApplication ( + (EApplication ( + (EIdentifier "( + )"), + (EApplication ( + (EApplication ( + (EIdentifier + "( + )"), + (EApplication ( + (EApplication ( + (EIdentifier + "( + )"), + (EApplication ( + (EApplication ( + (EIdentifier + "( + )"), + (EApplication ( + (EApplication ( + (EIdentifier + "( + )"), + (EApplication ( + (EApplication ( + (EIdentifier + "( + )"), + (EApplication ( + (EApplication ( + (EIdentifier + "( + )"), + (EIdentifier + "a"))), + (EIdentifier + "b"))))), + (EIdentifier + "c"))))), + (EIdentifier + "d"))))), + (EIdentifier + "e"))))), + (EIdentifier + "f") + )) + )), + (EIdentifier "g") + )) + )), + (EIdentifier "h"))) + )), + (EIdentifier "i"))) + )), + (EIdentifier "j"))) + )) + )) + )) + )) + )) + )) + )) + )) + )) + )) + )) + ]); + (NoRecDecl + [(DDeclaration ((PIdentifier "main"), + (ELetIn (NoRec, (PIdentifier "rez"), + (EApplication ( + (EApplication ( + (EApplication ( + (EApplication ( + (EApplication ( + (EApplication ( + (EApplication ( + (EApplication ( + (EApplication ( + (EApplication ( + (EApplication ( + (EIdentifier "wrap"), + (EIdentifier "test10"))), + (EConst (CInt 1)))), + (EConst (CInt 10)))), + (EConst (CInt 100)))), + (EConst (CInt 1000)))), + (EConst (CInt 10000)))), + (EConst (CInt 100000)))), + (EConst (CInt 1000000)))), + (EConst (CInt 10000000)))), + (EConst (CInt 100000000)))), + (EConst (CInt 1000000000)))), + (ELetIn (NoRec, PUnit, + (EApplication ((EIdentifier "print_int"), (EIdentifier "rez") + )), + (ELetIn (NoRec, (PIdentifier "temp2"), + (EApplication ( + (EApplication ( + (EApplication ( + (EApplication ((EIdentifier "wrap"), + (EIdentifier "test3"))), + (EConst (CInt 1)))), + (EConst (CInt 10)))), + (EConst (CInt 100)))), + (EConst (CInt 0)))) + )) + )) + )) + ]) + ] + + $ ./a_conv_runner.exe < manytests/typed/005fix.ml + [(RecDecl + [(DDeclaration ((PIdentifier "fix"), + (EFun ((PIdentifier "f"), + (EFun ((PIdentifier "x"), + (EApplication ( + (EApplication ((EIdentifier "f"), + (EApplication ((EIdentifier "fix"), (EIdentifier "f"))))), + (EIdentifier "x"))) + )) + )) + )) + ]); + (NoRecDecl + [(DDeclaration ((PIdentifier "fac"), + (EFun ((PIdentifier "self"), + (EFun ((PIdentifier "n"), + (EIf ( + (EApplication ( + (EApplication ((EIdentifier "( <= )"), (EIdentifier "n") + )), + (EConst (CInt 1)))), + (EConst (CInt 1)), + (EApplication ( + (EApplication ((EIdentifier "( * )"), (EIdentifier "n") + )), + (EApplication ((EIdentifier "self"), + (EApplication ( + (EApplication ((EIdentifier "( - )"), + (EIdentifier "n"))), + (EConst (CInt 1)))) + )) + )) + )) + )) + )) + )) + ]); + (NoRecDecl + [(DDeclaration ((PIdentifier "main"), + (ELetIn (NoRec, PUnit, + (EApplication ((EIdentifier "print_int"), + (EApplication ( + (EApplication ((EIdentifier "fix"), (EIdentifier "fac"))), + (EConst (CInt 6)))) + )), + (EConst (CInt 0)))) + )) + ]) + ] + + $ ./a_conv_runner.exe < manytests/typed/006partial.ml + [(NoRecDecl + [(DDeclaration ((PIdentifier "foo"), + (EFun ((PIdentifier "b"), + (EIf ((EIdentifier "b"), + (EFun ((PIdentifier "foo"), + (EApplication ( + (EApplication ((EIdentifier "( + )"), (EIdentifier "foo") + )), + (EConst (CInt 2)))) + )), + (EFun ((PIdentifier "foo"), + (EApplication ( + (EApplication ((EIdentifier "( * )"), (EIdentifier "foo") + )), + (EConst (CInt 10)))) + )) + )) + )) + )) + ]); + (NoRecDecl + [(DDeclaration ((PIdentifier "foo_ac0"), + (EFun ((PIdentifier "x"), + (EApplication ( + (EApplication ((EIdentifier "foo"), (EConst (CBool true)))), + (EApplication ( + (EApplication ((EIdentifier "foo"), (EConst (CBool false)) + )), + (EApplication ( + (EApplication ((EIdentifier "foo"), + (EConst (CBool true)))), + (EApplication ( + (EApplication ((EIdentifier "foo"), + (EConst (CBool false)))), + (EIdentifier "x"))) + )) + )) + )) + )) + )) + ]); + (NoRecDecl + [(DDeclaration ((PIdentifier "main"), + (ELetIn (NoRec, PUnit, + (EApplication ((EIdentifier "print_int"), + (EApplication ((EIdentifier "foo_ac0"), (EConst (CInt 11)))))), + (EConst (CInt 0)))) + )) + ]) + ] + + $ ./a_conv_runner.exe < manytests/typed/006partial2.ml + [(NoRecDecl + [(DDeclaration ((PIdentifier "foo"), + (EFun ((PIdentifier "a"), + (EFun ((PIdentifier "b"), + (EFun ((PIdentifier "c"), + (ELetIn (NoRec, PUnit, + (EApplication ((EIdentifier "print_int"), + (EIdentifier "a"))), + (ELetIn (NoRec, PUnit, + (EApplication ((EIdentifier "print_int"), + (EIdentifier "b"))), + (ELetIn (NoRec, PUnit, + (EApplication ((EIdentifier "print_int"), + (EIdentifier "c"))), + (EApplication ( + (EApplication ((EIdentifier "( + )"), + (EIdentifier "a"))), + (EApplication ( + (EApplication ((EIdentifier "( * )"), + (EIdentifier "b"))), + (EIdentifier "c"))) + )) + )) + )) + )) + )) + )) + )) + )) + ]); + (NoRecDecl + [(DDeclaration ((PIdentifier "main"), + (ELetIn (NoRec, (PIdentifier "foo_ac0"), + (EApplication ((EIdentifier "foo"), (EConst (CInt 1)))), + (ELetIn (NoRec, (PIdentifier "foo_ac1"), + (EApplication ((EIdentifier "foo_ac0"), (EConst (CInt 2)))), + (ELetIn (NoRec, (PIdentifier "foo_ac2"), + (EApplication ((EIdentifier "foo_ac1"), (EConst (CInt 3)))), + (ELetIn (NoRec, PUnit, + (EApplication ((EIdentifier "print_int"), + (EIdentifier "foo_ac2"))), + (EConst (CInt 0)))) + )) + )) + )) + )) + ]) + ] + $ ./a_conv_runner.exe < manytests/typed/006partial3.ml + [(NoRecDecl + [(DDeclaration ((PIdentifier "foo"), + (EFun ((PIdentifier "a"), + (ELetIn (NoRec, PUnit, + (EApplication ((EIdentifier "print_int"), (EIdentifier "a"))), + (EFun ((PIdentifier "b"), + (ELetIn (NoRec, PUnit, + (EApplication ((EIdentifier "print_int"), + (EIdentifier "b"))), + (EFun ((PIdentifier "c"), + (EApplication ((EIdentifier "print_int"), + (EIdentifier "c"))) + )) + )) + )) + )) + )) + )) + ]); + (NoRecDecl + [(DDeclaration ((PIdentifier "main"), + (ELetIn (NoRec, PUnit, + (EApplication ( + (EApplication ( + (EApplication ((EIdentifier "foo"), (EConst (CInt 4)))), + (EConst (CInt 8)))), + (EConst (CInt 9)))), + (EConst (CInt 0)))) + )) + ]) + ] + $ ./a_conv_runner.exe < manytests/typed/007order.ml + [(NoRecDecl + [(DDeclaration ((PIdentifier "_start"), + (EFun (PUnit, + (EFun (PUnit, + (EFun ((PIdentifier "a"), + (EFun (PUnit, + (EFun ((PIdentifier "b"), + (EFun ((PIdentifier "_c"), + (EFun (PUnit, + (EFun ((PIdentifier "d"), + (EFun ((PIdentifier "__"), + (ELetIn (NoRec, PUnit, + (EApplication ( + (EIdentifier "print_int"), + (EApplication ( + (EApplication ( + (EIdentifier "( + )"), + (EIdentifier "a"))), + (EIdentifier "b"))) + )), + (ELetIn (NoRec, PUnit, + (EApplication ( + (EIdentifier "print_int"), + (EIdentifier "__"))), + (EApplication ( + (EApplication ( + (EIdentifier "( + )"), + (EApplication ( + (EApplication ( + (EIdentifier "( / )"), + (EApplication ( + (EApplication ( + (EIdentifier + "( * )"), + (EIdentifier "a") + )), + (EIdentifier "b"))) + )), + (EIdentifier "_c"))) + )), + (EIdentifier "d"))) + )) + )) + )) + )) + )) + )) + )) + )) + )) + )) + )) + )) + ]); + (NoRecDecl + [(DDeclaration ((PIdentifier "main"), + (EApplication ((EIdentifier "print_int"), + (EApplication ( + (EApplication ( + (EApplication ( + (EApplication ( + (EApplication ( + (EApplication ( + (EApplication ( + (EApplication ( + (EApplication ((EIdentifier "_start"), + (EApplication ( + (EIdentifier "print_int"), + (EConst (CInt 1)))) + )), + (EApplication ((EIdentifier "print_int"), + (EConst (CInt 2)))) + )), + (EConst (CInt 3)))), + (EApplication ((EIdentifier "print_int"), + (EConst (CInt 4)))) + )), + (EConst (CInt 100)))), + (EConst (CInt 1000)))), + (EApplication ((EIdentifier "print_int"), + (EApplication ((EIdentifier "( ~- )"), + (EConst (CInt 1)))) + )) + )), + (EConst (CInt 10000)))), + (EApplication ((EIdentifier "( ~- )"), (EConst (CInt 555555)) + )) + )) + )) + )) + ]) + ] + $ ./a_conv_runner.exe < manytests/typed/008ascription.ml + [(NoRecDecl + [(DDeclaration ((PIdentifier "addi"), + (EFun ((PIdentifier "f"), + (EFun ((PIdentifier "g"), + (EFun ((PIdentifier "x"), + (EConstraint ( + (EApplication ( + (EApplication ((EIdentifier "f"), (EIdentifier "x"))), + (EConstraint ( + (EApplication ((EIdentifier "g"), (EIdentifier "x") + )), + ABool)) + )), + AInt)) + )) + )) + )) + )) + ]); + (NoRecDecl + [(DDeclaration ((PIdentifier "main"), + (ELetIn (NoRec, PUnit, + (EApplication ((EIdentifier "print_int"), + (EApplication ( + (EApplication ( + (EApplication ((EIdentifier "addi"), + (EFun ((PIdentifier "x"), + (EFun ((PIdentifier "b"), + (EIf ((EIdentifier "b"), + (EApplication ( + (EApplication ((EIdentifier "( + )"), + (EIdentifier "x"))), + (EConst (CInt 1)))), + (EApplication ( + (EApplication ((EIdentifier "( * )"), + (EIdentifier "x"))), + (EConst (CInt 2)))) + )) + )) + )) + )), + (EFun ((PIdentifier "_start"), + (EApplication ( + (EApplication ((EIdentifier "( = )"), + (EApplication ( + (EApplication ((EIdentifier "( / )"), + (EIdentifier "_start"))), + (EConst (CInt 2)))) + )), + (EConst (CInt 0)))) + )) + )), + (EConst (CInt 4)))) + )), + (EConst (CInt 0)))) + )) + ]) + ] + + $ ./a_conv_runner.exe < manytests/typed/009let_poly.ml + [(NoRecDecl + [(DDeclaration ((PIdentifier "temp"), + (ELetIn (NoRec, (PIdentifier "f"), + (EFun ((PIdentifier "x"), (EIdentifier "x"))), + (ETuple + [(EApplication ((EIdentifier "f"), (EConst (CInt 1)))); + (EApplication ((EIdentifier "f"), (EConst (CBool true))))]) + )) + )) + ]) + ] + + $ ./a_conv_runner.exe < manytests/typed/011mapcps.ml + [(RecDecl + [(DDeclaration ((PIdentifier "map"), + (EFun ((PIdentifier "f"), + (EFun ((PIdentifier "xs"), + (EFun ((PIdentifier "k"), + (EMatch ((EIdentifier "xs"), + [(PNill, (EApplication ((EIdentifier "k"), ENill))); + ((PCons ((PIdentifier "h"), (PIdentifier "tl"))), + (EApplication ( + (EApplication ( + (EApplication ((EIdentifier "map"), + (EIdentifier "f"))), + (EIdentifier "tl"))), + (EFun ((PIdentifier "tl_ac0"), + (EApplication ((EIdentifier "k"), + (ECons ( + (EApplication ((EIdentifier "f"), + (EIdentifier "h"))), + (EIdentifier "tl_ac0"))) + )) + )) + ))) + ] + )) + )) + )) + )) + )) + ]); + (RecDecl + [(DDeclaration ((PIdentifier "iter"), + (EFun ((PIdentifier "f"), + (EFun ((PIdentifier "xs"), + (EMatch ((EIdentifier "xs"), + [(PNill, EUnit); + ((PCons ((PIdentifier "h"), (PIdentifier "tl"))), + (ELetIn (NoRec, (PIdentifier "w"), + (EApplication ((EIdentifier "f"), (EIdentifier "h"))), + (EApplication ( + (EApplication ((EIdentifier "iter"), + (EIdentifier "f"))), + (EIdentifier "tl"))) + ))) + ] + )) + )) + )) + )) + ]); + (NoRecDecl + [(DDeclaration ((PIdentifier "main"), + (EApplication ( + (EApplication ((EIdentifier "iter"), (EIdentifier "print_int"))), + (EApplication ( + (EApplication ( + (EApplication ((EIdentifier "map"), + (EFun ((PIdentifier "x"), + (EApplication ( + (EApplication ((EIdentifier "( + )"), + (EIdentifier "x"))), + (EConst (CInt 1)))) + )) + )), + (ECons ((EConst (CInt 1)), + (ECons ((EConst (CInt 2)), + (ECons ((EConst (CInt 3)), ENill)))) + )) + )), + (EFun ((PIdentifier "x"), (EIdentifier "x"))))) + )) + )) + ]) + ] + $ ./a_conv_runner.exe < manytests/typed/012fibcps.ml + [(RecDecl + [(DDeclaration ((PIdentifier "fib"), + (EFun ((PIdentifier "n"), + (EFun ((PIdentifier "k"), + (EIf ( + (EApplication ( + (EApplication ((EIdentifier "( < )"), (EIdentifier "n"))), + (EConst (CInt 2)))), + (EApplication ((EIdentifier "k"), (EIdentifier "n"))), + (EApplication ( + (EApplication ((EIdentifier "fib"), + (EApplication ( + (EApplication ((EIdentifier "( - )"), + (EIdentifier "n"))), + (EConst (CInt 1)))) + )), + (EFun ((PIdentifier "a"), + (EApplication ( + (EApplication ((EIdentifier "fib"), + (EApplication ( + (EApplication ((EIdentifier "( - )"), + (EIdentifier "n"))), + (EConst (CInt 2)))) + )), + (EFun ((PIdentifier "b"), + (EApplication ((EIdentifier "k"), + (EApplication ( + (EApplication ((EIdentifier "( + )"), + (EIdentifier "a"))), + (EIdentifier "b"))) + )) + )) + )) + )) + )) + )) + )) + )) + )) + ]); + (NoRecDecl + [(DDeclaration ((PIdentifier "main"), + (EApplication ((EIdentifier "print_int"), + (EApplication ( + (EApplication ((EIdentifier "fib"), (EConst (CInt 6)))), + (EFun ((PIdentifier "x"), (EIdentifier "x"))))) + )) + )) + ]) + ] + $ ./a_conv_runner.exe < manytests/typed/013foldfoldr.ml + [(NoRecDecl + [(DDeclaration ((PIdentifier "id"), + (EFun ((PIdentifier "x"), (EIdentifier "x"))))) + ]); + (RecDecl + [(DDeclaration ((PIdentifier "fold_right"), + (EFun ((PIdentifier "f"), + (EFun ((PIdentifier "acc"), + (EFun ((PIdentifier "xs"), + (EMatch ((EIdentifier "xs"), + [(PNill, (EIdentifier "acc")); + ((PCons ((PIdentifier "h"), (PIdentifier "tl"))), + (EApplication ( + (EApplication ((EIdentifier "f"), + (EIdentifier "h"))), + (EApplication ( + (EApplication ( + (EApplication ((EIdentifier "fold_right"), + (EIdentifier "f"))), + (EIdentifier "acc"))), + (EIdentifier "tl"))) + ))) + ] + )) + )) + )) + )) + )) + ]); + (NoRecDecl + [(DDeclaration ((PIdentifier "foldl"), + (EFun ((PIdentifier "f"), + (EFun ((PIdentifier "a"), + (EFun ((PIdentifier "bs"), + (EApplication ( + (EApplication ( + (EApplication ( + (EApplication ((EIdentifier "fold_right"), + (EFun ((PIdentifier "b"), + (EFun ((PIdentifier "g"), + (EFun ((PIdentifier "x"), + (EApplication ((EIdentifier "g"), + (EApplication ( + (EApplication ( + (EIdentifier "f"), + (EIdentifier "x"))), + (EIdentifier "b"))) + )) + )) + )) + )) + )), + (EIdentifier "id"))), + (EIdentifier "bs"))), + (EIdentifier "a"))) + )) + )) + )) + )) + ]); + (NoRecDecl + [(DDeclaration ((PIdentifier "main"), + (EApplication ((EIdentifier "print_int"), + (EApplication ( + (EApplication ( + (EApplication ((EIdentifier "foldl"), + (EFun ((PIdentifier "x"), + (EFun ((PIdentifier "y"), + (EApplication ( + (EApplication ((EIdentifier "( * )"), + (EIdentifier "x"))), + (EIdentifier "y"))) + )) + )) + )), + (EConst (CInt 1)))), + (ECons ((EConst (CInt 1)), + (ECons ((EConst (CInt 2)), + (ECons ((EConst (CInt 3)), ENill)))) + )) + )) + )) + )) + ]) + ] + + $ ./a_conv_runner.exe < manytests/typed/015tuples.ml + [(RecDecl + [(DDeclaration ((PIdentifier "fix"), + (EFun ((PIdentifier "f"), + (EFun ((PIdentifier "x"), + (EApplication ( + (EApplication ((EIdentifier "f"), + (EApplication ((EIdentifier "fix"), (EIdentifier "f"))))), + (EIdentifier "x"))) + )) + )) + )) + ]); + (NoRecDecl + [(DDeclaration ((PIdentifier "map"), + (EFun ((PIdentifier "f"), + (EFun ((PIdentifier "p"), + (ELetIn (NoRec, + (PTuple [(PIdentifier "a"); (PIdentifier "b")]), + (EIdentifier "p"), + (ETuple + [(EApplication ((EIdentifier "f"), (EIdentifier "a"))); + (EApplication ((EIdentifier "f"), (EIdentifier "b")))]) + )) + )) + )) + )) + ]); + (NoRecDecl + [(DDeclaration ((PIdentifier "fixpoly"), + (EFun ((PIdentifier "l"), + (EApplication ( + (EApplication ((EIdentifier "fix"), + (EFun ((PIdentifier "self"), + (EFun ((PIdentifier "l_ac0"), + (EApplication ( + (EApplication ((EIdentifier "map"), + (EFun ((PIdentifier "li"), + (EFun ((PIdentifier "x"), + (EApplication ( + (EApplication ((EIdentifier "li"), + (EApplication ( + (EIdentifier "self"), + (EIdentifier "l_ac0"))) + )), + (EIdentifier "x"))) + )) + )) + )), + (EIdentifier "l_ac0"))) + )) + )) + )), + (EIdentifier "l"))) + )) + )) + ]); + (NoRecDecl + [(DDeclaration ((PIdentifier "feven"), + (EFun ((PIdentifier "p"), + (EFun ((PIdentifier "n"), + (ELetIn (NoRec, + (PTuple [(PIdentifier "e"); (PIdentifier "o")]), + (EIdentifier "p"), + (EIf ( + (EApplication ( + (EApplication ((EIdentifier "( = )"), + (EIdentifier "n"))), + (EConst (CInt 0)))), + (EConst (CInt 1)), + (EApplication ((EIdentifier "o"), + (EApplication ( + (EApplication ((EIdentifier "( - )"), + (EIdentifier "n"))), + (EConst (CInt 1)))) + )) + )) + )) + )) + )) + )) + ]); + (NoRecDecl + [(DDeclaration ((PIdentifier "fodd"), + (EFun ((PIdentifier "p"), + (EFun ((PIdentifier "n"), + (ELetIn (NoRec, + (PTuple [(PIdentifier "e"); (PIdentifier "o")]), + (EIdentifier "p"), + (EIf ( + (EApplication ( + (EApplication ((EIdentifier "( = )"), + (EIdentifier "n"))), + (EConst (CInt 0)))), + (EConst (CInt 0)), + (EApplication ((EIdentifier "e"), + (EApplication ( + (EApplication ((EIdentifier "( - )"), + (EIdentifier "n"))), + (EConst (CInt 1)))) + )) + )) + )) + )) + )) + )) + ]); + (NoRecDecl + [(DDeclaration ((PIdentifier "tie"), + (EApplication ((EIdentifier "fixpoly"), + (ETuple [(EIdentifier "feven"); (EIdentifier "fodd")]))) + )) + ]); + (RecDecl + [(DDeclaration ((PIdentifier "meven"), + (EFun ((PIdentifier "n"), + (EIf ( + (EApplication ( + (EApplication ((EIdentifier "( = )"), (EIdentifier "n"))), + (EConst (CInt 0)))), + (EConst (CInt 1)), + (EApplication ((EIdentifier "modd"), + (EApplication ( + (EApplication ((EIdentifier "( - )"), (EIdentifier "n") + )), + (EConst (CInt 1)))) + )) + )) + )) + )); + (DDeclaration ((PIdentifier "modd"), + (EFun ((PIdentifier "n"), + (EIf ( + (EApplication ( + (EApplication ((EIdentifier "( = )"), (EIdentifier "n"))), + (EConst (CInt 0)))), + (EConst (CInt 1)), + (EApplication ((EIdentifier "meven"), + (EApplication ( + (EApplication ((EIdentifier "( - )"), (EIdentifier "n") + )), + (EConst (CInt 1)))) + )) + )) + )) + )) + ]); + (NoRecDecl + [(DDeclaration ((PIdentifier "main"), + (ELetIn (NoRec, PUnit, + (EApplication ((EIdentifier "print_int"), + (EApplication ((EIdentifier "modd"), (EConst (CInt 1)))))), + (ELetIn (NoRec, PUnit, + (EApplication ((EIdentifier "print_int"), + (EApplication ((EIdentifier "meven"), (EConst (CInt 2)))))), + (ELetIn (NoRec, + (PTuple [(PIdentifier "even"); (PIdentifier "odd")]), + (EIdentifier "tie"), + (ELetIn (NoRec, PUnit, + (EApplication ((EIdentifier "print_int"), + (EApplication ((EIdentifier "odd"), (EConst (CInt 3)) + )) + )), + (ELetIn (NoRec, PUnit, + (EApplication ((EIdentifier "print_int"), + (EApplication ((EIdentifier "even"), + (EConst (CInt 4)))) + )), + (EConst (CInt 0)))) + )) + )) + )) + )) + )) + ]) + ] + + $ ./a_conv_runner.exe < manytests/typed/016lists.ml + [(RecDecl + [(DDeclaration ((PIdentifier "length"), + (EFun ((PIdentifier "xs"), + (EMatch ((EIdentifier "xs"), + [(PNill, (EConst (CInt 0))); + ((PCons ((PIdentifier "h"), (PIdentifier "tl"))), + (EApplication ( + (EApplication ((EIdentifier "( + )"), (EConst (CInt 1)))), + (EApplication ((EIdentifier "length"), (EIdentifier "tl") + )) + ))) + ] + )) + )) + )) + ]); + (NoRecDecl + [(DDeclaration ((PIdentifier "length_tail"), + (ELetIn (Rec, (PIdentifier "helper"), + (EFun ((PIdentifier "acc"), + (EFun ((PIdentifier "xs"), + (EMatch ((EIdentifier "xs"), + [(PNill, (EIdentifier "acc")); + ((PCons ((PIdentifier "h"), (PIdentifier "tl"))), + (EApplication ( + (EApplication ((EIdentifier "helper"), + (EApplication ( + (EApplication ((EIdentifier "( + )"), + (EIdentifier "acc"))), + (EConst (CInt 1)))) + )), + (EIdentifier "tl")))) + ] + )) + )) + )), + (EApplication ((EIdentifier "helper"), (EConst (CInt 0)))))) + )) + ]); + (RecDecl + [(DDeclaration ((PIdentifier "map"), + (EFun ((PIdentifier "f"), + (EFun ((PIdentifier "xs"), + (EMatch ((EIdentifier "xs"), + [(PNill, ENill); + ((PCons ((PIdentifier "a"), PNill)), + (ECons ( + (EApplication ((EIdentifier "f"), (EIdentifier "a"))), + ENill))); + ((PCons ((PIdentifier "a"), + (PCons ((PIdentifier "b"), PNill)))), + (ECons ( + (EApplication ((EIdentifier "f"), (EIdentifier "a"))), + (ECons ( + (EApplication ((EIdentifier "f"), + (EIdentifier "b"))), + ENill)) + ))); + ((PCons ((PIdentifier "a"), + (PCons ((PIdentifier "b"), + (PCons ((PIdentifier "c"), PNill)))) + )), + (ECons ( + (EApplication ((EIdentifier "f"), (EIdentifier "a"))), + (ECons ( + (EApplication ((EIdentifier "f"), + (EIdentifier "b"))), + (ECons ( + (EApplication ((EIdentifier "f"), + (EIdentifier "c"))), + ENill)) + )) + ))); + ((PCons ((PIdentifier "a"), + (PCons ((PIdentifier "b"), + (PCons ((PIdentifier "c"), + (PCons ((PIdentifier "d"), (PIdentifier "tl"))) + )) + )) + )), + (ECons ( + (EApplication ((EIdentifier "f"), (EIdentifier "a"))), + (ECons ( + (EApplication ((EIdentifier "f"), + (EIdentifier "b"))), + (ECons ( + (EApplication ((EIdentifier "f"), + (EIdentifier "c"))), + (ECons ( + (EApplication ((EIdentifier "f"), + (EIdentifier "d"))), + (EApplication ( + (EApplication ((EIdentifier "map"), + (EIdentifier "f"))), + (EIdentifier "tl"))) + )) + )) + )) + ))) + ] + )) + )) + )) + )) + ]); + (RecDecl + [(DDeclaration ((PIdentifier "append"), + (EFun ((PIdentifier "xs"), + (EFun ((PIdentifier "ys"), + (EMatch ((EIdentifier "xs"), + [(PNill, (EIdentifier "ys")); + ((PCons ((PIdentifier "x"), (PIdentifier "xs_ac0"))), + (ECons ((EIdentifier "x"), + (EApplication ( + (EApplication ((EIdentifier "append"), + (EIdentifier "xs_ac0"))), + (EIdentifier "ys"))) + ))) + ] + )) + )) + )) + )) + ]); + (NoRecDecl + [(DDeclaration ((PIdentifier "concat"), + (ELetIn (Rec, (PIdentifier "helper"), + (EFun ((PIdentifier "xs"), + (EMatch ((EIdentifier "xs"), + [(PNill, ENill); + ((PCons ((PIdentifier "h"), (PIdentifier "tl"))), + (EApplication ( + (EApplication ((EIdentifier "append"), + (EIdentifier "h"))), + (EApplication ((EIdentifier "helper"), + (EIdentifier "tl"))) + ))) + ] + )) + )), + (EIdentifier "helper"))) + )) + ]); + (RecDecl + [(DDeclaration ((PIdentifier "iter"), + (EFun ((PIdentifier "f"), + (EFun ((PIdentifier "xs"), + (EMatch ((EIdentifier "xs"), + [(PNill, EUnit); + ((PCons ((PIdentifier "h"), (PIdentifier "tl"))), + (ELetIn (NoRec, PUnit, + (EApplication ((EIdentifier "f"), (EIdentifier "h"))), + (EApplication ( + (EApplication ((EIdentifier "iter"), + (EIdentifier "f"))), + (EIdentifier "tl"))) + ))) + ] + )) + )) + )) + )) + ]); + (RecDecl + [(DDeclaration ((PIdentifier "cartesian"), + (EFun ((PIdentifier "xs"), + (EFun ((PIdentifier "ys"), + (EMatch ((EIdentifier "xs"), + [(PNill, ENill); + ((PCons ((PIdentifier "h"), (PIdentifier "tl"))), + (EApplication ( + (EApplication ((EIdentifier "append"), + (EApplication ( + (EApplication ((EIdentifier "map"), + (EFun ((PIdentifier "a"), + (ETuple + [(EIdentifier "h"); (EIdentifier "a")]) + )) + )), + (EIdentifier "ys"))) + )), + (EApplication ( + (EApplication ((EIdentifier "cartesian"), + (EIdentifier "tl"))), + (EIdentifier "ys"))) + ))) + ] + )) + )) + )) + )) + ]); + (NoRecDecl + [(DDeclaration ((PIdentifier "main"), + (ELetIn (NoRec, PUnit, + (EApplication ( + (EApplication ((EIdentifier "iter"), (EIdentifier "print_int") + )), + (ECons ((EConst (CInt 1)), + (ECons ((EConst (CInt 2)), + (ECons ((EConst (CInt 3)), ENill)))) + )) + )), + (ELetIn (NoRec, PUnit, + (EApplication ((EIdentifier "print_int"), + (EApplication ((EIdentifier "length"), + (EApplication ( + (EApplication ((EIdentifier "cartesian"), + (ECons ((EConst (CInt 1)), + (ECons ((EConst (CInt 2)), ENill)))) + )), + (ECons ((EConst (CInt 1)), + (ECons ((EConst (CInt 2)), + (ECons ((EConst (CInt 3)), + (ECons ((EConst (CInt 4)), ENill)))) + )) + )) + )) + )) + )), + (EConst (CInt 0)))) + )) + )) + ]) + ] + + $ ./a_conv_runner.exe < manytests/do_not_type/001.ml + Infer error: + $ ./a_conv_runner.exe < manytests/do_not_type/002if.ml + Infer error: + $ ./a_conv_runner.exe < manytests/do_not_type/003occurs.ml + Infer error: + + $ ./a_conv_runner.exe < manytests/do_not_type/004let_poly.ml + Infer error: + + $ ./a_conv_runner.exe < manytests/do_not_type/015tuples.ml + Infer error: + diff --git a/FML/tests/a_conv_runner.ml b/FML/tests/a_conv_runner.ml new file mode 100644 index 000000000..165927516 --- /dev/null +++ b/FML/tests/a_conv_runner.ml @@ -0,0 +1,25 @@ +(** Copyright 2024-2025, Dmitry Pilyuk, Aleksandr Rozhkov *) + +(** SPDX-License-Identifier: LGPL-2.1 *) + +open Fml_lib.Ast +open Fml_lib.Parser +open Fml_lib.Inferencer +open Fml_lib.A_conv + +let () = + let input = Stdio.In_channel.input_all Stdlib.stdin in + let parse_and_infer input = + match parse input with + | Ok parsed -> + (match run_program_inferencer parsed with + | Ok _ -> Ok parsed + | Error _ -> Error (Format.asprintf "Infer error:")) + | Error e -> Error (Format.sprintf "Parsing error: %s" e) + in + match parse_and_infer input with + | Ok ast -> + let ast = ac_program ast in + Format.printf "%a\n" pp_program ast + | Error message -> Format.printf "%s" message +;; diff --git a/FML/tests/alpha_conv_manytest.t b/FML/tests/alpha_conv_manytest.t index 294cffa24..edee99b03 100644 --- a/FML/tests/alpha_conv_manytest.t +++ b/FML/tests/alpha_conv_manytest.t @@ -1,3 +1,13 @@ + $ ./alpha_conv_runner.exe << EOF + > let f n _ = n + > + > let main = let () = print_int (f 6 5) in 0 + > EOF + let f = (fun n a0 -> n) + + let main = let () = (print_int ((f 6) 5)) in + 0 + $ ./alpha_conv_runner.exe << EOF > let fac n = > let rec fack n k = diff --git a/FML/tests/anf_manytests.t b/FML/tests/anf_manytests.t index e38b7175a..599cd83de 100644 --- a/FML/tests/anf_manytests.t +++ b/FML/tests/anf_manytests.t @@ -385,6 +385,8 @@ ( + ) 1 a4 else fail_match ;; + Типы после приведения в ANF: + Infer error. $ ./anf_runner.exe < manytests/typed/013foldfoldr.ml let id x = x ;; diff --git a/FML/tests/dune b/FML/tests/dune index 51e02550a..1164038f6 100644 --- a/FML/tests/dune +++ b/FML/tests/dune @@ -32,6 +32,12 @@ (modules alpha_conv_runner) (libraries fml_lib stdio)) +(executable + (name a_conv_runner) + (public_name a_conv_runner) + (modules a_conv_runner) + (libraries fml_lib stdio)) + (executable (name closure_conv_runner) (public_name closure_conv_runner) @@ -154,6 +160,32 @@ manytests/typed/015tuples.ml manytests/typed/016lists.ml)) +(cram + (applies_to a_conv_manytest) + (deps + ./a_conv_runner.exe + manytests/do_not_type/001.ml + manytests/do_not_type/002if.ml + manytests/do_not_type/003occurs.ml + manytests/do_not_type/004let_poly.ml + manytests/do_not_type/015tuples.ml + manytests/typed/001fac.ml + manytests/typed/002fac.ml + manytests/typed/003fib.ml + manytests/typed/004manyargs.ml + manytests/typed/005fix.ml + manytests/typed/006partial.ml + manytests/typed/006partial2.ml + manytests/typed/006partial3.ml + manytests/typed/007order.ml + manytests/typed/008ascription.ml + manytests/typed/009let_poly.ml + manytests/typed/011mapcps.ml + manytests/typed/012fibcps.ml + manytests/typed/013foldfoldr.ml + manytests/typed/015tuples.ml + manytests/typed/016lists.ml)) + (cram (applies_to closure_conv_manytest) (deps diff --git a/FML/tests/pe_manytests.t b/FML/tests/pe_manytests.t index 9c91b7b56..894427882 100644 --- a/FML/tests/pe_manytests.t +++ b/FML/tests/pe_manytests.t @@ -1,3 +1,13 @@ + $ ./pe_runner.exe << EOF + > let f n _ = n + > + > let main = let () = print_int (f 6 5) in 0 + > EOF + let f = (fun n a0 -> n) + + let main = let () = (print_int ((f 6) 5)) in + 0 + $ ./pe_runner.exe < manytests/typed/001fac.ml let rec fac = (fun n -> if ((( <= ) n) 1) then 1 From d244bb4b81a662d47084d62a7ad6cc0cc78fdf61 Mon Sep 17 00:00:00 2001 From: RozhkovAleksandr Date: Tue, 1 Apr 2025 23:24:25 +0300 Subject: [PATCH 51/92] add a little for me --- FML/lib/anf/match_elimination.ml | 89 ++++++++++++++++++++++++++++++++ FML/lib/dune | 1 + 2 files changed, 90 insertions(+) create mode 100644 FML/lib/anf/match_elimination.ml diff --git a/FML/lib/anf/match_elimination.ml b/FML/lib/anf/match_elimination.ml new file mode 100644 index 000000000..dc02ab9e1 --- /dev/null +++ b/FML/lib/anf/match_elimination.ml @@ -0,0 +1,89 @@ +(** Copyright 2024-2025, Dmitry Pilyuk, Aleksandr Rozhkov *) + +(** SPDX-License-Identifier: LGPL-2.1 *) + +open Ast +open Pe_ast +open Common + +module StateMonad : sig + include Base.Monad.Infix + + val return : 'a -> 'a t + val ( let* ) : 'a t -> ('a -> 'b t) -> 'b t + + module RList : sig + val fold_left : 'a list -> init:'b t -> f:('b -> 'a -> 'b t) -> 'b t + end + + module RMap : sig + val fold_left + : ('a, 'b, 'c) Base.Map.t + -> init:'d t + -> f:('a -> 'b -> 'd -> 'd t) + -> 'd t + end + + val fresh : int t + val run : 'a t -> 'a +end = struct + type 'a t = int -> int * 'a (* State and Result monad composition *) + + let ( >>= ) : 'a 'b. 'a t -> ('a -> 'b t) -> 'b t = + fun m f s -> + let s', v' = m s in + f v' s' + ;; + + let ( >>| ) : 'a 'b. 'a t -> ('a -> 'b) -> 'b t = + fun m f s -> + let s', x = m s in + s', f x + ;; + + let return v last = last, v + let bind x ~f = x >>= f + let fresh last = last + 1, last (* Get new state *) + let ( let* ) x f = bind x ~f (* Syntax sugar for bind *) + + module RMap = struct + (* Classic map folding. *) + let fold_left mp ~init ~f = + Base.Map.fold mp ~init ~f:(fun ~key ~data acc -> + let* acc = acc in + f key data acc) + ;; + end + + module RList = struct + (* Classic list folding. *) + let fold_left lt ~init ~f = + Base.List.fold_left lt ~init ~f:(fun acc item -> + let* acc = acc in + f acc item) + ;; + end + + (* Run and get the internal value. *) + let run m = snd (m 0) +end + +open StateMonad + + +let const_to_pe_const = function + | CInt a -> Pe_Cint a + | CBool a -> Pe_CBool a + +let rec expr_to_mexpr = function + | EUnit -> return @@ Pe_EUnit + | ENill -> return @@ Pe_ENill + | EConstraint (a, _) -> (expr_to_mexpr a) + | EConst a -> return @@ Pe_EConst (const_to_pe_const a) + | EIdentifier a -> return @@ Pe_EIdentifier a + | EApplication (a, b) -> + let* a = expr_to_mexpr a in + let* b = expr_to_mexpr b in + return @@ Pe_EApp (a, b) + | _ -> failwith "not impl" + \ No newline at end of file diff --git a/FML/lib/dune b/FML/lib/dune index 511ccfd8e..127b524c2 100644 --- a/FML/lib/dune +++ b/FML/lib/dune @@ -15,6 +15,7 @@ Pe_ast Alpha_conv A_conv + Match_elimination Closure_conv Lambda_lifting Anf_ast From 01af38faee6c5e483840cd520c1d761f40e661af Mon Sep 17 00:00:00 2001 From: RozhkovAleksandr Date: Wed, 2 Apr 2025 23:36:29 +0300 Subject: [PATCH 52/92] feat: semi-live version match elimination --- FML/lib/anf/match_elimination.ml | 151 ++++++++++- FML/tests/dune | 32 +++ FML/tests/match_elimination_manytest.t | 351 +++++++++++++++++++++++++ FML/tests/match_elimination_runner.ml | 27 ++ 4 files changed, 547 insertions(+), 14 deletions(-) create mode 100644 FML/tests/match_elimination_manytest.t create mode 100644 FML/tests/match_elimination_runner.ml diff --git a/FML/lib/anf/match_elimination.ml b/FML/lib/anf/match_elimination.ml index dc02ab9e1..1856447a9 100644 --- a/FML/lib/anf/match_elimination.ml +++ b/FML/lib/anf/match_elimination.ml @@ -3,8 +3,8 @@ (** SPDX-License-Identifier: LGPL-2.1 *) open Ast +open Base open Pe_ast -open Common module StateMonad : sig include Base.Monad.Infix @@ -68,22 +68,145 @@ end = struct let run m = snd (m 0) end -open StateMonad +let get_new_id n name = String.concat [ name; "_me"; Int.to_string n ] + +open StateMonad let const_to_pe_const = function | CInt a -> Pe_Cint a | CBool a -> Pe_CBool a -let rec expr_to_mexpr = function - | EUnit -> return @@ Pe_EUnit - | ENill -> return @@ Pe_ENill - | EConstraint (a, _) -> (expr_to_mexpr a) - | EConst a -> return @@ Pe_EConst (const_to_pe_const a) - | EIdentifier a -> return @@ Pe_EIdentifier a - | EApplication (a, b) -> - let* a = expr_to_mexpr a in - let* b = expr_to_mexpr b in - return @@ Pe_EApp (a, b) - | _ -> failwith "not impl" - \ No newline at end of file +let rec pattern_remove pat = + match pat with + | PUnit -> ["()"] + | PConst _ -> [] + | PIdentifier id -> [id] + | PNill -> ["[]"] + | PTuple pats -> List.concat_map ~f:pattern_remove pats + | PCons (hd, tl) -> pattern_remove hd @ pattern_remove tl + | PConstraint (p, _) -> pattern_remove p + | _ -> failwith "bye-bye, bro. im sleeping" + +let rec_flags : Ast.rec_flag -> Pe_ast.rec_flag = function + | Rec -> Rec + | NoRec -> NoRec + +let rec expr_to_mexpr expr = + match expr with + | EUnit -> return Pe_EUnit + | ENill -> return Pe_ENill + | EConstraint (e, _) -> expr_to_mexpr e + | EConst c -> return @@ Pe_EConst (const_to_pe_const c) + | EIdentifier id -> return @@ Pe_EIdentifier id + | EApplication (f, arg) -> + let* f' = expr_to_mexpr f in + let* arg' = expr_to_mexpr arg in + return @@ Pe_EApp (f', arg') + | EFun (pat, body) -> + let ids = pattern_remove pat in + let* body' = expr_to_mexpr body in + return @@ Pe_EFun (ids, body') + | ELetIn (rec_flag, pat, e1, e2) -> + let ids = pattern_remove pat in + let* e1' = expr_to_mexpr e1 in + let* e2' = expr_to_mexpr e2 in + let rec_flag = rec_flags rec_flag in + (match ids with + | [id] -> return @@ Pe_ELet (rec_flag, id, e1', e2') + | _ -> failwith "Only simple let bindings with 1 identifier are supported after alpha conversion") + | ETuple exprs -> + let* exprs' = RList.fold_left exprs ~init:(return []) ~f:(fun acc e -> + let* e' = expr_to_mexpr e in + return (acc @ [e'])) in + return @@ Pe_ETuple exprs' + | EIf (cond, then_, else_) -> + let* cond' = expr_to_mexpr cond in + let* then_' = expr_to_mexpr then_ in + let* else_' = expr_to_mexpr else_ in + return @@ Pe_EIf (cond', then_', else_') + | ECons (hd, tl) -> + let* hd' = expr_to_mexpr hd in + let* tl' = expr_to_mexpr tl in + return @@ Pe_ECons (hd', tl') + | EMatch (e, branches) -> + desugar_match e branches + +and desugar_match e branches = + let* e' = expr_to_mexpr e in + match branches with + | [] -> failwith "Empty match expression" + | (pat, expr_rhs) :: rest -> + let* id_num = fresh in + let tmp_var = get_new_id id_num "match_tmp" in + let bound_expr = Pe_EIdentifier tmp_var in + let* expr_rhs' = expr_to_mexpr expr_rhs in + let rec pattern_to_condition expr pat = + match pat with + | PAny -> return @@ Pe_EConst (Pe_CBool true) + | PUnit -> return @@ Pe_EIf (Pe_EApp (Pe_EIdentifier "is_unit", expr), Pe_EConst (Pe_CBool true), Pe_EConst (Pe_CBool false)) + | PConst c -> return @@ Pe_EApp (Pe_EApp (Pe_EIdentifier "(=)", + expr), + Pe_EConst (const_to_pe_const c)) + | PIdentifier _ -> return @@ Pe_EConst (Pe_CBool true) + | PNill -> return @@ Pe_EApp (Pe_EIdentifier "is_nil", expr) + | PCons (hd, tl) -> + let hd_expr = Pe_EApp (Pe_EIdentifier "hd", expr) in + let tl_expr = Pe_EApp (Pe_EIdentifier "tl", expr) in + let* cond_hd = pattern_to_condition hd_expr hd in + let* cond_tl = pattern_to_condition tl_expr tl in + return @@ Pe_EIf (Pe_EApp (Pe_EIdentifier "is_cons", expr), + Pe_EIf (cond_hd, cond_tl, Pe_EConst (Pe_CBool false)), + Pe_EConst (Pe_CBool false)) + | PTuple pats -> + let* conds = + RList.fold_left (List.mapi pats ~f:(fun i p -> (i, p))) + ~init:(return []) + ~f:(fun acc (i, p) -> + let ith_expr = Pe_EApp (Pe_EIdentifier ("fst" ^ Int.to_string i), expr) in + let* cond = pattern_to_condition ith_expr p in + return (acc @ [cond])) in + return @@ List.fold_right conds ~init:(Pe_EConst (Pe_CBool true)) + ~f:(fun c acc -> Pe_EIf (c, acc, Pe_EConst (Pe_CBool false))) + | PConstraint (p, _) -> pattern_to_condition expr p + in + + let* cond = pattern_to_condition bound_expr pat in + let* rest_expr = + match rest with + | [] -> return @@ Pe_EConst (Pe_CBool false) (* dummy fail case *) + | _ -> desugar_match (EIdentifier tmp_var) rest + in + return @@ Pe_ELet (NoRec, tmp_var, e', + Pe_EIf (cond, expr_rhs', rest_expr)) + + +let decl_to_pe_decl decl = + match decl with + | NoRecDecl decls -> + let* converted = + RList.fold_left decls ~init:(return []) ~f:(fun acc (DDeclaration (pat, expr)) -> + let ids = pattern_remove pat in + match ids with + | [id] -> + let* e' = expr_to_mexpr expr in + return ((id, e') :: acc) + | _ -> failwith "Bang-Bang. Only simple declarations supported") in + return @@ Pe_Nonrec (List.rev converted) + | RecDecl decls -> + let* converted = + RList.fold_left decls ~init:(return []) ~f:(fun acc (DDeclaration (pat, expr)) -> + let ids = pattern_remove pat in + match ids with + | [id] -> + let* e' = expr_to_mexpr expr in + return ((id, e') :: acc) + | _ -> failwith "Bang-Bang. Only simple declarations supported") in + return @@ Pe_Rec (List.rev converted) + +let match_elimination prog = + StateMonad.run ( + RList.fold_left prog ~init:(return []) ~f:(fun acc decl -> + let* d = decl_to_pe_decl decl in + return (acc @ [d])) + ) \ No newline at end of file diff --git a/FML/tests/dune b/FML/tests/dune index 1164038f6..cef7fee37 100644 --- a/FML/tests/dune +++ b/FML/tests/dune @@ -38,6 +38,12 @@ (modules a_conv_runner) (libraries fml_lib stdio)) +(executable + (name match_elimination_runner) + (public_name match_elimination_runner) + (modules match_elimination_runner) + (libraries fml_lib stdio)) + (executable (name closure_conv_runner) (public_name closure_conv_runner) @@ -263,3 +269,29 @@ manytests/typed/013foldfoldr.ml manytests/typed/015tuples.ml manytests/typed/016lists.ml)) + +(cram + (applies_to match_elimination_manytest) + (deps + ./match_elimination_runner.exe + manytests/do_not_type/001.ml + manytests/do_not_type/002if.ml + manytests/do_not_type/003occurs.ml + manytests/do_not_type/004let_poly.ml + manytests/do_not_type/015tuples.ml + manytests/typed/001fac.ml + manytests/typed/002fac.ml + manytests/typed/003fib.ml + manytests/typed/004manyargs.ml + manytests/typed/005fix.ml + manytests/typed/006partial.ml + manytests/typed/006partial2.ml + manytests/typed/006partial3.ml + manytests/typed/007order.ml + manytests/typed/008ascription.ml + manytests/typed/009let_poly.ml + manytests/typed/011mapcps.ml + manytests/typed/012fibcps.ml + manytests/typed/013foldfoldr.ml + manytests/typed/015tuples.ml + manytests/typed/016lists.ml)) diff --git a/FML/tests/match_elimination_manytest.t b/FML/tests/match_elimination_manytest.t new file mode 100644 index 000000000..cd6417384 --- /dev/null +++ b/FML/tests/match_elimination_manytest.t @@ -0,0 +1,351 @@ + $ ./match_elimination_runner.exe << EOF + > let fac n = + > let rec fack n k = + > if n<=1 then k 1 + > else fack (n - 1) ((fun k n m -> k (m * n)) k n) + > in + > fack n (fun x -> x) + > EOF + let fac = (fun n -> let rec fack = (fun n_ac0 -> (fun k -> if ((( <= ) n_ac0) 1) + then (k 1) + else ((fack ((( - ) n_ac0) 1)) (((fun k_ac1 -> (fun n_ac2 -> (fun m -> (k_ac1 ((( * ) m) n_ac2))))) k) n_ac0)))) in + ((fack n) (fun x -> x))) + + $ ./match_elimination_runner.exe << EOF + > let f x = match x with + > | 1 -> true + > | _ -> false + > EOF + let f = (fun x -> let match_tmp_me0 = x in + if (((=) match_tmp_me0) 1) + then true + else let match_tmp_me1 = match_tmp_me0 in + if true + then false + else false) + + $ ./match_elimination_runner.exe < manytests/typed/001fac.ml + let rec fac = (fun n -> if ((( <= ) n) 1) + then 1 + else ((( * ) n) (fac ((( - ) n) 1)))) + + let main = let () = (print_int (fac 4)) in + 0 + + $ ./match_elimination_runner.exe < manytests/typed/002fac.ml + let rec fac_cps = (fun n -> (fun k -> if ((( = ) n) 1) + then (k 1) + else ((fac_cps ((( - ) n) 1)) (fun p -> (k ((( * ) p) n)))))) + + let main = let () = (print_int ((fac_cps 4) (fun print_int_ac0 -> print_int_ac0))) in + 0 + + $ ./match_elimination_runner.exe < manytests/typed/003fib.ml + let rec fib_acc = (fun a -> (fun b -> (fun n -> if ((( = ) n) 1) + then b + else let n1 = ((( - ) n) 1) in + let ab = ((( + ) a) b) in + (((fib_acc b) ab) n1)))) + + let rec fib = (fun n -> if ((( < ) n) 2) + then n + else ((( + ) (fib ((( - ) n) 1))) (fib ((( - ) n) 2)))) + + let main = let () = (print_int (((fib_acc 0) 1) 4)) in + let () = (print_int (fib 4)) in + 0 + + $ ./match_elimination_runner.exe < manytests/typed/004manyargs.ml + let wrap = (fun f -> if ((( = ) 1) 1) + then f + else f) + + let test3 = (fun a -> (fun b -> (fun c -> let a_ac0 = (print_int a) in + let b_ac1 = (print_int b) in + let c_ac2 = (print_int c) in + 0))) + + let test10 = (fun a -> (fun b -> (fun c -> (fun d -> (fun e -> (fun f -> (fun g -> (fun h -> (fun i -> (fun j -> ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) a) b)) c)) d)) e)) f)) g)) h)) i)) j))))))))))) + + let main = let rez = (((((((((((wrap test10) 1) 10) 100) 1000) 10000) 100000) 1000000) 10000000) 100000000) 1000000000) in + let () = (print_int rez) in + let temp2 = ((((wrap test3) 1) 10) 100) in + 0 + + $ ./match_elimination_runner.exe < manytests/typed/005fix.ml + let rec fix = (fun f -> (fun x -> ((f (fix f)) x))) + + let fac = (fun self -> (fun n -> if ((( <= ) n) 1) + then 1 + else ((( * ) n) (self ((( - ) n) 1))))) + + let main = let () = (print_int ((fix fac) 6)) in + 0 + + $ ./match_elimination_runner.exe < manytests/typed/006partial.ml + let foo = (fun b -> if b + then (fun foo -> ((( + ) foo) 2)) + else (fun foo -> ((( * ) foo) 10))) + + let foo_ac0 = (fun x -> ((foo true) ((foo false) ((foo true) ((foo false) x))))) + + let main = let () = (print_int (foo_ac0 11)) in + 0 + + $ ./match_elimination_runner.exe < manytests/typed/006partial2.ml + let foo = (fun a -> (fun b -> (fun c -> let () = (print_int a) in + let () = (print_int b) in + let () = (print_int c) in + ((( + ) a) ((( * ) b) c))))) + + let main = let foo_ac0 = (foo 1) in + let foo_ac1 = (foo_ac0 2) in + let foo_ac2 = (foo_ac1 3) in + let () = (print_int foo_ac2) in + 0 + $ ./match_elimination_runner.exe < manytests/typed/006partial3.ml + let foo = (fun a -> let () = (print_int a) in + (fun b -> let () = (print_int b) in + (fun c -> (print_int c)))) + + let main = let () = (((foo 4) 8) 9) in + 0 + $ ./match_elimination_runner.exe < manytests/typed/007order.ml + let _start = (fun () -> (fun () -> (fun a -> (fun () -> (fun b -> (fun _c -> (fun () -> (fun d -> (fun __ -> let () = (print_int ((( + ) a) b)) in + let () = (print_int __) in + ((( + ) ((( / ) ((( * ) a) b)) _c)) d)))))))))) + + let main = (print_int (((((((((_start (print_int 1)) (print_int 2)) 3) (print_int 4)) 100) 1000) (print_int (( ~- ) 1))) 10000) (( ~- ) 555555))) + $ ./match_elimination_runner.exe < manytests/typed/008ascription.ml + let addi = (fun f -> (fun g -> (fun x -> ((f x) (g x))))) + + let main = let () = (print_int (((addi (fun x -> (fun b -> if b + then ((( + ) x) 1) + else ((( * ) x) 2)))) (fun _start -> ((( = ) ((( / ) _start) 2)) 0))) 4)) in + 0 + + $ ./match_elimination_runner.exe < manytests/typed/009let_poly.ml + let temp = let f = (fun x -> x) in + ((f 1), (f true)) + + $ ./match_elimination_runner.exe < manytests/typed/011mapcps.ml + let rec map = (fun f -> (fun xs -> (fun k -> let match_tmp_me0 = xs in + if (is_nil match_tmp_me0) + then (k []) + else let match_tmp_me1 = match_tmp_me0 in + if if (is_cons match_tmp_me1) + then if true + then true + else false + else false + then (((map f) tl) (fun tl_ac0 -> (k ((f h)::tl_ac0)))) + else false))) + + let rec iter = (fun f -> (fun xs -> let match_tmp_me2 = xs in + if (is_nil match_tmp_me2) + then () + else let match_tmp_me3 = match_tmp_me2 in + if if (is_cons match_tmp_me3) + then if true + then true + else false + else false + then let w = (f h) in + ((iter f) tl) + else false)) + + let main = ((iter print_int) (((map (fun x -> ((( + ) x) 1))) (1::(2::(3::[])))) (fun x -> x))) + $ ./match_elimination_runner.exe < manytests/typed/012fibcps.ml + let rec fib = (fun n -> (fun k -> if ((( < ) n) 2) + then (k n) + else ((fib ((( - ) n) 1)) (fun a -> ((fib ((( - ) n) 2)) (fun b -> (k ((( + ) a) b)))))))) + + let main = (print_int ((fib 6) (fun x -> x))) + $ ./match_elimination_runner.exe < manytests/typed/013foldfoldr.ml + let id = (fun x -> x) + + let rec fold_right = (fun f -> (fun acc -> (fun xs -> let match_tmp_me0 = xs in + if (is_nil match_tmp_me0) + then acc + else let match_tmp_me1 = match_tmp_me0 in + if if (is_cons match_tmp_me1) + then if true + then true + else false + else false + then ((f h) (((fold_right f) acc) tl)) + else false))) + + let foldl = (fun f -> (fun a -> (fun bs -> ((((fold_right (fun b -> (fun g -> (fun x -> (g ((f x) b)))))) id) bs) a)))) + + let main = (print_int (((foldl (fun x -> (fun y -> ((( * ) x) y)))) 1) (1::(2::(3::[]))))) + + $ ./match_elimination_runner.exe < manytests/typed/015tuples.ml + Fatal error: exception Failure("Only simple let bindings with 1 identifier are supported after alpha conversion") + Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 + Called from Fml_lib__Match_elimination.StateMonad.(>>=) in file "lib/anf/match_elimination.ml", line 34, characters 17-20 + Called from Fml_lib__Match_elimination.StateMonad.(>>=) in file "lib/anf/match_elimination.ml", line 34, characters 17-20 + Called from Fml_lib__Match_elimination.StateMonad.(>>=) in file "lib/anf/match_elimination.ml", line 34, characters 17-20 + Called from Fml_lib__Match_elimination.StateMonad.(>>=) in file "lib/anf/match_elimination.ml", line 34, characters 17-20 + Called from Fml_lib__Match_elimination.StateMonad.(>>=) in file "lib/anf/match_elimination.ml", line 34, characters 17-20 + Called from Fml_lib__Match_elimination.StateMonad.(>>=) in file "lib/anf/match_elimination.ml", line 34, characters 17-20 + Called from Fml_lib__Match_elimination.StateMonad.(>>=) in file "lib/anf/match_elimination.ml", line 34, characters 17-20 + Called from Fml_lib__Match_elimination.StateMonad.(>>=) in file "lib/anf/match_elimination.ml", line 34, characters 17-20 + Called from Fml_lib__Match_elimination.StateMonad.(>>=) in file "lib/anf/match_elimination.ml", line 34, characters 17-20 + Called from Fml_lib__Match_elimination.StateMonad.(>>=) in file "lib/anf/match_elimination.ml", line 34, characters 17-20 + Called from Fml_lib__Match_elimination.StateMonad.(>>=) in file "lib/anf/match_elimination.ml", line 34, characters 17-20 + Called from Fml_lib__Match_elimination.StateMonad.run in file "lib/anf/match_elimination.ml" (inlined), line 68, characters 18-23 + Called from Fml_lib__Match_elimination.match_elimination in file "lib/anf/match_elimination.ml", line 210, characters 2-150 + Called from Dune__exe__Match_elimination_runner in file "tests/match_elimination_runner.ml", line 24, characters 17-38 + [2] + + $ ./match_elimination_runner.exe < manytests/typed/016lists.ml + let rec length = (fun xs -> let match_tmp_me0 = xs in + if (is_nil match_tmp_me0) + then 0 + else let match_tmp_me1 = match_tmp_me0 in + if if (is_cons match_tmp_me1) + then if true + then true + else false + else false + then ((( + ) 1) (length tl)) + else false) + + let length_tail = let rec helper = (fun acc -> (fun xs -> let match_tmp_me2 = xs in + if (is_nil match_tmp_me2) + then acc + else let match_tmp_me3 = match_tmp_me2 in + if if (is_cons match_tmp_me3) + then if true + then true + else false + else false + then ((helper ((( + ) acc) 1)) tl) + else false)) in + (helper 0) + + let rec map = (fun f -> (fun xs -> let match_tmp_me4 = xs in + if (is_nil match_tmp_me4) + then [] + else let match_tmp_me5 = match_tmp_me4 in + if if (is_cons match_tmp_me5) + then if true + then (is_nil (tl match_tmp_me5)) + else false + else false + then ((f a)::[]) + else let match_tmp_me6 = match_tmp_me5 in + if if (is_cons match_tmp_me6) + then if true + then if (is_cons (tl match_tmp_me6)) + then if true + then (is_nil (tl (tl match_tmp_me6))) + else false + else false + else false + else false + then ((f a)::((f b)::[])) + else let match_tmp_me7 = match_tmp_me6 in + if if (is_cons match_tmp_me7) + then if true + then if (is_cons (tl match_tmp_me7)) + then if true + then if (is_cons (tl (tl match_tmp_me7))) + then if true + then (is_nil (tl (tl (tl match_tmp_me7)))) + else false + else false + else false + else false + else false + else false + then ((f a)::((f b)::((f c)::[]))) + else let match_tmp_me8 = match_tmp_me7 in + if if (is_cons match_tmp_me8) + then if true + then if (is_cons (tl match_tmp_me8)) + then if true + then if (is_cons (tl (tl match_tmp_me8))) + then if true + then if (is_cons (tl (tl (tl match_tmp_me8)))) + then if true + then true + else false + else false + else false + else false + else false + else false + else false + else false + then ((f a)::((f b)::((f c)::((f d)::((map f) tl))))) + else false)) + + let rec append = (fun xs -> (fun ys -> let match_tmp_me9 = xs in + if (is_nil match_tmp_me9) + then ys + else let match_tmp_me10 = match_tmp_me9 in + if if (is_cons match_tmp_me10) + then if true + then true + else false + else false + then (x::((append xs_ac0) ys)) + else false)) + + let concat = let rec helper = (fun xs -> let match_tmp_me11 = xs in + if (is_nil match_tmp_me11) + then [] + else let match_tmp_me12 = match_tmp_me11 in + if if (is_cons match_tmp_me12) + then if true + then true + else false + else false + then ((append h) (helper tl)) + else false) in + helper + + let rec iter = (fun f -> (fun xs -> let match_tmp_me13 = xs in + if (is_nil match_tmp_me13) + then () + else let match_tmp_me14 = match_tmp_me13 in + if if (is_cons match_tmp_me14) + then if true + then true + else false + else false + then let () = (f h) in + ((iter f) tl) + else false)) + + let rec cartesian = (fun xs -> (fun ys -> let match_tmp_me15 = xs in + if (is_nil match_tmp_me15) + then [] + else let match_tmp_me16 = match_tmp_me15 in + if if (is_cons match_tmp_me16) + then if true + then true + else false + else false + then ((append ((map (fun a -> (h, a))) ys)) ((cartesian tl) ys)) + else false)) + + let main = let () = ((iter print_int) (1::(2::(3::[])))) in + let () = (print_int (length ((cartesian (1::(2::[]))) (1::(2::(3::(4::[]))))))) in + 0 + + $ ./match_elimination_runner.exe < manytests/do_not_type/001.ml + Infer error: + $ ./match_elimination_runner.exe < manytests/do_not_type/002if.ml + Infer error: + $ ./match_elimination_runner.exe < manytests/do_not_type/003occurs.ml + Infer error: + + $ ./match_elimination_runner.exe < manytests/do_not_type/004let_poly.ml + Infer error: + + $ ./match_elimination_runner.exe < manytests/do_not_type/015tuples.ml + Infer error: + diff --git a/FML/tests/match_elimination_runner.ml b/FML/tests/match_elimination_runner.ml new file mode 100644 index 000000000..b4d0c402e --- /dev/null +++ b/FML/tests/match_elimination_runner.ml @@ -0,0 +1,27 @@ +(** Copyright 2024-2025, Dmitry Pilyuk, Aleksandr Rozhkov *) + +(** SPDX-License-Identifier: LGPL-2.1 *) + +open Fml_lib.Parser +open Fml_lib.Inferencer +open Fml_lib.A_conv +open Fml_lib.Match_elimination +open Fml_lib.Pe_ast + +let () = + let input = Stdio.In_channel.input_all Stdlib.stdin in + let parse_and_infer input = + match parse input with + | Ok parsed -> + (match run_program_inferencer parsed with + | Ok _ -> Ok parsed + | Error _ -> Error (Format.asprintf "Infer error:")) + | Error e -> Error (Format.sprintf "Parsing error: %s" e) + in + match parse_and_infer input with + | Ok ast -> + let ast = ac_program ast in + let ast_pe = match_elimination ast in + Format.printf "%a\n" pp_pe_program ast_pe + | Error message -> Format.printf "%s" message +;; From e34f0f260f90579843fd6ebd19e946f0f44cee56 Mon Sep 17 00:00:00 2001 From: RozhkovAleksandr Date: Thu, 3 Apr 2025 22:55:19 +0300 Subject: [PATCH 53/92] fix: tuple conv --- FML/lib/anf/match_elimination.ml | 42 +++++++--- FML/tests/match_elimination_manytest.t | 101 +++++++++++++++---------- 2 files changed, 91 insertions(+), 52 deletions(-) diff --git a/FML/lib/anf/match_elimination.ml b/FML/lib/anf/match_elimination.ml index 1856447a9..bf8397123 100644 --- a/FML/lib/anf/match_elimination.ml +++ b/FML/lib/anf/match_elimination.ml @@ -14,6 +14,7 @@ module StateMonad : sig module RList : sig val fold_left : 'a list -> init:'b t -> f:('b -> 'a -> 'b t) -> 'b t + val fold_right : 'a list -> init:'b t -> f:('a -> 'b -> 'b t) -> 'b t end module RMap : sig @@ -62,6 +63,12 @@ end = struct let* acc = acc in f acc item) ;; + + let fold_right lt ~init ~f = + Base.List.fold_right lt ~init ~f:(fun item acc -> + let* acc = acc in + f item acc) + ;; end (* Run and get the internal value. *) @@ -108,13 +115,27 @@ let rec expr_to_mexpr expr = let* body' = expr_to_mexpr body in return @@ Pe_EFun (ids, body') | ELetIn (rec_flag, pat, e1, e2) -> - let ids = pattern_remove pat in - let* e1' = expr_to_mexpr e1 in - let* e2' = expr_to_mexpr e2 in - let rec_flag = rec_flags rec_flag in - (match ids with - | [id] -> return @@ Pe_ELet (rec_flag, id, e1', e2') - | _ -> failwith "Only simple let bindings with 1 identifier are supported after alpha conversion") + let ids = pattern_remove pat in + let* e1' = expr_to_mexpr e1 in + let* e2' = expr_to_mexpr e2 in + let rec_flag = rec_flags rec_flag in + (match ids with + | [id] -> return @@ Pe_ELet (rec_flag, id, e1', e2') + | ids_list -> + let transformed_e = + List.mapi ids_list ~f:(fun i id -> + let idx_expr = EConst (CInt i) in + let unpack_expr = EApplication (EIdentifier "unpack_tuple", idx_expr) in + let applied = EApplication (e1, unpack_expr) in + (PIdentifier id, applied) + ) + in + let final_expr = + List.fold_right transformed_e ~init:e2 ~f:(fun (pat, expr) acc -> + ELetIn (NoRec, pat, expr, acc) + ) + in + expr_to_mexpr final_expr) | ETuple exprs -> let* exprs' = RList.fold_left exprs ~init:(return []) ~f:(fun acc e -> let* e' = expr_to_mexpr e in @@ -149,7 +170,7 @@ and desugar_match e branches = expr), Pe_EConst (const_to_pe_const c)) | PIdentifier _ -> return @@ Pe_EConst (Pe_CBool true) - | PNill -> return @@ Pe_EApp (Pe_EIdentifier "is_nil", expr) + | PNill -> return @@ Pe_EApp (Pe_EIdentifier "is_empty", expr) | PCons (hd, tl) -> let hd_expr = Pe_EApp (Pe_EIdentifier "hd", expr) in let tl_expr = Pe_EApp (Pe_EIdentifier "tl", expr) in @@ -163,18 +184,17 @@ and desugar_match e branches = RList.fold_left (List.mapi pats ~f:(fun i p -> (i, p))) ~init:(return []) ~f:(fun acc (i, p) -> - let ith_expr = Pe_EApp (Pe_EIdentifier ("fst" ^ Int.to_string i), expr) in + let ith_expr = Pe_EApp (Pe_EIdentifier ("tuple_get"), Pe_ETuple [expr; Pe_EConst (Pe_Cint i)]) in let* cond = pattern_to_condition ith_expr p in return (acc @ [cond])) in return @@ List.fold_right conds ~init:(Pe_EConst (Pe_CBool true)) ~f:(fun c acc -> Pe_EIf (c, acc, Pe_EConst (Pe_CBool false))) | PConstraint (p, _) -> pattern_to_condition expr p in - let* cond = pattern_to_condition bound_expr pat in let* rest_expr = match rest with - | [] -> return @@ Pe_EConst (Pe_CBool false) (* dummy fail case *) + | [] -> return @@ Pe_EApp (Pe_EIdentifier "failwith", Pe_EIdentifier "\"no matching\"") (* dummy fail case *) | _ -> desugar_match (EIdentifier tmp_var) rest in return @@ Pe_ELet (NoRec, tmp_var, e', diff --git a/FML/tests/match_elimination_manytest.t b/FML/tests/match_elimination_manytest.t index cd6417384..ae0d6b0b0 100644 --- a/FML/tests/match_elimination_manytest.t +++ b/FML/tests/match_elimination_manytest.t @@ -22,7 +22,7 @@ else let match_tmp_me1 = match_tmp_me0 in if true then false - else false) + else (failwith "no matching")) $ ./match_elimination_runner.exe < manytests/typed/001fac.ml let rec fac = (fun n -> if ((( <= ) n) 1) @@ -130,7 +130,7 @@ $ ./match_elimination_runner.exe < manytests/typed/011mapcps.ml let rec map = (fun f -> (fun xs -> (fun k -> let match_tmp_me0 = xs in - if (is_nil match_tmp_me0) + if (is_empty match_tmp_me0) then (k []) else let match_tmp_me1 = match_tmp_me0 in if if (is_cons match_tmp_me1) @@ -139,10 +139,10 @@ else false else false then (((map f) tl) (fun tl_ac0 -> (k ((f h)::tl_ac0)))) - else false))) + else (failwith "no matching")))) let rec iter = (fun f -> (fun xs -> let match_tmp_me2 = xs in - if (is_nil match_tmp_me2) + if (is_empty match_tmp_me2) then () else let match_tmp_me3 = match_tmp_me2 in if if (is_cons match_tmp_me3) @@ -152,7 +152,7 @@ else false then let w = (f h) in ((iter f) tl) - else false)) + else (failwith "no matching"))) let main = ((iter print_int) (((map (fun x -> ((( + ) x) 1))) (1::(2::(3::[])))) (fun x -> x))) $ ./match_elimination_runner.exe < manytests/typed/012fibcps.ml @@ -165,7 +165,7 @@ let id = (fun x -> x) let rec fold_right = (fun f -> (fun acc -> (fun xs -> let match_tmp_me0 = xs in - if (is_nil match_tmp_me0) + if (is_empty match_tmp_me0) then acc else let match_tmp_me1 = match_tmp_me0 in if if (is_cons match_tmp_me1) @@ -174,34 +174,53 @@ else false else false then ((f h) (((fold_right f) acc) tl)) - else false))) + else (failwith "no matching")))) let foldl = (fun f -> (fun a -> (fun bs -> ((((fold_right (fun b -> (fun g -> (fun x -> (g ((f x) b)))))) id) bs) a)))) let main = (print_int (((foldl (fun x -> (fun y -> ((( * ) x) y)))) 1) (1::(2::(3::[]))))) $ ./match_elimination_runner.exe < manytests/typed/015tuples.ml - Fatal error: exception Failure("Only simple let bindings with 1 identifier are supported after alpha conversion") - Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Fml_lib__Match_elimination.StateMonad.(>>=) in file "lib/anf/match_elimination.ml", line 34, characters 17-20 - Called from Fml_lib__Match_elimination.StateMonad.(>>=) in file "lib/anf/match_elimination.ml", line 34, characters 17-20 - Called from Fml_lib__Match_elimination.StateMonad.(>>=) in file "lib/anf/match_elimination.ml", line 34, characters 17-20 - Called from Fml_lib__Match_elimination.StateMonad.(>>=) in file "lib/anf/match_elimination.ml", line 34, characters 17-20 - Called from Fml_lib__Match_elimination.StateMonad.(>>=) in file "lib/anf/match_elimination.ml", line 34, characters 17-20 - Called from Fml_lib__Match_elimination.StateMonad.(>>=) in file "lib/anf/match_elimination.ml", line 34, characters 17-20 - Called from Fml_lib__Match_elimination.StateMonad.(>>=) in file "lib/anf/match_elimination.ml", line 34, characters 17-20 - Called from Fml_lib__Match_elimination.StateMonad.(>>=) in file "lib/anf/match_elimination.ml", line 34, characters 17-20 - Called from Fml_lib__Match_elimination.StateMonad.(>>=) in file "lib/anf/match_elimination.ml", line 34, characters 17-20 - Called from Fml_lib__Match_elimination.StateMonad.(>>=) in file "lib/anf/match_elimination.ml", line 34, characters 17-20 - Called from Fml_lib__Match_elimination.StateMonad.(>>=) in file "lib/anf/match_elimination.ml", line 34, characters 17-20 - Called from Fml_lib__Match_elimination.StateMonad.run in file "lib/anf/match_elimination.ml" (inlined), line 68, characters 18-23 - Called from Fml_lib__Match_elimination.match_elimination in file "lib/anf/match_elimination.ml", line 210, characters 2-150 - Called from Dune__exe__Match_elimination_runner in file "tests/match_elimination_runner.ml", line 24, characters 17-38 - [2] + let rec fix = (fun f -> (fun x -> ((f (fix f)) x))) + + let map = (fun f -> (fun p -> let a = (p (unpack_tuple 0)) in + let b = (p (unpack_tuple 1)) in + ((f a), (f b)))) + + let fixpoly = (fun l -> ((fix (fun self -> (fun l_ac0 -> ((map (fun li -> (fun x -> ((li (self l_ac0)) x)))) l_ac0)))) l)) + + let feven = (fun p -> (fun n -> let e = (p (unpack_tuple 0)) in + let o = (p (unpack_tuple 1)) in + if ((( = ) n) 0) + then 1 + else (o ((( - ) n) 1)))) + + let fodd = (fun p -> (fun n -> let e = (p (unpack_tuple 0)) in + let o = (p (unpack_tuple 1)) in + if ((( = ) n) 0) + then 0 + else (e ((( - ) n) 1)))) + + let tie = (fixpoly (feven, fodd)) + + let rec meven = (fun n -> if ((( = ) n) 0) + then 1 + else (modd ((( - ) n) 1))) + and modd = (fun n -> if ((( = ) n) 0) + then 1 + else (meven ((( - ) n) 1))) + + let main = let () = (print_int (modd 1)) in + let () = (print_int (meven 2)) in + let even = (tie (unpack_tuple 0)) in + let odd = (tie (unpack_tuple 1)) in + let () = (print_int (odd 3)) in + let () = (print_int (even 4)) in + 0 $ ./match_elimination_runner.exe < manytests/typed/016lists.ml let rec length = (fun xs -> let match_tmp_me0 = xs in - if (is_nil match_tmp_me0) + if (is_empty match_tmp_me0) then 0 else let match_tmp_me1 = match_tmp_me0 in if if (is_cons match_tmp_me1) @@ -210,10 +229,10 @@ else false else false then ((( + ) 1) (length tl)) - else false) + else (failwith "no matching")) let length_tail = let rec helper = (fun acc -> (fun xs -> let match_tmp_me2 = xs in - if (is_nil match_tmp_me2) + if (is_empty match_tmp_me2) then acc else let match_tmp_me3 = match_tmp_me2 in if if (is_cons match_tmp_me3) @@ -222,16 +241,16 @@ else false else false then ((helper ((( + ) acc) 1)) tl) - else false)) in + else (failwith "no matching"))) in (helper 0) let rec map = (fun f -> (fun xs -> let match_tmp_me4 = xs in - if (is_nil match_tmp_me4) + if (is_empty match_tmp_me4) then [] else let match_tmp_me5 = match_tmp_me4 in if if (is_cons match_tmp_me5) then if true - then (is_nil (tl match_tmp_me5)) + then (is_empty (tl match_tmp_me5)) else false else false then ((f a)::[]) @@ -240,7 +259,7 @@ then if true then if (is_cons (tl match_tmp_me6)) then if true - then (is_nil (tl (tl match_tmp_me6))) + then (is_empty (tl (tl match_tmp_me6))) else false else false else false @@ -253,7 +272,7 @@ then if true then if (is_cons (tl (tl match_tmp_me7))) then if true - then (is_nil (tl (tl (tl match_tmp_me7)))) + then (is_empty (tl (tl (tl match_tmp_me7)))) else false else false else false @@ -280,10 +299,10 @@ else false else false then ((f a)::((f b)::((f c)::((f d)::((map f) tl))))) - else false)) + else (failwith "no matching"))) let rec append = (fun xs -> (fun ys -> let match_tmp_me9 = xs in - if (is_nil match_tmp_me9) + if (is_empty match_tmp_me9) then ys else let match_tmp_me10 = match_tmp_me9 in if if (is_cons match_tmp_me10) @@ -292,10 +311,10 @@ else false else false then (x::((append xs_ac0) ys)) - else false)) + else (failwith "no matching"))) let concat = let rec helper = (fun xs -> let match_tmp_me11 = xs in - if (is_nil match_tmp_me11) + if (is_empty match_tmp_me11) then [] else let match_tmp_me12 = match_tmp_me11 in if if (is_cons match_tmp_me12) @@ -304,11 +323,11 @@ else false else false then ((append h) (helper tl)) - else false) in + else (failwith "no matching")) in helper let rec iter = (fun f -> (fun xs -> let match_tmp_me13 = xs in - if (is_nil match_tmp_me13) + if (is_empty match_tmp_me13) then () else let match_tmp_me14 = match_tmp_me13 in if if (is_cons match_tmp_me14) @@ -318,10 +337,10 @@ else false then let () = (f h) in ((iter f) tl) - else false)) + else (failwith "no matching"))) let rec cartesian = (fun xs -> (fun ys -> let match_tmp_me15 = xs in - if (is_nil match_tmp_me15) + if (is_empty match_tmp_me15) then [] else let match_tmp_me16 = match_tmp_me15 in if if (is_cons match_tmp_me16) @@ -330,7 +349,7 @@ else false else false then ((append ((map (fun a -> (h, a))) ys)) ((cartesian tl) ys)) - else false)) + else (failwith "no matching"))) let main = let () = ((iter print_int) (1::(2::(3::[])))) in let () = (print_int (length ((cartesian (1::(2::[]))) (1::(2::(3::(4::[]))))))) in From f1d96ba8ec951b91fef9a946a60c58c56ed99285 Mon Sep 17 00:00:00 2001 From: RozhkovAleksandr Date: Fri, 4 Apr 2025 21:45:01 +0300 Subject: [PATCH 54/92] fix match (add check bindinings for cons, clever comb and more --- FML/lib/anf/match_elimination.ml | 117 +++++++++---- FML/tests/match_elimination_manytest.t | 217 ++++++++++--------------- 2 files changed, 164 insertions(+), 170 deletions(-) diff --git a/FML/lib/anf/match_elimination.ml b/FML/lib/anf/match_elimination.ml index bf8397123..37fdec048 100644 --- a/FML/lib/anf/match_elimination.ml +++ b/FML/lib/anf/match_elimination.ml @@ -115,27 +115,27 @@ let rec expr_to_mexpr expr = let* body' = expr_to_mexpr body in return @@ Pe_EFun (ids, body') | ELetIn (rec_flag, pat, e1, e2) -> - let ids = pattern_remove pat in - let* e1' = expr_to_mexpr e1 in - let* e2' = expr_to_mexpr e2 in - let rec_flag = rec_flags rec_flag in - (match ids with - | [id] -> return @@ Pe_ELet (rec_flag, id, e1', e2') - | ids_list -> - let transformed_e = - List.mapi ids_list ~f:(fun i id -> - let idx_expr = EConst (CInt i) in - let unpack_expr = EApplication (EIdentifier "unpack_tuple", idx_expr) in - let applied = EApplication (e1, unpack_expr) in - (PIdentifier id, applied) - ) - in - let final_expr = - List.fold_right transformed_e ~init:e2 ~f:(fun (pat, expr) acc -> - ELetIn (NoRec, pat, expr, acc) - ) - in - expr_to_mexpr final_expr) + let ids = pattern_remove pat in + let* e1' = expr_to_mexpr e1 in + let* e2' = expr_to_mexpr e2 in + let rec_flag = rec_flags rec_flag in + (match ids with + | [id] -> return @@ Pe_ELet (rec_flag, id, e1', e2') + | ids_list -> + let transformed_e = + List.mapi ids_list ~f:(fun i id -> + let idx_expr = EConst (CInt i) in + let unpack_expr = EApplication (EIdentifier "unpack_tuple", idx_expr) in + let applied = EApplication (e1, unpack_expr) in + (PIdentifier id, applied) + ) + in + let final_expr = + List.fold_right transformed_e ~init:e2 ~f:(fun (pat, expr) acc -> + ELetIn (NoRec, pat, expr, acc) + ) + in + expr_to_mexpr final_expr) | ETuple exprs -> let* exprs' = RList.fold_left exprs ~init:(return []) ~f:(fun acc e -> let* e' = expr_to_mexpr e in @@ -158,17 +158,27 @@ and desugar_match e branches = match branches with | [] -> failwith "Empty match expression" | (pat, expr_rhs) :: rest -> - let* id_num = fresh in - let tmp_var = get_new_id id_num "match_tmp" in - let bound_expr = Pe_EIdentifier tmp_var in let* expr_rhs' = expr_to_mexpr expr_rhs in + let rec pattern_bindings expr pat = + match pat with + | PIdentifier id -> [ (id, expr) ] + | PCons (hd, tl) -> + let hd_expr = Pe_EApp (Pe_EIdentifier "hd_list_get", expr) in + let tl_expr = Pe_EApp (Pe_EIdentifier "tl_list_get", expr) in + pattern_bindings hd_expr hd @ pattern_bindings tl_expr tl + | PTuple pats -> + List.mapi pats ~f:(fun i p -> + let ith_expr = Pe_EApp (Pe_EIdentifier "tuple_get", Pe_ETuple [expr; Pe_EConst (Pe_Cint i)]) in + pattern_bindings ith_expr p + ) |> List.concat + | PConstraint (p, _) -> pattern_bindings expr p + | _ -> [] + in let rec pattern_to_condition expr pat = match pat with | PAny -> return @@ Pe_EConst (Pe_CBool true) | PUnit -> return @@ Pe_EIf (Pe_EApp (Pe_EIdentifier "is_unit", expr), Pe_EConst (Pe_CBool true), Pe_EConst (Pe_CBool false)) - | PConst c -> return @@ Pe_EApp (Pe_EApp (Pe_EIdentifier "(=)", - expr), - Pe_EConst (const_to_pe_const c)) + | PConst c -> return @@ Pe_EApp (Pe_EApp (Pe_EIdentifier "(=)", expr), Pe_EConst (const_to_pe_const c)) | PIdentifier _ -> return @@ Pe_EConst (Pe_CBool true) | PNill -> return @@ Pe_EApp (Pe_EIdentifier "is_empty", expr) | PCons (hd, tl) -> @@ -176,30 +186,65 @@ and desugar_match e branches = let tl_expr = Pe_EApp (Pe_EIdentifier "tl", expr) in let* cond_hd = pattern_to_condition hd_expr hd in let* cond_tl = pattern_to_condition tl_expr tl in - return @@ Pe_EIf (Pe_EApp (Pe_EIdentifier "is_cons", expr), - Pe_EIf (cond_hd, cond_tl, Pe_EConst (Pe_CBool false)), - Pe_EConst (Pe_CBool false)) + let is_cons_check = Pe_EApp (Pe_EIdentifier "is_cons", expr) in + let comb = match (cond_hd, cond_tl) with (* Если hd или tl — это PIdentifier или PAny, то if true then ... else false, что избыточно *) + | (Pe_EConst (Pe_CBool true), Pe_EConst (Pe_CBool true)) -> + is_cons_check + | (Pe_EConst (Pe_CBool true), cond) -> + Pe_EIf (is_cons_check, cond, Pe_EConst (Pe_CBool false)) + | (cond, Pe_EConst (Pe_CBool true)) -> + Pe_EIf (is_cons_check, cond, Pe_EConst (Pe_CBool false)) + | (cond1, cond2) -> + Pe_EIf (is_cons_check, + Pe_EIf (cond1, cond2, Pe_EConst (Pe_CBool false)), + Pe_EConst (Pe_CBool false)) + in + return comb | PTuple pats -> let* conds = RList.fold_left (List.mapi pats ~f:(fun i p -> (i, p))) ~init:(return []) ~f:(fun acc (i, p) -> - let ith_expr = Pe_EApp (Pe_EIdentifier ("tuple_get"), Pe_ETuple [expr; Pe_EConst (Pe_Cint i)]) in + let ith_expr = Pe_EApp (Pe_EIdentifier "tuple_get", Pe_ETuple [expr; Pe_EConst (Pe_Cint i)]) in let* cond = pattern_to_condition ith_expr p in return (acc @ [cond])) in return @@ List.fold_right conds ~init:(Pe_EConst (Pe_CBool true)) ~f:(fun c acc -> Pe_EIf (c, acc, Pe_EConst (Pe_CBool false))) | PConstraint (p, _) -> pattern_to_condition expr p in + + let* id_num = fresh in + let tmp_var = get_new_id id_num "match_tmp" in + let (bound_expr, bind_expr_opt) = + match e' with + | Pe_EIdentifier _ -> (e', None) + | _ -> (Pe_EIdentifier tmp_var, Some (tmp_var, e')) + in + let* cond = pattern_to_condition bound_expr pat in + let bindings = pattern_bindings bound_expr pat in + let bound_rhs = + List.fold_right bindings ~init:expr_rhs' ~f:(fun (id, expr) acc -> + Pe_ELet (NoRec, id, expr, acc)) + in + let* rest_expr = match rest with - | [] -> return @@ Pe_EApp (Pe_EIdentifier "failwith", Pe_EIdentifier "\"no matching\"") (* dummy fail case *) - | _ -> desugar_match (EIdentifier tmp_var) rest + | [] -> return @@ Pe_EApp (Pe_EIdentifier "failwith", Pe_EIdentifier "\"no matching\"") + | _ -> + let new_e = + match bind_expr_opt with + | None -> e + | Some (name, _) -> EIdentifier name + in + desugar_match new_e rest in - return @@ Pe_ELet (NoRec, tmp_var, e', - Pe_EIf (cond, expr_rhs', rest_expr)) - + + match bind_expr_opt with + | None -> return @@ Pe_EIf (cond, bound_rhs, rest_expr) + | Some (var, expr) -> + return @@ Pe_ELet (NoRec, var, expr, Pe_EIf (cond, bound_rhs, rest_expr)) + let decl_to_pe_decl decl = match decl with diff --git a/FML/tests/match_elimination_manytest.t b/FML/tests/match_elimination_manytest.t index ae0d6b0b0..528217218 100644 --- a/FML/tests/match_elimination_manytest.t +++ b/FML/tests/match_elimination_manytest.t @@ -13,15 +13,16 @@ $ ./match_elimination_runner.exe << EOF > let f x = match x with - > | 1 -> true - > | _ -> false + > | 1 -> 12 + > | 12 -> 12 + > | _ -> 325 > EOF - let f = (fun x -> let match_tmp_me0 = x in - if (((=) match_tmp_me0) 1) - then true - else let match_tmp_me1 = match_tmp_me0 in - if true - then false + let f = (fun x -> if (((=) x) 1) + then 12 + else if (((=) x) 12) + then 12 + else if true + then 325 else (failwith "no matching")) $ ./match_elimination_runner.exe < manytests/typed/001fac.ml @@ -129,28 +130,20 @@ ((f 1), (f true)) $ ./match_elimination_runner.exe < manytests/typed/011mapcps.ml - let rec map = (fun f -> (fun xs -> (fun k -> let match_tmp_me0 = xs in - if (is_empty match_tmp_me0) + let rec map = (fun f -> (fun xs -> (fun k -> if (is_empty xs) then (k []) - else let match_tmp_me1 = match_tmp_me0 in - if if (is_cons match_tmp_me1) - then if true - then true - else false - else false - then (((map f) tl) (fun tl_ac0 -> (k ((f h)::tl_ac0)))) + else if (is_cons xs) + then let h = (hd_list_get xs) in + let tl = (tl_list_get xs) in + (((map f) tl) (fun tl_ac0 -> (k ((f h)::tl_ac0)))) else (failwith "no matching")))) - let rec iter = (fun f -> (fun xs -> let match_tmp_me2 = xs in - if (is_empty match_tmp_me2) + let rec iter = (fun f -> (fun xs -> if (is_empty xs) then () - else let match_tmp_me3 = match_tmp_me2 in - if if (is_cons match_tmp_me3) - then if true - then true - else false - else false - then let w = (f h) in + else if (is_cons xs) + then let h = (hd_list_get xs) in + let tl = (tl_list_get xs) in + let w = (f h) in ((iter f) tl) else (failwith "no matching"))) @@ -164,16 +157,12 @@ $ ./match_elimination_runner.exe < manytests/typed/013foldfoldr.ml let id = (fun x -> x) - let rec fold_right = (fun f -> (fun acc -> (fun xs -> let match_tmp_me0 = xs in - if (is_empty match_tmp_me0) + let rec fold_right = (fun f -> (fun acc -> (fun xs -> if (is_empty xs) then acc - else let match_tmp_me1 = match_tmp_me0 in - if if (is_cons match_tmp_me1) - then if true - then true - else false - else false - then ((f h) (((fold_right f) acc) tl)) + else if (is_cons xs) + then let h = (hd_list_get xs) in + let tl = (tl_list_get xs) in + ((f h) (((fold_right f) acc) tl)) else (failwith "no matching")))) let foldl = (fun f -> (fun a -> (fun bs -> ((((fold_right (fun b -> (fun g -> (fun x -> (g ((f x) b)))))) id) bs) a)))) @@ -219,136 +208,96 @@ 0 $ ./match_elimination_runner.exe < manytests/typed/016lists.ml - let rec length = (fun xs -> let match_tmp_me0 = xs in - if (is_empty match_tmp_me0) + let rec length = (fun xs -> if (is_empty xs) then 0 - else let match_tmp_me1 = match_tmp_me0 in - if if (is_cons match_tmp_me1) - then if true - then true - else false - else false - then ((( + ) 1) (length tl)) + else if (is_cons xs) + then let h = (hd_list_get xs) in + let tl = (tl_list_get xs) in + ((( + ) 1) (length tl)) else (failwith "no matching")) - let length_tail = let rec helper = (fun acc -> (fun xs -> let match_tmp_me2 = xs in - if (is_empty match_tmp_me2) + let length_tail = let rec helper = (fun acc -> (fun xs -> if (is_empty xs) then acc - else let match_tmp_me3 = match_tmp_me2 in - if if (is_cons match_tmp_me3) - then if true - then true - else false - else false - then ((helper ((( + ) acc) 1)) tl) + else if (is_cons xs) + then let h = (hd_list_get xs) in + let tl = (tl_list_get xs) in + ((helper ((( + ) acc) 1)) tl) else (failwith "no matching"))) in (helper 0) - let rec map = (fun f -> (fun xs -> let match_tmp_me4 = xs in - if (is_empty match_tmp_me4) + let rec map = (fun f -> (fun xs -> if (is_empty xs) then [] - else let match_tmp_me5 = match_tmp_me4 in - if if (is_cons match_tmp_me5) - then if true - then (is_empty (tl match_tmp_me5)) - else false - else false - then ((f a)::[]) - else let match_tmp_me6 = match_tmp_me5 in - if if (is_cons match_tmp_me6) - then if true - then if (is_cons (tl match_tmp_me6)) - then if true - then (is_empty (tl (tl match_tmp_me6))) - else false - else false - else false + else if if (is_cons xs) + then (is_empty (tl xs)) else false - then ((f a)::((f b)::[])) - else let match_tmp_me7 = match_tmp_me6 in - if if (is_cons match_tmp_me7) - then if true - then if (is_cons (tl match_tmp_me7)) - then if true - then if (is_cons (tl (tl match_tmp_me7))) - then if true - then (is_empty (tl (tl (tl match_tmp_me7)))) + then let a = (hd_list_get xs) in + ((f a)::[]) + else if if (is_cons xs) + then if (is_cons (tl xs)) + then (is_empty (tl (tl xs))) else false else false + then let a = (hd_list_get xs) in + let b = (hd_list_get (tl_list_get xs)) in + ((f a)::((f b)::[])) + else if if (is_cons xs) + then if (is_cons (tl xs)) + then if (is_cons (tl (tl xs))) + then (is_empty (tl (tl (tl xs)))) else false else false else false + then let a = (hd_list_get xs) in + let b = (hd_list_get (tl_list_get xs)) in + let c = (hd_list_get (tl_list_get (tl_list_get xs))) in + ((f a)::((f b)::((f c)::[]))) + else if if (is_cons xs) + then if (is_cons (tl xs)) + then if (is_cons (tl (tl xs))) + then (is_cons (tl (tl (tl xs)))) else false - then ((f a)::((f b)::((f c)::[]))) - else let match_tmp_me8 = match_tmp_me7 in - if if (is_cons match_tmp_me8) - then if true - then if (is_cons (tl match_tmp_me8)) - then if true - then if (is_cons (tl (tl match_tmp_me8))) - then if true - then if (is_cons (tl (tl (tl match_tmp_me8)))) - then if true - then true else false else false - else false - else false - else false - else false - else false - else false - then ((f a)::((f b)::((f c)::((f d)::((map f) tl))))) + then let a = (hd_list_get xs) in + let b = (hd_list_get (tl_list_get xs)) in + let c = (hd_list_get (tl_list_get (tl_list_get xs))) in + let d = (hd_list_get (tl_list_get (tl_list_get (tl_list_get xs)))) in + let tl = (tl_list_get (tl_list_get (tl_list_get (tl_list_get xs)))) in + ((f a)::((f b)::((f c)::((f d)::((map f) tl))))) else (failwith "no matching"))) - let rec append = (fun xs -> (fun ys -> let match_tmp_me9 = xs in - if (is_empty match_tmp_me9) + let rec append = (fun xs -> (fun ys -> if (is_empty xs) then ys - else let match_tmp_me10 = match_tmp_me9 in - if if (is_cons match_tmp_me10) - then if true - then true - else false - else false - then (x::((append xs_ac0) ys)) + else if (is_cons xs) + then let x = (hd_list_get xs) in + let xs_ac0 = (tl_list_get xs) in + (x::((append xs_ac0) ys)) else (failwith "no matching"))) - let concat = let rec helper = (fun xs -> let match_tmp_me11 = xs in - if (is_empty match_tmp_me11) + let concat = let rec helper = (fun xs -> if (is_empty xs) then [] - else let match_tmp_me12 = match_tmp_me11 in - if if (is_cons match_tmp_me12) - then if true - then true - else false - else false - then ((append h) (helper tl)) + else if (is_cons xs) + then let h = (hd_list_get xs) in + let tl = (tl_list_get xs) in + ((append h) (helper tl)) else (failwith "no matching")) in helper - let rec iter = (fun f -> (fun xs -> let match_tmp_me13 = xs in - if (is_empty match_tmp_me13) + let rec iter = (fun f -> (fun xs -> if (is_empty xs) then () - else let match_tmp_me14 = match_tmp_me13 in - if if (is_cons match_tmp_me14) - then if true - then true - else false - else false - then let () = (f h) in + else if (is_cons xs) + then let h = (hd_list_get xs) in + let tl = (tl_list_get xs) in + let () = (f h) in ((iter f) tl) else (failwith "no matching"))) - let rec cartesian = (fun xs -> (fun ys -> let match_tmp_me15 = xs in - if (is_empty match_tmp_me15) + let rec cartesian = (fun xs -> (fun ys -> if (is_empty xs) then [] - else let match_tmp_me16 = match_tmp_me15 in - if if (is_cons match_tmp_me16) - then if true - then true - else false - else false - then ((append ((map (fun a -> (h, a))) ys)) ((cartesian tl) ys)) + else if (is_cons xs) + then let h = (hd_list_get xs) in + let tl = (tl_list_get xs) in + ((append ((map (fun a -> (h, a))) ys)) ((cartesian tl) ys)) else (failwith "no matching"))) let main = let () = ((iter print_int) (1::(2::(3::[])))) in From 78e9210f65e420930dc5509b25a8ebb36fdbd568 Mon Sep 17 00:00:00 2001 From: RozhkovAleksandr Date: Fri, 4 Apr 2025 21:56:12 +0300 Subject: [PATCH 55/92] fix middle ast --- FML/lib/anf/match_elimination.ml | 88 ++++++++++++------------ FML/lib/anf/me_ast.ml | 96 +++++++++++++++++++++++++++ FML/lib/dune | 1 + FML/tests/match_elimination_runner.ml | 6 +- 4 files changed, 144 insertions(+), 47 deletions(-) create mode 100644 FML/lib/anf/me_ast.ml diff --git a/FML/lib/anf/match_elimination.ml b/FML/lib/anf/match_elimination.ml index 37fdec048..91523abe7 100644 --- a/FML/lib/anf/match_elimination.ml +++ b/FML/lib/anf/match_elimination.ml @@ -4,7 +4,7 @@ open Ast open Base -open Pe_ast +open Me_ast module StateMonad : sig include Base.Monad.Infix @@ -81,8 +81,8 @@ let get_new_id n name = String.concat [ name; "_me"; Int.to_string n ] open StateMonad let const_to_pe_const = function - | CInt a -> Pe_Cint a - | CBool a -> Pe_CBool a + | CInt a -> Me_Cint a + | CBool a -> Me_CBool a let rec pattern_remove pat = match pat with @@ -95,32 +95,32 @@ let rec pattern_remove pat = | PConstraint (p, _) -> pattern_remove p | _ -> failwith "bye-bye, bro. im sleeping" -let rec_flags : Ast.rec_flag -> Pe_ast.rec_flag = function +let rec_flags : Ast.rec_flag -> Me_ast.rec_flag = function | Rec -> Rec | NoRec -> NoRec let rec expr_to_mexpr expr = match expr with - | EUnit -> return Pe_EUnit - | ENill -> return Pe_ENill + | EUnit -> return Me_EUnit + | ENill -> return Me_ENill | EConstraint (e, _) -> expr_to_mexpr e - | EConst c -> return @@ Pe_EConst (const_to_pe_const c) - | EIdentifier id -> return @@ Pe_EIdentifier id + | EConst c -> return @@ Me_EConst (const_to_pe_const c) + | EIdentifier id -> return @@ Me_EIdentifier id | EApplication (f, arg) -> let* f' = expr_to_mexpr f in let* arg' = expr_to_mexpr arg in - return @@ Pe_EApp (f', arg') + return @@ Me_EApp (f', arg') | EFun (pat, body) -> let ids = pattern_remove pat in let* body' = expr_to_mexpr body in - return @@ Pe_EFun (ids, body') + return @@ Me_EFun (ids, body') | ELetIn (rec_flag, pat, e1, e2) -> let ids = pattern_remove pat in let* e1' = expr_to_mexpr e1 in let* e2' = expr_to_mexpr e2 in let rec_flag = rec_flags rec_flag in (match ids with - | [id] -> return @@ Pe_ELet (rec_flag, id, e1', e2') + | [id] -> return @@ Me_ELet (rec_flag, id, e1', e2') | ids_list -> let transformed_e = List.mapi ids_list ~f:(fun i id -> @@ -140,16 +140,16 @@ let rec expr_to_mexpr expr = let* exprs' = RList.fold_left exprs ~init:(return []) ~f:(fun acc e -> let* e' = expr_to_mexpr e in return (acc @ [e'])) in - return @@ Pe_ETuple exprs' + return @@ Me_ETuple exprs' | EIf (cond, then_, else_) -> let* cond' = expr_to_mexpr cond in let* then_' = expr_to_mexpr then_ in let* else_' = expr_to_mexpr else_ in - return @@ Pe_EIf (cond', then_', else_') + return @@ Me_EIf (cond', then_', else_') | ECons (hd, tl) -> let* hd' = expr_to_mexpr hd in let* tl' = expr_to_mexpr tl in - return @@ Pe_ECons (hd', tl') + return @@ Me_ECons (hd', tl') | EMatch (e, branches) -> desugar_match e branches @@ -163,12 +163,12 @@ and desugar_match e branches = match pat with | PIdentifier id -> [ (id, expr) ] | PCons (hd, tl) -> - let hd_expr = Pe_EApp (Pe_EIdentifier "hd_list_get", expr) in - let tl_expr = Pe_EApp (Pe_EIdentifier "tl_list_get", expr) in + let hd_expr = Me_EApp (Me_EIdentifier "hd_list_get", expr) in + let tl_expr = Me_EApp (Me_EIdentifier "tl_list_get", expr) in pattern_bindings hd_expr hd @ pattern_bindings tl_expr tl | PTuple pats -> List.mapi pats ~f:(fun i p -> - let ith_expr = Pe_EApp (Pe_EIdentifier "tuple_get", Pe_ETuple [expr; Pe_EConst (Pe_Cint i)]) in + let ith_expr = Me_EApp (Me_EIdentifier "tuple_get", Me_ETuple [expr; Me_EConst (Me_Cint i)]) in pattern_bindings ith_expr p ) |> List.concat | PConstraint (p, _) -> pattern_bindings expr p @@ -176,28 +176,28 @@ and desugar_match e branches = in let rec pattern_to_condition expr pat = match pat with - | PAny -> return @@ Pe_EConst (Pe_CBool true) - | PUnit -> return @@ Pe_EIf (Pe_EApp (Pe_EIdentifier "is_unit", expr), Pe_EConst (Pe_CBool true), Pe_EConst (Pe_CBool false)) - | PConst c -> return @@ Pe_EApp (Pe_EApp (Pe_EIdentifier "(=)", expr), Pe_EConst (const_to_pe_const c)) - | PIdentifier _ -> return @@ Pe_EConst (Pe_CBool true) - | PNill -> return @@ Pe_EApp (Pe_EIdentifier "is_empty", expr) + | PAny -> return @@ Me_EConst (Me_CBool true) + | PUnit -> return @@ Me_EIf (Me_EApp (Me_EIdentifier "is_unit", expr), Me_EConst (Me_CBool true), Me_EConst (Me_CBool false)) + | PConst c -> return @@ Me_EApp (Me_EApp (Me_EIdentifier "(=)", expr), Me_EConst (const_to_pe_const c)) + | PIdentifier _ -> return @@ Me_EConst (Me_CBool true) + | PNill -> return @@ Me_EApp (Me_EIdentifier "is_empty", expr) | PCons (hd, tl) -> - let hd_expr = Pe_EApp (Pe_EIdentifier "hd", expr) in - let tl_expr = Pe_EApp (Pe_EIdentifier "tl", expr) in + let hd_expr = Me_EApp (Me_EIdentifier "hd", expr) in + let tl_expr = Me_EApp (Me_EIdentifier "tl", expr) in let* cond_hd = pattern_to_condition hd_expr hd in let* cond_tl = pattern_to_condition tl_expr tl in - let is_cons_check = Pe_EApp (Pe_EIdentifier "is_cons", expr) in + let is_cons_check = Me_EApp (Me_EIdentifier "is_cons", expr) in let comb = match (cond_hd, cond_tl) with (* Если hd или tl — это PIdentifier или PAny, то if true then ... else false, что избыточно *) - | (Pe_EConst (Pe_CBool true), Pe_EConst (Pe_CBool true)) -> + | (Me_EConst (Me_CBool true), Me_EConst (Me_CBool true)) -> is_cons_check - | (Pe_EConst (Pe_CBool true), cond) -> - Pe_EIf (is_cons_check, cond, Pe_EConst (Pe_CBool false)) - | (cond, Pe_EConst (Pe_CBool true)) -> - Pe_EIf (is_cons_check, cond, Pe_EConst (Pe_CBool false)) + | (Me_EConst (Me_CBool true), cond) -> + Me_EIf (is_cons_check, cond, Me_EConst (Me_CBool false)) + | (cond, Me_EConst (Me_CBool true)) -> + Me_EIf (is_cons_check, cond, Me_EConst (Me_CBool false)) | (cond1, cond2) -> - Pe_EIf (is_cons_check, - Pe_EIf (cond1, cond2, Pe_EConst (Pe_CBool false)), - Pe_EConst (Pe_CBool false)) + Me_EIf (is_cons_check, + Me_EIf (cond1, cond2, Me_EConst (Me_CBool false)), + Me_EConst (Me_CBool false)) in return comb | PTuple pats -> @@ -205,11 +205,11 @@ and desugar_match e branches = RList.fold_left (List.mapi pats ~f:(fun i p -> (i, p))) ~init:(return []) ~f:(fun acc (i, p) -> - let ith_expr = Pe_EApp (Pe_EIdentifier "tuple_get", Pe_ETuple [expr; Pe_EConst (Pe_Cint i)]) in + let ith_expr = Me_EApp (Me_EIdentifier "tuple_get", Me_ETuple [expr; Me_EConst (Me_Cint i)]) in let* cond = pattern_to_condition ith_expr p in return (acc @ [cond])) in - return @@ List.fold_right conds ~init:(Pe_EConst (Pe_CBool true)) - ~f:(fun c acc -> Pe_EIf (c, acc, Pe_EConst (Pe_CBool false))) + return @@ List.fold_right conds ~init:(Me_EConst (Me_CBool true)) + ~f:(fun c acc -> Me_EIf (c, acc, Me_EConst (Me_CBool false))) | PConstraint (p, _) -> pattern_to_condition expr p in @@ -217,20 +217,20 @@ and desugar_match e branches = let tmp_var = get_new_id id_num "match_tmp" in let (bound_expr, bind_expr_opt) = match e' with - | Pe_EIdentifier _ -> (e', None) - | _ -> (Pe_EIdentifier tmp_var, Some (tmp_var, e')) + | Me_EIdentifier _ -> (e', None) + | _ -> (Me_EIdentifier tmp_var, Some (tmp_var, e')) in let* cond = pattern_to_condition bound_expr pat in let bindings = pattern_bindings bound_expr pat in let bound_rhs = List.fold_right bindings ~init:expr_rhs' ~f:(fun (id, expr) acc -> - Pe_ELet (NoRec, id, expr, acc)) + Me_ELet (NoRec, id, expr, acc)) in let* rest_expr = match rest with - | [] -> return @@ Pe_EApp (Pe_EIdentifier "failwith", Pe_EIdentifier "\"no matching\"") + | [] -> return @@ Me_EApp (Me_EIdentifier "failwith", Me_EIdentifier "\"no matching\"") | _ -> let new_e = match bind_expr_opt with @@ -241,9 +241,9 @@ and desugar_match e branches = in match bind_expr_opt with - | None -> return @@ Pe_EIf (cond, bound_rhs, rest_expr) + | None -> return @@ Me_EIf (cond, bound_rhs, rest_expr) | Some (var, expr) -> - return @@ Pe_ELet (NoRec, var, expr, Pe_EIf (cond, bound_rhs, rest_expr)) + return @@ Me_ELet (NoRec, var, expr, Me_EIf (cond, bound_rhs, rest_expr)) let decl_to_pe_decl decl = @@ -257,7 +257,7 @@ let decl_to_pe_decl decl = let* e' = expr_to_mexpr expr in return ((id, e') :: acc) | _ -> failwith "Bang-Bang. Only simple declarations supported") in - return @@ Pe_Nonrec (List.rev converted) + return @@ Me_Nonrec (List.rev converted) | RecDecl decls -> let* converted = RList.fold_left decls ~init:(return []) ~f:(fun acc (DDeclaration (pat, expr)) -> @@ -267,7 +267,7 @@ let decl_to_pe_decl decl = let* e' = expr_to_mexpr expr in return ((id, e') :: acc) | _ -> failwith "Bang-Bang. Only simple declarations supported") in - return @@ Pe_Rec (List.rev converted) + return @@ Me_Rec (List.rev converted) let match_elimination prog = StateMonad.run ( diff --git a/FML/lib/anf/me_ast.ml b/FML/lib/anf/me_ast.ml new file mode 100644 index 000000000..b09ddd825 --- /dev/null +++ b/FML/lib/anf/me_ast.ml @@ -0,0 +1,96 @@ +(** Copyright 2024-2025, Dmitry Pilyuk, Aleksandr Rozhkov *) + +(** SPDX-License-Identifier: LGPL-2.1 *) + +type rec_flag = + | Rec + | NoRec + +type me_const = + | Me_Cint of int + | Me_CBool of bool + +type me_expr = + | Me_EUnit + | Me_ENill + | Me_EIdentifier of string + | Me_EConst of me_const + | Me_EIf of me_expr * me_expr * me_expr + | Me_EFun of string list * me_expr + | Me_EApp of me_expr * me_expr + | Me_ELet of rec_flag * string * me_expr * me_expr + | Me_ECons of me_expr * me_expr + | Me_ETuple of me_expr list + +type me_declaration = + | Me_Nonrec of (string * me_expr) list + | Me_Rec of (string * me_expr) list + +type me_program = me_declaration list + +let const_to_str = function + | Me_CBool b -> if b then "true" else "false" + | Me_Cint i -> Format.sprintf "%i" i +;; + +let rec expr_to_str = function + | Me_EUnit -> "()" + | Me_ENill -> "[]" + | Me_EIdentifier a -> a + | Me_EConst c -> const_to_str c + | Me_EIf (e1, e2, e3) -> + Format.sprintf + "if %s\nthen %s\nelse %s" + (expr_to_str e1) + (expr_to_str e2) + (expr_to_str e3) + | Me_EFun (args, e) -> + Format.sprintf "(fun %s -> %s)" (String.concat " " args) (expr_to_str e) + | Me_EApp (e1, e2) -> Format.sprintf "(%s %s)" (expr_to_str e1) (expr_to_str e2) + | Me_ELet (NoRec, name, e1, e2) -> + Format.sprintf "let %s = %s in\n%s" name (expr_to_str e1) (expr_to_str e2) + | Me_ELet (Rec, name1, e1, e2) -> + Format.sprintf "let rec %s = %s in\n%s" name1 (expr_to_str e1) (expr_to_str e2) + | Me_ECons (e1, e2) -> Format.sprintf "(%s::%s)" (expr_to_str e1) (expr_to_str e2) + | Me_ETuple e_list -> + Format.sprintf + "(%s)" + (expr_to_str (List.hd e_list) + ^ List.fold_left + (fun acc e -> acc ^ Format.sprintf ", %s" (expr_to_str e)) + "" + (List.tl e_list)) +;; + +let decl_to_str = function + | Me_Nonrec decl_list -> + (match decl_list with + | [] -> "" + | (name, e) :: tl -> + Format.sprintf "let %s = %s" name (expr_to_str e) + ^ List.fold_left + (fun acc (name, e) -> + acc ^ Format.sprintf "\nlet %s = %s" name (expr_to_str e)) + "" + tl) + | Me_Rec decl_list -> + (match decl_list with + | [] -> "" + | (name, e) :: tl -> + Format.sprintf "let rec %s = %s" name (expr_to_str e) + ^ List.fold_left + (fun acc (name, e) -> + acc ^ Format.sprintf "\nand %s = %s" name (expr_to_str e)) + "" + tl) +;; + +let pp_me_program ppf p = + let len = List.length p in + List.iteri + (fun i a -> + if i = len - 1 + then Format.fprintf ppf "%s" (decl_to_str a) + else Format.fprintf ppf "%s\n\n" (decl_to_str a)) + p +;; diff --git a/FML/lib/dune b/FML/lib/dune index 127b524c2..2ac2ac77a 100644 --- a/FML/lib/dune +++ b/FML/lib/dune @@ -13,6 +13,7 @@ Pattern_elim Common Pe_ast + Me_ast Alpha_conv A_conv Match_elimination diff --git a/FML/tests/match_elimination_runner.ml b/FML/tests/match_elimination_runner.ml index b4d0c402e..67def54cd 100644 --- a/FML/tests/match_elimination_runner.ml +++ b/FML/tests/match_elimination_runner.ml @@ -6,7 +6,7 @@ open Fml_lib.Parser open Fml_lib.Inferencer open Fml_lib.A_conv open Fml_lib.Match_elimination -open Fml_lib.Pe_ast +open Fml_lib.Me_ast let () = let input = Stdio.In_channel.input_all Stdlib.stdin in @@ -21,7 +21,7 @@ let () = match parse_and_infer input with | Ok ast -> let ast = ac_program ast in - let ast_pe = match_elimination ast in - Format.printf "%a\n" pp_pe_program ast_pe + let ast_me = match_elimination ast in + Format.printf "%a\n" pp_me_program ast_me | Error message -> Format.printf "%s" message ;; From 45fde2aefb9b117bc932a5f9b159904bab22fcb4 Mon Sep 17 00:00:00 2001 From: Dmitry Pilyuk Date: Sat, 5 Apr 2025 11:55:46 +0300 Subject: [PATCH 56/92] Format me_elim and add tests --- FML/lib/anf/match_elimination.ml | 160 ++++++++++++++----------- FML/tests/match_elimination_manytest.t | 20 ++++ 2 files changed, 109 insertions(+), 71 deletions(-) diff --git a/FML/lib/anf/match_elimination.ml b/FML/lib/anf/match_elimination.ml index 91523abe7..c4164bbbe 100644 --- a/FML/lib/anf/match_elimination.ml +++ b/FML/lib/anf/match_elimination.ml @@ -3,7 +3,7 @@ (** SPDX-License-Identifier: LGPL-2.1 *) open Ast -open Base +open Base open Me_ast module StateMonad : sig @@ -75,7 +75,6 @@ end = struct let run m = snd (m 0) end - let get_new_id n name = String.concat [ name; "_me"; Int.to_string n ] open StateMonad @@ -83,21 +82,24 @@ open StateMonad let const_to_pe_const = function | CInt a -> Me_Cint a | CBool a -> Me_CBool a +;; let rec pattern_remove pat = match pat with - | PUnit -> ["()"] + | PUnit -> [ "()" ] | PConst _ -> [] - | PIdentifier id -> [id] - | PNill -> ["[]"] + | PIdentifier id -> [ id ] + | PNill -> [ "[]" ] | PTuple pats -> List.concat_map ~f:pattern_remove pats | PCons (hd, tl) -> pattern_remove hd @ pattern_remove tl | PConstraint (p, _) -> pattern_remove p | _ -> failwith "bye-bye, bro. im sleeping" +;; let rec_flags : Ast.rec_flag -> Me_ast.rec_flag = function | Rec -> Rec | NoRec -> NoRec +;; let rec expr_to_mexpr expr = match expr with @@ -120,26 +122,26 @@ let rec expr_to_mexpr expr = let* e2' = expr_to_mexpr e2 in let rec_flag = rec_flags rec_flag in (match ids with - | [id] -> return @@ Me_ELet (rec_flag, id, e1', e2') - | ids_list -> - let transformed_e = - List.mapi ids_list ~f:(fun i id -> - let idx_expr = EConst (CInt i) in - let unpack_expr = EApplication (EIdentifier "unpack_tuple", idx_expr) in - let applied = EApplication (e1, unpack_expr) in - (PIdentifier id, applied) - ) - in - let final_expr = - List.fold_right transformed_e ~init:e2 ~f:(fun (pat, expr) acc -> - ELetIn (NoRec, pat, expr, acc) - ) - in - expr_to_mexpr final_expr) + | [ id ] -> return @@ Me_ELet (rec_flag, id, e1', e2') + | ids_list -> + let transformed_e = + List.mapi ids_list ~f:(fun i id -> + let idx_expr = EConst (CInt i) in + let unpack_expr = EApplication (EIdentifier "unpack_tuple", idx_expr) in + let applied = EApplication (e1, unpack_expr) in + PIdentifier id, applied) + in + let final_expr = + List.fold_right transformed_e ~init:e2 ~f:(fun (pat, expr) acc -> + ELetIn (NoRec, pat, expr, acc)) + in + expr_to_mexpr final_expr) | ETuple exprs -> - let* exprs' = RList.fold_left exprs ~init:(return []) ~f:(fun acc e -> - let* e' = expr_to_mexpr e in - return (acc @ [e'])) in + let* exprs' = + RList.fold_left exprs ~init:(return []) ~f:(fun acc e -> + let* e' = expr_to_mexpr e in + return (acc @ [ e' ])) + in return @@ Me_ETuple exprs' | EIf (cond, then_, else_) -> let* cond' = expr_to_mexpr cond in @@ -150,8 +152,7 @@ let rec expr_to_mexpr expr = let* hd' = expr_to_mexpr hd in let* tl' = expr_to_mexpr tl in return @@ Me_ECons (hd', tl') - | EMatch (e, branches) -> - desugar_match e branches + | EMatch (e, branches) -> desugar_match e branches and desugar_match e branches = let* e' = expr_to_mexpr e in @@ -161,24 +162,33 @@ and desugar_match e branches = let* expr_rhs' = expr_to_mexpr expr_rhs in let rec pattern_bindings expr pat = match pat with - | PIdentifier id -> [ (id, expr) ] + | PIdentifier id -> [ id, expr ] | PCons (hd, tl) -> let hd_expr = Me_EApp (Me_EIdentifier "hd_list_get", expr) in let tl_expr = Me_EApp (Me_EIdentifier "tl_list_get", expr) in pattern_bindings hd_expr hd @ pattern_bindings tl_expr tl | PTuple pats -> List.mapi pats ~f:(fun i p -> - let ith_expr = Me_EApp (Me_EIdentifier "tuple_get", Me_ETuple [expr; Me_EConst (Me_Cint i)]) in - pattern_bindings ith_expr p - ) |> List.concat + let ith_expr = + Me_EApp (Me_EIdentifier "tuple_get", Me_ETuple [ expr; Me_EConst (Me_Cint i) ]) + in + pattern_bindings ith_expr p) + |> List.concat | PConstraint (p, _) -> pattern_bindings expr p | _ -> [] in let rec pattern_to_condition expr pat = match pat with | PAny -> return @@ Me_EConst (Me_CBool true) - | PUnit -> return @@ Me_EIf (Me_EApp (Me_EIdentifier "is_unit", expr), Me_EConst (Me_CBool true), Me_EConst (Me_CBool false)) - | PConst c -> return @@ Me_EApp (Me_EApp (Me_EIdentifier "(=)", expr), Me_EConst (const_to_pe_const c)) + | PUnit -> + return + @@ Me_EIf + ( Me_EApp (Me_EIdentifier "is_unit", expr) + , Me_EConst (Me_CBool true) + , Me_EConst (Me_CBool false) ) + | PConst c -> + return + @@ Me_EApp (Me_EApp (Me_EIdentifier "(=)", expr), Me_EConst (const_to_pe_const c)) | PIdentifier _ -> return @@ Me_EConst (Me_CBool true) | PNill -> return @@ Me_EApp (Me_EIdentifier "is_empty", expr) | PCons (hd, tl) -> @@ -187,50 +197,56 @@ and desugar_match e branches = let* cond_hd = pattern_to_condition hd_expr hd in let* cond_tl = pattern_to_condition tl_expr tl in let is_cons_check = Me_EApp (Me_EIdentifier "is_cons", expr) in - let comb = match (cond_hd, cond_tl) with (* Если hd или tl — это PIdentifier или PAny, то if true then ... else false, что избыточно *) - | (Me_EConst (Me_CBool true), Me_EConst (Me_CBool true)) -> - is_cons_check - | (Me_EConst (Me_CBool true), cond) -> - Me_EIf (is_cons_check, cond, Me_EConst (Me_CBool false)) - | (cond, Me_EConst (Me_CBool true)) -> - Me_EIf (is_cons_check, cond, Me_EConst (Me_CBool false)) - | (cond1, cond2) -> - Me_EIf (is_cons_check, - Me_EIf (cond1, cond2, Me_EConst (Me_CBool false)), - Me_EConst (Me_CBool false)) + let comb = + match cond_hd, cond_tl with + (* Если hd или tl — это PIdentifier или PAny, то if true then ... else false, что избыточно *) + | Me_EConst (Me_CBool true), Me_EConst (Me_CBool true) -> is_cons_check + | Me_EConst (Me_CBool true), cond -> + Me_EIf (is_cons_check, cond, Me_EConst (Me_CBool false)) + | cond, Me_EConst (Me_CBool true) -> + Me_EIf (is_cons_check, cond, Me_EConst (Me_CBool false)) + | cond1, cond2 -> + Me_EIf + ( is_cons_check + , Me_EIf (cond1, cond2, Me_EConst (Me_CBool false)) + , Me_EConst (Me_CBool false) ) in return comb | PTuple pats -> let* conds = - RList.fold_left (List.mapi pats ~f:(fun i p -> (i, p))) + RList.fold_left + (List.mapi pats ~f:(fun i p -> i, p)) ~init:(return []) ~f:(fun acc (i, p) -> - let ith_expr = Me_EApp (Me_EIdentifier "tuple_get", Me_ETuple [expr; Me_EConst (Me_Cint i)]) in + let ith_expr = + Me_EApp + (Me_EIdentifier "tuple_get", Me_ETuple [ expr; Me_EConst (Me_Cint i) ]) + in let* cond = pattern_to_condition ith_expr p in - return (acc @ [cond])) in - return @@ List.fold_right conds ~init:(Me_EConst (Me_CBool true)) - ~f:(fun c acc -> Me_EIf (c, acc, Me_EConst (Me_CBool false))) + return (acc @ [ cond ])) + in + return + @@ List.fold_right conds ~init:(Me_EConst (Me_CBool true)) ~f:(fun c acc -> + Me_EIf (c, acc, Me_EConst (Me_CBool false))) | PConstraint (p, _) -> pattern_to_condition expr p in - let* id_num = fresh in let tmp_var = get_new_id id_num "match_tmp" in - let (bound_expr, bind_expr_opt) = + let bound_expr, bind_expr_opt = match e' with - | Me_EIdentifier _ -> (e', None) - | _ -> (Me_EIdentifier tmp_var, Some (tmp_var, e')) + | Me_EIdentifier _ -> e', None + | _ -> Me_EIdentifier tmp_var, Some (tmp_var, e') in - let* cond = pattern_to_condition bound_expr pat in let bindings = pattern_bindings bound_expr pat in let bound_rhs = List.fold_right bindings ~init:expr_rhs' ~f:(fun (id, expr) acc -> Me_ELet (NoRec, id, expr, acc)) in - let* rest_expr = match rest with - | [] -> return @@ Me_EApp (Me_EIdentifier "failwith", Me_EIdentifier "\"no matching\"") + | [] -> + return @@ Me_EApp (Me_EIdentifier "failwith", Me_EIdentifier "\"no matching\"") | _ -> let new_e = match bind_expr_opt with @@ -239,12 +255,11 @@ and desugar_match e branches = in desugar_match new_e rest in - - match bind_expr_opt with - | None -> return @@ Me_EIf (cond, bound_rhs, rest_expr) - | Some (var, expr) -> - return @@ Me_ELet (NoRec, var, expr, Me_EIf (cond, bound_rhs, rest_expr)) - + (match bind_expr_opt with + | None -> return @@ Me_EIf (cond, bound_rhs, rest_expr) + | Some (var, expr) -> + return @@ Me_ELet (NoRec, var, expr, Me_EIf (cond, bound_rhs, rest_expr))) +;; let decl_to_pe_decl decl = match decl with @@ -253,25 +268,28 @@ let decl_to_pe_decl decl = RList.fold_left decls ~init:(return []) ~f:(fun acc (DDeclaration (pat, expr)) -> let ids = pattern_remove pat in match ids with - | [id] -> + | [ id ] -> let* e' = expr_to_mexpr expr in return ((id, e') :: acc) - | _ -> failwith "Bang-Bang. Only simple declarations supported") in + | _ -> failwith "Bang-Bang. Only simple declarations supported") + in return @@ Me_Nonrec (List.rev converted) | RecDecl decls -> let* converted = RList.fold_left decls ~init:(return []) ~f:(fun acc (DDeclaration (pat, expr)) -> let ids = pattern_remove pat in match ids with - | [id] -> + | [ id ] -> let* e' = expr_to_mexpr expr in return ((id, e') :: acc) - | _ -> failwith "Bang-Bang. Only simple declarations supported") in + | _ -> failwith "Bang-Bang. Only simple declarations supported") + in return @@ Me_Rec (List.rev converted) +;; -let match_elimination prog = - StateMonad.run ( - RList.fold_left prog ~init:(return []) ~f:(fun acc decl -> - let* d = decl_to_pe_decl decl in - return (acc @ [d])) - ) \ No newline at end of file +let match_elimination prog = + StateMonad.run + (RList.fold_left prog ~init:(return []) ~f:(fun acc decl -> + let* d = decl_to_pe_decl decl in + return (acc @ [ d ]))) +;; diff --git a/FML/tests/match_elimination_manytest.t b/FML/tests/match_elimination_manytest.t index 528217218..fc1e7fcb0 100644 --- a/FML/tests/match_elimination_manytest.t +++ b/FML/tests/match_elimination_manytest.t @@ -1,3 +1,23 @@ + $ ./match_elimination_runner.exe << EOF + > let is_empty x = x+1 + > let rec length xs = match xs with + > | [] -> 0 + > | _::tl -> 1 + length xs + > EOF + let is_empty_ac0 = (fun x -> ((( + ) x) 1)) + + let rec length = (fun xs -> if (is_empty xs) + then 0 + else if (is_cons xs) + then let _ = (hd_list_get xs) in + let tl = (tl_list_get xs) in + ((( + ) 1) (length xs)) + else (failwith "no matching")) + + $ ./match_elimination_runner.exe << EOF + > let (a, b) = (5,6) + > EOF + $ ./match_elimination_runner.exe << EOF > let fac n = > let rec fack n k = From 29285f996280646bbaae4643220a817fa97ef71d Mon Sep 17 00:00:00 2001 From: Dmitry Pilyuk Date: Sat, 5 Apr 2025 12:06:36 +0300 Subject: [PATCH 57/92] Add tests --- FML/tests/match_elimination_manytest.t | 7 +++++++ FML/tests/pe_manytests.t | 7 +++++++ 2 files changed, 14 insertions(+) diff --git a/FML/tests/match_elimination_manytest.t b/FML/tests/match_elimination_manytest.t index fc1e7fcb0..5b496fa02 100644 --- a/FML/tests/match_elimination_manytest.t +++ b/FML/tests/match_elimination_manytest.t @@ -1,3 +1,10 @@ + $ ./match_elimination_runner.exe << EOF + > let length xs = match xs with + > | a::b::[] -> 2 + > | a::[] -> 1 + > | [] -> 0 + > EOF + $ ./match_elimination_runner.exe << EOF > let is_empty x = x+1 > let rec length xs = match xs with diff --git a/FML/tests/pe_manytests.t b/FML/tests/pe_manytests.t index 894427882..de50077e5 100644 --- a/FML/tests/pe_manytests.t +++ b/FML/tests/pe_manytests.t @@ -1,3 +1,10 @@ + $ ./pe_runner.exe << EOF + > let length xs = match xs with + > | a::b::[] -> 2 + > | a::[] -> 1 + > | [] -> 0 + > EOF + $ ./pe_runner.exe << EOF > let f n _ = n > From 5bc4d362150d739309d20985af9c2f5fcd793630 Mon Sep 17 00:00:00 2001 From: RozhkovAleksandr Date: Sat, 5 Apr 2025 17:12:08 +0300 Subject: [PATCH 58/92] fix hard patterns decl --- FML/lib/anf/match_elimination.ml | 73 ++++++++++++++++---------- FML/tests/match_elimination_manytest.t | 3 ++ 2 files changed, 48 insertions(+), 28 deletions(-) diff --git a/FML/lib/anf/match_elimination.ml b/FML/lib/anf/match_elimination.ml index c4164bbbe..a6e12e431 100644 --- a/FML/lib/anf/match_elimination.ml +++ b/FML/lib/anf/match_elimination.ml @@ -96,6 +96,24 @@ let rec pattern_remove pat = | _ -> failwith "bye-bye, bro. im sleeping" ;; +let rec pattern_bindings expr pat = + match pat with + | PIdentifier id -> [ id, expr ] + | PCons (hd, tl) -> + let hd_expr = Me_EApp (Me_EIdentifier "hd_list_get", expr) in + let tl_expr = Me_EApp (Me_EIdentifier "tl_list_get", expr) in + pattern_bindings hd_expr hd @ pattern_bindings tl_expr tl + | PTuple pats -> + List.mapi pats ~f:(fun i p -> + let ith_expr = + Me_EApp (Me_EIdentifier "tuple_get", Me_ETuple [ expr; Me_EConst (Me_Cint i) ]) + in + pattern_bindings ith_expr p) + |> List.concat + | PConstraint (p, _) -> pattern_bindings expr p + | _ -> [] +;; + let rec_flags : Ast.rec_flag -> Me_ast.rec_flag = function | Rec -> Rec | NoRec -> NoRec @@ -160,23 +178,6 @@ and desugar_match e branches = | [] -> failwith "Empty match expression" | (pat, expr_rhs) :: rest -> let* expr_rhs' = expr_to_mexpr expr_rhs in - let rec pattern_bindings expr pat = - match pat with - | PIdentifier id -> [ id, expr ] - | PCons (hd, tl) -> - let hd_expr = Me_EApp (Me_EIdentifier "hd_list_get", expr) in - let tl_expr = Me_EApp (Me_EIdentifier "tl_list_get", expr) in - pattern_bindings hd_expr hd @ pattern_bindings tl_expr tl - | PTuple pats -> - List.mapi pats ~f:(fun i p -> - let ith_expr = - Me_EApp (Me_EIdentifier "tuple_get", Me_ETuple [ expr; Me_EConst (Me_Cint i) ]) - in - pattern_bindings ith_expr p) - |> List.concat - | PConstraint (p, _) -> pattern_bindings expr p - | _ -> [] - in let rec pattern_to_condition expr pat = match pat with | PAny -> return @@ Me_EConst (Me_CBool true) @@ -261,19 +262,35 @@ and desugar_match e branches = return @@ Me_ELet (NoRec, var, expr, Me_EIf (cond, bound_rhs, rest_expr))) ;; -let decl_to_pe_decl decl = - match decl with + + +let decl_to_pe_decl decls = + let process_binding pat expr = + let ids = pattern_remove pat in + match ids with + | [ id ] -> + let* e' = expr_to_mexpr expr in + return [ (id, e') ] + | _ -> + let* tmp_id_num = fresh in + let tmp_var = get_new_id tmp_id_num "tmp" in + let* e' = expr_to_mexpr expr in + let tmp_expr = Me_EIdentifier tmp_var in + let bindings = + pattern_bindings tmp_expr pat + |> List.map ~f:(fun (id, expr) -> (id, expr)) + in + return ((tmp_var, e') :: bindings) + in + match decls with | NoRecDecl decls -> let* converted = RList.fold_left decls ~init:(return []) ~f:(fun acc (DDeclaration (pat, expr)) -> - let ids = pattern_remove pat in - match ids with - | [ id ] -> - let* e' = expr_to_mexpr expr in - return ((id, e') :: acc) - | _ -> failwith "Bang-Bang. Only simple declarations supported") + let* bindings = process_binding pat expr in + return (acc @ bindings)) in - return @@ Me_Nonrec (List.rev converted) + return @@ Me_Nonrec converted + | RecDecl decls -> let* converted = RList.fold_left decls ~init:(return []) ~f:(fun acc (DDeclaration (pat, expr)) -> @@ -282,10 +299,10 @@ let decl_to_pe_decl decl = | [ id ] -> let* e' = expr_to_mexpr expr in return ((id, e') :: acc) - | _ -> failwith "Bang-Bang. Only simple declarations supported") + | _ -> + failwith "Simple patterns on rec, otherwise it's crazt") in return @@ Me_Rec (List.rev converted) -;; let match_elimination prog = StateMonad.run diff --git a/FML/tests/match_elimination_manytest.t b/FML/tests/match_elimination_manytest.t index 5b496fa02..2acc7c5f0 100644 --- a/FML/tests/match_elimination_manytest.t +++ b/FML/tests/match_elimination_manytest.t @@ -24,6 +24,9 @@ $ ./match_elimination_runner.exe << EOF > let (a, b) = (5,6) > EOF + let tmp_me0 = (5, 6) + let a = (tuple_get (tmp_me0, 0)) + let b = (tuple_get (tmp_me0, 1)) $ ./match_elimination_runner.exe << EOF > let fac n = From efe5d449f1aa10766866a787cf2c9cb399ce1dc0 Mon Sep 17 00:00:00 2001 From: RozhkovAleksandr Date: Sat, 5 Apr 2025 17:18:32 +0300 Subject: [PATCH 59/92] fix bug in tuple --- FML/lib/anf/match_elimination.ml | 14 +++++++---- FML/tests/match_elimination_manytest.t | 32 +++++++++++++++++++------- 2 files changed, 34 insertions(+), 12 deletions(-) diff --git a/FML/lib/anf/match_elimination.ml b/FML/lib/anf/match_elimination.ml index a6e12e431..90a0a11d1 100644 --- a/FML/lib/anf/match_elimination.ml +++ b/FML/lib/anf/match_elimination.ml @@ -144,10 +144,16 @@ let rec expr_to_mexpr expr = | ids_list -> let transformed_e = List.mapi ids_list ~f:(fun i id -> - let idx_expr = EConst (CInt i) in - let unpack_expr = EApplication (EIdentifier "unpack_tuple", idx_expr) in - let applied = EApplication (e1, unpack_expr) in - PIdentifier id, applied) + let get_expr = + EApplication ( + EApplication ( + EIdentifier "tuple_get", + e1 + ), + EConst (CInt i) + ) + in + PIdentifier id, get_expr) in let final_expr = List.fold_right transformed_e ~init:e2 ~f:(fun (pat, expr) acc -> diff --git a/FML/tests/match_elimination_manytest.t b/FML/tests/match_elimination_manytest.t index 2acc7c5f0..87f5bddf5 100644 --- a/FML/tests/match_elimination_manytest.t +++ b/FML/tests/match_elimination_manytest.t @@ -4,6 +4,22 @@ > | a::[] -> 1 > | [] -> 0 > EOF + let length = (fun xs -> if if (is_cons xs) + then if (is_cons (tl xs)) + then (is_empty (tl (tl xs))) + else false + else false + then let a = (hd_list_get xs) in + let b = (hd_list_get (tl_list_get xs)) in + 2 + else if if (is_cons xs) + then (is_empty (tl xs)) + else false + then let a = (hd_list_get xs) in + 1 + else if (is_empty xs) + then 0 + else (failwith "no matching")) $ ./match_elimination_runner.exe << EOF > let is_empty x = x+1 @@ -202,20 +218,20 @@ $ ./match_elimination_runner.exe < manytests/typed/015tuples.ml let rec fix = (fun f -> (fun x -> ((f (fix f)) x))) - let map = (fun f -> (fun p -> let a = (p (unpack_tuple 0)) in - let b = (p (unpack_tuple 1)) in + let map = (fun f -> (fun p -> let a = ((tuple_get p) 0) in + let b = ((tuple_get p) 1) in ((f a), (f b)))) let fixpoly = (fun l -> ((fix (fun self -> (fun l_ac0 -> ((map (fun li -> (fun x -> ((li (self l_ac0)) x)))) l_ac0)))) l)) - let feven = (fun p -> (fun n -> let e = (p (unpack_tuple 0)) in - let o = (p (unpack_tuple 1)) in + let feven = (fun p -> (fun n -> let e = ((tuple_get p) 0) in + let o = ((tuple_get p) 1) in if ((( = ) n) 0) then 1 else (o ((( - ) n) 1)))) - let fodd = (fun p -> (fun n -> let e = (p (unpack_tuple 0)) in - let o = (p (unpack_tuple 1)) in + let fodd = (fun p -> (fun n -> let e = ((tuple_get p) 0) in + let o = ((tuple_get p) 1) in if ((( = ) n) 0) then 0 else (e ((( - ) n) 1)))) @@ -231,8 +247,8 @@ let main = let () = (print_int (modd 1)) in let () = (print_int (meven 2)) in - let even = (tie (unpack_tuple 0)) in - let odd = (tie (unpack_tuple 1)) in + let even = ((tuple_get tie) 0) in + let odd = ((tuple_get tie) 1) in let () = (print_int (odd 3)) in let () = (print_int (even 4)) in 0 From 22cc79d2a93066e2087ccf953e590b13ef8839c8 Mon Sep 17 00:00:00 2001 From: RozhkovAleksandr Date: Sat, 5 Apr 2025 22:32:33 +0300 Subject: [PATCH 60/92] fix --- FML/lib/anf/match_elimination.ml | 4 ++-- FML/tests/match_elimination_manytest.t | 24 ++++++++++++------------ 2 files changed, 14 insertions(+), 14 deletions(-) diff --git a/FML/lib/anf/match_elimination.ml b/FML/lib/anf/match_elimination.ml index 90a0a11d1..c92dd922d 100644 --- a/FML/lib/anf/match_elimination.ml +++ b/FML/lib/anf/match_elimination.ml @@ -199,8 +199,8 @@ and desugar_match e branches = | PIdentifier _ -> return @@ Me_EConst (Me_CBool true) | PNill -> return @@ Me_EApp (Me_EIdentifier "is_empty", expr) | PCons (hd, tl) -> - let hd_expr = Me_EApp (Me_EIdentifier "hd", expr) in - let tl_expr = Me_EApp (Me_EIdentifier "tl", expr) in + let hd_expr = Me_EApp (Me_EIdentifier "hd_list_get", expr) in + let tl_expr = Me_EApp (Me_EIdentifier "tl_list_get", expr) in let* cond_hd = pattern_to_condition hd_expr hd in let* cond_tl = pattern_to_condition tl_expr tl in let is_cons_check = Me_EApp (Me_EIdentifier "is_cons", expr) in diff --git a/FML/tests/match_elimination_manytest.t b/FML/tests/match_elimination_manytest.t index 87f5bddf5..1dacd1a3d 100644 --- a/FML/tests/match_elimination_manytest.t +++ b/FML/tests/match_elimination_manytest.t @@ -5,15 +5,15 @@ > | [] -> 0 > EOF let length = (fun xs -> if if (is_cons xs) - then if (is_cons (tl xs)) - then (is_empty (tl (tl xs))) + then if (is_cons (tl_list_get xs)) + then (is_empty (tl_list_get (tl_list_get xs))) else false else false then let a = (hd_list_get xs) in let b = (hd_list_get (tl_list_get xs)) in 2 else if if (is_cons xs) - then (is_empty (tl xs)) + then (is_empty (tl_list_get xs)) else false then let a = (hd_list_get xs) in 1 @@ -274,22 +274,22 @@ let rec map = (fun f -> (fun xs -> if (is_empty xs) then [] else if if (is_cons xs) - then (is_empty (tl xs)) + then (is_empty (tl_list_get xs)) else false then let a = (hd_list_get xs) in ((f a)::[]) else if if (is_cons xs) - then if (is_cons (tl xs)) - then (is_empty (tl (tl xs))) + then if (is_cons (tl_list_get xs)) + then (is_empty (tl_list_get (tl_list_get xs))) else false else false then let a = (hd_list_get xs) in let b = (hd_list_get (tl_list_get xs)) in ((f a)::((f b)::[])) else if if (is_cons xs) - then if (is_cons (tl xs)) - then if (is_cons (tl (tl xs))) - then (is_empty (tl (tl (tl xs)))) + then if (is_cons (tl_list_get xs)) + then if (is_cons (tl_list_get (tl_list_get xs))) + then (is_empty (tl_list_get (tl_list_get (tl_list_get xs)))) else false else false else false @@ -298,9 +298,9 @@ let c = (hd_list_get (tl_list_get (tl_list_get xs))) in ((f a)::((f b)::((f c)::[]))) else if if (is_cons xs) - then if (is_cons (tl xs)) - then if (is_cons (tl (tl xs))) - then (is_cons (tl (tl (tl xs)))) + then if (is_cons (tl_list_get xs)) + then if (is_cons (tl_list_get (tl_list_get xs))) + then (is_cons (tl_list_get (tl_list_get (tl_list_get xs)))) else false else false else false From 35ac2b34d5d6834352c647284fc6416996911534 Mon Sep 17 00:00:00 2001 From: RozhkovAleksandr Date: Sun, 6 Apr 2025 23:31:00 +0300 Subject: [PATCH 61/92] feat: add somes in lambda lift --- FML/lib/anf/lambda_lift.ml | 139 +++++++++++++++++++++++++++++++++++++ FML/lib/dune | 1 + 2 files changed, 140 insertions(+) create mode 100644 FML/lib/anf/lambda_lift.ml diff --git a/FML/lib/anf/lambda_lift.ml b/FML/lib/anf/lambda_lift.ml new file mode 100644 index 000000000..5be2abdc4 --- /dev/null +++ b/FML/lib/anf/lambda_lift.ml @@ -0,0 +1,139 @@ +(** Copyright 2024-2025, Dmitry Pilyuk, Aleksandr Rozhkov *) + +(** SPDX-License-Identifier: LGPL-2.1 *) + +open Me_ast +open Base + +module StateMonad : sig + include Base.Monad.Infix + + val return : 'a -> 'a t + val ( let* ) : 'a t -> ('a -> 'b t) -> 'b t + + module RList : sig + val fold_left : 'a list -> init:'b t -> f:('b -> 'a -> 'b t) -> 'b t + val fold_right : 'a list -> init:'b t -> f:('a -> 'b -> 'b t) -> 'b t + end + + module RMap : sig + val fold_left + : ('a, 'b, 'c) Base.Map.t + -> init:'d t + -> f:('a -> 'b -> 'd -> 'd t) + -> 'd t + end + + val fresh : int t + val run : 'a t -> 'a +end = struct + type 'a t = int -> int * 'a (* State and Result monad composition *) + + let ( >>= ) : 'a 'b. 'a t -> ('a -> 'b t) -> 'b t = + fun m f s -> + let s', v' = m s in + f v' s' + ;; + + let ( >>| ) : 'a 'b. 'a t -> ('a -> 'b) -> 'b t = + fun m f s -> + let s', x = m s in + s', f x + ;; + + let return v last = last, v + let bind x ~f = x >>= f + let fresh last = last + 1, last (* Get new state *) + let ( let* ) x f = bind x ~f (* Syntax sugar for bind *) + + module RMap = struct + (* Classic map folding. *) + let fold_left mp ~init ~f = + Base.Map.fold mp ~init ~f:(fun ~key ~data acc -> + let* acc = acc in + f key data acc) + ;; + end + + module RList = struct + (* Classic list folding. *) + let fold_left lt ~init ~f = + Base.List.fold_left lt ~init ~f:(fun acc item -> + let* acc = acc in + f acc item) + ;; + + let fold_right lt ~init ~f = + Base.List.fold_right lt ~init ~f:(fun item acc -> + let* acc = acc in + f item acc) + ;; + end + + (* Run and get the internal value. *) + let run m = snd (m 0) +end + +let get_new_id n name = Base.String.concat [ name; "_ll"; Int.to_string n ] + +open StateMonad + +(* добавляем в списочек свободные переменные *) +let rec free_vars expr bound = + match expr with + | Me_EUnit | Me_ENill | Me_EConst _ -> [] + | Me_EIdentifier x -> if Set.mem bound x then [] else [x] + | Me_EIf (e1, e2, e3) -> + free_vars e1 bound @ free_vars e2 bound @ free_vars e3 bound + | Me_EFun (args, body) -> + let bound' = List.fold_left ~f:Set.add ~init:bound args in + free_vars body bound' + | Me_EApp (e1, e2) -> free_vars e1 bound @ free_vars e2 bound + | Me_ELet (_, name, e1, e2) -> + let fv1 = free_vars e1 bound in + let fv2 = free_vars e2 (Set.add bound name) in + fv1 @ fv2 + | Me_ECons (e1, e2) -> free_vars e1 bound @ free_vars e2 bound + | Me_ETuple lst -> List.fold_left lst ~init:[] ~f:(fun acc e -> acc @ free_vars e bound) +;; + + + + +let rec ll_expr expr = + match expr with + | Me_EUnit | Me_ENill | Me_EConst _ | Me_EIdentifier _ -> return ([], expr) + + | Me_EIf (e1, e2, e3) -> + let* (defs1, e1') = ll_expr e1 in + let* (defs2, e2') = ll_expr e2 in + let* (defs3, e3') = ll_expr e3 in + return (defs1 @ defs2 @ defs3, Me_EIf (e1', e2', e3')) + + | Me_EApp (e1, e2) -> + let* (defs1, e1') = ll_expr e1 in + let* (defs2, e2') = ll_expr e2 in + return (defs1 @ defs2, Me_EApp (e1', e2')) + + | Me_ECons (e1, e2) -> + let* (defs1, e1') = ll_expr e1 in + let* (defs2, e2') = ll_expr e2 in + return (defs1 @ defs2, Me_ECons (e1', e2')) + + | Me_ETuple lst -> + let* results = + RList.fold_left lst ~init:(return ([], [])) ~f:(fun (acc_defs, acc_exprs) e -> + let* (defs, e') = ll_expr e in + return (acc_defs @ defs, acc_exprs @ [ e' ])) + in + let defs, exprs = results in + return (defs, Me_ETuple exprs) + + | Me_ELet (flag, name, e1, e2) -> + let* (defs1, e1') = ll_expr e1 in + let* (defs2, e2') = ll_expr e2 in + return (defs1 @ defs2, Me_ELet (flag, name, e1', e2')) + + | _ -> failwith "not impl" +;; + diff --git a/FML/lib/dune b/FML/lib/dune index 2ac2ac77a..932e13c71 100644 --- a/FML/lib/dune +++ b/FML/lib/dune @@ -17,6 +17,7 @@ Alpha_conv A_conv Match_elimination + Lambda_lift Closure_conv Lambda_lifting Anf_ast From d2ca6fd922cfe534df53d87e6cb4a60c42d7a347 Mon Sep 17 00:00:00 2001 From: RozhkovAleksandr Date: Wed, 9 Apr 2025 11:18:09 +0300 Subject: [PATCH 62/92] add handle for LL. feat for efun and elet ll --- FML/lib/anf/lambda_lift.ml | 72 ++++- FML/tests/dune | 32 ++ FML/tests/lambda_lift_manytest.t | 489 +++++++++++++++++++++++++++++++ FML/tests/lambda_lift_runner.ml | 29 ++ 4 files changed, 612 insertions(+), 10 deletions(-) create mode 100644 FML/tests/lambda_lift_manytest.t create mode 100644 FML/tests/lambda_lift_runner.ml diff --git a/FML/lib/anf/lambda_lift.ml b/FML/lib/anf/lambda_lift.ml index 5be2abdc4..d00b922dd 100644 --- a/FML/lib/anf/lambda_lift.ml +++ b/FML/lib/anf/lambda_lift.ml @@ -97,29 +97,22 @@ let rec free_vars expr bound = | Me_ETuple lst -> List.fold_left lst ~init:[] ~f:(fun acc e -> acc @ free_vars e bound) ;; - - - let rec ll_expr expr = match expr with | Me_EUnit | Me_ENill | Me_EConst _ | Me_EIdentifier _ -> return ([], expr) - | Me_EIf (e1, e2, e3) -> let* (defs1, e1') = ll_expr e1 in let* (defs2, e2') = ll_expr e2 in let* (defs3, e3') = ll_expr e3 in return (defs1 @ defs2 @ defs3, Me_EIf (e1', e2', e3')) - | Me_EApp (e1, e2) -> let* (defs1, e1') = ll_expr e1 in let* (defs2, e2') = ll_expr e2 in return (defs1 @ defs2, Me_EApp (e1', e2')) - | Me_ECons (e1, e2) -> let* (defs1, e1') = ll_expr e1 in let* (defs2, e2') = ll_expr e2 in - return (defs1 @ defs2, Me_ECons (e1', e2')) - + return (defs1 @ defs2, Me_ECons (e1', e2')) | Me_ETuple lst -> let* results = RList.fold_left lst ~init:(return ([], [])) ~f:(fun (acc_defs, acc_exprs) e -> @@ -132,8 +125,67 @@ let rec ll_expr expr = | Me_ELet (flag, name, e1, e2) -> let* (defs1, e1') = ll_expr e1 in let* (defs2, e2') = ll_expr e2 in - return (defs1 @ defs2, Me_ELet (flag, name, e1', e2')) + (* e1' — это анонимная функция (а функции у нас только так) *) + (match e1' with + | Me_EFun (args, body) -> + let* id = fresh in + let new_name = get_new_id id name in + let fvs = free_vars e1' (Set.of_list (module String) args) in + let new_args = fvs @ args in + let new_fun = Me_EFun (new_args, body) in + let def = (new_name, new_fun) in + let call_expr = + List.fold_left + (List.map ~f:(fun x -> Me_EIdentifier x) fvs) + ~init:(Me_EIdentifier new_name) + ~f:(fun acc arg -> Me_EApp (acc, arg)) + in + return (defs1 @ [ def ] @ defs2, Me_ELet (flag, name, call_expr, e2')) + | _ -> + return (defs1 @ defs2, Me_ELet (flag, name, e1', e2'))) - | _ -> failwith "not impl" + | Me_EFun (args, body) -> + let* id = fresh in + let name = get_new_id id "lam" in + let bound = Set.of_list (module String) args in + let fvs = free_vars expr bound in + let all_args = fvs @ args in + let* (defs, body') = ll_expr body in + let new_fun = Me_EFun (all_args, body') in + let def = (name, new_fun) in + let call_expr = + List.fold_left + (List.map ~f:(fun x -> Me_EIdentifier x) fvs) + ~init:(Me_EIdentifier name) + ~f:(fun acc arg -> Me_EApp (acc, arg)) + in + return (defs @ [ def ], call_expr) +;; + +let ll_binding (name, expr) = + let* (defs, expr') = ll_expr expr in + return (defs @ [ (name, expr') ]) +;; + +let ll_decl decl = + match decl with + | Me_Nonrec bindings -> + let* all_defs = + RList.fold_left bindings ~init:(return []) ~f:(fun acc b -> + let* lifted = ll_binding b in + return (acc @ lifted)) + in + return (Me_Nonrec all_defs) + | Me_Rec bindings -> + RList.fold_left bindings ~init:(return []) ~f:(fun acc (name, expr) -> + let* (defs, expr') = ll_expr expr in + return (acc @ defs @ [ (name, expr') ])) >>= fun all -> + return (Me_Rec all) ;; +let lambda_lift prog = + StateMonad.run + (RList.fold_left prog ~init:(return []) ~f:(fun acc decl -> + let* d = ll_decl decl in + return (acc @ [ d ]))) +;; \ No newline at end of file diff --git a/FML/tests/dune b/FML/tests/dune index cef7fee37..d6e91198c 100644 --- a/FML/tests/dune +++ b/FML/tests/dune @@ -44,6 +44,12 @@ (modules match_elimination_runner) (libraries fml_lib stdio)) +(executable + (name lambda_lift_runner) + (public_name lambda_lift_runner) + (modules lambda_lift_runner) + (libraries fml_lib stdio)) + (executable (name closure_conv_runner) (public_name closure_conv_runner) @@ -295,3 +301,29 @@ manytests/typed/013foldfoldr.ml manytests/typed/015tuples.ml manytests/typed/016lists.ml)) + +(cram + (applies_to lambda_lift_manytest) + (deps + ./lambda_lift_runner.exe + manytests/do_not_type/001.ml + manytests/do_not_type/002if.ml + manytests/do_not_type/003occurs.ml + manytests/do_not_type/004let_poly.ml + manytests/do_not_type/015tuples.ml + manytests/typed/001fac.ml + manytests/typed/002fac.ml + manytests/typed/003fib.ml + manytests/typed/004manyargs.ml + manytests/typed/005fix.ml + manytests/typed/006partial.ml + manytests/typed/006partial2.ml + manytests/typed/006partial3.ml + manytests/typed/007order.ml + manytests/typed/008ascription.ml + manytests/typed/009let_poly.ml + manytests/typed/011mapcps.ml + manytests/typed/012fibcps.ml + manytests/typed/013foldfoldr.ml + manytests/typed/015tuples.ml + manytests/typed/016lists.ml)) diff --git a/FML/tests/lambda_lift_manytest.t b/FML/tests/lambda_lift_manytest.t new file mode 100644 index 000000000..a73101485 --- /dev/null +++ b/FML/tests/lambda_lift_manytest.t @@ -0,0 +1,489 @@ + $ ./lambda_lift_runner.exe << EOF + > let f = let y x = x + 1 in y 3;; + > EOF + let lam_ll0 = (fun ( + ) x -> ((( + ) x) 1)) + let f = let y = (lam_ll0 ( + )) in + (y 3) + + $ ./lambda_lift_runner.exe << EOF + > let length xs = match xs with + > | a::b::[] -> 2 + > | a::[] -> 1 + > | [] -> 0 + > EOF + let lam_ll0 = (fun is_cons is_cons tl_list_get is_empty tl_list_get tl_list_get hd_list_get hd_list_get tl_list_get is_cons is_empty tl_list_get hd_list_get is_empty failwith "no matching" xs -> if if (is_cons xs) + then if (is_cons (tl_list_get xs)) + then (is_empty (tl_list_get (tl_list_get xs))) + else false + else false + then let a = (hd_list_get xs) in + let b = (hd_list_get (tl_list_get xs)) in + 2 + else if if (is_cons xs) + then (is_empty (tl_list_get xs)) + else false + then let a = (hd_list_get xs) in + 1 + else if (is_empty xs) + then 0 + else (failwith "no matching")) + let length = ((((((((((((((((lam_ll0 is_cons) is_cons) tl_list_get) is_empty) tl_list_get) tl_list_get) hd_list_get) hd_list_get) tl_list_get) is_cons) is_empty) tl_list_get) hd_list_get) is_empty) failwith) "no matching") + + $ ./lambda_lift_runner.exe << EOF + > let is_empty x = x+1 + > let rec length xs = match xs with + > | [] -> 0 + > | _::tl -> 1 + length xs + > EOF + let lam_ll0 = (fun ( + ) x -> ((( + ) x) 1)) + let is_empty_ac0 = (lam_ll0 ( + )) + + let rec lam_ll1 = (fun is_empty is_cons hd_list_get tl_list_get ( + ) length failwith "no matching" xs -> if (is_empty xs) + then 0 + else if (is_cons xs) + then let _ = (hd_list_get xs) in + let tl = (tl_list_get xs) in + ((( + ) 1) (length xs)) + else (failwith "no matching")) + and length = ((((((((lam_ll1 is_empty) is_cons) hd_list_get) tl_list_get) ( + )) length) failwith) "no matching") + + $ ./lambda_lift_runner.exe << EOF + > let (a, b) = (5,6) + > EOF + let tmp_me0 = (5, 6) + let a = (tuple_get (tmp_me0, 0)) + let b = (tuple_get (tmp_me0, 1)) + + $ ./lambda_lift_runner.exe << EOF + > let fac n = + > let rec fack n k = + > if n<=1 then k 1 + > else fack (n - 1) ((fun k n m -> k (m * n)) k n) + > in + > fack n (fun x -> x) + > EOF + let lam_ll5 = (fun k_ac1 ( * ) n_ac2 m -> (k_ac1 ((( * ) m) n_ac2))) + let lam_ll4 = (fun k_ac1 ( * ) n_ac2 -> (((lam_ll5 k_ac1) ( * )) n_ac2)) + let lam_ll3 = (fun ( * ) k_ac1 -> ((lam_ll4 k_ac1) ( * ))) + let lam_ll2 = (fun ( <= ) n_ac0 fack ( - ) n_ac0 ( * ) n_ac0 k -> if ((( <= ) n_ac0) 1) + then (k 1) + else ((fack ((( - ) n_ac0) 1)) (((lam_ll3 ( * )) k) n_ac0))) + let lam_ll1 = (fun ( <= ) fack ( - ) ( * ) n_ac0 -> (((((((lam_ll2 ( <= )) n_ac0) fack) ( - )) n_ac0) ( * )) n_ac0)) + let lam_ll6 = (fun x -> x) + let lam_ll0 = (fun ( <= ) fack ( - ) ( * ) n -> let rec fack = ((((lam_ll1 ( <= )) fack) ( - )) ( * )) in + ((fack n) lam_ll6)) + let fac = ((((lam_ll0 ( <= )) fack) ( - )) ( * )) + + $ ./lambda_lift_runner.exe << EOF + > let f x = match x with + > | 1 -> 12 + > | 12 -> 12 + > | _ -> 325 + > EOF + let lam_ll0 = (fun (=) (=) failwith "no matching" x -> if (((=) x) 1) + then 12 + else if (((=) x) 12) + then 12 + else if true + then 325 + else (failwith "no matching")) + let f = ((((lam_ll0 (=)) (=)) failwith) "no matching") + + $ ./lambda_lift_runner.exe < manytests/typed/001fac.ml + let rec lam_ll0 = (fun ( <= ) ( * ) fac ( - ) n -> if ((( <= ) n) 1) + then 1 + else ((( * ) n) (fac ((( - ) n) 1)))) + and fac = ((((lam_ll0 ( <= )) ( * )) fac) ( - )) + + let main = let () = (print_int (fac 4)) in + 0 + + $ ./lambda_lift_runner.exe < manytests/typed/002fac.ml + let rec lam_ll2 = (fun k ( * ) n p -> (k ((( * ) p) n))) + and lam_ll1 = (fun ( = ) n fac_cps ( - ) n ( * ) n k -> if ((( = ) n) 1) + then (k 1) + else ((fac_cps ((( - ) n) 1)) (((lam_ll2 k) ( * )) n))) + and lam_ll0 = (fun ( = ) fac_cps ( - ) ( * ) n -> (((((((lam_ll1 ( = )) n) fac_cps) ( - )) n) ( * )) n)) + and fac_cps = ((((lam_ll0 ( = )) fac_cps) ( - )) ( * )) + + let lam_ll3 = (fun print_int_ac0 -> print_int_ac0) + let main = let () = (print_int ((fac_cps 4) lam_ll3)) in + 0 + + $ ./lambda_lift_runner.exe < manytests/typed/003fib.ml + let rec lam_ll2 = (fun ( = ) b ( - ) ( + ) a b fib_acc b n -> if ((( = ) n) 1) + then b + else let n1 = ((( - ) n) 1) in + let ab = ((( + ) a) b) in + (((fib_acc b) ab) n1)) + and lam_ll1 = (fun ( = ) ( - ) ( + ) a fib_acc b -> ((((((((lam_ll2 ( = )) b) ( - )) ( + )) a) b) fib_acc) b)) + and lam_ll0 = (fun ( = ) ( - ) ( + ) fib_acc a -> (((((lam_ll1 ( = )) ( - )) ( + )) a) fib_acc)) + and fib_acc = ((((lam_ll0 ( = )) ( - )) ( + )) fib_acc) + + let rec lam_ll3 = (fun ( < ) ( + ) fib ( - ) fib ( - ) n -> if ((( < ) n) 2) + then n + else ((( + ) (fib ((( - ) n) 1))) (fib ((( - ) n) 2)))) + and fib = ((((((lam_ll3 ( < )) ( + )) fib) ( - )) fib) ( - )) + + let main = let () = (print_int (((fib_acc 0) 1) 4)) in + let () = (print_int (fib 4)) in + 0 + + $ ./lambda_lift_runner.exe < manytests/typed/004manyargs.ml + let lam_ll0 = (fun ( = ) f -> if ((( = ) 1) 1) + then f + else f) + let wrap = (lam_ll0 ( = )) + + let lam_ll3 = (fun print_int a print_int b print_int c -> let a_ac0 = (print_int a) in + let b_ac1 = (print_int b) in + let c_ac2 = (print_int c) in + 0) + let lam_ll2 = (fun print_int a print_int print_int b -> (((((lam_ll3 print_int) a) print_int) b) print_int)) + let lam_ll1 = (fun print_int print_int print_int a -> ((((lam_ll2 print_int) a) print_int) print_int)) + let test3 = (((lam_ll1 print_int) print_int) print_int) + + let lam_ll13 = (fun ( + ) ( + ) ( + ) ( + ) ( + ) ( + ) ( + ) ( + ) ( + ) a b c d e f g h i j -> ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) a) b)) c)) d)) e)) f)) g)) h)) i)) j)) + let lam_ll12 = (fun ( + ) ( + ) ( + ) ( + ) ( + ) ( + ) ( + ) ( + ) ( + ) a b c d e f g h i -> ((((((((((((((((((lam_ll13 ( + )) ( + )) ( + )) ( + )) ( + )) ( + )) ( + )) ( + )) ( + )) a) b) c) d) e) f) g) h) i)) + let lam_ll11 = (fun ( + ) ( + ) ( + ) ( + ) ( + ) ( + ) ( + ) ( + ) ( + ) a b c d e f g h -> (((((((((((((((((lam_ll12 ( + )) ( + )) ( + )) ( + )) ( + )) ( + )) ( + )) ( + )) ( + )) a) b) c) d) e) f) g) h)) + let lam_ll10 = (fun ( + ) ( + ) ( + ) ( + ) ( + ) ( + ) ( + ) ( + ) ( + ) a b c d e f g -> ((((((((((((((((lam_ll11 ( + )) ( + )) ( + )) ( + )) ( + )) ( + )) ( + )) ( + )) ( + )) a) b) c) d) e) f) g)) + let lam_ll9 = (fun ( + ) ( + ) ( + ) ( + ) ( + ) ( + ) ( + ) ( + ) ( + ) a b c d e f -> (((((((((((((((lam_ll10 ( + )) ( + )) ( + )) ( + )) ( + )) ( + )) ( + )) ( + )) ( + )) a) b) c) d) e) f)) + let lam_ll8 = (fun ( + ) ( + ) ( + ) ( + ) ( + ) ( + ) ( + ) ( + ) ( + ) a b c d e -> ((((((((((((((lam_ll9 ( + )) ( + )) ( + )) ( + )) ( + )) ( + )) ( + )) ( + )) ( + )) a) b) c) d) e)) + let lam_ll7 = (fun ( + ) ( + ) ( + ) ( + ) ( + ) ( + ) ( + ) ( + ) ( + ) a b c d -> (((((((((((((lam_ll8 ( + )) ( + )) ( + )) ( + )) ( + )) ( + )) ( + )) ( + )) ( + )) a) b) c) d)) + let lam_ll6 = (fun ( + ) ( + ) ( + ) ( + ) ( + ) ( + ) ( + ) ( + ) ( + ) a b c -> ((((((((((((lam_ll7 ( + )) ( + )) ( + )) ( + )) ( + )) ( + )) ( + )) ( + )) ( + )) a) b) c)) + let lam_ll5 = (fun ( + ) ( + ) ( + ) ( + ) ( + ) ( + ) ( + ) ( + ) ( + ) a b -> (((((((((((lam_ll6 ( + )) ( + )) ( + )) ( + )) ( + )) ( + )) ( + )) ( + )) ( + )) a) b)) + let lam_ll4 = (fun ( + ) ( + ) ( + ) ( + ) ( + ) ( + ) ( + ) ( + ) ( + ) a -> ((((((((((lam_ll5 ( + )) ( + )) ( + )) ( + )) ( + )) ( + )) ( + )) ( + )) ( + )) a)) + let test10 = (((((((((lam_ll4 ( + )) ( + )) ( + )) ( + )) ( + )) ( + )) ( + )) ( + )) ( + )) + + let main = let rez = (((((((((((wrap test10) 1) 10) 100) 1000) 10000) 100000) 1000000) 10000000) 100000000) 1000000000) in + let () = (print_int rez) in + let temp2 = ((((wrap test3) 1) 10) 100) in + 0 + + $ ./lambda_lift_runner.exe < manytests/typed/005fix.ml + let rec lam_ll1 = (fun f fix f x -> ((f (fix f)) x)) + and lam_ll0 = (fun fix f -> (((lam_ll1 f) fix) f)) + and fix = (lam_ll0 fix) + + let lam_ll3 = (fun ( <= ) ( * ) self ( - ) n -> if ((( <= ) n) 1) + then 1 + else ((( * ) n) (self ((( - ) n) 1)))) + let lam_ll2 = (fun ( <= ) ( * ) ( - ) self -> ((((lam_ll3 ( <= )) ( * )) self) ( - ))) + let fac = (((lam_ll2 ( <= )) ( * )) ( - )) + + let main = let () = (print_int ((fix fac) 6)) in + 0 + + $ ./lambda_lift_runner.exe < manytests/typed/006partial.ml + let lam_ll1 = (fun ( + ) foo -> ((( + ) foo) 2)) + let lam_ll2 = (fun ( * ) foo -> ((( * ) foo) 10)) + let lam_ll0 = (fun ( + ) ( * ) b -> if b + then (lam_ll1 ( + )) + else (lam_ll2 ( * ))) + let foo = ((lam_ll0 ( + )) ( * )) + + let lam_ll3 = (fun foo foo foo foo x -> ((foo true) ((foo false) ((foo true) ((foo false) x))))) + let foo_ac0 = ((((lam_ll3 foo) foo) foo) foo) + + let main = let () = (print_int (foo_ac0 11)) in + 0 + + $ ./lambda_lift_runner.exe < manytests/typed/006partial2.ml + let lam_ll2 = (fun print_int a print_int b print_int ( + ) a ( * ) b c -> let () = (print_int a) in + let () = (print_int b) in + let () = (print_int c) in + ((( + ) a) ((( * ) b) c))) + let lam_ll1 = (fun print_int a print_int print_int ( + ) a ( * ) b -> (((((((((lam_ll2 print_int) a) print_int) b) print_int) ( + )) a) ( * )) b)) + let lam_ll0 = (fun print_int print_int print_int ( + ) ( * ) a -> (((((((lam_ll1 print_int) a) print_int) print_int) ( + )) a) ( * ))) + let foo = (((((lam_ll0 print_int) print_int) print_int) ( + )) ( * )) + + let main = let foo_ac0 = (foo 1) in + let foo_ac1 = (foo_ac0 2) in + let foo_ac2 = (foo_ac1 3) in + let () = (print_int foo_ac2) in + 0 + $ ./lambda_lift_runner.exe < manytests/typed/006partial3.ml + let lam_ll2 = (fun print_int c -> (print_int c)) + let lam_ll1 = (fun print_int print_int b -> let () = (print_int b) in + (lam_ll2 print_int)) + let lam_ll0 = (fun print_int print_int print_int a -> let () = (print_int a) in + ((lam_ll1 print_int) print_int)) + let foo = (((lam_ll0 print_int) print_int) print_int) + + let main = let () = (((foo 4) 8) 9) in + 0 + $ ./lambda_lift_runner.exe < manytests/typed/007order.ml + let lam_ll8 = (fun print_int ( + ) a b print_int ( + ) ( / ) ( * ) a b _c d __ -> let () = (print_int ((( + ) a) b)) in + let () = (print_int __) in + ((( + ) ((( / ) ((( * ) a) b)) _c)) d)) + let lam_ll7 = (fun print_int ( + ) a b print_int ( + ) ( / ) ( * ) a b _c d -> ((((((((((((lam_ll8 print_int) ( + )) a) b) print_int) ( + )) ( / )) ( * )) a) b) _c) d)) + let lam_ll6 = (fun print_int ( + ) a b print_int ( + ) ( / ) ( * ) a b _c () -> (((((((((((lam_ll7 print_int) ( + )) a) b) print_int) ( + )) ( / )) ( * )) a) b) _c)) + let lam_ll5 = (fun print_int ( + ) a b print_int ( + ) ( / ) ( * ) a b _c -> (((((((((((lam_ll6 print_int) ( + )) a) b) print_int) ( + )) ( / )) ( * )) a) b) _c)) + let lam_ll4 = (fun print_int ( + ) a print_int ( + ) ( / ) ( * ) a b -> ((((((((((lam_ll5 print_int) ( + )) a) b) print_int) ( + )) ( / )) ( * )) a) b)) + let lam_ll3 = (fun print_int ( + ) a print_int ( + ) ( / ) ( * ) a () -> ((((((((lam_ll4 print_int) ( + )) a) print_int) ( + )) ( / )) ( * )) a)) + let lam_ll2 = (fun print_int ( + ) print_int ( + ) ( / ) ( * ) a -> ((((((((lam_ll3 print_int) ( + )) a) print_int) ( + )) ( / )) ( * )) a)) + let lam_ll1 = (fun print_int ( + ) print_int ( + ) ( / ) ( * ) () -> ((((((lam_ll2 print_int) ( + )) print_int) ( + )) ( / )) ( * ))) + let lam_ll0 = (fun print_int ( + ) print_int ( + ) ( / ) ( * ) () -> ((((((lam_ll1 print_int) ( + )) print_int) ( + )) ( / )) ( * ))) + let _start = ((((((lam_ll0 print_int) ( + )) print_int) ( + )) ( / )) ( * )) + + let main = (print_int (((((((((_start (print_int 1)) (print_int 2)) 3) (print_int 4)) 100) 1000) (print_int (( ~- ) 1))) 10000) (( ~- ) 555555))) + $ ./lambda_lift_runner.exe < manytests/typed/008ascription.ml + let lam_ll2 = (fun f g x -> ((f x) (g x))) + let lam_ll1 = (fun f g -> ((lam_ll2 f) g)) + let lam_ll0 = (fun f -> (lam_ll1 f)) + let addi = lam_ll0 + + let lam_ll4 = (fun ( + ) x ( * ) x b -> if b + then ((( + ) x) 1) + else ((( * ) x) 2)) + let lam_ll3 = (fun ( + ) ( * ) x -> ((((lam_ll4 ( + )) x) ( * )) x)) + let lam_ll5 = (fun ( = ) ( / ) _start -> ((( = ) ((( / ) _start) 2)) 0)) + let main = let () = (print_int (((addi ((lam_ll3 ( + )) ( * ))) ((lam_ll5 ( = )) ( / ))) 4)) in + 0 + + $ ./lambda_lift_runner.exe < manytests/typed/009let_poly.ml + let lam_ll0 = (fun x -> x) + let temp = let f = lam_ll0 in + ((f 1), (f true)) + + $ ./lambda_lift_runner.exe < manytests/typed/011mapcps.ml + let rec lam_ll3 = (fun k f h tl_ac0 -> (k ((f h)::tl_ac0))) + and lam_ll2 = (fun is_empty xs is_cons xs hd_list_get xs tl_list_get xs map f f failwith "no matching" k -> if (is_empty xs) + then (k []) + else if (is_cons xs) + then let h = (hd_list_get xs) in + let tl = (tl_list_get xs) in + (((map f) tl) (((lam_ll3 k) f) h)) + else (failwith "no matching")) + and lam_ll1 = (fun is_empty is_cons hd_list_get tl_list_get map f f failwith "no matching" xs -> (((((((((((((lam_ll2 is_empty) xs) is_cons) xs) hd_list_get) xs) tl_list_get) xs) map) f) f) failwith) "no matching")) + and lam_ll0 = (fun is_empty is_cons hd_list_get tl_list_get map failwith "no matching" f -> (((((((((lam_ll1 is_empty) is_cons) hd_list_get) tl_list_get) map) f) f) failwith) "no matching")) + and map = (((((((lam_ll0 is_empty) is_cons) hd_list_get) tl_list_get) map) failwith) "no matching") + + let rec lam_ll5 = (fun is_empty is_cons hd_list_get tl_list_get f iter f failwith "no matching" xs -> if (is_empty xs) + then () + else if (is_cons xs) + then let h = (hd_list_get xs) in + let tl = (tl_list_get xs) in + let w = (f h) in + ((iter f) tl) + else (failwith "no matching")) + and lam_ll4 = (fun is_empty is_cons hd_list_get tl_list_get iter failwith "no matching" f -> (((((((((lam_ll5 is_empty) is_cons) hd_list_get) tl_list_get) f) iter) f) failwith) "no matching")) + and iter = (((((((lam_ll4 is_empty) is_cons) hd_list_get) tl_list_get) iter) failwith) "no matching") + + let lam_ll6 = (fun ( + ) x -> ((( + ) x) 1)) + let lam_ll7 = (fun x -> x) + let main = ((iter print_int) (((map (lam_ll6 ( + ))) (1::(2::(3::[])))) lam_ll7)) + $ ./lambda_lift_runner.exe < manytests/typed/012fibcps.ml + let rec lam_ll3 = (fun k ( + ) a b -> (k ((( + ) a) b))) + and lam_ll2 = (fun fib ( - ) n k ( + ) a -> ((fib ((( - ) n) 2)) (((lam_ll3 k) ( + )) a))) + and lam_ll1 = (fun ( < ) n n fib ( - ) n fib ( - ) n ( + ) k -> if ((( < ) n) 2) + then (k n) + else ((fib ((( - ) n) 1)) (((((lam_ll2 fib) ( - )) n) k) ( + )))) + and lam_ll0 = (fun ( < ) fib ( - ) fib ( - ) ( + ) n -> ((((((((((lam_ll1 ( < )) n) n) fib) ( - )) n) fib) ( - )) n) ( + ))) + and fib = ((((((lam_ll0 ( < )) fib) ( - )) fib) ( - )) ( + )) + + let lam_ll4 = (fun x -> x) + let main = (print_int ((fib 6) lam_ll4)) + $ ./lambda_lift_runner.exe < manytests/typed/013foldfoldr.ml + let lam_ll0 = (fun x -> x) + let id = lam_ll0 + + let rec lam_ll3 = (fun is_empty acc is_cons hd_list_get tl_list_get f fold_right f acc failwith "no matching" xs -> if (is_empty xs) + then acc + else if (is_cons xs) + then let h = (hd_list_get xs) in + let tl = (tl_list_get xs) in + ((f h) (((fold_right f) acc) tl)) + else (failwith "no matching")) + and lam_ll2 = (fun is_empty is_cons hd_list_get tl_list_get f fold_right f failwith "no matching" acc -> (((((((((((lam_ll3 is_empty) acc) is_cons) hd_list_get) tl_list_get) f) fold_right) f) acc) failwith) "no matching")) + and lam_ll1 = (fun is_empty is_cons hd_list_get tl_list_get fold_right failwith "no matching" f -> (((((((((lam_ll2 is_empty) is_cons) hd_list_get) tl_list_get) f) fold_right) f) failwith) "no matching")) + and fold_right = (((((((lam_ll1 is_empty) is_cons) hd_list_get) tl_list_get) fold_right) failwith) "no matching") + + let lam_ll9 = (fun g f b x -> (g ((f x) b))) + let lam_ll8 = (fun f b g -> (((lam_ll9 g) f) b)) + let lam_ll7 = (fun f b -> ((lam_ll8 f) b)) + let lam_ll6 = (fun fold_right f id a bs -> ((((fold_right (lam_ll7 f)) id) bs) a)) + let lam_ll5 = (fun fold_right f id a -> ((((lam_ll6 fold_right) f) id) a)) + let lam_ll4 = (fun fold_right id f -> (((lam_ll5 fold_right) f) id)) + let foldl = ((lam_ll4 fold_right) id) + + let lam_ll11 = (fun ( * ) x y -> ((( * ) x) y)) + let lam_ll10 = (fun ( * ) x -> ((lam_ll11 ( * )) x)) + let main = (print_int (((foldl (lam_ll10 ( * ))) 1) (1::(2::(3::[]))))) + + $ ./lambda_lift_runner.exe < manytests/typed/015tuples.ml + let rec lam_ll1 = (fun f fix f x -> ((f (fix f)) x)) + and lam_ll0 = (fun fix f -> (((lam_ll1 f) fix) f)) + and fix = (lam_ll0 fix) + + let lam_ll3 = (fun tuple_get tuple_get f f p -> let a = ((tuple_get p) 0) in + let b = ((tuple_get p) 1) in + ((f a), (f b))) + let lam_ll2 = (fun tuple_get tuple_get f -> ((((lam_ll3 tuple_get) tuple_get) f) f)) + let map = ((lam_ll2 tuple_get) tuple_get) + + let lam_ll8 = (fun li self l_ac0 x -> ((li (self l_ac0)) x)) + let lam_ll7 = (fun self l_ac0 li -> (((lam_ll8 li) self) l_ac0)) + let lam_ll6 = (fun map self l_ac0 -> ((map ((lam_ll7 self) l_ac0)) l_ac0)) + let lam_ll5 = (fun map self -> ((lam_ll6 map) self)) + let lam_ll4 = (fun fix map l -> ((fix (lam_ll5 map)) l)) + let fixpoly = ((lam_ll4 fix) map) + + let lam_ll10 = (fun tuple_get p tuple_get p ( = ) ( - ) n -> let e = ((tuple_get p) 0) in + let o = ((tuple_get p) 1) in + if ((( = ) n) 0) + then 1 + else (o ((( - ) n) 1))) + let lam_ll9 = (fun tuple_get tuple_get ( = ) ( - ) p -> ((((((lam_ll10 tuple_get) p) tuple_get) p) ( = )) ( - ))) + let feven = ((((lam_ll9 tuple_get) tuple_get) ( = )) ( - )) + + let lam_ll12 = (fun tuple_get p tuple_get p ( = ) ( - ) n -> let e = ((tuple_get p) 0) in + let o = ((tuple_get p) 1) in + if ((( = ) n) 0) + then 0 + else (e ((( - ) n) 1))) + let lam_ll11 = (fun tuple_get tuple_get ( = ) ( - ) p -> ((((((lam_ll12 tuple_get) p) tuple_get) p) ( = )) ( - ))) + let fodd = ((((lam_ll11 tuple_get) tuple_get) ( = )) ( - )) + + let tie = (fixpoly (feven, fodd)) + + let rec lam_ll13 = (fun ( = ) modd ( - ) n -> if ((( = ) n) 0) + then 1 + else (modd ((( - ) n) 1))) + and meven = (((lam_ll13 ( = )) modd) ( - )) + and lam_ll14 = (fun ( = ) meven ( - ) n -> if ((( = ) n) 0) + then 1 + else (meven ((( - ) n) 1))) + and modd = (((lam_ll14 ( = )) meven) ( - )) + + let main = let () = (print_int (modd 1)) in + let () = (print_int (meven 2)) in + let even = ((tuple_get tie) 0) in + let odd = ((tuple_get tie) 1) in + let () = (print_int (odd 3)) in + let () = (print_int (even 4)) in + 0 + + $ ./lambda_lift_runner.exe < manytests/typed/016lists.ml + let rec lam_ll0 = (fun is_empty is_cons hd_list_get tl_list_get ( + ) length failwith "no matching" xs -> if (is_empty xs) + then 0 + else if (is_cons xs) + then let h = (hd_list_get xs) in + let tl = (tl_list_get xs) in + ((( + ) 1) (length tl)) + else (failwith "no matching")) + and length = ((((((((lam_ll0 is_empty) is_cons) hd_list_get) tl_list_get) ( + )) length) failwith) "no matching") + + let lam_ll2 = (fun is_empty acc is_cons hd_list_get tl_list_get helper ( + ) acc failwith "no matching" xs -> if (is_empty xs) + then acc + else if (is_cons xs) + then let h = (hd_list_get xs) in + let tl = (tl_list_get xs) in + ((helper ((( + ) acc) 1)) tl) + else (failwith "no matching")) + let lam_ll1 = (fun is_empty is_cons hd_list_get tl_list_get helper ( + ) failwith "no matching" acc -> ((((((((((lam_ll2 is_empty) acc) is_cons) hd_list_get) tl_list_get) helper) ( + )) acc) failwith) "no matching")) + let length_tail = let rec helper = ((((((((lam_ll1 is_empty) is_cons) hd_list_get) tl_list_get) helper) ( + )) failwith) "no matching") in + (helper 0) + + let rec lam_ll4 = (fun is_empty is_cons is_empty tl_list_get hd_list_get f is_cons is_cons tl_list_get is_empty tl_list_get tl_list_get hd_list_get hd_list_get tl_list_get f f is_cons is_cons tl_list_get is_cons tl_list_get tl_list_get is_empty tl_list_get tl_list_get tl_list_get hd_list_get hd_list_get tl_list_get hd_list_get tl_list_get tl_list_get f f f is_cons is_cons tl_list_get is_cons tl_list_get tl_list_get is_cons tl_list_get tl_list_get tl_list_get hd_list_get hd_list_get tl_list_get hd_list_get tl_list_get tl_list_get hd_list_get tl_list_get tl_list_get tl_list_get tl_list_get tl_list_get tl_list_get tl_list_get f f f f map f failwith "no matching" xs -> if (is_empty xs) + then [] + else if if (is_cons xs) + then (is_empty (tl_list_get xs)) + else false + then let a = (hd_list_get xs) in + ((f a)::[]) + else if if (is_cons xs) + then if (is_cons (tl_list_get xs)) + then (is_empty (tl_list_get (tl_list_get xs))) + else false + else false + then let a = (hd_list_get xs) in + let b = (hd_list_get (tl_list_get xs)) in + ((f a)::((f b)::[])) + else if if (is_cons xs) + then if (is_cons (tl_list_get xs)) + then if (is_cons (tl_list_get (tl_list_get xs))) + then (is_empty (tl_list_get (tl_list_get (tl_list_get xs)))) + else false + else false + else false + then let a = (hd_list_get xs) in + let b = (hd_list_get (tl_list_get xs)) in + let c = (hd_list_get (tl_list_get (tl_list_get xs))) in + ((f a)::((f b)::((f c)::[]))) + else if if (is_cons xs) + then if (is_cons (tl_list_get xs)) + then if (is_cons (tl_list_get (tl_list_get xs))) + then (is_cons (tl_list_get (tl_list_get (tl_list_get xs)))) + else false + else false + else false + then let a = (hd_list_get xs) in + let b = (hd_list_get (tl_list_get xs)) in + let c = (hd_list_get (tl_list_get (tl_list_get xs))) in + let d = (hd_list_get (tl_list_get (tl_list_get (tl_list_get xs)))) in + let tl = (tl_list_get (tl_list_get (tl_list_get (tl_list_get xs)))) in + ((f a)::((f b)::((f c)::((f d)::((map f) tl))))) + else (failwith "no matching")) + and lam_ll3 = (fun is_empty is_cons is_empty tl_list_get hd_list_get is_cons is_cons tl_list_get is_empty tl_list_get tl_list_get hd_list_get hd_list_get tl_list_get is_cons is_cons tl_list_get is_cons tl_list_get tl_list_get is_empty tl_list_get tl_list_get tl_list_get hd_list_get hd_list_get tl_list_get hd_list_get tl_list_get tl_list_get is_cons is_cons tl_list_get is_cons tl_list_get tl_list_get is_cons tl_list_get tl_list_get tl_list_get hd_list_get hd_list_get tl_list_get hd_list_get tl_list_get tl_list_get hd_list_get tl_list_get tl_list_get tl_list_get tl_list_get tl_list_get tl_list_get tl_list_get map failwith "no matching" f -> ((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((lam_ll4 is_empty) is_cons) is_empty) tl_list_get) hd_list_get) f) is_cons) is_cons) tl_list_get) is_empty) tl_list_get) tl_list_get) hd_list_get) hd_list_get) tl_list_get) f) f) is_cons) is_cons) tl_list_get) is_cons) tl_list_get) tl_list_get) is_empty) tl_list_get) tl_list_get) tl_list_get) hd_list_get) hd_list_get) tl_list_get) hd_list_get) tl_list_get) tl_list_get) f) f) f) is_cons) is_cons) tl_list_get) is_cons) tl_list_get) tl_list_get) is_cons) tl_list_get) tl_list_get) tl_list_get) hd_list_get) hd_list_get) tl_list_get) hd_list_get) tl_list_get) tl_list_get) hd_list_get) tl_list_get) tl_list_get) tl_list_get) tl_list_get) tl_list_get) tl_list_get) tl_list_get) f) f) f) f) map) f) failwith) "no matching")) + and map = (((((((((((((((((((((((((((((((((((((((((((((((((((((((((lam_ll3 is_empty) is_cons) is_empty) tl_list_get) hd_list_get) is_cons) is_cons) tl_list_get) is_empty) tl_list_get) tl_list_get) hd_list_get) hd_list_get) tl_list_get) is_cons) is_cons) tl_list_get) is_cons) tl_list_get) tl_list_get) is_empty) tl_list_get) tl_list_get) tl_list_get) hd_list_get) hd_list_get) tl_list_get) hd_list_get) tl_list_get) tl_list_get) is_cons) is_cons) tl_list_get) is_cons) tl_list_get) tl_list_get) is_cons) tl_list_get) tl_list_get) tl_list_get) hd_list_get) hd_list_get) tl_list_get) hd_list_get) tl_list_get) tl_list_get) hd_list_get) tl_list_get) tl_list_get) tl_list_get) tl_list_get) tl_list_get) tl_list_get) tl_list_get) map) failwith) "no matching") + + let rec lam_ll6 = (fun is_empty xs is_cons xs hd_list_get xs tl_list_get xs append failwith "no matching" ys -> if (is_empty xs) + then ys + else if (is_cons xs) + then let x = (hd_list_get xs) in + let xs_ac0 = (tl_list_get xs) in + (x::((append xs_ac0) ys)) + else (failwith "no matching")) + and lam_ll5 = (fun is_empty is_cons hd_list_get tl_list_get append failwith "no matching" xs -> (((((((((((lam_ll6 is_empty) xs) is_cons) xs) hd_list_get) xs) tl_list_get) xs) append) failwith) "no matching")) + and append = (((((((lam_ll5 is_empty) is_cons) hd_list_get) tl_list_get) append) failwith) "no matching") + + let lam_ll7 = (fun is_empty is_cons hd_list_get tl_list_get append helper failwith "no matching" xs -> if (is_empty xs) + then [] + else if (is_cons xs) + then let h = (hd_list_get xs) in + let tl = (tl_list_get xs) in + ((append h) (helper tl)) + else (failwith "no matching")) + let concat = let rec helper = ((((((((lam_ll7 is_empty) is_cons) hd_list_get) tl_list_get) append) helper) failwith) "no matching") in + helper + + let rec lam_ll9 = (fun is_empty is_cons hd_list_get tl_list_get f iter f failwith "no matching" xs -> if (is_empty xs) + then () + else if (is_cons xs) + then let h = (hd_list_get xs) in + let tl = (tl_list_get xs) in + let () = (f h) in + ((iter f) tl) + else (failwith "no matching")) + and lam_ll8 = (fun is_empty is_cons hd_list_get tl_list_get iter failwith "no matching" f -> (((((((((lam_ll9 is_empty) is_cons) hd_list_get) tl_list_get) f) iter) f) failwith) "no matching")) + and iter = (((((((lam_ll8 is_empty) is_cons) hd_list_get) tl_list_get) iter) failwith) "no matching") + + let rec lam_ll12 = (fun h a -> (h, a)) + and lam_ll11 = (fun is_empty xs is_cons xs hd_list_get xs tl_list_get xs append map cartesian failwith "no matching" ys -> if (is_empty xs) + then [] + else if (is_cons xs) + then let h = (hd_list_get xs) in + let tl = (tl_list_get xs) in + ((append ((map (lam_ll12 h)) ys)) ((cartesian tl) ys)) + else (failwith "no matching")) + and lam_ll10 = (fun is_empty is_cons hd_list_get tl_list_get append map cartesian failwith "no matching" xs -> (((((((((((((lam_ll11 is_empty) xs) is_cons) xs) hd_list_get) xs) tl_list_get) xs) append) map) cartesian) failwith) "no matching")) + and cartesian = (((((((((lam_ll10 is_empty) is_cons) hd_list_get) tl_list_get) append) map) cartesian) failwith) "no matching") + + let main = let () = ((iter print_int) (1::(2::(3::[])))) in + let () = (print_int (length ((cartesian (1::(2::[]))) (1::(2::(3::(4::[]))))))) in + 0 + + $ ./lambda_lift_runner.exe < manytests/do_not_type/001.ml + Infer error: + $ ./lambda_lift_runner.exe < manytests/do_not_type/002if.ml + Infer error: + $ ./lambda_lift_runner.exe < manytests/do_not_type/003occurs.ml + Infer error: + + $ ./lambda_lift_runner.exe < manytests/do_not_type/004let_poly.ml + Infer error: + + $ ./lambda_lift_runner.exe < manytests/do_not_type/015tuples.ml + Infer error: + diff --git a/FML/tests/lambda_lift_runner.ml b/FML/tests/lambda_lift_runner.ml new file mode 100644 index 000000000..b72a14f65 --- /dev/null +++ b/FML/tests/lambda_lift_runner.ml @@ -0,0 +1,29 @@ +(** Copyright 2024-2025, Dmitry Pilyuk, Aleksandr Rozhkov *) + +(** SPDX-License-Identifier: LGPL-2.1 *) + +open Fml_lib.Parser +open Fml_lib.Inferencer +open Fml_lib.A_conv +open Fml_lib.Match_elimination +open Fml_lib.Lambda_lift +open Fml_lib.Me_ast + +let () = + let input = Stdio.In_channel.input_all Stdlib.stdin in + let parse_and_infer input = + match parse input with + | Ok parsed -> + (match run_program_inferencer parsed with + | Ok _ -> Ok parsed + | Error _ -> Error (Format.asprintf "Infer error:")) + | Error e -> Error (Format.sprintf "Parsing error: %s" e) + in + match parse_and_infer input with + | Ok ast -> + let ast = ac_program ast in + let ast_me = match_elimination ast in + let ast_ll = lambda_lift ast_me in + Format.printf "%a\n" pp_me_program ast_ll + | Error message -> Format.printf "%s" message +;; From aafbf94922d044f0dc3666b0cf9d92cf0ac91146 Mon Sep 17 00:00:00 2001 From: RozhkovAleksandr Date: Wed, 9 Apr 2025 11:49:18 +0300 Subject: [PATCH 63/92] delete old --- FML/bin/dune | 43 -- FML/lib/anf/alpha_conv.ml | 112 ---- FML/lib/anf/alpha_conv.mli | 8 - FML/lib/anf/anf.ml | 133 ----- FML/lib/anf/closure_conv.ml | 163 ------ FML/lib/anf/closure_conv.mli | 7 - FML/lib/anf/common.ml | 9 - FML/lib/anf/lambda_lifting.ml | 98 ---- FML/lib/anf/lambda_lifting.mli | 8 - FML/lib/anf/pattern_elim.ml | 309 ----------- FML/lib/anf/pattern_elim.mli | 9 - FML/lib/anf/pe_ast.ml | 96 ---- FML/lib/anf/pe_ast.mli | 34 -- FML/lib/dune | 10 +- FML/tests/alpha_conv_manytest.t | 297 ----------- FML/tests/alpha_conv_runner.ml | 27 - FML/tests/anf_manytests.t | 705 ------------------------- FML/tests/anf_runner.ml | 39 -- FML/tests/closure_conv_manytest.t | 287 ---------- FML/tests/closure_conv_runner.ml | 29 - FML/tests/dune | 28 - FML/tests/lambda_lifting_manytests.t | 333 ------------ FML/tests/lambda_lifting_runner.ml | 31 -- FML/tests/match_elimination_manytest.t | 6 + FML/tests/pe_manytests.t | 292 ---------- FML/tests/pe_runner.ml | 25 - 26 files changed, 7 insertions(+), 3131 deletions(-) delete mode 100644 FML/lib/anf/alpha_conv.ml delete mode 100644 FML/lib/anf/alpha_conv.mli delete mode 100644 FML/lib/anf/anf.ml delete mode 100644 FML/lib/anf/closure_conv.ml delete mode 100644 FML/lib/anf/closure_conv.mli delete mode 100644 FML/lib/anf/lambda_lifting.ml delete mode 100644 FML/lib/anf/lambda_lifting.mli delete mode 100644 FML/lib/anf/pattern_elim.ml delete mode 100644 FML/lib/anf/pattern_elim.mli delete mode 100644 FML/lib/anf/pe_ast.ml delete mode 100644 FML/lib/anf/pe_ast.mli delete mode 100644 FML/tests/alpha_conv_manytest.t delete mode 100644 FML/tests/alpha_conv_runner.ml delete mode 100644 FML/tests/anf_manytests.t delete mode 100644 FML/tests/anf_runner.ml delete mode 100644 FML/tests/closure_conv_manytest.t delete mode 100644 FML/tests/closure_conv_runner.ml delete mode 100644 FML/tests/lambda_lifting_manytests.t delete mode 100644 FML/tests/lambda_lifting_runner.ml delete mode 100644 FML/tests/pe_manytests.t delete mode 100644 FML/tests/pe_runner.ml diff --git a/FML/bin/dune b/FML/bin/dune index c2a65ab9d..e69de29bb 100644 --- a/FML/bin/dune +++ b/FML/bin/dune @@ -1,43 +0,0 @@ -(executable - (name compiler) - (public_name compiler) - (modules compiler) - (libraries fml_lib stdio)) - -(cram - (applies_to bitecode) - (deps - ./compiler.exe - manytests/typed/001fac.ml - manytests/typed/002fac.ml - manytests/typed/003fib.ml - manytests/typed/004manyargs.ml - manytests/typed/005fix.ml - manytests/typed/006partial.ml - manytests/typed/006partial2.ml - manytests/typed/006partial3.ml - manytests/typed/007order.ml - manytests/typed/008ascription.ml - manytests/typed/009let_poly.ml - manytests/typed/015tuples.ml - manytests/typed/016lists.ml)) - -(cram - (applies_to llvm_exec) - (deps - runtime.c - ./compiler.exe - manytests/typed/001fac.ml - manytests/typed/002fac.ml - manytests/typed/003fib.ml - manytests/typed/004manyargs.ml - manytests/typed/005fix.ml - manytests/typed/006partial.ml - manytests/typed/006partial2.ml - manytests/typed/006partial3.ml - manytests/typed/007order.ml - manytests/typed/008ascription.ml - manytests/typed/009let_poly.ml - manytests/typed/012fibcps.ml - manytests/typed/015tuples.ml - manytests/typed/016lists.ml)) diff --git a/FML/lib/anf/alpha_conv.ml b/FML/lib/anf/alpha_conv.ml deleted file mode 100644 index 2a38ebf79..000000000 --- a/FML/lib/anf/alpha_conv.ml +++ /dev/null @@ -1,112 +0,0 @@ -(** Copyright 2024-2025, Dmitry Pilyuk, Aleksandr Rozhkov *) - -(** SPDX-License-Identifier: LGPL-2.1 *) - -open Base -open Pe_ast -open Common -open Common.MonadCounter -open Common.StrSet - -let rec ac_expr env bindings = function - | Pe_EUnit -> return Pe_EUnit - | Pe_ENill -> return Pe_ENill - | Pe_EConst _ as c -> return c - | Pe_EIdentifier x as v -> - (match StrMap.find bindings x with - | Some x -> return @@ Pe_EIdentifier x - | None -> return v) - | Pe_ECons (h, t) -> - let* h = ac_expr env bindings h in - let* t = ac_expr env bindings t in - return @@ Pe_ECons (h, t) - | Pe_EApp (e1, e2) -> - let* e1 = ac_expr env bindings e1 in - let* e2 = ac_expr env bindings e2 in - return @@ Pe_EApp (e1, e2) - | Pe_EIf (e1, e2, e3) -> - let* e1 = ac_expr env bindings e1 in - let* e2 = ac_expr env bindings e2 in - let* e3 = ac_expr env bindings e3 in - return @@ Pe_EIf (e1, e2, e3) - | Pe_EFun (args, body) -> - let* args, env, bindings = - fold_left - args - ~init:(return ([], env, bindings)) - ~f:(fun (names, env, bindings) name -> - let* env, bindings, name = rename env bindings name in - return (name :: names, env, bindings)) - in - let args = List.rev args in - let* body = ac_expr env bindings body in - return @@ Pe_EFun (args, body) - | Pe_ETuple el -> - let* e_list = map el ~f:(ac_expr env bindings) in - return @@ Pe_ETuple e_list - | Pe_ELet (rec_flag, name, e1, e2) -> - let* new_e1 = ac_expr env bindings e1 in - let* env, bindings, new_name = rename env bindings name in - let* new_e2 = ac_expr env bindings e2 in - return @@ Pe_ELet (rec_flag, new_name, new_e1, new_e2) - -and rename env binds name = - if String.equal name "()" - then return (env, binds, "()") - else if find env name - then - let* fresh = fresh in - let id = get_id fresh in - return (add env id, StrMap.update binds name ~f:(fun _ -> id), id) - else return (add env name, binds, name) -;; - -let ac_declaration env bindings = function - | Pe_Nonrec bindings_list -> - let* decls, env, bindings = - List.fold_left - bindings_list - ~init:(return ([], env, bindings)) - ~f:(fun acc (name, expr) -> - let* acc_decls, acc_env, acc_bindings = acc in - let* new_env, new_bindings, new_name = rename acc_env acc_bindings name in - let* e = ac_expr env bindings expr in - return ((new_name, e) :: acc_decls, new_env, new_bindings)) - in - return (env, bindings, Pe_Nonrec (List.rev decls)) - | Pe_Rec bindings_list -> - let ids, exps = List.unzip bindings_list in - let* ids, env, bindings = - fold_left - ids - ~init:(return ([], env, bindings)) - ~f:(fun (ids, env, bindings) id -> - let* env, bindings, id = rename env bindings id in - return (id :: ids, env, bindings)) - in - let ids = List.rev ids in - let exps = List.map exps ~f:(ac_expr env bindings) in - let* bindings_list = - List.fold2_exn ids exps ~init:(return []) ~f:(fun acc name expr -> - let* acc = acc in - let* expr = expr in - return ((name, expr) :: acc)) - in - let bindings_list = List.rev bindings_list in - return (env, bindings, Pe_Rec bindings_list) -;; - -let ac_program program env = - let rec helper env bindings = function - | [] -> return [] - | hd :: tl -> - let* env, bindings, ast = ac_declaration env bindings hd in - let* rest = helper env bindings tl in - return (ast :: rest) - in - helper env (Map.empty (module String)) program -;; - -let run_alpha_conv bindings init prog = - run (ac_program prog (of_list builtins)) bindings init -;; diff --git a/FML/lib/anf/alpha_conv.mli b/FML/lib/anf/alpha_conv.mli deleted file mode 100644 index 6384603c4..000000000 --- a/FML/lib/anf/alpha_conv.mli +++ /dev/null @@ -1,8 +0,0 @@ -(** Copyright 2024-2025, Dmitry Pilyuk, Aleksandr Rozhkov *) - -(** SPDX-License-Identifier: LGPL-2.1 *) - -open Pe_ast -open Common - -val run_alpha_conv : bindings -> int -> pe_program -> bindings * int * pe_program diff --git a/FML/lib/anf/anf.ml b/FML/lib/anf/anf.ml deleted file mode 100644 index abab2b188..000000000 --- a/FML/lib/anf/anf.ml +++ /dev/null @@ -1,133 +0,0 @@ -(** Copyright 2024-2025, Dmitry Pilyuk, Aleksandr Rozhkov *) - -(** SPDX-License-Identifier: LGPL-2.1 *) - -open Common -open Anf_ast -open Pe_ast -open Base -open Common.MonadCounter - -let cexp_app e e_list = CEApply (e, e_list) -let cexp_ite i t e = CEIf (i, t, e) -let cexp_cons aexp1 aexp2 = CECons (aexp1, aexp2) -let aexpr_let_in name cexp exp = ALetIn (name, cexp, exp) -let aexpr_complex cexp = ACExpr cexp -let imm_int int_ = ImmInt int_ -let imm_bool bool_ = ImmBool bool_ -let imm_var var_ = ImmIdentifier var_ -let imm_tuple lst_ = ImmTuple lst_ - -let const_to_immexp = function - | Pe_Cint i -> ImmInt i - | Pe_CBool b -> ImmBool b -;; - -let rec to_immexp = function - | Pe_EIdentifier v -> return ([], imm_var v) - | Pe_EConst c -> return ([], const_to_immexp c) - | Pe_EUnit -> return ([], ImmUnit) - | Pe_ENill -> return ([], ImmNill) - | e -> - let* fresh = fresh >>| get_id in - let* binds1, e = to_cexp e in - return (binds1 @ [ fresh, e ], imm_var fresh) - -and to_cexp = function - | Pe_EUnit -> return ([], cimmexpr @@ ImmUnit) - | Pe_ENill -> return ([], cimmexpr @@ ImmNill) - | Pe_EConst c -> return ([], cimmexpr @@ const_to_immexp c) - | Pe_EIdentifier v -> return ([], cimmexpr @@ imm_var v) - | Pe_EApp (e1, e2) -> app_to_cexp e1 e2 - | Pe_ELet (NoRec, name, e1, e2) -> - let* binds1, e1 = to_cexp e1 in - let* binds2, e2 = to_cexp e2 in - return (binds1 @ [ name, e1 ] @ binds2, e2) - | Pe_EIf (e1, e2, e3) -> - let* binds, e1 = to_immexp e1 in - let* e2 = to_exp e2 in - let* e3 = to_exp e3 in - return (binds, cexp_ite e1 e2 e3) - | Pe_ETuple e_list -> - let* binds, e_list = map e_list ~f:to_immexp >>| List.unzip in - return (List.concat binds, cimmexpr @@ imm_tuple e_list) - | Pe_ECons (e1, e2) -> - let* binds1, e1 = to_immexp e1 in - let* binds2, e2 = to_immexp e2 in - return (binds1 @ binds2, cexp_cons e1 e2) - | _ -> return ([], cimmexpr @@ ImmUnit) - -and app_to_cexp e1 e2 = - let rec helper = function - | Pe_EApp (e1, e2) -> - let f, args_e = helper e1 in - f, e2 :: args_e - | e -> e, [] - in - let to_app, args_e = helper @@ Pe_EApp (e1, e2) in - let args_e = List.rev args_e in - let f1 acc expr = - let cur_exprs, cur_binds = acc in - match expr with - | Pe_EIdentifier v -> return (imm_var v :: cur_exprs, cur_binds) - | Pe_EConst c -> return (const_to_immexp c :: cur_exprs, cur_binds) - | _ -> - let* fresh = fresh >>| get_id in - let* new_binds, f_cexp = to_cexp expr in - return (imm_var fresh :: cur_exprs, new_binds @ [ fresh, f_cexp ] @ cur_binds) - in - let* exprs, binds = fold_left (to_app :: args_e) ~init:(return ([], [])) ~f:f1 in - let exprs = List.rev exprs in - match List.hd_exn exprs with - | ImmIdentifier to_app -> - let args_e = List.tl_exn exprs in - return (binds, cexp_app to_app args_e) - | _ -> failwith "Unexpected expression in application" - -and to_exp e = - let* binds, init = to_cexp e in - fold_right - binds - ~init:(return @@ aexpr_complex init) - ~f:(fun (name, cexp) acc -> return @@ aexpr_let_in name cexp acc) -;; - -let anf_declaranion = function - | Pe_Nonrec decls -> - let* bindings = - map decls ~f:(fun (name, e) -> - match e with - | Pe_EFun (args, body) -> - let* new_body = to_exp body in - return (ALet (name, args, new_body)) - | _ -> - let* new_e = to_exp e in - return (ALet (name, [], new_e))) - in - return [ ADNoRec bindings ] - | Pe_Rec decls -> - let* bindings = - map decls ~f:(fun (name, e) -> - match e with - | Pe_EFun (args, body) -> - let* new_body = to_exp body in - return (ALet (name, args, new_body)) - | _ -> - let* new_e = to_exp e in - return (ALet (name, [], new_e))) - in - return [ ADREC bindings ] -;; - -let anf_structure structure = - let rec helper = function - | [] -> return [] - | hd :: tl -> - let* d1 = anf_declaranion hd in - let* d2 = helper tl in - return @@ d1 @ d2 - in - helper structure -;; - -let run_anf bindings init structure = run (anf_structure structure) bindings init diff --git a/FML/lib/anf/closure_conv.ml b/FML/lib/anf/closure_conv.ml deleted file mode 100644 index d8fa688b3..000000000 --- a/FML/lib/anf/closure_conv.ml +++ /dev/null @@ -1,163 +0,0 @@ -(** Copyright 2024-2025, Dmitry Pilyuk, Aleksandr Rozhkov *) - -(** SPDX-License-Identifier: LGPL-2.1 *) - -open Pe_ast -open Common -open Base - -let rec free_vars binded = - let open StrSet in - function - | Pe_EConst _ | Pe_ENill | Pe_EUnit -> StrSet.empty - | Pe_EIdentifier id -> if find binded id then empty else singleton id - | Pe_EIf (e1, e2, e3) -> - union_list [ free_vars binded e1; free_vars binded e2; free_vars binded e3 ] - | Pe_EFun (args, body) -> - let binded = union binded (of_list args) in - free_vars binded body - | Pe_EApp (e1, e2) -> union (free_vars binded e1) (free_vars binded e2) - | Pe_ELet (NoRec, name, e1, e2) -> - union (free_vars binded e1) (free_vars (add binded name) e2) - | Pe_ELet (Rec, name, e1, e2) -> - let binded = add binded name in - union (free_vars binded e1) (free_vars binded e2) - | Pe_ECons (e1, e2) -> union (free_vars binded e1) (free_vars binded e2) - | Pe_ETuple es -> - List.fold es ~init:empty ~f:(fun acc e -> union acc (free_vars binded e)) -;; - -let make_apply expr args env = - List.fold args ~init:expr ~f:(fun acc name -> - let arg = - match StrMap.find env name with - | Some e -> e - | None -> Pe_EIdentifier name - in - Pe_EApp (acc, arg)) -;; - -let rec cc_expr global_env bindings = function - | Pe_EIdentifier id as v -> - (match StrMap.find bindings id with - | Some new_expr -> new_expr - | None -> v) - | Pe_EIf (e1, e2, e3) -> - let e1 = cc_expr global_env bindings e1 in - let e2 = cc_expr global_env bindings e2 in - let e3 = cc_expr global_env bindings e3 in - Pe_EIf (e1, e2, e3) - | Pe_EFun (args, body) as v -> - let fvs = free_vars global_env v |> StrSet.to_list in - let body = cc_expr global_env empty body in - let e = Pe_EFun (fvs @ args, body) in - make_apply e fvs bindings - | Pe_EApp (e1, e2) -> - let e1 = cc_expr global_env bindings e1 in - let e2 = cc_expr global_env bindings e2 in - Pe_EApp (e1, e2) - | Pe_ELet (NoRec, name, e1, e2) -> - let e1, env1 = - match e1 with - | Pe_EFun (args, body) -> - let fvs = StrSet.(to_list (diff (free_vars global_env body) (of_list args))) in - let body = cc_expr global_env empty body in - let e = Pe_EFun (fvs @ args, body) in - let apply = make_apply (Pe_EIdentifier name) fvs bindings in - e, StrMap.singleton name apply - | expr -> cc_expr global_env bindings expr, empty - in - let env2 = StrMap.merge_two bindings env1 in - let e2 = cc_expr global_env env2 e2 in - Pe_ELet (NoRec, name, e1, e2) - | Pe_ELet (Rec, name, e1, e2) -> - let e1, env1 = - match e1 with - | Pe_EFun (args, body) -> - let fvs = - StrSet.(to_list (diff (free_vars global_env body) (of_list (name :: args)))) - in - let apply = make_apply (Pe_EIdentifier name) fvs bindings in - let body = cc_expr global_env (StrMap.singleton name apply) body in - let e = Pe_EFun (fvs @ args, body) in - let apply = make_apply (Pe_EIdentifier name) fvs bindings in - e, StrMap.singleton name apply - | expr -> cc_expr global_env bindings expr, empty - in - let env2 = StrMap.merge_two bindings env1 in - let e2 = cc_expr global_env env2 e2 in - Pe_ELet (Rec, name, e1, e2) - | Pe_ECons (e1, e2) -> - let e1 = cc_expr global_env bindings e1 in - let e2 = cc_expr global_env bindings e2 in - Pe_ECons (e1, e2) - | Pe_ETuple el -> - let el = List.map el ~f:(cc_expr global_env bindings) in - Pe_ETuple el - | c -> c -;; - -let cc_nonrec global_env decl_list = - let f1 (decl_acc, env) (name, expr) = - match expr with - | Pe_EFun (args, body) -> - let fvs = StrSet.(to_list (diff (free_vars global_env body) (of_list args))) in - let body = cc_expr global_env empty body in - let e = Pe_EFun (fvs @ args, body) in - (name, e) :: decl_acc, StrSet.add env name - | expr -> (name, cc_expr global_env empty expr) :: decl_acc, StrSet.add env name - in - List.fold decl_list ~init:([], global_env) ~f:f1 -;; - -let cc_rec global_env prev_env cl = - let ids = List.map cl ~f:fst in - let f1 (free, env) (name, expr) = - match expr with - | Pe_EFun (args, body) -> - let remove = StrSet.union (StrSet.of_list ids) (StrSet.of_list args) in - let fvs = StrSet.diff (free_vars global_env body) remove |> StrSet.to_list in - let bind = make_apply (Pe_EIdentifier name) fvs prev_env in - let env = StrMap.update env name ~f:(fun _ -> bind) in - fvs :: free, env - | _ -> [] :: free, env - in - let fvs, env = List.fold cl ~init:([], prev_env) ~f:f1 in - let fvs = List.rev fvs in - let to_fold = List.zip_exn cl fvs in - let f1 decl_acc ((name, e), free) = - match e with - | Pe_EFun (args, body) -> - let new_body = cc_expr global_env empty body in - let efun = Pe_EFun (free @ args, new_body) in - (name, efun) :: decl_acc - | _ -> - let e = cc_expr global_env env e in - (name, e) :: decl_acc - in - let cl = List.fold to_fold ~init:[] ~f:f1 in - let cl = List.rev cl in - cl, env -;; - -let cc_declaration global_env = function - | Pe_Nonrec decl_list -> - let decl_list, env = cc_nonrec global_env decl_list in - env, Pe_Nonrec decl_list - | Pe_Rec decl_list -> - let ids = List.map decl_list ~f:fst in - let cl, _ = cc_rec global_env empty decl_list in - let env = List.fold ids ~init:global_env ~f:(fun acc name -> StrSet.add acc name) in - env, Pe_Rec cl -;; - -let run_cc ast = - let builtins = List.fold Common.builtins ~init:StrSet.empty ~f:StrSet.add in - let rec helper last_env = function - | [] -> [] - | hd :: tl -> - let env, ast = cc_declaration last_env hd in - ast :: helper env tl - in - helper builtins ast -;; diff --git a/FML/lib/anf/closure_conv.mli b/FML/lib/anf/closure_conv.mli deleted file mode 100644 index a2c191313..000000000 --- a/FML/lib/anf/closure_conv.mli +++ /dev/null @@ -1,7 +0,0 @@ -(** Copyright 2024-2025, Dmitry Pilyuk, Aleksandr Rozhkov *) - -(** SPDX-License-Identifier: LGPL-2.1 *) - -open Pe_ast - -val run_cc : pe_program -> pe_program diff --git a/FML/lib/anf/common.ml b/FML/lib/anf/common.ml index 4d3fcbf64..53f122160 100644 --- a/FML/lib/anf/common.ml +++ b/FML/lib/anf/common.ml @@ -4,7 +4,6 @@ open Base open Ast -open Pe_ast module StrMap = struct type 'a t = (string, 'a, String.comparator_witness) Map.t @@ -41,7 +40,6 @@ let builtins = ] ;; -let make_apply op expr1 expr2 = Pe_EApp (Pe_EApp (Pe_EIdentifier op, expr1), expr2) module StrSet = struct open Base @@ -131,13 +129,6 @@ let rec get_binds_pat = function StrSet.union acc (get_binds_pat p)) ;; -let make_condition checks e1 e2 = - let cond = - List.fold (List.tl_exn checks) ~init:(List.hd_exn checks) ~f:(fun acc a -> - make_apply "( && )" acc a) - in - Pe_EIf (cond, e1, e2) -;; let get_id i = "a" ^ Int.to_string i let empty = Base.Map.empty (module Base.String) diff --git a/FML/lib/anf/lambda_lifting.ml b/FML/lib/anf/lambda_lifting.ml deleted file mode 100644 index 95096c9d8..000000000 --- a/FML/lib/anf/lambda_lifting.ml +++ /dev/null @@ -1,98 +0,0 @@ -(** Copyright 2024-2025, Dmitry Pilyuk, Aleksandr Rozhkov *) - -(** SPDX-License-Identifier: LGPL-2.1 *) - -open Base -open Pe_ast -open Common -open Common.MonadCounter - -let rec ll_expr env = function - | Pe_EUnit -> return ([], Pe_EUnit) - | Pe_ENill -> return ([], Pe_ENill) - | Pe_EConst _ as v -> return ([], v) - | Pe_EIdentifier id as v -> - (match Map.find env id with - | Some x -> return ([], Pe_EIdentifier x) - | None -> return ([], v)) - | Pe_EApp (e1, e2) -> - let* str1, e1 = ll_expr env e1 in - let* sl2, e2 = ll_expr env e2 in - return (str1 @ sl2, Pe_EApp (e1, e2)) - | Pe_EIf (e1, e2, e3) -> - let* str1, e1 = ll_expr env e1 in - let* str2, e2 = ll_expr env e2 in - let* str3, e3 = ll_expr env e3 in - return (str1 @ str2 @ str3, Pe_EIf (e1, e2, e3)) - | Pe_EFun (args, body) -> - let* fresh = fresh >>| get_id in - let new_env = List.fold args ~init:env ~f:Map.remove in - let* str, body = ll_expr new_env body in - return (str @ [ Pe_Nonrec [ fresh, Pe_EFun (args, body) ] ], Pe_EIdentifier fresh) - | Pe_ECons (e1, e2) -> - let* str1, e1 = ll_expr env e1 in - let* str2, e2 = ll_expr env e2 in - return (str1 @ str2, Pe_ECons (e1, e2)) - | Pe_ETuple e_list -> - let* t = map e_list ~f:(ll_expr env) in - let str, el = List.unzip t in - return (List.concat str, Pe_ETuple el) - | Pe_ELet (Rec, name, e1, e2) -> - let* fresh_name = fresh >>| get_id in - let env = Map.set env ~key:name ~data:fresh_name in - let* str1, e1 = ll_inner env e1 in - let* str2, e2 = ll_expr env e2 in - return (str1 @ [ Pe_Rec [ fresh_name, e1 ] ] @ str2, e2) - | Pe_ELet (NoRec, name, e1, e2) -> - let* str1, e1 = ll_inner env e1 in - (match e1 with - | Pe_EFun _ -> - let* fresh_name = fresh >>| get_id in - let bindings = Map.set env ~key:name ~data:fresh_name in - let* str2, e2 = ll_expr bindings e2 in - return (str1 @ [ Pe_Nonrec [ fresh_name, e1 ] ] @ str2, e2) - | _ -> - let* str2, e2 = ll_expr env e2 in - return (str1 @ str2, Pe_ELet (NoRec, name, e1, e2))) - -and ll_inner env = function - | Pe_EFun (args, body) -> - let env = List.fold args ~init:env ~f:Map.remove in - let* str, body = ll_expr env body in - return (str, Pe_EFun (args, body)) - | e -> - let* str, e = ll_expr env e in - return (str, e) -;; - -let ll_str_item = function - | Pe_Nonrec bindings -> - let* lifted_bindings = - map bindings ~f:(fun (name, e) -> - let* str, new_e = ll_inner empty e in - return (str, (name, new_e))) - in - let strs, new_bindings = List.unzip lifted_bindings in - return (List.concat strs @ [ Pe_Nonrec new_bindings ]) - | Pe_Rec bindings -> - let* lifted_bindings = - map bindings ~f:(fun (name, e) -> - let* str, new_e = ll_inner empty e in - return (str, (name, new_e))) - in - let strs, new_bindings = List.unzip lifted_bindings in - return (List.concat strs @ [ Pe_Rec new_bindings ]) -;; - -let ll_structure structure = - let rec helper = function - | [] -> return [] - | hd :: tl -> - let* str1 = ll_str_item hd in - let* str2 = helper tl in - return @@ str1 @ str2 - in - helper structure -;; - -let run_ll bindings init_num p = run (ll_structure p) bindings init_num diff --git a/FML/lib/anf/lambda_lifting.mli b/FML/lib/anf/lambda_lifting.mli deleted file mode 100644 index 4aa536a88..000000000 --- a/FML/lib/anf/lambda_lifting.mli +++ /dev/null @@ -1,8 +0,0 @@ -(** Copyright 2024-2025, Dmitry Pilyuk, Aleksandr Rozhkov *) - -(** SPDX-License-Identifier: LGPL-2.1 *) - -open Common -open Pe_ast - -val run_ll : bindings -> int -> pe_program -> bindings * int * pe_program diff --git a/FML/lib/anf/pattern_elim.ml b/FML/lib/anf/pattern_elim.ml deleted file mode 100644 index 587f43dd1..000000000 --- a/FML/lib/anf/pattern_elim.ml +++ /dev/null @@ -1,309 +0,0 @@ -(** Copyright 2024-2025, Dmitry Pilyuk, Aleksandr Rozhkov *) - -(** SPDX-License-Identifier: LGPL-2.1 *) - -open Ast -open Pe_ast -open Common - -type value_to_get = - | Tuple of int - | Cons_head - | Cons_tail - | Other - -let get_element e = function - | Tuple i -> Pe_EApp (Pe_EApp (Pe_EIdentifier "tuple_element", e), Pe_EConst (Pe_Cint i)) - | Cons_head -> Pe_EApp (Pe_EIdentifier "list_head", e) - | Cons_tail -> Pe_EApp (Pe_EIdentifier "list_tail", e) - | Other -> e -;; - -let const_to_peconst const = - let pe_const = - match const with - | CInt i -> Pe_Cint i - | CBool b -> Pe_CBool b - in - Pe_EConst pe_const -;; - -open Base -open MonadCounter - -let check_pattern expr pat = - let rec helper add expr = function - | PConstraint (p, _) -> helper add expr p - | PConst c -> [ make_apply "( = )" expr (const_to_peconst c) ] - | PTuple pl -> - List.concat - @@ List.mapi pl ~f:(fun i p -> helper true (get_element expr (Tuple i)) p) - | PCons (l, r) -> - let check = - Pe_EApp (Pe_EIdentifier "not", Pe_EApp (Pe_EIdentifier "is_empty", expr)) - in - let l = helper true (get_element expr Cons_head) l in - let r = helper false (get_element expr Cons_tail) r in - if add then (check :: l) @ r else l @ r - | PNill -> [ Pe_EApp (Pe_EIdentifier "is_empty", expr) ] - | _ -> [] - in - helper true expr pat -;; - -let check_declaration expr pat = - let rec helper name = function - | PConstraint (p, _) -> helper name p - | PCons (l, r) -> - (match helper name l with - | _ :: _ as lst -> Cons_head :: lst - | _ -> Cons_tail :: helper name r) - | PTuple pl -> - let t = List.map pl ~f:(helper name) in - (match List.findi t ~f:(fun _ a -> not @@ List.is_empty a) with - | Some (i, lst) -> Tuple i :: lst - | None -> []) - | PIdentifier v when String.equal v name -> [ Other ] - | _ -> [] - in - let create_expr name = - List.fold_left (helper name pat) ~init:expr ~f:(fun acc unpack -> - get_element acc unpack) - in - let names = get_binds_pat pat in - let decls = List.map (StrSet.to_list names) ~f:(fun name -> name, create_expr name) in - Pe_Nonrec decls -;; - -let make_case expr pat case_expr not_match_expr = - let checks = check_pattern expr pat in - let decl = check_declaration expr pat in - let let_expr = - match decl with - | Pe_Nonrec decl_list -> - List.fold_right decl_list ~init:case_expr ~f:(fun (name, value) acc -> - Pe_ELet (NoRec, name, value, acc)) - | Pe_Rec decl_list -> - List.fold_right decl_list ~init:case_expr ~f:(fun (name, value) acc -> - Pe_ELet (Rec, name, value, acc)) - in - if List.is_empty checks then let_expr else make_condition checks let_expr not_match_expr -;; - -let rec pe_expr = - let open Ast in - function - | EUnit -> return @@ Pe_EUnit - | ENill -> return @@ Pe_ENill - | EConstraint (e, _) -> pe_expr e - | EConst c -> return @@ const_to_peconst c - | EIdentifier v -> return @@ Pe_EIdentifier v - | EApplication (e1, e2) -> - let* e1 = pe_expr e1 in - let* e2 = pe_expr e2 in - return @@ Pe_EApp (e1, e2) - | EIf (e1, e2, e3) -> - let* e1 = pe_expr e1 in - let* e2 = pe_expr e2 in - let* e3 = pe_expr e3 in - return @@ Pe_EIf (e1, e2, e3) - | ECons (e1, e2) -> - let* e1 = pe_expr e1 in - let* e2 = pe_expr e2 in - return @@ Pe_ECons (e1, e2) - | ETuple e_list -> - let* e_list = map e_list ~f:(fun e -> pe_expr e) in - return @@ Pe_ETuple e_list - | EFun (p, e) -> - let rec extract_body = function - | EFun (_, e) -> extract_body e - | e -> e - in - let body = extract_body e in - let rec extract_args = function - | EFun (p, e) -> p :: extract_args e - | _ -> [] - in - let other = extract_args e in - let last_args = p :: other in - let f1 (new_args, args_to_match, pat_list) arg = - match arg with - | PIdentifier v when not (List.mem new_args v ~equal:String.equal) -> - return (v :: new_args, args_to_match, pat_list) - | _ -> - let* fresh_name = fresh >>| get_id in - return (fresh_name :: new_args, fresh_name :: args_to_match, arg :: pat_list) - in - let* new_args, args_to_match, pat_list = - fold_left last_args ~init:(return ([], [], [])) ~f:f1 - in - let new_args = List.rev new_args in - let args_to_match = List.rev args_to_match in - let pat_list = List.rev pat_list in - let* new_body = pe_expr body in - (match List.length args_to_match with - | 0 -> return @@ Pe_EFun (new_args, new_body) - | 1 -> - let pat = List.hd_exn pat_list in - let to_match = Pe_EIdentifier (List.hd_exn args_to_match) in - let case_expr = make_case to_match pat new_body (Pe_EIdentifier "fail_match") in - return @@ Pe_EFun (new_args, case_expr) - | _ -> - let pat = PTuple pat_list in - let to_match = - let vals = List.map args_to_match ~f:(fun a -> Pe_EIdentifier a) in - Pe_ETuple vals - in - let* fresh_name = fresh >>| get_id in - let case_expr = - make_case (Pe_EIdentifier fresh_name) pat new_body (Pe_EIdentifier "fail_match") - in - return @@ Pe_EFun (new_args, Pe_ELet (NoRec, fresh_name, to_match, case_expr))) - | EMatch (e_last, case_list) -> - let* e = pe_expr e_last in - (match e_last with - | EIdentifier _ | EConst _ -> pe_match e case_list - | _ -> - let* fresh_name = fresh >>| get_id in - let* e_match = pe_match (Pe_EIdentifier fresh_name) case_list in - return @@ Pe_ELet (NoRec, fresh_name, e, e_match)) - | ELetIn (NoRec, pat, e1, e2) -> - let* e1 = pe_expr e1 in - let* e2 = pe_expr e2 in - (match pat with - | PIdentifier name -> return @@ Pe_ELet (NoRec, name, e1, e2) - | PUnit -> return @@ Pe_ELet (NoRec, "()", e1, e2) - | _ -> - (match e1 with - | Pe_EIdentifier _ -> - let case_expr = make_case e1 pat e2 (Pe_EIdentifier "fail_match") in - return case_expr - | _ -> - let* fresh_name = fresh >>| get_id in - let case_expr = - make_case (Pe_EIdentifier fresh_name) pat e2 (Pe_EIdentifier "fail_match") - in - return @@ Pe_ELet (NoRec, fresh_name, e1, case_expr))) - | ELetIn (Rec, pat, e1, e2) -> - let* e1 = pe_expr e1 in - let* e2 = pe_expr e2 in - (match pat with - | PIdentifier name -> return @@ Pe_ELet (Rec, name, e1, e2) - | PUnit -> return @@ Pe_ELet (Rec, "()", e1, e2) - | _ -> - let* fresh_name = fresh >>| get_id in - let case_expr = - make_case (Pe_EIdentifier fresh_name) pat e2 (Pe_EIdentifier "fail_match") - in - return @@ Pe_ELet (Rec, fresh_name, e1, case_expr)) - -and pe_match to_match = function - | (p, e) :: tl -> - let checks = check_pattern to_match p in - let decls = check_declaration to_match p in - let* e = pe_expr e in - let let_in = - match decls with - | Pe_Nonrec decl_list -> - List.fold_right decl_list ~init:e ~f:(fun (name, value) acc -> - Pe_ELet (NoRec, name, value, acc)) - | Pe_Rec decl_list -> - List.fold_right decl_list ~init:e ~f:(fun (name, value) acc -> - Pe_ELet (Rec, name, value, acc)) - in - if List.is_empty checks - then return let_in - else - let* match_e = pe_match to_match tl in - return @@ make_condition checks let_in match_e - | _ -> return @@ Pe_EIdentifier "fail_match" -;; - -let pe_declaration = function - | NoRecDecl decl_list -> - let* decls = - map decl_list ~f:(fun (Ast.DDeclaration (pat, e)) -> - let* e = pe_expr e in - match pat with - | PIdentifier name -> return (name, e) - | PUnit -> return ("()", e) - | _ -> - let* fresh_name = fresh >>| get_id in - return (fresh_name, e)) - in - return (Pe_Nonrec decls) - | RecDecl decl_list -> - let* decls = - map decl_list ~f:(fun (Ast.DDeclaration (pat, e)) -> - let* e = pe_expr e in - match pat with - | PIdentifier v -> return (v, e) - | _ -> return ("()", e)) - in - return (Pe_Rec decls) -;; - -let pe_prog program = - let rec helper = function - | [] -> return [] - | hd :: tl -> - let* hd = pe_declaration hd in - let* tl = helper tl in - return @@ (hd :: tl) - in - helper program -;; - -let rec get_binds_expr = function - | EConstraint (e, _) -> get_binds_expr e - | EConst _ | EUnit | ENill -> StrSet.empty - | EIdentifier ident -> StrSet.singleton ident - | ECons (e1, e2) -> StrSet.union (get_binds_expr e1) (get_binds_expr e2) - | EApplication (e1, e2) -> StrSet.union (get_binds_expr e1) (get_binds_expr e2) - | EFun (pat, e) -> StrSet.union (get_binds_pat pat) (get_binds_expr e) - | EIf (e1, e2, e3) -> - StrSet.union_list [ get_binds_expr e1; get_binds_expr e2; get_binds_expr e3 ] - | ELetIn (_, p, e1, e2) -> - StrSet.union (get_binds_pat p) (StrSet.union (get_binds_expr e1) (get_binds_expr e2)) - | EMatch (e, p_list) -> - StrSet.union_list - (get_binds_expr e - :: List.map p_list ~f:(fun (p, e) -> - StrSet.union (get_binds_pat p) (get_binds_expr e))) - | ETuple e_list -> StrSet.union_list @@ List.map e_list ~f:get_binds_expr - -and get_binds_declaration = function - | NoRecDecl decl_list -> - List.fold decl_list ~init:StrSet.empty ~f:(fun acc (DDeclaration (pat, e)) -> - StrSet.union acc (StrSet.union (get_binds_pat pat) (get_binds_expr e))) - | RecDecl decl_list -> - List.fold decl_list ~init:StrSet.empty ~f:(fun acc (DDeclaration (pat, e)) -> - StrSet.union acc (StrSet.union (get_binds_pat pat) (get_binds_expr e))) -;; - -let create_bundle structure = - let make_id id = - let is_digit = function - | '0' .. '9' -> true - | _ -> false - in - let char_to_digit c = Char.to_int c - Char.to_int '0' in - let rec helper acc = function - | [] -> Some acc - | hd :: tl -> - if is_digit hd then helper ((acc * 10) + char_to_digit hd) tl else None - in - let char_list = String.to_list id in - match List.length char_list with - | x when x >= 2 && x <= 10 && Char.equal (List.hd_exn char_list) 'a' -> - helper 0 (List.tl_exn char_list) - | _ -> None - in - let idents = - List.fold_left structure ~init:StrSet.empty ~f:(fun acc t -> - StrSet.union acc (get_binds_declaration t)) - in - Set.filter_map (module Int) idents ~f:make_id -;; - -let run_pe program = run (pe_prog program) (create_bundle program) 0 diff --git a/FML/lib/anf/pattern_elim.mli b/FML/lib/anf/pattern_elim.mli deleted file mode 100644 index bb72d6a97..000000000 --- a/FML/lib/anf/pattern_elim.mli +++ /dev/null @@ -1,9 +0,0 @@ -(** Copyright 2024-2025, Dmitry Pilyuk, Aleksandr Rozhkov *) - -(** SPDX-License-Identifier: LGPL-2.1 *) - -open Ast -open Pe_ast -open Common - -val run_pe : program -> bindings * int * pe_program diff --git a/FML/lib/anf/pe_ast.ml b/FML/lib/anf/pe_ast.ml deleted file mode 100644 index e3587734f..000000000 --- a/FML/lib/anf/pe_ast.ml +++ /dev/null @@ -1,96 +0,0 @@ -(** Copyright 2024-2025, Dmitry Pilyuk, Aleksandr Rozhkov *) - -(** SPDX-License-Identifier: LGPL-2.1 *) - -type rec_flag = - | Rec - | NoRec - -type pe_const = - | Pe_Cint of int - | Pe_CBool of bool - -type pe_expr = - | Pe_EUnit - | Pe_ENill - | Pe_EIdentifier of string - | Pe_EConst of pe_const - | Pe_EIf of pe_expr * pe_expr * pe_expr - | Pe_EFun of string list * pe_expr - | Pe_EApp of pe_expr * pe_expr - | Pe_ELet of rec_flag * string * pe_expr * pe_expr - | Pe_ECons of pe_expr * pe_expr - | Pe_ETuple of pe_expr list - -type pe_declaration = - | Pe_Nonrec of (string * pe_expr) list - | Pe_Rec of (string * pe_expr) list - -type pe_program = pe_declaration list - -let const_to_str = function - | Pe_CBool b -> if b then "true" else "false" - | Pe_Cint i -> Format.sprintf "%i" i -;; - -let rec expr_to_str = function - | Pe_EUnit -> "()" - | Pe_ENill -> "[]" - | Pe_EIdentifier a -> a - | Pe_EConst c -> const_to_str c - | Pe_EIf (e1, e2, e3) -> - Format.sprintf - "if %s\nthen %s\nelse %s" - (expr_to_str e1) - (expr_to_str e2) - (expr_to_str e3) - | Pe_EFun (args, e) -> - Format.sprintf "(fun %s -> %s)" (String.concat " " args) (expr_to_str e) - | Pe_EApp (e1, e2) -> Format.sprintf "(%s %s)" (expr_to_str e1) (expr_to_str e2) - | Pe_ELet (NoRec, name, e1, e2) -> - Format.sprintf "let %s = %s in\n%s" name (expr_to_str e1) (expr_to_str e2) - | Pe_ELet (Rec, name1, e1, e2) -> - Format.sprintf "let rec %s = %s in\n%s" name1 (expr_to_str e1) (expr_to_str e2) - | Pe_ECons (e1, e2) -> Format.sprintf "(%s::%s)" (expr_to_str e1) (expr_to_str e2) - | Pe_ETuple e_list -> - Format.sprintf - "(%s)" - (expr_to_str (List.hd e_list) - ^ List.fold_left - (fun acc e -> acc ^ Format.sprintf ", %s" (expr_to_str e)) - "" - (List.tl e_list)) -;; - -let decl_to_str = function - | Pe_Nonrec decl_list -> - (match decl_list with - | [] -> "" - | (name, e) :: tl -> - Format.sprintf "let %s = %s" name (expr_to_str e) - ^ List.fold_left - (fun acc (name, e) -> - acc ^ Format.sprintf "\nlet %s = %s" name (expr_to_str e)) - "" - tl) - | Pe_Rec decl_list -> - (match decl_list with - | [] -> "" - | (name, e) :: tl -> - Format.sprintf "let rec %s = %s" name (expr_to_str e) - ^ List.fold_left - (fun acc (name, e) -> - acc ^ Format.sprintf "\nand %s = %s" name (expr_to_str e)) - "" - tl) -;; - -let pp_pe_program ppf p = - let len = List.length p in - List.iteri - (fun i a -> - if i = len - 1 - then Format.fprintf ppf "%s" (decl_to_str a) - else Format.fprintf ppf "%s\n\n" (decl_to_str a)) - p -;; diff --git a/FML/lib/anf/pe_ast.mli b/FML/lib/anf/pe_ast.mli deleted file mode 100644 index 6ff80376c..000000000 --- a/FML/lib/anf/pe_ast.mli +++ /dev/null @@ -1,34 +0,0 @@ -(** Copyright 2024-2025, Dmitry Pilyuk, Aleksandr Rozhkov *) - -(** SPDX-License-Identifier: LGPL-2.1 *) - -type rec_flag = - | Rec (** rec *) - | NoRec (** norec*) - -type pe_const = - | Pe_Cint of int (** 1 *) - | Pe_CBool of bool (** true *) - -type pe_expr = - | Pe_EUnit (** () *) - | Pe_ENill (** [] *) - | Pe_EIdentifier of string (** x *) - | Pe_EConst of pe_const (** 1 || true *) - | Pe_EIf of pe_expr * pe_expr * pe_expr (** if E1 then E2 else E3*) - | Pe_EFun of string list * pe_expr (** fun x y -> E *) - | Pe_EApp of pe_expr * pe_expr (** E1 E2 *) - | Pe_ELet of rec_flag * string * pe_expr * pe_expr (** let (rec) f = E1 in E2 *) - | Pe_ECons of pe_expr * pe_expr (** E1 :: E2 *) - | Pe_ETuple of pe_expr list (** (E1, E2, E3) *) - -type pe_declaration = - | Pe_Nonrec of (string * pe_expr) list (** (let f1 = E1 (and f2 = E2) *) - | Pe_Rec of (string * pe_expr) list (** (let rec f1 = E1 (and f2 = E2) *) - -type pe_program = pe_declaration list - -val const_to_str : pe_const -> string -val expr_to_str : pe_expr -> string -val decl_to_str : pe_declaration -> string -val pp_pe_program : Format.formatter -> pe_program -> unit diff --git a/FML/lib/dune b/FML/lib/dune index 932e13c71..229137cac 100644 --- a/FML/lib/dune +++ b/FML/lib/dune @@ -10,19 +10,11 @@ Inf_pprint Inferencer Typedtree - Pattern_elim Common - Pe_ast Me_ast - Alpha_conv A_conv Match_elimination - Lambda_lift - Closure_conv - Lambda_lifting - Anf_ast - Anf - Codegen) + Lambda_lift) (modules_without_implementation inf_errors) (libraries base angstrom llvm llvm.analysis llvm.executionengine) (preprocess diff --git a/FML/tests/alpha_conv_manytest.t b/FML/tests/alpha_conv_manytest.t deleted file mode 100644 index edee99b03..000000000 --- a/FML/tests/alpha_conv_manytest.t +++ /dev/null @@ -1,297 +0,0 @@ - $ ./alpha_conv_runner.exe << EOF - > let f n _ = n - > - > let main = let () = print_int (f 6 5) in 0 - > EOF - let f = (fun n a0 -> n) - - let main = let () = (print_int ((f 6) 5)) in - 0 - - $ ./alpha_conv_runner.exe << EOF - > let fac n = - > let rec fack n k = - > if n<=1 then k 1 - > else fack (n - 1) ((fun k n m -> k (m * n)) k n) - > in - > fack n (fun x -> x) - > EOF - let fac = (fun n -> let rec fack = (fun a0 k -> if ((( <= ) a0) 1) - then (k 1) - else ((fack ((( - ) a0) 1)) (((fun a1 a2 m -> (a1 ((( * ) m) a2))) k) a0))) in - ((fack n) (fun x -> x))) - $ ./alpha_conv_runner.exe < manytests/typed/001fac.ml - let rec fac = (fun n -> if ((( <= ) n) 1) - then 1 - else ((( * ) n) (fac ((( - ) n) 1)))) - - let main = let () = (print_int (fac 4)) in - 0 - - $ ./alpha_conv_runner.exe < manytests/typed/002fac.ml - let rec fac_cps = (fun n k -> if ((( = ) n) 1) - then (k 1) - else ((fac_cps ((( - ) n) 1)) (fun p -> (k ((( * ) p) n))))) - - let main = let () = (print_int ((fac_cps 4) (fun a0 -> a0))) in - 0 - - $ ./alpha_conv_runner.exe < manytests/typed/003fib.ml - let rec fib_acc = (fun a b n -> if ((( = ) n) 1) - then b - else let n1 = ((( - ) n) 1) in - let ab = ((( + ) a) b) in - (((fib_acc b) ab) n1)) - - let rec fib = (fun n -> if ((( < ) n) 2) - then n - else ((( + ) (fib ((( - ) n) 1))) (fib ((( - ) n) 2)))) - - let main = let () = (print_int (((fib_acc 0) 1) 4)) in - let () = (print_int (fib 4)) in - 0 - - $ ./alpha_conv_runner.exe < manytests/typed/004manyargs.ml - let wrap = (fun f -> if ((( = ) 1) 1) - then f - else f) - - let test3 = (fun a b c -> let a0 = (print_int a) in - let a1 = (print_int b) in - let a2 = (print_int c) in - 0) - - let test10 = (fun a b c d e f g h i j -> ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) a) b)) c)) d)) e)) f)) g)) h)) i)) j)) - - let main = let rez = (((((((((((wrap test10) 1) 10) 100) 1000) 10000) 100000) 1000000) 10000000) 100000000) 1000000000) in - let () = (print_int rez) in - let temp2 = ((((wrap test3) 1) 10) 100) in - 0 - - $ ./alpha_conv_runner.exe < manytests/typed/005fix.ml - let rec fix = (fun f x -> ((f (fix f)) x)) - - let fac = (fun self n -> if ((( <= ) n) 1) - then 1 - else ((( * ) n) (self ((( - ) n) 1)))) - - let main = let () = (print_int ((fix fac) 6)) in - 0 - - $ ./alpha_conv_runner.exe < manytests/typed/006partial.ml - let foo = (fun b -> if b - then (fun foo -> ((( + ) foo) 2)) - else (fun foo -> ((( * ) foo) 10))) - - let a0 = (fun x -> ((foo true) ((foo false) ((foo true) ((foo false) x))))) - - let main = let () = (print_int (a0 11)) in - 0 - - $ ./alpha_conv_runner.exe < manytests/typed/006partial2.ml - let foo = (fun a b c -> let () = (print_int a) in - let () = (print_int b) in - let () = (print_int c) in - ((( + ) a) ((( * ) b) c))) - - let main = let a0 = (foo 1) in - let a1 = (a0 2) in - let a2 = (a1 3) in - let () = (print_int a2) in - 0 - $ ./alpha_conv_runner.exe < manytests/typed/006partial3.ml - let foo = (fun a -> let () = (print_int a) in - (fun b -> let () = (print_int b) in - (fun c -> (print_int c)))) - - let main = let () = (((foo 4) 8) 9) in - 0 - $ ./alpha_conv_runner.exe < manytests/typed/007order.ml - let _start = (fun a0 a1 a a2 b _c a3 d __ -> let a4 = (a0, a1, a2, a3) in - let () = (print_int ((( + ) a) b)) in - let () = (print_int __) in - ((( + ) ((( / ) ((( * ) a) b)) _c)) d)) - - let main = (print_int (((((((((_start (print_int 1)) (print_int 2)) 3) (print_int 4)) 100) 1000) (print_int (( ~- ) 1))) 10000) (( ~- ) 555555))) - $ ./alpha_conv_runner.exe < manytests/typed/008ascription.ml - let addi = (fun f g x -> ((f x) (g x))) - - let main = let () = (print_int (((addi (fun x b -> if b - then ((( + ) x) 1) - else ((( * ) x) 2))) (fun _start -> ((( = ) ((( / ) _start) 2)) 0))) 4)) in - 0 - - $ ./alpha_conv_runner.exe < manytests/typed/009let_poly.ml - let temp = let f = (fun x -> x) in - ((f 1), (f true)) - - $ ./alpha_conv_runner.exe < manytests/typed/011mapcps.ml - let rec map = (fun f xs k -> if (is_empty xs) - then (k []) - else if (not (is_empty xs)) - then let h = (list_head xs) in - let tl = (list_tail xs) in - (((map f) tl) (fun a0 -> (k ((f h)::a0)))) - else fail_match) - - let rec iter = (fun f xs -> if (is_empty xs) - then () - else if (not (is_empty xs)) - then let h = (list_head xs) in - let tl = (list_tail xs) in - let w = (f h) in - ((iter f) tl) - else fail_match) - - let main = ((iter print_int) (((map (fun x -> ((( + ) x) 1))) (1::(2::(3::[])))) (fun x -> x))) - $ ./alpha_conv_runner.exe < manytests/typed/012fibcps.ml - let rec fib = (fun n k -> if ((( < ) n) 2) - then (k n) - else ((fib ((( - ) n) 1)) (fun a -> ((fib ((( - ) n) 2)) (fun b -> (k ((( + ) a) b))))))) - - let main = (print_int ((fib 6) (fun x -> x))) - $ ./alpha_conv_runner.exe < manytests/typed/013foldfoldr.ml - let id = (fun x -> x) - - let rec fold_right = (fun f acc xs -> if (is_empty xs) - then acc - else if (not (is_empty xs)) - then let h = (list_head xs) in - let tl = (list_tail xs) in - ((f h) (((fold_right f) acc) tl)) - else fail_match) - - let foldl = (fun f a bs -> ((((fold_right (fun b g x -> (g ((f x) b)))) id) bs) a)) - - let main = (print_int (((foldl (fun x y -> ((( * ) x) y))) 1) (1::(2::(3::[]))))) - - $ ./alpha_conv_runner.exe < manytests/typed/015tuples.ml - let rec fix = (fun f x -> ((f (fix f)) x)) - - let map = (fun f p -> let a = ((tuple_element p) 0) in - let b = ((tuple_element p) 1) in - ((f a), (f b))) - - let fixpoly = (fun l -> ((fix (fun self a0 -> ((map (fun li x -> ((li (self a0)) x))) a0))) l)) - - let feven = (fun p n -> let e = ((tuple_element p) 0) in - let o = ((tuple_element p) 1) in - if ((( = ) n) 0) - then 1 - else (o ((( - ) n) 1))) - - let fodd = (fun p n -> let e = ((tuple_element p) 0) in - let o = ((tuple_element p) 1) in - if ((( = ) n) 0) - then 0 - else (e ((( - ) n) 1))) - - let tie = (fixpoly (feven, fodd)) - - let rec meven = (fun n -> if ((( = ) n) 0) - then 1 - else (modd ((( - ) n) 1))) - and modd = (fun n -> if ((( = ) n) 0) - then 1 - else (meven ((( - ) n) 1))) - - let main = let () = (print_int (modd 1)) in - let () = (print_int (meven 2)) in - let even = ((tuple_element tie) 0) in - let odd = ((tuple_element tie) 1) in - let () = (print_int (odd 3)) in - let () = (print_int (even 4)) in - 0 - - $ ./alpha_conv_runner.exe < manytests/typed/016lists.ml - let rec length = (fun xs -> if (is_empty xs) - then 0 - else if (not (is_empty xs)) - then let h = (list_head xs) in - let tl = (list_tail xs) in - ((( + ) 1) (length tl)) - else fail_match) - - let length_tail = let rec helper = (fun acc xs -> if (is_empty xs) - then acc - else if (not (is_empty xs)) - then let h = (list_head xs) in - let tl = (list_tail xs) in - ((helper ((( + ) acc) 1)) tl) - else fail_match) in - (helper 0) - - let rec map = (fun f xs -> if (is_empty xs) - then [] - else if ((( && ) (not (is_empty xs))) (is_empty (list_tail xs))) - then let a = (list_head xs) in - ((f a)::[]) - else if ((( && ) (not (is_empty xs))) (is_empty (list_tail (list_tail xs)))) - then let a = (list_head xs) in - let b = (list_head (list_tail xs)) in - ((f a)::((f b)::[])) - else if ((( && ) (not (is_empty xs))) (is_empty (list_tail (list_tail (list_tail xs))))) - then let a = (list_head xs) in - let b = (list_head (list_tail xs)) in - let c = (list_head (list_tail (list_tail xs))) in - ((f a)::((f b)::((f c)::[]))) - else if (not (is_empty xs)) - then let a = (list_head xs) in - let b = (list_head (list_tail xs)) in - let c = (list_head (list_tail (list_tail xs))) in - let d = (list_head (list_tail (list_tail (list_tail xs)))) in - let tl = (list_tail (list_tail (list_tail (list_tail xs)))) in - ((f a)::((f b)::((f c)::((f d)::((map f) tl))))) - else fail_match) - - let rec append = (fun xs ys -> if (is_empty xs) - then ys - else if (not (is_empty xs)) - then let x = (list_head xs) in - let a0 = (list_tail xs) in - (x::((append a0) ys)) - else fail_match) - - let concat = let rec helper = (fun xs -> if (is_empty xs) - then [] - else if (not (is_empty xs)) - then let h = (list_head xs) in - let tl = (list_tail xs) in - ((append h) (helper tl)) - else fail_match) in - helper - - let rec iter = (fun f xs -> if (is_empty xs) - then () - else if (not (is_empty xs)) - then let h = (list_head xs) in - let tl = (list_tail xs) in - let () = (f h) in - ((iter f) tl) - else fail_match) - - let rec cartesian = (fun xs ys -> if (is_empty xs) - then [] - else if (not (is_empty xs)) - then let h = (list_head xs) in - let tl = (list_tail xs) in - ((append ((map (fun a -> (h, a))) ys)) ((cartesian tl) ys)) - else fail_match) - - let main = let () = ((iter print_int) (1::(2::(3::[])))) in - let () = (print_int (length ((cartesian (1::(2::[]))) (1::(2::(3::(4::[]))))))) in - 0 - - $ ./alpha_conv_runner.exe < manytests/do_not_type/001.ml - Infer error: - $ ./alpha_conv_runner.exe < manytests/do_not_type/002if.ml - Infer error: - $ ./alpha_conv_runner.exe < manytests/do_not_type/003occurs.ml - Infer error: - - $ ./alpha_conv_runner.exe < manytests/do_not_type/004let_poly.ml - Infer error: - - $ ./alpha_conv_runner.exe < manytests/do_not_type/015tuples.ml - Infer error: - diff --git a/FML/tests/alpha_conv_runner.ml b/FML/tests/alpha_conv_runner.ml deleted file mode 100644 index ae454d99a..000000000 --- a/FML/tests/alpha_conv_runner.ml +++ /dev/null @@ -1,27 +0,0 @@ -(** Copyright 2024-2025, Dmitry Pilyuk, Aleksandr Rozhkov *) - -(** SPDX-License-Identifier: LGPL-2.1 *) - -open Fml_lib.Parser -open Fml_lib.Inferencer -open Fml_lib.Pe_ast -open Fml_lib.Pattern_elim -open Fml_lib.Alpha_conv - -let () = - let input = Stdio.In_channel.input_all Stdlib.stdin in - let parse_and_infer input = - match parse input with - | Ok parsed -> - (match run_program_inferencer parsed with - | Ok _ -> Ok parsed - | Error _ -> Error (Format.asprintf "Infer error:")) - | Error e -> Error (Format.sprintf "Parsing error: %s" e) - in - match parse_and_infer input with - | Ok ast -> - let bind, cnt, ast = run_pe ast in - let _, _, ast = run_alpha_conv bind cnt ast in - Format.printf "%a" pp_pe_program ast - | Error message -> Format.printf "%s" message -;; diff --git a/FML/tests/anf_manytests.t b/FML/tests/anf_manytests.t deleted file mode 100644 index 599cd83de..000000000 --- a/FML/tests/anf_manytests.t +++ /dev/null @@ -1,705 +0,0 @@ - $ ./anf_runner.exe << EOF - > let fac n = - > let rec fack n k = - > if n<=1 then k 1 - > else fack (n - 1) ((fun k n m -> k (m * n)) k n) - > in - > fack n (fun x -> x) - > EOF - let a4 a1 a2 m = let a6 = ( * ) m a2 in - a1 a6 - ;; - - let rec a3 a0 k = let a7 = ( <= ) a0 1 in - if a7 - then k 1 - else let a9 = a4 k a0 in - let a8 = ( - ) a0 1 in - a3 a8 a9 - ;; - - let a5 x = x - ;; - - let fac n = a3 n a5 - ;; - Типы после приведения в ANF: - val a4 : (int -> 'a) -> int -> int -> 'a - val a3 : int -> (int -> 'a) -> 'a - val a5 : 'a -> 'a - val fac : int -> int - $ ./anf_runner.exe < manytests/typed/001fac.ml - let rec fac n = let a0 = ( <= ) n 1 in - if a0 - then 1 - else let a2 = ( - ) n 1 in - let a1 = fac a2 in - ( * ) n a1 - ;; - - let main = let a3 = fac 4 in - let () = print_int a3 in - 0 - ;; - Типы после приведения в ANF: - val fac : int -> int - val main : int - - $ ./anf_runner.exe < manytests/typed/002fac.ml - let a1 k n p = let a3 = ( * ) p n in - k a3 - ;; - - let rec fac_cps n k = let a4 = ( = ) n 1 in - if a4 - then k 1 - else let a6 = a1 k n in - let a5 = ( - ) n 1 in - fac_cps a5 a6 - ;; - - let a2 a0 = a0 - ;; - - let main = let a7 = fac_cps 4 a2 in - let () = print_int a7 in - 0 - ;; - Типы после приведения в ANF: - val a1 : (int -> 'a) -> int -> int -> 'a - val fac_cps : int -> (int -> 'a) -> 'a - val a2 : 'a -> 'a - val main : int - - $ ./anf_runner.exe < manytests/typed/003fib.ml - let rec fib_acc a b n = let a0 = ( = ) n 1 in - if a0 - then b - else let n1 = ( - ) n 1 in - let ab = ( + ) a b in - fib_acc b ab n1 - ;; - - let rec fib n = let a1 = ( < ) n 2 in - if a1 - then n - else let a5 = ( - ) n 2 in - let a4 = fib a5 in - let a3 = ( - ) n 1 in - let a2 = fib a3 in - ( + ) a2 a4 - ;; - - let main = let a6 = fib_acc 0 1 4 in - let () = print_int a6 in - let a7 = fib 4 in - let () = print_int a7 in - 0 - ;; - Типы после приведения в ANF: - val fib_acc : int -> int -> int -> int - val fib : int -> int - val main : int - - $ ./anf_runner.exe < manytests/typed/004manyargs.ml - let wrap f = let a3 = ( = ) 1 1 in - if a3 - then f - else f - ;; - - let test3 a b c = let a0 = print_int a in - let a1 = print_int b in - let a2 = print_int c in - 0 - ;; - - let test10 a b c d e f g h i j = let a11 = ( + ) a b in - let a10 = ( + ) a11 c in - let a9 = ( + ) a10 d in - let a8 = ( + ) a9 e in - let a7 = ( + ) a8 f in - let a6 = ( + ) a7 g in - let a5 = ( + ) a6 h in - let a4 = ( + ) a5 i in - ( + ) a4 j - ;; - - let main = let rez = wrap test10 1 10 100 1000 10000 100000 1000000 10000000 100000000 1000000000 in - let () = print_int rez in - let temp2 = wrap test3 1 10 100 in - 0 - ;; - Типы после приведения в ANF: - val wrap : 'a -> 'a - val test3 : int -> int -> int -> int - val test10 : int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int - val main : int - - $ ./anf_runner.exe < manytests/typed/005fix.ml - let rec fix f x = let a0 = fix f in - f a0 x - ;; - - let fac self n = let a1 = ( <= ) n 1 in - if a1 - then 1 - else let a3 = ( - ) n 1 in - let a2 = self a3 in - ( * ) n a2 - ;; - - let main = let a4 = fix fac 6 in - let () = print_int a4 in - 0 - ;; - Типы после приведения в ANF: - val fix : (('a -> 'b) -> 'a -> 'b) -> 'a -> 'b - val fac : (int -> int) -> int -> int - val main : int - - $ ./anf_runner.exe < manytests/typed/006partial.ml - let a1 foo = ( + ) foo 2 - ;; - - let a2 foo = ( * ) foo 10 - ;; - - let foo b = if b - then a1 - else a2 - ;; - - let a0 x = let a5 = foo false x in - let a4 = foo true a5 in - let a3 = foo false a4 in - foo true a3 - ;; - - let main = let a6 = a0 11 in - let () = print_int a6 in - 0 - ;; - Типы после приведения в ANF: - val a1 : int -> int - val a2 : int -> int - val foo : bool -> int -> int - val a0 : int -> int - val main : int - - $ ./anf_runner.exe < manytests/typed/006partial2.ml - let foo a b c = let () = print_int a in - let () = print_int b in - let () = print_int c in - let a3 = ( * ) b c in - ( + ) a a3 - ;; - - let main = let a0 = foo 1 in - let a1 = a0 2 in - let a2 = a1 3 in - let () = print_int a2 in - 0 - ;; - Типы после приведения в ANF: - val foo : int -> int -> int -> int - val main : int - $ ./anf_runner.exe < manytests/typed/006partial3.ml - let a1 c = print_int c - ;; - - let a0 b = let () = print_int b in - a1 - ;; - - let foo a = let () = print_int a in - a0 - ;; - - let main = let () = foo 4 8 9 in - 0 - ;; - Типы после приведения в ANF: - val a1 : int -> unit - val a0 : int -> int -> unit - val foo : int -> int -> int -> unit - val main : int - $ ./anf_runner.exe < manytests/typed/007order.ml - let _start a0 a1 a a2 b _c a3 d __ = let a4 = (a0, a1, a2, a3) in - let a5 = ( + ) a b in - let () = print_int a5 in - let () = print_int __ in - let a7 = ( * ) a b in - let a6 = ( / ) a7 _c in - ( + ) a6 d - ;; - - let main = let a14 = ( ~- ) 555555 in - let a13 = ( ~- ) 1 in - let a12 = print_int a13 in - let a11 = print_int 4 in - let a10 = print_int 2 in - let a9 = print_int 1 in - let a8 = _start a9 a10 3 a11 100 1000 a12 10000 a14 in - print_int a8 - ;; - Типы после приведения в ANF: - val _start : 'a -> 'b -> int -> 'c -> int -> int -> 'd -> int -> int -> int - val main : unit - $ ./anf_runner.exe < manytests/typed/008ascription.ml - let addi f g x = let a2 = g x in - f x a2 - ;; - - let a0 x b = if b - then ( + ) x 1 - else ( * ) x 2 - ;; - - let a1 _start = let a3 = ( / ) _start 2 in - ( = ) a3 0 - ;; - - let main = let a4 = addi a0 a1 4 in - let () = print_int a4 in - 0 - ;; - Типы после приведения в ANF: - val addi : ('a -> 'b -> 'c) -> ('a -> 'b) -> 'a -> 'c - val a0 : int -> bool -> int - val a1 : int -> bool - val main : int - - $ ./anf_runner.exe < manytests/typed/009let_poly.ml - let a0 x = x - ;; - - let temp = let a1 = a0 1 in - let a2 = a0 true in - (a1, a2) - ;; - Типы после приведения в ANF: - val a0 : 'a -> 'a - val temp : int * bool - - $ ./anf_runner.exe < manytests/typed/011mapcps.ml - let a1 f h k a0 = let a5 = f h in - let a4 = (a5::a0) in - k a4 - ;; - - let rec map f xs k = let a6 = is_empty xs in - if a6 - then let a7 = [] in - k a7 - else let a9 = is_empty xs in - let a8 = not a9 in - if a8 - then let h = list_head xs in - let tl = list_tail xs in - let a10 = a1 f h k in - map f tl a10 - else fail_match - ;; - - let rec iter f xs = let a11 = is_empty xs in - if a11 - then () - else let a13 = is_empty xs in - let a12 = not a13 in - if a12 - then let h = list_head xs in - let tl = list_tail xs in - let w = f h in - iter f tl - else fail_match - ;; - - let a2 x = ( + ) x 1 - ;; - - let a3 x = x - ;; - - let main = let a17 = (3::[]) in - let a16 = (2::a17) in - let a15 = (1::a16) in - let a14 = map a2 a15 a3 in - iter print_int a14 - ;; - Типы после приведения в ANF: - val a1 : ('a -> 'b) -> 'a -> ('b list -> 'c) -> 'b list -> 'c - val map : ('a -> 'b) -> 'a list -> ('b list -> 'c) -> 'c - val iter : ('a -> 'b) -> 'a list -> unit - val a2 : int -> int - val a3 : 'a -> 'a - val main : unit - $ ./anf_runner.exe < manytests/typed/012fibcps.ml - let a1 a k b = let a3 = ( + ) a b in - k a3 - ;; - - let a0 fib k n a = let a5 = a1 a k in - let a4 = ( - ) n 2 in - fib a4 a5 - ;; - - let rec fib n k = let a6 = ( < ) n 2 in - if a6 - then k n - else let a8 = a0 fib k n in - let a7 = ( - ) n 1 in - fib a7 a8 - ;; - - let a2 x = x - ;; - - let main = let a9 = fib 6 a2 in - print_int a9 - ;; - Типы после приведения в ANF: - val a1 : int -> (int -> 'a) -> int -> 'a - val a0 : (int -> (int -> 'a) -> 'b) -> (int -> 'a) -> int -> int -> 'b - val fib : int -> (int -> 'a) -> 'a - val a2 : 'a -> 'a - val main : unit - $ ./anf_runner.exe << EOF - > let is_empty x = x+1 - > let rec length xs = match xs with - > | [] -> 0 - > | _::tl -> 1 + length xs - > EOF - let a0 x = ( + ) x 1 - ;; - - let rec length xs = let a1 = a0 xs in - if a1 - then 0 - else let a3 = a0 xs in - let a2 = not a3 in - if a2 - then let _ = list_head xs in - let tl = list_tail xs in - let a4 = length xs in - ( + ) 1 a4 - else fail_match - ;; - Типы после приведения в ANF: - Infer error. - $ ./anf_runner.exe < manytests/typed/013foldfoldr.ml - let id x = x - ;; - - let rec fold_right f acc xs = let a2 = is_empty xs in - if a2 - then acc - else let a4 = is_empty xs in - let a3 = not a4 in - if a3 - then let h = list_head xs in - let tl = list_tail xs in - let a5 = fold_right f acc tl in - f h a5 - else fail_match - ;; - - let a0 f b g x = let a6 = f x b in - g a6 - ;; - - let foldl f a bs = let a7 = a0 f in - fold_right a7 id bs a - ;; - - let a1 x y = ( * ) x y - ;; - - let main = let a11 = (3::[]) in - let a10 = (2::a11) in - let a9 = (1::a10) in - let a8 = foldl a1 1 a9 in - print_int a8 - ;; - Типы после приведения в ANF: - val id : 'a -> 'a - val fold_right : ('a -> 'b -> 'b) -> 'b -> 'a list -> 'b - val a0 : ('a -> 'b -> 'c) -> 'b -> ('c -> 'd) -> 'a -> 'd - val foldl : ('a -> 'b -> 'a) -> 'a -> 'b list -> 'a - val a1 : int -> int -> int - val main : unit - - $ ./anf_runner.exe < manytests/typed/015tuples.ml - let rec fix f x = let a3 = fix f in - f a3 x - ;; - - let map f p = let a = tuple_element p 0 in - let b = tuple_element p 1 in - let a4 = f a in - let a5 = f b in - (a4, a5) - ;; - - let a2 a0 self li x = let a6 = self a0 in - li a6 x - ;; - - let a1 self a0 = let a7 = a2 a0 self in - map a7 a0 - ;; - - let fixpoly l = fix a1 l - ;; - - let feven p n = let e = tuple_element p 0 in - let o = tuple_element p 1 in - let a8 = ( = ) n 0 in - if a8 - then 1 - else let a9 = ( - ) n 1 in - o a9 - ;; - - let fodd p n = let e = tuple_element p 0 in - let o = tuple_element p 1 in - let a10 = ( = ) n 0 in - if a10 - then 0 - else let a11 = ( - ) n 1 in - e a11 - ;; - - let tie = let a12 = (feven, fodd) in - fixpoly a12 - ;; - - let rec meven n = let a13 = ( = ) n 0 in - if a13 - then 1 - else let a14 = ( - ) n 1 in - modd a14 - and modd n = let a15 = ( = ) n 0 in - if a15 - then 1 - else let a16 = ( - ) n 1 in - meven a16 - ;; - - let main = let a17 = modd 1 in - let () = print_int a17 in - let a18 = meven 2 in - let () = print_int a18 in - let even = tuple_element tie 0 in - let odd = tuple_element tie 1 in - let a19 = odd 3 in - let () = print_int a19 in - let a20 = even 4 in - let () = print_int a20 in - 0 - ;; - Типы после приведения в ANF: - val fix : (('a -> 'b) -> 'a -> 'b) -> 'a -> 'b - val map : ('a -> 'b) -> 'c -> 'b * 'b - val a2 : 'a -> ('a -> 'b) -> ('b -> 'c -> 'd) -> 'c -> 'd - val a1 : ('a -> 'b) -> 'a -> ('c -> 'd) * ('c -> 'd) - val fixpoly : 'a -> ('b -> 'c) * ('b -> 'c) - val feven : 'a -> int -> int - val fodd : 'a -> int -> int - val tie : ('a -> 'b) * ('a -> 'b) - val meven : int -> int - val modd : int -> int - val main : int - - $ ./anf_runner.exe < manytests/typed/016lists.ml - let rec length xs = let a4 = is_empty xs in - if a4 - then 0 - else let a6 = is_empty xs in - let a5 = not a6 in - if a5 - then let h = list_head xs in - let tl = list_tail xs in - let a7 = length tl in - ( + ) 1 a7 - else fail_match - ;; - - let rec a1 acc xs = let a8 = is_empty xs in - if a8 - then acc - else let a10 = is_empty xs in - let a9 = not a10 in - if a9 - then let h = list_head xs in - let tl = list_tail xs in - let a11 = ( + ) acc 1 in - a1 a11 tl - else fail_match - ;; - - let length_tail = a1 0 - ;; - - let rec map f xs = let a12 = is_empty xs in - if a12 - then [] - else let a17 = list_tail xs in - let a16 = is_empty a17 in - let a15 = is_empty xs in - let a14 = not a15 in - let a13 = ( && ) a14 a16 in - if a13 - then let a = list_head xs in - let a18 = f a in - (a18::[]) - else let a24 = list_tail xs in - let a23 = list_tail a24 in - let a22 = is_empty a23 in - let a21 = is_empty xs in - let a20 = not a21 in - let a19 = ( && ) a20 a22 in - if a19 - then let a = list_head xs in - let a25 = list_tail xs in - let b = list_head a25 in - let a26 = f a in - let a28 = f b in - let a27 = (a28::[]) in - (a26::a27) - else let a35 = list_tail xs in - let a34 = list_tail a35 in - let a33 = list_tail a34 in - let a32 = is_empty a33 in - let a31 = is_empty xs in - let a30 = not a31 in - let a29 = ( && ) a30 a32 in - if a29 - then let a = list_head xs in - let a36 = list_tail xs in - let b = list_head a36 in - let a38 = list_tail xs in - let a37 = list_tail a38 in - let c = list_head a37 in - let a39 = f a in - let a41 = f b in - let a43 = f c in - let a42 = (a43::[]) in - let a40 = (a41::a42) in - (a39::a40) - else let a45 = is_empty xs in - let a44 = not a45 in - if a44 - then let a = list_head xs in - let a46 = list_tail xs in - let b = list_head a46 in - let a48 = list_tail xs in - let a47 = list_tail a48 in - let c = list_head a47 in - let a51 = list_tail xs in - let a50 = list_tail a51 in - let a49 = list_tail a50 in - let d = list_head a49 in - let a54 = list_tail xs in - let a53 = list_tail a54 in - let a52 = list_tail a53 in - let tl = list_tail a52 in - let a55 = f a in - let a57 = f b in - let a59 = f c in - let a61 = f d in - let a62 = map f tl in - let a60 = (a61::a62) in - let a58 = (a59::a60) in - let a56 = (a57::a58) in - (a55::a56) - else fail_match - ;; - - let rec append xs ys = let a63 = is_empty xs in - if a63 - then ys - else let a65 = is_empty xs in - let a64 = not a65 in - if a64 - then let x = list_head xs in - let a0 = list_tail xs in - let a66 = append a0 ys in - (x::a66) - else fail_match - ;; - - let rec a2 xs = let a67 = is_empty xs in - if a67 - then [] - else let a69 = is_empty xs in - let a68 = not a69 in - if a68 - then let h = list_head xs in - let tl = list_tail xs in - let a70 = a2 tl in - append h a70 - else fail_match - ;; - - let concat = a2 - ;; - - let rec iter f xs = let a71 = is_empty xs in - if a71 - then () - else let a73 = is_empty xs in - let a72 = not a73 in - if a72 - then let h = list_head xs in - let tl = list_tail xs in - let () = f h in - iter f tl - else fail_match - ;; - - let a3 h a = (h, a) - ;; - - let rec cartesian xs ys = let a74 = is_empty xs in - if a74 - then [] - else let a76 = is_empty xs in - let a75 = not a76 in - if a75 - then let h = list_head xs in - let tl = list_tail xs in - let a79 = cartesian tl ys in - let a78 = a3 h in - let a77 = map a78 ys in - append a77 a79 - else fail_match - ;; - - let main = let a82 = (3::[]) in - let a81 = (2::a82) in - let a80 = (1::a81) in - let () = iter print_int a80 in - let a90 = (4::[]) in - let a89 = (3::a90) in - let a88 = (2::a89) in - let a87 = (1::a88) in - let a86 = (2::[]) in - let a85 = (1::a86) in - let a84 = cartesian a85 a87 in - let a83 = length a84 in - let () = print_int a83 in - 0 - ;; - Типы после приведения в ANF: - val length : 'a list -> int - val a1 : int -> 'a list -> int - val length_tail : 'a list -> int - val map : ('a -> 'b) -> 'a list -> 'b list - val append : 'a list -> 'a list -> 'a list - val a2 : 'a list list -> 'a list - val concat : 'a list list -> 'a list - val iter : ('a -> unit) -> 'a list -> unit - val a3 : 'a -> 'b -> 'a * 'b - val cartesian : 'a list -> 'b list -> 'a * 'b list - val main : int diff --git a/FML/tests/anf_runner.ml b/FML/tests/anf_runner.ml deleted file mode 100644 index 00509e6b3..000000000 --- a/FML/tests/anf_runner.ml +++ /dev/null @@ -1,39 +0,0 @@ -(** Copyright 2024-2025, Dmitry Pilyuk, Aleksandr Rozhkov *) - -(** SPDX-License-Identifier: LGPL-2.1 *) - -open Fml_lib.Parser -open Fml_lib.Inferencer -open Fml_lib.Inf_pprint -open Fml_lib.Pattern_elim -open Fml_lib.Alpha_conv -open Fml_lib.Lambda_lifting -open Fml_lib.Closure_conv -open Fml_lib.Anf -open Fml_lib.Anf_ast - -let () = - let input = Stdio.In_channel.input_all Stdlib.stdin in - let parse_and_infer input = - match parse input with - | Ok parsed -> - (match run_program_inferencer parsed with - | Ok types -> Ok (parsed, types) - | Error _ -> Error (Format.asprintf "Infer error.")) - | Error e -> Error (Format.sprintf "Parsing error: %s" e) - in - match parse_and_infer input with - | Ok (ast, _) -> - let bind, cnt, ast = run_pe ast in - let bind, cnt, ast = run_alpha_conv bind cnt ast in - let ast = run_cc ast in - let bind, cnt, ast = run_ll bind cnt ast in - let _, _, ast = run_anf bind cnt ast in - let result = Format.asprintf "%a" pp_anf_program ast in - let () = Format.printf "%a" pp_anf_program ast in - let () = Format.printf "\nТипы после приведения в ANF:\n" in - (match parse_and_infer result with - | Ok (_, (env, names_list)) -> print_program_type env names_list - | Error e -> Format.printf "%s" e) - | Error message -> Format.printf "%s" message -;; diff --git a/FML/tests/closure_conv_manytest.t b/FML/tests/closure_conv_manytest.t deleted file mode 100644 index 9f91dd0d9..000000000 --- a/FML/tests/closure_conv_manytest.t +++ /dev/null @@ -1,287 +0,0 @@ - $ ./closure_conv_runner.exe << EOF - > let fac n = - > let rec fack n k = - > if n<=1 then k 1 - > else fack (n - 1) ((fun k n m -> k (m * n)) k n) - > in - > fack n (fun x -> x) - > EOF - let fac = (fun n -> let rec fack = (fun a0 k -> if ((( <= ) a0) 1) - then (k 1) - else ((fack ((( - ) a0) 1)) (((fun a1 a2 m -> (a1 ((( * ) m) a2))) k) a0))) in - ((fack n) (fun x -> x))) - $ ./closure_conv_runner.exe < manytests/typed/001fac.ml - let rec fac = (fun n -> if ((( <= ) n) 1) - then 1 - else ((( * ) n) (fac ((( - ) n) 1)))) - - let main = let () = (print_int (fac 4)) in - 0 - - $ ./closure_conv_runner.exe < manytests/typed/002fac.ml - let rec fac_cps = (fun n k -> if ((( = ) n) 1) - then (k 1) - else ((fac_cps ((( - ) n) 1)) (((fun k n p -> (k ((( * ) p) n))) k) n))) - - let main = let () = (print_int ((fac_cps 4) (fun a0 -> a0))) in - 0 - - $ ./closure_conv_runner.exe < manytests/typed/003fib.ml - let rec fib_acc = (fun a b n -> if ((( = ) n) 1) - then b - else let n1 = ((( - ) n) 1) in - let ab = ((( + ) a) b) in - (((fib_acc b) ab) n1)) - - let rec fib = (fun n -> if ((( < ) n) 2) - then n - else ((( + ) (fib ((( - ) n) 1))) (fib ((( - ) n) 2)))) - - let main = let () = (print_int (((fib_acc 0) 1) 4)) in - let () = (print_int (fib 4)) in - 0 - - $ ./closure_conv_runner.exe < manytests/typed/004manyargs.ml - let wrap = (fun f -> if ((( = ) 1) 1) - then f - else f) - - let test3 = (fun a b c -> let a0 = (print_int a) in - let a1 = (print_int b) in - let a2 = (print_int c) in - 0) - - let test10 = (fun a b c d e f g h i j -> ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) a) b)) c)) d)) e)) f)) g)) h)) i)) j)) - - let main = let rez = (((((((((((wrap test10) 1) 10) 100) 1000) 10000) 100000) 1000000) 10000000) 100000000) 1000000000) in - let () = (print_int rez) in - let temp2 = ((((wrap test3) 1) 10) 100) in - 0 - - $ ./closure_conv_runner.exe < manytests/typed/005fix.ml - let rec fix = (fun f x -> ((f (fix f)) x)) - - let fac = (fun self n -> if ((( <= ) n) 1) - then 1 - else ((( * ) n) (self ((( - ) n) 1)))) - - let main = let () = (print_int ((fix fac) 6)) in - 0 - - $ ./closure_conv_runner.exe < manytests/typed/006partial.ml - let foo = (fun b -> if b - then (fun foo -> ((( + ) foo) 2)) - else (fun foo -> ((( * ) foo) 10))) - - let a0 = (fun x -> ((foo true) ((foo false) ((foo true) ((foo false) x))))) - - let main = let () = (print_int (a0 11)) in - 0 - - $ ./closure_conv_runner.exe < manytests/typed/006partial2.ml - let foo = (fun a b c -> let () = (print_int a) in - let () = (print_int b) in - let () = (print_int c) in - ((( + ) a) ((( * ) b) c))) - - let main = let a0 = (foo 1) in - let a1 = (a0 2) in - let a2 = (a1 3) in - let () = (print_int a2) in - 0 - $ ./closure_conv_runner.exe < manytests/typed/006partial3.ml - let foo = (fun a -> let () = (print_int a) in - (fun b -> let () = (print_int b) in - (fun c -> (print_int c)))) - - let main = let () = (((foo 4) 8) 9) in - 0 - $ ./closure_conv_runner.exe < manytests/typed/007order.ml - let _start = (fun a0 a1 a a2 b _c a3 d __ -> let a4 = (a0, a1, a2, a3) in - let () = (print_int ((( + ) a) b)) in - let () = (print_int __) in - ((( + ) ((( / ) ((( * ) a) b)) _c)) d)) - - let main = (print_int (((((((((_start (print_int 1)) (print_int 2)) 3) (print_int 4)) 100) 1000) (print_int (( ~- ) 1))) 10000) (( ~- ) 555555))) - $ ./closure_conv_runner.exe < manytests/typed/008ascription.ml - let addi = (fun f g x -> ((f x) (g x))) - - let main = let () = (print_int (((addi (fun x b -> if b - then ((( + ) x) 1) - else ((( * ) x) 2))) (fun _start -> ((( = ) ((( / ) _start) 2)) 0))) 4)) in - 0 - - $ ./closure_conv_runner.exe < manytests/typed/009let_poly.ml - let temp = let f = (fun x -> x) in - ((f 1), (f true)) - - $ ./closure_conv_runner.exe < manytests/typed/011mapcps.ml - let rec map = (fun f xs k -> if (is_empty xs) - then (k []) - else if (not (is_empty xs)) - then let h = (list_head xs) in - let tl = (list_tail xs) in - (((map f) tl) ((((fun f h k a0 -> (k ((f h)::a0))) f) h) k)) - else fail_match) - - let rec iter = (fun f xs -> if (is_empty xs) - then () - else if (not (is_empty xs)) - then let h = (list_head xs) in - let tl = (list_tail xs) in - let w = (f h) in - ((iter f) tl) - else fail_match) - - let main = ((iter print_int) (((map (fun x -> ((( + ) x) 1))) (1::(2::(3::[])))) (fun x -> x))) - $ ./closure_conv_runner.exe < manytests/typed/012fibcps.ml - let rec fib = (fun n k -> if ((( < ) n) 2) - then (k n) - else ((fib ((( - ) n) 1)) ((((fun fib k n a -> ((fib ((( - ) n) 2)) (((fun a k b -> (k ((( + ) a) b))) a) k))) fib) k) n))) - - let main = (print_int ((fib 6) (fun x -> x))) - $ ./closure_conv_runner.exe < manytests/typed/013foldfoldr.ml - let id = (fun x -> x) - - let rec fold_right = (fun f acc xs -> if (is_empty xs) - then acc - else if (not (is_empty xs)) - then let h = (list_head xs) in - let tl = (list_tail xs) in - ((f h) (((fold_right f) acc) tl)) - else fail_match) - - let foldl = (fun f a bs -> ((((fold_right ((fun f b g x -> (g ((f x) b))) f)) id) bs) a)) - - let main = (print_int (((foldl (fun x y -> ((( * ) x) y))) 1) (1::(2::(3::[]))))) - - $ ./closure_conv_runner.exe < manytests/typed/015tuples.ml - let rec fix = (fun f x -> ((f (fix f)) x)) - - let map = (fun f p -> let a = ((tuple_element p) 0) in - let b = ((tuple_element p) 1) in - ((f a), (f b))) - - let fixpoly = (fun l -> ((fix (fun self a0 -> ((map (((fun a0 self li x -> ((li (self a0)) x)) a0) self)) a0))) l)) - - let feven = (fun p n -> let e = ((tuple_element p) 0) in - let o = ((tuple_element p) 1) in - if ((( = ) n) 0) - then 1 - else (o ((( - ) n) 1))) - - let fodd = (fun p n -> let e = ((tuple_element p) 0) in - let o = ((tuple_element p) 1) in - if ((( = ) n) 0) - then 0 - else (e ((( - ) n) 1))) - - let tie = (fixpoly (feven, fodd)) - - let rec meven = (fun n -> if ((( = ) n) 0) - then 1 - else (modd ((( - ) n) 1))) - and modd = (fun n -> if ((( = ) n) 0) - then 1 - else (meven ((( - ) n) 1))) - - let main = let () = (print_int (modd 1)) in - let () = (print_int (meven 2)) in - let even = ((tuple_element tie) 0) in - let odd = ((tuple_element tie) 1) in - let () = (print_int (odd 3)) in - let () = (print_int (even 4)) in - 0 - - $ ./closure_conv_runner.exe < manytests/typed/016lists.ml - let rec length = (fun xs -> if (is_empty xs) - then 0 - else if (not (is_empty xs)) - then let h = (list_head xs) in - let tl = (list_tail xs) in - ((( + ) 1) (length tl)) - else fail_match) - - let length_tail = let rec helper = (fun acc xs -> if (is_empty xs) - then acc - else if (not (is_empty xs)) - then let h = (list_head xs) in - let tl = (list_tail xs) in - ((helper ((( + ) acc) 1)) tl) - else fail_match) in - (helper 0) - - let rec map = (fun f xs -> if (is_empty xs) - then [] - else if ((( && ) (not (is_empty xs))) (is_empty (list_tail xs))) - then let a = (list_head xs) in - ((f a)::[]) - else if ((( && ) (not (is_empty xs))) (is_empty (list_tail (list_tail xs)))) - then let a = (list_head xs) in - let b = (list_head (list_tail xs)) in - ((f a)::((f b)::[])) - else if ((( && ) (not (is_empty xs))) (is_empty (list_tail (list_tail (list_tail xs))))) - then let a = (list_head xs) in - let b = (list_head (list_tail xs)) in - let c = (list_head (list_tail (list_tail xs))) in - ((f a)::((f b)::((f c)::[]))) - else if (not (is_empty xs)) - then let a = (list_head xs) in - let b = (list_head (list_tail xs)) in - let c = (list_head (list_tail (list_tail xs))) in - let d = (list_head (list_tail (list_tail (list_tail xs)))) in - let tl = (list_tail (list_tail (list_tail (list_tail xs)))) in - ((f a)::((f b)::((f c)::((f d)::((map f) tl))))) - else fail_match) - - let rec append = (fun xs ys -> if (is_empty xs) - then ys - else if (not (is_empty xs)) - then let x = (list_head xs) in - let a0 = (list_tail xs) in - (x::((append a0) ys)) - else fail_match) - - let concat = let rec helper = (fun xs -> if (is_empty xs) - then [] - else if (not (is_empty xs)) - then let h = (list_head xs) in - let tl = (list_tail xs) in - ((append h) (helper tl)) - else fail_match) in - helper - - let rec iter = (fun f xs -> if (is_empty xs) - then () - else if (not (is_empty xs)) - then let h = (list_head xs) in - let tl = (list_tail xs) in - let () = (f h) in - ((iter f) tl) - else fail_match) - - let rec cartesian = (fun xs ys -> if (is_empty xs) - then [] - else if (not (is_empty xs)) - then let h = (list_head xs) in - let tl = (list_tail xs) in - ((append ((map ((fun h a -> (h, a)) h)) ys)) ((cartesian tl) ys)) - else fail_match) - - let main = let () = ((iter print_int) (1::(2::(3::[])))) in - let () = (print_int (length ((cartesian (1::(2::[]))) (1::(2::(3::(4::[]))))))) in - 0 - - $ ./closure_conv_runner.exe < manytests/do_not_type/001.ml - Infer error: - $ ./closure_conv_runner.exe < manytests/do_not_type/002if.ml - Infer error: - $ ./closure_conv_runner.exe < manytests/do_not_type/003occurs.ml - Infer error: - - $ ./closure_conv_runner.exe < manytests/do_not_type/004let_poly.ml - Infer error: - - $ ./closure_conv_runner.exe < manytests/do_not_type/015tuples.ml - Infer error: - diff --git a/FML/tests/closure_conv_runner.ml b/FML/tests/closure_conv_runner.ml deleted file mode 100644 index c38de4987..000000000 --- a/FML/tests/closure_conv_runner.ml +++ /dev/null @@ -1,29 +0,0 @@ -(** Copyright 2024-2025, Dmitry Pilyuk, Aleksandr Rozhkov *) - -(** SPDX-License-Identifier: LGPL-2.1 *) - -open Fml_lib.Parser -open Fml_lib.Inferencer -open Fml_lib.Pe_ast -open Fml_lib.Pattern_elim -open Fml_lib.Alpha_conv -open Fml_lib.Closure_conv - -let () = - let input = Stdio.In_channel.input_all Stdlib.stdin in - let parse_and_infer input = - match parse input with - | Ok parsed -> - (match run_program_inferencer parsed with - | Ok _ -> Ok parsed - | Error _ -> Error (Format.asprintf "Infer error:")) - | Error e -> Error (Format.sprintf "Parsing error: %s" e) - in - match parse_and_infer input with - | Ok ast -> - let bind, cnt, ast = run_pe ast in - let _, _, ast = run_alpha_conv bind cnt ast in - let ast = run_cc ast in - Format.printf "%a" pp_pe_program ast - | Error message -> Format.printf "%s" message -;; diff --git a/FML/tests/dune b/FML/tests/dune index d6e91198c..35762f071 100644 --- a/FML/tests/dune +++ b/FML/tests/dune @@ -20,17 +20,7 @@ (modules inferencer_runner) (libraries fml_lib stdio)) -(executable - (name pe_runner) - (public_name pe_runner) - (modules pe_runner) - (libraries fml_lib stdio)) -(executable - (name alpha_conv_runner) - (public_name alpha_conv_runner) - (modules alpha_conv_runner) - (libraries fml_lib stdio)) (executable (name a_conv_runner) @@ -50,24 +40,6 @@ (modules lambda_lift_runner) (libraries fml_lib stdio)) -(executable - (name closure_conv_runner) - (public_name closure_conv_runner) - (modules closure_conv_runner) - (libraries fml_lib stdio)) - -(executable - (name lambda_lifting_runner) - (public_name lambda_lifting_runner) - (modules lambda_lifting_runner) - (libraries fml_lib stdio)) - -(executable - (name anf_runner) - (public_name anf_runner) - (modules anf_runner) - (libraries fml_lib stdio)) - (cram (applies_to parser_manytests) (deps diff --git a/FML/tests/lambda_lifting_manytests.t b/FML/tests/lambda_lifting_manytests.t deleted file mode 100644 index cf294901d..000000000 --- a/FML/tests/lambda_lifting_manytests.t +++ /dev/null @@ -1,333 +0,0 @@ - $ ./lambda_lifting_runner.exe << EOF - > let fac n = - > let rec fack n k = - > if n<=1 then k 1 - > else fack (n - 1) ((fun k n m -> k (m * n)) k n) - > in - > fack n (fun x -> x) - > EOF - let a4 = (fun a1 a2 m -> (a1 ((( * ) m) a2))) - - let rec a3 = (fun a0 k -> if ((( <= ) a0) 1) - then (k 1) - else ((a3 ((( - ) a0) 1)) ((a4 k) a0))) - - let a5 = (fun x -> x) - - let fac = (fun n -> ((a3 n) a5)) - $ ./lambda_lifting_runner.exe < manytests/typed/001fac.ml - let rec fac = (fun n -> if ((( <= ) n) 1) - then 1 - else ((( * ) n) (fac ((( - ) n) 1)))) - - let main = let () = (print_int (fac 4)) in - 0 - - $ ./lambda_lifting_runner.exe < manytests/typed/002fac.ml - let a1 = (fun k n p -> (k ((( * ) p) n))) - - let rec fac_cps = (fun n k -> if ((( = ) n) 1) - then (k 1) - else ((fac_cps ((( - ) n) 1)) ((a1 k) n))) - - let a2 = (fun a0 -> a0) - - let main = let () = (print_int ((fac_cps 4) a2)) in - 0 - - $ ./lambda_lifting_runner.exe < manytests/typed/003fib.ml - let rec fib_acc = (fun a b n -> if ((( = ) n) 1) - then b - else let n1 = ((( - ) n) 1) in - let ab = ((( + ) a) b) in - (((fib_acc b) ab) n1)) - - let rec fib = (fun n -> if ((( < ) n) 2) - then n - else ((( + ) (fib ((( - ) n) 1))) (fib ((( - ) n) 2)))) - - let main = let () = (print_int (((fib_acc 0) 1) 4)) in - let () = (print_int (fib 4)) in - 0 - - $ ./lambda_lifting_runner.exe < manytests/typed/004manyargs.ml - let wrap = (fun f -> if ((( = ) 1) 1) - then f - else f) - - let test3 = (fun a b c -> let a0 = (print_int a) in - let a1 = (print_int b) in - let a2 = (print_int c) in - 0) - - let test10 = (fun a b c d e f g h i j -> ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) a) b)) c)) d)) e)) f)) g)) h)) i)) j)) - - let main = let rez = (((((((((((wrap test10) 1) 10) 100) 1000) 10000) 100000) 1000000) 10000000) 100000000) 1000000000) in - let () = (print_int rez) in - let temp2 = ((((wrap test3) 1) 10) 100) in - 0 - - $ ./lambda_lifting_runner.exe < manytests/typed/005fix.ml - let rec fix = (fun f x -> ((f (fix f)) x)) - - let fac = (fun self n -> if ((( <= ) n) 1) - then 1 - else ((( * ) n) (self ((( - ) n) 1)))) - - let main = let () = (print_int ((fix fac) 6)) in - 0 - - $ ./lambda_lifting_runner.exe < manytests/typed/006partial.ml - let a1 = (fun foo -> ((( + ) foo) 2)) - - let a2 = (fun foo -> ((( * ) foo) 10)) - - let foo = (fun b -> if b - then a1 - else a2) - - let a0 = (fun x -> ((foo true) ((foo false) ((foo true) ((foo false) x))))) - - let main = let () = (print_int (a0 11)) in - 0 - - $ ./lambda_lifting_runner.exe < manytests/typed/006partial2.ml - let foo = (fun a b c -> let () = (print_int a) in - let () = (print_int b) in - let () = (print_int c) in - ((( + ) a) ((( * ) b) c))) - - let main = let a0 = (foo 1) in - let a1 = (a0 2) in - let a2 = (a1 3) in - let () = (print_int a2) in - 0 - $ ./lambda_lifting_runner.exe < manytests/typed/006partial3.ml - let a1 = (fun c -> (print_int c)) - - let a0 = (fun b -> let () = (print_int b) in - a1) - - let foo = (fun a -> let () = (print_int a) in - a0) - - let main = let () = (((foo 4) 8) 9) in - 0 - $ ./lambda_lifting_runner.exe < manytests/typed/007order.ml - let _start = (fun a0 a1 a a2 b _c a3 d __ -> let a4 = (a0, a1, a2, a3) in - let () = (print_int ((( + ) a) b)) in - let () = (print_int __) in - ((( + ) ((( / ) ((( * ) a) b)) _c)) d)) - - let main = (print_int (((((((((_start (print_int 1)) (print_int 2)) 3) (print_int 4)) 100) 1000) (print_int (( ~- ) 1))) 10000) (( ~- ) 555555))) - $ ./lambda_lifting_runner.exe < manytests/typed/008ascription.ml - let addi = (fun f g x -> ((f x) (g x))) - - let a0 = (fun x b -> if b - then ((( + ) x) 1) - else ((( * ) x) 2)) - - let a1 = (fun _start -> ((( = ) ((( / ) _start) 2)) 0)) - - let main = let () = (print_int (((addi a0) a1) 4)) in - 0 - - $ ./lambda_lifting_runner.exe < manytests/typed/009let_poly.ml - let a0 = (fun x -> x) - - let temp = ((a0 1), (a0 true)) - - $ ./lambda_lifting_runner.exe < manytests/typed/011mapcps.ml - let a1 = (fun f h k a0 -> (k ((f h)::a0))) - - let rec map = (fun f xs k -> if (is_empty xs) - then (k []) - else if (not (is_empty xs)) - then let h = (list_head xs) in - let tl = (list_tail xs) in - (((map f) tl) (((a1 f) h) k)) - else fail_match) - - let rec iter = (fun f xs -> if (is_empty xs) - then () - else if (not (is_empty xs)) - then let h = (list_head xs) in - let tl = (list_tail xs) in - let w = (f h) in - ((iter f) tl) - else fail_match) - - let a2 = (fun x -> ((( + ) x) 1)) - - let a3 = (fun x -> x) - - let main = ((iter print_int) (((map a2) (1::(2::(3::[])))) a3)) - $ ./lambda_lifting_runner.exe < manytests/typed/012fibcps.ml - let a1 = (fun a k b -> (k ((( + ) a) b))) - - let a0 = (fun fib k n a -> ((fib ((( - ) n) 2)) ((a1 a) k))) - - let rec fib = (fun n k -> if ((( < ) n) 2) - then (k n) - else ((fib ((( - ) n) 1)) (((a0 fib) k) n))) - - let a2 = (fun x -> x) - - let main = (print_int ((fib 6) a2)) - $ ./lambda_lifting_runner.exe < manytests/typed/013foldfoldr.ml - let id = (fun x -> x) - - let rec fold_right = (fun f acc xs -> if (is_empty xs) - then acc - else if (not (is_empty xs)) - then let h = (list_head xs) in - let tl = (list_tail xs) in - ((f h) (((fold_right f) acc) tl)) - else fail_match) - - let a0 = (fun f b g x -> (g ((f x) b))) - - let foldl = (fun f a bs -> ((((fold_right (a0 f)) id) bs) a)) - - let a1 = (fun x y -> ((( * ) x) y)) - - let main = (print_int (((foldl a1) 1) (1::(2::(3::[]))))) - - $ ./lambda_lifting_runner.exe < manytests/typed/015tuples.ml - let rec fix = (fun f x -> ((f (fix f)) x)) - - let map = (fun f p -> let a = ((tuple_element p) 0) in - let b = ((tuple_element p) 1) in - ((f a), (f b))) - - let a2 = (fun a0 self li x -> ((li (self a0)) x)) - - let a1 = (fun self a0 -> ((map ((a2 a0) self)) a0)) - - let fixpoly = (fun l -> ((fix a1) l)) - - let feven = (fun p n -> let e = ((tuple_element p) 0) in - let o = ((tuple_element p) 1) in - if ((( = ) n) 0) - then 1 - else (o ((( - ) n) 1))) - - let fodd = (fun p n -> let e = ((tuple_element p) 0) in - let o = ((tuple_element p) 1) in - if ((( = ) n) 0) - then 0 - else (e ((( - ) n) 1))) - - let tie = (fixpoly (feven, fodd)) - - let rec meven = (fun n -> if ((( = ) n) 0) - then 1 - else (modd ((( - ) n) 1))) - and modd = (fun n -> if ((( = ) n) 0) - then 1 - else (meven ((( - ) n) 1))) - - let main = let () = (print_int (modd 1)) in - let () = (print_int (meven 2)) in - let even = ((tuple_element tie) 0) in - let odd = ((tuple_element tie) 1) in - let () = (print_int (odd 3)) in - let () = (print_int (even 4)) in - 0 - - $ ./lambda_lifting_runner.exe < manytests/typed/016lists.ml - let rec length = (fun xs -> if (is_empty xs) - then 0 - else if (not (is_empty xs)) - then let h = (list_head xs) in - let tl = (list_tail xs) in - ((( + ) 1) (length tl)) - else fail_match) - - let rec a1 = (fun acc xs -> if (is_empty xs) - then acc - else if (not (is_empty xs)) - then let h = (list_head xs) in - let tl = (list_tail xs) in - ((a1 ((( + ) acc) 1)) tl) - else fail_match) - - let length_tail = (a1 0) - - let rec map = (fun f xs -> if (is_empty xs) - then [] - else if ((( && ) (not (is_empty xs))) (is_empty (list_tail xs))) - then let a = (list_head xs) in - ((f a)::[]) - else if ((( && ) (not (is_empty xs))) (is_empty (list_tail (list_tail xs)))) - then let a = (list_head xs) in - let b = (list_head (list_tail xs)) in - ((f a)::((f b)::[])) - else if ((( && ) (not (is_empty xs))) (is_empty (list_tail (list_tail (list_tail xs))))) - then let a = (list_head xs) in - let b = (list_head (list_tail xs)) in - let c = (list_head (list_tail (list_tail xs))) in - ((f a)::((f b)::((f c)::[]))) - else if (not (is_empty xs)) - then let a = (list_head xs) in - let b = (list_head (list_tail xs)) in - let c = (list_head (list_tail (list_tail xs))) in - let d = (list_head (list_tail (list_tail (list_tail xs)))) in - let tl = (list_tail (list_tail (list_tail (list_tail xs)))) in - ((f a)::((f b)::((f c)::((f d)::((map f) tl))))) - else fail_match) - - let rec append = (fun xs ys -> if (is_empty xs) - then ys - else if (not (is_empty xs)) - then let x = (list_head xs) in - let a0 = (list_tail xs) in - (x::((append a0) ys)) - else fail_match) - - let rec a2 = (fun xs -> if (is_empty xs) - then [] - else if (not (is_empty xs)) - then let h = (list_head xs) in - let tl = (list_tail xs) in - ((append h) (a2 tl)) - else fail_match) - - let concat = a2 - - let rec iter = (fun f xs -> if (is_empty xs) - then () - else if (not (is_empty xs)) - then let h = (list_head xs) in - let tl = (list_tail xs) in - let () = (f h) in - ((iter f) tl) - else fail_match) - - let a3 = (fun h a -> (h, a)) - - let rec cartesian = (fun xs ys -> if (is_empty xs) - then [] - else if (not (is_empty xs)) - then let h = (list_head xs) in - let tl = (list_tail xs) in - ((append ((map (a3 h)) ys)) ((cartesian tl) ys)) - else fail_match) - - let main = let () = ((iter print_int) (1::(2::(3::[])))) in - let () = (print_int (length ((cartesian (1::(2::[]))) (1::(2::(3::(4::[]))))))) in - 0 - - $ ./lambda_lifting_runner.exe < manytests/do_not_type/001.ml - Infer error: - $ ./lambda_lifting_runner.exe < manytests/do_not_type/002if.ml - Infer error: - $ ./lambda_lifting_runner.exe < manytests/do_not_type/003occurs.ml - Infer error: - - $ ./lambda_lifting_runner.exe < manytests/do_not_type/004let_poly.ml - Infer error: - - $ ./lambda_lifting_runner.exe < manytests/do_not_type/015tuples.ml - Infer error: - diff --git a/FML/tests/lambda_lifting_runner.ml b/FML/tests/lambda_lifting_runner.ml deleted file mode 100644 index f1ed8fe27..000000000 --- a/FML/tests/lambda_lifting_runner.ml +++ /dev/null @@ -1,31 +0,0 @@ -(** Copyright 2024-2025, Dmitry Pilyuk, Aleksandr Rozhkov *) - -(** SPDX-License-Identifier: LGPL-2.1 *) - -open Fml_lib.Parser -open Fml_lib.Inferencer -open Fml_lib.Pe_ast -open Fml_lib.Pattern_elim -open Fml_lib.Alpha_conv -open Fml_lib.Lambda_lifting -open Fml_lib.Closure_conv - -let () = - let input = Stdio.In_channel.input_all Stdlib.stdin in - let parse_and_infer input = - match parse input with - | Ok parsed -> - (match run_program_inferencer parsed with - | Ok _ -> Ok parsed - | Error _ -> Error (Format.asprintf "Infer error:")) - | Error e -> Error (Format.sprintf "Parsing error: %s" e) - in - match parse_and_infer input with - | Ok ast -> - let bind, cnt, ast = run_pe ast in - let bind, cnt, ast = run_alpha_conv bind cnt ast in - let ast = run_cc ast in - let _, _, ast = run_ll bind cnt ast in - Format.printf "%a" pp_pe_program ast - | Error message -> Format.printf "%s" message -;; diff --git a/FML/tests/match_elimination_manytest.t b/FML/tests/match_elimination_manytest.t index 1dacd1a3d..182cce41a 100644 --- a/FML/tests/match_elimination_manytest.t +++ b/FML/tests/match_elimination_manytest.t @@ -1,3 +1,9 @@ + $ ./match_elimination_runner.exe << EOF + > let f = let y x = x + 1 in y 3;; + > EOF + let f = let y = (fun x -> ((( + ) x) 1)) in + (y 3) + $ ./match_elimination_runner.exe << EOF > let length xs = match xs with > | a::b::[] -> 2 diff --git a/FML/tests/pe_manytests.t b/FML/tests/pe_manytests.t deleted file mode 100644 index de50077e5..000000000 --- a/FML/tests/pe_manytests.t +++ /dev/null @@ -1,292 +0,0 @@ - $ ./pe_runner.exe << EOF - > let length xs = match xs with - > | a::b::[] -> 2 - > | a::[] -> 1 - > | [] -> 0 - > EOF - - $ ./pe_runner.exe << EOF - > let f n _ = n - > - > let main = let () = print_int (f 6 5) in 0 - > EOF - let f = (fun n a0 -> n) - - let main = let () = (print_int ((f 6) 5)) in - 0 - - $ ./pe_runner.exe < manytests/typed/001fac.ml - let rec fac = (fun n -> if ((( <= ) n) 1) - then 1 - else ((( * ) n) (fac ((( - ) n) 1)))) - - let main = let () = (print_int (fac 4)) in - 0 - - $ ./pe_runner.exe < manytests/typed/002fac.ml - let rec fac_cps = (fun n k -> if ((( = ) n) 1) - then (k 1) - else ((fac_cps ((( - ) n) 1)) (fun p -> (k ((( * ) p) n))))) - - let main = let () = (print_int ((fac_cps 4) (fun print_int -> print_int))) in - 0 - - $ ./pe_runner.exe < manytests/typed/003fib.ml - let rec fib_acc = (fun a b n -> if ((( = ) n) 1) - then b - else let n1 = ((( - ) n) 1) in - let ab = ((( + ) a) b) in - (((fib_acc b) ab) n1)) - - let rec fib = (fun n -> if ((( < ) n) 2) - then n - else ((( + ) (fib ((( - ) n) 1))) (fib ((( - ) n) 2)))) - - let main = let () = (print_int (((fib_acc 0) 1) 4)) in - let () = (print_int (fib 4)) in - 0 - - $ ./pe_runner.exe < manytests/typed/004manyargs.ml - let wrap = (fun f -> if ((( = ) 1) 1) - then f - else f) - - let test3 = (fun a b c -> let a = (print_int a) in - let b = (print_int b) in - let c = (print_int c) in - 0) - - let test10 = (fun a b c d e f g h i j -> ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) a) b)) c)) d)) e)) f)) g)) h)) i)) j)) - - let main = let rez = (((((((((((wrap test10) 1) 10) 100) 1000) 10000) 100000) 1000000) 10000000) 100000000) 1000000000) in - let () = (print_int rez) in - let temp2 = ((((wrap test3) 1) 10) 100) in - 0 - - $ ./pe_runner.exe < manytests/typed/005fix.ml - let rec fix = (fun f x -> ((f (fix f)) x)) - - let fac = (fun self n -> if ((( <= ) n) 1) - then 1 - else ((( * ) n) (self ((( - ) n) 1)))) - - let main = let () = (print_int ((fix fac) 6)) in - 0 - - $ ./pe_runner.exe < manytests/typed/006partial.ml - let foo = (fun b -> if b - then (fun foo -> ((( + ) foo) 2)) - else (fun foo -> ((( * ) foo) 10))) - - let foo = (fun x -> ((foo true) ((foo false) ((foo true) ((foo false) x))))) - - let main = let () = (print_int (foo 11)) in - 0 - - $ ./pe_runner.exe < manytests/typed/006partial2.ml - let foo = (fun a b c -> let () = (print_int a) in - let () = (print_int b) in - let () = (print_int c) in - ((( + ) a) ((( * ) b) c))) - - let main = let foo = (foo 1) in - let foo = (foo 2) in - let foo = (foo 3) in - let () = (print_int foo) in - 0 - $ ./pe_runner.exe < manytests/typed/006partial3.ml - let foo = (fun a -> let () = (print_int a) in - (fun b -> let () = (print_int b) in - (fun c -> (print_int c)))) - - let main = let () = (((foo 4) 8) 9) in - 0 - $ ./pe_runner.exe < manytests/typed/007order.ml - let _start = (fun a0 a1 a a2 b _c a3 d __ -> let a4 = (a0, a1, a2, a3) in - let () = (print_int ((( + ) a) b)) in - let () = (print_int __) in - ((( + ) ((( / ) ((( * ) a) b)) _c)) d)) - - let main = (print_int (((((((((_start (print_int 1)) (print_int 2)) 3) (print_int 4)) 100) 1000) (print_int (( ~- ) 1))) 10000) (( ~- ) 555555))) - $ ./pe_runner.exe < manytests/typed/008ascription.ml - let addi = (fun f g x -> ((f x) (g x))) - - let main = let () = (print_int (((addi (fun x b -> if b - then ((( + ) x) 1) - else ((( * ) x) 2))) (fun _start -> ((( = ) ((( / ) _start) 2)) 0))) 4)) in - 0 - - $ ./pe_runner.exe < manytests/typed/009let_poly.ml - let temp = let f = (fun x -> x) in - ((f 1), (f true)) - - $ ./pe_runner.exe < manytests/typed/011mapcps.ml - let rec map = (fun f xs k -> if (is_empty xs) - then (k []) - else if (not (is_empty xs)) - then let h = (list_head xs) in - let tl = (list_tail xs) in - (((map f) tl) (fun tl -> (k ((f h)::tl)))) - else fail_match) - - let rec iter = (fun f xs -> if (is_empty xs) - then () - else if (not (is_empty xs)) - then let h = (list_head xs) in - let tl = (list_tail xs) in - let w = (f h) in - ((iter f) tl) - else fail_match) - - let main = ((iter print_int) (((map (fun x -> ((( + ) x) 1))) (1::(2::(3::[])))) (fun x -> x))) - $ ./pe_runner.exe < manytests/typed/012fibcps.ml - let rec fib = (fun n k -> if ((( < ) n) 2) - then (k n) - else ((fib ((( - ) n) 1)) (fun a -> ((fib ((( - ) n) 2)) (fun b -> (k ((( + ) a) b))))))) - - let main = (print_int ((fib 6) (fun x -> x))) - $ ./pe_runner.exe < manytests/typed/013foldfoldr.ml - let id = (fun x -> x) - - let rec fold_right = (fun f acc xs -> if (is_empty xs) - then acc - else if (not (is_empty xs)) - then let h = (list_head xs) in - let tl = (list_tail xs) in - ((f h) (((fold_right f) acc) tl)) - else fail_match) - - let foldl = (fun f a bs -> ((((fold_right (fun b g x -> (g ((f x) b)))) id) bs) a)) - - let main = (print_int (((foldl (fun x y -> ((( * ) x) y))) 1) (1::(2::(3::[]))))) - - $ ./pe_runner.exe < manytests/typed/015tuples.ml - let rec fix = (fun f x -> ((f (fix f)) x)) - - let map = (fun f p -> let a = ((tuple_element p) 0) in - let b = ((tuple_element p) 1) in - ((f a), (f b))) - - let fixpoly = (fun l -> ((fix (fun self l -> ((map (fun li x -> ((li (self l)) x))) l))) l)) - - let feven = (fun p n -> let e = ((tuple_element p) 0) in - let o = ((tuple_element p) 1) in - if ((( = ) n) 0) - then 1 - else (o ((( - ) n) 1))) - - let fodd = (fun p n -> let e = ((tuple_element p) 0) in - let o = ((tuple_element p) 1) in - if ((( = ) n) 0) - then 0 - else (e ((( - ) n) 1))) - - let tie = (fixpoly (feven, fodd)) - - let rec meven = (fun n -> if ((( = ) n) 0) - then 1 - else (modd ((( - ) n) 1))) - and modd = (fun n -> if ((( = ) n) 0) - then 1 - else (meven ((( - ) n) 1))) - - let main = let () = (print_int (modd 1)) in - let () = (print_int (meven 2)) in - let even = ((tuple_element tie) 0) in - let odd = ((tuple_element tie) 1) in - let () = (print_int (odd 3)) in - let () = (print_int (even 4)) in - 0 - - $ ./pe_runner.exe < manytests/typed/016lists.ml - let rec length = (fun xs -> if (is_empty xs) - then 0 - else if (not (is_empty xs)) - then let h = (list_head xs) in - let tl = (list_tail xs) in - ((( + ) 1) (length tl)) - else fail_match) - - let length_tail = let rec helper = (fun acc xs -> if (is_empty xs) - then acc - else if (not (is_empty xs)) - then let h = (list_head xs) in - let tl = (list_tail xs) in - ((helper ((( + ) acc) 1)) tl) - else fail_match) in - (helper 0) - - let rec map = (fun f xs -> if (is_empty xs) - then [] - else if ((( && ) (not (is_empty xs))) (is_empty (list_tail xs))) - then let a = (list_head xs) in - ((f a)::[]) - else if ((( && ) (not (is_empty xs))) (is_empty (list_tail (list_tail xs)))) - then let a = (list_head xs) in - let b = (list_head (list_tail xs)) in - ((f a)::((f b)::[])) - else if ((( && ) (not (is_empty xs))) (is_empty (list_tail (list_tail (list_tail xs))))) - then let a = (list_head xs) in - let b = (list_head (list_tail xs)) in - let c = (list_head (list_tail (list_tail xs))) in - ((f a)::((f b)::((f c)::[]))) - else if (not (is_empty xs)) - then let a = (list_head xs) in - let b = (list_head (list_tail xs)) in - let c = (list_head (list_tail (list_tail xs))) in - let d = (list_head (list_tail (list_tail (list_tail xs)))) in - let tl = (list_tail (list_tail (list_tail (list_tail xs)))) in - ((f a)::((f b)::((f c)::((f d)::((map f) tl))))) - else fail_match) - - let rec append = (fun xs ys -> if (is_empty xs) - then ys - else if (not (is_empty xs)) - then let x = (list_head xs) in - let xs = (list_tail xs) in - (x::((append xs) ys)) - else fail_match) - - let concat = let rec helper = (fun xs -> if (is_empty xs) - then [] - else if (not (is_empty xs)) - then let h = (list_head xs) in - let tl = (list_tail xs) in - ((append h) (helper tl)) - else fail_match) in - helper - - let rec iter = (fun f xs -> if (is_empty xs) - then () - else if (not (is_empty xs)) - then let h = (list_head xs) in - let tl = (list_tail xs) in - let () = (f h) in - ((iter f) tl) - else fail_match) - - let rec cartesian = (fun xs ys -> if (is_empty xs) - then [] - else if (not (is_empty xs)) - then let h = (list_head xs) in - let tl = (list_tail xs) in - ((append ((map (fun a -> (h, a))) ys)) ((cartesian tl) ys)) - else fail_match) - - let main = let () = ((iter print_int) (1::(2::(3::[])))) in - let () = (print_int (length ((cartesian (1::(2::[]))) (1::(2::(3::(4::[]))))))) in - 0 - - $ ./pe_runner.exe < manytests/do_not_type/001.ml - Infer error: - $ ./pe_runner.exe < manytests/do_not_type/002if.ml - Infer error: - $ ./pe_runner.exe < manytests/do_not_type/003occurs.ml - Infer error: - - $ ./pe_runner.exe < manytests/do_not_type/004let_poly.ml - Infer error: - - $ ./pe_runner.exe < manytests/do_not_type/015tuples.ml - Infer error: - diff --git a/FML/tests/pe_runner.ml b/FML/tests/pe_runner.ml deleted file mode 100644 index 2c78a8146..000000000 --- a/FML/tests/pe_runner.ml +++ /dev/null @@ -1,25 +0,0 @@ -(** Copyright 2024-2025, Dmitry Pilyuk, Aleksandr Rozhkov *) - -(** SPDX-License-Identifier: LGPL-2.1 *) - -open Fml_lib.Parser -open Fml_lib.Inferencer -open Fml_lib.Pe_ast -open Fml_lib.Pattern_elim - -let () = - let input = Stdio.In_channel.input_all Stdlib.stdin in - let parse_and_infer input = - match parse input with - | Ok parsed -> - (match run_program_inferencer parsed with - | Ok _ -> Ok parsed - | Error _ -> Error (Format.asprintf "Infer error:")) - | Error e -> Error (Format.sprintf "Parsing error: %s" e) - in - match parse_and_infer input with - | Ok ast -> - let _, _, converted = run_pe ast in - Format.printf "%a" pp_pe_program converted - | Error message -> Format.printf "%s" message -;; From 858c036e7602f26ba3926a164b4c99a5597164a5 Mon Sep 17 00:00:00 2001 From: RozhkovAleksandr Date: Wed, 9 Apr 2025 12:26:02 +0300 Subject: [PATCH 64/92] clean code (monade add in common) --- FML/lib/anf/a_conv.ml | 63 ------------- FML/lib/anf/anf.ml | 5 ++ FML/lib/anf/common.ml | 148 +++++++++++++++---------------- FML/lib/anf/lambda_lift.ml | 72 +-------------- FML/lib/anf/match_elimination.ml | 72 +-------------- FML/lib/dune | 2 + 6 files changed, 82 insertions(+), 280 deletions(-) create mode 100644 FML/lib/anf/anf.ml diff --git a/FML/lib/anf/a_conv.ml b/FML/lib/anf/a_conv.ml index 03d3102af..b7213961b 100644 --- a/FML/lib/anf/a_conv.ml +++ b/FML/lib/anf/a_conv.ml @@ -5,69 +5,6 @@ open Base open Ast open Common - -module StateMonad : sig - include Base.Monad.Infix - - val return : 'a -> 'a t - val ( let* ) : 'a t -> ('a -> 'b t) -> 'b t - - module RList : sig - val fold_left : 'a list -> init:'b t -> f:('b -> 'a -> 'b t) -> 'b t - end - - module RMap : sig - val fold_left - : ('a, 'b, 'c) Base.Map.t - -> init:'d t - -> f:('a -> 'b -> 'd -> 'd t) - -> 'd t - end - - val fresh : int t - val run : 'a t -> 'a -end = struct - type 'a t = int -> int * 'a (* State and Result monad composition *) - - let ( >>= ) : 'a 'b. 'a t -> ('a -> 'b t) -> 'b t = - fun m f s -> - let s', v' = m s in - f v' s' - ;; - - let ( >>| ) : 'a 'b. 'a t -> ('a -> 'b) -> 'b t = - fun m f s -> - let s', x = m s in - s', f x - ;; - - let return v last = last, v - let bind x ~f = x >>= f - let fresh last = last + 1, last (* Get new state *) - let ( let* ) x f = bind x ~f (* Syntax sugar for bind *) - - module RMap = struct - (* Classic map folding. *) - let fold_left mp ~init ~f = - Base.Map.fold mp ~init ~f:(fun ~key ~data acc -> - let* acc = acc in - f key data acc) - ;; - end - - module RList = struct - (* Classic list folding. *) - let fold_left lt ~init ~f = - Base.List.fold_left lt ~init ~f:(fun acc item -> - let* acc = acc in - f acc item) - ;; - end - - (* Run and get the internal value. *) - let run m = snd (m 0) -end - open StateMonad let get_new_id n name = String.concat [ name; "_ac"; Int.to_string n ] diff --git a/FML/lib/anf/anf.ml b/FML/lib/anf/anf.ml new file mode 100644 index 000000000..024e96ed8 --- /dev/null +++ b/FML/lib/anf/anf.ml @@ -0,0 +1,5 @@ +(** Copyright 2024-2025, Dmitry Pilyuk, Aleksandr Rozhkov *) + +(** SPDX-License-Identifier: LGPL-2.1 *) + + diff --git a/FML/lib/anf/common.ml b/FML/lib/anf/common.ml index 53f122160..658a2cab8 100644 --- a/FML/lib/anf/common.ml +++ b/FML/lib/anf/common.ml @@ -3,39 +3,38 @@ (** SPDX-License-Identifier: LGPL-2.1 *) open Base -open Ast module StrMap = struct type 'a t = (string, 'a, String.comparator_witness) Map.t let empty = Map.empty (module String) let singleton str = Map.singleton (module String) str - let find m str = Map.find m str let add = Map.add let update = Map.update + let find m str = Map.find m str let merge_two fst snd = Map.merge_skewed fst snd ~combine:(fun ~key:_ _ v2 -> v2) end let builtins = [ "( + )" ; "( - )" + ; "( > )" + ; "( <= )" + ; "( && )" ; "( / )" ; "( * )" ; "( < )" - ; "( > )" - ; "( <= )" ; "( >= )" ; "( <> )" ; "( = )" - ; "( != )" - ; "( && )" + ; "( != )" ; "( || )" ; "not" ; "print_int" - ; "list_head" - ; "list_tail" ; "tuple_element" ; "is_empty" + ; "list_head" + ; "list_tail" ; "fail_match" ] ;; @@ -46,89 +45,84 @@ module StrSet = struct type t = (string, String.comparator_witness) Set.t + let add = Set.add let empty = Set.empty (module String) let singleton str = Set.singleton (module String) str let union = Set.union - let union_list lst = Set.union_list (module String) lst - let find s str = Set.mem s str - let add = Set.add let to_list = Set.to_list let of_list = Set.of_list (module String) let fold = Set.fold let diff = Set.diff + let union_list lst = Set.union_list (module String) lst + let find s str = Set.mem s str + end -type bindings = (int, Int.comparator_witness) Set.t - -let contains ng id = - match Set.find ng ~f:(Int.equal id) with - | Some _ -> true - | None -> false -;; - -module MonadCounter = struct - open Base - - type 'a t = bindings * int -> bindings * int * 'a - - let return x (binds, var) = binds, var, x - - let fresh (binds, var) = - let rec helper num = if contains binds num then helper (num + 1) else num in - let next = helper var in - binds, next + 1, next +module StateMonad : sig + include Base.Monad.Infix + + val return : 'a -> 'a t + val ( let* ) : 'a t -> ('a -> 'b t) -> 'b t + + module RList : sig + val fold_left : 'a list -> init:'b t -> f:('b -> 'a -> 'b t) -> 'b t + val fold_right : 'a list -> init:'b t -> f:('a -> 'b -> 'b t) -> 'b t + end + + module RMap : sig + val fold_left + : ('a, 'b, 'c) Base.Map.t + -> init:'d t + -> f:('a -> 'b -> 'd -> 'd t) + -> 'd t + end + + val fresh : int t + val run : 'a t -> 'a +end = struct + type 'a t = int -> int * 'a (* State and Result monad composition *) + + let ( >>= ) : 'a 'b. 'a t -> ('a -> 'b t) -> 'b t = + fun m f s -> + let s', v' = m s in + f v' s' ;; - let bind (m : 'a t) (f : 'a -> 'b t) : 'b t = - fun t -> - let binds, var, x = m t in - f x (binds, var) + let ( >>| ) : 'a 'b. 'a t -> ('a -> 'b) -> 'b t = + fun m f s -> + let s', x = m s in + s', f x ;; - let ( >>= ) = bind - let ( let* ) = bind - - let ( >>| ) (m : 'a t) (f : 'a -> 'b) : 'b t = - fun t -> - let binds, var, x = m t in - binds, var, f x - ;; + let return v last = last, v + let bind x ~f = x >>= f + let fresh last = last + 1, last (* Get new state *) + let ( let* ) x f = bind x ~f (* Syntax sugar for bind *) - let run (m : 'a t) binds start = m (binds, start) - - let map (xs : 'a list) ~(f : 'a -> 'b t) : 'b list t = - let* xs = - List.fold xs ~init:(return []) ~f:(fun acc x -> + module RMap = struct + (* Classic map folding. *) + let fold_left mp ~init ~f = + Base.Map.fold mp ~init ~f:(fun ~key ~data acc -> let* acc = acc in - let* x = f x in - return (x :: acc)) - in - return @@ List.rev xs - ;; - - let fold_left (xs : 'a list) ~(init : 'b t) ~(f : 'b -> 'a -> 'b t) : 'b t = - List.fold xs ~init ~f:(fun acc x -> - let* acc = acc in - f acc x) - ;; - - let fold_right xs ~init ~f = - List.fold_right xs ~init ~f:(fun x acc -> - let* acc = acc in - f x acc) - ;; -end - -let rec get_binds_pat = function - | PConstraint (pat, _) -> get_binds_pat pat - | PAny | PConst _ | PNill | PUnit -> StrSet.empty - | PIdentifier ident -> StrSet.singleton ident - | PCons (p1, p2) -> StrSet.union (get_binds_pat p1) (get_binds_pat p2) - | PTuple pl -> - Base.List.fold pl ~init:StrSet.empty ~f:(fun acc p -> - StrSet.union acc (get_binds_pat p)) -;; + f key data acc) + ;; + end + + module RList = struct + (* Classic list folding. *) + let fold_left lt ~init ~f = + Base.List.fold_left lt ~init ~f:(fun acc item -> + let* acc = acc in + f acc item) + ;; + let fold_right lt ~init ~f = + Base.List.fold_right lt ~init ~f:(fun item acc -> + let* acc = acc in + f item acc) + ;; + end -let get_id i = "a" ^ Int.to_string i -let empty = Base.Map.empty (module Base.String) + (* Run and get the internal value. *) + let run m = snd (m 0) +end \ No newline at end of file diff --git a/FML/lib/anf/lambda_lift.ml b/FML/lib/anf/lambda_lift.ml index d00b922dd..2218efc98 100644 --- a/FML/lib/anf/lambda_lift.ml +++ b/FML/lib/anf/lambda_lift.ml @@ -4,80 +4,12 @@ open Me_ast open Base +open Common +open StateMonad -module StateMonad : sig - include Base.Monad.Infix - - val return : 'a -> 'a t - val ( let* ) : 'a t -> ('a -> 'b t) -> 'b t - - module RList : sig - val fold_left : 'a list -> init:'b t -> f:('b -> 'a -> 'b t) -> 'b t - val fold_right : 'a list -> init:'b t -> f:('a -> 'b -> 'b t) -> 'b t - end - - module RMap : sig - val fold_left - : ('a, 'b, 'c) Base.Map.t - -> init:'d t - -> f:('a -> 'b -> 'd -> 'd t) - -> 'd t - end - - val fresh : int t - val run : 'a t -> 'a -end = struct - type 'a t = int -> int * 'a (* State and Result monad composition *) - - let ( >>= ) : 'a 'b. 'a t -> ('a -> 'b t) -> 'b t = - fun m f s -> - let s', v' = m s in - f v' s' - ;; - - let ( >>| ) : 'a 'b. 'a t -> ('a -> 'b) -> 'b t = - fun m f s -> - let s', x = m s in - s', f x - ;; - - let return v last = last, v - let bind x ~f = x >>= f - let fresh last = last + 1, last (* Get new state *) - let ( let* ) x f = bind x ~f (* Syntax sugar for bind *) - - module RMap = struct - (* Classic map folding. *) - let fold_left mp ~init ~f = - Base.Map.fold mp ~init ~f:(fun ~key ~data acc -> - let* acc = acc in - f key data acc) - ;; - end - - module RList = struct - (* Classic list folding. *) - let fold_left lt ~init ~f = - Base.List.fold_left lt ~init ~f:(fun acc item -> - let* acc = acc in - f acc item) - ;; - - let fold_right lt ~init ~f = - Base.List.fold_right lt ~init ~f:(fun item acc -> - let* acc = acc in - f item acc) - ;; - end - - (* Run and get the internal value. *) - let run m = snd (m 0) -end let get_new_id n name = Base.String.concat [ name; "_ll"; Int.to_string n ] -open StateMonad - (* добавляем в списочек свободные переменные *) let rec free_vars expr bound = match expr with diff --git a/FML/lib/anf/match_elimination.ml b/FML/lib/anf/match_elimination.ml index c92dd922d..98849a4e4 100644 --- a/FML/lib/anf/match_elimination.ml +++ b/FML/lib/anf/match_elimination.ml @@ -5,79 +5,11 @@ open Ast open Base open Me_ast - -module StateMonad : sig - include Base.Monad.Infix - - val return : 'a -> 'a t - val ( let* ) : 'a t -> ('a -> 'b t) -> 'b t - - module RList : sig - val fold_left : 'a list -> init:'b t -> f:('b -> 'a -> 'b t) -> 'b t - val fold_right : 'a list -> init:'b t -> f:('a -> 'b -> 'b t) -> 'b t - end - - module RMap : sig - val fold_left - : ('a, 'b, 'c) Base.Map.t - -> init:'d t - -> f:('a -> 'b -> 'd -> 'd t) - -> 'd t - end - - val fresh : int t - val run : 'a t -> 'a -end = struct - type 'a t = int -> int * 'a (* State and Result monad composition *) - - let ( >>= ) : 'a 'b. 'a t -> ('a -> 'b t) -> 'b t = - fun m f s -> - let s', v' = m s in - f v' s' - ;; - - let ( >>| ) : 'a 'b. 'a t -> ('a -> 'b) -> 'b t = - fun m f s -> - let s', x = m s in - s', f x - ;; - - let return v last = last, v - let bind x ~f = x >>= f - let fresh last = last + 1, last (* Get new state *) - let ( let* ) x f = bind x ~f (* Syntax sugar for bind *) - - module RMap = struct - (* Classic map folding. *) - let fold_left mp ~init ~f = - Base.Map.fold mp ~init ~f:(fun ~key ~data acc -> - let* acc = acc in - f key data acc) - ;; - end - - module RList = struct - (* Classic list folding. *) - let fold_left lt ~init ~f = - Base.List.fold_left lt ~init ~f:(fun acc item -> - let* acc = acc in - f acc item) - ;; - - let fold_right lt ~init ~f = - Base.List.fold_right lt ~init ~f:(fun item acc -> - let* acc = acc in - f item acc) - ;; - end - - (* Run and get the internal value. *) - let run m = snd (m 0) -end +open Common +open StateMonad let get_new_id n name = String.concat [ name; "_me"; Int.to_string n ] -open StateMonad let const_to_pe_const = function | CInt a -> Me_Cint a diff --git a/FML/lib/dune b/FML/lib/dune index 229137cac..6139f7251 100644 --- a/FML/lib/dune +++ b/FML/lib/dune @@ -14,6 +14,8 @@ Me_ast A_conv Match_elimination + Anf_ast + Anf Lambda_lift) (modules_without_implementation inf_errors) (libraries base angstrom llvm llvm.analysis llvm.executionengine) From dd26e54ee2214203af5740ab06eb08e57133e11c Mon Sep 17 00:00:00 2001 From: Dmitry Pilyuk Date: Thu, 10 Apr 2025 01:53:13 +0300 Subject: [PATCH 65/92] Closure conversion fix --- FML/lib/anf/anf.ml | 2 - FML/lib/anf/c_conv.ml | 122 ++++++++++ FML/lib/anf/common.ml | 15 +- FML/lib/anf/lambda_lift.ml | 62 +++--- FML/lib/anf/match_elimination.ml | 21 +- FML/lib/dune | 1 + FML/tests/c_conv_manytest.t | 371 +++++++++++++++++++++++++++++++ FML/tests/c_conv_runner.ml | 29 +++ FML/tests/dune | 12 +- 9 files changed, 573 insertions(+), 62 deletions(-) create mode 100644 FML/lib/anf/c_conv.ml create mode 100644 FML/tests/c_conv_manytest.t create mode 100644 FML/tests/c_conv_runner.ml diff --git a/FML/lib/anf/anf.ml b/FML/lib/anf/anf.ml index 024e96ed8..cf84644ec 100644 --- a/FML/lib/anf/anf.ml +++ b/FML/lib/anf/anf.ml @@ -1,5 +1,3 @@ (** Copyright 2024-2025, Dmitry Pilyuk, Aleksandr Rozhkov *) (** SPDX-License-Identifier: LGPL-2.1 *) - - diff --git a/FML/lib/anf/c_conv.ml b/FML/lib/anf/c_conv.ml new file mode 100644 index 000000000..f86372245 --- /dev/null +++ b/FML/lib/anf/c_conv.ml @@ -0,0 +1,122 @@ +(** Copyright 2024-2025, Dmitry Pilyuk, Aleksandr Rozhkov *) + +(** SPDX-License-Identifier: LGPL-2.1 *) + +open Me_ast +open Common + +let rec expr_free_vars binded = + let open StrSet in + function + | Me_EConst _ | Me_ENill | Me_EUnit -> StrSet.empty + | Me_EIdentifier id -> if find binded id then empty else singleton id + | Me_EIf (e1, e2, e3) -> + union_list + [ expr_free_vars binded e1; expr_free_vars binded e2; expr_free_vars binded e3 ] + | Me_ECons (e1, e2) | Me_EApp (e1, e2) -> + union (expr_free_vars binded e1) (expr_free_vars binded e2) + | Me_ETuple es -> + List.fold_left (fun acc expr -> union acc (expr_free_vars binded expr)) empty es + | Me_EFun (args, expr) -> + let binded = union binded (of_list args) in + expr_free_vars binded expr + | Me_ELet (NoRec, name, e1, e2) -> + let binded' = add binded name in + union (expr_free_vars binded e1) (expr_free_vars binded' e2) + | Me_ELet (Rec, name, e1, e2) -> + let binded = add binded name in + union (expr_free_vars binded e1) (expr_free_vars binded e2) +;; + +let rec cc_expr env bindings = function + | Me_EIdentifier id -> + (match StrMap.find bindings id with + | Some new_expr -> new_expr + | None -> Me_EIdentifier id) + | Me_ETuple es -> Me_ETuple (List.map (fun expr -> cc_expr env bindings expr) es) + | Me_EIf (e1, e2, e3) -> + Me_EIf (cc_expr env bindings e1, cc_expr env bindings e2, cc_expr env bindings e3) + | Me_ECons (e1, e2) -> Me_ECons (cc_expr env bindings e1, cc_expr env bindings e2) + | Me_EApp (e1, e2) -> Me_EApp (cc_expr env bindings e1, cc_expr env bindings e2) + | Me_EFun (args, expr) as e -> + let fvs = StrSet.to_list (expr_free_vars env e) in + let body = cc_expr env StrMap.empty expr in + let e_fun = Me_EFun (fvs @ args, body) in + List.fold_left (fun acc arg -> Me_EApp (acc, Me_EIdentifier arg)) e_fun fvs + | Me_ELet (NoRec, name, e1, e2) -> + let new_e1, bindings = + match e1 with + | Me_EFun (args, expr) as e -> + let fvs = StrSet.to_list (expr_free_vars env e) in + let body = cc_expr env StrMap.empty expr in + let new_expr = Me_EFun (fvs @ args, body) in + let apply = + List.fold_left + (fun acc arg -> Me_EApp (acc, Me_EIdentifier arg)) + (Me_EIdentifier name) + fvs + in + new_expr, StrMap.update bindings name ~f:(fun _ -> apply) + | expr -> cc_expr env StrMap.empty expr, bindings + in + let new_e2 = cc_expr env bindings e2 in + Me_ELet (NoRec, name, new_e1, new_e2) + | Me_ELet (Rec, name, e1, e2) -> + let env = StrSet.add env name in + let new_e1, bindings = + match e1 with + | Me_EFun (args, expr) as e -> + let fvs = StrSet.to_list (expr_free_vars env e) in + let apply = + List.fold_left + (fun acc arg -> Me_EApp (acc, Me_EIdentifier arg)) + (Me_EIdentifier name) + fvs + in + let body = cc_expr env (StrMap.singleton name apply) expr in + let new_expr = Me_EFun (fvs @ args, body) in + new_expr, StrMap.update bindings name ~f:(fun _ -> apply) + | expr -> cc_expr env StrMap.empty expr, bindings + in + let new_e2 = cc_expr env bindings e2 in + Me_ELet (Rec, name, new_e1, new_e2) + | expr -> expr +;; + +(* let cc_nonrec env decls = + let decls = List.map (fun (name, expr) -> name, cc_expr env StrMap.empty expr) decls in + let env = List.fold_left (fun acc (name, _) -> StrSet.add acc name) env decls in + decls, env + ;; + + let cc_rec env decls = + let env = List.fold_left (fun acc (name, _) -> StrSet.add acc name) env decls in + let decls = List.map (fun (name, expr) -> name, cc_expr env StrMap.empty expr) decls in + decls, env + ;; *) + +let cc_decl env = function + | Me_Nonrec decls -> + let decls = + List.map (fun (name, expr) -> name, cc_expr env StrMap.empty expr) decls + in + let env = List.fold_left (fun acc (name, _) -> StrSet.add acc name) env decls in + Me_Nonrec decls, env + | Me_Rec decls -> + let env = List.fold_left (fun acc (name, _) -> StrSet.add acc name) env decls in + let decls = + List.map (fun (name, expr) -> name, cc_expr env StrMap.empty expr) decls + in + Me_Rec decls, env +;; + +let cc_program ast = + let builtins = StrSet.of_list builtins in + let rec helper last_env = function + | [] -> [] + | hd :: tl -> + let decls, env = cc_decl last_env hd in + decls :: helper env tl + in + helper builtins ast +;; diff --git a/FML/lib/anf/common.ml b/FML/lib/anf/common.ml index 658a2cab8..44d5c2bb7 100644 --- a/FML/lib/anf/common.ml +++ b/FML/lib/anf/common.ml @@ -27,19 +27,19 @@ let builtins = ; "( >= )" ; "( <> )" ; "( = )" - ; "( != )" + ; "( != )" ; "( || )" ; "not" ; "print_int" - ; "tuple_element" + ; "tuple_get" ; "is_empty" - ; "list_head" - ; "list_tail" - ; "fail_match" + ; "is_cons" + ; "hd_list_get" + ; "tl_list_get" + ; "failwith" ] ;; - module StrSet = struct open Base @@ -55,7 +55,6 @@ module StrSet = struct let diff = Set.diff let union_list lst = Set.union_list (module String) lst let find s str = Set.mem s str - end module StateMonad : sig @@ -125,4 +124,4 @@ end = struct (* Run and get the internal value. *) let run m = snd (m 0) -end \ No newline at end of file +end diff --git a/FML/lib/anf/lambda_lift.ml b/FML/lib/anf/lambda_lift.ml index 2218efc98..028a3af6b 100644 --- a/FML/lib/anf/lambda_lift.ml +++ b/FML/lib/anf/lambda_lift.ml @@ -7,16 +7,14 @@ open Base open Common open StateMonad - let get_new_id n name = Base.String.concat [ name; "_ll"; Int.to_string n ] (* добавляем в списочек свободные переменные *) let rec free_vars expr bound = match expr with | Me_EUnit | Me_ENill | Me_EConst _ -> [] - | Me_EIdentifier x -> if Set.mem bound x then [] else [x] - | Me_EIf (e1, e2, e3) -> - free_vars e1 bound @ free_vars e2 bound @ free_vars e3 bound + | Me_EIdentifier x -> if Set.mem bound x then [] else [ x ] + | Me_EIf (e1, e2, e3) -> free_vars e1 bound @ free_vars e2 bound @ free_vars e3 bound | Me_EFun (args, body) -> let bound' = List.fold_left ~f:Set.add ~init:bound args in free_vars body bound' @@ -24,39 +22,41 @@ let rec free_vars expr bound = | Me_ELet (_, name, e1, e2) -> let fv1 = free_vars e1 bound in let fv2 = free_vars e2 (Set.add bound name) in - fv1 @ fv2 + fv1 @ fv2 | Me_ECons (e1, e2) -> free_vars e1 bound @ free_vars e2 bound - | Me_ETuple lst -> List.fold_left lst ~init:[] ~f:(fun acc e -> acc @ free_vars e bound) + | Me_ETuple lst -> List.fold_left lst ~init:[] ~f:(fun acc e -> acc @ free_vars e bound) ;; let rec ll_expr expr = match expr with | Me_EUnit | Me_ENill | Me_EConst _ | Me_EIdentifier _ -> return ([], expr) | Me_EIf (e1, e2, e3) -> - let* (defs1, e1') = ll_expr e1 in - let* (defs2, e2') = ll_expr e2 in - let* (defs3, e3') = ll_expr e3 in + let* defs1, e1' = ll_expr e1 in + let* defs2, e2' = ll_expr e2 in + let* defs3, e3' = ll_expr e3 in return (defs1 @ defs2 @ defs3, Me_EIf (e1', e2', e3')) | Me_EApp (e1, e2) -> - let* (defs1, e1') = ll_expr e1 in - let* (defs2, e2') = ll_expr e2 in + let* defs1, e1' = ll_expr e1 in + let* defs2, e2' = ll_expr e2 in return (defs1 @ defs2, Me_EApp (e1', e2')) | Me_ECons (e1, e2) -> - let* (defs1, e1') = ll_expr e1 in - let* (defs2, e2') = ll_expr e2 in - return (defs1 @ defs2, Me_ECons (e1', e2')) + let* defs1, e1' = ll_expr e1 in + let* defs2, e2' = ll_expr e2 in + return (defs1 @ defs2, Me_ECons (e1', e2')) | Me_ETuple lst -> let* results = - RList.fold_left lst ~init:(return ([], [])) ~f:(fun (acc_defs, acc_exprs) e -> - let* (defs, e') = ll_expr e in - return (acc_defs @ defs, acc_exprs @ [ e' ])) + RList.fold_left + lst + ~init:(return ([], [])) + ~f:(fun (acc_defs, acc_exprs) e -> + let* defs, e' = ll_expr e in + return (acc_defs @ defs, acc_exprs @ [ e' ])) in let defs, exprs = results in return (defs, Me_ETuple exprs) - | Me_ELet (flag, name, e1, e2) -> - let* (defs1, e1') = ll_expr e1 in - let* (defs2, e2') = ll_expr e2 in + let* defs1, e1' = ll_expr e1 in + let* defs2, e2' = ll_expr e2 in (* e1' — это анонимная функция (а функции у нас только так) *) (match e1' with | Me_EFun (args, body) -> @@ -65,7 +65,7 @@ let rec ll_expr expr = let fvs = free_vars e1' (Set.of_list (module String) args) in let new_args = fvs @ args in let new_fun = Me_EFun (new_args, body) in - let def = (new_name, new_fun) in + let def = new_name, new_fun in let call_expr = List.fold_left (List.map ~f:(fun x -> Me_EIdentifier x) fvs) @@ -73,18 +73,16 @@ let rec ll_expr expr = ~f:(fun acc arg -> Me_EApp (acc, arg)) in return (defs1 @ [ def ] @ defs2, Me_ELet (flag, name, call_expr, e2')) - | _ -> - return (defs1 @ defs2, Me_ELet (flag, name, e1', e2'))) - + | _ -> return (defs1 @ defs2, Me_ELet (flag, name, e1', e2'))) | Me_EFun (args, body) -> let* id = fresh in let name = get_new_id id "lam" in let bound = Set.of_list (module String) args in let fvs = free_vars expr bound in let all_args = fvs @ args in - let* (defs, body') = ll_expr body in + let* defs, body' = ll_expr body in let new_fun = Me_EFun (all_args, body') in - let def = (name, new_fun) in + let def = name, new_fun in let call_expr = List.fold_left (List.map ~f:(fun x -> Me_EIdentifier x) fvs) @@ -95,8 +93,8 @@ let rec ll_expr expr = ;; let ll_binding (name, expr) = - let* (defs, expr') = ll_expr expr in - return (defs @ [ (name, expr') ]) + let* defs, expr' = ll_expr expr in + return (defs @ [ name, expr' ]) ;; let ll_decl decl = @@ -110,9 +108,9 @@ let ll_decl decl = return (Me_Nonrec all_defs) | Me_Rec bindings -> RList.fold_left bindings ~init:(return []) ~f:(fun acc (name, expr) -> - let* (defs, expr') = ll_expr expr in - return (acc @ defs @ [ (name, expr') ])) >>= fun all -> - return (Me_Rec all) + let* defs, expr' = ll_expr expr in + return (acc @ defs @ [ name, expr' ])) + >>= fun all -> return (Me_Rec all) ;; let lambda_lift prog = @@ -120,4 +118,4 @@ let lambda_lift prog = (RList.fold_left prog ~init:(return []) ~f:(fun acc decl -> let* d = ll_decl decl in return (acc @ [ d ]))) -;; \ No newline at end of file +;; diff --git a/FML/lib/anf/match_elimination.ml b/FML/lib/anf/match_elimination.ml index 98849a4e4..59b21c85c 100644 --- a/FML/lib/anf/match_elimination.ml +++ b/FML/lib/anf/match_elimination.ml @@ -10,7 +10,6 @@ open StateMonad let get_new_id n name = String.concat [ name; "_me"; Int.to_string n ] - let const_to_pe_const = function | CInt a -> Me_Cint a | CBool a -> Me_CBool a @@ -77,13 +76,7 @@ let rec expr_to_mexpr expr = let transformed_e = List.mapi ids_list ~f:(fun i id -> let get_expr = - EApplication ( - EApplication ( - EIdentifier "tuple_get", - e1 - ), - EConst (CInt i) - ) + EApplication (EApplication (EIdentifier "tuple_get", e1), EConst (CInt i)) in PIdentifier id, get_expr) in @@ -200,23 +193,20 @@ and desugar_match e branches = return @@ Me_ELet (NoRec, var, expr, Me_EIf (cond, bound_rhs, rest_expr))) ;; - - let decl_to_pe_decl decls = let process_binding pat expr = let ids = pattern_remove pat in match ids with | [ id ] -> let* e' = expr_to_mexpr expr in - return [ (id, e') ] + return [ id, e' ] | _ -> let* tmp_id_num = fresh in let tmp_var = get_new_id tmp_id_num "tmp" in let* e' = expr_to_mexpr expr in let tmp_expr = Me_EIdentifier tmp_var in let bindings = - pattern_bindings tmp_expr pat - |> List.map ~f:(fun (id, expr) -> (id, expr)) + pattern_bindings tmp_expr pat |> List.map ~f:(fun (id, expr) -> id, expr) in return ((tmp_var, e') :: bindings) in @@ -228,7 +218,6 @@ let decl_to_pe_decl decls = return (acc @ bindings)) in return @@ Me_Nonrec converted - | RecDecl decls -> let* converted = RList.fold_left decls ~init:(return []) ~f:(fun acc (DDeclaration (pat, expr)) -> @@ -237,10 +226,10 @@ let decl_to_pe_decl decls = | [ id ] -> let* e' = expr_to_mexpr expr in return ((id, e') :: acc) - | _ -> - failwith "Simple patterns on rec, otherwise it's crazt") + | _ -> failwith "Simple patterns on rec, otherwise it's crazt") in return @@ Me_Rec (List.rev converted) +;; let match_elimination prog = StateMonad.run diff --git a/FML/lib/dune b/FML/lib/dune index 6139f7251..f14d6721c 100644 --- a/FML/lib/dune +++ b/FML/lib/dune @@ -13,6 +13,7 @@ Common Me_ast A_conv + C_conv Match_elimination Anf_ast Anf diff --git a/FML/tests/c_conv_manytest.t b/FML/tests/c_conv_manytest.t new file mode 100644 index 000000000..78f033010 --- /dev/null +++ b/FML/tests/c_conv_manytest.t @@ -0,0 +1,371 @@ + $ ./c_conv_runner.exe << EOF + > let f x = let g y = x + y in g 5;; + > EOF + let f = let y = (fun x -> ((( + ) x) 1)) in + (y 3) + + $ ./c_conv_runner.exe << EOF + > let length xs = match xs with + > | a::b::[] -> 2 + > | a::[] -> 1 + > | [] -> 0 + > EOF + let length = ((fun "no matching" xs -> if if (is_cons xs) + then if (is_cons (tl_list_get xs)) + then (is_empty (tl_list_get (tl_list_get xs))) + else false + else false + then let a = (hd_list_get xs) in + let b = (hd_list_get (tl_list_get xs)) in + 2 + else if if (is_cons xs) + then (is_empty (tl_list_get xs)) + else false + then let a = (hd_list_get xs) in + 1 + else if (is_empty xs) + then 0 + else (failwith "no matching")) "no matching") + + $ ./c_conv_runner.exe << EOF + > let is_empty x = x+1 + > let rec length xs = match xs with + > | [] -> 0 + > | _::tl -> 1 + length xs + > EOF + let is_empty_ac0 = (fun x -> ((( + ) x) 1)) + + let rec length = ((fun "no matching" xs -> if (is_empty xs) + then 0 + else if (is_cons xs) + then let _ = (hd_list_get xs) in + let tl = (tl_list_get xs) in + ((( + ) 1) (length xs)) + else (failwith "no matching")) "no matching") + + $ ./c_conv_runner.exe << EOF + > let (a, b) = (5,6) + > EOF + let tmp_me0 = (5, 6) + let a = (tuple_get (tmp_me0, 0)) + let b = (tuple_get (tmp_me0, 1)) + + $ ./c_conv_runner.exe << EOF + > let fac n = + > let rec fack n k = + > if n<=1 then k 1 + > else fack (n - 1) ((fun k n m -> k (m * n)) k n) + > in + > fack n (fun x -> x) + > EOF + let fac = (fun n -> let rec fack = (fun n_ac0 -> ((fun n_ac0 k -> if ((( <= ) n_ac0) 1) + then (k 1) + else ((fack ((( - ) n_ac0) 1)) (((fun k_ac1 -> ((fun k_ac1 n_ac2 -> (((fun k_ac1 n_ac2 m -> (k_ac1 ((( * ) m) n_ac2))) k_ac1) n_ac2)) k_ac1)) k) n_ac0))) n_ac0)) in + ((fack n) (fun x -> x))) + + $ ./c_conv_runner.exe << EOF + > let f x = match x with + > | 1 -> 12 + > | 12 -> 12 + > | _ -> 325 + > EOF + let f = (((fun "no matching" (=) x -> if (((=) x) 1) + then 12 + else if (((=) x) 12) + then 12 + else if true + then 325 + else (failwith "no matching")) "no matching") (=)) + + $ ./c_conv_runner.exe < manytests/typed/001fac.ml + let rec fac = (fun n -> if ((( <= ) n) 1) + then 1 + else ((( * ) n) (fac ((( - ) n) 1)))) + + let main = let () = (print_int (fac 4)) in + 0 + + $ ./c_conv_runner.exe < manytests/typed/002fac.ml + let rec fac_cps = (fun n -> ((fun n k -> if ((( = ) n) 1) + then (k 1) + else ((fac_cps ((( - ) n) 1)) (((fun k n p -> (k ((( * ) p) n))) k) n))) n)) + + let main = let () = (print_int ((fac_cps 4) (fun print_int_ac0 -> print_int_ac0))) in + 0 + + $ ./c_conv_runner.exe < manytests/typed/003fib.ml + let rec fib_acc = (fun a -> ((fun a b -> (((fun a b n -> if ((( = ) n) 1) + then b + else let n1 = ((( - ) n) 1) in + let ab = ((( + ) a) b) in + (((fib_acc b) ab) n1)) a) b)) a)) + + let rec fib = (fun n -> if ((( < ) n) 2) + then n + else ((( + ) (fib ((( - ) n) 1))) (fib ((( - ) n) 2)))) + + let main = let () = (print_int (((fib_acc 0) 1) 4)) in + let () = (print_int (fib 4)) in + 0 + + $ ./c_conv_runner.exe < manytests/typed/004manyargs.ml + let wrap = (fun f -> if ((( = ) 1) 1) + then f + else f) + + let test3 = (fun a -> ((fun a b -> (((fun a b c -> let a_ac0 = (print_int a) in + let b_ac1 = (print_int b) in + let c_ac2 = (print_int c) in + 0) a) b)) a)) + + let test10 = (fun a -> ((fun a b -> (((fun a b c -> ((((fun a b c d -> (((((fun a b c d e -> ((((((fun a b c d e f -> (((((((fun a b c d e f g -> ((((((((fun a b c d e f g h -> (((((((((fun a b c d e f g h i -> ((((((((((fun a b c d e f g h i j -> ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) a) b)) c)) d)) e)) f)) g)) h)) i)) j)) a) b) c) d) e) f) g) h) i)) a) b) c) d) e) f) g) h)) a) b) c) d) e) f) g)) a) b) c) d) e) f)) a) b) c) d) e)) a) b) c) d)) a) b) c)) a) b)) a)) + + let main = let rez = (((((((((((wrap test10) 1) 10) 100) 1000) 10000) 100000) 1000000) 10000000) 100000000) 1000000000) in + let () = (print_int rez) in + let temp2 = ((((wrap test3) 1) 10) 100) in + 0 + + $ ./c_conv_runner.exe < manytests/typed/005fix.ml + let rec fix = (fun f -> ((fun f x -> ((f (fix f)) x)) f)) + + let fac = (fun self -> ((fun self n -> if ((( <= ) n) 1) + then 1 + else ((( * ) n) (self ((( - ) n) 1)))) self)) + + let main = let () = (print_int ((fix fac) 6)) in + 0 + + $ ./c_conv_runner.exe < manytests/typed/006partial.ml + let foo = (fun b -> if b + then (fun foo -> ((( + ) foo) 2)) + else (fun foo -> ((( * ) foo) 10))) + + let foo_ac0 = (fun x -> ((foo true) ((foo false) ((foo true) ((foo false) x))))) + + let main = let () = (print_int (foo_ac0 11)) in + 0 + + $ ./c_conv_runner.exe < manytests/typed/006partial2.ml + let foo = (fun a -> ((fun a b -> (((fun a b c -> let () = (print_int a) in + let () = (print_int b) in + let () = (print_int c) in + ((( + ) a) ((( * ) b) c))) a) b)) a)) + + let main = let foo_ac0 = (foo 1) in + let foo_ac1 = (foo_ac0 2) in + let foo_ac2 = (foo_ac1 3) in + let () = (print_int foo_ac2) in + 0 + $ ./c_conv_runner.exe < manytests/typed/006partial3.ml + let foo = (fun a -> let () = (print_int a) in + (fun b -> let () = (print_int b) in + (fun c -> (print_int c)))) + + let main = let () = (((foo 4) 8) 9) in + 0 + $ ./c_conv_runner.exe < manytests/typed/007order.ml + let _start = (fun () -> (fun () -> (fun a -> ((fun a () -> ((fun a b -> (((fun a b _c -> ((((fun _c a b () -> ((((fun _c a b d -> (((((fun _c a b d __ -> let () = (print_int ((( + ) a) b)) in + let () = (print_int __) in + ((( + ) ((( / ) ((( * ) a) b)) _c)) d)) _c) a) b) d)) _c) a) b)) _c) a) b)) a) b)) a)) a)))) + + let main = (print_int (((((((((_start (print_int 1)) (print_int 2)) 3) (print_int 4)) 100) 1000) (print_int (( ~- ) 1))) 10000) (( ~- ) 555555))) + $ ./c_conv_runner.exe < manytests/typed/008ascription.ml + let addi = (fun f -> ((fun f g -> (((fun f g x -> ((f x) (g x))) f) g)) f)) + + let main = let () = (print_int (((addi (fun x -> ((fun x b -> if b + then ((( + ) x) 1) + else ((( * ) x) 2)) x))) (fun _start -> ((( = ) ((( / ) _start) 2)) 0))) 4)) in + 0 + + $ ./c_conv_runner.exe < manytests/typed/009let_poly.ml + let temp = let f = (fun x -> x) in + ((f 1), (f true)) + + $ ./c_conv_runner.exe < manytests/typed/011mapcps.ml + let rec map = ((fun "no matching" f -> (((fun "no matching" f xs -> ((((fun "no matching" f xs k -> if (is_empty xs) + then (k []) + else if (is_cons xs) + then let h = (hd_list_get xs) in + let tl = (tl_list_get xs) in + (((map f) tl) ((((fun f h k tl_ac0 -> (k ((f h)::tl_ac0))) f) h) k)) + else (failwith "no matching")) "no matching") f) xs)) "no matching") f)) "no matching") + + let rec iter = ((fun "no matching" f -> (((fun "no matching" f xs -> if (is_empty xs) + then () + else if (is_cons xs) + then let h = (hd_list_get xs) in + let tl = (tl_list_get xs) in + let w = (f h) in + ((iter f) tl) + else (failwith "no matching")) "no matching") f)) "no matching") + + let main = ((iter print_int) (((map (fun x -> ((( + ) x) 1))) (1::(2::(3::[])))) (fun x -> x))) + $ ./c_conv_runner.exe < manytests/typed/012fibcps.ml + let rec fib = (fun n -> ((fun n k -> if ((( < ) n) 2) + then (k n) + else ((fib ((( - ) n) 1)) (((fun k n a -> ((fib ((( - ) n) 2)) (((fun a k b -> (k ((( + ) a) b))) a) k))) k) n))) n)) + + let main = (print_int ((fib 6) (fun x -> x))) + $ ./c_conv_runner.exe < manytests/typed/013foldfoldr.ml + let id = (fun x -> x) + + let rec fold_right = ((fun "no matching" f -> (((fun "no matching" f acc -> ((((fun "no matching" acc f xs -> if (is_empty xs) + then acc + else if (is_cons xs) + then let h = (hd_list_get xs) in + let tl = (tl_list_get xs) in + ((f h) (((fold_right f) acc) tl)) + else (failwith "no matching")) "no matching") acc) f)) "no matching") f)) "no matching") + + let foldl = (fun f -> ((fun f a -> (((fun a f bs -> ((((fold_right ((fun f b -> (((fun b f g -> ((((fun b f g x -> (g ((f x) b))) b) f) g)) b) f)) f)) id) bs) a)) a) f)) f)) + + let main = (print_int (((foldl (fun x -> ((fun x y -> ((( * ) x) y)) x))) 1) (1::(2::(3::[]))))) + + $ ./c_conv_runner.exe < manytests/typed/015tuples.ml + let rec fix = (fun f -> ((fun f x -> ((f (fix f)) x)) f)) + + let map = (fun f -> ((fun f p -> let a = ((tuple_get p) 0) in + let b = ((tuple_get p) 1) in + ((f a), (f b))) f)) + + let fixpoly = (fun l -> ((fix (fun self -> ((fun self l_ac0 -> ((map (((fun l_ac0 self li -> ((((fun l_ac0 li self x -> ((li (self l_ac0)) x)) l_ac0) li) self)) l_ac0) self)) l_ac0)) self))) l)) + + let feven = (fun p -> ((fun p n -> let e = ((tuple_get p) 0) in + let o = ((tuple_get p) 1) in + if ((( = ) n) 0) + then 1 + else (o ((( - ) n) 1))) p)) + + let fodd = (fun p -> ((fun p n -> let e = ((tuple_get p) 0) in + let o = ((tuple_get p) 1) in + if ((( = ) n) 0) + then 0 + else (e ((( - ) n) 1))) p)) + + let tie = (fixpoly (feven, fodd)) + + let rec meven = (fun n -> if ((( = ) n) 0) + then 1 + else (modd ((( - ) n) 1))) + and modd = (fun n -> if ((( = ) n) 0) + then 1 + else (meven ((( - ) n) 1))) + + let main = let () = (print_int (modd 1)) in + let () = (print_int (meven 2)) in + let even = ((tuple_get tie) 0) in + let odd = ((tuple_get tie) 1) in + let () = (print_int (odd 3)) in + let () = (print_int (even 4)) in + 0 + + $ ./c_conv_runner.exe < manytests/typed/016lists.ml + let rec length = ((fun "no matching" xs -> if (is_empty xs) + then 0 + else if (is_cons xs) + then let h = (hd_list_get xs) in + let tl = (tl_list_get xs) in + ((( + ) 1) (length tl)) + else (failwith "no matching")) "no matching") + + let length_tail = let rec helper = (fun "no matching" acc -> (((fun "no matching" acc xs -> if (is_empty xs) + then acc + else if (is_cons xs) + then let h = (hd_list_get xs) in + let tl = (tl_list_get xs) in + ((helper ((( + ) acc) 1)) tl) + else (failwith "no matching")) "no matching") acc)) in + ((helper "no matching") 0) + + let rec map = ((fun "no matching" f -> (((fun "no matching" f xs -> if (is_empty xs) + then [] + else if if (is_cons xs) + then (is_empty (tl_list_get xs)) + else false + then let a = (hd_list_get xs) in + ((f a)::[]) + else if if (is_cons xs) + then if (is_cons (tl_list_get xs)) + then (is_empty (tl_list_get (tl_list_get xs))) + else false + else false + then let a = (hd_list_get xs) in + let b = (hd_list_get (tl_list_get xs)) in + ((f a)::((f b)::[])) + else if if (is_cons xs) + then if (is_cons (tl_list_get xs)) + then if (is_cons (tl_list_get (tl_list_get xs))) + then (is_empty (tl_list_get (tl_list_get (tl_list_get xs)))) + else false + else false + else false + then let a = (hd_list_get xs) in + let b = (hd_list_get (tl_list_get xs)) in + let c = (hd_list_get (tl_list_get (tl_list_get xs))) in + ((f a)::((f b)::((f c)::[]))) + else if if (is_cons xs) + then if (is_cons (tl_list_get xs)) + then if (is_cons (tl_list_get (tl_list_get xs))) + then (is_cons (tl_list_get (tl_list_get (tl_list_get xs)))) + else false + else false + else false + then let a = (hd_list_get xs) in + let b = (hd_list_get (tl_list_get xs)) in + let c = (hd_list_get (tl_list_get (tl_list_get xs))) in + let d = (hd_list_get (tl_list_get (tl_list_get (tl_list_get xs)))) in + let tl = (tl_list_get (tl_list_get (tl_list_get (tl_list_get xs)))) in + ((f a)::((f b)::((f c)::((f d)::((map f) tl))))) + else (failwith "no matching")) "no matching") f)) "no matching") + + let rec append = ((fun "no matching" xs -> (((fun "no matching" xs ys -> if (is_empty xs) + then ys + else if (is_cons xs) + then let x = (hd_list_get xs) in + let xs_ac0 = (tl_list_get xs) in + (x::((append xs_ac0) ys)) + else (failwith "no matching")) "no matching") xs)) "no matching") + + let concat = let rec helper = (fun "no matching" xs -> if (is_empty xs) + then [] + else if (is_cons xs) + then let h = (hd_list_get xs) in + let tl = (tl_list_get xs) in + ((append h) ((helper "no matching") tl)) + else (failwith "no matching")) in + (helper "no matching") + + let rec iter = ((fun "no matching" f -> (((fun "no matching" f xs -> if (is_empty xs) + then () + else if (is_cons xs) + then let h = (hd_list_get xs) in + let tl = (tl_list_get xs) in + let () = (f h) in + ((iter f) tl) + else (failwith "no matching")) "no matching") f)) "no matching") + + let rec cartesian = ((fun "no matching" xs -> (((fun "no matching" xs ys -> if (is_empty xs) + then [] + else if (is_cons xs) + then let h = (hd_list_get xs) in + let tl = (tl_list_get xs) in + ((append ((map ((fun h a -> (h, a)) h)) ys)) ((cartesian tl) ys)) + else (failwith "no matching")) "no matching") xs)) "no matching") + + let main = let () = ((iter print_int) (1::(2::(3::[])))) in + let () = (print_int (length ((cartesian (1::(2::[]))) (1::(2::(3::(4::[]))))))) in + 0 + + $ ./c_conv_runner.exe < manytests/do_not_type/001.ml + Infer error: + $ ./c_conv_runner.exe < manytests/do_not_type/002if.ml + Infer error: + $ ./c_conv_runner.exe < manytests/do_not_type/003occurs.ml + Infer error: + + $ ./c_conv_runner.exe < manytests/do_not_type/004let_poly.ml + Infer error: + + $ ./c_conv_runner.exe < manytests/do_not_type/015tuples.ml + Infer error: + diff --git a/FML/tests/c_conv_runner.ml b/FML/tests/c_conv_runner.ml new file mode 100644 index 000000000..1bc6aab83 --- /dev/null +++ b/FML/tests/c_conv_runner.ml @@ -0,0 +1,29 @@ +(** Copyright 2024-2025, Dmitry Pilyuk, Aleksandr Rozhkov *) + +(** SPDX-License-Identifier: LGPL-2.1 *) + +open Fml_lib.Parser +open Fml_lib.Inferencer +open Fml_lib.A_conv +open Fml_lib.Match_elimination +open Fml_lib.C_conv +open Fml_lib.Me_ast + +let () = + let input = Stdio.In_channel.input_all Stdlib.stdin in + let parse_and_infer input = + match parse input with + | Ok parsed -> + (match run_program_inferencer parsed with + | Ok _ -> Ok parsed + | Error _ -> Error (Format.asprintf "Infer error:")) + | Error e -> Error (Format.sprintf "Parsing error: %s" e) + in + match parse_and_infer input with + | Ok ast -> + let ast = ac_program ast in + let ast_me = match_elimination ast in + let ast_cc = cc_program ast_me in + Format.printf "%a\n" pp_me_program ast_cc + | Error message -> Format.printf "%s" message +;; diff --git a/FML/tests/dune b/FML/tests/dune index 35762f071..5574b4bdc 100644 --- a/FML/tests/dune +++ b/FML/tests/dune @@ -20,14 +20,18 @@ (modules inferencer_runner) (libraries fml_lib stdio)) - - (executable (name a_conv_runner) (public_name a_conv_runner) (modules a_conv_runner) (libraries fml_lib stdio)) +(executable + (name c_conv_runner) + (public_name c_conv_runner) + (modules c_conv_runner) + (libraries fml_lib stdio)) + (executable (name match_elimination_runner) (public_name match_elimination_runner) @@ -171,9 +175,9 @@ manytests/typed/016lists.ml)) (cram - (applies_to closure_conv_manytest) + (applies_to c_conv_manytest) (deps - ./closure_conv_runner.exe + ./c_conv_runner.exe manytests/do_not_type/001.ml manytests/do_not_type/002if.ml manytests/do_not_type/003occurs.ml From 95b541556e9cef982cdb2045f7a9186ec75d821e Mon Sep 17 00:00:00 2001 From: RozhkovAleksandr Date: Thu, 10 Apr 2025 22:33:49 +0300 Subject: [PATCH 66/92] rename fail and fix ll (bultins problem) --- FML/lib/anf/common.ml | 2 +- FML/lib/anf/lambda_lift.ml | 44 ++-- FML/lib/anf/match_elimination.ml | 2 +- FML/tests/c_conv_manytest.t | 62 ++--- FML/tests/lambda_lift_manytest.t | 322 +++++++++++++------------ FML/tests/match_elimination_manytest.t | 26 +- 6 files changed, 247 insertions(+), 211 deletions(-) diff --git a/FML/lib/anf/common.ml b/FML/lib/anf/common.ml index 44d5c2bb7..52331e92f 100644 --- a/FML/lib/anf/common.ml +++ b/FML/lib/anf/common.ml @@ -36,7 +36,7 @@ let builtins = ; "is_cons" ; "hd_list_get" ; "tl_list_get" - ; "failwith" + ; "fail" ] ;; diff --git a/FML/lib/anf/lambda_lift.ml b/FML/lib/anf/lambda_lift.ml index 028a3af6b..65acfa308 100644 --- a/FML/lib/anf/lambda_lift.ml +++ b/FML/lib/anf/lambda_lift.ml @@ -9,22 +9,34 @@ open StateMonad let get_new_id n name = Base.String.concat [ name; "_ll"; Int.to_string n ] -(* добавляем в списочек свободные переменные *) -let rec free_vars expr bound = - match expr with - | Me_EUnit | Me_ENill | Me_EConst _ -> [] - | Me_EIdentifier x -> if Set.mem bound x then [] else [ x ] - | Me_EIf (e1, e2, e3) -> free_vars e1 bound @ free_vars e2 bound @ free_vars e3 bound - | Me_EFun (args, body) -> - let bound' = List.fold_left ~f:Set.add ~init:bound args in - free_vars body bound' - | Me_EApp (e1, e2) -> free_vars e1 bound @ free_vars e2 bound - | Me_ELet (_, name, e1, e2) -> - let fv1 = free_vars e1 bound in - let fv2 = free_vars e2 (Set.add bound name) in - fv1 @ fv2 - | Me_ECons (e1, e2) -> free_vars e1 bound @ free_vars e2 bound - | Me_ETuple lst -> List.fold_left lst ~init:[] ~f:(fun acc e -> acc @ free_vars e bound) +let free_vars expr bound = + let builtins_set = StrSet.of_list builtins in + let is_builtin x = StrSet.find builtins_set x in + + let rec helper expr bound = + match expr with + | Me_EUnit | Me_ENill | Me_EConst _ -> [] + | Me_EIdentifier x -> + if Set.mem bound x || is_builtin x then + [] + else + [x] + | Me_EIf (e1, e2, e3) -> + helper e1 bound @ helper e2 bound @ helper e3 bound + | Me_EFun (args, body) -> + let bound' = List.fold_left ~f:Set.add ~init:bound args in + helper body bound' + | Me_EApp (e1, e2) -> helper e1 bound @ helper e2 bound + | Me_ELet (_, name, e1, e2) -> + let fv1 = helper e1 bound in + let fv2 = helper e2 (Set.add bound name) in + fv1 @ fv2 + | Me_ECons (e1, e2) -> helper e1 bound @ helper e2 bound + | Me_ETuple lst -> + List.fold_left lst ~init:[] ~f:(fun acc e -> acc @ helper e bound) + in + + helper expr bound ;; let rec ll_expr expr = diff --git a/FML/lib/anf/match_elimination.ml b/FML/lib/anf/match_elimination.ml index 59b21c85c..b21b7a56a 100644 --- a/FML/lib/anf/match_elimination.ml +++ b/FML/lib/anf/match_elimination.ml @@ -178,7 +178,7 @@ and desugar_match e branches = let* rest_expr = match rest with | [] -> - return @@ Me_EApp (Me_EIdentifier "failwith", Me_EIdentifier "\"no matching\"") + return @@ Me_EIdentifier "fail" | _ -> let new_e = match bind_expr_opt with diff --git a/FML/tests/c_conv_manytest.t b/FML/tests/c_conv_manytest.t index 78f033010..6ac2dea74 100644 --- a/FML/tests/c_conv_manytest.t +++ b/FML/tests/c_conv_manytest.t @@ -1,8 +1,8 @@ $ ./c_conv_runner.exe << EOF > let f x = let g y = x + y in g 5;; > EOF - let f = let y = (fun x -> ((( + ) x) 1)) in - (y 3) + let f = (fun x -> let g = (fun x y -> ((( + ) x) y)) in + ((g x) 5)) $ ./c_conv_runner.exe << EOF > let length xs = match xs with @@ -10,7 +10,7 @@ > | a::[] -> 1 > | [] -> 0 > EOF - let length = ((fun "no matching" xs -> if if (is_cons xs) + let length = (fun xs -> if if (is_cons xs) then if (is_cons (tl_list_get xs)) then (is_empty (tl_list_get (tl_list_get xs))) else false @@ -25,7 +25,7 @@ 1 else if (is_empty xs) then 0 - else (failwith "no matching")) "no matching") + else fail) $ ./c_conv_runner.exe << EOF > let is_empty x = x+1 @@ -35,13 +35,13 @@ > EOF let is_empty_ac0 = (fun x -> ((( + ) x) 1)) - let rec length = ((fun "no matching" xs -> if (is_empty xs) + let rec length = (fun xs -> if (is_empty xs) then 0 else if (is_cons xs) then let _ = (hd_list_get xs) in let tl = (tl_list_get xs) in ((( + ) 1) (length xs)) - else (failwith "no matching")) "no matching") + else fail) $ ./c_conv_runner.exe << EOF > let (a, b) = (5,6) @@ -69,13 +69,13 @@ > | 12 -> 12 > | _ -> 325 > EOF - let f = (((fun "no matching" (=) x -> if (((=) x) 1) + let f = ((fun (=) x -> if (((=) x) 1) then 12 else if (((=) x) 12) then 12 else if true then 325 - else (failwith "no matching")) "no matching") (=)) + else fail) (=)) $ ./c_conv_runner.exe < manytests/typed/001fac.ml let rec fac = (fun n -> if ((( <= ) n) 1) @@ -182,22 +182,22 @@ ((f 1), (f true)) $ ./c_conv_runner.exe < manytests/typed/011mapcps.ml - let rec map = ((fun "no matching" f -> (((fun "no matching" f xs -> ((((fun "no matching" f xs k -> if (is_empty xs) + let rec map = (fun f -> ((fun f xs -> (((fun f xs k -> if (is_empty xs) then (k []) else if (is_cons xs) then let h = (hd_list_get xs) in let tl = (tl_list_get xs) in (((map f) tl) ((((fun f h k tl_ac0 -> (k ((f h)::tl_ac0))) f) h) k)) - else (failwith "no matching")) "no matching") f) xs)) "no matching") f)) "no matching") + else fail) f) xs)) f)) - let rec iter = ((fun "no matching" f -> (((fun "no matching" f xs -> if (is_empty xs) + let rec iter = (fun f -> ((fun f xs -> if (is_empty xs) then () else if (is_cons xs) then let h = (hd_list_get xs) in let tl = (tl_list_get xs) in let w = (f h) in ((iter f) tl) - else (failwith "no matching")) "no matching") f)) "no matching") + else fail) f)) let main = ((iter print_int) (((map (fun x -> ((( + ) x) 1))) (1::(2::(3::[])))) (fun x -> x))) $ ./c_conv_runner.exe < manytests/typed/012fibcps.ml @@ -209,13 +209,13 @@ $ ./c_conv_runner.exe < manytests/typed/013foldfoldr.ml let id = (fun x -> x) - let rec fold_right = ((fun "no matching" f -> (((fun "no matching" f acc -> ((((fun "no matching" acc f xs -> if (is_empty xs) + let rec fold_right = (fun f -> ((fun f acc -> (((fun acc f xs -> if (is_empty xs) then acc else if (is_cons xs) then let h = (hd_list_get xs) in let tl = (tl_list_get xs) in ((f h) (((fold_right f) acc) tl)) - else (failwith "no matching")) "no matching") acc) f)) "no matching") f)) "no matching") + else fail) acc) f)) f)) let foldl = (fun f -> ((fun f a -> (((fun a f bs -> ((((fold_right ((fun f b -> (((fun b f g -> ((((fun b f g x -> (g ((f x) b))) b) f) g)) b) f)) f)) id) bs) a)) a) f)) f)) @@ -260,24 +260,24 @@ 0 $ ./c_conv_runner.exe < manytests/typed/016lists.ml - let rec length = ((fun "no matching" xs -> if (is_empty xs) + let rec length = (fun xs -> if (is_empty xs) then 0 else if (is_cons xs) then let h = (hd_list_get xs) in let tl = (tl_list_get xs) in ((( + ) 1) (length tl)) - else (failwith "no matching")) "no matching") + else fail) - let length_tail = let rec helper = (fun "no matching" acc -> (((fun "no matching" acc xs -> if (is_empty xs) + let length_tail = let rec helper = (fun acc -> ((fun acc xs -> if (is_empty xs) then acc else if (is_cons xs) then let h = (hd_list_get xs) in let tl = (tl_list_get xs) in ((helper ((( + ) acc) 1)) tl) - else (failwith "no matching")) "no matching") acc)) in - ((helper "no matching") 0) + else fail) acc)) in + (helper 0) - let rec map = ((fun "no matching" f -> (((fun "no matching" f xs -> if (is_empty xs) + let rec map = (fun f -> ((fun f xs -> if (is_empty xs) then [] else if if (is_cons xs) then (is_empty (tl_list_get xs)) @@ -316,41 +316,41 @@ let d = (hd_list_get (tl_list_get (tl_list_get (tl_list_get xs)))) in let tl = (tl_list_get (tl_list_get (tl_list_get (tl_list_get xs)))) in ((f a)::((f b)::((f c)::((f d)::((map f) tl))))) - else (failwith "no matching")) "no matching") f)) "no matching") + else fail) f)) - let rec append = ((fun "no matching" xs -> (((fun "no matching" xs ys -> if (is_empty xs) + let rec append = (fun xs -> ((fun xs ys -> if (is_empty xs) then ys else if (is_cons xs) then let x = (hd_list_get xs) in let xs_ac0 = (tl_list_get xs) in (x::((append xs_ac0) ys)) - else (failwith "no matching")) "no matching") xs)) "no matching") + else fail) xs)) - let concat = let rec helper = (fun "no matching" xs -> if (is_empty xs) + let concat = let rec helper = (fun xs -> if (is_empty xs) then [] else if (is_cons xs) then let h = (hd_list_get xs) in let tl = (tl_list_get xs) in - ((append h) ((helper "no matching") tl)) - else (failwith "no matching")) in - (helper "no matching") + ((append h) (helper tl)) + else fail) in + helper - let rec iter = ((fun "no matching" f -> (((fun "no matching" f xs -> if (is_empty xs) + let rec iter = (fun f -> ((fun f xs -> if (is_empty xs) then () else if (is_cons xs) then let h = (hd_list_get xs) in let tl = (tl_list_get xs) in let () = (f h) in ((iter f) tl) - else (failwith "no matching")) "no matching") f)) "no matching") + else fail) f)) - let rec cartesian = ((fun "no matching" xs -> (((fun "no matching" xs ys -> if (is_empty xs) + let rec cartesian = (fun xs -> ((fun xs ys -> if (is_empty xs) then [] else if (is_cons xs) then let h = (hd_list_get xs) in let tl = (tl_list_get xs) in ((append ((map ((fun h a -> (h, a)) h)) ys)) ((cartesian tl) ys)) - else (failwith "no matching")) "no matching") xs)) "no matching") + else fail) xs)) let main = let () = ((iter print_int) (1::(2::(3::[])))) in let () = (print_int (length ((cartesian (1::(2::[]))) (1::(2::(3::(4::[]))))))) in diff --git a/FML/tests/lambda_lift_manytest.t b/FML/tests/lambda_lift_manytest.t index a73101485..1a1378e38 100644 --- a/FML/tests/lambda_lift_manytest.t +++ b/FML/tests/lambda_lift_manytest.t @@ -1,8 +1,32 @@ + $ ./lambda_lift_runner.exe << EOF + > let length xs = match xs with + > | a::b::[] -> 2 + > | a::[] -> 1 + > | [] -> 0 + > EOF + let lam_ll0 = (fun xs -> if if (is_cons xs) + then if (is_cons (tl_list_get xs)) + then (is_empty (tl_list_get (tl_list_get xs))) + else false + else false + then let a = (hd_list_get xs) in + let b = (hd_list_get (tl_list_get xs)) in + 2 + else if if (is_cons xs) + then (is_empty (tl_list_get xs)) + else false + then let a = (hd_list_get xs) in + 1 + else if (is_empty xs) + then 0 + else fail) + let length = lam_ll0 + $ ./lambda_lift_runner.exe << EOF > let f = let y x = x + 1 in y 3;; > EOF - let lam_ll0 = (fun ( + ) x -> ((( + ) x) 1)) - let f = let y = (lam_ll0 ( + )) in + let lam_ll0 = (fun x -> ((( + ) x) 1)) + let f = let y = lam_ll0 in (y 3) $ ./lambda_lift_runner.exe << EOF @@ -11,7 +35,7 @@ > | a::[] -> 1 > | [] -> 0 > EOF - let lam_ll0 = (fun is_cons is_cons tl_list_get is_empty tl_list_get tl_list_get hd_list_get hd_list_get tl_list_get is_cons is_empty tl_list_get hd_list_get is_empty failwith "no matching" xs -> if if (is_cons xs) + let lam_ll0 = (fun xs -> if if (is_cons xs) then if (is_cons (tl_list_get xs)) then (is_empty (tl_list_get (tl_list_get xs))) else false @@ -26,8 +50,8 @@ 1 else if (is_empty xs) then 0 - else (failwith "no matching")) - let length = ((((((((((((((((lam_ll0 is_cons) is_cons) tl_list_get) is_empty) tl_list_get) tl_list_get) hd_list_get) hd_list_get) tl_list_get) is_cons) is_empty) tl_list_get) hd_list_get) is_empty) failwith) "no matching") + else fail) + let length = lam_ll0 $ ./lambda_lift_runner.exe << EOF > let is_empty x = x+1 @@ -35,17 +59,17 @@ > | [] -> 0 > | _::tl -> 1 + length xs > EOF - let lam_ll0 = (fun ( + ) x -> ((( + ) x) 1)) - let is_empty_ac0 = (lam_ll0 ( + )) + let lam_ll0 = (fun x -> ((( + ) x) 1)) + let is_empty_ac0 = lam_ll0 - let rec lam_ll1 = (fun is_empty is_cons hd_list_get tl_list_get ( + ) length failwith "no matching" xs -> if (is_empty xs) + let rec lam_ll1 = (fun length xs -> if (is_empty xs) then 0 else if (is_cons xs) then let _ = (hd_list_get xs) in let tl = (tl_list_get xs) in ((( + ) 1) (length xs)) - else (failwith "no matching")) - and length = ((((((((lam_ll1 is_empty) is_cons) hd_list_get) tl_list_get) ( + )) length) failwith) "no matching") + else fail) + and length = (lam_ll1 length) $ ./lambda_lift_runner.exe << EOF > let (a, b) = (5,6) @@ -62,17 +86,17 @@ > in > fack n (fun x -> x) > EOF - let lam_ll5 = (fun k_ac1 ( * ) n_ac2 m -> (k_ac1 ((( * ) m) n_ac2))) - let lam_ll4 = (fun k_ac1 ( * ) n_ac2 -> (((lam_ll5 k_ac1) ( * )) n_ac2)) - let lam_ll3 = (fun ( * ) k_ac1 -> ((lam_ll4 k_ac1) ( * ))) - let lam_ll2 = (fun ( <= ) n_ac0 fack ( - ) n_ac0 ( * ) n_ac0 k -> if ((( <= ) n_ac0) 1) + let lam_ll5 = (fun k_ac1 n_ac2 m -> (k_ac1 ((( * ) m) n_ac2))) + let lam_ll4 = (fun k_ac1 n_ac2 -> ((lam_ll5 k_ac1) n_ac2)) + let lam_ll3 = (fun k_ac1 -> (lam_ll4 k_ac1)) + let lam_ll2 = (fun n_ac0 fack n_ac0 n_ac0 k -> if ((( <= ) n_ac0) 1) then (k 1) - else ((fack ((( - ) n_ac0) 1)) (((lam_ll3 ( * )) k) n_ac0))) - let lam_ll1 = (fun ( <= ) fack ( - ) ( * ) n_ac0 -> (((((((lam_ll2 ( <= )) n_ac0) fack) ( - )) n_ac0) ( * )) n_ac0)) + else ((fack ((( - ) n_ac0) 1)) ((lam_ll3 k) n_ac0))) + let lam_ll1 = (fun fack n_ac0 -> ((((lam_ll2 n_ac0) fack) n_ac0) n_ac0)) let lam_ll6 = (fun x -> x) - let lam_ll0 = (fun ( <= ) fack ( - ) ( * ) n -> let rec fack = ((((lam_ll1 ( <= )) fack) ( - )) ( * )) in + let lam_ll0 = (fun fack n -> let rec fack = (lam_ll1 fack) in ((fack n) lam_ll6)) - let fac = ((((lam_ll0 ( <= )) fack) ( - )) ( * )) + let fac = (lam_ll0 fack) $ ./lambda_lift_runner.exe << EOF > let f x = match x with @@ -80,80 +104,80 @@ > | 12 -> 12 > | _ -> 325 > EOF - let lam_ll0 = (fun (=) (=) failwith "no matching" x -> if (((=) x) 1) + let lam_ll0 = (fun (=) (=) x -> if (((=) x) 1) then 12 else if (((=) x) 12) then 12 else if true then 325 - else (failwith "no matching")) - let f = ((((lam_ll0 (=)) (=)) failwith) "no matching") + else fail) + let f = ((lam_ll0 (=)) (=)) $ ./lambda_lift_runner.exe < manytests/typed/001fac.ml - let rec lam_ll0 = (fun ( <= ) ( * ) fac ( - ) n -> if ((( <= ) n) 1) + let rec lam_ll0 = (fun fac n -> if ((( <= ) n) 1) then 1 else ((( * ) n) (fac ((( - ) n) 1)))) - and fac = ((((lam_ll0 ( <= )) ( * )) fac) ( - )) + and fac = (lam_ll0 fac) let main = let () = (print_int (fac 4)) in 0 $ ./lambda_lift_runner.exe < manytests/typed/002fac.ml - let rec lam_ll2 = (fun k ( * ) n p -> (k ((( * ) p) n))) - and lam_ll1 = (fun ( = ) n fac_cps ( - ) n ( * ) n k -> if ((( = ) n) 1) + let rec lam_ll2 = (fun k n p -> (k ((( * ) p) n))) + and lam_ll1 = (fun n fac_cps n n k -> if ((( = ) n) 1) then (k 1) - else ((fac_cps ((( - ) n) 1)) (((lam_ll2 k) ( * )) n))) - and lam_ll0 = (fun ( = ) fac_cps ( - ) ( * ) n -> (((((((lam_ll1 ( = )) n) fac_cps) ( - )) n) ( * )) n)) - and fac_cps = ((((lam_ll0 ( = )) fac_cps) ( - )) ( * )) + else ((fac_cps ((( - ) n) 1)) ((lam_ll2 k) n))) + and lam_ll0 = (fun fac_cps n -> ((((lam_ll1 n) fac_cps) n) n)) + and fac_cps = (lam_ll0 fac_cps) let lam_ll3 = (fun print_int_ac0 -> print_int_ac0) let main = let () = (print_int ((fac_cps 4) lam_ll3)) in 0 $ ./lambda_lift_runner.exe < manytests/typed/003fib.ml - let rec lam_ll2 = (fun ( = ) b ( - ) ( + ) a b fib_acc b n -> if ((( = ) n) 1) + let rec lam_ll2 = (fun b a b fib_acc b n -> if ((( = ) n) 1) then b else let n1 = ((( - ) n) 1) in let ab = ((( + ) a) b) in (((fib_acc b) ab) n1)) - and lam_ll1 = (fun ( = ) ( - ) ( + ) a fib_acc b -> ((((((((lam_ll2 ( = )) b) ( - )) ( + )) a) b) fib_acc) b)) - and lam_ll0 = (fun ( = ) ( - ) ( + ) fib_acc a -> (((((lam_ll1 ( = )) ( - )) ( + )) a) fib_acc)) - and fib_acc = ((((lam_ll0 ( = )) ( - )) ( + )) fib_acc) + and lam_ll1 = (fun a fib_acc b -> (((((lam_ll2 b) a) b) fib_acc) b)) + and lam_ll0 = (fun fib_acc a -> ((lam_ll1 a) fib_acc)) + and fib_acc = (lam_ll0 fib_acc) - let rec lam_ll3 = (fun ( < ) ( + ) fib ( - ) fib ( - ) n -> if ((( < ) n) 2) + let rec lam_ll3 = (fun fib fib n -> if ((( < ) n) 2) then n else ((( + ) (fib ((( - ) n) 1))) (fib ((( - ) n) 2)))) - and fib = ((((((lam_ll3 ( < )) ( + )) fib) ( - )) fib) ( - )) + and fib = ((lam_ll3 fib) fib) let main = let () = (print_int (((fib_acc 0) 1) 4)) in let () = (print_int (fib 4)) in 0 $ ./lambda_lift_runner.exe < manytests/typed/004manyargs.ml - let lam_ll0 = (fun ( = ) f -> if ((( = ) 1) 1) + let lam_ll0 = (fun f -> if ((( = ) 1) 1) then f else f) - let wrap = (lam_ll0 ( = )) + let wrap = lam_ll0 - let lam_ll3 = (fun print_int a print_int b print_int c -> let a_ac0 = (print_int a) in + let lam_ll3 = (fun a b c -> let a_ac0 = (print_int a) in let b_ac1 = (print_int b) in let c_ac2 = (print_int c) in 0) - let lam_ll2 = (fun print_int a print_int print_int b -> (((((lam_ll3 print_int) a) print_int) b) print_int)) - let lam_ll1 = (fun print_int print_int print_int a -> ((((lam_ll2 print_int) a) print_int) print_int)) - let test3 = (((lam_ll1 print_int) print_int) print_int) - - let lam_ll13 = (fun ( + ) ( + ) ( + ) ( + ) ( + ) ( + ) ( + ) ( + ) ( + ) a b c d e f g h i j -> ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) a) b)) c)) d)) e)) f)) g)) h)) i)) j)) - let lam_ll12 = (fun ( + ) ( + ) ( + ) ( + ) ( + ) ( + ) ( + ) ( + ) ( + ) a b c d e f g h i -> ((((((((((((((((((lam_ll13 ( + )) ( + )) ( + )) ( + )) ( + )) ( + )) ( + )) ( + )) ( + )) a) b) c) d) e) f) g) h) i)) - let lam_ll11 = (fun ( + ) ( + ) ( + ) ( + ) ( + ) ( + ) ( + ) ( + ) ( + ) a b c d e f g h -> (((((((((((((((((lam_ll12 ( + )) ( + )) ( + )) ( + )) ( + )) ( + )) ( + )) ( + )) ( + )) a) b) c) d) e) f) g) h)) - let lam_ll10 = (fun ( + ) ( + ) ( + ) ( + ) ( + ) ( + ) ( + ) ( + ) ( + ) a b c d e f g -> ((((((((((((((((lam_ll11 ( + )) ( + )) ( + )) ( + )) ( + )) ( + )) ( + )) ( + )) ( + )) a) b) c) d) e) f) g)) - let lam_ll9 = (fun ( + ) ( + ) ( + ) ( + ) ( + ) ( + ) ( + ) ( + ) ( + ) a b c d e f -> (((((((((((((((lam_ll10 ( + )) ( + )) ( + )) ( + )) ( + )) ( + )) ( + )) ( + )) ( + )) a) b) c) d) e) f)) - let lam_ll8 = (fun ( + ) ( + ) ( + ) ( + ) ( + ) ( + ) ( + ) ( + ) ( + ) a b c d e -> ((((((((((((((lam_ll9 ( + )) ( + )) ( + )) ( + )) ( + )) ( + )) ( + )) ( + )) ( + )) a) b) c) d) e)) - let lam_ll7 = (fun ( + ) ( + ) ( + ) ( + ) ( + ) ( + ) ( + ) ( + ) ( + ) a b c d -> (((((((((((((lam_ll8 ( + )) ( + )) ( + )) ( + )) ( + )) ( + )) ( + )) ( + )) ( + )) a) b) c) d)) - let lam_ll6 = (fun ( + ) ( + ) ( + ) ( + ) ( + ) ( + ) ( + ) ( + ) ( + ) a b c -> ((((((((((((lam_ll7 ( + )) ( + )) ( + )) ( + )) ( + )) ( + )) ( + )) ( + )) ( + )) a) b) c)) - let lam_ll5 = (fun ( + ) ( + ) ( + ) ( + ) ( + ) ( + ) ( + ) ( + ) ( + ) a b -> (((((((((((lam_ll6 ( + )) ( + )) ( + )) ( + )) ( + )) ( + )) ( + )) ( + )) ( + )) a) b)) - let lam_ll4 = (fun ( + ) ( + ) ( + ) ( + ) ( + ) ( + ) ( + ) ( + ) ( + ) a -> ((((((((((lam_ll5 ( + )) ( + )) ( + )) ( + )) ( + )) ( + )) ( + )) ( + )) ( + )) a)) - let test10 = (((((((((lam_ll4 ( + )) ( + )) ( + )) ( + )) ( + )) ( + )) ( + )) ( + )) ( + )) + let lam_ll2 = (fun a b -> ((lam_ll3 a) b)) + let lam_ll1 = (fun a -> (lam_ll2 a)) + let test3 = lam_ll1 + + let lam_ll13 = (fun a b c d e f g h i j -> ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) a) b)) c)) d)) e)) f)) g)) h)) i)) j)) + let lam_ll12 = (fun a b c d e f g h i -> (((((((((lam_ll13 a) b) c) d) e) f) g) h) i)) + let lam_ll11 = (fun a b c d e f g h -> ((((((((lam_ll12 a) b) c) d) e) f) g) h)) + let lam_ll10 = (fun a b c d e f g -> (((((((lam_ll11 a) b) c) d) e) f) g)) + let lam_ll9 = (fun a b c d e f -> ((((((lam_ll10 a) b) c) d) e) f)) + let lam_ll8 = (fun a b c d e -> (((((lam_ll9 a) b) c) d) e)) + let lam_ll7 = (fun a b c d -> ((((lam_ll8 a) b) c) d)) + let lam_ll6 = (fun a b c -> (((lam_ll7 a) b) c)) + let lam_ll5 = (fun a b -> ((lam_ll6 a) b)) + let lam_ll4 = (fun a -> (lam_ll5 a)) + let test10 = lam_ll4 let main = let rez = (((((((((((wrap test10) 1) 10) 100) 1000) 10000) 100000) 1000000) 10000000) 100000000) 1000000000) in let () = (print_int rez) in @@ -165,22 +189,22 @@ and lam_ll0 = (fun fix f -> (((lam_ll1 f) fix) f)) and fix = (lam_ll0 fix) - let lam_ll3 = (fun ( <= ) ( * ) self ( - ) n -> if ((( <= ) n) 1) + let lam_ll3 = (fun self n -> if ((( <= ) n) 1) then 1 else ((( * ) n) (self ((( - ) n) 1)))) - let lam_ll2 = (fun ( <= ) ( * ) ( - ) self -> ((((lam_ll3 ( <= )) ( * )) self) ( - ))) - let fac = (((lam_ll2 ( <= )) ( * )) ( - )) + let lam_ll2 = (fun self -> (lam_ll3 self)) + let fac = lam_ll2 let main = let () = (print_int ((fix fac) 6)) in 0 $ ./lambda_lift_runner.exe < manytests/typed/006partial.ml - let lam_ll1 = (fun ( + ) foo -> ((( + ) foo) 2)) - let lam_ll2 = (fun ( * ) foo -> ((( * ) foo) 10)) - let lam_ll0 = (fun ( + ) ( * ) b -> if b - then (lam_ll1 ( + )) - else (lam_ll2 ( * ))) - let foo = ((lam_ll0 ( + )) ( * )) + let lam_ll1 = (fun foo -> ((( + ) foo) 2)) + let lam_ll2 = (fun foo -> ((( * ) foo) 10)) + let lam_ll0 = (fun b -> if b + then lam_ll1 + else lam_ll2) + let foo = lam_ll0 let lam_ll3 = (fun foo foo foo foo x -> ((foo true) ((foo false) ((foo true) ((foo false) x))))) let foo_ac0 = ((((lam_ll3 foo) foo) foo) foo) @@ -189,13 +213,13 @@ 0 $ ./lambda_lift_runner.exe < manytests/typed/006partial2.ml - let lam_ll2 = (fun print_int a print_int b print_int ( + ) a ( * ) b c -> let () = (print_int a) in + let lam_ll2 = (fun a b a b c -> let () = (print_int a) in let () = (print_int b) in let () = (print_int c) in ((( + ) a) ((( * ) b) c))) - let lam_ll1 = (fun print_int a print_int print_int ( + ) a ( * ) b -> (((((((((lam_ll2 print_int) a) print_int) b) print_int) ( + )) a) ( * )) b)) - let lam_ll0 = (fun print_int print_int print_int ( + ) ( * ) a -> (((((((lam_ll1 print_int) a) print_int) print_int) ( + )) a) ( * ))) - let foo = (((((lam_ll0 print_int) print_int) print_int) ( + )) ( * )) + let lam_ll1 = (fun a a b -> ((((lam_ll2 a) b) a) b)) + let lam_ll0 = (fun a -> ((lam_ll1 a) a)) + let foo = lam_ll0 let main = let foo_ac0 = (foo 1) in let foo_ac1 = (foo_ac0 2) in @@ -203,28 +227,28 @@ let () = (print_int foo_ac2) in 0 $ ./lambda_lift_runner.exe < manytests/typed/006partial3.ml - let lam_ll2 = (fun print_int c -> (print_int c)) - let lam_ll1 = (fun print_int print_int b -> let () = (print_int b) in - (lam_ll2 print_int)) - let lam_ll0 = (fun print_int print_int print_int a -> let () = (print_int a) in - ((lam_ll1 print_int) print_int)) - let foo = (((lam_ll0 print_int) print_int) print_int) + let lam_ll2 = (fun c -> (print_int c)) + let lam_ll1 = (fun b -> let () = (print_int b) in + lam_ll2) + let lam_ll0 = (fun a -> let () = (print_int a) in + lam_ll1) + let foo = lam_ll0 let main = let () = (((foo 4) 8) 9) in 0 $ ./lambda_lift_runner.exe < manytests/typed/007order.ml - let lam_ll8 = (fun print_int ( + ) a b print_int ( + ) ( / ) ( * ) a b _c d __ -> let () = (print_int ((( + ) a) b)) in + let lam_ll8 = (fun a b a b _c d __ -> let () = (print_int ((( + ) a) b)) in let () = (print_int __) in ((( + ) ((( / ) ((( * ) a) b)) _c)) d)) - let lam_ll7 = (fun print_int ( + ) a b print_int ( + ) ( / ) ( * ) a b _c d -> ((((((((((((lam_ll8 print_int) ( + )) a) b) print_int) ( + )) ( / )) ( * )) a) b) _c) d)) - let lam_ll6 = (fun print_int ( + ) a b print_int ( + ) ( / ) ( * ) a b _c () -> (((((((((((lam_ll7 print_int) ( + )) a) b) print_int) ( + )) ( / )) ( * )) a) b) _c)) - let lam_ll5 = (fun print_int ( + ) a b print_int ( + ) ( / ) ( * ) a b _c -> (((((((((((lam_ll6 print_int) ( + )) a) b) print_int) ( + )) ( / )) ( * )) a) b) _c)) - let lam_ll4 = (fun print_int ( + ) a print_int ( + ) ( / ) ( * ) a b -> ((((((((((lam_ll5 print_int) ( + )) a) b) print_int) ( + )) ( / )) ( * )) a) b)) - let lam_ll3 = (fun print_int ( + ) a print_int ( + ) ( / ) ( * ) a () -> ((((((((lam_ll4 print_int) ( + )) a) print_int) ( + )) ( / )) ( * )) a)) - let lam_ll2 = (fun print_int ( + ) print_int ( + ) ( / ) ( * ) a -> ((((((((lam_ll3 print_int) ( + )) a) print_int) ( + )) ( / )) ( * )) a)) - let lam_ll1 = (fun print_int ( + ) print_int ( + ) ( / ) ( * ) () -> ((((((lam_ll2 print_int) ( + )) print_int) ( + )) ( / )) ( * ))) - let lam_ll0 = (fun print_int ( + ) print_int ( + ) ( / ) ( * ) () -> ((((((lam_ll1 print_int) ( + )) print_int) ( + )) ( / )) ( * ))) - let _start = ((((((lam_ll0 print_int) ( + )) print_int) ( + )) ( / )) ( * )) + let lam_ll7 = (fun a b a b _c d -> ((((((lam_ll8 a) b) a) b) _c) d)) + let lam_ll6 = (fun a b a b _c () -> (((((lam_ll7 a) b) a) b) _c)) + let lam_ll5 = (fun a b a b _c -> (((((lam_ll6 a) b) a) b) _c)) + let lam_ll4 = (fun a a b -> ((((lam_ll5 a) b) a) b)) + let lam_ll3 = (fun a a () -> ((lam_ll4 a) a)) + let lam_ll2 = (fun a -> ((lam_ll3 a) a)) + let lam_ll1 = (fun () -> lam_ll2) + let lam_ll0 = (fun () -> lam_ll1) + let _start = lam_ll0 let main = (print_int (((((((((_start (print_int 1)) (print_int 2)) 3) (print_int 4)) 100) 1000) (print_int (( ~- ) 1))) 10000) (( ~- ) 555555))) $ ./lambda_lift_runner.exe < manytests/typed/008ascription.ml @@ -233,12 +257,12 @@ let lam_ll0 = (fun f -> (lam_ll1 f)) let addi = lam_ll0 - let lam_ll4 = (fun ( + ) x ( * ) x b -> if b + let lam_ll4 = (fun x x b -> if b then ((( + ) x) 1) else ((( * ) x) 2)) - let lam_ll3 = (fun ( + ) ( * ) x -> ((((lam_ll4 ( + )) x) ( * )) x)) - let lam_ll5 = (fun ( = ) ( / ) _start -> ((( = ) ((( / ) _start) 2)) 0)) - let main = let () = (print_int (((addi ((lam_ll3 ( + )) ( * ))) ((lam_ll5 ( = )) ( / ))) 4)) in + let lam_ll3 = (fun x -> ((lam_ll4 x) x)) + let lam_ll5 = (fun _start -> ((( = ) ((( / ) _start) 2)) 0)) + let main = let () = (print_int (((addi lam_ll3) lam_ll5) 4)) in 0 $ ./lambda_lift_runner.exe < manytests/typed/009let_poly.ml @@ -248,39 +272,39 @@ $ ./lambda_lift_runner.exe < manytests/typed/011mapcps.ml let rec lam_ll3 = (fun k f h tl_ac0 -> (k ((f h)::tl_ac0))) - and lam_ll2 = (fun is_empty xs is_cons xs hd_list_get xs tl_list_get xs map f f failwith "no matching" k -> if (is_empty xs) + and lam_ll2 = (fun xs xs xs xs map f f k -> if (is_empty xs) then (k []) else if (is_cons xs) then let h = (hd_list_get xs) in let tl = (tl_list_get xs) in (((map f) tl) (((lam_ll3 k) f) h)) - else (failwith "no matching")) - and lam_ll1 = (fun is_empty is_cons hd_list_get tl_list_get map f f failwith "no matching" xs -> (((((((((((((lam_ll2 is_empty) xs) is_cons) xs) hd_list_get) xs) tl_list_get) xs) map) f) f) failwith) "no matching")) - and lam_ll0 = (fun is_empty is_cons hd_list_get tl_list_get map failwith "no matching" f -> (((((((((lam_ll1 is_empty) is_cons) hd_list_get) tl_list_get) map) f) f) failwith) "no matching")) - and map = (((((((lam_ll0 is_empty) is_cons) hd_list_get) tl_list_get) map) failwith) "no matching") + else fail) + and lam_ll1 = (fun map f f xs -> (((((((lam_ll2 xs) xs) xs) xs) map) f) f)) + and lam_ll0 = (fun map f -> (((lam_ll1 map) f) f)) + and map = (lam_ll0 map) - let rec lam_ll5 = (fun is_empty is_cons hd_list_get tl_list_get f iter f failwith "no matching" xs -> if (is_empty xs) + let rec lam_ll5 = (fun f iter f xs -> if (is_empty xs) then () else if (is_cons xs) then let h = (hd_list_get xs) in let tl = (tl_list_get xs) in let w = (f h) in ((iter f) tl) - else (failwith "no matching")) - and lam_ll4 = (fun is_empty is_cons hd_list_get tl_list_get iter failwith "no matching" f -> (((((((((lam_ll5 is_empty) is_cons) hd_list_get) tl_list_get) f) iter) f) failwith) "no matching")) - and iter = (((((((lam_ll4 is_empty) is_cons) hd_list_get) tl_list_get) iter) failwith) "no matching") + else fail) + and lam_ll4 = (fun iter f -> (((lam_ll5 f) iter) f)) + and iter = (lam_ll4 iter) - let lam_ll6 = (fun ( + ) x -> ((( + ) x) 1)) + let lam_ll6 = (fun x -> ((( + ) x) 1)) let lam_ll7 = (fun x -> x) - let main = ((iter print_int) (((map (lam_ll6 ( + ))) (1::(2::(3::[])))) lam_ll7)) + let main = ((iter print_int) (((map lam_ll6) (1::(2::(3::[])))) lam_ll7)) $ ./lambda_lift_runner.exe < manytests/typed/012fibcps.ml - let rec lam_ll3 = (fun k ( + ) a b -> (k ((( + ) a) b))) - and lam_ll2 = (fun fib ( - ) n k ( + ) a -> ((fib ((( - ) n) 2)) (((lam_ll3 k) ( + )) a))) - and lam_ll1 = (fun ( < ) n n fib ( - ) n fib ( - ) n ( + ) k -> if ((( < ) n) 2) + let rec lam_ll3 = (fun k a b -> (k ((( + ) a) b))) + and lam_ll2 = (fun fib n k a -> ((fib ((( - ) n) 2)) ((lam_ll3 k) a))) + and lam_ll1 = (fun n n fib n fib n k -> if ((( < ) n) 2) then (k n) - else ((fib ((( - ) n) 1)) (((((lam_ll2 fib) ( - )) n) k) ( + )))) - and lam_ll0 = (fun ( < ) fib ( - ) fib ( - ) ( + ) n -> ((((((((((lam_ll1 ( < )) n) n) fib) ( - )) n) fib) ( - )) n) ( + ))) - and fib = ((((((lam_ll0 ( < )) fib) ( - )) fib) ( - )) ( + )) + else ((fib ((( - ) n) 1)) (((lam_ll2 fib) n) k))) + and lam_ll0 = (fun fib fib n -> ((((((lam_ll1 n) n) fib) n) fib) n)) + and fib = ((lam_ll0 fib) fib) let lam_ll4 = (fun x -> x) let main = (print_int ((fib 6) lam_ll4)) @@ -288,16 +312,16 @@ let lam_ll0 = (fun x -> x) let id = lam_ll0 - let rec lam_ll3 = (fun is_empty acc is_cons hd_list_get tl_list_get f fold_right f acc failwith "no matching" xs -> if (is_empty xs) + let rec lam_ll3 = (fun acc f fold_right f acc xs -> if (is_empty xs) then acc else if (is_cons xs) then let h = (hd_list_get xs) in let tl = (tl_list_get xs) in ((f h) (((fold_right f) acc) tl)) - else (failwith "no matching")) - and lam_ll2 = (fun is_empty is_cons hd_list_get tl_list_get f fold_right f failwith "no matching" acc -> (((((((((((lam_ll3 is_empty) acc) is_cons) hd_list_get) tl_list_get) f) fold_right) f) acc) failwith) "no matching")) - and lam_ll1 = (fun is_empty is_cons hd_list_get tl_list_get fold_right failwith "no matching" f -> (((((((((lam_ll2 is_empty) is_cons) hd_list_get) tl_list_get) f) fold_right) f) failwith) "no matching")) - and fold_right = (((((((lam_ll1 is_empty) is_cons) hd_list_get) tl_list_get) fold_right) failwith) "no matching") + else fail) + and lam_ll2 = (fun f fold_right f acc -> (((((lam_ll3 acc) f) fold_right) f) acc)) + and lam_ll1 = (fun fold_right f -> (((lam_ll2 f) fold_right) f)) + and fold_right = (lam_ll1 fold_right) let lam_ll9 = (fun g f b x -> (g ((f x) b))) let lam_ll8 = (fun f b g -> (((lam_ll9 g) f) b)) @@ -307,20 +331,20 @@ let lam_ll4 = (fun fold_right id f -> (((lam_ll5 fold_right) f) id)) let foldl = ((lam_ll4 fold_right) id) - let lam_ll11 = (fun ( * ) x y -> ((( * ) x) y)) - let lam_ll10 = (fun ( * ) x -> ((lam_ll11 ( * )) x)) - let main = (print_int (((foldl (lam_ll10 ( * ))) 1) (1::(2::(3::[]))))) + let lam_ll11 = (fun x y -> ((( * ) x) y)) + let lam_ll10 = (fun x -> (lam_ll11 x)) + let main = (print_int (((foldl lam_ll10) 1) (1::(2::(3::[]))))) $ ./lambda_lift_runner.exe < manytests/typed/015tuples.ml let rec lam_ll1 = (fun f fix f x -> ((f (fix f)) x)) and lam_ll0 = (fun fix f -> (((lam_ll1 f) fix) f)) and fix = (lam_ll0 fix) - let lam_ll3 = (fun tuple_get tuple_get f f p -> let a = ((tuple_get p) 0) in + let lam_ll3 = (fun f f p -> let a = ((tuple_get p) 0) in let b = ((tuple_get p) 1) in ((f a), (f b))) - let lam_ll2 = (fun tuple_get tuple_get f -> ((((lam_ll3 tuple_get) tuple_get) f) f)) - let map = ((lam_ll2 tuple_get) tuple_get) + let lam_ll2 = (fun f -> ((lam_ll3 f) f)) + let map = lam_ll2 let lam_ll8 = (fun li self l_ac0 x -> ((li (self l_ac0)) x)) let lam_ll7 = (fun self l_ac0 li -> (((lam_ll8 li) self) l_ac0)) @@ -329,32 +353,32 @@ let lam_ll4 = (fun fix map l -> ((fix (lam_ll5 map)) l)) let fixpoly = ((lam_ll4 fix) map) - let lam_ll10 = (fun tuple_get p tuple_get p ( = ) ( - ) n -> let e = ((tuple_get p) 0) in + let lam_ll10 = (fun p p n -> let e = ((tuple_get p) 0) in let o = ((tuple_get p) 1) in if ((( = ) n) 0) then 1 else (o ((( - ) n) 1))) - let lam_ll9 = (fun tuple_get tuple_get ( = ) ( - ) p -> ((((((lam_ll10 tuple_get) p) tuple_get) p) ( = )) ( - ))) - let feven = ((((lam_ll9 tuple_get) tuple_get) ( = )) ( - )) + let lam_ll9 = (fun p -> ((lam_ll10 p) p)) + let feven = lam_ll9 - let lam_ll12 = (fun tuple_get p tuple_get p ( = ) ( - ) n -> let e = ((tuple_get p) 0) in + let lam_ll12 = (fun p p n -> let e = ((tuple_get p) 0) in let o = ((tuple_get p) 1) in if ((( = ) n) 0) then 0 else (e ((( - ) n) 1))) - let lam_ll11 = (fun tuple_get tuple_get ( = ) ( - ) p -> ((((((lam_ll12 tuple_get) p) tuple_get) p) ( = )) ( - ))) - let fodd = ((((lam_ll11 tuple_get) tuple_get) ( = )) ( - )) + let lam_ll11 = (fun p -> ((lam_ll12 p) p)) + let fodd = lam_ll11 let tie = (fixpoly (feven, fodd)) - let rec lam_ll13 = (fun ( = ) modd ( - ) n -> if ((( = ) n) 0) + let rec lam_ll13 = (fun modd n -> if ((( = ) n) 0) then 1 else (modd ((( - ) n) 1))) - and meven = (((lam_ll13 ( = )) modd) ( - )) - and lam_ll14 = (fun ( = ) meven ( - ) n -> if ((( = ) n) 0) + and meven = (lam_ll13 modd) + and lam_ll14 = (fun meven n -> if ((( = ) n) 0) then 1 else (meven ((( - ) n) 1))) - and modd = (((lam_ll14 ( = )) meven) ( - )) + and modd = (lam_ll14 meven) let main = let () = (print_int (modd 1)) in let () = (print_int (meven 2)) in @@ -365,27 +389,27 @@ 0 $ ./lambda_lift_runner.exe < manytests/typed/016lists.ml - let rec lam_ll0 = (fun is_empty is_cons hd_list_get tl_list_get ( + ) length failwith "no matching" xs -> if (is_empty xs) + let rec lam_ll0 = (fun length xs -> if (is_empty xs) then 0 else if (is_cons xs) then let h = (hd_list_get xs) in let tl = (tl_list_get xs) in ((( + ) 1) (length tl)) - else (failwith "no matching")) - and length = ((((((((lam_ll0 is_empty) is_cons) hd_list_get) tl_list_get) ( + )) length) failwith) "no matching") + else fail) + and length = (lam_ll0 length) - let lam_ll2 = (fun is_empty acc is_cons hd_list_get tl_list_get helper ( + ) acc failwith "no matching" xs -> if (is_empty xs) + let lam_ll2 = (fun acc helper acc xs -> if (is_empty xs) then acc else if (is_cons xs) then let h = (hd_list_get xs) in let tl = (tl_list_get xs) in ((helper ((( + ) acc) 1)) tl) - else (failwith "no matching")) - let lam_ll1 = (fun is_empty is_cons hd_list_get tl_list_get helper ( + ) failwith "no matching" acc -> ((((((((((lam_ll2 is_empty) acc) is_cons) hd_list_get) tl_list_get) helper) ( + )) acc) failwith) "no matching")) - let length_tail = let rec helper = ((((((((lam_ll1 is_empty) is_cons) hd_list_get) tl_list_get) helper) ( + )) failwith) "no matching") in + else fail) + let lam_ll1 = (fun helper acc -> (((lam_ll2 acc) helper) acc)) + let length_tail = let rec helper = (lam_ll1 helper) in (helper 0) - let rec lam_ll4 = (fun is_empty is_cons is_empty tl_list_get hd_list_get f is_cons is_cons tl_list_get is_empty tl_list_get tl_list_get hd_list_get hd_list_get tl_list_get f f is_cons is_cons tl_list_get is_cons tl_list_get tl_list_get is_empty tl_list_get tl_list_get tl_list_get hd_list_get hd_list_get tl_list_get hd_list_get tl_list_get tl_list_get f f f is_cons is_cons tl_list_get is_cons tl_list_get tl_list_get is_cons tl_list_get tl_list_get tl_list_get hd_list_get hd_list_get tl_list_get hd_list_get tl_list_get tl_list_get hd_list_get tl_list_get tl_list_get tl_list_get tl_list_get tl_list_get tl_list_get tl_list_get f f f f map f failwith "no matching" xs -> if (is_empty xs) + let rec lam_ll4 = (fun f f f f f f f f f f map f xs -> if (is_empty xs) then [] else if if (is_cons xs) then (is_empty (tl_list_get xs)) @@ -424,51 +448,51 @@ let d = (hd_list_get (tl_list_get (tl_list_get (tl_list_get xs)))) in let tl = (tl_list_get (tl_list_get (tl_list_get (tl_list_get xs)))) in ((f a)::((f b)::((f c)::((f d)::((map f) tl))))) - else (failwith "no matching")) - and lam_ll3 = (fun is_empty is_cons is_empty tl_list_get hd_list_get is_cons is_cons tl_list_get is_empty tl_list_get tl_list_get hd_list_get hd_list_get tl_list_get is_cons is_cons tl_list_get is_cons tl_list_get tl_list_get is_empty tl_list_get tl_list_get tl_list_get hd_list_get hd_list_get tl_list_get hd_list_get tl_list_get tl_list_get is_cons is_cons tl_list_get is_cons tl_list_get tl_list_get is_cons tl_list_get tl_list_get tl_list_get hd_list_get hd_list_get tl_list_get hd_list_get tl_list_get tl_list_get hd_list_get tl_list_get tl_list_get tl_list_get tl_list_get tl_list_get tl_list_get tl_list_get map failwith "no matching" f -> ((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((lam_ll4 is_empty) is_cons) is_empty) tl_list_get) hd_list_get) f) is_cons) is_cons) tl_list_get) is_empty) tl_list_get) tl_list_get) hd_list_get) hd_list_get) tl_list_get) f) f) is_cons) is_cons) tl_list_get) is_cons) tl_list_get) tl_list_get) is_empty) tl_list_get) tl_list_get) tl_list_get) hd_list_get) hd_list_get) tl_list_get) hd_list_get) tl_list_get) tl_list_get) f) f) f) is_cons) is_cons) tl_list_get) is_cons) tl_list_get) tl_list_get) is_cons) tl_list_get) tl_list_get) tl_list_get) hd_list_get) hd_list_get) tl_list_get) hd_list_get) tl_list_get) tl_list_get) hd_list_get) tl_list_get) tl_list_get) tl_list_get) tl_list_get) tl_list_get) tl_list_get) tl_list_get) f) f) f) f) map) f) failwith) "no matching")) - and map = (((((((((((((((((((((((((((((((((((((((((((((((((((((((((lam_ll3 is_empty) is_cons) is_empty) tl_list_get) hd_list_get) is_cons) is_cons) tl_list_get) is_empty) tl_list_get) tl_list_get) hd_list_get) hd_list_get) tl_list_get) is_cons) is_cons) tl_list_get) is_cons) tl_list_get) tl_list_get) is_empty) tl_list_get) tl_list_get) tl_list_get) hd_list_get) hd_list_get) tl_list_get) hd_list_get) tl_list_get) tl_list_get) is_cons) is_cons) tl_list_get) is_cons) tl_list_get) tl_list_get) is_cons) tl_list_get) tl_list_get) tl_list_get) hd_list_get) hd_list_get) tl_list_get) hd_list_get) tl_list_get) tl_list_get) hd_list_get) tl_list_get) tl_list_get) tl_list_get) tl_list_get) tl_list_get) tl_list_get) tl_list_get) map) failwith) "no matching") + else fail) + and lam_ll3 = (fun map f -> ((((((((((((lam_ll4 f) f) f) f) f) f) f) f) f) f) map) f)) + and map = (lam_ll3 map) - let rec lam_ll6 = (fun is_empty xs is_cons xs hd_list_get xs tl_list_get xs append failwith "no matching" ys -> if (is_empty xs) + let rec lam_ll6 = (fun xs xs xs xs append ys -> if (is_empty xs) then ys else if (is_cons xs) then let x = (hd_list_get xs) in let xs_ac0 = (tl_list_get xs) in (x::((append xs_ac0) ys)) - else (failwith "no matching")) - and lam_ll5 = (fun is_empty is_cons hd_list_get tl_list_get append failwith "no matching" xs -> (((((((((((lam_ll6 is_empty) xs) is_cons) xs) hd_list_get) xs) tl_list_get) xs) append) failwith) "no matching")) - and append = (((((((lam_ll5 is_empty) is_cons) hd_list_get) tl_list_get) append) failwith) "no matching") + else fail) + and lam_ll5 = (fun append xs -> (((((lam_ll6 xs) xs) xs) xs) append)) + and append = (lam_ll5 append) - let lam_ll7 = (fun is_empty is_cons hd_list_get tl_list_get append helper failwith "no matching" xs -> if (is_empty xs) + let lam_ll7 = (fun append helper xs -> if (is_empty xs) then [] else if (is_cons xs) then let h = (hd_list_get xs) in let tl = (tl_list_get xs) in ((append h) (helper tl)) - else (failwith "no matching")) - let concat = let rec helper = ((((((((lam_ll7 is_empty) is_cons) hd_list_get) tl_list_get) append) helper) failwith) "no matching") in + else fail) + let concat = let rec helper = ((lam_ll7 append) helper) in helper - let rec lam_ll9 = (fun is_empty is_cons hd_list_get tl_list_get f iter f failwith "no matching" xs -> if (is_empty xs) + let rec lam_ll9 = (fun f iter f xs -> if (is_empty xs) then () else if (is_cons xs) then let h = (hd_list_get xs) in let tl = (tl_list_get xs) in let () = (f h) in ((iter f) tl) - else (failwith "no matching")) - and lam_ll8 = (fun is_empty is_cons hd_list_get tl_list_get iter failwith "no matching" f -> (((((((((lam_ll9 is_empty) is_cons) hd_list_get) tl_list_get) f) iter) f) failwith) "no matching")) - and iter = (((((((lam_ll8 is_empty) is_cons) hd_list_get) tl_list_get) iter) failwith) "no matching") + else fail) + and lam_ll8 = (fun iter f -> (((lam_ll9 f) iter) f)) + and iter = (lam_ll8 iter) let rec lam_ll12 = (fun h a -> (h, a)) - and lam_ll11 = (fun is_empty xs is_cons xs hd_list_get xs tl_list_get xs append map cartesian failwith "no matching" ys -> if (is_empty xs) + and lam_ll11 = (fun xs xs xs xs append map cartesian ys -> if (is_empty xs) then [] else if (is_cons xs) then let h = (hd_list_get xs) in let tl = (tl_list_get xs) in ((append ((map (lam_ll12 h)) ys)) ((cartesian tl) ys)) - else (failwith "no matching")) - and lam_ll10 = (fun is_empty is_cons hd_list_get tl_list_get append map cartesian failwith "no matching" xs -> (((((((((((((lam_ll11 is_empty) xs) is_cons) xs) hd_list_get) xs) tl_list_get) xs) append) map) cartesian) failwith) "no matching")) - and cartesian = (((((((((lam_ll10 is_empty) is_cons) hd_list_get) tl_list_get) append) map) cartesian) failwith) "no matching") + else fail) + and lam_ll10 = (fun append map cartesian xs -> (((((((lam_ll11 xs) xs) xs) xs) append) map) cartesian)) + and cartesian = (((lam_ll10 append) map) cartesian) let main = let () = ((iter print_int) (1::(2::(3::[])))) in let () = (print_int (length ((cartesian (1::(2::[]))) (1::(2::(3::(4::[]))))))) in diff --git a/FML/tests/match_elimination_manytest.t b/FML/tests/match_elimination_manytest.t index 182cce41a..d7f9b62ec 100644 --- a/FML/tests/match_elimination_manytest.t +++ b/FML/tests/match_elimination_manytest.t @@ -25,7 +25,7 @@ 1 else if (is_empty xs) then 0 - else (failwith "no matching")) + else fail) $ ./match_elimination_runner.exe << EOF > let is_empty x = x+1 @@ -41,7 +41,7 @@ then let _ = (hd_list_get xs) in let tl = (tl_list_get xs) in ((( + ) 1) (length xs)) - else (failwith "no matching")) + else fail) $ ./match_elimination_runner.exe << EOF > let (a, b) = (5,6) @@ -75,7 +75,7 @@ then 12 else if true then 325 - else (failwith "no matching")) + else fail) $ ./match_elimination_runner.exe < manytests/typed/001fac.ml let rec fac = (fun n -> if ((( <= ) n) 1) @@ -188,7 +188,7 @@ then let h = (hd_list_get xs) in let tl = (tl_list_get xs) in (((map f) tl) (fun tl_ac0 -> (k ((f h)::tl_ac0)))) - else (failwith "no matching")))) + else fail))) let rec iter = (fun f -> (fun xs -> if (is_empty xs) then () @@ -197,7 +197,7 @@ let tl = (tl_list_get xs) in let w = (f h) in ((iter f) tl) - else (failwith "no matching"))) + else fail)) let main = ((iter print_int) (((map (fun x -> ((( + ) x) 1))) (1::(2::(3::[])))) (fun x -> x))) $ ./match_elimination_runner.exe < manytests/typed/012fibcps.ml @@ -215,7 +215,7 @@ then let h = (hd_list_get xs) in let tl = (tl_list_get xs) in ((f h) (((fold_right f) acc) tl)) - else (failwith "no matching")))) + else fail))) let foldl = (fun f -> (fun a -> (fun bs -> ((((fold_right (fun b -> (fun g -> (fun x -> (g ((f x) b)))))) id) bs) a)))) @@ -266,7 +266,7 @@ then let h = (hd_list_get xs) in let tl = (tl_list_get xs) in ((( + ) 1) (length tl)) - else (failwith "no matching")) + else fail) let length_tail = let rec helper = (fun acc -> (fun xs -> if (is_empty xs) then acc @@ -274,7 +274,7 @@ then let h = (hd_list_get xs) in let tl = (tl_list_get xs) in ((helper ((( + ) acc) 1)) tl) - else (failwith "no matching"))) in + else fail)) in (helper 0) let rec map = (fun f -> (fun xs -> if (is_empty xs) @@ -316,7 +316,7 @@ let d = (hd_list_get (tl_list_get (tl_list_get (tl_list_get xs)))) in let tl = (tl_list_get (tl_list_get (tl_list_get (tl_list_get xs)))) in ((f a)::((f b)::((f c)::((f d)::((map f) tl))))) - else (failwith "no matching"))) + else fail)) let rec append = (fun xs -> (fun ys -> if (is_empty xs) then ys @@ -324,7 +324,7 @@ then let x = (hd_list_get xs) in let xs_ac0 = (tl_list_get xs) in (x::((append xs_ac0) ys)) - else (failwith "no matching"))) + else fail)) let concat = let rec helper = (fun xs -> if (is_empty xs) then [] @@ -332,7 +332,7 @@ then let h = (hd_list_get xs) in let tl = (tl_list_get xs) in ((append h) (helper tl)) - else (failwith "no matching")) in + else fail) in helper let rec iter = (fun f -> (fun xs -> if (is_empty xs) @@ -342,7 +342,7 @@ let tl = (tl_list_get xs) in let () = (f h) in ((iter f) tl) - else (failwith "no matching"))) + else fail)) let rec cartesian = (fun xs -> (fun ys -> if (is_empty xs) then [] @@ -350,7 +350,7 @@ then let h = (hd_list_get xs) in let tl = (tl_list_get xs) in ((append ((map (fun a -> (h, a))) ys)) ((cartesian tl) ys)) - else (failwith "no matching"))) + else fail)) let main = let () = ((iter print_int) (1::(2::(3::[])))) in let () = (print_int (length ((cartesian (1::(2::[]))) (1::(2::(3::(4::[]))))))) in From a36b41cb96d8df35c61b035a6998a0151fe21941 Mon Sep 17 00:00:00 2001 From: RozhkovAleksandr Date: Fri, 11 Apr 2025 00:07:26 +0300 Subject: [PATCH 67/92] fix case with _ in match --- FML/lib/anf/anf.ml | 3 --- FML/lib/anf/match_elimination.ml | 13 ++++++++----- FML/tests/c_conv_manytest.t | 3 +-- FML/tests/lambda_lift_manytest.t | 3 +-- FML/tests/match_elimination_manytest.t | 3 +-- 5 files changed, 11 insertions(+), 14 deletions(-) diff --git a/FML/lib/anf/anf.ml b/FML/lib/anf/anf.ml index cf84644ec..e69de29bb 100644 --- a/FML/lib/anf/anf.ml +++ b/FML/lib/anf/anf.ml @@ -1,3 +0,0 @@ -(** Copyright 2024-2025, Dmitry Pilyuk, Aleksandr Rozhkov *) - -(** SPDX-License-Identifier: LGPL-2.1 *) diff --git a/FML/lib/anf/match_elimination.ml b/FML/lib/anf/match_elimination.ml index b21b7a56a..bc72d3ccd 100644 --- a/FML/lib/anf/match_elimination.ml +++ b/FML/lib/anf/match_elimination.ml @@ -18,18 +18,23 @@ let const_to_pe_const = function let rec pattern_remove pat = match pat with | PUnit -> [ "()" ] + | PAny -> [] | PConst _ -> [] | PIdentifier id -> [ id ] | PNill -> [ "[]" ] | PTuple pats -> List.concat_map ~f:pattern_remove pats | PCons (hd, tl) -> pattern_remove hd @ pattern_remove tl | PConstraint (p, _) -> pattern_remove p - | _ -> failwith "bye-bye, bro. im sleeping" ;; let rec pattern_bindings expr pat = match pat with - | PIdentifier id -> [ id, expr ] + | PIdentifier id when String.(id <> "_") -> [ id, expr ] + | PIdentifier _ -> [] + | PAny -> [] + | PConst _ -> [] + | PUnit -> [] + | PNill -> [] | PCons (hd, tl) -> let hd_expr = Me_EApp (Me_EIdentifier "hd_list_get", expr) in let tl_expr = Me_EApp (Me_EIdentifier "tl_list_get", expr) in @@ -42,8 +47,6 @@ let rec pattern_bindings expr pat = pattern_bindings ith_expr p) |> List.concat | PConstraint (p, _) -> pattern_bindings expr p - | _ -> [] -;; let rec_flags : Ast.rec_flag -> Me_ast.rec_flag = function | Rec -> Rec @@ -158,7 +161,7 @@ and desugar_match e branches = return (acc @ [ cond ])) in return - @@ List.fold_right conds ~init:(Me_EConst (Me_CBool true)) ~f:(fun c acc -> + @@ List.fold_right conds ~init:(Me_EConst (Me_CBool true)) ~f:(fun c acc -> Me_EIf (c, acc, Me_EConst (Me_CBool false))) | PConstraint (p, _) -> pattern_to_condition expr p in diff --git a/FML/tests/c_conv_manytest.t b/FML/tests/c_conv_manytest.t index 6ac2dea74..78125adb1 100644 --- a/FML/tests/c_conv_manytest.t +++ b/FML/tests/c_conv_manytest.t @@ -38,8 +38,7 @@ let rec length = (fun xs -> if (is_empty xs) then 0 else if (is_cons xs) - then let _ = (hd_list_get xs) in - let tl = (tl_list_get xs) in + then let tl = (tl_list_get xs) in ((( + ) 1) (length xs)) else fail) diff --git a/FML/tests/lambda_lift_manytest.t b/FML/tests/lambda_lift_manytest.t index 1a1378e38..809e22e9c 100644 --- a/FML/tests/lambda_lift_manytest.t +++ b/FML/tests/lambda_lift_manytest.t @@ -65,8 +65,7 @@ let rec lam_ll1 = (fun length xs -> if (is_empty xs) then 0 else if (is_cons xs) - then let _ = (hd_list_get xs) in - let tl = (tl_list_get xs) in + then let tl = (tl_list_get xs) in ((( + ) 1) (length xs)) else fail) and length = (lam_ll1 length) diff --git a/FML/tests/match_elimination_manytest.t b/FML/tests/match_elimination_manytest.t index d7f9b62ec..9413e6e34 100644 --- a/FML/tests/match_elimination_manytest.t +++ b/FML/tests/match_elimination_manytest.t @@ -38,8 +38,7 @@ let rec length = (fun xs -> if (is_empty xs) then 0 else if (is_cons xs) - then let _ = (hd_list_get xs) in - let tl = (tl_list_get xs) in + then let tl = (tl_list_get xs) in ((( + ) 1) (length xs)) else fail) From 49f1ecb4a4a3273474116f57c88368c6e57d6861 Mon Sep 17 00:00:00 2001 From: RozhkovAleksandr Date: Fri, 11 Apr 2025 23:03:57 +0300 Subject: [PATCH 68/92] fix handle for func first class in LL --- FML/lib/anf/lambda_lift.ml | 59 +++++----- FML/tests/lambda_lift_manytest.t | 196 +++++++++++-------------------- 2 files changed, 99 insertions(+), 156 deletions(-) diff --git a/FML/lib/anf/lambda_lift.ml b/FML/lib/anf/lambda_lift.ml index 65acfa308..9516d8fd3 100644 --- a/FML/lib/anf/lambda_lift.ml +++ b/FML/lib/anf/lambda_lift.ml @@ -39,7 +39,7 @@ let free_vars expr bound = helper expr bound ;; -let rec ll_expr expr = +let rec ll_expr expr = match expr with | Me_EUnit | Me_ENill | Me_EConst _ | Me_EIdentifier _ -> return ([], expr) | Me_EIf (e1, e2, e3) -> @@ -69,39 +69,44 @@ let rec ll_expr expr = | Me_ELet (flag, name, e1, e2) -> let* defs1, e1' = ll_expr e1 in let* defs2, e2' = ll_expr e2 in - (* e1' — это анонимная функция (а функции у нас только так) *) (match e1' with | Me_EFun (args, body) -> - let* id = fresh in - let new_name = get_new_id id name in let fvs = free_vars e1' (Set.of_list (module String) args) in - let new_args = fvs @ args in - let new_fun = Me_EFun (new_args, body) in - let def = new_name, new_fun in - let call_expr = - List.fold_left - (List.map ~f:(fun x -> Me_EIdentifier x) fvs) - ~init:(Me_EIdentifier new_name) - ~f:(fun acc arg -> Me_EApp (acc, arg)) - in - return (defs1 @ [ def ] @ defs2, Me_ELet (flag, name, call_expr, e2')) + if List.is_empty fvs + then return (defs1 @ defs2, Me_ELet (flag, name, e1', e2')) + else ( + let* id = fresh in + let new_name = get_new_id id name in + let new_args = fvs @ args in + let new_fun = Me_EFun (new_args, body) in + let def = new_name, new_fun in + let call_expr = + List.fold_left + (List.map ~f:(fun x -> Me_EIdentifier x) fvs) + ~init:(Me_EIdentifier new_name) + ~f:(fun acc arg -> Me_EApp (acc, arg)) + in + return (defs1 @ [ def ] @ defs2, Me_ELet (flag, name, call_expr, e2'))) | _ -> return (defs1 @ defs2, Me_ELet (flag, name, e1', e2'))) | Me_EFun (args, body) -> - let* id = fresh in - let name = get_new_id id "lam" in let bound = Set.of_list (module String) args in let fvs = free_vars expr bound in - let all_args = fvs @ args in - let* defs, body' = ll_expr body in - let new_fun = Me_EFun (all_args, body') in - let def = name, new_fun in - let call_expr = - List.fold_left - (List.map ~f:(fun x -> Me_EIdentifier x) fvs) - ~init:(Me_EIdentifier name) - ~f:(fun acc arg -> Me_EApp (acc, arg)) - in - return (defs @ [ def ], call_expr) + if List.is_empty fvs + then return ([], expr) + else + let* id = fresh in + let name = get_new_id id "lam" in + let all_args = fvs @ args in + let* defs, body' = ll_expr body in + let new_fun = Me_EFun (all_args, body') in + let def = name, new_fun in + let call_expr = + List.fold_left + (List.map ~f:(fun x -> Me_EIdentifier x) fvs) + ~init:(Me_EIdentifier name) + ~f:(fun acc arg -> Me_EApp (acc, arg)) + in + return (defs @ [ def ], call_expr) ;; let ll_binding (name, expr) = diff --git a/FML/tests/lambda_lift_manytest.t b/FML/tests/lambda_lift_manytest.t index 809e22e9c..e38e69f22 100644 --- a/FML/tests/lambda_lift_manytest.t +++ b/FML/tests/lambda_lift_manytest.t @@ -4,7 +4,7 @@ > | a::[] -> 1 > | [] -> 0 > EOF - let lam_ll0 = (fun xs -> if if (is_cons xs) + let length = (fun xs -> if if (is_cons xs) then if (is_cons (tl_list_get xs)) then (is_empty (tl_list_get (tl_list_get xs))) else false @@ -20,13 +20,11 @@ else if (is_empty xs) then 0 else fail) - let length = lam_ll0 $ ./lambda_lift_runner.exe << EOF > let f = let y x = x + 1 in y 3;; > EOF - let lam_ll0 = (fun x -> ((( + ) x) 1)) - let f = let y = lam_ll0 in + let f = let y = (fun x -> ((( + ) x) 1)) in (y 3) $ ./lambda_lift_runner.exe << EOF @@ -35,7 +33,7 @@ > | a::[] -> 1 > | [] -> 0 > EOF - let lam_ll0 = (fun xs -> if if (is_cons xs) + let length = (fun xs -> if if (is_cons xs) then if (is_cons (tl_list_get xs)) then (is_empty (tl_list_get (tl_list_get xs))) else false @@ -51,7 +49,6 @@ else if (is_empty xs) then 0 else fail) - let length = lam_ll0 $ ./lambda_lift_runner.exe << EOF > let is_empty x = x+1 @@ -59,16 +56,15 @@ > | [] -> 0 > | _::tl -> 1 + length xs > EOF - let lam_ll0 = (fun x -> ((( + ) x) 1)) - let is_empty_ac0 = lam_ll0 + let is_empty_ac0 = (fun x -> ((( + ) x) 1)) - let rec lam_ll1 = (fun length xs -> if (is_empty xs) + let rec lam_ll0 = (fun length xs -> if (is_empty xs) then 0 else if (is_cons xs) then let tl = (tl_list_get xs) in ((( + ) 1) (length xs)) else fail) - and length = (lam_ll1 length) + and length = (lam_ll0 length) $ ./lambda_lift_runner.exe << EOF > let (a, b) = (5,6) @@ -85,16 +81,12 @@ > in > fack n (fun x -> x) > EOF - let lam_ll5 = (fun k_ac1 n_ac2 m -> (k_ac1 ((( * ) m) n_ac2))) - let lam_ll4 = (fun k_ac1 n_ac2 -> ((lam_ll5 k_ac1) n_ac2)) - let lam_ll3 = (fun k_ac1 -> (lam_ll4 k_ac1)) let lam_ll2 = (fun n_ac0 fack n_ac0 n_ac0 k -> if ((( <= ) n_ac0) 1) then (k 1) - else ((fack ((( - ) n_ac0) 1)) ((lam_ll3 k) n_ac0))) + else ((fack ((( - ) n_ac0) 1)) (((fun k_ac1 -> (fun n_ac2 -> (fun m -> (k_ac1 ((( * ) m) n_ac2))))) k) n_ac0))) let lam_ll1 = (fun fack n_ac0 -> ((((lam_ll2 n_ac0) fack) n_ac0) n_ac0)) - let lam_ll6 = (fun x -> x) let lam_ll0 = (fun fack n -> let rec fack = (lam_ll1 fack) in - ((fack n) lam_ll6)) + ((fack n) (fun x -> x))) let fac = (lam_ll0 fack) $ ./lambda_lift_runner.exe << EOF @@ -129,8 +121,7 @@ and lam_ll0 = (fun fac_cps n -> ((((lam_ll1 n) fac_cps) n) n)) and fac_cps = (lam_ll0 fac_cps) - let lam_ll3 = (fun print_int_ac0 -> print_int_ac0) - let main = let () = (print_int ((fac_cps 4) lam_ll3)) in + let main = let () = (print_int ((fac_cps 4) (fun print_int_ac0 -> print_int_ac0))) in 0 $ ./lambda_lift_runner.exe < manytests/typed/003fib.ml @@ -153,30 +144,16 @@ 0 $ ./lambda_lift_runner.exe < manytests/typed/004manyargs.ml - let lam_ll0 = (fun f -> if ((( = ) 1) 1) + let wrap = (fun f -> if ((( = ) 1) 1) then f else f) - let wrap = lam_ll0 - let lam_ll3 = (fun a b c -> let a_ac0 = (print_int a) in + let test3 = (fun a -> (fun b -> (fun c -> let a_ac0 = (print_int a) in let b_ac1 = (print_int b) in let c_ac2 = (print_int c) in - 0) - let lam_ll2 = (fun a b -> ((lam_ll3 a) b)) - let lam_ll1 = (fun a -> (lam_ll2 a)) - let test3 = lam_ll1 - - let lam_ll13 = (fun a b c d e f g h i j -> ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) a) b)) c)) d)) e)) f)) g)) h)) i)) j)) - let lam_ll12 = (fun a b c d e f g h i -> (((((((((lam_ll13 a) b) c) d) e) f) g) h) i)) - let lam_ll11 = (fun a b c d e f g h -> ((((((((lam_ll12 a) b) c) d) e) f) g) h)) - let lam_ll10 = (fun a b c d e f g -> (((((((lam_ll11 a) b) c) d) e) f) g)) - let lam_ll9 = (fun a b c d e f -> ((((((lam_ll10 a) b) c) d) e) f)) - let lam_ll8 = (fun a b c d e -> (((((lam_ll9 a) b) c) d) e)) - let lam_ll7 = (fun a b c d -> ((((lam_ll8 a) b) c) d)) - let lam_ll6 = (fun a b c -> (((lam_ll7 a) b) c)) - let lam_ll5 = (fun a b -> ((lam_ll6 a) b)) - let lam_ll4 = (fun a -> (lam_ll5 a)) - let test10 = lam_ll4 + 0))) + + let test10 = (fun a -> (fun b -> (fun c -> (fun d -> (fun e -> (fun f -> (fun g -> (fun h -> (fun i -> (fun j -> ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) a) b)) c)) d)) e)) f)) g)) h)) i)) j))))))))))) let main = let rez = (((((((((((wrap test10) 1) 10) 100) 1000) 10000) 100000) 1000000) 10000000) 100000000) 1000000000) in let () = (print_int rez) in @@ -188,37 +165,29 @@ and lam_ll0 = (fun fix f -> (((lam_ll1 f) fix) f)) and fix = (lam_ll0 fix) - let lam_ll3 = (fun self n -> if ((( <= ) n) 1) + let fac = (fun self -> (fun n -> if ((( <= ) n) 1) then 1 - else ((( * ) n) (self ((( - ) n) 1)))) - let lam_ll2 = (fun self -> (lam_ll3 self)) - let fac = lam_ll2 + else ((( * ) n) (self ((( - ) n) 1))))) let main = let () = (print_int ((fix fac) 6)) in 0 $ ./lambda_lift_runner.exe < manytests/typed/006partial.ml - let lam_ll1 = (fun foo -> ((( + ) foo) 2)) - let lam_ll2 = (fun foo -> ((( * ) foo) 10)) - let lam_ll0 = (fun b -> if b - then lam_ll1 - else lam_ll2) - let foo = lam_ll0 + let foo = (fun b -> if b + then (fun foo -> ((( + ) foo) 2)) + else (fun foo -> ((( * ) foo) 10))) - let lam_ll3 = (fun foo foo foo foo x -> ((foo true) ((foo false) ((foo true) ((foo false) x))))) - let foo_ac0 = ((((lam_ll3 foo) foo) foo) foo) + let lam_ll0 = (fun foo foo foo foo x -> ((foo true) ((foo false) ((foo true) ((foo false) x))))) + let foo_ac0 = ((((lam_ll0 foo) foo) foo) foo) let main = let () = (print_int (foo_ac0 11)) in 0 $ ./lambda_lift_runner.exe < manytests/typed/006partial2.ml - let lam_ll2 = (fun a b a b c -> let () = (print_int a) in + let foo = (fun a -> (fun b -> (fun c -> let () = (print_int a) in let () = (print_int b) in let () = (print_int c) in - ((( + ) a) ((( * ) b) c))) - let lam_ll1 = (fun a a b -> ((((lam_ll2 a) b) a) b)) - let lam_ll0 = (fun a -> ((lam_ll1 a) a)) - let foo = lam_ll0 + ((( + ) a) ((( * ) b) c))))) let main = let foo_ac0 = (foo 1) in let foo_ac1 = (foo_ac0 2) in @@ -226,47 +195,28 @@ let () = (print_int foo_ac2) in 0 $ ./lambda_lift_runner.exe < manytests/typed/006partial3.ml - let lam_ll2 = (fun c -> (print_int c)) - let lam_ll1 = (fun b -> let () = (print_int b) in - lam_ll2) - let lam_ll0 = (fun a -> let () = (print_int a) in - lam_ll1) - let foo = lam_ll0 + let foo = (fun a -> let () = (print_int a) in + (fun b -> let () = (print_int b) in + (fun c -> (print_int c)))) let main = let () = (((foo 4) 8) 9) in 0 $ ./lambda_lift_runner.exe < manytests/typed/007order.ml - let lam_ll8 = (fun a b a b _c d __ -> let () = (print_int ((( + ) a) b)) in + let _start = (fun () -> (fun () -> (fun a -> (fun () -> (fun b -> (fun _c -> (fun () -> (fun d -> (fun __ -> let () = (print_int ((( + ) a) b)) in let () = (print_int __) in - ((( + ) ((( / ) ((( * ) a) b)) _c)) d)) - let lam_ll7 = (fun a b a b _c d -> ((((((lam_ll8 a) b) a) b) _c) d)) - let lam_ll6 = (fun a b a b _c () -> (((((lam_ll7 a) b) a) b) _c)) - let lam_ll5 = (fun a b a b _c -> (((((lam_ll6 a) b) a) b) _c)) - let lam_ll4 = (fun a a b -> ((((lam_ll5 a) b) a) b)) - let lam_ll3 = (fun a a () -> ((lam_ll4 a) a)) - let lam_ll2 = (fun a -> ((lam_ll3 a) a)) - let lam_ll1 = (fun () -> lam_ll2) - let lam_ll0 = (fun () -> lam_ll1) - let _start = lam_ll0 + ((( + ) ((( / ) ((( * ) a) b)) _c)) d)))))))))) let main = (print_int (((((((((_start (print_int 1)) (print_int 2)) 3) (print_int 4)) 100) 1000) (print_int (( ~- ) 1))) 10000) (( ~- ) 555555))) $ ./lambda_lift_runner.exe < manytests/typed/008ascription.ml - let lam_ll2 = (fun f g x -> ((f x) (g x))) - let lam_ll1 = (fun f g -> ((lam_ll2 f) g)) - let lam_ll0 = (fun f -> (lam_ll1 f)) - let addi = lam_ll0 + let addi = (fun f -> (fun g -> (fun x -> ((f x) (g x))))) - let lam_ll4 = (fun x x b -> if b + let main = let () = (print_int (((addi (fun x -> (fun b -> if b then ((( + ) x) 1) - else ((( * ) x) 2)) - let lam_ll3 = (fun x -> ((lam_ll4 x) x)) - let lam_ll5 = (fun _start -> ((( = ) ((( / ) _start) 2)) 0)) - let main = let () = (print_int (((addi lam_ll3) lam_ll5) 4)) in + else ((( * ) x) 2)))) (fun _start -> ((( = ) ((( / ) _start) 2)) 0))) 4)) in 0 $ ./lambda_lift_runner.exe < manytests/typed/009let_poly.ml - let lam_ll0 = (fun x -> x) - let temp = let f = lam_ll0 in + let temp = let f = (fun x -> x) in ((f 1), (f true)) $ ./lambda_lift_runner.exe < manytests/typed/011mapcps.ml @@ -293,9 +243,7 @@ and lam_ll4 = (fun iter f -> (((lam_ll5 f) iter) f)) and iter = (lam_ll4 iter) - let lam_ll6 = (fun x -> ((( + ) x) 1)) - let lam_ll7 = (fun x -> x) - let main = ((iter print_int) (((map lam_ll6) (1::(2::(3::[])))) lam_ll7)) + let main = ((iter print_int) (((map (fun x -> ((( + ) x) 1))) (1::(2::(3::[])))) (fun x -> x))) $ ./lambda_lift_runner.exe < manytests/typed/012fibcps.ml let rec lam_ll3 = (fun k a b -> (k ((( + ) a) b))) and lam_ll2 = (fun fib n k a -> ((fib ((( - ) n) 2)) ((lam_ll3 k) a))) @@ -305,79 +253,69 @@ and lam_ll0 = (fun fib fib n -> ((((((lam_ll1 n) n) fib) n) fib) n)) and fib = ((lam_ll0 fib) fib) - let lam_ll4 = (fun x -> x) - let main = (print_int ((fib 6) lam_ll4)) + let main = (print_int ((fib 6) (fun x -> x))) $ ./lambda_lift_runner.exe < manytests/typed/013foldfoldr.ml - let lam_ll0 = (fun x -> x) - let id = lam_ll0 + let id = (fun x -> x) - let rec lam_ll3 = (fun acc f fold_right f acc xs -> if (is_empty xs) + let rec lam_ll2 = (fun acc f fold_right f acc xs -> if (is_empty xs) then acc else if (is_cons xs) then let h = (hd_list_get xs) in let tl = (tl_list_get xs) in ((f h) (((fold_right f) acc) tl)) else fail) - and lam_ll2 = (fun f fold_right f acc -> (((((lam_ll3 acc) f) fold_right) f) acc)) - and lam_ll1 = (fun fold_right f -> (((lam_ll2 f) fold_right) f)) - and fold_right = (lam_ll1 fold_right) - - let lam_ll9 = (fun g f b x -> (g ((f x) b))) - let lam_ll8 = (fun f b g -> (((lam_ll9 g) f) b)) - let lam_ll7 = (fun f b -> ((lam_ll8 f) b)) - let lam_ll6 = (fun fold_right f id a bs -> ((((fold_right (lam_ll7 f)) id) bs) a)) - let lam_ll5 = (fun fold_right f id a -> ((((lam_ll6 fold_right) f) id) a)) - let lam_ll4 = (fun fold_right id f -> (((lam_ll5 fold_right) f) id)) - let foldl = ((lam_ll4 fold_right) id) - - let lam_ll11 = (fun x y -> ((( * ) x) y)) - let lam_ll10 = (fun x -> (lam_ll11 x)) - let main = (print_int (((foldl lam_ll10) 1) (1::(2::(3::[]))))) + and lam_ll1 = (fun f fold_right f acc -> (((((lam_ll2 acc) f) fold_right) f) acc)) + and lam_ll0 = (fun fold_right f -> (((lam_ll1 f) fold_right) f)) + and fold_right = (lam_ll0 fold_right) + + let lam_ll8 = (fun g f b x -> (g ((f x) b))) + let lam_ll7 = (fun f b g -> (((lam_ll8 g) f) b)) + let lam_ll6 = (fun f b -> ((lam_ll7 f) b)) + let lam_ll5 = (fun fold_right f id a bs -> ((((fold_right (lam_ll6 f)) id) bs) a)) + let lam_ll4 = (fun fold_right f id a -> ((((lam_ll5 fold_right) f) id) a)) + let lam_ll3 = (fun fold_right id f -> (((lam_ll4 fold_right) f) id)) + let foldl = ((lam_ll3 fold_right) id) + + let main = (print_int (((foldl (fun x -> (fun y -> ((( * ) x) y)))) 1) (1::(2::(3::[]))))) $ ./lambda_lift_runner.exe < manytests/typed/015tuples.ml let rec lam_ll1 = (fun f fix f x -> ((f (fix f)) x)) and lam_ll0 = (fun fix f -> (((lam_ll1 f) fix) f)) and fix = (lam_ll0 fix) - let lam_ll3 = (fun f f p -> let a = ((tuple_get p) 0) in + let map = (fun f -> (fun p -> let a = ((tuple_get p) 0) in let b = ((tuple_get p) 1) in - ((f a), (f b))) - let lam_ll2 = (fun f -> ((lam_ll3 f) f)) - let map = lam_ll2 - - let lam_ll8 = (fun li self l_ac0 x -> ((li (self l_ac0)) x)) - let lam_ll7 = (fun self l_ac0 li -> (((lam_ll8 li) self) l_ac0)) - let lam_ll6 = (fun map self l_ac0 -> ((map ((lam_ll7 self) l_ac0)) l_ac0)) - let lam_ll5 = (fun map self -> ((lam_ll6 map) self)) - let lam_ll4 = (fun fix map l -> ((fix (lam_ll5 map)) l)) - let fixpoly = ((lam_ll4 fix) map) - - let lam_ll10 = (fun p p n -> let e = ((tuple_get p) 0) in + ((f a), (f b)))) + + let lam_ll6 = (fun li self l_ac0 x -> ((li (self l_ac0)) x)) + let lam_ll5 = (fun self l_ac0 li -> (((lam_ll6 li) self) l_ac0)) + let lam_ll4 = (fun map self l_ac0 -> ((map ((lam_ll5 self) l_ac0)) l_ac0)) + let lam_ll3 = (fun map self -> ((lam_ll4 map) self)) + let lam_ll2 = (fun fix map l -> ((fix (lam_ll3 map)) l)) + let fixpoly = ((lam_ll2 fix) map) + + let feven = (fun p -> (fun n -> let e = ((tuple_get p) 0) in let o = ((tuple_get p) 1) in if ((( = ) n) 0) then 1 - else (o ((( - ) n) 1))) - let lam_ll9 = (fun p -> ((lam_ll10 p) p)) - let feven = lam_ll9 + else (o ((( - ) n) 1)))) - let lam_ll12 = (fun p p n -> let e = ((tuple_get p) 0) in + let fodd = (fun p -> (fun n -> let e = ((tuple_get p) 0) in let o = ((tuple_get p) 1) in if ((( = ) n) 0) then 0 - else (e ((( - ) n) 1))) - let lam_ll11 = (fun p -> ((lam_ll12 p) p)) - let fodd = lam_ll11 + else (e ((( - ) n) 1)))) let tie = (fixpoly (feven, fodd)) - let rec lam_ll13 = (fun modd n -> if ((( = ) n) 0) + let rec lam_ll7 = (fun modd n -> if ((( = ) n) 0) then 1 else (modd ((( - ) n) 1))) - and meven = (lam_ll13 modd) - and lam_ll14 = (fun meven n -> if ((( = ) n) 0) + and meven = (lam_ll7 modd) + and lam_ll8 = (fun meven n -> if ((( = ) n) 0) then 1 else (meven ((( - ) n) 1))) - and modd = (lam_ll14 meven) + and modd = (lam_ll8 meven) let main = let () = (print_int (modd 1)) in let () = (print_int (meven 2)) in From 3806322afa3bf13c22cfa99173e26efc461e89df Mon Sep 17 00:00:00 2001 From: Dmitry Pilyuk Date: Tue, 15 Apr 2025 00:39:32 +0300 Subject: [PATCH 69/92] fix bugs --- FML/lib/anf/lambda_lift.ml | 145 +++++++---------- FML/lib/anf/match_elimination.ml | 16 +- FML/tests/c_conv_manytest.t | 94 +++++------ FML/tests/lambda_lift_manytest.t | 212 ++++++++++--------------- FML/tests/match_elimination_manytest.t | 103 ++++++------ 5 files changed, 260 insertions(+), 310 deletions(-) diff --git a/FML/lib/anf/lambda_lift.ml b/FML/lib/anf/lambda_lift.ml index 9516d8fd3..d1ac530cd 100644 --- a/FML/lib/anf/lambda_lift.ml +++ b/FML/lib/anf/lambda_lift.ml @@ -9,51 +9,25 @@ open StateMonad let get_new_id n name = Base.String.concat [ name; "_ll"; Int.to_string n ] -let free_vars expr bound = - let builtins_set = StrSet.of_list builtins in - let is_builtin x = StrSet.find builtins_set x in - - let rec helper expr bound = - match expr with - | Me_EUnit | Me_ENill | Me_EConst _ -> [] - | Me_EIdentifier x -> - if Set.mem bound x || is_builtin x then - [] - else - [x] - | Me_EIf (e1, e2, e3) -> - helper e1 bound @ helper e2 bound @ helper e3 bound - | Me_EFun (args, body) -> - let bound' = List.fold_left ~f:Set.add ~init:bound args in - helper body bound' - | Me_EApp (e1, e2) -> helper e1 bound @ helper e2 bound - | Me_ELet (_, name, e1, e2) -> - let fv1 = helper e1 bound in - let fv2 = helper e2 (Set.add bound name) in - fv1 @ fv2 - | Me_ECons (e1, e2) -> helper e1 bound @ helper e2 bound - | Me_ETuple lst -> - List.fold_left lst ~init:[] ~f:(fun acc e -> acc @ helper e bound) - in - - helper expr bound -;; - -let rec ll_expr expr = +let rec ll_expr bindings expr = match expr with - | Me_EUnit | Me_ENill | Me_EConst _ | Me_EIdentifier _ -> return ([], expr) + | Me_EUnit | Me_ENill | Me_EConst _ -> return ([], expr) + | Me_EIdentifier id -> + (match StrMap.find bindings id with + | Some name -> return ([], Me_EIdentifier name) + | None -> return ([], expr)) | Me_EIf (e1, e2, e3) -> - let* defs1, e1' = ll_expr e1 in - let* defs2, e2' = ll_expr e2 in - let* defs3, e3' = ll_expr e3 in + let* defs1, e1' = ll_expr bindings e1 in + let* defs2, e2' = ll_expr bindings e2 in + let* defs3, e3' = ll_expr bindings e3 in return (defs1 @ defs2 @ defs3, Me_EIf (e1', e2', e3')) | Me_EApp (e1, e2) -> - let* defs1, e1' = ll_expr e1 in - let* defs2, e2' = ll_expr e2 in + let* defs1, e1' = ll_expr bindings e1 in + let* defs2, e2' = ll_expr bindings e2 in return (defs1 @ defs2, Me_EApp (e1', e2')) | Me_ECons (e1, e2) -> - let* defs1, e1' = ll_expr e1 in - let* defs2, e2' = ll_expr e2 in + let* defs1, e1' = ll_expr bindings e1 in + let* defs2, e2' = ll_expr bindings e2 in return (defs1 @ defs2, Me_ECons (e1', e2')) | Me_ETuple lst -> let* results = @@ -61,57 +35,54 @@ let rec ll_expr expr = lst ~init:(return ([], [])) ~f:(fun (acc_defs, acc_exprs) e -> - let* defs, e' = ll_expr e in + let* defs, e' = ll_expr bindings e in return (acc_defs @ defs, acc_exprs @ [ e' ])) in let defs, exprs = results in return (defs, Me_ETuple exprs) - | Me_ELet (flag, name, e1, e2) -> - let* defs1, e1' = ll_expr e1 in - let* defs2, e2' = ll_expr e2 in - (match e1' with - | Me_EFun (args, body) -> - let fvs = free_vars e1' (Set.of_list (module String) args) in - if List.is_empty fvs - then return (defs1 @ defs2, Me_ELet (flag, name, e1', e2')) - else ( - let* id = fresh in - let new_name = get_new_id id name in - let new_args = fvs @ args in - let new_fun = Me_EFun (new_args, body) in - let def = new_name, new_fun in - let call_expr = - List.fold_left - (List.map ~f:(fun x -> Me_EIdentifier x) fvs) - ~init:(Me_EIdentifier new_name) - ~f:(fun acc arg -> Me_EApp (acc, arg)) - in - return (defs1 @ [ def ] @ defs2, Me_ELet (flag, name, call_expr, e2'))) - | _ -> return (defs1 @ defs2, Me_ELet (flag, name, e1', e2'))) + | Me_ELet (NoRec, name, e1, e2) -> + (match e1 with + | Me_EFun (args, e1) -> + let* defs1, e1' = ll_expr bindings e1 in + let* id = fresh in + let new_name = get_new_id id name in + let def = new_name, Me_EFun (args, e1') in + let* defs2, e2' = + ll_expr (StrMap.update bindings name ~f:(fun _ -> new_name)) e2 + in + return (defs1 @ [ def ] @ defs2, e2') + | e1 -> + let* defs1, e1' = ll_expr bindings e1 in + let* defs2, e2' = ll_expr bindings e2 in + return (defs1 @ defs2, Me_ELet (NoRec, name, e1', e2'))) + | Me_ELet (Rec, name, e1, e2) -> + (match e1 with + | Me_EFun (args, e1) -> + let* id = fresh in + let new_name = get_new_id id name in + let bindings' = StrMap.update bindings name ~f:(fun _ -> new_name) in + let* defs1, e1' = ll_expr bindings' e1 in + let def = new_name, Me_EFun (args, e1') in + let* defs2, e2' = ll_expr bindings' e2 in + return (defs1 @ [ def ] @ defs2, e2') + | _ -> failwith "Not reachable") | Me_EFun (args, body) -> - let bound = Set.of_list (module String) args in - let fvs = free_vars expr bound in - if List.is_empty fvs - then return ([], expr) - else - let* id = fresh in - let name = get_new_id id "lam" in - let all_args = fvs @ args in - let* defs, body' = ll_expr body in - let new_fun = Me_EFun (all_args, body') in - let def = name, new_fun in - let call_expr = - List.fold_left - (List.map ~f:(fun x -> Me_EIdentifier x) fvs) - ~init:(Me_EIdentifier name) - ~f:(fun acc arg -> Me_EApp (acc, arg)) - in - return (defs @ [ def ], call_expr) + let* id = fresh in + let name = get_new_id id "lam" in + let* defs, body' = ll_expr bindings body in + let new_fun = Me_EFun (args, body') in + let def = name, new_fun in + return (defs @ [ def ], Me_EIdentifier name) ;; let ll_binding (name, expr) = - let* defs, expr' = ll_expr expr in - return (defs @ [ name, expr' ]) + match expr with + | Me_EFun (args, expr) -> + let* defs, expr' = ll_expr StrMap.empty expr in + return (defs @ [ name, Me_EFun (args, expr') ]) + | expr -> + let* defs, expr' = ll_expr StrMap.empty expr in + return (defs @ [ name, expr' ]) ;; let ll_decl decl = @@ -124,10 +95,12 @@ let ll_decl decl = in return (Me_Nonrec all_defs) | Me_Rec bindings -> - RList.fold_left bindings ~init:(return []) ~f:(fun acc (name, expr) -> - let* defs, expr' = ll_expr expr in - return (acc @ defs @ [ name, expr' ])) - >>= fun all -> return (Me_Rec all) + let* all_defs = + RList.fold_left bindings ~init:(return []) ~f:(fun acc b -> + let* lifted = ll_binding b in + return (acc @ lifted)) + in + return (Me_Rec all_defs) ;; let lambda_lift prog = diff --git a/FML/lib/anf/match_elimination.ml b/FML/lib/anf/match_elimination.ml index bc72d3ccd..56b9da764 100644 --- a/FML/lib/anf/match_elimination.ml +++ b/FML/lib/anf/match_elimination.ml @@ -47,6 +47,7 @@ let rec pattern_bindings expr pat = pattern_bindings ith_expr p) |> List.concat | PConstraint (p, _) -> pattern_bindings expr p +;; let rec_flags : Ast.rec_flag -> Me_ast.rec_flag = function | Rec -> Rec @@ -65,9 +66,13 @@ let rec expr_to_mexpr expr = let* arg' = expr_to_mexpr arg in return @@ Me_EApp (f', arg') | EFun (pat, body) -> - let ids = pattern_remove pat in - let* body' = expr_to_mexpr body in - return @@ Me_EFun (ids, body') + let rec helper acc = function + | EFun (pat, body) -> helper (acc @ pattern_remove pat) body + | expr -> + let* body = expr_to_mexpr expr in + return @@ Me_EFun (acc, body) + in + helper (pattern_remove pat) body | ELetIn (rec_flag, pat, e1, e2) -> let ids = pattern_remove pat in let* e1' = expr_to_mexpr e1 in @@ -161,7 +166,7 @@ and desugar_match e branches = return (acc @ [ cond ])) in return - @@ List.fold_right conds ~init:(Me_EConst (Me_CBool true)) ~f:(fun c acc -> + @@ List.fold_right conds ~init:(Me_EConst (Me_CBool true)) ~f:(fun c acc -> Me_EIf (c, acc, Me_EConst (Me_CBool false))) | PConstraint (p, _) -> pattern_to_condition expr p in @@ -180,8 +185,7 @@ and desugar_match e branches = in let* rest_expr = match rest with - | [] -> - return @@ Me_EIdentifier "fail" + | [] -> return @@ Me_EIdentifier "fail" | _ -> let new_e = match bind_expr_opt with diff --git a/FML/tests/c_conv_manytest.t b/FML/tests/c_conv_manytest.t index 78125adb1..18173f187 100644 --- a/FML/tests/c_conv_manytest.t +++ b/FML/tests/c_conv_manytest.t @@ -57,9 +57,9 @@ > in > fack n (fun x -> x) > EOF - let fac = (fun n -> let rec fack = (fun n_ac0 -> ((fun n_ac0 k -> if ((( <= ) n_ac0) 1) + let fac = (fun n -> let rec fack = (fun n_ac0 k -> if ((( <= ) n_ac0) 1) then (k 1) - else ((fack ((( - ) n_ac0) 1)) (((fun k_ac1 -> ((fun k_ac1 n_ac2 -> (((fun k_ac1 n_ac2 m -> (k_ac1 ((( * ) m) n_ac2))) k_ac1) n_ac2)) k_ac1)) k) n_ac0))) n_ac0)) in + else ((fack ((( - ) n_ac0) 1)) (((fun k_ac1 n_ac2 m -> (k_ac1 ((( * ) m) n_ac2))) k) n_ac0))) in ((fack n) (fun x -> x))) $ ./c_conv_runner.exe << EOF @@ -85,19 +85,19 @@ 0 $ ./c_conv_runner.exe < manytests/typed/002fac.ml - let rec fac_cps = (fun n -> ((fun n k -> if ((( = ) n) 1) + let rec fac_cps = (fun n k -> if ((( = ) n) 1) then (k 1) - else ((fac_cps ((( - ) n) 1)) (((fun k n p -> (k ((( * ) p) n))) k) n))) n)) + else ((fac_cps ((( - ) n) 1)) (((fun k n p -> (k ((( * ) p) n))) k) n))) let main = let () = (print_int ((fac_cps 4) (fun print_int_ac0 -> print_int_ac0))) in 0 $ ./c_conv_runner.exe < manytests/typed/003fib.ml - let rec fib_acc = (fun a -> ((fun a b -> (((fun a b n -> if ((( = ) n) 1) + let rec fib_acc = (fun a b n -> if ((( = ) n) 1) then b else let n1 = ((( - ) n) 1) in let ab = ((( + ) a) b) in - (((fib_acc b) ab) n1)) a) b)) a)) + (((fib_acc b) ab) n1)) let rec fib = (fun n -> if ((( < ) n) 2) then n @@ -112,12 +112,12 @@ then f else f) - let test3 = (fun a -> ((fun a b -> (((fun a b c -> let a_ac0 = (print_int a) in + let test3 = (fun a b c -> let a_ac0 = (print_int a) in let b_ac1 = (print_int b) in let c_ac2 = (print_int c) in - 0) a) b)) a)) + 0) - let test10 = (fun a -> ((fun a b -> (((fun a b c -> ((((fun a b c d -> (((((fun a b c d e -> ((((((fun a b c d e f -> (((((((fun a b c d e f g -> ((((((((fun a b c d e f g h -> (((((((((fun a b c d e f g h i -> ((((((((((fun a b c d e f g h i j -> ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) a) b)) c)) d)) e)) f)) g)) h)) i)) j)) a) b) c) d) e) f) g) h) i)) a) b) c) d) e) f) g) h)) a) b) c) d) e) f) g)) a) b) c) d) e) f)) a) b) c) d) e)) a) b) c) d)) a) b) c)) a) b)) a)) + let test10 = (fun a b c d e f g h i j -> ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) a) b)) c)) d)) e)) f)) g)) h)) i)) j)) let main = let rez = (((((((((((wrap test10) 1) 10) 100) 1000) 10000) 100000) 1000000) 10000000) 100000000) 1000000000) in let () = (print_int rez) in @@ -125,11 +125,11 @@ 0 $ ./c_conv_runner.exe < manytests/typed/005fix.ml - let rec fix = (fun f -> ((fun f x -> ((f (fix f)) x)) f)) + let rec fix = (fun f x -> ((f (fix f)) x)) - let fac = (fun self -> ((fun self n -> if ((( <= ) n) 1) + let fac = (fun self n -> if ((( <= ) n) 1) then 1 - else ((( * ) n) (self ((( - ) n) 1)))) self)) + else ((( * ) n) (self ((( - ) n) 1)))) let main = let () = (print_int ((fix fac) 6)) in 0 @@ -145,10 +145,10 @@ 0 $ ./c_conv_runner.exe < manytests/typed/006partial2.ml - let foo = (fun a -> ((fun a b -> (((fun a b c -> let () = (print_int a) in + let foo = (fun a b c -> let () = (print_int a) in let () = (print_int b) in let () = (print_int c) in - ((( + ) a) ((( * ) b) c))) a) b)) a)) + ((( + ) a) ((( * ) b) c))) let main = let foo_ac0 = (foo 1) in let foo_ac1 = (foo_ac0 2) in @@ -163,17 +163,17 @@ let main = let () = (((foo 4) 8) 9) in 0 $ ./c_conv_runner.exe < manytests/typed/007order.ml - let _start = (fun () -> (fun () -> (fun a -> ((fun a () -> ((fun a b -> (((fun a b _c -> ((((fun _c a b () -> ((((fun _c a b d -> (((((fun _c a b d __ -> let () = (print_int ((( + ) a) b)) in + let _start = (fun () () a () b _c () d __ -> let () = (print_int ((( + ) a) b)) in let () = (print_int __) in - ((( + ) ((( / ) ((( * ) a) b)) _c)) d)) _c) a) b) d)) _c) a) b)) _c) a) b)) a) b)) a)) a)))) + ((( + ) ((( / ) ((( * ) a) b)) _c)) d)) let main = (print_int (((((((((_start (print_int 1)) (print_int 2)) 3) (print_int 4)) 100) 1000) (print_int (( ~- ) 1))) 10000) (( ~- ) 555555))) $ ./c_conv_runner.exe < manytests/typed/008ascription.ml - let addi = (fun f -> ((fun f g -> (((fun f g x -> ((f x) (g x))) f) g)) f)) + let addi = (fun f g x -> ((f x) (g x))) - let main = let () = (print_int (((addi (fun x -> ((fun x b -> if b + let main = let () = (print_int (((addi (fun x b -> if b then ((( + ) x) 1) - else ((( * ) x) 2)) x))) (fun _start -> ((( = ) ((( / ) _start) 2)) 0))) 4)) in + else ((( * ) x) 2))) (fun _start -> ((( = ) ((( / ) _start) 2)) 0))) 4)) in 0 $ ./c_conv_runner.exe < manytests/typed/009let_poly.ml @@ -181,65 +181,65 @@ ((f 1), (f true)) $ ./c_conv_runner.exe < manytests/typed/011mapcps.ml - let rec map = (fun f -> ((fun f xs -> (((fun f xs k -> if (is_empty xs) + let rec map = (fun f xs k -> if (is_empty xs) then (k []) else if (is_cons xs) then let h = (hd_list_get xs) in let tl = (tl_list_get xs) in (((map f) tl) ((((fun f h k tl_ac0 -> (k ((f h)::tl_ac0))) f) h) k)) - else fail) f) xs)) f)) + else fail) - let rec iter = (fun f -> ((fun f xs -> if (is_empty xs) + let rec iter = (fun f xs -> if (is_empty xs) then () else if (is_cons xs) then let h = (hd_list_get xs) in let tl = (tl_list_get xs) in let w = (f h) in ((iter f) tl) - else fail) f)) + else fail) let main = ((iter print_int) (((map (fun x -> ((( + ) x) 1))) (1::(2::(3::[])))) (fun x -> x))) $ ./c_conv_runner.exe < manytests/typed/012fibcps.ml - let rec fib = (fun n -> ((fun n k -> if ((( < ) n) 2) + let rec fib = (fun n k -> if ((( < ) n) 2) then (k n) - else ((fib ((( - ) n) 1)) (((fun k n a -> ((fib ((( - ) n) 2)) (((fun a k b -> (k ((( + ) a) b))) a) k))) k) n))) n)) + else ((fib ((( - ) n) 1)) (((fun k n a -> ((fib ((( - ) n) 2)) (((fun a k b -> (k ((( + ) a) b))) a) k))) k) n))) let main = (print_int ((fib 6) (fun x -> x))) $ ./c_conv_runner.exe < manytests/typed/013foldfoldr.ml let id = (fun x -> x) - let rec fold_right = (fun f -> ((fun f acc -> (((fun acc f xs -> if (is_empty xs) + let rec fold_right = (fun f acc xs -> if (is_empty xs) then acc else if (is_cons xs) then let h = (hd_list_get xs) in let tl = (tl_list_get xs) in ((f h) (((fold_right f) acc) tl)) - else fail) acc) f)) f)) + else fail) - let foldl = (fun f -> ((fun f a -> (((fun a f bs -> ((((fold_right ((fun f b -> (((fun b f g -> ((((fun b f g x -> (g ((f x) b))) b) f) g)) b) f)) f)) id) bs) a)) a) f)) f)) + let foldl = (fun f a bs -> ((((fold_right ((fun f b g x -> (g ((f x) b))) f)) id) bs) a)) - let main = (print_int (((foldl (fun x -> ((fun x y -> ((( * ) x) y)) x))) 1) (1::(2::(3::[]))))) + let main = (print_int (((foldl (fun x y -> ((( * ) x) y))) 1) (1::(2::(3::[]))))) $ ./c_conv_runner.exe < manytests/typed/015tuples.ml - let rec fix = (fun f -> ((fun f x -> ((f (fix f)) x)) f)) + let rec fix = (fun f x -> ((f (fix f)) x)) - let map = (fun f -> ((fun f p -> let a = ((tuple_get p) 0) in + let map = (fun f p -> let a = ((tuple_get p) 0) in let b = ((tuple_get p) 1) in - ((f a), (f b))) f)) + ((f a), (f b))) - let fixpoly = (fun l -> ((fix (fun self -> ((fun self l_ac0 -> ((map (((fun l_ac0 self li -> ((((fun l_ac0 li self x -> ((li (self l_ac0)) x)) l_ac0) li) self)) l_ac0) self)) l_ac0)) self))) l)) + let fixpoly = (fun l -> ((fix (fun self l_ac0 -> ((map (((fun l_ac0 self li x -> ((li (self l_ac0)) x)) l_ac0) self)) l_ac0))) l)) - let feven = (fun p -> ((fun p n -> let e = ((tuple_get p) 0) in + let feven = (fun p n -> let e = ((tuple_get p) 0) in let o = ((tuple_get p) 1) in if ((( = ) n) 0) then 1 - else (o ((( - ) n) 1))) p)) + else (o ((( - ) n) 1))) - let fodd = (fun p -> ((fun p n -> let e = ((tuple_get p) 0) in + let fodd = (fun p n -> let e = ((tuple_get p) 0) in let o = ((tuple_get p) 1) in if ((( = ) n) 0) then 0 - else (e ((( - ) n) 1))) p)) + else (e ((( - ) n) 1))) let tie = (fixpoly (feven, fodd)) @@ -267,16 +267,16 @@ ((( + ) 1) (length tl)) else fail) - let length_tail = let rec helper = (fun acc -> ((fun acc xs -> if (is_empty xs) + let length_tail = let rec helper = (fun acc xs -> if (is_empty xs) then acc else if (is_cons xs) then let h = (hd_list_get xs) in let tl = (tl_list_get xs) in ((helper ((( + ) acc) 1)) tl) - else fail) acc)) in + else fail) in (helper 0) - let rec map = (fun f -> ((fun f xs -> if (is_empty xs) + let rec map = (fun f xs -> if (is_empty xs) then [] else if if (is_cons xs) then (is_empty (tl_list_get xs)) @@ -315,15 +315,15 @@ let d = (hd_list_get (tl_list_get (tl_list_get (tl_list_get xs)))) in let tl = (tl_list_get (tl_list_get (tl_list_get (tl_list_get xs)))) in ((f a)::((f b)::((f c)::((f d)::((map f) tl))))) - else fail) f)) + else fail) - let rec append = (fun xs -> ((fun xs ys -> if (is_empty xs) + let rec append = (fun xs ys -> if (is_empty xs) then ys else if (is_cons xs) then let x = (hd_list_get xs) in let xs_ac0 = (tl_list_get xs) in (x::((append xs_ac0) ys)) - else fail) xs)) + else fail) let concat = let rec helper = (fun xs -> if (is_empty xs) then [] @@ -334,22 +334,22 @@ else fail) in helper - let rec iter = (fun f -> ((fun f xs -> if (is_empty xs) + let rec iter = (fun f xs -> if (is_empty xs) then () else if (is_cons xs) then let h = (hd_list_get xs) in let tl = (tl_list_get xs) in let () = (f h) in ((iter f) tl) - else fail) f)) + else fail) - let rec cartesian = (fun xs -> ((fun xs ys -> if (is_empty xs) + let rec cartesian = (fun xs ys -> if (is_empty xs) then [] else if (is_cons xs) then let h = (hd_list_get xs) in let tl = (tl_list_get xs) in ((append ((map ((fun h a -> (h, a)) h)) ys)) ((cartesian tl) ys)) - else fail) xs)) + else fail) let main = let () = ((iter print_int) (1::(2::(3::[])))) in let () = (print_int (length ((cartesian (1::(2::[]))) (1::(2::(3::(4::[]))))))) in diff --git a/FML/tests/lambda_lift_manytest.t b/FML/tests/lambda_lift_manytest.t index e38e69f22..f53c1e30d 100644 --- a/FML/tests/lambda_lift_manytest.t +++ b/FML/tests/lambda_lift_manytest.t @@ -24,8 +24,8 @@ $ ./lambda_lift_runner.exe << EOF > let f = let y x = x + 1 in y 3;; > EOF - let f = let y = (fun x -> ((( + ) x) 1)) in - (y 3) + let y_ll0 = (fun x -> ((( + ) x) 1)) + let f = (y_ll0 3) $ ./lambda_lift_runner.exe << EOF > let length xs = match xs with @@ -58,13 +58,12 @@ > EOF let is_empty_ac0 = (fun x -> ((( + ) x) 1)) - let rec lam_ll0 = (fun length xs -> if (is_empty xs) + let rec length = (fun xs -> if (is_empty xs) then 0 else if (is_cons xs) then let tl = (tl_list_get xs) in ((( + ) 1) (length xs)) else fail) - and length = (lam_ll0 length) $ ./lambda_lift_runner.exe << EOF > let (a, b) = (5,6) @@ -81,13 +80,12 @@ > in > fack n (fun x -> x) > EOF - let lam_ll2 = (fun n_ac0 fack n_ac0 n_ac0 k -> if ((( <= ) n_ac0) 1) + let lam_ll1 = (fun k_ac1 n_ac2 m -> (k_ac1 ((( * ) m) n_ac2))) + let fack_ll0 = (fun n_ac0 k -> if ((( <= ) n_ac0) 1) then (k 1) - else ((fack ((( - ) n_ac0) 1)) (((fun k_ac1 -> (fun n_ac2 -> (fun m -> (k_ac1 ((( * ) m) n_ac2))))) k) n_ac0))) - let lam_ll1 = (fun fack n_ac0 -> ((((lam_ll2 n_ac0) fack) n_ac0) n_ac0)) - let lam_ll0 = (fun fack n -> let rec fack = (lam_ll1 fack) in - ((fack n) (fun x -> x))) - let fac = (lam_ll0 fack) + else ((fack_ll0 ((( - ) n_ac0) 1)) ((lam_ll1 k) n_ac0))) + let lam_ll2 = (fun x -> x) + let fac = (fun n -> ((fack_ll0 n) lam_ll2)) $ ./lambda_lift_runner.exe << EOF > let f x = match x with @@ -95,49 +93,42 @@ > | 12 -> 12 > | _ -> 325 > EOF - let lam_ll0 = (fun (=) (=) x -> if (((=) x) 1) + let f = (fun x -> if (((=) x) 1) then 12 else if (((=) x) 12) then 12 else if true then 325 else fail) - let f = ((lam_ll0 (=)) (=)) $ ./lambda_lift_runner.exe < manytests/typed/001fac.ml - let rec lam_ll0 = (fun fac n -> if ((( <= ) n) 1) + let rec fac = (fun n -> if ((( <= ) n) 1) then 1 else ((( * ) n) (fac ((( - ) n) 1)))) - and fac = (lam_ll0 fac) let main = let () = (print_int (fac 4)) in 0 $ ./lambda_lift_runner.exe < manytests/typed/002fac.ml - let rec lam_ll2 = (fun k n p -> (k ((( * ) p) n))) - and lam_ll1 = (fun n fac_cps n n k -> if ((( = ) n) 1) + let rec lam_ll0 = (fun p -> (k ((( * ) p) n))) + and fac_cps = (fun n k -> if ((( = ) n) 1) then (k 1) - else ((fac_cps ((( - ) n) 1)) ((lam_ll2 k) n))) - and lam_ll0 = (fun fac_cps n -> ((((lam_ll1 n) fac_cps) n) n)) - and fac_cps = (lam_ll0 fac_cps) + else ((fac_cps ((( - ) n) 1)) lam_ll0)) - let main = let () = (print_int ((fac_cps 4) (fun print_int_ac0 -> print_int_ac0))) in + let lam_ll1 = (fun print_int_ac0 -> print_int_ac0) + let main = let () = (print_int ((fac_cps 4) lam_ll1)) in 0 $ ./lambda_lift_runner.exe < manytests/typed/003fib.ml - let rec lam_ll2 = (fun b a b fib_acc b n -> if ((( = ) n) 1) + let rec fib_acc = (fun a b n -> if ((( = ) n) 1) then b else let n1 = ((( - ) n) 1) in let ab = ((( + ) a) b) in (((fib_acc b) ab) n1)) - and lam_ll1 = (fun a fib_acc b -> (((((lam_ll2 b) a) b) fib_acc) b)) - and lam_ll0 = (fun fib_acc a -> ((lam_ll1 a) fib_acc)) - and fib_acc = (lam_ll0 fib_acc) - let rec lam_ll3 = (fun fib fib n -> if ((( < ) n) 2) + let rec fib = (fun n -> if ((( < ) n) 2) then n else ((( + ) (fib ((( - ) n) 1))) (fib ((( - ) n) 2)))) - and fib = ((lam_ll3 fib) fib) let main = let () = (print_int (((fib_acc 0) 1) 4)) in let () = (print_int (fib 4)) in @@ -148,12 +139,12 @@ then f else f) - let test3 = (fun a -> (fun b -> (fun c -> let a_ac0 = (print_int a) in + let test3 = (fun a b c -> let a_ac0 = (print_int a) in let b_ac1 = (print_int b) in let c_ac2 = (print_int c) in - 0))) + 0) - let test10 = (fun a -> (fun b -> (fun c -> (fun d -> (fun e -> (fun f -> (fun g -> (fun h -> (fun i -> (fun j -> ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) a) b)) c)) d)) e)) f)) g)) h)) i)) j))))))))))) + let test10 = (fun a b c d e f g h i j -> ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) a) b)) c)) d)) e)) f)) g)) h)) i)) j)) let main = let rez = (((((((((((wrap test10) 1) 10) 100) 1000) 10000) 100000) 1000000) 10000000) 100000000) 1000000000) in let () = (print_int rez) in @@ -161,33 +152,32 @@ 0 $ ./lambda_lift_runner.exe < manytests/typed/005fix.ml - let rec lam_ll1 = (fun f fix f x -> ((f (fix f)) x)) - and lam_ll0 = (fun fix f -> (((lam_ll1 f) fix) f)) - and fix = (lam_ll0 fix) + let rec fix = (fun f x -> ((f (fix f)) x)) - let fac = (fun self -> (fun n -> if ((( <= ) n) 1) + let fac = (fun self n -> if ((( <= ) n) 1) then 1 - else ((( * ) n) (self ((( - ) n) 1))))) + else ((( * ) n) (self ((( - ) n) 1)))) let main = let () = (print_int ((fix fac) 6)) in 0 $ ./lambda_lift_runner.exe < manytests/typed/006partial.ml + let lam_ll0 = (fun foo -> ((( + ) foo) 2)) + let lam_ll1 = (fun foo -> ((( * ) foo) 10)) let foo = (fun b -> if b - then (fun foo -> ((( + ) foo) 2)) - else (fun foo -> ((( * ) foo) 10))) + then lam_ll0 + else lam_ll1) - let lam_ll0 = (fun foo foo foo foo x -> ((foo true) ((foo false) ((foo true) ((foo false) x))))) - let foo_ac0 = ((((lam_ll0 foo) foo) foo) foo) + let foo_ac0 = (fun x -> ((foo true) ((foo false) ((foo true) ((foo false) x))))) let main = let () = (print_int (foo_ac0 11)) in 0 $ ./lambda_lift_runner.exe < manytests/typed/006partial2.ml - let foo = (fun a -> (fun b -> (fun c -> let () = (print_int a) in + let foo = (fun a b c -> let () = (print_int a) in let () = (print_int b) in let () = (print_int c) in - ((( + ) a) ((( * ) b) c))))) + ((( + ) a) ((( * ) b) c))) let main = let foo_ac0 = (foo 1) in let foo_ac1 = (foo_ac0 2) in @@ -195,44 +185,45 @@ let () = (print_int foo_ac2) in 0 $ ./lambda_lift_runner.exe < manytests/typed/006partial3.ml + let lam_ll1 = (fun c -> (print_int c)) + let lam_ll0 = (fun b -> let () = (print_int b) in + lam_ll1) let foo = (fun a -> let () = (print_int a) in - (fun b -> let () = (print_int b) in - (fun c -> (print_int c)))) + lam_ll0) let main = let () = (((foo 4) 8) 9) in 0 $ ./lambda_lift_runner.exe < manytests/typed/007order.ml - let _start = (fun () -> (fun () -> (fun a -> (fun () -> (fun b -> (fun _c -> (fun () -> (fun d -> (fun __ -> let () = (print_int ((( + ) a) b)) in + let _start = (fun () () a () b _c () d __ -> let () = (print_int ((( + ) a) b)) in let () = (print_int __) in - ((( + ) ((( / ) ((( * ) a) b)) _c)) d)))))))))) + ((( + ) ((( / ) ((( * ) a) b)) _c)) d)) let main = (print_int (((((((((_start (print_int 1)) (print_int 2)) 3) (print_int 4)) 100) 1000) (print_int (( ~- ) 1))) 10000) (( ~- ) 555555))) $ ./lambda_lift_runner.exe < manytests/typed/008ascription.ml - let addi = (fun f -> (fun g -> (fun x -> ((f x) (g x))))) + let addi = (fun f g x -> ((f x) (g x))) - let main = let () = (print_int (((addi (fun x -> (fun b -> if b + let lam_ll0 = (fun x b -> if b then ((( + ) x) 1) - else ((( * ) x) 2)))) (fun _start -> ((( = ) ((( / ) _start) 2)) 0))) 4)) in + else ((( * ) x) 2)) + let lam_ll1 = (fun _start -> ((( = ) ((( / ) _start) 2)) 0)) + let main = let () = (print_int (((addi lam_ll0) lam_ll1) 4)) in 0 $ ./lambda_lift_runner.exe < manytests/typed/009let_poly.ml - let temp = let f = (fun x -> x) in - ((f 1), (f true)) + let f_ll0 = (fun x -> x) + let temp = ((f_ll0 1), (f_ll0 true)) $ ./lambda_lift_runner.exe < manytests/typed/011mapcps.ml - let rec lam_ll3 = (fun k f h tl_ac0 -> (k ((f h)::tl_ac0))) - and lam_ll2 = (fun xs xs xs xs map f f k -> if (is_empty xs) + let rec lam_ll0 = (fun tl_ac0 -> (k ((f h)::tl_ac0))) + and map = (fun f xs k -> if (is_empty xs) then (k []) else if (is_cons xs) then let h = (hd_list_get xs) in let tl = (tl_list_get xs) in - (((map f) tl) (((lam_ll3 k) f) h)) + (((map f) tl) lam_ll0) else fail) - and lam_ll1 = (fun map f f xs -> (((((((lam_ll2 xs) xs) xs) xs) map) f) f)) - and lam_ll0 = (fun map f -> (((lam_ll1 map) f) f)) - and map = (lam_ll0 map) - let rec lam_ll5 = (fun f iter f xs -> if (is_empty xs) + let rec iter = (fun f xs -> if (is_empty xs) then () else if (is_cons xs) then let h = (hd_list_get xs) in @@ -240,82 +231,67 @@ let w = (f h) in ((iter f) tl) else fail) - and lam_ll4 = (fun iter f -> (((lam_ll5 f) iter) f)) - and iter = (lam_ll4 iter) - let main = ((iter print_int) (((map (fun x -> ((( + ) x) 1))) (1::(2::(3::[])))) (fun x -> x))) + let lam_ll1 = (fun x -> ((( + ) x) 1)) + let lam_ll2 = (fun x -> x) + let main = ((iter print_int) (((map lam_ll1) (1::(2::(3::[])))) lam_ll2)) $ ./lambda_lift_runner.exe < manytests/typed/012fibcps.ml - let rec lam_ll3 = (fun k a b -> (k ((( + ) a) b))) - and lam_ll2 = (fun fib n k a -> ((fib ((( - ) n) 2)) ((lam_ll3 k) a))) - and lam_ll1 = (fun n n fib n fib n k -> if ((( < ) n) 2) + let rec lam_ll1 = (fun b -> (k ((( + ) a) b))) + and lam_ll0 = (fun a -> ((fib ((( - ) n) 2)) lam_ll1)) + and fib = (fun n k -> if ((( < ) n) 2) then (k n) - else ((fib ((( - ) n) 1)) (((lam_ll2 fib) n) k))) - and lam_ll0 = (fun fib fib n -> ((((((lam_ll1 n) n) fib) n) fib) n)) - and fib = ((lam_ll0 fib) fib) + else ((fib ((( - ) n) 1)) lam_ll0)) - let main = (print_int ((fib 6) (fun x -> x))) + let lam_ll2 = (fun x -> x) + let main = (print_int ((fib 6) lam_ll2)) $ ./lambda_lift_runner.exe < manytests/typed/013foldfoldr.ml let id = (fun x -> x) - let rec lam_ll2 = (fun acc f fold_right f acc xs -> if (is_empty xs) + let rec fold_right = (fun f acc xs -> if (is_empty xs) then acc else if (is_cons xs) then let h = (hd_list_get xs) in let tl = (tl_list_get xs) in ((f h) (((fold_right f) acc) tl)) else fail) - and lam_ll1 = (fun f fold_right f acc -> (((((lam_ll2 acc) f) fold_right) f) acc)) - and lam_ll0 = (fun fold_right f -> (((lam_ll1 f) fold_right) f)) - and fold_right = (lam_ll0 fold_right) - - let lam_ll8 = (fun g f b x -> (g ((f x) b))) - let lam_ll7 = (fun f b g -> (((lam_ll8 g) f) b)) - let lam_ll6 = (fun f b -> ((lam_ll7 f) b)) - let lam_ll5 = (fun fold_right f id a bs -> ((((fold_right (lam_ll6 f)) id) bs) a)) - let lam_ll4 = (fun fold_right f id a -> ((((lam_ll5 fold_right) f) id) a)) - let lam_ll3 = (fun fold_right id f -> (((lam_ll4 fold_right) f) id)) - let foldl = ((lam_ll3 fold_right) id) - - let main = (print_int (((foldl (fun x -> (fun y -> ((( * ) x) y)))) 1) (1::(2::(3::[]))))) + + let lam_ll0 = (fun b g x -> (g ((f x) b))) + let foldl = (fun f a bs -> ((((fold_right lam_ll0) id) bs) a)) + + let lam_ll1 = (fun x y -> ((( * ) x) y)) + let main = (print_int (((foldl lam_ll1) 1) (1::(2::(3::[]))))) $ ./lambda_lift_runner.exe < manytests/typed/015tuples.ml - let rec lam_ll1 = (fun f fix f x -> ((f (fix f)) x)) - and lam_ll0 = (fun fix f -> (((lam_ll1 f) fix) f)) - and fix = (lam_ll0 fix) + let rec fix = (fun f x -> ((f (fix f)) x)) - let map = (fun f -> (fun p -> let a = ((tuple_get p) 0) in + let map = (fun f p -> let a = ((tuple_get p) 0) in let b = ((tuple_get p) 1) in - ((f a), (f b)))) + ((f a), (f b))) - let lam_ll6 = (fun li self l_ac0 x -> ((li (self l_ac0)) x)) - let lam_ll5 = (fun self l_ac0 li -> (((lam_ll6 li) self) l_ac0)) - let lam_ll4 = (fun map self l_ac0 -> ((map ((lam_ll5 self) l_ac0)) l_ac0)) - let lam_ll3 = (fun map self -> ((lam_ll4 map) self)) - let lam_ll2 = (fun fix map l -> ((fix (lam_ll3 map)) l)) - let fixpoly = ((lam_ll2 fix) map) + let lam_ll1 = (fun li x -> ((li (self l_ac0)) x)) + let lam_ll0 = (fun self l_ac0 -> ((map lam_ll1) l_ac0)) + let fixpoly = (fun l -> ((fix lam_ll0) l)) - let feven = (fun p -> (fun n -> let e = ((tuple_get p) 0) in + let feven = (fun p n -> let e = ((tuple_get p) 0) in let o = ((tuple_get p) 1) in if ((( = ) n) 0) then 1 - else (o ((( - ) n) 1)))) + else (o ((( - ) n) 1))) - let fodd = (fun p -> (fun n -> let e = ((tuple_get p) 0) in + let fodd = (fun p n -> let e = ((tuple_get p) 0) in let o = ((tuple_get p) 1) in if ((( = ) n) 0) then 0 - else (e ((( - ) n) 1)))) + else (e ((( - ) n) 1))) let tie = (fixpoly (feven, fodd)) - let rec lam_ll7 = (fun modd n -> if ((( = ) n) 0) + let rec meven = (fun n -> if ((( = ) n) 0) then 1 else (modd ((( - ) n) 1))) - and meven = (lam_ll7 modd) - and lam_ll8 = (fun meven n -> if ((( = ) n) 0) + and modd = (fun n -> if ((( = ) n) 0) then 1 else (meven ((( - ) n) 1))) - and modd = (lam_ll8 meven) let main = let () = (print_int (modd 1)) in let () = (print_int (meven 2)) in @@ -326,27 +302,24 @@ 0 $ ./lambda_lift_runner.exe < manytests/typed/016lists.ml - let rec lam_ll0 = (fun length xs -> if (is_empty xs) + let rec length = (fun xs -> if (is_empty xs) then 0 else if (is_cons xs) then let h = (hd_list_get xs) in let tl = (tl_list_get xs) in ((( + ) 1) (length tl)) else fail) - and length = (lam_ll0 length) - let lam_ll2 = (fun acc helper acc xs -> if (is_empty xs) + let helper_ll0 = (fun acc xs -> if (is_empty xs) then acc else if (is_cons xs) then let h = (hd_list_get xs) in let tl = (tl_list_get xs) in - ((helper ((( + ) acc) 1)) tl) + ((helper_ll0 ((( + ) acc) 1)) tl) else fail) - let lam_ll1 = (fun helper acc -> (((lam_ll2 acc) helper) acc)) - let length_tail = let rec helper = (lam_ll1 helper) in - (helper 0) + let length_tail = (helper_ll0 0) - let rec lam_ll4 = (fun f f f f f f f f f f map f xs -> if (is_empty xs) + let rec map = (fun f xs -> if (is_empty xs) then [] else if if (is_cons xs) then (is_empty (tl_list_get xs)) @@ -386,30 +359,25 @@ let tl = (tl_list_get (tl_list_get (tl_list_get (tl_list_get xs)))) in ((f a)::((f b)::((f c)::((f d)::((map f) tl))))) else fail) - and lam_ll3 = (fun map f -> ((((((((((((lam_ll4 f) f) f) f) f) f) f) f) f) f) map) f)) - and map = (lam_ll3 map) - let rec lam_ll6 = (fun xs xs xs xs append ys -> if (is_empty xs) + let rec append = (fun xs ys -> if (is_empty xs) then ys else if (is_cons xs) then let x = (hd_list_get xs) in let xs_ac0 = (tl_list_get xs) in (x::((append xs_ac0) ys)) else fail) - and lam_ll5 = (fun append xs -> (((((lam_ll6 xs) xs) xs) xs) append)) - and append = (lam_ll5 append) - let lam_ll7 = (fun append helper xs -> if (is_empty xs) + let helper_ll1 = (fun xs -> if (is_empty xs) then [] else if (is_cons xs) then let h = (hd_list_get xs) in let tl = (tl_list_get xs) in - ((append h) (helper tl)) + ((append h) (helper_ll1 tl)) else fail) - let concat = let rec helper = ((lam_ll7 append) helper) in - helper + let concat = helper_ll1 - let rec lam_ll9 = (fun f iter f xs -> if (is_empty xs) + let rec iter = (fun f xs -> if (is_empty xs) then () else if (is_cons xs) then let h = (hd_list_get xs) in @@ -417,19 +385,15 @@ let () = (f h) in ((iter f) tl) else fail) - and lam_ll8 = (fun iter f -> (((lam_ll9 f) iter) f)) - and iter = (lam_ll8 iter) - let rec lam_ll12 = (fun h a -> (h, a)) - and lam_ll11 = (fun xs xs xs xs append map cartesian ys -> if (is_empty xs) + let rec lam_ll2 = (fun a -> (h, a)) + and cartesian = (fun xs ys -> if (is_empty xs) then [] else if (is_cons xs) then let h = (hd_list_get xs) in let tl = (tl_list_get xs) in - ((append ((map (lam_ll12 h)) ys)) ((cartesian tl) ys)) + ((append ((map lam_ll2) ys)) ((cartesian tl) ys)) else fail) - and lam_ll10 = (fun append map cartesian xs -> (((((((lam_ll11 xs) xs) xs) xs) append) map) cartesian)) - and cartesian = (((lam_ll10 append) map) cartesian) let main = let () = ((iter print_int) (1::(2::(3::[])))) in let () = (print_int (length ((cartesian (1::(2::[]))) (1::(2::(3::(4::[]))))))) in diff --git a/FML/tests/match_elimination_manytest.t b/FML/tests/match_elimination_manytest.t index 9413e6e34..801a1e5e9 100644 --- a/FML/tests/match_elimination_manytest.t +++ b/FML/tests/match_elimination_manytest.t @@ -1,3 +1,12 @@ + $ ./match_elimination_runner.exe << EOF + > let f (x,y) = x+y;; + > let main = let () = print_int ( f (1,2) ) in 0;; + > EOF + let f = (fun x y -> ((( + ) x) y)) + + let main = let () = (print_int (f (1, 2))) in + 0 + $ ./match_elimination_runner.exe << EOF > let f = let y x = x + 1 in y 3;; > EOF @@ -57,9 +66,9 @@ > in > fack n (fun x -> x) > EOF - let fac = (fun n -> let rec fack = (fun n_ac0 -> (fun k -> if ((( <= ) n_ac0) 1) + let fac = (fun n -> let rec fack = (fun n_ac0 k -> if ((( <= ) n_ac0) 1) then (k 1) - else ((fack ((( - ) n_ac0) 1)) (((fun k_ac1 -> (fun n_ac2 -> (fun m -> (k_ac1 ((( * ) m) n_ac2))))) k) n_ac0)))) in + else ((fack ((( - ) n_ac0) 1)) (((fun k_ac1 n_ac2 m -> (k_ac1 ((( * ) m) n_ac2))) k) n_ac0))) in ((fack n) (fun x -> x))) $ ./match_elimination_runner.exe << EOF @@ -85,19 +94,19 @@ 0 $ ./match_elimination_runner.exe < manytests/typed/002fac.ml - let rec fac_cps = (fun n -> (fun k -> if ((( = ) n) 1) + let rec fac_cps = (fun n k -> if ((( = ) n) 1) then (k 1) - else ((fac_cps ((( - ) n) 1)) (fun p -> (k ((( * ) p) n)))))) + else ((fac_cps ((( - ) n) 1)) (fun p -> (k ((( * ) p) n))))) let main = let () = (print_int ((fac_cps 4) (fun print_int_ac0 -> print_int_ac0))) in 0 $ ./match_elimination_runner.exe < manytests/typed/003fib.ml - let rec fib_acc = (fun a -> (fun b -> (fun n -> if ((( = ) n) 1) + let rec fib_acc = (fun a b n -> if ((( = ) n) 1) then b else let n1 = ((( - ) n) 1) in let ab = ((( + ) a) b) in - (((fib_acc b) ab) n1)))) + (((fib_acc b) ab) n1)) let rec fib = (fun n -> if ((( < ) n) 2) then n @@ -112,12 +121,12 @@ then f else f) - let test3 = (fun a -> (fun b -> (fun c -> let a_ac0 = (print_int a) in + let test3 = (fun a b c -> let a_ac0 = (print_int a) in let b_ac1 = (print_int b) in let c_ac2 = (print_int c) in - 0))) + 0) - let test10 = (fun a -> (fun b -> (fun c -> (fun d -> (fun e -> (fun f -> (fun g -> (fun h -> (fun i -> (fun j -> ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) a) b)) c)) d)) e)) f)) g)) h)) i)) j))))))))))) + let test10 = (fun a b c d e f g h i j -> ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) ((( + ) a) b)) c)) d)) e)) f)) g)) h)) i)) j)) let main = let rez = (((((((((((wrap test10) 1) 10) 100) 1000) 10000) 100000) 1000000) 10000000) 100000000) 1000000000) in let () = (print_int rez) in @@ -125,11 +134,11 @@ 0 $ ./match_elimination_runner.exe < manytests/typed/005fix.ml - let rec fix = (fun f -> (fun x -> ((f (fix f)) x))) + let rec fix = (fun f x -> ((f (fix f)) x)) - let fac = (fun self -> (fun n -> if ((( <= ) n) 1) + let fac = (fun self n -> if ((( <= ) n) 1) then 1 - else ((( * ) n) (self ((( - ) n) 1))))) + else ((( * ) n) (self ((( - ) n) 1)))) let main = let () = (print_int ((fix fac) 6)) in 0 @@ -145,10 +154,10 @@ 0 $ ./match_elimination_runner.exe < manytests/typed/006partial2.ml - let foo = (fun a -> (fun b -> (fun c -> let () = (print_int a) in + let foo = (fun a b c -> let () = (print_int a) in let () = (print_int b) in let () = (print_int c) in - ((( + ) a) ((( * ) b) c))))) + ((( + ) a) ((( * ) b) c))) let main = let foo_ac0 = (foo 1) in let foo_ac1 = (foo_ac0 2) in @@ -163,17 +172,17 @@ let main = let () = (((foo 4) 8) 9) in 0 $ ./match_elimination_runner.exe < manytests/typed/007order.ml - let _start = (fun () -> (fun () -> (fun a -> (fun () -> (fun b -> (fun _c -> (fun () -> (fun d -> (fun __ -> let () = (print_int ((( + ) a) b)) in + let _start = (fun () () a () b _c () d __ -> let () = (print_int ((( + ) a) b)) in let () = (print_int __) in - ((( + ) ((( / ) ((( * ) a) b)) _c)) d)))))))))) + ((( + ) ((( / ) ((( * ) a) b)) _c)) d)) let main = (print_int (((((((((_start (print_int 1)) (print_int 2)) 3) (print_int 4)) 100) 1000) (print_int (( ~- ) 1))) 10000) (( ~- ) 555555))) $ ./match_elimination_runner.exe < manytests/typed/008ascription.ml - let addi = (fun f -> (fun g -> (fun x -> ((f x) (g x))))) + let addi = (fun f g x -> ((f x) (g x))) - let main = let () = (print_int (((addi (fun x -> (fun b -> if b + let main = let () = (print_int (((addi (fun x b -> if b then ((( + ) x) 1) - else ((( * ) x) 2)))) (fun _start -> ((( = ) ((( / ) _start) 2)) 0))) 4)) in + else ((( * ) x) 2))) (fun _start -> ((( = ) ((( / ) _start) 2)) 0))) 4)) in 0 $ ./match_elimination_runner.exe < manytests/typed/009let_poly.ml @@ -181,65 +190,65 @@ ((f 1), (f true)) $ ./match_elimination_runner.exe < manytests/typed/011mapcps.ml - let rec map = (fun f -> (fun xs -> (fun k -> if (is_empty xs) + let rec map = (fun f xs k -> if (is_empty xs) then (k []) else if (is_cons xs) then let h = (hd_list_get xs) in let tl = (tl_list_get xs) in (((map f) tl) (fun tl_ac0 -> (k ((f h)::tl_ac0)))) - else fail))) + else fail) - let rec iter = (fun f -> (fun xs -> if (is_empty xs) + let rec iter = (fun f xs -> if (is_empty xs) then () else if (is_cons xs) then let h = (hd_list_get xs) in let tl = (tl_list_get xs) in let w = (f h) in ((iter f) tl) - else fail)) + else fail) let main = ((iter print_int) (((map (fun x -> ((( + ) x) 1))) (1::(2::(3::[])))) (fun x -> x))) $ ./match_elimination_runner.exe < manytests/typed/012fibcps.ml - let rec fib = (fun n -> (fun k -> if ((( < ) n) 2) + let rec fib = (fun n k -> if ((( < ) n) 2) then (k n) - else ((fib ((( - ) n) 1)) (fun a -> ((fib ((( - ) n) 2)) (fun b -> (k ((( + ) a) b)))))))) + else ((fib ((( - ) n) 1)) (fun a -> ((fib ((( - ) n) 2)) (fun b -> (k ((( + ) a) b))))))) let main = (print_int ((fib 6) (fun x -> x))) $ ./match_elimination_runner.exe < manytests/typed/013foldfoldr.ml let id = (fun x -> x) - let rec fold_right = (fun f -> (fun acc -> (fun xs -> if (is_empty xs) + let rec fold_right = (fun f acc xs -> if (is_empty xs) then acc else if (is_cons xs) then let h = (hd_list_get xs) in let tl = (tl_list_get xs) in ((f h) (((fold_right f) acc) tl)) - else fail))) + else fail) - let foldl = (fun f -> (fun a -> (fun bs -> ((((fold_right (fun b -> (fun g -> (fun x -> (g ((f x) b)))))) id) bs) a)))) + let foldl = (fun f a bs -> ((((fold_right (fun b g x -> (g ((f x) b)))) id) bs) a)) - let main = (print_int (((foldl (fun x -> (fun y -> ((( * ) x) y)))) 1) (1::(2::(3::[]))))) + let main = (print_int (((foldl (fun x y -> ((( * ) x) y))) 1) (1::(2::(3::[]))))) $ ./match_elimination_runner.exe < manytests/typed/015tuples.ml - let rec fix = (fun f -> (fun x -> ((f (fix f)) x))) + let rec fix = (fun f x -> ((f (fix f)) x)) - let map = (fun f -> (fun p -> let a = ((tuple_get p) 0) in + let map = (fun f p -> let a = ((tuple_get p) 0) in let b = ((tuple_get p) 1) in - ((f a), (f b)))) + ((f a), (f b))) - let fixpoly = (fun l -> ((fix (fun self -> (fun l_ac0 -> ((map (fun li -> (fun x -> ((li (self l_ac0)) x)))) l_ac0)))) l)) + let fixpoly = (fun l -> ((fix (fun self l_ac0 -> ((map (fun li x -> ((li (self l_ac0)) x))) l_ac0))) l)) - let feven = (fun p -> (fun n -> let e = ((tuple_get p) 0) in + let feven = (fun p n -> let e = ((tuple_get p) 0) in let o = ((tuple_get p) 1) in if ((( = ) n) 0) then 1 - else (o ((( - ) n) 1)))) + else (o ((( - ) n) 1))) - let fodd = (fun p -> (fun n -> let e = ((tuple_get p) 0) in + let fodd = (fun p n -> let e = ((tuple_get p) 0) in let o = ((tuple_get p) 1) in if ((( = ) n) 0) then 0 - else (e ((( - ) n) 1)))) + else (e ((( - ) n) 1))) let tie = (fixpoly (feven, fodd)) @@ -267,16 +276,16 @@ ((( + ) 1) (length tl)) else fail) - let length_tail = let rec helper = (fun acc -> (fun xs -> if (is_empty xs) + let length_tail = let rec helper = (fun acc xs -> if (is_empty xs) then acc else if (is_cons xs) then let h = (hd_list_get xs) in let tl = (tl_list_get xs) in ((helper ((( + ) acc) 1)) tl) - else fail)) in + else fail) in (helper 0) - let rec map = (fun f -> (fun xs -> if (is_empty xs) + let rec map = (fun f xs -> if (is_empty xs) then [] else if if (is_cons xs) then (is_empty (tl_list_get xs)) @@ -315,15 +324,15 @@ let d = (hd_list_get (tl_list_get (tl_list_get (tl_list_get xs)))) in let tl = (tl_list_get (tl_list_get (tl_list_get (tl_list_get xs)))) in ((f a)::((f b)::((f c)::((f d)::((map f) tl))))) - else fail)) + else fail) - let rec append = (fun xs -> (fun ys -> if (is_empty xs) + let rec append = (fun xs ys -> if (is_empty xs) then ys else if (is_cons xs) then let x = (hd_list_get xs) in let xs_ac0 = (tl_list_get xs) in (x::((append xs_ac0) ys)) - else fail)) + else fail) let concat = let rec helper = (fun xs -> if (is_empty xs) then [] @@ -334,22 +343,22 @@ else fail) in helper - let rec iter = (fun f -> (fun xs -> if (is_empty xs) + let rec iter = (fun f xs -> if (is_empty xs) then () else if (is_cons xs) then let h = (hd_list_get xs) in let tl = (tl_list_get xs) in let () = (f h) in ((iter f) tl) - else fail)) + else fail) - let rec cartesian = (fun xs -> (fun ys -> if (is_empty xs) + let rec cartesian = (fun xs ys -> if (is_empty xs) then [] else if (is_cons xs) then let h = (hd_list_get xs) in let tl = (tl_list_get xs) in ((append ((map (fun a -> (h, a))) ys)) ((cartesian tl) ys)) - else fail)) + else fail) let main = let () = ((iter print_int) (1::(2::(3::[])))) in let () = (print_int (length ((cartesian (1::(2::[]))) (1::(2::(3::(4::[]))))))) in From f1fde8c99c2713631ac5d98cd8ff88ea4e570a99 Mon Sep 17 00:00:00 2001 From: RozhkovAleksandr Date: Tue, 15 Apr 2025 20:40:29 +0300 Subject: [PATCH 70/92] wip anf --- FML/lib/anf/anf.ml | 55 ++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 55 insertions(+) diff --git a/FML/lib/anf/anf.ml b/FML/lib/anf/anf.ml index e69de29bb..476397115 100644 --- a/FML/lib/anf/anf.ml +++ b/FML/lib/anf/anf.ml @@ -0,0 +1,55 @@ +open Anf_ast +open Me_ast +open Common +open StateMonad + + +let const_to_immexp = function + | Me_Cint i -> ImmInt i + | Me_CBool b -> ImmBool b +;; + +let rec to_cexp = function + | Me_ETuple elems -> + let* binds, imm_elems = + RList.fold_left elems ~init:(return ([], [])) ~f:(fun (acc_binds, acc_elems) el -> + let* binds_el, imm_el = check_hard_expr el in + return (acc_binds @ binds_el, acc_elems @ [imm_el])) + in + return (binds, CImmExpr (ImmTuple imm_elems)) + + | Me_ELet (NoRec, name, e1, e2) -> + let* binds1, ce1 = to_cexp e1 in + let* binds2, ce2 = to_cexp e2 in + return (binds1 @ [ name, ce1 ] @ binds2, ce2) + + | Me_ECons (e1, e2) -> + let* binds1, a1 = check_hard_expr e1 in + let* binds2, a2 = check_hard_expr e2 in + return (binds1 @ binds2, CECons (a1, a2)) + + | Me_EConst c -> return ([], CImmExpr (const_to_immexp c)) + | Me_EIdentifier v -> return ([], CImmExpr (ImmIdentifier v)) + | Me_EUnit -> return ([], CImmExpr ImmUnit) + | Me_ENill -> return ([], CImmExpr ImmNill) + | _ -> failwith "See you later space cowboy" + +(* для обработки сложных выражений в условиях *) +and check_hard_expr e = match e with + | Me_EIdentifier v -> return ([], ImmIdentifier v) + | Me_EConst c -> return ([], const_to_immexp c) + | Me_EUnit -> return ([], ImmUnit) + | Me_ENill -> return ([], ImmNill) + | e -> + let* id = fresh in + let name = "anf" ^ Int.to_string id in + let* binds1, ce = to_cexp e in + return (binds1 @ [ name, ce ], (ImmIdentifier name)) +;; + +(* let anf prog = + StateMonad.run + (RList.fold_left prog ~init:(return []) ~f:(fun acc decl -> + let* d = anf_decl decl in + return (acc @ [ d ]))) +;; *) From 9674be37778bc1dbc2e347fa35b7a285aef2cb5d Mon Sep 17 00:00:00 2001 From: RozhkovAleksandr Date: Tue, 15 Apr 2025 21:20:18 +0300 Subject: [PATCH 71/92] fix ast --- FML/lib/anf/anf_ast.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/FML/lib/anf/anf_ast.ml b/FML/lib/anf/anf_ast.ml index e925eba0a..0beaf413b 100644 --- a/FML/lib/anf/anf_ast.ml +++ b/FML/lib/anf/anf_ast.ml @@ -23,6 +23,7 @@ and aexpr = type anf_binding = ALet of string * string list * aexpr type anf_decl = + | Based_value of string * aexpr | ADNoRec of anf_binding list | ADREC of anf_binding list From 4bbc30dca31e520b9a923838c93bd4f1a58fdc05 Mon Sep 17 00:00:00 2001 From: RozhkovAleksandr Date: Tue, 15 Apr 2025 23:02:37 +0300 Subject: [PATCH 72/92] anf done --- FML/lib/anf/anf.ml | 84 +++- FML/lib/anf/anf_ast.ml | 1 + FML/tests/anf_manytest.t | 692 +++++++++++++++++++++++++++++++ FML/tests/anf_runner.ml | 33 ++ FML/tests/c_conv_manytest.t | 15 +- FML/tests/dune | 33 ++ FML/tests/lambda_lift_manytest.t | 50 +-- FML/tests/lambda_lift_runner.ml | 4 +- 8 files changed, 865 insertions(+), 47 deletions(-) create mode 100644 FML/tests/anf_manytest.t create mode 100644 FML/tests/anf_runner.ml diff --git a/FML/lib/anf/anf.ml b/FML/lib/anf/anf.ml index 476397115..09fdbe737 100644 --- a/FML/lib/anf/anf.ml +++ b/FML/lib/anf/anf.ml @@ -9,7 +9,14 @@ let const_to_immexp = function | Me_CBool b -> ImmBool b ;; -let rec to_cexp = function +let rec collect_apps expr = + match expr with + | Me_EApp (f, arg) -> + let f', args = collect_apps f in + (f', args @ [arg]) + | _ -> (expr, []) + +let rec to_cexp: me_expr -> ((string * cexpr) list * cexpr) t = function | Me_ETuple elems -> let* binds, imm_elems = RList.fold_left elems ~init:(return ([], [])) ~f:(fun (acc_binds, acc_elems) el -> @@ -28,6 +35,34 @@ let rec to_cexp = function let* binds2, a2 = check_hard_expr e2 in return (binds1 @ binds2, CECons (a1, a2)) + | Me_EIf (e1, e2, e3) -> + let* binds1, e1 = check_hard_expr e1 in + let handle_for_let (e: me_expr) = + let* binds, expr = to_cexp e in + RList.fold_right + binds + ~init:(return @@ ACExpr(expr)) + ~f:(fun (name, cexp) acc -> return @@ ALetIn(name, cexp, acc)) in + + let* ce2 = handle_for_let e2 in + let* ce3 = handle_for_let e3 in + + return (binds1, CEIf(e1, ce2, ce3)) + + | Me_EApp (e1, e2) -> + let f_expr, args = collect_apps (Me_EApp (e1, e2)) in + let* binds_f, fun_imm = check_hard_expr f_expr in + let* binds_args, imm_args = + RList.fold_left args ~init:(return ([], [])) ~f:(fun (acc_binds, acc_args) arg -> + let* binds_arg, imm_arg = check_hard_expr arg in + return (acc_binds @ binds_arg, acc_args @ [imm_arg])) + in + (match fun_imm with + | ImmIdentifier f_name -> + return (binds_f @ binds_args, CEApply (f_name, imm_args)) + | _ -> failwith "Expected function to be an identifier after all") + + | Me_EConst c -> return ([], CImmExpr (const_to_immexp c)) | Me_EIdentifier v -> return ([], CImmExpr (ImmIdentifier v)) | Me_EUnit -> return ([], CImmExpr ImmUnit) @@ -47,9 +82,50 @@ and check_hard_expr e = match e with return (binds1 @ [ name, ce ], (ImmIdentifier name)) ;; -(* let anf prog = +let anf_decl = + let handle_for_let (e: me_expr) = + let* binds, expr = to_cexp e in + RList.fold_right + binds + ~init:(return @@ ACExpr expr) + ~f:(fun (name, cexp) acc -> return @@ ALetIn(name, cexp, acc)) + in + function + | Me_Nonrec decls -> + RList.fold_left decls ~init:(return []) ~f:(fun acc (name, e) -> + let* new_expr = + match e with + | Me_EFun (args, body) -> + let* body' = handle_for_let body in + return (ALet (name, args, body')) + | _ -> + let* expr' = handle_for_let e in + return (ALet (name, [], expr')) + in + return (acc @ [ADNoRec [new_expr]]) + ) + + | Me_Rec decls -> + let* bindings = + RList.fold_left decls ~init:(return []) ~f:(fun acc (name, e) -> + let* new_e = + match e with + | Me_EFun (args, body) -> + let* body' = handle_for_let body in + return (ALet (name, args, body')) + | _ -> + let* expr' = handle_for_let e in + return (ALet (name, [], expr')) + in + return (acc @ [new_e]) + ) + in + return [ADREC bindings] + ;; + +let anf prog = StateMonad.run (RList.fold_left prog ~init:(return []) ~f:(fun acc decl -> let* d = anf_decl decl in - return (acc @ [ d ]))) -;; *) + return (acc @ d))) +;; diff --git a/FML/lib/anf/anf_ast.ml b/FML/lib/anf/anf_ast.ml index 0beaf413b..7691d9f38 100644 --- a/FML/lib/anf/anf_ast.ml +++ b/FML/lib/anf/anf_ast.ml @@ -71,6 +71,7 @@ let fun_to_str = function ;; let declaration_to_str = function + | Based_value (name, e) -> Format.sprintf "let %s =\n %s" name (exp_to_str e) | ADNoRec func_list -> let funs = List.map fun_to_str func_list in "let " ^ String.concat "\nand " funs ^ "\n;;" diff --git a/FML/tests/anf_manytest.t b/FML/tests/anf_manytest.t new file mode 100644 index 000000000..c925a2400 --- /dev/null +++ b/FML/tests/anf_manytest.t @@ -0,0 +1,692 @@ + $ ./anf_runner.exe << EOF + > let f x = let g y = x + y in g 5;; + > EOF + let g_ll0 x y = ( + ) x y + ;; + + let f x = g_ll0 x 5 + ;; + + $ ./anf_runner.exe << EOF + > let length xs = match xs with + > | a::b::[] -> 2 + > | a::[] -> 1 + > | [] -> 0 + > EOF + let length xs = let anf1 = is_cons xs in + let anf0 = if anf1 + then let anf3 = tl_list_get xs in + let anf2 = is_cons anf3 in + if anf2 + then let anf5 = tl_list_get xs in + let anf4 = tl_list_get anf5 in + is_empty anf4 + else false + else false in + if anf0 + then let a = hd_list_get xs in + let anf6 = tl_list_get xs in + let b = hd_list_get anf6 in + 2 + else let anf8 = is_cons xs in + let anf7 = if anf8 + then let anf9 = tl_list_get xs in + is_empty anf9 + else false in + if anf7 + then let a = hd_list_get xs in + 1 + else let anf10 = is_empty xs in + if anf10 + then 0 + else fail + ;; + + $ ./anf_runner.exe << EOF + > let is_empty x = x+1 + > let rec length xs = match xs with + > | [] -> 0 + > | _::tl -> 1 + length xs + > EOF + let is_empty_ac0 x = ( + ) x 1 + ;; + + let rec length xs = let anf0 = is_empty xs in + if anf0 + then 0 + else let anf1 = is_cons xs in + if anf1 + then let tl = tl_list_get xs in + let anf2 = length xs in + ( + ) 1 anf2 + else fail + ;; + + $ ./anf_runner.exe << EOF + > let (a, b) = (5,6) + > EOF + let tmp_me0 = (5, 6) + ;; + + let a = let anf0 = (tmp_me0, 0) in + tuple_get anf0 + ;; + + let b = let anf1 = (tmp_me0, 1) in + tuple_get anf1 + ;; + + $ ./anf_runner.exe << EOF + > let fac n = + > let rec fack n k = + > if n<=1 then k 1 + > else fack (n - 1) ((fun k n m -> k (m * n)) k n) + > in + > fack n (fun x -> x) + > EOF + let lam_ll1 k_ac1 n_ac2 m = let anf0 = ( * ) m n_ac2 in + k_ac1 anf0 + ;; + + let fack_ll0 n_ac0 k = let anf1 = ( <= ) n_ac0 1 in + if anf1 + then k 1 + else let anf2 = ( - ) n_ac0 1 in + let anf3 = lam_ll1 k n_ac0 in + fack_ll0 anf2 anf3 + ;; + + let lam_ll2 x = x + ;; + + let fac n = fack_ll0 n lam_ll2 + ;; + + $ ./anf_runner.exe << EOF + > let f x = match x with + > | 1 -> 12 + > | 12 -> 12 + > | _ -> 325 + > EOF + let lam_ll0 (=) x = let anf0 = (=) x 1 in + if anf0 + then 12 + else let anf1 = (=) x 12 in + if anf1 + then 12 + else if true + then 325 + else fail + ;; + + let f = lam_ll0 (=) + ;; + + $ ./anf_runner.exe < manytests/typed/001fac.ml + let rec fac n = let anf0 = ( <= ) n 1 in + if anf0 + then 1 + else let anf2 = ( - ) n 1 in + let anf1 = fac anf2 in + ( * ) n anf1 + ;; + + let main = let anf3 = fac 4 in + let () = print_int anf3 in + 0 + ;; + + $ ./anf_runner.exe < manytests/typed/002fac.ml + let rec lam_ll0 k n p = let anf0 = ( * ) p n in + k anf0 + and fac_cps n k = let anf1 = ( = ) n 1 in + if anf1 + then k 1 + else let anf2 = ( - ) n 1 in + let anf3 = lam_ll0 k n in + fac_cps anf2 anf3 + ;; + + let lam_ll1 print_int_ac0 = print_int_ac0 + ;; + + let main = let anf4 = fac_cps 4 lam_ll1 in + let () = print_int anf4 in + 0 + ;; + + $ ./anf_runner.exe < manytests/typed/003fib.ml + let rec fib_acc a b n = let anf0 = ( = ) n 1 in + if anf0 + then b + else let n1 = ( - ) n 1 in + let ab = ( + ) a b in + fib_acc b ab n1 + ;; + + let rec fib n = let anf1 = ( < ) n 2 in + if anf1 + then n + else let anf3 = ( - ) n 1 in + let anf2 = fib anf3 in + let anf5 = ( - ) n 2 in + let anf4 = fib anf5 in + ( + ) anf2 anf4 + ;; + + let main = let anf6 = fib_acc 0 1 4 in + let () = print_int anf6 in + let anf7 = fib 4 in + let () = print_int anf7 in + 0 + ;; + + $ ./anf_runner.exe < manytests/typed/004manyargs.ml + let wrap f = let anf0 = ( = ) 1 1 in + if anf0 + then f + else f + ;; + + let test3 a b c = let a_ac0 = print_int a in + let b_ac1 = print_int b in + let c_ac2 = print_int c in + 0 + ;; + + let test10 a b c d e f g h i j = let anf8 = ( + ) a b in + let anf7 = ( + ) anf8 c in + let anf6 = ( + ) anf7 d in + let anf5 = ( + ) anf6 e in + let anf4 = ( + ) anf5 f in + let anf3 = ( + ) anf4 g in + let anf2 = ( + ) anf3 h in + let anf1 = ( + ) anf2 i in + ( + ) anf1 j + ;; + + let main = let rez = wrap test10 1 10 100 1000 10000 100000 1000000 10000000 100000000 1000000000 in + let () = print_int rez in + let temp2 = wrap test3 1 10 100 in + 0 + ;; + + $ ./anf_runner.exe < manytests/typed/005fix.ml + let rec fix f x = let anf0 = fix f in + f anf0 x + ;; + + let fac self n = let anf1 = ( <= ) n 1 in + if anf1 + then 1 + else let anf3 = ( - ) n 1 in + let anf2 = self anf3 in + ( * ) n anf2 + ;; + + let main = let anf4 = fix fac 6 in + let () = print_int anf4 in + 0 + ;; + + $ ./anf_runner.exe < manytests/typed/006partial.ml + let lam_ll0 foo = ( + ) foo 2 + ;; + + let lam_ll1 foo = ( * ) foo 10 + ;; + + let foo b = if b + then lam_ll0 + else lam_ll1 + ;; + + let foo_ac0 x = let anf2 = foo false x in + let anf1 = foo true anf2 in + let anf0 = foo false anf1 in + foo true anf0 + ;; + + let main = let anf3 = foo_ac0 11 in + let () = print_int anf3 in + 0 + ;; + + $ ./anf_runner.exe < manytests/typed/006partial2.ml + let foo a b c = let () = print_int a in + let () = print_int b in + let () = print_int c in + let anf0 = ( * ) b c in + ( + ) a anf0 + ;; + + let main = let foo_ac0 = foo 1 in + let foo_ac1 = foo_ac0 2 in + let foo_ac2 = foo_ac1 3 in + let () = print_int foo_ac2 in + 0 + ;; + $ ./anf_runner.exe < manytests/typed/006partial3.ml + let lam_ll1 c = print_int c + ;; + + let lam_ll0 b = let () = print_int b in + lam_ll1 + ;; + + let foo a = let () = print_int a in + lam_ll0 + ;; + + let main = let () = foo 4 8 9 in + 0 + ;; + $ ./anf_runner.exe < manytests/typed/007order.ml + let _start () () a () b _c () d __ = let anf0 = ( + ) a b in + let () = print_int anf0 in + let () = print_int __ in + let anf2 = ( * ) a b in + let anf1 = ( / ) anf2 _c in + ( + ) anf1 d + ;; + + let main = let anf4 = print_int 1 in + let anf5 = print_int 2 in + let anf6 = print_int 4 in + let anf8 = ( ~- ) 1 in + let anf7 = print_int anf8 in + let anf9 = ( ~- ) 555555 in + let anf3 = _start anf4 anf5 3 anf6 100 1000 anf7 10000 anf9 in + print_int anf3 + ;; + $ ./anf_runner.exe < manytests/typed/008ascription.ml + let addi f g x = let anf0 = g x in + f x anf0 + ;; + + let lam_ll0 x b = if b + then ( + ) x 1 + else ( * ) x 2 + ;; + + let lam_ll1 _start = let anf1 = ( / ) _start 2 in + ( = ) anf1 0 + ;; + + let main = let anf2 = addi lam_ll0 lam_ll1 4 in + let () = print_int anf2 in + 0 + ;; + + $ ./anf_runner.exe < manytests/typed/009let_poly.ml + let f_ll0 x = x + ;; + + let temp = let anf0 = f_ll0 1 in + let anf1 = f_ll0 true in + (anf0, anf1) + ;; + + $ ./anf_runner.exe < manytests/typed/011mapcps.ml + let rec lam_ll0 f h k tl_ac0 = let anf1 = f h in + let anf0 = (anf1::tl_ac0) in + k anf0 + and map f xs k = let anf2 = is_empty xs in + if anf2 + then k [] + else let anf3 = is_cons xs in + if anf3 + then let h = hd_list_get xs in + let tl = tl_list_get xs in + let anf4 = lam_ll0 f h k in + map f tl anf4 + else fail + ;; + + let rec iter f xs = let anf5 = is_empty xs in + if anf5 + then () + else let anf6 = is_cons xs in + if anf6 + then let h = hd_list_get xs in + let tl = tl_list_get xs in + let w = f h in + iter f tl + else fail + ;; + + let lam_ll1 x = ( + ) x 1 + ;; + + let lam_ll2 x = x + ;; + + let main = let anf10 = (3::[]) in + let anf9 = (2::anf10) in + let anf8 = (1::anf9) in + let anf7 = map lam_ll1 anf8 lam_ll2 in + iter print_int anf7 + ;; + $ ./anf_runner.exe < manytests/typed/012fibcps.ml + let rec lam_ll1 a k b = let anf0 = ( + ) a b in + k anf0 + and lam_ll0 k n a = let anf1 = ( - ) n 2 in + let anf2 = lam_ll1 a k in + fib anf1 anf2 + and fib n k = let anf3 = ( < ) n 2 in + if anf3 + then k n + else let anf4 = ( - ) n 1 in + let anf5 = lam_ll0 k n in + fib anf4 anf5 + ;; + + let lam_ll2 x = x + ;; + + let main = let anf6 = fib 6 lam_ll2 in + print_int anf6 + ;; + $ ./anf_runner.exe < manytests/typed/013foldfoldr.ml + let id x = x + ;; + + let rec fold_right f acc xs = let anf0 = is_empty xs in + if anf0 + then acc + else let anf1 = is_cons xs in + if anf1 + then let h = hd_list_get xs in + let tl = tl_list_get xs in + let anf2 = fold_right f acc tl in + f h anf2 + else fail + ;; + + let lam_ll0 f b g x = let anf3 = f x b in + g anf3 + ;; + + let foldl f a bs = let anf4 = lam_ll0 f in + fold_right anf4 id bs a + ;; + + let lam_ll1 x y = ( * ) x y + ;; + + let main = let anf8 = (3::[]) in + let anf7 = (2::anf8) in + let anf6 = (1::anf7) in + let anf5 = foldl lam_ll1 1 anf6 in + print_int anf5 + ;; + + $ ./anf_runner.exe < manytests/typed/015tuples.ml + let rec fix f x = let anf0 = fix f in + f anf0 x + ;; + + let map f p = let a = tuple_get p 0 in + let b = tuple_get p 1 in + let anf1 = f a in + let anf2 = f b in + (anf1, anf2) + ;; + + let lam_ll1 l_ac0 self li x = let anf3 = self l_ac0 in + li anf3 x + ;; + + let lam_ll0 self l_ac0 = let anf4 = lam_ll1 l_ac0 self in + map anf4 l_ac0 + ;; + + let fixpoly l = fix lam_ll0 l + ;; + + let feven p n = let e = tuple_get p 0 in + let o = tuple_get p 1 in + let anf5 = ( = ) n 0 in + if anf5 + then 1 + else let anf6 = ( - ) n 1 in + o anf6 + ;; + + let fodd p n = let e = tuple_get p 0 in + let o = tuple_get p 1 in + let anf7 = ( = ) n 0 in + if anf7 + then 0 + else let anf8 = ( - ) n 1 in + e anf8 + ;; + + let tie = let anf9 = (feven, fodd) in + fixpoly anf9 + ;; + + let rec meven n = let anf10 = ( = ) n 0 in + if anf10 + then 1 + else let anf11 = ( - ) n 1 in + modd anf11 + and modd n = let anf12 = ( = ) n 0 in + if anf12 + then 1 + else let anf13 = ( - ) n 1 in + meven anf13 + ;; + + let main = let anf14 = modd 1 in + let () = print_int anf14 in + let anf15 = meven 2 in + let () = print_int anf15 in + let even = tuple_get tie 0 in + let odd = tuple_get tie 1 in + let anf16 = odd 3 in + let () = print_int anf16 in + let anf17 = even 4 in + let () = print_int anf17 in + 0 + ;; + + $ ./anf_runner.exe < manytests/typed/016lists.ml + let rec length xs = let anf0 = is_empty xs in + if anf0 + then 0 + else let anf1 = is_cons xs in + if anf1 + then let h = hd_list_get xs in + let tl = tl_list_get xs in + let anf2 = length tl in + ( + ) 1 anf2 + else fail + ;; + + let helper_ll0 acc xs = let anf3 = is_empty xs in + if anf3 + then acc + else let anf4 = is_cons xs in + if anf4 + then let h = hd_list_get xs in + let tl = tl_list_get xs in + let anf5 = ( + ) acc 1 in + helper_ll0 anf5 tl + else fail + ;; + + let length_tail = helper_ll0 0 + ;; + + let rec map f xs = let anf6 = is_empty xs in + if anf6 + then [] + else let anf8 = is_cons xs in + let anf7 = if anf8 + then let anf9 = tl_list_get xs in + is_empty anf9 + else false in + if anf7 + then let a = hd_list_get xs in + let anf10 = f a in + (anf10::[]) + else let anf12 = is_cons xs in + let anf11 = if anf12 + then let anf14 = tl_list_get xs in + let anf13 = is_cons anf14 in + if anf13 + then let anf16 = tl_list_get xs in + let anf15 = tl_list_get anf16 in + is_empty anf15 + else false + else false in + if anf11 + then let a = hd_list_get xs in + let anf17 = tl_list_get xs in + let b = hd_list_get anf17 in + let anf18 = f a in + let anf20 = f b in + let anf19 = (anf20::[]) in + (anf18::anf19) + else let anf22 = is_cons xs in + let anf21 = if anf22 + then let anf24 = tl_list_get xs in + let anf23 = is_cons anf24 in + if anf23 + then let anf27 = tl_list_get xs in + let anf26 = tl_list_get anf27 in + let anf25 = is_cons anf26 in + if anf25 + then let anf30 = tl_list_get xs in + let anf29 = tl_list_get anf30 in + let anf28 = tl_list_get anf29 in + is_empty anf28 + else false + else false + else false in + if anf21 + then let a = hd_list_get xs in + let anf31 = tl_list_get xs in + let b = hd_list_get anf31 in + let anf33 = tl_list_get xs in + let anf32 = tl_list_get anf33 in + let c = hd_list_get anf32 in + let anf34 = f a in + let anf36 = f b in + let anf38 = f c in + let anf37 = (anf38::[]) in + let anf35 = (anf36::anf37) in + (anf34::anf35) + else let anf40 = is_cons xs in + let anf39 = if anf40 + then let anf42 = tl_list_get xs in + let anf41 = is_cons anf42 in + if anf41 + then let anf45 = tl_list_get xs in + let anf44 = tl_list_get anf45 in + let anf43 = is_cons anf44 in + if anf43 + then let anf48 = tl_list_get xs in + let anf47 = tl_list_get anf48 in + let anf46 = tl_list_get anf47 in + is_cons anf46 + else false + else false + else false in + if anf39 + then let a = hd_list_get xs in + let anf49 = tl_list_get xs in + let b = hd_list_get anf49 in + let anf51 = tl_list_get xs in + let anf50 = tl_list_get anf51 in + let c = hd_list_get anf50 in + let anf54 = tl_list_get xs in + let anf53 = tl_list_get anf54 in + let anf52 = tl_list_get anf53 in + let d = hd_list_get anf52 in + let anf57 = tl_list_get xs in + let anf56 = tl_list_get anf57 in + let anf55 = tl_list_get anf56 in + let tl = tl_list_get anf55 in + let anf58 = f a in + let anf60 = f b in + let anf62 = f c in + let anf64 = f d in + let anf65 = map f tl in + let anf63 = (anf64::anf65) in + let anf61 = (anf62::anf63) in + let anf59 = (anf60::anf61) in + (anf58::anf59) + else fail + ;; + + let rec append xs ys = let anf66 = is_empty xs in + if anf66 + then ys + else let anf67 = is_cons xs in + if anf67 + then let x = hd_list_get xs in + let xs_ac0 = tl_list_get xs in + let anf68 = append xs_ac0 ys in + (x::anf68) + else fail + ;; + + let helper_ll1 xs = let anf69 = is_empty xs in + if anf69 + then [] + else let anf70 = is_cons xs in + if anf70 + then let h = hd_list_get xs in + let tl = tl_list_get xs in + let anf71 = helper_ll1 tl in + append h anf71 + else fail + ;; + + let concat = helper_ll1 + ;; + + let rec iter f xs = let anf72 = is_empty xs in + if anf72 + then () + else let anf73 = is_cons xs in + if anf73 + then let h = hd_list_get xs in + let tl = tl_list_get xs in + let () = f h in + iter f tl + else fail + ;; + + let rec lam_ll2 h a = (h, a) + and cartesian xs ys = let anf74 = is_empty xs in + if anf74 + then [] + else let anf75 = is_cons xs in + if anf75 + then let h = hd_list_get xs in + let tl = tl_list_get xs in + let anf77 = lam_ll2 h in + let anf76 = map anf77 ys in + let anf78 = cartesian tl ys in + append anf76 anf78 + else fail + ;; + + let main = let anf81 = (3::[]) in + let anf80 = (2::anf81) in + let anf79 = (1::anf80) in + let () = iter print_int anf79 in + let anf85 = (2::[]) in + let anf84 = (1::anf85) in + let anf89 = (4::[]) in + let anf88 = (3::anf89) in + let anf87 = (2::anf88) in + let anf86 = (1::anf87) in + let anf83 = cartesian anf84 anf86 in + let anf82 = length anf83 in + let () = print_int anf82 in + 0 + ;; \ No newline at end of file diff --git a/FML/tests/anf_runner.ml b/FML/tests/anf_runner.ml new file mode 100644 index 000000000..e2fa101db --- /dev/null +++ b/FML/tests/anf_runner.ml @@ -0,0 +1,33 @@ +(** Copyright 2024-2025, Dmitry Pilyuk, Aleksandr Rozhkov *) + +(** SPDX-License-Identifier: LGPL-2.1 *) + +open Fml_lib.Parser +open Fml_lib.Inferencer +open Fml_lib.A_conv +open Fml_lib.Match_elimination +open Fml_lib.C_conv +open Fml_lib.Anf +open Fml_lib.Lambda_lift +open Fml_lib.Anf_ast + +let () = + let input = Stdio.In_channel.input_all Stdlib.stdin in + let parse_and_infer input = + match parse input with + | Ok parsed -> + (match run_program_inferencer parsed with + | Ok _ -> Ok parsed + | Error _ -> Error (Format.asprintf "Infer error:")) + | Error e -> Error (Format.sprintf "Parsing error: %s" e) + in + match parse_and_infer input with + | Ok ast -> + let ast = ac_program ast in + let ast_me = match_elimination ast in + let ast_cc = cc_program ast_me in + let ast_ll = lambda_lift ast_cc in + let ast_anf = anf ast_ll in + Format.printf "%a\n" pp_anf_program ast_anf + | Error message -> Format.printf "%s" message +;; diff --git a/FML/tests/c_conv_manytest.t b/FML/tests/c_conv_manytest.t index 18173f187..424254a8d 100644 --- a/FML/tests/c_conv_manytest.t +++ b/FML/tests/c_conv_manytest.t @@ -354,17 +354,4 @@ let main = let () = ((iter print_int) (1::(2::(3::[])))) in let () = (print_int (length ((cartesian (1::(2::[]))) (1::(2::(3::(4::[]))))))) in 0 - - $ ./c_conv_runner.exe < manytests/do_not_type/001.ml - Infer error: - $ ./c_conv_runner.exe < manytests/do_not_type/002if.ml - Infer error: - $ ./c_conv_runner.exe < manytests/do_not_type/003occurs.ml - Infer error: - - $ ./c_conv_runner.exe < manytests/do_not_type/004let_poly.ml - Infer error: - - $ ./c_conv_runner.exe < manytests/do_not_type/015tuples.ml - Infer error: - + \ No newline at end of file diff --git a/FML/tests/dune b/FML/tests/dune index 5574b4bdc..1ae157fa2 100644 --- a/FML/tests/dune +++ b/FML/tests/dune @@ -44,6 +44,12 @@ (modules lambda_lift_runner) (libraries fml_lib stdio)) +(executable + (name anf_runner) + (public_name anf_runner) + (modules anf_runner) + (libraries fml_lib stdio)) + (cram (applies_to parser_manytests) (deps @@ -303,3 +309,30 @@ manytests/typed/013foldfoldr.ml manytests/typed/015tuples.ml manytests/typed/016lists.ml)) + + +(cram + (applies_to anf_manytest) + (deps + ./anf_runner.exe + manytests/do_not_type/001.ml + manytests/do_not_type/002if.ml + manytests/do_not_type/003occurs.ml + manytests/do_not_type/004let_poly.ml + manytests/do_not_type/015tuples.ml + manytests/typed/001fac.ml + manytests/typed/002fac.ml + manytests/typed/003fib.ml + manytests/typed/004manyargs.ml + manytests/typed/005fix.ml + manytests/typed/006partial.ml + manytests/typed/006partial2.ml + manytests/typed/006partial3.ml + manytests/typed/007order.ml + manytests/typed/008ascription.ml + manytests/typed/009let_poly.ml + manytests/typed/011mapcps.ml + manytests/typed/012fibcps.ml + manytests/typed/013foldfoldr.ml + manytests/typed/015tuples.ml + manytests/typed/016lists.ml)) diff --git a/FML/tests/lambda_lift_manytest.t b/FML/tests/lambda_lift_manytest.t index f53c1e30d..49d7fb659 100644 --- a/FML/tests/lambda_lift_manytest.t +++ b/FML/tests/lambda_lift_manytest.t @@ -1,3 +1,9 @@ + $ ./lambda_lift_runner.exe << EOF + > let f x = let g y = x + y in g 5;; + > EOF + let g_ll0 = (fun x y -> ((( + ) x) y)) + let f = (fun x -> ((g_ll0 x) 5)) + $ ./lambda_lift_runner.exe << EOF > let length xs = match xs with > | a::b::[] -> 2 @@ -93,13 +99,14 @@ > | 12 -> 12 > | _ -> 325 > EOF - let f = (fun x -> if (((=) x) 1) + let lam_ll0 = (fun (=) x -> if (((=) x) 1) then 12 else if (((=) x) 12) then 12 else if true then 325 else fail) + let f = (lam_ll0 (=)) $ ./lambda_lift_runner.exe < manytests/typed/001fac.ml let rec fac = (fun n -> if ((( <= ) n) 1) @@ -110,10 +117,10 @@ 0 $ ./lambda_lift_runner.exe < manytests/typed/002fac.ml - let rec lam_ll0 = (fun p -> (k ((( * ) p) n))) + let rec lam_ll0 = (fun k n p -> (k ((( * ) p) n))) and fac_cps = (fun n k -> if ((( = ) n) 1) then (k 1) - else ((fac_cps ((( - ) n) 1)) lam_ll0)) + else ((fac_cps ((( - ) n) 1)) ((lam_ll0 k) n))) let lam_ll1 = (fun print_int_ac0 -> print_int_ac0) let main = let () = (print_int ((fac_cps 4) lam_ll1)) in @@ -214,13 +221,13 @@ let temp = ((f_ll0 1), (f_ll0 true)) $ ./lambda_lift_runner.exe < manytests/typed/011mapcps.ml - let rec lam_ll0 = (fun tl_ac0 -> (k ((f h)::tl_ac0))) + let rec lam_ll0 = (fun f h k tl_ac0 -> (k ((f h)::tl_ac0))) and map = (fun f xs k -> if (is_empty xs) then (k []) else if (is_cons xs) then let h = (hd_list_get xs) in let tl = (tl_list_get xs) in - (((map f) tl) lam_ll0) + (((map f) tl) (((lam_ll0 f) h) k)) else fail) let rec iter = (fun f xs -> if (is_empty xs) @@ -236,11 +243,11 @@ let lam_ll2 = (fun x -> x) let main = ((iter print_int) (((map lam_ll1) (1::(2::(3::[])))) lam_ll2)) $ ./lambda_lift_runner.exe < manytests/typed/012fibcps.ml - let rec lam_ll1 = (fun b -> (k ((( + ) a) b))) - and lam_ll0 = (fun a -> ((fib ((( - ) n) 2)) lam_ll1)) + let rec lam_ll1 = (fun a k b -> (k ((( + ) a) b))) + and lam_ll0 = (fun k n a -> ((fib ((( - ) n) 2)) ((lam_ll1 a) k))) and fib = (fun n k -> if ((( < ) n) 2) then (k n) - else ((fib ((( - ) n) 1)) lam_ll0)) + else ((fib ((( - ) n) 1)) ((lam_ll0 k) n))) let lam_ll2 = (fun x -> x) let main = (print_int ((fib 6) lam_ll2)) @@ -255,8 +262,8 @@ ((f h) (((fold_right f) acc) tl)) else fail) - let lam_ll0 = (fun b g x -> (g ((f x) b))) - let foldl = (fun f a bs -> ((((fold_right lam_ll0) id) bs) a)) + let lam_ll0 = (fun f b g x -> (g ((f x) b))) + let foldl = (fun f a bs -> ((((fold_right (lam_ll0 f)) id) bs) a)) let lam_ll1 = (fun x y -> ((( * ) x) y)) let main = (print_int (((foldl lam_ll1) 1) (1::(2::(3::[]))))) @@ -268,8 +275,8 @@ let b = ((tuple_get p) 1) in ((f a), (f b))) - let lam_ll1 = (fun li x -> ((li (self l_ac0)) x)) - let lam_ll0 = (fun self l_ac0 -> ((map lam_ll1) l_ac0)) + let lam_ll1 = (fun l_ac0 self li x -> ((li (self l_ac0)) x)) + let lam_ll0 = (fun self l_ac0 -> ((map ((lam_ll1 l_ac0) self)) l_ac0)) let fixpoly = (fun l -> ((fix lam_ll0) l)) let feven = (fun p n -> let e = ((tuple_get p) 0) in @@ -386,29 +393,16 @@ ((iter f) tl) else fail) - let rec lam_ll2 = (fun a -> (h, a)) + let rec lam_ll2 = (fun h a -> (h, a)) and cartesian = (fun xs ys -> if (is_empty xs) then [] else if (is_cons xs) then let h = (hd_list_get xs) in let tl = (tl_list_get xs) in - ((append ((map lam_ll2) ys)) ((cartesian tl) ys)) + ((append ((map (lam_ll2 h)) ys)) ((cartesian tl) ys)) else fail) let main = let () = ((iter print_int) (1::(2::(3::[])))) in let () = (print_int (length ((cartesian (1::(2::[]))) (1::(2::(3::(4::[]))))))) in 0 - - $ ./lambda_lift_runner.exe < manytests/do_not_type/001.ml - Infer error: - $ ./lambda_lift_runner.exe < manytests/do_not_type/002if.ml - Infer error: - $ ./lambda_lift_runner.exe < manytests/do_not_type/003occurs.ml - Infer error: - - $ ./lambda_lift_runner.exe < manytests/do_not_type/004let_poly.ml - Infer error: - - $ ./lambda_lift_runner.exe < manytests/do_not_type/015tuples.ml - Infer error: - + \ No newline at end of file diff --git a/FML/tests/lambda_lift_runner.ml b/FML/tests/lambda_lift_runner.ml index b72a14f65..faadc6d24 100644 --- a/FML/tests/lambda_lift_runner.ml +++ b/FML/tests/lambda_lift_runner.ml @@ -8,6 +8,7 @@ open Fml_lib.A_conv open Fml_lib.Match_elimination open Fml_lib.Lambda_lift open Fml_lib.Me_ast +open Fml_lib.C_conv let () = let input = Stdio.In_channel.input_all Stdlib.stdin in @@ -23,7 +24,8 @@ let () = | Ok ast -> let ast = ac_program ast in let ast_me = match_elimination ast in - let ast_ll = lambda_lift ast_me in + let ast_cc = cc_program ast_me in + let ast_ll = lambda_lift ast_cc in Format.printf "%a\n" pp_me_program ast_ll | Error message -> Format.printf "%s" message ;; From 35652e181a6c57858b62080164b76a54ace94a2f Mon Sep 17 00:00:00 2001 From: RozhkovAleksandr Date: Tue, 15 Apr 2025 23:19:32 +0300 Subject: [PATCH 73/92] fix based value --- FML/lib/anf/anf.ml | 19 ++++++++++++------- FML/lib/anf/anf_ast.ml | 2 +- FML/tests/anf_manytest.t | 2 +- FML/tests/c_conv_manytest.t | 2 +- 4 files changed, 15 insertions(+), 10 deletions(-) diff --git a/FML/lib/anf/anf.ml b/FML/lib/anf/anf.ml index 09fdbe737..0b68b7a67 100644 --- a/FML/lib/anf/anf.ml +++ b/FML/lib/anf/anf.ml @@ -90,20 +90,25 @@ let anf_decl = ~init:(return @@ ACExpr expr) ~f:(fun (name, cexp) acc -> return @@ ALetIn(name, cexp, acc)) in + let is_based_value = function + | Me_EConst _ | Me_EIdentifier _ | Me_EUnit | Me_ENill -> true + | _ -> false in function | Me_Nonrec decls -> - RList.fold_left decls ~init:(return []) ~f:(fun acc (name, e) -> - let* new_expr = + RList.fold_left decls ~init:(return []) ~f:(fun acc (name, e) -> match e with | Me_EFun (args, body) -> let* body' = handle_for_let body in - return (ALet (name, args, body')) + return (acc @ [ADNoRec [ALet (name, args, body')]]) + + | _ when is_based_value e -> + let* body' = handle_for_let e in + return (acc @ [Based_value (name, body')]) + | _ -> let* expr' = handle_for_let e in - return (ALet (name, [], expr')) - in - return (acc @ [ADNoRec [new_expr]]) - ) + return (acc @ [ADNoRec [ALet (name, [], expr')]]) + ) | Me_Rec decls -> let* bindings = diff --git a/FML/lib/anf/anf_ast.ml b/FML/lib/anf/anf_ast.ml index 7691d9f38..829a6299e 100644 --- a/FML/lib/anf/anf_ast.ml +++ b/FML/lib/anf/anf_ast.ml @@ -71,7 +71,7 @@ let fun_to_str = function ;; let declaration_to_str = function - | Based_value (name, e) -> Format.sprintf "let %s =\n %s" name (exp_to_str e) + | Based_value (name, e) -> Format.sprintf "let %s = %s\n;;" name (exp_to_str e) | ADNoRec func_list -> let funs = List.map fun_to_str func_list in "let " ^ String.concat "\nand " funs ^ "\n;;" diff --git a/FML/tests/anf_manytest.t b/FML/tests/anf_manytest.t index c925a2400..e557387e6 100644 --- a/FML/tests/anf_manytest.t +++ b/FML/tests/anf_manytest.t @@ -689,4 +689,4 @@ let anf82 = length anf83 in let () = print_int anf82 in 0 - ;; \ No newline at end of file + ;; diff --git a/FML/tests/c_conv_manytest.t b/FML/tests/c_conv_manytest.t index 424254a8d..616c6972a 100644 --- a/FML/tests/c_conv_manytest.t +++ b/FML/tests/c_conv_manytest.t @@ -354,4 +354,4 @@ let main = let () = ((iter print_int) (1::(2::(3::[])))) in let () = (print_int (length ((cartesian (1::(2::[]))) (1::(2::(3::(4::[]))))))) in 0 - \ No newline at end of file + From fcac1b17f74d6e0cbea2c05d2b6df3c6f4ba12af Mon Sep 17 00:00:00 2001 From: Dmitry Pilyuk Date: Tue, 15 Apr 2025 11:33:51 +0300 Subject: [PATCH 74/92] Improve LL --- FML/lib/anf/lambda_lift.ml | 47 ++++++++++--------- FML/lib/anf/match_elimination.ml | 5 +-- FML/lib/inferencer/inferencer.ml | 2 +- FML/tests/c_conv_manytest.t | 4 +- FML/tests/lambda_lift_manytest.t | 62 ++++++++++++++++++-------- FML/tests/match_elimination_manytest.t | 4 +- 6 files changed, 77 insertions(+), 47 deletions(-) diff --git a/FML/lib/anf/lambda_lift.ml b/FML/lib/anf/lambda_lift.ml index d1ac530cd..78671fb25 100644 --- a/FML/lib/anf/lambda_lift.ml +++ b/FML/lib/anf/lambda_lift.ml @@ -9,13 +9,12 @@ open StateMonad let get_new_id n name = Base.String.concat [ name; "_ll"; Int.to_string n ] -let rec ll_expr bindings expr = - match expr with - | Me_EUnit | Me_ENill | Me_EConst _ -> return ([], expr) +let rec ll_expr bindings = function + | (Me_EUnit | Me_ENill | Me_EConst _) as expr -> return ([], expr) | Me_EIdentifier id -> (match StrMap.find bindings id with | Some name -> return ([], Me_EIdentifier name) - | None -> return ([], expr)) + | None -> return ([], Me_EIdentifier id)) | Me_EIf (e1, e2, e3) -> let* defs1, e1' = ll_expr bindings e1 in let* defs2, e2' = ll_expr bindings e2 in @@ -46,7 +45,7 @@ let rec ll_expr bindings expr = let* defs1, e1' = ll_expr bindings e1 in let* id = fresh in let new_name = get_new_id id name in - let def = new_name, Me_EFun (args, e1') in + let def = Me_Nonrec [ new_name, Me_EFun (args, e1') ] in let* defs2, e2' = ll_expr (StrMap.update bindings name ~f:(fun _ -> new_name)) e2 in @@ -62,7 +61,7 @@ let rec ll_expr bindings expr = let new_name = get_new_id id name in let bindings' = StrMap.update bindings name ~f:(fun _ -> new_name) in let* defs1, e1' = ll_expr bindings' e1 in - let def = new_name, Me_EFun (args, e1') in + let def = Me_Rec [ new_name, Me_EFun (args, e1') ] in let* defs2, e2' = ll_expr bindings' e2 in return (defs1 @ [ def ] @ defs2, e2') | _ -> failwith "Not reachable") @@ -71,7 +70,7 @@ let rec ll_expr bindings expr = let name = get_new_id id "lam" in let* defs, body' = ll_expr bindings body in let new_fun = Me_EFun (args, body') in - let def = name, new_fun in + let def = Me_Nonrec [ name, new_fun ] in return (defs @ [ def ], Me_EIdentifier name) ;; @@ -79,33 +78,39 @@ let ll_binding (name, expr) = match expr with | Me_EFun (args, expr) -> let* defs, expr' = ll_expr StrMap.empty expr in - return (defs @ [ name, Me_EFun (args, expr') ]) + return (defs, (name, Me_EFun (args, expr'))) | expr -> let* defs, expr' = ll_expr StrMap.empty expr in - return (defs @ [ name, expr' ]) + return (defs, (name, expr')) ;; let ll_decl decl = match decl with | Me_Nonrec bindings -> - let* all_defs = - RList.fold_left bindings ~init:(return []) ~f:(fun acc b -> - let* lifted = ll_binding b in - return (acc @ lifted)) + let* all_defs, curr_defs = + RList.fold_left + bindings + ~init:(return ([], [])) + ~f:(fun (acc_defs, acc_curr) b -> + let* defs, binding = ll_binding b in + return (acc_defs @ defs, acc_curr @ [ binding ])) in - return (Me_Nonrec all_defs) + return (all_defs, Me_Nonrec curr_defs) | Me_Rec bindings -> - let* all_defs = - RList.fold_left bindings ~init:(return []) ~f:(fun acc b -> - let* lifted = ll_binding b in - return (acc @ lifted)) + let* all_defs, curr_defs = + RList.fold_left + bindings + ~init:(return ([], [])) + ~f:(fun (acc_defs, acc_curr) b -> + let* defs, binding = ll_binding b in + return (acc_defs @ defs, acc_curr @ [ binding ])) in - return (Me_Rec all_defs) + return (all_defs, Me_Rec curr_defs) ;; let lambda_lift prog = StateMonad.run (RList.fold_left prog ~init:(return []) ~f:(fun acc decl -> - let* d = ll_decl decl in - return (acc @ [ d ]))) + let* decls, d = ll_decl decl in + return (acc @ decls @ [ d ]))) ;; diff --git a/FML/lib/anf/match_elimination.ml b/FML/lib/anf/match_elimination.ml index 56b9da764..fd09df509 100644 --- a/FML/lib/anf/match_elimination.ml +++ b/FML/lib/anf/match_elimination.ml @@ -42,7 +42,7 @@ let rec pattern_bindings expr pat = | PTuple pats -> List.mapi pats ~f:(fun i p -> let ith_expr = - Me_EApp (Me_EIdentifier "tuple_get", Me_ETuple [ expr; Me_EConst (Me_Cint i) ]) + Me_EApp (Me_EApp (Me_EIdentifier "tuple_get", expr), Me_EConst (Me_Cint i)) in pattern_bindings ith_expr p) |> List.concat @@ -159,8 +159,7 @@ and desugar_match e branches = ~init:(return []) ~f:(fun acc (i, p) -> let ith_expr = - Me_EApp - (Me_EIdentifier "tuple_get", Me_ETuple [ expr; Me_EConst (Me_Cint i) ]) + Me_EApp (Me_EApp (Me_EIdentifier "tuple_get", expr), Me_EConst (Me_Cint i)) in let* cond = pattern_to_condition ith_expr p in return (acc @ [ cond ])) diff --git a/FML/lib/inferencer/inferencer.ml b/FML/lib/inferencer/inferencer.ml index f7eaa96f4..ab3696021 100644 --- a/FML/lib/inferencer/inferencer.ml +++ b/FML/lib/inferencer/inferencer.ml @@ -659,7 +659,7 @@ let start_env = ; "list_head", TFunction (TList (TVar 1), TVar 1) ; "list_tail", TFunction (TList (TVar 1), TList (TVar 1)) ; "tuple_element", TFunction (TVar 1, TFunction (TInt, TVar 2)) - ; "fail_match", TVar 1 + ; "fail", TVar 1 ] in let env = TypeEnv.empty in diff --git a/FML/tests/c_conv_manytest.t b/FML/tests/c_conv_manytest.t index 616c6972a..2fc83c59d 100644 --- a/FML/tests/c_conv_manytest.t +++ b/FML/tests/c_conv_manytest.t @@ -46,8 +46,8 @@ > let (a, b) = (5,6) > EOF let tmp_me0 = (5, 6) - let a = (tuple_get (tmp_me0, 0)) - let b = (tuple_get (tmp_me0, 1)) + let a = ((tuple_get tmp_me0) 0) + let b = ((tuple_get tmp_me0) 1) $ ./c_conv_runner.exe << EOF > let fac n = diff --git a/FML/tests/lambda_lift_manytest.t b/FML/tests/lambda_lift_manytest.t index 49d7fb659..e66552931 100644 --- a/FML/tests/lambda_lift_manytest.t +++ b/FML/tests/lambda_lift_manytest.t @@ -31,6 +31,7 @@ > let f = let y x = x + 1 in y 3;; > EOF let y_ll0 = (fun x -> ((( + ) x) 1)) + let f = (y_ll0 3) $ ./lambda_lift_runner.exe << EOF @@ -75,8 +76,8 @@ > let (a, b) = (5,6) > EOF let tmp_me0 = (5, 6) - let a = (tuple_get (tmp_me0, 0)) - let b = (tuple_get (tmp_me0, 1)) + let a = ((tuple_get tmp_me0) 0) + let b = ((tuple_get tmp_me0) 1) $ ./lambda_lift_runner.exe << EOF > let fac n = @@ -87,10 +88,13 @@ > fack n (fun x -> x) > EOF let lam_ll1 = (fun k_ac1 n_ac2 m -> (k_ac1 ((( * ) m) n_ac2))) - let fack_ll0 = (fun n_ac0 k -> if ((( <= ) n_ac0) 1) + + let rec fack_ll0 = (fun n_ac0 k -> if ((( <= ) n_ac0) 1) then (k 1) else ((fack_ll0 ((( - ) n_ac0) 1)) ((lam_ll1 k) n_ac0))) + let lam_ll2 = (fun x -> x) + let fac = (fun n -> ((fack_ll0 n) lam_ll2)) $ ./lambda_lift_runner.exe << EOF @@ -117,12 +121,14 @@ 0 $ ./lambda_lift_runner.exe < manytests/typed/002fac.ml - let rec lam_ll0 = (fun k n p -> (k ((( * ) p) n))) - and fac_cps = (fun n k -> if ((( = ) n) 1) + let lam_ll0 = (fun p -> (k ((( * ) p) n))) + + let rec fac_cps = (fun n k -> if ((( = ) n) 1) then (k 1) else ((fac_cps ((( - ) n) 1)) ((lam_ll0 k) n))) let lam_ll1 = (fun print_int_ac0 -> print_int_ac0) + let main = let () = (print_int ((fac_cps 4) lam_ll1)) in 0 @@ -170,7 +176,9 @@ $ ./lambda_lift_runner.exe < manytests/typed/006partial.ml let lam_ll0 = (fun foo -> ((( + ) foo) 2)) + let lam_ll1 = (fun foo -> ((( * ) foo) 10)) + let foo = (fun b -> if b then lam_ll0 else lam_ll1) @@ -193,8 +201,10 @@ 0 $ ./lambda_lift_runner.exe < manytests/typed/006partial3.ml let lam_ll1 = (fun c -> (print_int c)) + let lam_ll0 = (fun b -> let () = (print_int b) in lam_ll1) + let foo = (fun a -> let () = (print_int a) in lam_ll0) @@ -212,17 +222,21 @@ let lam_ll0 = (fun x b -> if b then ((( + ) x) 1) else ((( * ) x) 2)) + let lam_ll1 = (fun _start -> ((( = ) ((( / ) _start) 2)) 0)) + let main = let () = (print_int (((addi lam_ll0) lam_ll1) 4)) in 0 $ ./lambda_lift_runner.exe < manytests/typed/009let_poly.ml let f_ll0 = (fun x -> x) + let temp = ((f_ll0 1), (f_ll0 true)) $ ./lambda_lift_runner.exe < manytests/typed/011mapcps.ml - let rec lam_ll0 = (fun f h k tl_ac0 -> (k ((f h)::tl_ac0))) - and map = (fun f xs k -> if (is_empty xs) + let lam_ll0 = (fun tl_ac0 -> (k ((f h)::tl_ac0))) + + let rec map = (fun f xs k -> if (is_empty xs) then (k []) else if (is_cons xs) then let h = (hd_list_get xs) in @@ -240,16 +254,21 @@ else fail) let lam_ll1 = (fun x -> ((( + ) x) 1)) + let lam_ll2 = (fun x -> x) + let main = ((iter print_int) (((map lam_ll1) (1::(2::(3::[])))) lam_ll2)) $ ./lambda_lift_runner.exe < manytests/typed/012fibcps.ml - let rec lam_ll1 = (fun a k b -> (k ((( + ) a) b))) - and lam_ll0 = (fun k n a -> ((fib ((( - ) n) 2)) ((lam_ll1 a) k))) - and fib = (fun n k -> if ((( < ) n) 2) + let lam_ll1 = (fun b -> (k ((( + ) a) b))) + + let lam_ll0 = (fun a -> ((fib ((( - ) n) 2)) lam_ll1)) + + let rec fib = (fun n k -> if ((( < ) n) 2) then (k n) else ((fib ((( - ) n) 1)) ((lam_ll0 k) n))) let lam_ll2 = (fun x -> x) + let main = (print_int ((fib 6) lam_ll2)) $ ./lambda_lift_runner.exe < manytests/typed/013foldfoldr.ml let id = (fun x -> x) @@ -262,10 +281,12 @@ ((f h) (((fold_right f) acc) tl)) else fail) - let lam_ll0 = (fun f b g x -> (g ((f x) b))) - let foldl = (fun f a bs -> ((((fold_right (lam_ll0 f)) id) bs) a)) + let lam_ll0 = (fun b g x -> (g ((f x) b))) + + let foldl = (fun f a bs -> ((((fold_right lam_ll0) id) bs) a)) let lam_ll1 = (fun x y -> ((( * ) x) y)) + let main = (print_int (((foldl lam_ll1) 1) (1::(2::(3::[]))))) $ ./lambda_lift_runner.exe < manytests/typed/015tuples.ml @@ -275,8 +296,10 @@ let b = ((tuple_get p) 1) in ((f a), (f b))) - let lam_ll1 = (fun l_ac0 self li x -> ((li (self l_ac0)) x)) - let lam_ll0 = (fun self l_ac0 -> ((map ((lam_ll1 l_ac0) self)) l_ac0)) + let lam_ll1 = (fun li x -> ((li (self l_ac0)) x)) + + let lam_ll0 = (fun self l_ac0 -> ((map lam_ll1) l_ac0)) + let fixpoly = (fun l -> ((fix lam_ll0) l)) let feven = (fun p n -> let e = ((tuple_get p) 0) in @@ -317,13 +340,14 @@ ((( + ) 1) (length tl)) else fail) - let helper_ll0 = (fun acc xs -> if (is_empty xs) + let rec helper_ll0 = (fun acc xs -> if (is_empty xs) then acc else if (is_cons xs) then let h = (hd_list_get xs) in let tl = (tl_list_get xs) in ((helper_ll0 ((( + ) acc) 1)) tl) else fail) + let length_tail = (helper_ll0 0) let rec map = (fun f xs -> if (is_empty xs) @@ -375,13 +399,14 @@ (x::((append xs_ac0) ys)) else fail) - let helper_ll1 = (fun xs -> if (is_empty xs) + let rec helper_ll1 = (fun xs -> if (is_empty xs) then [] else if (is_cons xs) then let h = (hd_list_get xs) in let tl = (tl_list_get xs) in ((append h) (helper_ll1 tl)) else fail) + let concat = helper_ll1 let rec iter = (fun f xs -> if (is_empty xs) @@ -393,8 +418,9 @@ ((iter f) tl) else fail) - let rec lam_ll2 = (fun h a -> (h, a)) - and cartesian = (fun xs ys -> if (is_empty xs) + let lam_ll2 = (fun a -> (h, a)) + + let rec cartesian = (fun xs ys -> if (is_empty xs) then [] else if (is_cons xs) then let h = (hd_list_get xs) in diff --git a/FML/tests/match_elimination_manytest.t b/FML/tests/match_elimination_manytest.t index 801a1e5e9..79b10b9b6 100644 --- a/FML/tests/match_elimination_manytest.t +++ b/FML/tests/match_elimination_manytest.t @@ -55,8 +55,8 @@ > let (a, b) = (5,6) > EOF let tmp_me0 = (5, 6) - let a = (tuple_get (tmp_me0, 0)) - let b = (tuple_get (tmp_me0, 1)) + let a = ((tuple_get tmp_me0) 0) + let b = ((tuple_get tmp_me0) 1) $ ./match_elimination_runner.exe << EOF > let fac n = From a85f2ec496ec7ab7e8228b83a94bdda3fa9d202f Mon Sep 17 00:00:00 2001 From: Dmitry Pilyuk Date: Wed, 16 Apr 2025 00:17:56 +0300 Subject: [PATCH 75/92] Update tests --- FML/tests/anf_manytest.t | 40 +++++++++++++++++++------------- FML/tests/lambda_lift_manytest.t | 22 ++++++++++-------- 2 files changed, 36 insertions(+), 26 deletions(-) diff --git a/FML/tests/anf_manytest.t b/FML/tests/anf_manytest.t index e557387e6..84429fd67 100644 --- a/FML/tests/anf_manytest.t +++ b/FML/tests/anf_manytest.t @@ -68,12 +68,10 @@ let tmp_me0 = (5, 6) ;; - let a = let anf0 = (tmp_me0, 0) in - tuple_get anf0 + let a = tuple_get tmp_me0 0 ;; - let b = let anf1 = (tmp_me0, 1) in - tuple_get anf1 + let b = tuple_get tmp_me0 1 ;; $ ./anf_runner.exe << EOF @@ -88,7 +86,7 @@ k_ac1 anf0 ;; - let fack_ll0 n_ac0 k = let anf1 = ( <= ) n_ac0 1 in + let rec fack_ll0 n_ac0 k = let anf1 = ( <= ) n_ac0 1 in if anf1 then k 1 else let anf2 = ( - ) n_ac0 1 in @@ -137,9 +135,11 @@ ;; $ ./anf_runner.exe < manytests/typed/002fac.ml - let rec lam_ll0 k n p = let anf0 = ( * ) p n in + let lam_ll0 k n p = let anf0 = ( * ) p n in k anf0 - and fac_cps n k = let anf1 = ( = ) n 1 in + ;; + + let rec fac_cps n k = let anf1 = ( = ) n 1 in if anf1 then k 1 else let anf2 = ( - ) n 1 in @@ -328,10 +328,12 @@ ;; $ ./anf_runner.exe < manytests/typed/011mapcps.ml - let rec lam_ll0 f h k tl_ac0 = let anf1 = f h in + let lam_ll0 f h k tl_ac0 = let anf1 = f h in let anf0 = (anf1::tl_ac0) in k anf0 - and map f xs k = let anf2 = is_empty xs in + ;; + + let rec map f xs k = let anf2 = is_empty xs in if anf2 then k [] else let anf3 = is_cons xs in @@ -368,12 +370,16 @@ iter print_int anf7 ;; $ ./anf_runner.exe < manytests/typed/012fibcps.ml - let rec lam_ll1 a k b = let anf0 = ( + ) a b in + let lam_ll1 a k b = let anf0 = ( + ) a b in k anf0 - and lam_ll0 k n a = let anf1 = ( - ) n 2 in + ;; + + let lam_ll0 k n a = let anf1 = ( - ) n 2 in let anf2 = lam_ll1 a k in fib anf1 anf2 - and fib n k = let anf3 = ( < ) n 2 in + ;; + + let rec fib n k = let anf3 = ( < ) n 2 in if anf3 then k n else let anf4 = ( - ) n 1 in @@ -504,7 +510,7 @@ else fail ;; - let helper_ll0 acc xs = let anf3 = is_empty xs in + let rec helper_ll0 acc xs = let anf3 = is_empty xs in if anf3 then acc else let anf4 = is_cons xs in @@ -633,7 +639,7 @@ else fail ;; - let helper_ll1 xs = let anf69 = is_empty xs in + let rec helper_ll1 xs = let anf69 = is_empty xs in if anf69 then [] else let anf70 = is_cons xs in @@ -660,8 +666,10 @@ else fail ;; - let rec lam_ll2 h a = (h, a) - and cartesian xs ys = let anf74 = is_empty xs in + let lam_ll2 h a = (h, a) + ;; + + let rec cartesian xs ys = let anf74 = is_empty xs in if anf74 then [] else let anf75 = is_cons xs in diff --git a/FML/tests/lambda_lift_manytest.t b/FML/tests/lambda_lift_manytest.t index e66552931..e17d9f93d 100644 --- a/FML/tests/lambda_lift_manytest.t +++ b/FML/tests/lambda_lift_manytest.t @@ -2,6 +2,7 @@ > let f x = let g y = x + y in g 5;; > EOF let g_ll0 = (fun x y -> ((( + ) x) y)) + let f = (fun x -> ((g_ll0 x) 5)) $ ./lambda_lift_runner.exe << EOF @@ -110,6 +111,7 @@ else if true then 325 else fail) + let f = (lam_ll0 (=)) $ ./lambda_lift_runner.exe < manytests/typed/001fac.ml @@ -121,7 +123,7 @@ 0 $ ./lambda_lift_runner.exe < manytests/typed/002fac.ml - let lam_ll0 = (fun p -> (k ((( * ) p) n))) + let lam_ll0 = (fun k n p -> (k ((( * ) p) n))) let rec fac_cps = (fun n k -> if ((( = ) n) 1) then (k 1) @@ -234,7 +236,7 @@ let temp = ((f_ll0 1), (f_ll0 true)) $ ./lambda_lift_runner.exe < manytests/typed/011mapcps.ml - let lam_ll0 = (fun tl_ac0 -> (k ((f h)::tl_ac0))) + let lam_ll0 = (fun f h k tl_ac0 -> (k ((f h)::tl_ac0))) let rec map = (fun f xs k -> if (is_empty xs) then (k []) @@ -259,9 +261,9 @@ let main = ((iter print_int) (((map lam_ll1) (1::(2::(3::[])))) lam_ll2)) $ ./lambda_lift_runner.exe < manytests/typed/012fibcps.ml - let lam_ll1 = (fun b -> (k ((( + ) a) b))) + let lam_ll1 = (fun a k b -> (k ((( + ) a) b))) - let lam_ll0 = (fun a -> ((fib ((( - ) n) 2)) lam_ll1)) + let lam_ll0 = (fun k n a -> ((fib ((( - ) n) 2)) ((lam_ll1 a) k))) let rec fib = (fun n k -> if ((( < ) n) 2) then (k n) @@ -281,9 +283,9 @@ ((f h) (((fold_right f) acc) tl)) else fail) - let lam_ll0 = (fun b g x -> (g ((f x) b))) + let lam_ll0 = (fun f b g x -> (g ((f x) b))) - let foldl = (fun f a bs -> ((((fold_right lam_ll0) id) bs) a)) + let foldl = (fun f a bs -> ((((fold_right (lam_ll0 f)) id) bs) a)) let lam_ll1 = (fun x y -> ((( * ) x) y)) @@ -296,9 +298,9 @@ let b = ((tuple_get p) 1) in ((f a), (f b))) - let lam_ll1 = (fun li x -> ((li (self l_ac0)) x)) + let lam_ll1 = (fun l_ac0 self li x -> ((li (self l_ac0)) x)) - let lam_ll0 = (fun self l_ac0 -> ((map lam_ll1) l_ac0)) + let lam_ll0 = (fun self l_ac0 -> ((map ((lam_ll1 l_ac0) self)) l_ac0)) let fixpoly = (fun l -> ((fix lam_ll0) l)) @@ -418,7 +420,7 @@ ((iter f) tl) else fail) - let lam_ll2 = (fun a -> (h, a)) + let lam_ll2 = (fun h a -> (h, a)) let rec cartesian = (fun xs ys -> if (is_empty xs) then [] @@ -431,4 +433,4 @@ let main = let () = ((iter print_int) (1::(2::(3::[])))) in let () = (print_int (length ((cartesian (1::(2::[]))) (1::(2::(3::(4::[]))))))) in 0 - \ No newline at end of file + From 1da3c7bced9a780110b22b84a42cd6a00d459e2c Mon Sep 17 00:00:00 2001 From: Dmitry Pilyuk Date: Wed, 16 Apr 2025 01:51:32 +0300 Subject: [PATCH 76/92] Add type inference to anf tests --- FML/lib/inferencer/inferencer.ml | 7 +- FML/tests/anf_manytest.t | 231 +++++++++++++++++++++++++++++++ FML/tests/anf_runner.ml | 14 +- 3 files changed, 246 insertions(+), 6 deletions(-) diff --git a/FML/lib/inferencer/inferencer.ml b/FML/lib/inferencer/inferencer.ml index ab3696021..cd3352a43 100644 --- a/FML/lib/inferencer/inferencer.ml +++ b/FML/lib/inferencer/inferencer.ml @@ -656,9 +656,10 @@ let start_env = ; "not", TFunction (TBool, TBool) ; "print_int", TFunction (TInt, TUnit) ; "is_empty", TFunction (TList (TVar 1), TBool) - ; "list_head", TFunction (TList (TVar 1), TVar 1) - ; "list_tail", TFunction (TList (TVar 1), TList (TVar 1)) - ; "tuple_element", TFunction (TVar 1, TFunction (TInt, TVar 2)) + ; "is_cons", TFunction (TList (TVar 1), TBool) + ; "hd_list_get", TFunction (TList (TVar 1), TVar 1) + ; "tl_list_get", TFunction (TList (TVar 1), TList (TVar 1)) + ; "tuple_get", TFunction (TVar 1, TFunction (TInt, TVar 2)) ; "fail", TVar 1 ] in diff --git a/FML/tests/anf_manytest.t b/FML/tests/anf_manytest.t index 84429fd67..808b266d0 100644 --- a/FML/tests/anf_manytest.t +++ b/FML/tests/anf_manytest.t @@ -6,6 +6,13 @@ let f x = g_ll0 x 5 ;; + + Типы до приведения в ANF: + val f : int -> int + + Типы после приведения в ANF: + val g_ll0 : int -> int -> int + val f : int -> int $ ./anf_runner.exe << EOF > let length xs = match xs with @@ -41,6 +48,12 @@ then 0 else fail ;; + + Типы до приведения в ANF: + val length : 'a list -> int + + Типы после приведения в ANF: + val length : 'a list -> int $ ./anf_runner.exe << EOF > let is_empty x = x+1 @@ -61,6 +74,14 @@ ( + ) 1 anf2 else fail ;; + + Типы до приведения в ANF: + val is_empty : int -> int + val length : 'a list -> int + + Типы после приведения в ANF: + val is_empty_ac0 : int -> int + val length : 'a list -> int $ ./anf_runner.exe << EOF > let (a, b) = (5,6) @@ -73,6 +94,15 @@ let b = tuple_get tmp_me0 1 ;; + + Типы до приведения в ANF: + val a : int + val b : int + + Типы после приведения в ANF: + val tmp_me0 : int * int + val a : int * int + val b : 'a $ ./anf_runner.exe << EOF > let fac n = @@ -99,6 +129,15 @@ let fac n = fack_ll0 n lam_ll2 ;; + + Типы до приведения в ANF: + val fac : int -> int + + Типы после приведения в ANF: + val lam_ll1 : (int -> 'a) -> int -> int -> 'a + val fack_ll0 : int -> (int -> 'a) -> 'a + val lam_ll2 : 'a -> 'a + val fac : int -> int $ ./anf_runner.exe << EOF > let f x = match x with @@ -119,6 +158,13 @@ let f = lam_ll0 (=) ;; + + Типы до приведения в ANF: + val f : int -> int + + Типы после приведения в ANF: + val lam_ll0 : ('a -> int -> bool) -> 'a -> int + val f : int -> int $ ./anf_runner.exe < manytests/typed/001fac.ml let rec fac n = let anf0 = ( <= ) n 1 in @@ -133,6 +179,14 @@ let () = print_int anf3 in 0 ;; + + Типы до приведения в ANF: + val fac : int -> int + val main : int + + Типы после приведения в ANF: + val fac : int -> int + val main : int $ ./anf_runner.exe < manytests/typed/002fac.ml let lam_ll0 k n p = let anf0 = ( * ) p n in @@ -154,6 +208,16 @@ let () = print_int anf4 in 0 ;; + + Типы до приведения в ANF: + val fac_cps : int -> (int -> 'a) -> 'a + val main : int + + Типы после приведения в ANF: + val lam_ll0 : (int -> 'a) -> int -> int -> 'a + val fac_cps : int -> (int -> 'a) -> 'a + val lam_ll1 : 'a -> 'a + val main : int $ ./anf_runner.exe < manytests/typed/003fib.ml let rec fib_acc a b n = let anf0 = ( = ) n 1 in @@ -180,6 +244,16 @@ let () = print_int anf7 in 0 ;; + + Типы до приведения в ANF: + val fib_acc : int -> int -> int -> int + val fib : int -> int + val main : int + + Типы после приведения в ANF: + val fib_acc : int -> int -> int -> int + val fib : int -> int + val main : int $ ./anf_runner.exe < manytests/typed/004manyargs.ml let wrap f = let anf0 = ( = ) 1 1 in @@ -210,6 +284,18 @@ let temp2 = wrap test3 1 10 100 in 0 ;; + + Типы до приведения в ANF: + val wrap : 'a -> 'a + val test3 : int -> int -> int -> int + val test10 : int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int + val main : int + + Типы после приведения в ANF: + val wrap : 'a -> 'a + val test3 : int -> int -> int -> int + val test10 : int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int + val main : int $ ./anf_runner.exe < manytests/typed/005fix.ml let rec fix f x = let anf0 = fix f in @@ -228,6 +314,16 @@ let () = print_int anf4 in 0 ;; + + Типы до приведения в ANF: + val fix : (('a -> 'b) -> 'a -> 'b) -> 'a -> 'b + val fac : (int -> int) -> int -> int + val main : int + + Типы после приведения в ANF: + val fix : (('a -> 'b) -> 'a -> 'b) -> 'a -> 'b + val fac : (int -> int) -> int -> int + val main : int $ ./anf_runner.exe < manytests/typed/006partial.ml let lam_ll0 foo = ( + ) foo 2 @@ -251,6 +347,17 @@ let () = print_int anf3 in 0 ;; + + Типы до приведения в ANF: + val foo : int -> int + val main : int + + Типы после приведения в ANF: + val lam_ll0 : int -> int + val lam_ll1 : int -> int + val foo : bool -> int -> int + val foo_ac0 : int -> int + val main : int $ ./anf_runner.exe < manytests/typed/006partial2.ml let foo a b c = let () = print_int a in @@ -266,6 +373,14 @@ let () = print_int foo_ac2 in 0 ;; + + Типы до приведения в ANF: + val foo : int -> int -> int -> int + val main : int + + Типы после приведения в ANF: + val foo : int -> int -> int -> int + val main : int $ ./anf_runner.exe < manytests/typed/006partial3.ml let lam_ll1 c = print_int c ;; @@ -281,6 +396,16 @@ let main = let () = foo 4 8 9 in 0 ;; + + Типы до приведения в ANF: + val foo : int -> int -> int -> unit + val main : int + + Типы после приведения в ANF: + val lam_ll1 : int -> unit + val lam_ll0 : int -> int -> unit + val foo : int -> int -> int -> unit + val main : int $ ./anf_runner.exe < manytests/typed/007order.ml let _start () () a () b _c () d __ = let anf0 = ( + ) a b in let () = print_int anf0 in @@ -299,6 +424,14 @@ let anf3 = _start anf4 anf5 3 anf6 100 1000 anf7 10000 anf9 in print_int anf3 ;; + + Типы до приведения в ANF: + val _start : unit -> unit -> int -> unit -> int -> int -> unit -> int -> int -> int + val main : unit + + Типы после приведения в ANF: + val _start : unit -> unit -> int -> unit -> int -> int -> unit -> int -> int -> int + val main : unit $ ./anf_runner.exe < manytests/typed/008ascription.ml let addi f g x = let anf0 = g x in f x anf0 @@ -317,6 +450,16 @@ let () = print_int anf2 in 0 ;; + + Типы до приведения в ANF: + val addi : ('a -> bool -> int) -> ('a -> bool) -> 'a -> int + val main : int + + Типы после приведения в ANF: + val addi : ('a -> 'b -> 'c) -> ('a -> 'b) -> 'a -> 'c + val lam_ll0 : int -> bool -> int + val lam_ll1 : int -> bool + val main : int $ ./anf_runner.exe < manytests/typed/009let_poly.ml let f_ll0 x = x @@ -326,6 +469,13 @@ let anf1 = f_ll0 true in (anf0, anf1) ;; + + Типы до приведения в ANF: + val temp : int * bool + + Типы после приведения в ANF: + val f_ll0 : 'a -> 'a + val temp : int * bool $ ./anf_runner.exe < manytests/typed/011mapcps.ml let lam_ll0 f h k tl_ac0 = let anf1 = f h in @@ -369,6 +519,19 @@ let anf7 = map lam_ll1 anf8 lam_ll2 in iter print_int anf7 ;; + + Типы до приведения в ANF: + val map : ('a -> 'b) -> 'a list -> ('b list -> 'c) -> 'c + val iter : ('a -> 'b) -> 'a list -> unit + val main : unit + + Типы после приведения в ANF: + val lam_ll0 : ('a -> 'b) -> 'a -> ('b list -> 'c) -> 'b list -> 'c + val map : ('a -> 'b) -> 'a list -> ('b list -> 'c) -> 'c + val iter : ('a -> 'b) -> 'a list -> unit + val lam_ll1 : int -> int + val lam_ll2 : 'a -> 'a + val main : unit $ ./anf_runner.exe < manytests/typed/012fibcps.ml let lam_ll1 a k b = let anf0 = ( + ) a b in k anf0 @@ -393,6 +556,13 @@ let main = let anf6 = fib 6 lam_ll2 in print_int anf6 ;; + + Типы до приведения в ANF: + val fib : int -> (int -> 'a) -> 'a + val main : unit + + Типы после приведения в ANF: + Infer error: $ ./anf_runner.exe < manytests/typed/013foldfoldr.ml let id x = x ;; @@ -426,6 +596,20 @@ let anf5 = foldl lam_ll1 1 anf6 in print_int anf5 ;; + + Типы до приведения в ANF: + val id : 'a -> 'a + val fold_right : ('a -> 'b -> 'b) -> 'b -> 'a list -> 'b + val foldl : ('a -> 'b -> 'a) -> 'a -> 'b list -> 'a + val main : unit + + Типы после приведения в ANF: + val id : 'a -> 'a + val fold_right : ('a -> 'b -> 'b) -> 'b -> 'a list -> 'b + val lam_ll0 : ('a -> 'b -> 'c) -> 'b -> ('c -> 'd) -> 'a -> 'd + val foldl : ('a -> 'b -> 'a) -> 'a -> 'b list -> 'a + val lam_ll1 : int -> int -> int + val main : unit $ ./anf_runner.exe < manytests/typed/015tuples.ml let rec fix f x = let anf0 = fix f in @@ -496,6 +680,30 @@ let () = print_int anf17 in 0 ;; + + Типы до приведения в ANF: + val fix : (('a -> 'b) -> 'a -> 'b) -> 'a -> 'b + val map : ('a -> 'b) -> 'a * 'a -> 'b * 'b + val fixpoly : (('a -> 'b) * ('a -> 'b) -> 'a -> 'b) * (('a -> 'b) * ('a -> 'b) -> 'a -> 'b) -> ('a -> 'b) * ('a -> 'b) + val feven : 'a * (int -> int) -> int -> int + val fodd : (int -> int) * 'a -> int -> int + val tie : (int -> int) * (int -> int) + val meven : int -> int + val modd : int -> int + val main : int + + Типы после приведения в ANF: + val fix : (('a -> 'b) -> 'a -> 'b) -> 'a -> 'b + val map : ('a -> 'b) -> 'c -> 'b * 'b + val lam_ll1 : 'a -> ('a -> 'b) -> ('b -> 'c -> 'd) -> 'c -> 'd + val lam_ll0 : ('a -> 'b) -> 'a -> ('c -> 'd) * ('c -> 'd) + val fixpoly : 'a -> ('b -> 'c) * ('b -> 'c) + val feven : 'a -> int -> int + val fodd : 'a -> int -> int + val tie : ('a -> 'b) * ('a -> 'b) + val meven : int -> int + val modd : int -> int + val main : int $ ./anf_runner.exe < manytests/typed/016lists.ml let rec length xs = let anf0 = is_empty xs in @@ -698,3 +906,26 @@ let () = print_int anf82 in 0 ;; + + Типы до приведения в ANF: + val length : 'a list -> int + val length_tail : 'a list -> int + val map : ('a -> 'b) -> 'a list -> 'b list + val append : 'a list -> 'a list -> 'a list + val concat : 'a list list -> 'a list + val iter : ('a -> unit) -> 'a list -> unit + val cartesian : 'a list -> 'b list -> 'a * 'b list + val main : int + + Типы после приведения в ANF: + val length : 'a list -> int + val helper_ll0 : int -> 'a list -> int + val length_tail : 'a list -> int + val map : ('a -> 'b) -> 'a list -> 'b list + val append : 'a list -> 'a list -> 'a list + val helper_ll1 : 'a list list -> 'a list + val concat : 'a list list -> 'a list + val iter : ('a -> unit) -> 'a list -> unit + val lam_ll2 : 'a -> 'b -> 'a * 'b + val cartesian : 'a list -> 'b list -> 'a * 'b list + val main : int diff --git a/FML/tests/anf_runner.ml b/FML/tests/anf_runner.ml index e2fa101db..68b452612 100644 --- a/FML/tests/anf_runner.ml +++ b/FML/tests/anf_runner.ml @@ -4,6 +4,7 @@ open Fml_lib.Parser open Fml_lib.Inferencer +open Fml_lib.Inf_pprint open Fml_lib.A_conv open Fml_lib.Match_elimination open Fml_lib.C_conv @@ -17,17 +18,24 @@ let () = match parse input with | Ok parsed -> (match run_program_inferencer parsed with - | Ok _ -> Ok parsed + | Ok types -> Ok (parsed, types) | Error _ -> Error (Format.asprintf "Infer error:")) | Error e -> Error (Format.sprintf "Parsing error: %s" e) in match parse_and_infer input with - | Ok ast -> + | Ok (ast, (env, names_list)) -> let ast = ac_program ast in let ast_me = match_elimination ast in let ast_cc = cc_program ast_me in let ast_ll = lambda_lift ast_cc in let ast_anf = anf ast_ll in - Format.printf "%a\n" pp_anf_program ast_anf + let result = Format.asprintf "%a" pp_anf_program ast_anf in + let () = Format.printf "%a\n" pp_anf_program ast_anf in + let () = Format.printf "\nТипы до приведения в ANF:\n" in + let () = print_program_type env names_list in + let () = Format.printf "\nТипы после приведения в ANF:\n" in + (match parse_and_infer result with + | Ok (_, (env, names_list)) -> print_program_type env names_list + | Error e -> Format.printf "%s" e) | Error message -> Format.printf "%s" message ;; From b2e28a16aaca1fc81f9920733431c506fc88c35e Mon Sep 17 00:00:00 2001 From: Dmitry Pilyuk Date: Thu, 17 Apr 2025 19:59:55 +0300 Subject: [PATCH 77/92] Format --- FML/lib/anf/anf.ml | 97 +++++++++++++++++++----------------------- FML/lib/anf/anf_ast.ml | 4 +- 2 files changed, 46 insertions(+), 55 deletions(-) diff --git a/FML/lib/anf/anf.ml b/FML/lib/anf/anf.ml index 0b68b7a67..749a4d47c 100644 --- a/FML/lib/anf/anf.ml +++ b/FML/lib/anf/anf.ml @@ -3,7 +3,6 @@ open Me_ast open Common open StateMonad - let const_to_immexp = function | Me_Cint i -> ImmInt i | Me_CBool b -> ImmBool b @@ -12,57 +11,54 @@ let const_to_immexp = function let rec collect_apps expr = match expr with | Me_EApp (f, arg) -> - let f', args = collect_apps f in - (f', args @ [arg]) - | _ -> (expr, []) + let f', args = collect_apps f in + f', args @ [ arg ] + | _ -> expr, [] +;; -let rec to_cexp: me_expr -> ((string * cexpr) list * cexpr) t = function +let rec to_cexp : me_expr -> ((string * cexpr) list * cexpr) t = function | Me_ETuple elems -> let* binds, imm_elems = - RList.fold_left elems ~init:(return ([], [])) ~f:(fun (acc_binds, acc_elems) el -> - let* binds_el, imm_el = check_hard_expr el in - return (acc_binds @ binds_el, acc_elems @ [imm_el])) + RList.fold_left + elems + ~init:(return ([], [])) + ~f:(fun (acc_binds, acc_elems) el -> + let* binds_el, imm_el = check_hard_expr el in + return (acc_binds @ binds_el, acc_elems @ [ imm_el ])) in return (binds, CImmExpr (ImmTuple imm_elems)) - | Me_ELet (NoRec, name, e1, e2) -> let* binds1, ce1 = to_cexp e1 in let* binds2, ce2 = to_cexp e2 in return (binds1 @ [ name, ce1 ] @ binds2, ce2) - | Me_ECons (e1, e2) -> let* binds1, a1 = check_hard_expr e1 in let* binds2, a2 = check_hard_expr e2 in return (binds1 @ binds2, CECons (a1, a2)) - | Me_EIf (e1, e2, e3) -> let* binds1, e1 = check_hard_expr e1 in - let handle_for_let (e: me_expr) = - let* binds, expr = to_cexp e in - RList.fold_right - binds - ~init:(return @@ ACExpr(expr)) - ~f:(fun (name, cexp) acc -> return @@ ALetIn(name, cexp, acc)) in - + let handle_for_let (e : me_expr) = + let* binds, expr = to_cexp e in + RList.fold_right binds ~init:(return @@ ACExpr expr) ~f:(fun (name, cexp) acc -> + return @@ ALetIn (name, cexp, acc)) + in let* ce2 = handle_for_let e2 in let* ce3 = handle_for_let e3 in - - return (binds1, CEIf(e1, ce2, ce3)) - + return (binds1, CEIf (e1, ce2, ce3)) | Me_EApp (e1, e2) -> let f_expr, args = collect_apps (Me_EApp (e1, e2)) in let* binds_f, fun_imm = check_hard_expr f_expr in let* binds_args, imm_args = - RList.fold_left args ~init:(return ([], [])) ~f:(fun (acc_binds, acc_args) arg -> - let* binds_arg, imm_arg = check_hard_expr arg in - return (acc_binds @ binds_arg, acc_args @ [imm_arg])) + RList.fold_left + args + ~init:(return ([], [])) + ~f:(fun (acc_binds, acc_args) arg -> + let* binds_arg, imm_arg = check_hard_expr arg in + return (acc_binds @ binds_arg, acc_args @ [ imm_arg ])) in (match fun_imm with - | ImmIdentifier f_name -> - return (binds_f @ binds_args, CEApply (f_name, imm_args)) - | _ -> failwith "Expected function to be an identifier after all") - - + | ImmIdentifier f_name -> return (binds_f @ binds_args, CEApply (f_name, imm_args)) + | _ -> failwith "Expected function to be an identifier after all") | Me_EConst c -> return ([], CImmExpr (const_to_immexp c)) | Me_EIdentifier v -> return ([], CImmExpr (ImmIdentifier v)) | Me_EUnit -> return ([], CImmExpr ImmUnit) @@ -70,46 +66,42 @@ let rec to_cexp: me_expr -> ((string * cexpr) list * cexpr) t = function | _ -> failwith "See you later space cowboy" (* для обработки сложных выражений в условиях *) -and check_hard_expr e = match e with +and check_hard_expr e = + match e with | Me_EIdentifier v -> return ([], ImmIdentifier v) | Me_EConst c -> return ([], const_to_immexp c) | Me_EUnit -> return ([], ImmUnit) | Me_ENill -> return ([], ImmNill) - | e -> - let* id = fresh in - let name = "anf" ^ Int.to_string id in - let* binds1, ce = to_cexp e in - return (binds1 @ [ name, ce ], (ImmIdentifier name)) + | e -> + let* id = fresh in + let name = "anf" ^ Int.to_string id in + let* binds1, ce = to_cexp e in + return (binds1 @ [ name, ce ], ImmIdentifier name) ;; let anf_decl = - let handle_for_let (e: me_expr) = + let handle_for_let (e : me_expr) = let* binds, expr = to_cexp e in - RList.fold_right - binds - ~init:(return @@ ACExpr expr) - ~f:(fun (name, cexp) acc -> return @@ ALetIn(name, cexp, acc)) + RList.fold_right binds ~init:(return @@ ACExpr expr) ~f:(fun (name, cexp) acc -> + return @@ ALetIn (name, cexp, acc)) in let is_based_value = function - | Me_EConst _ | Me_EIdentifier _ | Me_EUnit | Me_ENill -> true - | _ -> false in + | Me_EConst _ | Me_EIdentifier _ | Me_EUnit | Me_ENill -> true + | _ -> false + in function | Me_Nonrec decls -> RList.fold_left decls ~init:(return []) ~f:(fun acc (name, e) -> match e with | Me_EFun (args, body) -> let* body' = handle_for_let body in - return (acc @ [ADNoRec [ALet (name, args, body')]]) - + return (acc @ [ ADNoRec [ ALet (name, args, body') ] ]) | _ when is_based_value e -> let* body' = handle_for_let e in - return (acc @ [Based_value (name, body')]) - + return (acc @ [ Based_value (name, body') ]) | _ -> let* expr' = handle_for_let e in - return (acc @ [ADNoRec [ALet (name, [], expr')]]) - ) - + return (acc @ [ ADNoRec [ ALet (name, [], expr') ] ])) | Me_Rec decls -> let* bindings = RList.fold_left decls ~init:(return []) ~f:(fun acc (name, e) -> @@ -122,11 +114,10 @@ let anf_decl = let* expr' = handle_for_let e in return (ALet (name, [], expr')) in - return (acc @ [new_e]) - ) + return (acc @ [ new_e ])) in - return [ADREC bindings] - ;; + return [ ADRec bindings ] +;; let anf prog = StateMonad.run diff --git a/FML/lib/anf/anf_ast.ml b/FML/lib/anf/anf_ast.ml index 829a6299e..f6e794ee8 100644 --- a/FML/lib/anf/anf_ast.ml +++ b/FML/lib/anf/anf_ast.ml @@ -25,7 +25,7 @@ type anf_binding = ALet of string * string list * aexpr type anf_decl = | Based_value of string * aexpr | ADNoRec of anf_binding list - | ADREC of anf_binding list + | ADRec of anf_binding list type anf_prog = anf_decl list @@ -75,7 +75,7 @@ let declaration_to_str = function | ADNoRec func_list -> let funs = List.map fun_to_str func_list in "let " ^ String.concat "\nand " funs ^ "\n;;" - | ADREC func_list -> + | ADRec func_list -> let funs = List.map fun_to_str func_list in "let rec " ^ String.concat "\nand " funs ^ "\n;;" ;; From 5a78434cd2e3b8a4138fe4a4aa980aef15027a1d Mon Sep 17 00:00:00 2001 From: Dmitry Pilyuk Date: Fri, 18 Apr 2025 02:24:50 +0300 Subject: [PATCH 78/92] better --- FML/lib/anf/c_conv.ml | 26 ++++------ FML/lib/anf/lambda_lift.ml | 24 +++++++-- FML/tests/anf_manytest.t | 88 +++++++++++++++++++++++++------- FML/tests/c_conv_manytest.t | 24 ++++++--- FML/tests/lambda_lift_manytest.t | 47 ++++++++++++----- 5 files changed, 153 insertions(+), 56 deletions(-) diff --git a/FML/lib/anf/c_conv.ml b/FML/lib/anf/c_conv.ml index f86372245..6248a63ee 100644 --- a/FML/lib/anf/c_conv.ml +++ b/FML/lib/anf/c_conv.ml @@ -62,11 +62,10 @@ let rec cc_expr env bindings = function let new_e2 = cc_expr env bindings e2 in Me_ELet (NoRec, name, new_e1, new_e2) | Me_ELet (Rec, name, e1, e2) -> - let env = StrSet.add env name in let new_e1, bindings = match e1 with | Me_EFun (args, expr) as e -> - let fvs = StrSet.to_list (expr_free_vars env e) in + let fvs = StrSet.to_list (expr_free_vars (StrSet.add env name) e) in let apply = List.fold_left (fun acc arg -> Me_EApp (acc, Me_EIdentifier arg)) @@ -78,23 +77,11 @@ let rec cc_expr env bindings = function new_expr, StrMap.update bindings name ~f:(fun _ -> apply) | expr -> cc_expr env StrMap.empty expr, bindings in - let new_e2 = cc_expr env bindings e2 in + let new_e2 = cc_expr (StrSet.add env name) bindings e2 in Me_ELet (Rec, name, new_e1, new_e2) | expr -> expr ;; -(* let cc_nonrec env decls = - let decls = List.map (fun (name, expr) -> name, cc_expr env StrMap.empty expr) decls in - let env = List.fold_left (fun acc (name, _) -> StrSet.add acc name) env decls in - decls, env - ;; - - let cc_rec env decls = - let env = List.fold_left (fun acc (name, _) -> StrSet.add acc name) env decls in - let decls = List.map (fun (name, expr) -> name, cc_expr env StrMap.empty expr) decls in - decls, env - ;; *) - let cc_decl env = function | Me_Nonrec decls -> let decls = @@ -103,9 +90,14 @@ let cc_decl env = function let env = List.fold_left (fun acc (name, _) -> StrSet.add acc name) env decls in Me_Nonrec decls, env | Me_Rec decls -> - let env = List.fold_left (fun acc (name, _) -> StrSet.add acc name) env decls in + (* let env = List.fold_left (fun acc (name, _) -> StrSet.add acc name) env decls in *) let decls = - List.map (fun (name, expr) -> name, cc_expr env StrMap.empty expr) decls + List.map + (fun (name, expr) -> + match expr with + | Me_EFun (args, expr) -> name, Me_EFun (args, cc_expr env StrMap.empty expr) + | expr -> name, cc_expr env StrMap.empty expr) + decls in Me_Rec decls, env ;; diff --git a/FML/lib/anf/lambda_lift.ml b/FML/lib/anf/lambda_lift.ml index 78671fb25..26848bed2 100644 --- a/FML/lib/anf/lambda_lift.ml +++ b/FML/lib/anf/lambda_lift.ml @@ -45,7 +45,13 @@ let rec ll_expr bindings = function let* defs1, e1' = ll_expr bindings e1 in let* id = fresh in let new_name = get_new_id id name in - let def = Me_Nonrec [ new_name, Me_EFun (args, e1') ] in + let new_args = + List.map args ~f:(fun arg -> + match StrMap.find bindings arg with + | Some id -> id + | None -> arg) + in + let def = Me_Nonrec [ new_name, Me_EFun (new_args, e1') ] in let* defs2, e2' = ll_expr (StrMap.update bindings name ~f:(fun _ -> new_name)) e2 in @@ -61,7 +67,13 @@ let rec ll_expr bindings = function let new_name = get_new_id id name in let bindings' = StrMap.update bindings name ~f:(fun _ -> new_name) in let* defs1, e1' = ll_expr bindings' e1 in - let def = Me_Rec [ new_name, Me_EFun (args, e1') ] in + let new_args = + List.map args ~f:(fun arg -> + match StrMap.find bindings arg with + | Some id -> id + | None -> arg) + in + let def = Me_Rec [ new_name, Me_EFun (new_args, e1') ] in let* defs2, e2' = ll_expr bindings' e2 in return (defs1 @ [ def ] @ defs2, e2') | _ -> failwith "Not reachable") @@ -69,7 +81,13 @@ let rec ll_expr bindings = function let* id = fresh in let name = get_new_id id "lam" in let* defs, body' = ll_expr bindings body in - let new_fun = Me_EFun (args, body') in + let new_args = + List.map args ~f:(fun arg -> + match StrMap.find bindings arg with + | Some id -> id + | None -> arg) + in + let new_fun = Me_EFun (new_args, body') in let def = Me_Nonrec [ name, new_fun ] in return (defs @ [ def ], Me_EIdentifier name) ;; diff --git a/FML/tests/anf_manytest.t b/FML/tests/anf_manytest.t index 808b266d0..0851a4714 100644 --- a/FML/tests/anf_manytest.t +++ b/FML/tests/anf_manytest.t @@ -1,4 +1,44 @@ $ ./anf_runner.exe << EOF + > let main = + > let rec fib n k = + > if n < 2 + > then k n + > else fib (n - 1) (fun a -> fib (n - 2) (fun b -> k (a + b))) in print_int(fib 6 (fun x -> x)) + > EOF + let lam_ll2 a k b = let anf0 = ( + ) a b in + k anf0 + ;; + + let lam_ll1 fib_ll0 k n a = let anf1 = ( - ) n 2 in + let anf2 = lam_ll2 a k in + fib_ll0 anf1 anf2 + ;; + + let rec fib_ll0 n k = let anf3 = ( < ) n 2 in + if anf3 + then k n + else let anf4 = ( - ) n 1 in + let anf5 = lam_ll1 fib_ll0 k n in + fib_ll0 anf4 anf5 + ;; + + let lam_ll3 x = x + ;; + + let main = let anf6 = fib_ll0 6 lam_ll3 in + print_int anf6 + ;; + + Типы до приведения в ANF: + val main : unit + + Типы после приведения в ANF: + val lam_ll2 : int -> (int -> 'a) -> int -> 'a + val lam_ll1 : (int -> (int -> 'a) -> 'b) -> (int -> 'a) -> int -> int -> 'b + val fib_ll0 : int -> (int -> 'a) -> 'a + val lam_ll3 : 'a -> 'a + val main : unit + $ ./anf_runner.exe << EOF > let f x = let g y = x + y in g 5;; > EOF let g_ll0 x y = ( + ) x y @@ -537,7 +577,7 @@ k anf0 ;; - let lam_ll0 k n a = let anf1 = ( - ) n 2 in + let lam_ll0 fib k n a = let anf1 = ( - ) n 2 in let anf2 = lam_ll1 a k in fib anf1 anf2 ;; @@ -546,7 +586,7 @@ if anf3 then k n else let anf4 = ( - ) n 1 in - let anf5 = lam_ll0 k n in + let anf5 = lam_ll0 fib k n in fib anf4 anf5 ;; @@ -562,7 +602,11 @@ val main : unit Типы после приведения в ANF: - Infer error: + val lam_ll1 : int -> (int -> 'a) -> int -> 'a + val lam_ll0 : (int -> (int -> 'a) -> 'b) -> (int -> 'a) -> int -> int -> 'b + val fib : int -> (int -> 'a) -> 'a + val lam_ll2 : 'a -> 'a + val main : unit $ ./anf_runner.exe < manytests/typed/013foldfoldr.ml let id x = x ;; @@ -579,21 +623,24 @@ else fail ;; - let lam_ll0 f b g x = let anf3 = f x b in + let lam_ll1 f b g x = let anf3 = f x b in g anf3 ;; - let foldl f a bs = let anf4 = lam_ll0 f in + let lam_ll0 fold_right f a bs = let anf4 = lam_ll1 f in fold_right anf4 id bs a ;; - let lam_ll1 x y = ( * ) x y + let foldl = lam_ll0 fold_right + ;; + + let lam_ll2 x y = ( * ) x y ;; let main = let anf8 = (3::[]) in let anf7 = (2::anf8) in let anf6 = (1::anf7) in - let anf5 = foldl lam_ll1 1 anf6 in + let anf5 = foldl lam_ll2 1 anf6 in print_int anf5 ;; @@ -606,9 +653,10 @@ Типы после приведения в ANF: val id : 'a -> 'a val fold_right : ('a -> 'b -> 'b) -> 'b -> 'a list -> 'b - val lam_ll0 : ('a -> 'b -> 'c) -> 'b -> ('c -> 'd) -> 'a -> 'd + val lam_ll1 : ('a -> 'b -> 'c) -> 'b -> ('c -> 'd) -> 'a -> 'd + val lam_ll0 : (('a -> ('b -> 'c) -> 'd -> 'c) -> ('e -> 'e) -> 'f -> 'g -> 'h) -> ('d -> 'a -> 'b) -> 'g -> 'f -> 'h val foldl : ('a -> 'b -> 'a) -> 'a -> 'b list -> 'a - val lam_ll1 : int -> int -> int + val lam_ll2 : int -> int -> int val main : unit $ ./anf_runner.exe < manytests/typed/015tuples.ml @@ -623,15 +671,18 @@ (anf1, anf2) ;; - let lam_ll1 l_ac0 self li x = let anf3 = self l_ac0 in + let lam_ll2 l_ac0 self li x = let anf3 = self l_ac0 in li anf3 x ;; - let lam_ll0 self l_ac0 = let anf4 = lam_ll1 l_ac0 self in + let lam_ll1 self l_ac0 = let anf4 = lam_ll2 l_ac0 self in map anf4 l_ac0 ;; - let fixpoly l = fix lam_ll0 l + let lam_ll0 fix l = fix lam_ll1 l + ;; + + let fixpoly = lam_ll0 fix ;; let feven p n = let e = tuple_get p 0 in @@ -695,8 +746,9 @@ Типы после приведения в ANF: val fix : (('a -> 'b) -> 'a -> 'b) -> 'a -> 'b val map : ('a -> 'b) -> 'c -> 'b * 'b - val lam_ll1 : 'a -> ('a -> 'b) -> ('b -> 'c -> 'd) -> 'c -> 'd - val lam_ll0 : ('a -> 'b) -> 'a -> ('c -> 'd) * ('c -> 'd) + val lam_ll2 : 'a -> ('a -> 'b) -> ('b -> 'c -> 'd) -> 'c -> 'd + val lam_ll1 : ('a -> 'b) -> 'a -> ('c -> 'd) * ('c -> 'd) + val lam_ll0 : ((('a -> 'b) -> 'a -> ('c -> 'd) * ('c -> 'd)) -> 'e -> 'f) -> 'e -> 'f val fixpoly : 'a -> ('b -> 'c) * ('b -> 'c) val feven : 'a -> int -> int val fodd : 'a -> int -> int @@ -847,19 +899,19 @@ else fail ;; - let rec helper_ll1 xs = let anf69 = is_empty xs in + let rec helper_ll1 append xs = let anf69 = is_empty xs in if anf69 then [] else let anf70 = is_cons xs in if anf70 then let h = hd_list_get xs in let tl = tl_list_get xs in - let anf71 = helper_ll1 tl in + let anf71 = helper_ll1 append tl in append h anf71 else fail ;; - let concat = helper_ll1 + let concat = helper_ll1 append ;; let rec iter f xs = let anf72 = is_empty xs in @@ -923,7 +975,7 @@ val length_tail : 'a list -> int val map : ('a -> 'b) -> 'a list -> 'b list val append : 'a list -> 'a list -> 'a list - val helper_ll1 : 'a list list -> 'a list + val helper_ll1 : ('a -> 'b list -> 'b list) -> 'a list -> 'b list val concat : 'a list list -> 'a list val iter : ('a -> unit) -> 'a list -> unit val lam_ll2 : 'a -> 'b -> 'a * 'b diff --git a/FML/tests/c_conv_manytest.t b/FML/tests/c_conv_manytest.t index 2fc83c59d..4c0945caf 100644 --- a/FML/tests/c_conv_manytest.t +++ b/FML/tests/c_conv_manytest.t @@ -1,3 +1,15 @@ + $ ./c_conv_runner.exe << EOF + > let main = + > let rec fib n k = + > if n < 2 + > then k n + > else fib (n - 1) (fun a -> fib (n - 2) (fun b -> k (a + b))) in print_int(fib 6 (fun x -> x)) + > EOF + let main = let rec fib = (fun n k -> if ((( < ) n) 2) + then (k n) + else ((fib ((( - ) n) 1)) ((((fun fib k n a -> ((fib ((( - ) n) 2)) (((fun a k b -> (k ((( + ) a) b))) a) k))) fib) k) n))) in + (print_int ((fib 6) (fun x -> x))) + $ ./c_conv_runner.exe << EOF > let f x = let g y = x + y in g 5;; > EOF @@ -202,7 +214,7 @@ $ ./c_conv_runner.exe < manytests/typed/012fibcps.ml let rec fib = (fun n k -> if ((( < ) n) 2) then (k n) - else ((fib ((( - ) n) 1)) (((fun k n a -> ((fib ((( - ) n) 2)) (((fun a k b -> (k ((( + ) a) b))) a) k))) k) n))) + else ((fib ((( - ) n) 1)) ((((fun fib k n a -> ((fib ((( - ) n) 2)) (((fun a k b -> (k ((( + ) a) b))) a) k))) fib) k) n))) let main = (print_int ((fib 6) (fun x -> x))) $ ./c_conv_runner.exe < manytests/typed/013foldfoldr.ml @@ -216,7 +228,7 @@ ((f h) (((fold_right f) acc) tl)) else fail) - let foldl = (fun f a bs -> ((((fold_right ((fun f b g x -> (g ((f x) b))) f)) id) bs) a)) + let foldl = ((fun fold_right f a bs -> ((((fold_right ((fun f b g x -> (g ((f x) b))) f)) id) bs) a)) fold_right) let main = (print_int (((foldl (fun x y -> ((( * ) x) y))) 1) (1::(2::(3::[]))))) @@ -227,7 +239,7 @@ let b = ((tuple_get p) 1) in ((f a), (f b))) - let fixpoly = (fun l -> ((fix (fun self l_ac0 -> ((map (((fun l_ac0 self li x -> ((li (self l_ac0)) x)) l_ac0) self)) l_ac0))) l)) + let fixpoly = ((fun fix l -> ((fix (fun self l_ac0 -> ((map (((fun l_ac0 self li x -> ((li (self l_ac0)) x)) l_ac0) self)) l_ac0))) l)) fix) let feven = (fun p n -> let e = ((tuple_get p) 0) in let o = ((tuple_get p) 1) in @@ -325,14 +337,14 @@ (x::((append xs_ac0) ys)) else fail) - let concat = let rec helper = (fun xs -> if (is_empty xs) + let concat = let rec helper = (fun append xs -> if (is_empty xs) then [] else if (is_cons xs) then let h = (hd_list_get xs) in let tl = (tl_list_get xs) in - ((append h) (helper tl)) + ((append h) ((helper append) tl)) else fail) in - helper + (helper append) let rec iter = (fun f xs -> if (is_empty xs) then () diff --git a/FML/tests/lambda_lift_manytest.t b/FML/tests/lambda_lift_manytest.t index e17d9f93d..fe19098ed 100644 --- a/FML/tests/lambda_lift_manytest.t +++ b/FML/tests/lambda_lift_manytest.t @@ -1,3 +1,22 @@ + $ ./lambda_lift_runner.exe << EOF + > let main = + > let rec fib n k = + > if n < 2 + > then k n + > else fib (n - 1) (fun a -> fib (n - 2) (fun b -> k (a + b))) in print_int(fib 6 (fun x -> x)) + > EOF + let lam_ll2 = (fun a k b -> (k ((( + ) a) b))) + + let lam_ll1 = (fun fib_ll0 k n a -> ((fib_ll0 ((( - ) n) 2)) ((lam_ll2 a) k))) + + let rec fib_ll0 = (fun n k -> if ((( < ) n) 2) + then (k n) + else ((fib_ll0 ((( - ) n) 1)) (((lam_ll1 fib_ll0) k) n))) + + let lam_ll3 = (fun x -> x) + + let main = (print_int ((fib_ll0 6) lam_ll3)) + $ ./lambda_lift_runner.exe << EOF > let f x = let g y = x + y in g 5;; > EOF @@ -263,11 +282,11 @@ $ ./lambda_lift_runner.exe < manytests/typed/012fibcps.ml let lam_ll1 = (fun a k b -> (k ((( + ) a) b))) - let lam_ll0 = (fun k n a -> ((fib ((( - ) n) 2)) ((lam_ll1 a) k))) + let lam_ll0 = (fun fib k n a -> ((fib ((( - ) n) 2)) ((lam_ll1 a) k))) let rec fib = (fun n k -> if ((( < ) n) 2) then (k n) - else ((fib ((( - ) n) 1)) ((lam_ll0 k) n))) + else ((fib ((( - ) n) 1)) (((lam_ll0 fib) k) n))) let lam_ll2 = (fun x -> x) @@ -283,13 +302,15 @@ ((f h) (((fold_right f) acc) tl)) else fail) - let lam_ll0 = (fun f b g x -> (g ((f x) b))) + let lam_ll1 = (fun f b g x -> (g ((f x) b))) - let foldl = (fun f a bs -> ((((fold_right (lam_ll0 f)) id) bs) a)) + let lam_ll0 = (fun fold_right f a bs -> ((((fold_right (lam_ll1 f)) id) bs) a)) - let lam_ll1 = (fun x y -> ((( * ) x) y)) + let foldl = (lam_ll0 fold_right) - let main = (print_int (((foldl lam_ll1) 1) (1::(2::(3::[]))))) + let lam_ll2 = (fun x y -> ((( * ) x) y)) + + let main = (print_int (((foldl lam_ll2) 1) (1::(2::(3::[]))))) $ ./lambda_lift_runner.exe < manytests/typed/015tuples.ml let rec fix = (fun f x -> ((f (fix f)) x)) @@ -298,11 +319,13 @@ let b = ((tuple_get p) 1) in ((f a), (f b))) - let lam_ll1 = (fun l_ac0 self li x -> ((li (self l_ac0)) x)) + let lam_ll2 = (fun l_ac0 self li x -> ((li (self l_ac0)) x)) + + let lam_ll1 = (fun self l_ac0 -> ((map ((lam_ll2 l_ac0) self)) l_ac0)) - let lam_ll0 = (fun self l_ac0 -> ((map ((lam_ll1 l_ac0) self)) l_ac0)) + let lam_ll0 = (fun fix l -> ((fix lam_ll1) l)) - let fixpoly = (fun l -> ((fix lam_ll0) l)) + let fixpoly = (lam_ll0 fix) let feven = (fun p n -> let e = ((tuple_get p) 0) in let o = ((tuple_get p) 1) in @@ -401,15 +424,15 @@ (x::((append xs_ac0) ys)) else fail) - let rec helper_ll1 = (fun xs -> if (is_empty xs) + let rec helper_ll1 = (fun append xs -> if (is_empty xs) then [] else if (is_cons xs) then let h = (hd_list_get xs) in let tl = (tl_list_get xs) in - ((append h) (helper_ll1 tl)) + ((append h) ((helper_ll1 append) tl)) else fail) - let concat = helper_ll1 + let concat = (helper_ll1 append) let rec iter = (fun f xs -> if (is_empty xs) then () From 933c96cc0064f7101fa6dd836a2c0ff255c0d31e Mon Sep 17 00:00:00 2001 From: RozhkovAleksandr Date: Sat, 19 Apr 2025 11:24:07 +0300 Subject: [PATCH 79/92] fix bug with getting tuple in efun --- FML/lib/anf/match_elimination.ml | 30 +++++++++++++++++++------- FML/tests/match_elimination_manytest.t | 4 +++- 2 files changed, 25 insertions(+), 9 deletions(-) diff --git a/FML/lib/anf/match_elimination.ml b/FML/lib/anf/match_elimination.ml index fd09df509..47979c042 100644 --- a/FML/lib/anf/match_elimination.ml +++ b/FML/lib/anf/match_elimination.ml @@ -65,14 +65,28 @@ let rec expr_to_mexpr expr = let* f' = expr_to_mexpr f in let* arg' = expr_to_mexpr arg in return @@ Me_EApp (f', arg') - | EFun (pat, body) -> - let rec helper acc = function - | EFun (pat, body) -> helper (acc @ pattern_remove pat) body - | expr -> - let* body = expr_to_mexpr expr in - return @@ Me_EFun (acc, body) - in - helper (pattern_remove pat) body + | EFun (pat, body) -> ( + match pat with + | PTuple _ -> + (* Случай: let f (x, y) = ... *) + let* id_num = fresh in + let arg_id = get_new_id id_num "me" in + let arg_expr = Me_EIdentifier arg_id in + let bindings = pattern_bindings arg_expr pat in + let* body' = expr_to_mexpr body in + let body_with_bindings = + List.fold_right bindings ~init:body' ~f:(fun (id, expr) acc -> + Me_ELet (NoRec, id, expr, acc)) + in return @@ Me_EFun ([arg_id], body_with_bindings) + | _ -> + let rec helper acc = function + | EFun (pat, body) -> helper (acc @ pattern_remove pat) body + | expr -> + let* body = expr_to_mexpr expr in + return @@ Me_EFun (acc, body) + in + helper (pattern_remove pat) body + ) | ELetIn (rec_flag, pat, e1, e2) -> let ids = pattern_remove pat in let* e1' = expr_to_mexpr e1 in diff --git a/FML/tests/match_elimination_manytest.t b/FML/tests/match_elimination_manytest.t index 79b10b9b6..9d9e537a1 100644 --- a/FML/tests/match_elimination_manytest.t +++ b/FML/tests/match_elimination_manytest.t @@ -2,7 +2,9 @@ > let f (x,y) = x+y;; > let main = let () = print_int ( f (1,2) ) in 0;; > EOF - let f = (fun x y -> ((( + ) x) y)) + let f = (fun me_me0 -> let x = ((tuple_get me_me0) 0) in + let y = ((tuple_get me_me0) 1) in + ((( + ) x) y)) let main = let () = (print_int (f (1, 2))) in 0 From 0696fe64b1a4c207fcd164c774b31d89181ef7e9 Mon Sep 17 00:00:00 2001 From: Dmitry Pilyuk Date: Sat, 19 Apr 2025 18:08:53 +0300 Subject: [PATCH 80/92] Fix order of args --- FML/lib/anf/anf.ml | 4 +-- FML/tests/anf_manytest.t | 76 ++++++++++++++++++++-------------------- 2 files changed, 40 insertions(+), 40 deletions(-) diff --git a/FML/lib/anf/anf.ml b/FML/lib/anf/anf.ml index 749a4d47c..86be74db7 100644 --- a/FML/lib/anf/anf.ml +++ b/FML/lib/anf/anf.ml @@ -50,11 +50,11 @@ let rec to_cexp : me_expr -> ((string * cexpr) list * cexpr) t = function let* binds_f, fun_imm = check_hard_expr f_expr in let* binds_args, imm_args = RList.fold_left - args + (List.rev args) ~init:(return ([], [])) ~f:(fun (acc_binds, acc_args) arg -> let* binds_arg, imm_arg = check_hard_expr arg in - return (acc_binds @ binds_arg, acc_args @ [ imm_arg ])) + return (acc_binds @ binds_arg, imm_arg :: acc_args)) in (match fun_imm with | ImmIdentifier f_name -> return (binds_f @ binds_args, CEApply (f_name, imm_args)) diff --git a/FML/tests/anf_manytest.t b/FML/tests/anf_manytest.t index 0851a4714..4a0dbc524 100644 --- a/FML/tests/anf_manytest.t +++ b/FML/tests/anf_manytest.t @@ -9,17 +9,17 @@ k anf0 ;; - let lam_ll1 fib_ll0 k n a = let anf1 = ( - ) n 2 in - let anf2 = lam_ll2 a k in - fib_ll0 anf1 anf2 + let lam_ll1 fib_ll0 k n a = let anf1 = lam_ll2 a k in + let anf2 = ( - ) n 2 in + fib_ll0 anf2 anf1 ;; let rec fib_ll0 n k = let anf3 = ( < ) n 2 in if anf3 then k n - else let anf4 = ( - ) n 1 in - let anf5 = lam_ll1 fib_ll0 k n in - fib_ll0 anf4 anf5 + else let anf4 = lam_ll1 fib_ll0 k n in + let anf5 = ( - ) n 1 in + fib_ll0 anf5 anf4 ;; let lam_ll3 x = x @@ -159,9 +159,9 @@ let rec fack_ll0 n_ac0 k = let anf1 = ( <= ) n_ac0 1 in if anf1 then k 1 - else let anf2 = ( - ) n_ac0 1 in - let anf3 = lam_ll1 k n_ac0 in - fack_ll0 anf2 anf3 + else let anf2 = lam_ll1 k n_ac0 in + let anf3 = ( - ) n_ac0 1 in + fack_ll0 anf3 anf2 ;; let lam_ll2 x = x @@ -236,9 +236,9 @@ let rec fac_cps n k = let anf1 = ( = ) n 1 in if anf1 then k 1 - else let anf2 = ( - ) n 1 in - let anf3 = lam_ll0 k n in - fac_cps anf2 anf3 + else let anf2 = lam_ll0 k n in + let anf3 = ( - ) n 1 in + fac_cps anf3 anf2 ;; let lam_ll1 print_int_ac0 = print_int_ac0 @@ -271,11 +271,11 @@ let rec fib n = let anf1 = ( < ) n 2 in if anf1 then n - else let anf3 = ( - ) n 1 in + else let anf3 = ( - ) n 2 in let anf2 = fib anf3 in - let anf5 = ( - ) n 2 in + let anf5 = ( - ) n 1 in let anf4 = fib anf5 in - ( + ) anf2 anf4 + ( + ) anf4 anf2 ;; let main = let anf6 = fib_acc 0 1 4 in @@ -455,13 +455,13 @@ ( + ) anf1 d ;; - let main = let anf4 = print_int 1 in - let anf5 = print_int 2 in - let anf6 = print_int 4 in - let anf8 = ( ~- ) 1 in - let anf7 = print_int anf8 in - let anf9 = ( ~- ) 555555 in - let anf3 = _start anf4 anf5 3 anf6 100 1000 anf7 10000 anf9 in + let main = let anf4 = ( ~- ) 555555 in + let anf6 = ( ~- ) 1 in + let anf5 = print_int anf6 in + let anf7 = print_int 4 in + let anf8 = print_int 2 in + let anf9 = print_int 1 in + let anf3 = _start anf9 anf8 3 anf7 100 1000 anf5 10000 anf4 in print_int anf3 ;; @@ -577,17 +577,17 @@ k anf0 ;; - let lam_ll0 fib k n a = let anf1 = ( - ) n 2 in - let anf2 = lam_ll1 a k in - fib anf1 anf2 + let lam_ll0 fib k n a = let anf1 = lam_ll1 a k in + let anf2 = ( - ) n 2 in + fib anf2 anf1 ;; let rec fib n k = let anf3 = ( < ) n 2 in if anf3 then k n - else let anf4 = ( - ) n 1 in - let anf5 = lam_ll0 fib k n in - fib anf4 anf5 + else let anf4 = lam_ll0 fib k n in + let anf5 = ( - ) n 1 in + fib anf5 anf4 ;; let lam_ll2 x = x @@ -936,10 +936,10 @@ if anf75 then let h = hd_list_get xs in let tl = tl_list_get xs in - let anf77 = lam_ll2 h in - let anf76 = map anf77 ys in - let anf78 = cartesian tl ys in - append anf76 anf78 + let anf76 = cartesian tl ys in + let anf78 = lam_ll2 h in + let anf77 = map anf78 ys in + append anf77 anf76 else fail ;; @@ -947,13 +947,13 @@ let anf80 = (2::anf81) in let anf79 = (1::anf80) in let () = iter print_int anf79 in - let anf85 = (2::[]) in + let anf87 = (4::[]) in + let anf86 = (3::anf87) in + let anf85 = (2::anf86) in let anf84 = (1::anf85) in - let anf89 = (4::[]) in - let anf88 = (3::anf89) in - let anf87 = (2::anf88) in - let anf86 = (1::anf87) in - let anf83 = cartesian anf84 anf86 in + let anf89 = (2::[]) in + let anf88 = (1::anf89) in + let anf83 = cartesian anf88 anf84 in let anf82 = length anf83 in let () = print_int anf82 in 0 From cfc9bfbed76500cd7890e745cc0b4a447e22ad89 Mon Sep 17 00:00:00 2001 From: RozhkovAleksandr Date: Sat, 19 Apr 2025 19:11:59 +0300 Subject: [PATCH 81/92] fix list pattern in me --- FML/lib/anf/match_elimination.ml | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/FML/lib/anf/match_elimination.ml b/FML/lib/anf/match_elimination.ml index 47979c042..b90611e34 100644 --- a/FML/lib/anf/match_elimination.ml +++ b/FML/lib/anf/match_elimination.ml @@ -67,17 +67,17 @@ let rec expr_to_mexpr expr = return @@ Me_EApp (f', arg') | EFun (pat, body) -> ( match pat with - | PTuple _ -> - (* Случай: let f (x, y) = ... *) + | PTuple _ | PCons _ -> let* id_num = fresh in let arg_id = get_new_id id_num "me" in let arg_expr = Me_EIdentifier arg_id in let bindings = pattern_bindings arg_expr pat in let* body' = expr_to_mexpr body in let body_with_bindings = - List.fold_right bindings ~init:body' ~f:(fun (id, expr) acc -> - Me_ELet (NoRec, id, expr, acc)) - in return @@ Me_EFun ([arg_id], body_with_bindings) + List.fold_right bindings ~init:body' ~f:(fun (id, expr) acc -> + Me_ELet (NoRec, id, expr, acc)) + in + return @@ Me_EFun ([arg_id], body_with_bindings) | _ -> let rec helper acc = function | EFun (pat, body) -> helper (acc @ pattern_remove pat) body From 9e3fcd3f34126d171fb216936f535fc115ebaf50 Mon Sep 17 00:00:00 2001 From: Dmitry Pilyuk Date: Sun, 20 Apr 2025 03:07:50 +0300 Subject: [PATCH 82/92] Fix linter warnings --- FML/lib/anf/a_conv.ml | 14 ++++---- FML/lib/anf/anf.ml | 7 ++-- FML/lib/anf/c_conv.ml | 3 +- FML/lib/anf/common.ml | 4 +-- FML/lib/anf/lambda_lift.ml | 3 +- FML/lib/anf/match_elimination.ml | 59 ++++++++++++++------------------ FML/lib/anf/me_ast.ml | 3 +- FML/lib/inferencer/inferencer.ml | 18 ++++------ FML/lib/parser/parser.ml | 2 +- FML/tests/dune | 1 - 10 files changed, 52 insertions(+), 62 deletions(-) diff --git a/FML/lib/anf/a_conv.ml b/FML/lib/anf/a_conv.ml index b7213961b..1cd372f2c 100644 --- a/FML/lib/anf/a_conv.ml +++ b/FML/lib/anf/a_conv.ml @@ -10,14 +10,12 @@ open StateMonad let get_new_id n name = String.concat [ name; "_ac"; Int.to_string n ] let rec ac_pattern env bindings = function - | PIdentifier name as pat -> - if StrSet.find env name - then - let* fr = fresh in - let id = get_new_id fr name in - return - (StrSet.add env id, StrMap.update bindings name ~f:(fun _ -> id), PIdentifier id) - else return (StrSet.add env name, bindings, pat) + | PIdentifier name when StrSet.find env name -> + let* fr = fresh in + let id = get_new_id fr name in + return + (StrSet.add env id, StrMap.update bindings name ~f:(fun _ -> id), PIdentifier id) + | PIdentifier name as pat -> return (StrSet.add env name, bindings, pat) | PConstraint (pat, _) -> ac_pattern env bindings pat | PCons (hd, tl) -> let* env', bindings', hd_pat = ac_pattern env bindings hd in diff --git a/FML/lib/anf/anf.ml b/FML/lib/anf/anf.ml index 86be74db7..336f1b729 100644 --- a/FML/lib/anf/anf.ml +++ b/FML/lib/anf/anf.ml @@ -1,3 +1,7 @@ +(** Copyright 2024-2025, Dmitry Pilyuk, Aleksandr Rozhkov *) + +(** SPDX-License-Identifier: LGPL-2.1 *) + open Anf_ast open Me_ast open Common @@ -66,8 +70,7 @@ let rec to_cexp : me_expr -> ((string * cexpr) list * cexpr) t = function | _ -> failwith "See you later space cowboy" (* для обработки сложных выражений в условиях *) -and check_hard_expr e = - match e with +and check_hard_expr = function | Me_EIdentifier v -> return ([], ImmIdentifier v) | Me_EConst c -> return ([], const_to_immexp c) | Me_EUnit -> return ([], ImmUnit) diff --git a/FML/lib/anf/c_conv.ml b/FML/lib/anf/c_conv.ml index 6248a63ee..7f50ac598 100644 --- a/FML/lib/anf/c_conv.ml +++ b/FML/lib/anf/c_conv.ml @@ -9,7 +9,8 @@ let rec expr_free_vars binded = let open StrSet in function | Me_EConst _ | Me_ENill | Me_EUnit -> StrSet.empty - | Me_EIdentifier id -> if find binded id then empty else singleton id + | Me_EIdentifier id when find binded id -> empty + | Me_EIdentifier id -> singleton id | Me_EIf (e1, e2, e3) -> union_list [ expr_free_vars binded e1; expr_free_vars binded e2; expr_free_vars binded e3 ] diff --git a/FML/lib/anf/common.ml b/FML/lib/anf/common.ml index 52331e92f..bff820642 100644 --- a/FML/lib/anf/common.ml +++ b/FML/lib/anf/common.ml @@ -11,7 +11,7 @@ module StrMap = struct let singleton str = Map.singleton (module String) str let add = Map.add let update = Map.update - let find m str = Map.find m str + let find = Map.find let merge_two fst snd = Map.merge_skewed fst snd ~combine:(fun ~key:_ _ v2 -> v2) end @@ -54,7 +54,7 @@ module StrSet = struct let fold = Set.fold let diff = Set.diff let union_list lst = Set.union_list (module String) lst - let find s str = Set.mem s str + let find = Set.mem end module StateMonad : sig diff --git a/FML/lib/anf/lambda_lift.ml b/FML/lib/anf/lambda_lift.ml index 26848bed2..603e1142e 100644 --- a/FML/lib/anf/lambda_lift.ml +++ b/FML/lib/anf/lambda_lift.ml @@ -102,8 +102,7 @@ let ll_binding (name, expr) = return (defs, (name, expr')) ;; -let ll_decl decl = - match decl with +let ll_decl = function | Me_Nonrec bindings -> let* all_defs, curr_defs = RList.fold_left diff --git a/FML/lib/anf/match_elimination.ml b/FML/lib/anf/match_elimination.ml index b90611e34..184204c38 100644 --- a/FML/lib/anf/match_elimination.ml +++ b/FML/lib/anf/match_elimination.ml @@ -15,8 +15,7 @@ let const_to_pe_const = function | CBool a -> Me_CBool a ;; -let rec pattern_remove pat = - match pat with +let rec pattern_remove = function | PUnit -> [ "()" ] | PAny -> [] | PConst _ -> [] @@ -27,8 +26,7 @@ let rec pattern_remove pat = | PConstraint (p, _) -> pattern_remove p ;; -let rec pattern_bindings expr pat = - match pat with +let rec pattern_bindings expr = function | PIdentifier id when String.(id <> "_") -> [ id, expr ] | PIdentifier _ -> [] | PAny -> [] @@ -54,8 +52,7 @@ let rec_flags : Ast.rec_flag -> Me_ast.rec_flag = function | NoRec -> NoRec ;; -let rec expr_to_mexpr expr = - match expr with +let rec expr_to_mexpr = function | EUnit -> return Me_EUnit | ENill -> return Me_ENill | EConstraint (e, _) -> expr_to_mexpr e @@ -65,28 +62,27 @@ let rec expr_to_mexpr expr = let* f' = expr_to_mexpr f in let* arg' = expr_to_mexpr arg in return @@ Me_EApp (f', arg') - | EFun (pat, body) -> ( - match pat with - | PTuple _ | PCons _ -> - let* id_num = fresh in - let arg_id = get_new_id id_num "me" in - let arg_expr = Me_EIdentifier arg_id in - let bindings = pattern_bindings arg_expr pat in - let* body' = expr_to_mexpr body in - let body_with_bindings = - List.fold_right bindings ~init:body' ~f:(fun (id, expr) acc -> - Me_ELet (NoRec, id, expr, acc)) - in - return @@ Me_EFun ([arg_id], body_with_bindings) - | _ -> - let rec helper acc = function - | EFun (pat, body) -> helper (acc @ pattern_remove pat) body - | expr -> - let* body = expr_to_mexpr expr in - return @@ Me_EFun (acc, body) - in - helper (pattern_remove pat) body - ) + | EFun (pat, body) -> + (match pat with + | PTuple _ | PCons _ -> + let* id_num = fresh in + let arg_id = get_new_id id_num "me" in + let arg_expr = Me_EIdentifier arg_id in + let bindings = pattern_bindings arg_expr pat in + let* body' = expr_to_mexpr body in + let body_with_bindings = + List.fold_right bindings ~init:body' ~f:(fun (id, expr) acc -> + Me_ELet (NoRec, id, expr, acc)) + in + return @@ Me_EFun ([ arg_id ], body_with_bindings) + | _ -> + let rec helper acc = function + | EFun (pat, body) -> helper (acc @ pattern_remove pat) body + | expr -> + let* body = expr_to_mexpr expr in + return @@ Me_EFun (acc, body) + in + helper (pattern_remove pat) body) | ELetIn (rec_flag, pat, e1, e2) -> let ids = pattern_remove pat in let* e1' = expr_to_mexpr e1 in @@ -131,8 +127,7 @@ and desugar_match e branches = | [] -> failwith "Empty match expression" | (pat, expr_rhs) :: rest -> let* expr_rhs' = expr_to_mexpr expr_rhs in - let rec pattern_to_condition expr pat = - match pat with + let rec pattern_to_condition expr = function | PAny -> return @@ Me_EConst (Me_CBool true) | PUnit -> return @@ -225,9 +220,7 @@ let decl_to_pe_decl decls = let tmp_var = get_new_id tmp_id_num "tmp" in let* e' = expr_to_mexpr expr in let tmp_expr = Me_EIdentifier tmp_var in - let bindings = - pattern_bindings tmp_expr pat |> List.map ~f:(fun (id, expr) -> id, expr) - in + let bindings = pattern_bindings tmp_expr pat in return ((tmp_var, e') :: bindings) in match decls with diff --git a/FML/lib/anf/me_ast.ml b/FML/lib/anf/me_ast.ml index b09ddd825..7337f5550 100644 --- a/FML/lib/anf/me_ast.ml +++ b/FML/lib/anf/me_ast.ml @@ -29,7 +29,8 @@ type me_declaration = type me_program = me_declaration list let const_to_str = function - | Me_CBool b -> if b then "true" else "false" + | Me_CBool b when b -> "true" + | Me_CBool _ -> "false" | Me_Cint i -> Format.sprintf "%i" i ;; diff --git a/FML/lib/inferencer/inferencer.ml b/FML/lib/inferencer/inferencer.ml index cd3352a43..7d0b0aad8 100644 --- a/FML/lib/inferencer/inferencer.ml +++ b/FML/lib/inferencer/inferencer.ml @@ -299,7 +299,7 @@ let annotation_to_type = | AUnit -> tunit | AFunction (l, r) -> tfunction (helper l) (helper r) | AList a -> tlist (helper a) - | ATuple a -> ttuple @@ List.map (fun x -> helper x) a + | ATuple a -> ttuple @@ List.map helper a in helper ;; @@ -309,12 +309,10 @@ let check_unique_vars = Used to detect severeal bound errors in tuple patterns, list constructor patterns. *) let rec helper var_set = function - | PIdentifier v -> - if VarSet.mem v var_set - then - (* If at least one variable is found twice, we raise an error. *) - fail (`Several_bounds v) - else return (VarSet.add v var_set) + | PIdentifier v when VarSet.mem v var_set -> + (* If at least one variable is found twice, we raise an error. *) + fail (`Several_bounds v) + | PIdentifier v -> return (VarSet.add v var_set) | PAny -> return var_set | PNill -> return var_set | PUnit -> return var_set @@ -331,10 +329,8 @@ let check_unique_vars = let check_unique_vars_list patterns = let rec helper var_set = function | [] -> return var_set - | PIdentifier name :: rest -> - if VarSet.mem name var_set - then fail (`Several_bounds name) - else helper (VarSet.add name var_set) rest + | PIdentifier name :: _ when VarSet.mem name var_set -> fail (`Several_bounds name) + | PIdentifier name :: rest -> helper (VarSet.add name var_set) rest | PAny :: rest -> helper var_set rest | PNill :: rest -> helper var_set rest | PUnit :: rest -> helper var_set rest diff --git a/FML/lib/parser/parser.ml b/FML/lib/parser/parser.ml index 6a020fa50..cc1039f65 100644 --- a/FML/lib/parser/parser.ml +++ b/FML/lib/parser/parser.ml @@ -50,7 +50,7 @@ let keyword s = skip_wspace *> string s <* skip_wspace1 let chainl1 e op = let rec go acc = lift2 (fun f x -> f acc x) op e >>= go <|> return acc in - e >>= fun init -> go init + e >>= go ;; let rec chainr1 e op = e >>= fun a -> op >>= (fun f -> chainr1 e op >>| f a) <|> return a diff --git a/FML/tests/dune b/FML/tests/dune index 1ae157fa2..94835033b 100644 --- a/FML/tests/dune +++ b/FML/tests/dune @@ -310,7 +310,6 @@ manytests/typed/015tuples.ml manytests/typed/016lists.ml)) - (cram (applies_to anf_manytest) (deps From d6cfe9ec7278ce9bffaa9d369471483faf29d039 Mon Sep 17 00:00:00 2001 From: Dmitry Pilyuk Date: Tue, 22 Apr 2025 17:49:49 +0300 Subject: [PATCH 83/92] Fixes --- FML/lib/anf/match_elimination.ml | 212 ++++++++----------- FML/lib/ast/ast.ml | 1 + FML/lib/ast/ast.mli | 1 + FML/lib/inferencer/inferencer.ml | 1 + FML/lib/parser/parser.ml | 19 +- FML/tests/a_conv_manytest.t | 2 +- FML/tests/anf_manytest.t | 281 ++++++++++++------------- FML/tests/c_conv_manytest.t | 42 +--- FML/tests/lambda_lift_manytest.t | 52 +---- FML/tests/match_elimination_manytest.t | 55 ++--- 10 files changed, 281 insertions(+), 385 deletions(-) diff --git a/FML/lib/anf/match_elimination.ml b/FML/lib/anf/match_elimination.ml index 184204c38..d252f42ba 100644 --- a/FML/lib/anf/match_elimination.ml +++ b/FML/lib/anf/match_elimination.ml @@ -15,6 +15,20 @@ let const_to_pe_const = function | CBool a -> Me_CBool a ;; +let hd_list_get expr = Me_EApp (Me_EIdentifier "hd_list_get", expr) +let tl_list_get expr = Me_EApp (Me_EIdentifier "tl_list_get", expr) + +let tuple_get expr i = + Me_EApp (Me_EApp (Me_EIdentifier "tuple_get", expr), Me_EConst (Me_Cint i)) +;; + +let is_empty expr = Me_EApp (Me_EIdentifier "is_empty", expr) +let is_cons expr = Me_EApp (Me_EIdentifier "is_cons", expr) + +let is_equal e c = + Me_EApp (Me_EApp (Me_EIdentifier "( = )", e), Me_EConst (const_to_pe_const c)) +;; + let rec pattern_remove = function | PUnit -> [ "()" ] | PAny -> [] @@ -27,26 +41,26 @@ let rec pattern_remove = function ;; let rec pattern_bindings expr = function - | PIdentifier id when String.(id <> "_") -> [ id, expr ] - | PIdentifier _ -> [] - | PAny -> [] - | PConst _ -> [] - | PUnit -> [] - | PNill -> [] + | PIdentifier id -> [ id, expr ] + | PAny | PConst _ | PUnit | PNill -> [] | PCons (hd, tl) -> - let hd_expr = Me_EApp (Me_EIdentifier "hd_list_get", expr) in - let tl_expr = Me_EApp (Me_EIdentifier "tl_list_get", expr) in - pattern_bindings hd_expr hd @ pattern_bindings tl_expr tl - | PTuple pats -> - List.mapi pats ~f:(fun i p -> - let ith_expr = - Me_EApp (Me_EApp (Me_EIdentifier "tuple_get", expr), Me_EConst (Me_Cint i)) - in - pattern_bindings ith_expr p) - |> List.concat + pattern_bindings (hd_list_get expr) hd @ pattern_bindings (tl_list_get expr) tl + | PTuple ps -> List.concat_mapi ps ~f:(fun i p -> pattern_bindings (tuple_get expr i) p) | PConstraint (p, _) -> pattern_bindings expr p ;; +let rec pattern_checks expr = function + | PNill -> [ is_empty expr ] + | PCons (h, tl) -> + [ is_cons expr ] + @ pattern_checks (hd_list_get expr) h + @ pattern_checks (tl_list_get expr) tl + | PConstraint (p, _) -> pattern_checks expr p + | PConst c -> [ is_equal expr c ] + | PUnit | PIdentifier _ | PAny -> [] + | PTuple ps -> List.concat_mapi ps ~f:(fun i p -> pattern_checks (tuple_get expr i) p) +;; + let rec_flags : Ast.rec_flag -> Me_ast.rec_flag = function | Rec -> Rec | NoRec -> NoRec @@ -62,27 +76,54 @@ let rec expr_to_mexpr = function let* f' = expr_to_mexpr f in let* arg' = expr_to_mexpr arg in return @@ Me_EApp (f', arg') - | EFun (pat, body) -> - (match pat with - | PTuple _ | PCons _ -> - let* id_num = fresh in - let arg_id = get_new_id id_num "me" in - let arg_expr = Me_EIdentifier arg_id in - let bindings = pattern_bindings arg_expr pat in - let* body' = expr_to_mexpr body in - let body_with_bindings = - List.fold_right bindings ~init:body' ~f:(fun (id, expr) acc -> - Me_ELet (NoRec, id, expr, acc)) - in - return @@ Me_EFun ([ arg_id ], body_with_bindings) - | _ -> - let rec helper acc = function - | EFun (pat, body) -> helper (acc @ pattern_remove pat) body - | expr -> - let* body = expr_to_mexpr expr in - return @@ Me_EFun (acc, body) + | EFun _ as e -> + let rev_pats, expr = + let rec helper acc = function + | EFun (pat, body) -> helper (pat :: acc) body + | expr -> acc, expr + in + helper [] e + in + let* expr = expr_to_mexpr expr in + let* args, checks, expr = + RList.fold_left + rev_pats + ~init:(return ([], [], expr)) + ~f:(fun (args, checks, expr) pat -> + let rec remove_annotations = function + | PConstraint (p, _) -> remove_annotations p + | p -> p + in + let pat = remove_annotations pat in + match pat with + | PTuple _ | PCons _ -> + let* id_num = fresh in + let arg_id = get_new_id id_num "me" in + let bindings = pattern_bindings (Me_EIdentifier arg_id) pat in + let expr = + List.fold_right bindings ~init:expr ~f:(fun (name, e) expr -> + Me_ELet (NoRec, name, e, expr)) + in + let new_checks = pattern_checks (Me_EIdentifier arg_id) pat in + return (arg_id :: args, new_checks @ checks, expr) + | PIdentifier id -> return (id :: args, checks, expr) + | PNill | PConst _ -> + let* id_num = fresh in + let arg_id = get_new_id id_num "me" in + return + (arg_id :: args, pattern_checks (Me_EIdentifier arg_id) pat @ checks, expr) + | PAny -> return ("_" :: args, checks, expr) + | PUnit -> return ("()" :: args, checks, expr) + | PConstraint _ -> return (args, checks, expr)) + in + (match checks with + | [] -> return @@ Me_EFun (args, expr) + | h :: tl -> + let check = + List.fold tl ~init:h ~f:(fun acc c -> + Me_EApp (Me_EApp (Me_EIdentifier "( && )", acc), c)) in - helper (pattern_remove pat) body) + return @@ Me_EFun (args, Me_EIf (check, expr, Me_EIdentifier "fail"))) | ELetIn (rec_flag, pat, e1, e2) -> let ids = pattern_remove pat in let* e1' = expr_to_mexpr e1 in @@ -121,91 +162,24 @@ let rec expr_to_mexpr = function return @@ Me_ECons (hd', tl') | EMatch (e, branches) -> desugar_match e branches -and desugar_match e branches = - let* e' = expr_to_mexpr e in - match branches with - | [] -> failwith "Empty match expression" - | (pat, expr_rhs) :: rest -> - let* expr_rhs' = expr_to_mexpr expr_rhs in - let rec pattern_to_condition expr = function - | PAny -> return @@ Me_EConst (Me_CBool true) - | PUnit -> - return - @@ Me_EIf - ( Me_EApp (Me_EIdentifier "is_unit", expr) - , Me_EConst (Me_CBool true) - , Me_EConst (Me_CBool false) ) - | PConst c -> - return - @@ Me_EApp (Me_EApp (Me_EIdentifier "(=)", expr), Me_EConst (const_to_pe_const c)) - | PIdentifier _ -> return @@ Me_EConst (Me_CBool true) - | PNill -> return @@ Me_EApp (Me_EIdentifier "is_empty", expr) - | PCons (hd, tl) -> - let hd_expr = Me_EApp (Me_EIdentifier "hd_list_get", expr) in - let tl_expr = Me_EApp (Me_EIdentifier "tl_list_get", expr) in - let* cond_hd = pattern_to_condition hd_expr hd in - let* cond_tl = pattern_to_condition tl_expr tl in - let is_cons_check = Me_EApp (Me_EIdentifier "is_cons", expr) in - let comb = - match cond_hd, cond_tl with - (* Если hd или tl — это PIdentifier или PAny, то if true then ... else false, что избыточно *) - | Me_EConst (Me_CBool true), Me_EConst (Me_CBool true) -> is_cons_check - | Me_EConst (Me_CBool true), cond -> - Me_EIf (is_cons_check, cond, Me_EConst (Me_CBool false)) - | cond, Me_EConst (Me_CBool true) -> - Me_EIf (is_cons_check, cond, Me_EConst (Me_CBool false)) - | cond1, cond2 -> - Me_EIf - ( is_cons_check - , Me_EIf (cond1, cond2, Me_EConst (Me_CBool false)) - , Me_EConst (Me_CBool false) ) - in - return comb - | PTuple pats -> - let* conds = - RList.fold_left - (List.mapi pats ~f:(fun i p -> i, p)) - ~init:(return []) - ~f:(fun acc (i, p) -> - let ith_expr = - Me_EApp (Me_EApp (Me_EIdentifier "tuple_get", expr), Me_EConst (Me_Cint i)) - in - let* cond = pattern_to_condition ith_expr p in - return (acc @ [ cond ])) - in - return - @@ List.fold_right conds ~init:(Me_EConst (Me_CBool true)) ~f:(fun c acc -> - Me_EIf (c, acc, Me_EConst (Me_CBool false))) - | PConstraint (p, _) -> pattern_to_condition expr p - in - let* id_num = fresh in - let tmp_var = get_new_id id_num "match_tmp" in - let bound_expr, bind_expr_opt = - match e' with - | Me_EIdentifier _ -> e', None - | _ -> Me_EIdentifier tmp_var, Some (tmp_var, e') - in - let* cond = pattern_to_condition bound_expr pat in - let bindings = pattern_bindings bound_expr pat in - let bound_rhs = - List.fold_right bindings ~init:expr_rhs' ~f:(fun (id, expr) acc -> - Me_ELet (NoRec, id, expr, acc)) +and desugar_match expr branches = + let* expr' = expr_to_mexpr expr in + List.fold_right branches ~init:(return @@ Me_EIdentifier "fail") ~f:(fun (p, e) acc -> + let check = + match pattern_checks expr' p with + | [] -> Me_EConst (Me_CBool true) + | h :: tl -> + List.fold_right tl ~init:h ~f:(fun c acc -> + Me_EApp (Me_EApp (Me_EIdentifier "( && )", acc), c)) in - let* rest_expr = - match rest with - | [] -> return @@ Me_EIdentifier "fail" - | _ -> - let new_e = - match bind_expr_opt with - | None -> e - | Some (name, _) -> EIdentifier name - in - desugar_match new_e rest + let bindings = pattern_bindings expr' p in + let* e' = expr_to_mexpr e in + let expr = + List.fold_right bindings ~init:e' ~f:(fun (name, e) acc -> + Me_ELet (NoRec, name, e, acc)) in - (match bind_expr_opt with - | None -> return @@ Me_EIf (cond, bound_rhs, rest_expr) - | Some (var, expr) -> - return @@ Me_ELet (NoRec, var, expr, Me_EIf (cond, bound_rhs, rest_expr))) + let* acc = acc in + return @@ Me_EIf (check, expr, acc)) ;; let decl_to_pe_decl decls = diff --git a/FML/lib/ast/ast.ml b/FML/lib/ast/ast.ml index 24d461fd8..fa5892ae7 100644 --- a/FML/lib/ast/ast.ml +++ b/FML/lib/ast/ast.ml @@ -18,6 +18,7 @@ type type_annotation = | AUnit | AInt | ABool + | AVar of int | AList of type_annotation | ATuple of type_annotation list | AFunction of type_annotation * type_annotation diff --git a/FML/lib/ast/ast.mli b/FML/lib/ast/ast.mli index 213c000b5..e5029a86d 100644 --- a/FML/lib/ast/ast.mli +++ b/FML/lib/ast/ast.mli @@ -18,6 +18,7 @@ type type_annotation = | AUnit (** : unit *) | AInt (** : int *) | ABool (** : bool *) + | AVar of int (** 'a *) | AList of type_annotation (** : 'a list *) | ATuple of type_annotation list (** : 'a * 'b *) | AFunction of type_annotation * type_annotation (** : 'a -> 'b *) diff --git a/FML/lib/inferencer/inferencer.ml b/FML/lib/inferencer/inferencer.ml index 7d0b0aad8..5b12f8ac1 100644 --- a/FML/lib/inferencer/inferencer.ml +++ b/FML/lib/inferencer/inferencer.ml @@ -297,6 +297,7 @@ let annotation_to_type = | AInt -> tint | ABool -> tbool | AUnit -> tunit + | AVar n -> tvar n | AFunction (l, r) -> tfunction (helper l) (helper r) | AList a -> tlist (helper a) | ATuple a -> ttuple @@ List.map helper a diff --git a/FML/lib/parser/parser.ml b/FML/lib/parser/parser.ml index cc1039f65..8a872b4c5 100644 --- a/FML/lib/parser/parser.ml +++ b/FML/lib/parser/parser.ml @@ -63,7 +63,8 @@ let parse_name = let parse_identifier constr = parse_name >>= fun name -> - if ((not @@ is_keyword name) && is_lower name.[0]) || name.[0] = '_' + if ((not @@ is_keyword name) && is_lower name.[0]) + || (name.[0] = '_' && String.length name > 1) then return @@ constr name else fail "Syntax error: invalid identifier name" ;; @@ -84,6 +85,14 @@ let parse_primitive_type = ] ;; +let parse_var_type = + parse_name + >>= fun name -> + if String.length name = 2 && name.[0] = '\'' && is_lower name.[1] + then return @@ AVar (int_of_char name.[1]) + else fail "Syntax error." +;; + let parse_list_type p_type = p_type <* token "list" >>= fun l -> return @@ AList l let parse_tuple_type p_type = @@ -97,7 +106,9 @@ let parse_function_type p_type = let parse_type = let typ = - fix @@ fun self -> choice [ parens self; parse_primitive_type; parse_list_type self ] + fix + @@ fun self -> + choice [ parens self; parse_primitive_type; parse_var_type; parse_list_type self ] in let typ = parse_tuple_type typ <|> typ in parse_function_type typ <|> typ @@ -130,7 +141,7 @@ let parse_operators = (* ------------------------ *) (* Pattern parsers*) -let parse_pany = token "_" *> skip_wspace1 >>| pany +let parse_pany = token "_" >>| pany let parse_punit = token "(" *> token ")" >>| punit let parse_pidentifier = parse_operators >>| pident <|> parse_identifier pident let parse_pconst = parse_const pconst @@ -152,11 +163,11 @@ let parse_pattern_wout_type = let patt = choice [ parens self + ; parse_pidentifier ; parse_pany ; parse_punit ; parse_pconst ; parse_pnill - ; parse_pidentifier ; parse_ptuple self ] in diff --git a/FML/tests/a_conv_manytest.t b/FML/tests/a_conv_manytest.t index b926d0cf5..2c7589d3f 100644 --- a/FML/tests/a_conv_manytest.t +++ b/FML/tests/a_conv_manytest.t @@ -18,7 +18,7 @@ (EFun ((PIdentifier "xs"), (EMatch ((EIdentifier "xs"), [(PNill, (EConst (CInt 0))); - ((PCons ((PIdentifier "_"), (PIdentifier "tl"))), + ((PCons (PAny, (PIdentifier "tl"))), (EApplication ( (EApplication ((EIdentifier "( + )"), (EConst (CInt 1)) )), diff --git a/FML/tests/anf_manytest.t b/FML/tests/anf_manytest.t index 4a0dbc524..ea1d58cbe 100644 --- a/FML/tests/anf_manytest.t +++ b/FML/tests/anf_manytest.t @@ -60,31 +60,28 @@ > | a::[] -> 1 > | [] -> 0 > EOF - let length xs = let anf1 = is_cons xs in - let anf0 = if anf1 - then let anf3 = tl_list_get xs in - let anf2 = is_cons anf3 in - if anf2 - then let anf5 = tl_list_get xs in - let anf4 = tl_list_get anf5 in - is_empty anf4 - else false - else false in + let length xs = let anf2 = tl_list_get xs in + let anf1 = is_cons anf2 in + let anf6 = tl_list_get xs in + let anf5 = tl_list_get anf6 in + let anf4 = is_empty anf5 in + let anf7 = is_cons xs in + let anf3 = ( && ) anf7 anf4 in + let anf0 = ( && ) anf3 anf1 in if anf0 then let a = hd_list_get xs in - let anf6 = tl_list_get xs in - let b = hd_list_get anf6 in + let anf8 = tl_list_get xs in + let b = hd_list_get anf8 in 2 - else let anf8 = is_cons xs in - let anf7 = if anf8 - then let anf9 = tl_list_get xs in - is_empty anf9 - else false in - if anf7 + else let anf11 = tl_list_get xs in + let anf10 = is_empty anf11 in + let anf12 = is_cons xs in + let anf9 = ( && ) anf12 anf10 in + if anf9 then let a = hd_list_get xs in 1 - else let anf10 = is_empty xs in - if anf10 + else let anf13 = is_empty xs in + if anf13 then 0 else fail ;; @@ -97,6 +94,7 @@ $ ./anf_runner.exe << EOF > let is_empty x = x+1 + > > let rec length xs = match xs with > | [] -> 0 > | _::tl -> 1 + length xs @@ -185,10 +183,10 @@ > | 12 -> 12 > | _ -> 325 > EOF - let lam_ll0 (=) x = let anf0 = (=) x 1 in + let f x = let anf0 = ( = ) x 1 in if anf0 then 12 - else let anf1 = (=) x 12 in + else let anf1 = ( = ) x 12 in if anf1 then 12 else if true @@ -196,14 +194,10 @@ else fail ;; - let f = lam_ll0 (=) - ;; - Типы до приведения в ANF: val f : int -> int Типы после приведения в ANF: - val lam_ll0 : ('a -> int -> bool) -> 'a -> int val f : int -> int $ ./anf_runner.exe < manytests/typed/001fac.ml @@ -788,137 +782,128 @@ let rec map f xs = let anf6 = is_empty xs in if anf6 then [] - else let anf8 = is_cons xs in - let anf7 = if anf8 - then let anf9 = tl_list_get xs in - is_empty anf9 - else false in + else let anf9 = tl_list_get xs in + let anf8 = is_empty anf9 in + let anf10 = is_cons xs in + let anf7 = ( && ) anf10 anf8 in if anf7 then let a = hd_list_get xs in - let anf10 = f a in - (anf10::[]) - else let anf12 = is_cons xs in - let anf11 = if anf12 - then let anf14 = tl_list_get xs in + let anf11 = f a in + (anf11::[]) + else let anf14 = tl_list_get xs in let anf13 = is_cons anf14 in - if anf13 - then let anf16 = tl_list_get xs in - let anf15 = tl_list_get anf16 in - is_empty anf15 - else false - else false in - if anf11 + let anf18 = tl_list_get xs in + let anf17 = tl_list_get anf18 in + let anf16 = is_empty anf17 in + let anf19 = is_cons xs in + let anf15 = ( && ) anf19 anf16 in + let anf12 = ( && ) anf15 anf13 in + if anf12 then let a = hd_list_get xs in - let anf17 = tl_list_get xs in - let b = hd_list_get anf17 in - let anf18 = f a in - let anf20 = f b in - let anf19 = (anf20::[]) in - (anf18::anf19) - else let anf22 = is_cons xs in - let anf21 = if anf22 - then let anf24 = tl_list_get xs in - let anf23 = is_cons anf24 in - if anf23 - then let anf27 = tl_list_get xs in - let anf26 = tl_list_get anf27 in + let anf20 = tl_list_get xs in + let b = hd_list_get anf20 in + let anf21 = f a in + let anf23 = f b in + let anf22 = (anf23::[]) in + (anf21::anf22) + else let anf26 = tl_list_get xs in let anf25 = is_cons anf26 in - if anf25 - then let anf30 = tl_list_get xs in + let anf30 = tl_list_get xs in let anf29 = tl_list_get anf30 in - let anf28 = tl_list_get anf29 in - is_empty anf28 - else false - else false - else false in - if anf21 - then let a = hd_list_get xs in - let anf31 = tl_list_get xs in - let b = hd_list_get anf31 in - let anf33 = tl_list_get xs in - let anf32 = tl_list_get anf33 in - let c = hd_list_get anf32 in - let anf34 = f a in - let anf36 = f b in - let anf38 = f c in - let anf37 = (anf38::[]) in - let anf35 = (anf36::anf37) in - (anf34::anf35) - else let anf40 = is_cons xs in - let anf39 = if anf40 - then let anf42 = tl_list_get xs in - let anf41 = is_cons anf42 in - if anf41 - then let anf45 = tl_list_get xs in - let anf44 = tl_list_get anf45 in - let anf43 = is_cons anf44 in - if anf43 - then let anf48 = tl_list_get xs in - let anf47 = tl_list_get anf48 in - let anf46 = tl_list_get anf47 in - is_cons anf46 - else false - else false - else false in - if anf39 + let anf28 = is_cons anf29 in + let anf35 = tl_list_get xs in + let anf34 = tl_list_get anf35 in + let anf33 = tl_list_get anf34 in + let anf32 = is_empty anf33 in + let anf36 = is_cons xs in + let anf31 = ( && ) anf36 anf32 in + let anf27 = ( && ) anf31 anf28 in + let anf24 = ( && ) anf27 anf25 in + if anf24 then let a = hd_list_get xs in - let anf49 = tl_list_get xs in - let b = hd_list_get anf49 in + let anf37 = tl_list_get xs in + let b = hd_list_get anf37 in + let anf39 = tl_list_get xs in + let anf38 = tl_list_get anf39 in + let c = hd_list_get anf38 in + let anf40 = f a in + let anf42 = f b in + let anf44 = f c in + let anf43 = (anf44::[]) in + let anf41 = (anf42::anf43) in + (anf40::anf41) + else let anf47 = tl_list_get xs in + let anf46 = is_cons anf47 in let anf51 = tl_list_get xs in let anf50 = tl_list_get anf51 in - let c = hd_list_get anf50 in - let anf54 = tl_list_get xs in - let anf53 = tl_list_get anf54 in - let anf52 = tl_list_get anf53 in - let d = hd_list_get anf52 in - let anf57 = tl_list_get xs in - let anf56 = tl_list_get anf57 in + let anf49 = is_cons anf50 in + let anf56 = tl_list_get xs in let anf55 = tl_list_get anf56 in - let tl = tl_list_get anf55 in - let anf58 = f a in - let anf60 = f b in - let anf62 = f c in - let anf64 = f d in - let anf65 = map f tl in - let anf63 = (anf64::anf65) in - let anf61 = (anf62::anf63) in - let anf59 = (anf60::anf61) in - (anf58::anf59) + let anf54 = tl_list_get anf55 in + let anf53 = is_cons anf54 in + let anf57 = is_cons xs in + let anf52 = ( && ) anf57 anf53 in + let anf48 = ( && ) anf52 anf49 in + let anf45 = ( && ) anf48 anf46 in + if anf45 + then let a = hd_list_get xs in + let anf58 = tl_list_get xs in + let b = hd_list_get anf58 in + let anf60 = tl_list_get xs in + let anf59 = tl_list_get anf60 in + let c = hd_list_get anf59 in + let anf63 = tl_list_get xs in + let anf62 = tl_list_get anf63 in + let anf61 = tl_list_get anf62 in + let d = hd_list_get anf61 in + let anf66 = tl_list_get xs in + let anf65 = tl_list_get anf66 in + let anf64 = tl_list_get anf65 in + let tl = tl_list_get anf64 in + let anf67 = f a in + let anf69 = f b in + let anf71 = f c in + let anf73 = f d in + let anf74 = map f tl in + let anf72 = (anf73::anf74) in + let anf70 = (anf71::anf72) in + let anf68 = (anf69::anf70) in + (anf67::anf68) else fail ;; - let rec append xs ys = let anf66 = is_empty xs in - if anf66 + let rec append xs ys = let anf75 = is_empty xs in + if anf75 then ys - else let anf67 = is_cons xs in - if anf67 + else let anf76 = is_cons xs in + if anf76 then let x = hd_list_get xs in let xs_ac0 = tl_list_get xs in - let anf68 = append xs_ac0 ys in - (x::anf68) + let anf77 = append xs_ac0 ys in + (x::anf77) else fail ;; - let rec helper_ll1 append xs = let anf69 = is_empty xs in - if anf69 + let rec helper_ll1 append xs = let anf78 = is_empty xs in + if anf78 then [] - else let anf70 = is_cons xs in - if anf70 + else let anf79 = is_cons xs in + if anf79 then let h = hd_list_get xs in let tl = tl_list_get xs in - let anf71 = helper_ll1 append tl in - append h anf71 + let anf80 = helper_ll1 append tl in + append h anf80 else fail ;; let concat = helper_ll1 append ;; - let rec iter f xs = let anf72 = is_empty xs in - if anf72 + let rec iter f xs = let anf81 = is_empty xs in + if anf81 then () - else let anf73 = is_cons xs in - if anf73 + else let anf82 = is_cons xs in + if anf82 then let h = hd_list_get xs in let tl = tl_list_get xs in let () = f h in @@ -929,33 +914,33 @@ let lam_ll2 h a = (h, a) ;; - let rec cartesian xs ys = let anf74 = is_empty xs in - if anf74 + let rec cartesian xs ys = let anf83 = is_empty xs in + if anf83 then [] - else let anf75 = is_cons xs in - if anf75 + else let anf84 = is_cons xs in + if anf84 then let h = hd_list_get xs in let tl = tl_list_get xs in - let anf76 = cartesian tl ys in - let anf78 = lam_ll2 h in - let anf77 = map anf78 ys in - append anf77 anf76 + let anf85 = cartesian tl ys in + let anf87 = lam_ll2 h in + let anf86 = map anf87 ys in + append anf86 anf85 else fail ;; - let main = let anf81 = (3::[]) in - let anf80 = (2::anf81) in - let anf79 = (1::anf80) in - let () = iter print_int anf79 in - let anf87 = (4::[]) in - let anf86 = (3::anf87) in - let anf85 = (2::anf86) in - let anf84 = (1::anf85) in - let anf89 = (2::[]) in + let main = let anf90 = (3::[]) in + let anf89 = (2::anf90) in let anf88 = (1::anf89) in - let anf83 = cartesian anf88 anf84 in - let anf82 = length anf83 in - let () = print_int anf82 in + let () = iter print_int anf88 in + let anf96 = (4::[]) in + let anf95 = (3::anf96) in + let anf94 = (2::anf95) in + let anf93 = (1::anf94) in + let anf98 = (2::[]) in + let anf97 = (1::anf98) in + let anf92 = cartesian anf97 anf93 in + let anf91 = length anf92 in + let () = print_int anf91 in 0 ;; diff --git a/FML/tests/c_conv_manytest.t b/FML/tests/c_conv_manytest.t index 4c0945caf..b0aecb14c 100644 --- a/FML/tests/c_conv_manytest.t +++ b/FML/tests/c_conv_manytest.t @@ -22,17 +22,11 @@ > | a::[] -> 1 > | [] -> 0 > EOF - let length = (fun xs -> if if (is_cons xs) - then if (is_cons (tl_list_get xs)) - then (is_empty (tl_list_get (tl_list_get xs))) - else false - else false + let length = (fun xs -> if ((( && ) ((( && ) (is_cons xs)) (is_empty (tl_list_get (tl_list_get xs))))) (is_cons (tl_list_get xs))) then let a = (hd_list_get xs) in let b = (hd_list_get (tl_list_get xs)) in 2 - else if if (is_cons xs) - then (is_empty (tl_list_get xs)) - else false + else if ((( && ) (is_cons xs)) (is_empty (tl_list_get xs))) then let a = (hd_list_get xs) in 1 else if (is_empty xs) @@ -80,13 +74,13 @@ > | 12 -> 12 > | _ -> 325 > EOF - let f = ((fun (=) x -> if (((=) x) 1) + let f = (fun x -> if ((( = ) x) 1) then 12 - else if (((=) x) 12) + else if ((( = ) x) 12) then 12 else if true then 325 - else fail) (=)) + else fail) $ ./c_conv_runner.exe < manytests/typed/001fac.ml let rec fac = (fun n -> if ((( <= ) n) 1) @@ -290,37 +284,19 @@ let rec map = (fun f xs -> if (is_empty xs) then [] - else if if (is_cons xs) - then (is_empty (tl_list_get xs)) - else false + else if ((( && ) (is_cons xs)) (is_empty (tl_list_get xs))) then let a = (hd_list_get xs) in ((f a)::[]) - else if if (is_cons xs) - then if (is_cons (tl_list_get xs)) - then (is_empty (tl_list_get (tl_list_get xs))) - else false - else false + else if ((( && ) ((( && ) (is_cons xs)) (is_empty (tl_list_get (tl_list_get xs))))) (is_cons (tl_list_get xs))) then let a = (hd_list_get xs) in let b = (hd_list_get (tl_list_get xs)) in ((f a)::((f b)::[])) - else if if (is_cons xs) - then if (is_cons (tl_list_get xs)) - then if (is_cons (tl_list_get (tl_list_get xs))) - then (is_empty (tl_list_get (tl_list_get (tl_list_get xs)))) - else false - else false - else false + else if ((( && ) ((( && ) ((( && ) (is_cons xs)) (is_empty (tl_list_get (tl_list_get (tl_list_get xs)))))) (is_cons (tl_list_get (tl_list_get xs))))) (is_cons (tl_list_get xs))) then let a = (hd_list_get xs) in let b = (hd_list_get (tl_list_get xs)) in let c = (hd_list_get (tl_list_get (tl_list_get xs))) in ((f a)::((f b)::((f c)::[]))) - else if if (is_cons xs) - then if (is_cons (tl_list_get xs)) - then if (is_cons (tl_list_get (tl_list_get xs))) - then (is_cons (tl_list_get (tl_list_get (tl_list_get xs)))) - else false - else false - else false + else if ((( && ) ((( && ) ((( && ) (is_cons xs)) (is_cons (tl_list_get (tl_list_get (tl_list_get xs)))))) (is_cons (tl_list_get (tl_list_get xs))))) (is_cons (tl_list_get xs))) then let a = (hd_list_get xs) in let b = (hd_list_get (tl_list_get xs)) in let c = (hd_list_get (tl_list_get (tl_list_get xs))) in diff --git a/FML/tests/lambda_lift_manytest.t b/FML/tests/lambda_lift_manytest.t index fe19098ed..604738f57 100644 --- a/FML/tests/lambda_lift_manytest.t +++ b/FML/tests/lambda_lift_manytest.t @@ -30,17 +30,11 @@ > | a::[] -> 1 > | [] -> 0 > EOF - let length = (fun xs -> if if (is_cons xs) - then if (is_cons (tl_list_get xs)) - then (is_empty (tl_list_get (tl_list_get xs))) - else false - else false + let length = (fun xs -> if ((( && ) ((( && ) (is_cons xs)) (is_empty (tl_list_get (tl_list_get xs))))) (is_cons (tl_list_get xs))) then let a = (hd_list_get xs) in let b = (hd_list_get (tl_list_get xs)) in 2 - else if if (is_cons xs) - then (is_empty (tl_list_get xs)) - else false + else if ((( && ) (is_cons xs)) (is_empty (tl_list_get xs))) then let a = (hd_list_get xs) in 1 else if (is_empty xs) @@ -60,17 +54,11 @@ > | a::[] -> 1 > | [] -> 0 > EOF - let length = (fun xs -> if if (is_cons xs) - then if (is_cons (tl_list_get xs)) - then (is_empty (tl_list_get (tl_list_get xs))) - else false - else false + let length = (fun xs -> if ((( && ) ((( && ) (is_cons xs)) (is_empty (tl_list_get (tl_list_get xs))))) (is_cons (tl_list_get xs))) then let a = (hd_list_get xs) in let b = (hd_list_get (tl_list_get xs)) in 2 - else if if (is_cons xs) - then (is_empty (tl_list_get xs)) - else false + else if ((( && ) (is_cons xs)) (is_empty (tl_list_get xs))) then let a = (hd_list_get xs) in 1 else if (is_empty xs) @@ -123,15 +111,13 @@ > | 12 -> 12 > | _ -> 325 > EOF - let lam_ll0 = (fun (=) x -> if (((=) x) 1) + let f = (fun x -> if ((( = ) x) 1) then 12 - else if (((=) x) 12) + else if ((( = ) x) 12) then 12 else if true then 325 else fail) - - let f = (lam_ll0 (=)) $ ./lambda_lift_runner.exe < manytests/typed/001fac.ml let rec fac = (fun n -> if ((( <= ) n) 1) @@ -377,37 +363,19 @@ let rec map = (fun f xs -> if (is_empty xs) then [] - else if if (is_cons xs) - then (is_empty (tl_list_get xs)) - else false + else if ((( && ) (is_cons xs)) (is_empty (tl_list_get xs))) then let a = (hd_list_get xs) in ((f a)::[]) - else if if (is_cons xs) - then if (is_cons (tl_list_get xs)) - then (is_empty (tl_list_get (tl_list_get xs))) - else false - else false + else if ((( && ) ((( && ) (is_cons xs)) (is_empty (tl_list_get (tl_list_get xs))))) (is_cons (tl_list_get xs))) then let a = (hd_list_get xs) in let b = (hd_list_get (tl_list_get xs)) in ((f a)::((f b)::[])) - else if if (is_cons xs) - then if (is_cons (tl_list_get xs)) - then if (is_cons (tl_list_get (tl_list_get xs))) - then (is_empty (tl_list_get (tl_list_get (tl_list_get xs)))) - else false - else false - else false + else if ((( && ) ((( && ) ((( && ) (is_cons xs)) (is_empty (tl_list_get (tl_list_get (tl_list_get xs)))))) (is_cons (tl_list_get (tl_list_get xs))))) (is_cons (tl_list_get xs))) then let a = (hd_list_get xs) in let b = (hd_list_get (tl_list_get xs)) in let c = (hd_list_get (tl_list_get (tl_list_get xs))) in ((f a)::((f b)::((f c)::[]))) - else if if (is_cons xs) - then if (is_cons (tl_list_get xs)) - then if (is_cons (tl_list_get (tl_list_get xs))) - then (is_cons (tl_list_get (tl_list_get (tl_list_get xs)))) - else false - else false - else false + else if ((( && ) ((( && ) ((( && ) (is_cons xs)) (is_cons (tl_list_get (tl_list_get (tl_list_get xs)))))) (is_cons (tl_list_get (tl_list_get xs))))) (is_cons (tl_list_get xs))) then let a = (hd_list_get xs) in let b = (hd_list_get (tl_list_get xs)) in let c = (hd_list_get (tl_list_get (tl_list_get xs))) in diff --git a/FML/tests/match_elimination_manytest.t b/FML/tests/match_elimination_manytest.t index 9d9e537a1..5a5c84973 100644 --- a/FML/tests/match_elimination_manytest.t +++ b/FML/tests/match_elimination_manytest.t @@ -1,12 +1,15 @@ $ ./match_elimination_runner.exe << EOF - > let f (x,y) = x+y;; - > let main = let () = print_int ( f (1,2) ) in 0;; + > let f (x,y) [] h::[] = x+y + h;; + > let main = let () = print_int ( f (1,2) [] [1]) in 0;; > EOF - let f = (fun me_me0 -> let x = ((tuple_get me_me0) 0) in - let y = ((tuple_get me_me0) 1) in - ((( + ) x) y)) + let f = (fun me_me2 me_me1 me_me0 -> if ((( && ) ((( && ) (is_empty me_me1)) (is_cons me_me0))) (is_empty (tl_list_get me_me0))) + then let x = ((tuple_get me_me2) 0) in + let y = ((tuple_get me_me2) 1) in + let h = (hd_list_get me_me0) in + ((( + ) ((( + ) x) y)) h) + else fail) - let main = let () = (print_int (f (1, 2))) in + let main = let () = (print_int (((f (1, 2)) []) (1::[]))) in 0 $ ./match_elimination_runner.exe << EOF @@ -21,17 +24,11 @@ > | a::[] -> 1 > | [] -> 0 > EOF - let length = (fun xs -> if if (is_cons xs) - then if (is_cons (tl_list_get xs)) - then (is_empty (tl_list_get (tl_list_get xs))) - else false - else false + let length = (fun xs -> if ((( && ) ((( && ) (is_cons xs)) (is_empty (tl_list_get (tl_list_get xs))))) (is_cons (tl_list_get xs))) then let a = (hd_list_get xs) in let b = (hd_list_get (tl_list_get xs)) in 2 - else if if (is_cons xs) - then (is_empty (tl_list_get xs)) - else false + else if ((( && ) (is_cons xs)) (is_empty (tl_list_get xs))) then let a = (hd_list_get xs) in 1 else if (is_empty xs) @@ -79,9 +76,9 @@ > | 12 -> 12 > | _ -> 325 > EOF - let f = (fun x -> if (((=) x) 1) + let f = (fun x -> if ((( = ) x) 1) then 12 - else if (((=) x) 12) + else if ((( = ) x) 12) then 12 else if true then 325 @@ -289,37 +286,19 @@ let rec map = (fun f xs -> if (is_empty xs) then [] - else if if (is_cons xs) - then (is_empty (tl_list_get xs)) - else false + else if ((( && ) (is_cons xs)) (is_empty (tl_list_get xs))) then let a = (hd_list_get xs) in ((f a)::[]) - else if if (is_cons xs) - then if (is_cons (tl_list_get xs)) - then (is_empty (tl_list_get (tl_list_get xs))) - else false - else false + else if ((( && ) ((( && ) (is_cons xs)) (is_empty (tl_list_get (tl_list_get xs))))) (is_cons (tl_list_get xs))) then let a = (hd_list_get xs) in let b = (hd_list_get (tl_list_get xs)) in ((f a)::((f b)::[])) - else if if (is_cons xs) - then if (is_cons (tl_list_get xs)) - then if (is_cons (tl_list_get (tl_list_get xs))) - then (is_empty (tl_list_get (tl_list_get (tl_list_get xs)))) - else false - else false - else false + else if ((( && ) ((( && ) ((( && ) (is_cons xs)) (is_empty (tl_list_get (tl_list_get (tl_list_get xs)))))) (is_cons (tl_list_get (tl_list_get xs))))) (is_cons (tl_list_get xs))) then let a = (hd_list_get xs) in let b = (hd_list_get (tl_list_get xs)) in let c = (hd_list_get (tl_list_get (tl_list_get xs))) in ((f a)::((f b)::((f c)::[]))) - else if if (is_cons xs) - then if (is_cons (tl_list_get xs)) - then if (is_cons (tl_list_get (tl_list_get xs))) - then (is_cons (tl_list_get (tl_list_get (tl_list_get xs)))) - else false - else false - else false + else if ((( && ) ((( && ) ((( && ) (is_cons xs)) (is_cons (tl_list_get (tl_list_get (tl_list_get xs)))))) (is_cons (tl_list_get (tl_list_get xs))))) (is_cons (tl_list_get xs))) then let a = (hd_list_get xs) in let b = (hd_list_get (tl_list_get xs)) in let c = (hd_list_get (tl_list_get (tl_list_get xs))) in From 366ac51690da9f017f742ea9104b7488e5ec569e Mon Sep 17 00:00:00 2001 From: Dmitry Pilyuk Date: Fri, 25 Apr 2025 02:40:53 +0300 Subject: [PATCH 84/92] New runtime --- FML/lib/anf/common.ml | 2 +- FML/lib/anf/match_elimination.ml | 42 +++++---- FML/lib/inferencer/inferencer.ml | 2 +- FML/lib/llvm/dune | 5 ++ FML/lib/llvm/runtime.c | 116 +++++++++++++++++++++++++ FML/tests/anf_manytest.t | 26 +++--- FML/tests/c_conv_manytest.t | 26 +++--- FML/tests/lambda_lift_manytest.t | 28 +++--- FML/tests/match_elimination_manytest.t | 28 +++--- 9 files changed, 202 insertions(+), 73 deletions(-) create mode 100644 FML/lib/llvm/dune create mode 100644 FML/lib/llvm/runtime.c diff --git a/FML/lib/anf/common.ml b/FML/lib/anf/common.ml index bff820642..0aa9beb4b 100644 --- a/FML/lib/anf/common.ml +++ b/FML/lib/anf/common.ml @@ -36,7 +36,7 @@ let builtins = ; "is_cons" ; "hd_list_get" ; "tl_list_get" - ; "fail" + ; "fail_match" ] ;; diff --git a/FML/lib/anf/match_elimination.ml b/FML/lib/anf/match_elimination.ml index d252f42ba..a711df61d 100644 --- a/FML/lib/anf/match_elimination.ml +++ b/FML/lib/anf/match_elimination.ml @@ -123,7 +123,12 @@ let rec expr_to_mexpr = function List.fold tl ~init:h ~f:(fun acc c -> Me_EApp (Me_EApp (Me_EIdentifier "( && )", acc), c)) in - return @@ Me_EFun (args, Me_EIf (check, expr, Me_EIdentifier "fail"))) + return + @@ Me_EFun + ( args + , Me_EIf + (check, expr, Me_EApp (Me_EIdentifier "fail_match", Me_EConst (Me_Cint 1))) + )) | ELetIn (rec_flag, pat, e1, e2) -> let ids = pattern_remove pat in let* e1' = expr_to_mexpr e1 in @@ -164,22 +169,25 @@ let rec expr_to_mexpr = function and desugar_match expr branches = let* expr' = expr_to_mexpr expr in - List.fold_right branches ~init:(return @@ Me_EIdentifier "fail") ~f:(fun (p, e) acc -> - let check = - match pattern_checks expr' p with - | [] -> Me_EConst (Me_CBool true) - | h :: tl -> - List.fold_right tl ~init:h ~f:(fun c acc -> - Me_EApp (Me_EApp (Me_EIdentifier "( && )", acc), c)) - in - let bindings = pattern_bindings expr' p in - let* e' = expr_to_mexpr e in - let expr = - List.fold_right bindings ~init:e' ~f:(fun (name, e) acc -> - Me_ELet (NoRec, name, e, acc)) - in - let* acc = acc in - return @@ Me_EIf (check, expr, acc)) + List.fold_right + branches + ~init:(return @@ Me_EApp (Me_EIdentifier "fail_match", Me_EConst (Me_Cint 1))) + ~f:(fun (p, e) acc -> + let check = + match pattern_checks expr' p with + | [] -> Me_EConst (Me_CBool true) + | h :: tl -> + List.fold_right tl ~init:h ~f:(fun c acc -> + Me_EApp (Me_EApp (Me_EIdentifier "( && )", acc), c)) + in + let bindings = pattern_bindings expr' p in + let* e' = expr_to_mexpr e in + let expr = + List.fold_right bindings ~init:e' ~f:(fun (name, e) acc -> + Me_ELet (NoRec, name, e, acc)) + in + let* acc = acc in + return @@ Me_EIf (check, expr, acc)) ;; let decl_to_pe_decl decls = diff --git a/FML/lib/inferencer/inferencer.ml b/FML/lib/inferencer/inferencer.ml index 5b12f8ac1..b9f9d34f6 100644 --- a/FML/lib/inferencer/inferencer.ml +++ b/FML/lib/inferencer/inferencer.ml @@ -657,7 +657,7 @@ let start_env = ; "hd_list_get", TFunction (TList (TVar 1), TVar 1) ; "tl_list_get", TFunction (TList (TVar 1), TList (TVar 1)) ; "tuple_get", TFunction (TVar 1, TFunction (TInt, TVar 2)) - ; "fail", TVar 1 + ; "fail_match", TFunction (TInt, TVar 1) ] in let env = TypeEnv.empty in diff --git a/FML/lib/llvm/dune b/FML/lib/llvm/dune new file mode 100644 index 000000000..ec09360b5 --- /dev/null +++ b/FML/lib/llvm/dune @@ -0,0 +1,5 @@ +(rule + (targets runtime.a) + (deps runtime.c) + (action + (run clang-16 -c runtime.c -o %{targets}))) diff --git a/FML/lib/llvm/runtime.c b/FML/lib/llvm/runtime.c new file mode 100644 index 000000000..149a4fd30 --- /dev/null +++ b/FML/lib/llvm/runtime.c @@ -0,0 +1,116 @@ +#include +#include +#include +#include +#include + +int64_t print_int(int64_t x) +{ + printf("%ld\n", x); + return 0; +} + +int64_t fail_match(int64_t err) +{ + fprintf(stderr, "Match failure\n"); + exit(err); +} + +int64_t rt_add(int64_t x, int64_t y) { return x + y; } +int64_t rt_sub(int64_t x, int64_t y) { return x - y; } +int64_t rt_mul(int64_t x, int64_t y) { return x * y; } +int64_t rt_divd(int64_t x, int64_t y) { return x / y; } +int64_t rt_eq(int64_t x, int64_t y) { return x == y; } +int64_t rt_neq(int64_t x, int64_t y) { return x != y; } +int64_t rt_less(int64_t x, int64_t y) { return x < y; } +int64_t rt_leq(int64_t x, int64_t y) { return x <= y; } +int64_t rt_gre(int64_t x, int64_t y) { return x > y; } +int64_t rt_geq(int64_t x, int64_t y) { return x >= y; } +int64_t rt_and(int64_t x, int64_t y) { return x && y; } +int64_t rt_or(int64_t x, int64_t y) { return x || y; } + +typedef struct +{ + int64_t fun_ptr; + int64_t args_num; + int64_t args_applied; + int64_t args[]; +} closure_t; + +int64_t +new_closure(int64_t f_ptr, int64_t args_num) +{ + closure_t *closure = malloc(sizeof(closure_t) + args_num * sizeof(int64_t)); + closure->fun_ptr = f_ptr; + closure->args_num = args_num; + closure->args_applied = 0; + return (int64_t)closure; +} + +int64_t call_closure(closure_t *closure) +{ + int64_t args_n = closure->args_num; + ffi_cif cif; + ffi_type *args_types[args_n]; + void *args[args_n]; + for (int64_t i = 0; i < args_n; i++) + { + args_types[i] = &ffi_type_sint64; + args[i] = &closure->args[i]; + } + + if (ffi_prep_cif(&cif, FFI_DEFAULT_ABI, 2, &ffi_type_sint64, args_types) != FFI_OK) + { + fprintf(stderr, "Failed to prepare CIF\n"); + exit(1); + }; + + int64_t res; + + ffi_call(&cif, (void *)closure->fun_ptr, &res, args); + + return res; +} + +int64_t _apply(closure_t *closure, int new_args_num, va_list *args) +{ + int64_t args_to_apply = closure->args_num - closure->args_applied; + + if (new_args_num < args_to_apply) + { + for (int64_t i = 0; i < new_args_num; i++) + { + int64_t arg = va_arg(*args, int64_t); + closure->args[closure->args_applied + i] = arg; + closure->args_applied += new_args_num; + } + return (int64_t)closure; + } + else + { + for (int64_t i = 0; i < args_to_apply; i++) + { + int64_t arg = va_arg(*args, int64_t); + closure->args[closure->args_applied + i] = arg; + } + + int64_t res = call_closure(closure); + new_args_num -= args_to_apply; + free(closure); + if (new_args_num == 0) + { + return res; + } + closure = (closure_t *)res; + return _apply(closure, new_args_num, args); + } +} + +int64_t apply(closure_t *closure, int new_args_num, ...) +{ + va_list args; + va_start(args, new_args_num); + + return _apply(closure, new_args_num, &args); + va_end(args); +} diff --git a/FML/tests/anf_manytest.t b/FML/tests/anf_manytest.t index ea1d58cbe..957449b9f 100644 --- a/FML/tests/anf_manytest.t +++ b/FML/tests/anf_manytest.t @@ -83,7 +83,7 @@ else let anf13 = is_empty xs in if anf13 then 0 - else fail + else fail_match 1 ;; Типы до приведения в ANF: @@ -110,7 +110,7 @@ then let tl = tl_list_get xs in let anf2 = length xs in ( + ) 1 anf2 - else fail + else fail_match 1 ;; Типы до приведения в ANF: @@ -191,7 +191,7 @@ then 12 else if true then 325 - else fail + else fail_match 1 ;; Типы до приведения в ANF: @@ -526,7 +526,7 @@ let tl = tl_list_get xs in let anf4 = lam_ll0 f h k in map f tl anf4 - else fail + else fail_match 1 ;; let rec iter f xs = let anf5 = is_empty xs in @@ -538,7 +538,7 @@ let tl = tl_list_get xs in let w = f h in iter f tl - else fail + else fail_match 1 ;; let lam_ll1 x = ( + ) x 1 @@ -614,7 +614,7 @@ let tl = tl_list_get xs in let anf2 = fold_right f acc tl in f h anf2 - else fail + else fail_match 1 ;; let lam_ll1 f b g x = let anf3 = f x b in @@ -761,7 +761,7 @@ let tl = tl_list_get xs in let anf2 = length tl in ( + ) 1 anf2 - else fail + else fail_match 1 ;; let rec helper_ll0 acc xs = let anf3 = is_empty xs in @@ -773,7 +773,7 @@ let tl = tl_list_get xs in let anf5 = ( + ) acc 1 in helper_ll0 anf5 tl - else fail + else fail_match 1 ;; let length_tail = helper_ll0 0 @@ -869,7 +869,7 @@ let anf70 = (anf71::anf72) in let anf68 = (anf69::anf70) in (anf67::anf68) - else fail + else fail_match 1 ;; let rec append xs ys = let anf75 = is_empty xs in @@ -881,7 +881,7 @@ let xs_ac0 = tl_list_get xs in let anf77 = append xs_ac0 ys in (x::anf77) - else fail + else fail_match 1 ;; let rec helper_ll1 append xs = let anf78 = is_empty xs in @@ -893,7 +893,7 @@ let tl = tl_list_get xs in let anf80 = helper_ll1 append tl in append h anf80 - else fail + else fail_match 1 ;; let concat = helper_ll1 append @@ -908,7 +908,7 @@ let tl = tl_list_get xs in let () = f h in iter f tl - else fail + else fail_match 1 ;; let lam_ll2 h a = (h, a) @@ -925,7 +925,7 @@ let anf87 = lam_ll2 h in let anf86 = map anf87 ys in append anf86 anf85 - else fail + else fail_match 1 ;; let main = let anf90 = (3::[]) in diff --git a/FML/tests/c_conv_manytest.t b/FML/tests/c_conv_manytest.t index b0aecb14c..52eef2ea4 100644 --- a/FML/tests/c_conv_manytest.t +++ b/FML/tests/c_conv_manytest.t @@ -31,7 +31,7 @@ 1 else if (is_empty xs) then 0 - else fail) + else (fail_match 1)) $ ./c_conv_runner.exe << EOF > let is_empty x = x+1 @@ -46,7 +46,7 @@ else if (is_cons xs) then let tl = (tl_list_get xs) in ((( + ) 1) (length xs)) - else fail) + else (fail_match 1)) $ ./c_conv_runner.exe << EOF > let (a, b) = (5,6) @@ -80,7 +80,7 @@ then 12 else if true then 325 - else fail) + else (fail_match 1)) $ ./c_conv_runner.exe < manytests/typed/001fac.ml let rec fac = (fun n -> if ((( <= ) n) 1) @@ -193,7 +193,7 @@ then let h = (hd_list_get xs) in let tl = (tl_list_get xs) in (((map f) tl) ((((fun f h k tl_ac0 -> (k ((f h)::tl_ac0))) f) h) k)) - else fail) + else (fail_match 1)) let rec iter = (fun f xs -> if (is_empty xs) then () @@ -202,7 +202,7 @@ let tl = (tl_list_get xs) in let w = (f h) in ((iter f) tl) - else fail) + else (fail_match 1)) let main = ((iter print_int) (((map (fun x -> ((( + ) x) 1))) (1::(2::(3::[])))) (fun x -> x))) $ ./c_conv_runner.exe < manytests/typed/012fibcps.ml @@ -220,7 +220,7 @@ then let h = (hd_list_get xs) in let tl = (tl_list_get xs) in ((f h) (((fold_right f) acc) tl)) - else fail) + else (fail_match 1)) let foldl = ((fun fold_right f a bs -> ((((fold_right ((fun f b g x -> (g ((f x) b))) f)) id) bs) a)) fold_right) @@ -271,7 +271,7 @@ then let h = (hd_list_get xs) in let tl = (tl_list_get xs) in ((( + ) 1) (length tl)) - else fail) + else (fail_match 1)) let length_tail = let rec helper = (fun acc xs -> if (is_empty xs) then acc @@ -279,7 +279,7 @@ then let h = (hd_list_get xs) in let tl = (tl_list_get xs) in ((helper ((( + ) acc) 1)) tl) - else fail) in + else (fail_match 1)) in (helper 0) let rec map = (fun f xs -> if (is_empty xs) @@ -303,7 +303,7 @@ let d = (hd_list_get (tl_list_get (tl_list_get (tl_list_get xs)))) in let tl = (tl_list_get (tl_list_get (tl_list_get (tl_list_get xs)))) in ((f a)::((f b)::((f c)::((f d)::((map f) tl))))) - else fail) + else (fail_match 1)) let rec append = (fun xs ys -> if (is_empty xs) then ys @@ -311,7 +311,7 @@ then let x = (hd_list_get xs) in let xs_ac0 = (tl_list_get xs) in (x::((append xs_ac0) ys)) - else fail) + else (fail_match 1)) let concat = let rec helper = (fun append xs -> if (is_empty xs) then [] @@ -319,7 +319,7 @@ then let h = (hd_list_get xs) in let tl = (tl_list_get xs) in ((append h) ((helper append) tl)) - else fail) in + else (fail_match 1)) in (helper append) let rec iter = (fun f xs -> if (is_empty xs) @@ -329,7 +329,7 @@ let tl = (tl_list_get xs) in let () = (f h) in ((iter f) tl) - else fail) + else (fail_match 1)) let rec cartesian = (fun xs ys -> if (is_empty xs) then [] @@ -337,7 +337,7 @@ then let h = (hd_list_get xs) in let tl = (tl_list_get xs) in ((append ((map ((fun h a -> (h, a)) h)) ys)) ((cartesian tl) ys)) - else fail) + else (fail_match 1)) let main = let () = ((iter print_int) (1::(2::(3::[])))) in let () = (print_int (length ((cartesian (1::(2::[]))) (1::(2::(3::(4::[]))))))) in diff --git a/FML/tests/lambda_lift_manytest.t b/FML/tests/lambda_lift_manytest.t index 604738f57..1a681f06e 100644 --- a/FML/tests/lambda_lift_manytest.t +++ b/FML/tests/lambda_lift_manytest.t @@ -39,7 +39,7 @@ 1 else if (is_empty xs) then 0 - else fail) + else (fail_match 1)) $ ./lambda_lift_runner.exe << EOF > let f = let y x = x + 1 in y 3;; @@ -63,7 +63,7 @@ 1 else if (is_empty xs) then 0 - else fail) + else (fail_match 1)) $ ./lambda_lift_runner.exe << EOF > let is_empty x = x+1 @@ -78,7 +78,7 @@ else if (is_cons xs) then let tl = (tl_list_get xs) in ((( + ) 1) (length xs)) - else fail) + else (fail_match 1)) $ ./lambda_lift_runner.exe << EOF > let (a, b) = (5,6) @@ -117,7 +117,7 @@ then 12 else if true then 325 - else fail) + else (fail_match 1)) $ ./lambda_lift_runner.exe < manytests/typed/001fac.ml let rec fac = (fun n -> if ((( <= ) n) 1) @@ -249,7 +249,7 @@ then let h = (hd_list_get xs) in let tl = (tl_list_get xs) in (((map f) tl) (((lam_ll0 f) h) k)) - else fail) + else (fail_match 1)) let rec iter = (fun f xs -> if (is_empty xs) then () @@ -258,7 +258,7 @@ let tl = (tl_list_get xs) in let w = (f h) in ((iter f) tl) - else fail) + else (fail_match 1)) let lam_ll1 = (fun x -> ((( + ) x) 1)) @@ -286,7 +286,7 @@ then let h = (hd_list_get xs) in let tl = (tl_list_get xs) in ((f h) (((fold_right f) acc) tl)) - else fail) + else (fail_match 1)) let lam_ll1 = (fun f b g x -> (g ((f x) b))) @@ -349,7 +349,7 @@ then let h = (hd_list_get xs) in let tl = (tl_list_get xs) in ((( + ) 1) (length tl)) - else fail) + else (fail_match 1)) let rec helper_ll0 = (fun acc xs -> if (is_empty xs) then acc @@ -357,7 +357,7 @@ then let h = (hd_list_get xs) in let tl = (tl_list_get xs) in ((helper_ll0 ((( + ) acc) 1)) tl) - else fail) + else (fail_match 1)) let length_tail = (helper_ll0 0) @@ -382,7 +382,7 @@ let d = (hd_list_get (tl_list_get (tl_list_get (tl_list_get xs)))) in let tl = (tl_list_get (tl_list_get (tl_list_get (tl_list_get xs)))) in ((f a)::((f b)::((f c)::((f d)::((map f) tl))))) - else fail) + else (fail_match 1)) let rec append = (fun xs ys -> if (is_empty xs) then ys @@ -390,7 +390,7 @@ then let x = (hd_list_get xs) in let xs_ac0 = (tl_list_get xs) in (x::((append xs_ac0) ys)) - else fail) + else (fail_match 1)) let rec helper_ll1 = (fun append xs -> if (is_empty xs) then [] @@ -398,7 +398,7 @@ then let h = (hd_list_get xs) in let tl = (tl_list_get xs) in ((append h) ((helper_ll1 append) tl)) - else fail) + else (fail_match 1)) let concat = (helper_ll1 append) @@ -409,7 +409,7 @@ let tl = (tl_list_get xs) in let () = (f h) in ((iter f) tl) - else fail) + else (fail_match 1)) let lam_ll2 = (fun h a -> (h, a)) @@ -419,7 +419,7 @@ then let h = (hd_list_get xs) in let tl = (tl_list_get xs) in ((append ((map (lam_ll2 h)) ys)) ((cartesian tl) ys)) - else fail) + else (fail_match 1)) let main = let () = ((iter print_int) (1::(2::(3::[])))) in let () = (print_int (length ((cartesian (1::(2::[]))) (1::(2::(3::(4::[]))))))) in diff --git a/FML/tests/match_elimination_manytest.t b/FML/tests/match_elimination_manytest.t index 5a5c84973..419f437d5 100644 --- a/FML/tests/match_elimination_manytest.t +++ b/FML/tests/match_elimination_manytest.t @@ -7,7 +7,7 @@ let y = ((tuple_get me_me2) 1) in let h = (hd_list_get me_me0) in ((( + ) ((( + ) x) y)) h) - else fail) + else (fail_match 1)) let main = let () = (print_int (((f (1, 2)) []) (1::[]))) in 0 @@ -33,7 +33,7 @@ 1 else if (is_empty xs) then 0 - else fail) + else (fail_match 1)) $ ./match_elimination_runner.exe << EOF > let is_empty x = x+1 @@ -48,7 +48,7 @@ else if (is_cons xs) then let tl = (tl_list_get xs) in ((( + ) 1) (length xs)) - else fail) + else (fail_match 1)) $ ./match_elimination_runner.exe << EOF > let (a, b) = (5,6) @@ -82,7 +82,7 @@ then 12 else if true then 325 - else fail) + else (fail_match 1)) $ ./match_elimination_runner.exe < manytests/typed/001fac.ml let rec fac = (fun n -> if ((( <= ) n) 1) @@ -195,7 +195,7 @@ then let h = (hd_list_get xs) in let tl = (tl_list_get xs) in (((map f) tl) (fun tl_ac0 -> (k ((f h)::tl_ac0)))) - else fail) + else (fail_match 1)) let rec iter = (fun f xs -> if (is_empty xs) then () @@ -204,7 +204,7 @@ let tl = (tl_list_get xs) in let w = (f h) in ((iter f) tl) - else fail) + else (fail_match 1)) let main = ((iter print_int) (((map (fun x -> ((( + ) x) 1))) (1::(2::(3::[])))) (fun x -> x))) $ ./match_elimination_runner.exe < manytests/typed/012fibcps.ml @@ -222,7 +222,7 @@ then let h = (hd_list_get xs) in let tl = (tl_list_get xs) in ((f h) (((fold_right f) acc) tl)) - else fail) + else (fail_match 1)) let foldl = (fun f a bs -> ((((fold_right (fun b g x -> (g ((f x) b)))) id) bs) a)) @@ -273,7 +273,7 @@ then let h = (hd_list_get xs) in let tl = (tl_list_get xs) in ((( + ) 1) (length tl)) - else fail) + else (fail_match 1)) let length_tail = let rec helper = (fun acc xs -> if (is_empty xs) then acc @@ -281,7 +281,7 @@ then let h = (hd_list_get xs) in let tl = (tl_list_get xs) in ((helper ((( + ) acc) 1)) tl) - else fail) in + else (fail_match 1)) in (helper 0) let rec map = (fun f xs -> if (is_empty xs) @@ -305,7 +305,7 @@ let d = (hd_list_get (tl_list_get (tl_list_get (tl_list_get xs)))) in let tl = (tl_list_get (tl_list_get (tl_list_get (tl_list_get xs)))) in ((f a)::((f b)::((f c)::((f d)::((map f) tl))))) - else fail) + else (fail_match 1)) let rec append = (fun xs ys -> if (is_empty xs) then ys @@ -313,7 +313,7 @@ then let x = (hd_list_get xs) in let xs_ac0 = (tl_list_get xs) in (x::((append xs_ac0) ys)) - else fail) + else (fail_match 1)) let concat = let rec helper = (fun xs -> if (is_empty xs) then [] @@ -321,7 +321,7 @@ then let h = (hd_list_get xs) in let tl = (tl_list_get xs) in ((append h) (helper tl)) - else fail) in + else (fail_match 1)) in helper let rec iter = (fun f xs -> if (is_empty xs) @@ -331,7 +331,7 @@ let tl = (tl_list_get xs) in let () = (f h) in ((iter f) tl) - else fail) + else (fail_match 1)) let rec cartesian = (fun xs ys -> if (is_empty xs) then [] @@ -339,7 +339,7 @@ then let h = (hd_list_get xs) in let tl = (tl_list_get xs) in ((append ((map (fun a -> (h, a))) ys)) ((cartesian tl) ys)) - else fail) + else (fail_match 1)) let main = let () = ((iter print_int) (1::(2::(3::[])))) in let () = (print_int (length ((cartesian (1::(2::[]))) (1::(2::(3::(4::[]))))))) in From 7793a883f3b966160696eee638c390f709544506 Mon Sep 17 00:00:00 2001 From: Dmitry Pilyuk Date: Mon, 28 Apr 2025 02:41:24 +0300 Subject: [PATCH 85/92] Codegen --- FML/bin/bitecode.t | 50 +++++----- FML/bin/compiler.ml | 14 +-- FML/bin/dune | 31 ++++++ FML/lib/dune | 3 +- FML/lib/llvm/gen.ml | 215 +++++++++++++++++++++++++++++++++++++++++ FML/lib/llvm/runtime.c | 4 +- 6 files changed, 282 insertions(+), 35 deletions(-) create mode 100644 FML/lib/llvm/gen.ml diff --git a/FML/bin/bitecode.t b/FML/bin/bitecode.t index 48b4f2555..6bb22187c 100644 --- a/FML/bin/bitecode.t +++ b/FML/bin/bitecode.t @@ -4,7 +4,7 @@ source_filename = "FML" target triple = "x86_64-pc-linux-gnu" - declare i64 @create_closure(i64, i64, i64) + declare i64 @new_closure(i64, i64) declare i64 @apply_args(i64, i64, i64, ...) @@ -65,12 +65,27 @@ } $ ./compiler.exe < manytests/typed/002fac.ml + Fatal error: exception Invalid_argument("option is None") + Raised at Stdlib.invalid_arg in file "stdlib.ml" (inlined), line 30, characters 20-45 + Called from Stdlib__Option.get in file "option.ml", line 21, characters 41-69 + Called from Fml_lib__Gen.compile_immexpr in file "lib/llvm/gen.ml", line 48, characters 9-65 + Called from Fml_lib__Gen.compile_cexpr in file "lib/llvm/gen.ml", line 108, characters 15-51 + Called from Fml_lib__Gen.compile_aexpr in file "lib/llvm/gen.ml", line 146, characters 12-31 + Called from Fml_lib__Gen.compile_cexpr in file "lib/llvm/gen.ml", line 128, characters 16-36 + Called from Fml_lib__Gen.compile_anf_binding in file "lib/llvm/gen.ml", line 167, characters 17-35 + Called from Fml_lib__Gen.compile_anf_decl.(fun) in file "lib/llvm/gen.ml", line 177, characters 37-66 + Called from Stdlib__List.iter in file "list.ml", line 110, characters 12-15 + Called from Fml_lib__Gen.create_main.(fun) in file "lib/llvm/gen.ml", line 209, characters 32-55 + Called from Stdlib__List.iter in file "list.ml", line 110, characters 12-15 + Called from Fml_lib__Gen.compile_program in file "lib/llvm/gen.ml", line 213, characters 10-29 + Called from Dune__exe__Compiler in file "bin/compiler.ml", line 24, characters 4-31 + [2] $ cat < out.ll ; ModuleID = 'FML' source_filename = "FML" target triple = "x86_64-pc-linux-gnu" - declare i64 @create_closure(i64, i64, i64) + declare i64 @new_closure(i64, i64) declare i64 @apply_args(i64, i64, i64, ...) @@ -102,45 +117,30 @@ declare i64 @fail_match(i64) - define i64 @a1(i64 %k, i64 %n, i64 %p) { - entry: - %mul = mul i64 %p, %n - %applied_closure = call i64 (i64, i64, ...) @apply_args(i64 %k, i64 1, i64 %mul) - ret i64 %applied_closure - } - - define i64 @fac_cps(i64 %n, i64 %k) { + define i64 @fac(i64 %n) { entry: - %eq = icmp eq i64 %n, 1 - %eq_i64t = zext i1 %eq to i64 - %cond_v = icmp ne i64 %eq_i64t, 0 + %sle = icmp sle i64 %n, 1 + %sle_i64t = zext i1 %sle to i64 + %cond_v = icmp ne i64 %sle_i64t, 0 br i1 %cond_v, label %then, label %else then: ; preds = %entry - %applied_closure = call i64 (i64, i64, ...) @apply_args(i64 %k, i64 1, i64 1) br label %merge else: ; preds = %entry - %empty_closure = call i64 @create_closure(i64 ptrtoint (ptr @a1 to i64), i64 3, i64 0) - %applied_closure1 = call i64 (i64, i64, ...) @apply_args(i64 %empty_closure, i64 2, i64 %k, i64 %n) %sub = sub i64 %n, 1 - %call = call i64 @fac_cps(i64 %sub, i64 %applied_closure1) + %call = call i64 @fac(i64 %sub) + %mul = mul i64 %n, %call br label %merge merge: ; preds = %else, %then - %phi = phi i64 [ %applied_closure, %then ], [ %call, %else ] + %phi = phi i64 [ 1, %then ], [ %mul, %else ] ret i64 %phi } - define i64 @a2(i64 %a0) { - entry: - ret i64 %a0 - } - define i64 @main() { entry: - %empty_closure = call i64 @create_closure(i64 ptrtoint (ptr @a2 to i64), i64 1, i64 0) - %call = call i64 @fac_cps(i64 4, i64 %empty_closure) + %call = call i64 @fac(i64 4) %call1 = call i64 @print_int(i64 %call) ret i64 0 } diff --git a/FML/bin/compiler.ml b/FML/bin/compiler.ml index fccde0bd0..7cded9e95 100644 --- a/FML/bin/compiler.ml +++ b/FML/bin/compiler.ml @@ -11,16 +11,16 @@ let () = | Ok parsed -> (match Inferencer.run_program_inferencer parsed with | Ok types -> Ok (parsed, types) - | Error _ -> Error (Format.asprintf "Infer error.")) + | Error _ -> Error (Format.asprintf "Infer error:")) | Error e -> Error (Format.sprintf "Parsing error: %s" e) in match parse_and_infer input with | Ok (ast, _) -> - let bind, cnt, ast = Pattern_elim.run_pe ast in - let bind, cnt, ast = Alpha_conv.run_alpha_conv bind cnt ast in - let ast = Closure_conv.run_cc ast in - let bind, cnt, ast = Lambda_lifting.run_ll bind cnt ast in - let _, _, ast = Anf.run_anf bind cnt ast in - Codegen.compile_program ast + let ast = A_conv.ac_program ast in + let ast_me = Match_elimination.match_elimination ast in + let ast_cc = C_conv.cc_program ast_me in + let ast_ll = Lambda_lift.lambda_lift ast_cc in + let ast_anf = Anf.anf ast_ll in + Gen.compile_program ast_anf | Error message -> Format.printf "%s" message ;; diff --git a/FML/bin/dune b/FML/bin/dune index e69de29bb..a806727ae 100644 --- a/FML/bin/dune +++ b/FML/bin/dune @@ -0,0 +1,31 @@ +(executable + (name compiler) + (public_name compliler) + (modules compiler) + (libraries fml_lib stdio)) + +(cram + (applies_to bitecode) + (deps + ./compiler.exe + manytests/do_not_type/001.ml + manytests/do_not_type/002if.ml + manytests/do_not_type/003occurs.ml + manytests/do_not_type/004let_poly.ml + manytests/do_not_type/015tuples.ml + manytests/typed/001fac.ml + manytests/typed/002fac.ml + manytests/typed/003fib.ml + manytests/typed/004manyargs.ml + manytests/typed/005fix.ml + manytests/typed/006partial.ml + manytests/typed/006partial2.ml + manytests/typed/006partial3.ml + manytests/typed/007order.ml + manytests/typed/008ascription.ml + manytests/typed/009let_poly.ml + manytests/typed/011mapcps.ml + manytests/typed/012fibcps.ml + manytests/typed/013foldfoldr.ml + manytests/typed/015tuples.ml + manytests/typed/016lists.ml)) diff --git a/FML/lib/dune b/FML/lib/dune index f14d6721c..61829eddd 100644 --- a/FML/lib/dune +++ b/FML/lib/dune @@ -17,7 +17,8 @@ Match_elimination Anf_ast Anf - Lambda_lift) + Lambda_lift + Gen) (modules_without_implementation inf_errors) (libraries base angstrom llvm llvm.analysis llvm.executionengine) (preprocess diff --git a/FML/lib/llvm/gen.ml b/FML/lib/llvm/gen.ml new file mode 100644 index 000000000..25d3b2a3f --- /dev/null +++ b/FML/lib/llvm/gen.ml @@ -0,0 +1,215 @@ +(** Copyright 2024-2025, Dmitry Pilyuk, Aleksandr Rozhkov *) + +(** SPDX-License-Identifier: LGPL-2.1 *) + +open Llvm +open Anf_ast + +let sym_to_value : (string, llvalue) Hashtbl.t = Hashtbl.create 10 +let sym_to_type : (string, lltype) Hashtbl.t = Hashtbl.create 10 +let lookup_name name = Hashtbl.find_opt sym_to_value name +let lookup_type name = Hashtbl.find_opt sym_to_type name +let add_sym name value = Hashtbl.add sym_to_value name value +let add_type name ty = Hashtbl.add sym_to_type name ty +let ctx = global_context () +let builder = builder ctx +let module_ = create_module ctx "FML" +let target_triple = Llvm_target.Target.default_triple () +let () = Llvm.set_target_triple target_triple module_ +let i64_t = i64_type ctx + +let get_rt_name = function + | "( + )" -> "rt_add" + | "( - )" -> "rt_sub" + | "( * )" -> "rt_mul" + | "( / )" -> "rt_divd" + | "( = )" -> "rt_eq" + | "( != )" -> "rt_neq" + | "( < )" -> "rt_less" + | "( <= )" -> "rt_leq" + | "( > )" -> "rt_gre" + | "( >= )" -> "rt_geq" + | "( && )" -> "rt_and" + | "( || )" -> "rt_or" + | other -> other +;; + +let compile_immexpr = function + | ImmInt n -> const_int i64_t n + | ImmBool b -> const_int i64_t (Bool.to_int b) + | ImmUnit -> const_int i64_t 0 + | ImmIdentifier name -> + let name = get_rt_name name in + (match lookup_function name module_ with + | Some f -> + let fun_ptr = build_ptrtoint f i64_t "" builder in + build_call + (function_type i64_t [| i64_t; i64_t |]) + (Option.get @@ lookup_function "create_closure" module_) + [| fun_ptr; const_int i64_t (Array.length (params f)); const_int i64_t 0 |] + "empty_closure" + builder + | None -> + (match lookup_global name module_ with + | Some g -> g + | None -> + (match lookup_name name with + | Some v -> v + | None -> failwith ("Unknown variable: " ^ name)))) + | _ -> failwith "Not_implemented" +;; + +let is_binop = function + | "( + )" + | "( - )" + | "( * )" + | "( / )" + | "( = )" + | "( == )" + | "( <> )" + | "( != )" + | "( > )" + | "( >= )" + | "( < )" + | "( <= )" -> true + | _ -> false +;; + +let compile_binop op x y = + match op with + | "( + )" -> build_add x y "add" builder + | "( - )" -> build_sub x y "sub" builder + | "( * )" -> build_mul x y "mul" builder + | "( / )" -> build_sdiv x y "div" builder + | "( = )" | "( == )" -> + build_zext (build_icmp Icmp.Eq x y "eq" builder) i64_t "eq_i64t" builder + | "( <> )" | "( != )" -> + build_zext (build_icmp Icmp.Ne x y "ne" builder) i64_t "ne_i64t" builder + | "( > )" -> build_zext (build_icmp Icmp.Sgt x y "sgt" builder) i64_t "sgt_i64t" builder + | "( >= )" -> + build_zext (build_icmp Icmp.Sge x y "sge" builder) i64_t "sge_i64t" builder + | "( < )" -> build_zext (build_icmp Icmp.Slt x y "slt" builder) i64_t "slt_i64t" builder + | "( <= )" -> + build_zext (build_icmp Icmp.Sle x y "sle" builder) i64_t "sle_i64t" builder + | _ -> failwith ("Invalid operator: " ^ op) +;; + +let rec compile_cexpr = function + | CImmExpr imm -> compile_immexpr imm + | CEApply (name, [ arg1; arg2 ]) when is_binop name -> + compile_binop name (compile_immexpr arg1) (compile_immexpr arg2) + | CEApply (name, args) -> + let compiled_args = List.map compile_immexpr args in + (match lookup_function name module_ with + | Some f when Array.length (params f) = List.length args -> + let func_type = function_type i64_t (Array.make (List.length args) i64_t) in + build_call func_type f (Array.of_list compiled_args) "call" builder + | _ -> + let f = compile_immexpr (ImmIdentifier name) in + build_call + (var_arg_function_type i64_t [| i64_t; i64_t |]) + (Option.get (lookup_function "apply_args" module_)) + (Array.of_list + ([ f; const_int i64_t (List.length compiled_args) ] @ compiled_args)) + "applied_closure" + builder) + | CEIf (cond, then_e, else_e) -> + let cond_v = + build_icmp Icmp.Ne (compile_immexpr cond) (const_int i64_t 0) "cond_v" builder + in + let entry_block = insertion_block builder in + let parent = block_parent entry_block in + let then_block = append_block ctx "then" parent in + position_at_end then_block builder; + let then_ = compile_aexpr then_e in + let new_then_block = insertion_block builder in + let else_block = append_block ctx "else" parent in + position_at_end else_block builder; + let else_ = compile_aexpr else_e in + let new_else_block = insertion_block builder in + let merge_bb = append_block ctx "merge" parent in + position_at_end merge_bb builder; + let phi = build_phi [ then_, new_then_block; else_, new_else_block ] "phi" builder in + position_at_end entry_block builder; + let (_ : llvalue) = build_cond_br cond_v then_block else_block builder in + position_at_end new_then_block builder; + let (_ : llvalue) = build_br merge_bb builder in + position_at_end new_else_block builder; + let (_ : llvalue) = build_br merge_bb builder in + position_at_end merge_bb builder; + phi + | _ -> failwith "Not implemented" + +and compile_aexpr = function + | ACExpr e -> compile_cexpr e + | ALetIn (name, cexpr, aexpr) -> + let v = compile_cexpr cexpr in + add_sym name v; + compile_aexpr aexpr +;; + +let declare_func name args = + let arg_types = Array.make (List.length args) i64_t in + let func_type = function_type i64_t arg_types in + declare_function name func_type module_ +;; + +let compile_anf_binding (ALet (name, args, body)) = + let func = declare_func name args in + let bb = append_block ctx "entry" func in + position_at_end bb builder; + List.iteri + (fun i arg_name -> + let arg_value = param func i in + set_value_name arg_name arg_value; + add_sym arg_name arg_value) + args; + let body_val = compile_aexpr body in + let _ = build_ret body_val builder in + ignore func +;; + +let compile_anf_decl = function + | ADNoRec bindings -> + List.iter (fun binding -> ignore (compile_anf_binding binding)) bindings + | ADRec bindings -> + List.iter (fun (ALet (name, args, _)) -> ignore (declare_func name args)) bindings; + List.iter (fun binding -> ignore (compile_anf_binding binding)) bindings + | Based_value (name, body) -> + let body = compile_aexpr body in + let gvar = define_global name (const_int i64_t 0) module_ in + ignore (build_store body gvar builder) +;; + +let init_runtime = + let runtime_funs = + [ "new_closure", function_type i64_t [| i64_t; i64_t |] + ; "apply_args", var_arg_function_type i64_t [| i64_t; i64_t; i64_t |] + ; "print_int", function_type i64_t [| i64_t |] + ; "rt_add", function_type i64_t [| i64_t; i64_t |] + ; "rt_sub", function_type i64_t [| i64_t; i64_t |] + ; "rt_mul", function_type i64_t [| i64_t; i64_t |] + ; "rt_div", function_type i64_t [| i64_t; i64_t |] + ; "rt_leq", function_type i64_t [| i64_t; i64_t |] + ; "rt_less", function_type i64_t [| i64_t; i64_t |] + ; "rt_geq", function_type i64_t [| i64_t; i64_t |] + ; "rt_gre", function_type i64_t [| i64_t; i64_t |] + ; "rt_eq", function_type i64_t [| i64_t; i64_t |] + ; "rt_neq", function_type i64_t [| i64_t; i64_t |] + ; "rt_and", function_type i64_t [| i64_t; i64_t |] + ; "rt_or", function_type i64_t [| i64_t; i64_t |] + ; "fail_match", function_type i64_t [| i64_t |] + ] + in + List.map (fun (name, ty) -> declare_function name ty module_) runtime_funs +;; + +let create_main program = + ignore init_runtime; + List.iter (fun decl -> ignore (compile_anf_decl decl)) program +;; + +let compile_program program = + let _ = create_main program in + print_module "out.ll" module_ +;; diff --git a/FML/lib/llvm/runtime.c b/FML/lib/llvm/runtime.c index 149a4fd30..c61fa348f 100644 --- a/FML/lib/llvm/runtime.c +++ b/FML/lib/llvm/runtime.c @@ -6,7 +6,7 @@ int64_t print_int(int64_t x) { - printf("%ld\n", x); + printf("%ld", x); return 0; } @@ -106,7 +106,7 @@ int64_t _apply(closure_t *closure, int new_args_num, va_list *args) } } -int64_t apply(closure_t *closure, int new_args_num, ...) +int64_t apply_args(closure_t *closure, int new_args_num, ...) { va_list args; va_start(args, new_args_num); From 8b65ac9363556f9a87985b4d5380fab1275a32b3 Mon Sep 17 00:00:00 2001 From: Dmitry Pilyuk Date: Mon, 28 Apr 2025 13:03:42 +0300 Subject: [PATCH 86/92] Codegen in work --- FML/bin/bitecode.t | 46 ++++----- FML/bin/dune | 27 ++++++ FML/bin/llvm_exec.t | 30 +++--- FML/bin/runtime.c | 128 ------------------------- FML/lib/anf/common.ml | 1 + FML/lib/llvm/gen.ml | 18 +++- FML/lib/llvm/runtime.c | 14 +-- FML/tests/a_conv_manytest.t | 9 +- FML/tests/anf_manytest.t | 8 +- FML/tests/c_conv_manytest.t | 6 +- FML/tests/lambda_lift_manytest.t | 6 +- FML/tests/match_elimination_manytest.t | 6 +- 12 files changed, 107 insertions(+), 192 deletions(-) delete mode 100644 FML/bin/runtime.c diff --git a/FML/bin/bitecode.t b/FML/bin/bitecode.t index 6bb22187c..9741cb8af 100644 --- a/FML/bin/bitecode.t +++ b/FML/bin/bitecode.t @@ -65,21 +65,6 @@ } $ ./compiler.exe < manytests/typed/002fac.ml - Fatal error: exception Invalid_argument("option is None") - Raised at Stdlib.invalid_arg in file "stdlib.ml" (inlined), line 30, characters 20-45 - Called from Stdlib__Option.get in file "option.ml", line 21, characters 41-69 - Called from Fml_lib__Gen.compile_immexpr in file "lib/llvm/gen.ml", line 48, characters 9-65 - Called from Fml_lib__Gen.compile_cexpr in file "lib/llvm/gen.ml", line 108, characters 15-51 - Called from Fml_lib__Gen.compile_aexpr in file "lib/llvm/gen.ml", line 146, characters 12-31 - Called from Fml_lib__Gen.compile_cexpr in file "lib/llvm/gen.ml", line 128, characters 16-36 - Called from Fml_lib__Gen.compile_anf_binding in file "lib/llvm/gen.ml", line 167, characters 17-35 - Called from Fml_lib__Gen.compile_anf_decl.(fun) in file "lib/llvm/gen.ml", line 177, characters 37-66 - Called from Stdlib__List.iter in file "list.ml", line 110, characters 12-15 - Called from Fml_lib__Gen.create_main.(fun) in file "lib/llvm/gen.ml", line 209, characters 32-55 - Called from Stdlib__List.iter in file "list.ml", line 110, characters 12-15 - Called from Fml_lib__Gen.compile_program in file "lib/llvm/gen.ml", line 213, characters 10-29 - Called from Dune__exe__Compiler in file "bin/compiler.ml", line 24, characters 4-31 - [2] $ cat < out.ll ; ModuleID = 'FML' source_filename = "FML" @@ -117,30 +102,45 @@ declare i64 @fail_match(i64) - define i64 @fac(i64 %n) { + define i64 @lam_ll0(i64 %k, i64 %n, i64 %p) { entry: - %sle = icmp sle i64 %n, 1 - %sle_i64t = zext i1 %sle to i64 - %cond_v = icmp ne i64 %sle_i64t, 0 + %mul = mul i64 %p, %n + %applied_closure = call i64 (i64, i64, ...) @apply_args(i64 %k, i64 1, i64 %mul) + ret i64 %applied_closure + } + + define i64 @fac_cps(i64 %n, i64 %k) { + entry: + %eq = icmp eq i64 %n, 1 + %eq_i64t = zext i1 %eq to i64 + %cond_v = icmp ne i64 %eq_i64t, 0 br i1 %cond_v, label %then, label %else then: ; preds = %entry + %applied_closure = call i64 (i64, i64, ...) @apply_args(i64 %k, i64 1, i64 1) br label %merge else: ; preds = %entry + %empty_closure = call i64 @new_closure(i64 ptrtoint (ptr @lam_ll0 to i64), i64 3) + %applied_closure1 = call i64 (i64, i64, ...) @apply_args(i64 %empty_closure, i64 2, i64 %k, i64 %n) %sub = sub i64 %n, 1 - %call = call i64 @fac(i64 %sub) - %mul = mul i64 %n, %call + %call = call i64 @fac_cps(i64 %sub, i64 %applied_closure1) br label %merge merge: ; preds = %else, %then - %phi = phi i64 [ 1, %then ], [ %mul, %else ] + %phi = phi i64 [ %applied_closure, %then ], [ %call, %else ] ret i64 %phi } + define i64 @lam_ll1(i64 %print_int_ac0) { + entry: + ret i64 %print_int_ac0 + } + define i64 @main() { entry: - %call = call i64 @fac(i64 4) + %empty_closure = call i64 @new_closure(i64 ptrtoint (ptr @lam_ll1 to i64), i64 1) + %call = call i64 @fac_cps(i64 4, i64 %empty_closure) %call1 = call i64 @print_int(i64 %call) ret i64 0 } diff --git a/FML/bin/dune b/FML/bin/dune index a806727ae..25b73e146 100644 --- a/FML/bin/dune +++ b/FML/bin/dune @@ -29,3 +29,30 @@ manytests/typed/013foldfoldr.ml manytests/typed/015tuples.ml manytests/typed/016lists.ml)) + +(cram + (applies_to llvm_exec) + (deps + ./compiler.exe + ./../lib/llvm/runtime.c + manytests/do_not_type/001.ml + manytests/do_not_type/002if.ml + manytests/do_not_type/003occurs.ml + manytests/do_not_type/004let_poly.ml + manytests/do_not_type/015tuples.ml + manytests/typed/001fac.ml + manytests/typed/002fac.ml + manytests/typed/003fib.ml + manytests/typed/004manyargs.ml + manytests/typed/005fix.ml + manytests/typed/006partial.ml + manytests/typed/006partial2.ml + manytests/typed/006partial3.ml + manytests/typed/007order.ml + manytests/typed/008ascription.ml + manytests/typed/009let_poly.ml + manytests/typed/011mapcps.ml + manytests/typed/012fibcps.ml + manytests/typed/013foldfoldr.ml + manytests/typed/015tuples.ml + manytests/typed/016lists.ml)) diff --git a/FML/bin/llvm_exec.t b/FML/bin/llvm_exec.t index 40d9fa1a1..53c18b2e9 100644 --- a/FML/bin/llvm_exec.t +++ b/FML/bin/llvm_exec.t @@ -1,4 +1,4 @@ - $ clang-16 -c runtime.c -o runtime.o + $ clang-16 -c ./../lib/llvm/runtime.c -o runtime.o $ ./compiler.exe < manytests/typed/001fac.ml $ clang-16 out.ll runtime.o -lffi -o 001fac @@ -8,21 +8,17 @@ $ ./compiler.exe < manytests/typed/002fac.ml $ clang-16 out.ll runtime.o -lffi -o 002fac $ ./002fac - 24 + 0 $ ./compiler.exe < manytests/typed/003fib.ml $ clang-16 out.ll runtime.o -lffi -o 003fib $ ./003fib - 3 - 3 + 33 $ ./compiler.exe < manytests/typed/004manyargs.ml $ clang-16 out.ll runtime.o -lffi -o 004manyargs $ ./004manyargs - 1111111111 - 1 - 10 - 100 + 1111111111110100 $ ./compiler.exe < manytests/typed/005fix.ml $ clang-16 out.ll runtime.o -lffi -o 005fix @@ -37,17 +33,17 @@ $ ./compiler.exe < manytests/typed/006partial2.ml $ clang-16 out.ll runtime.o -lffi -o 006partial2 $ ./006partial2 - 1 - 2 - 3 - 7 + 1237 $ ./compiler.exe < manytests/typed/006partial3.ml $ clang-16 out.ll runtime.o -lffi -o 006partial3 $ ./006partial3 - 4 - 8 - 9 + 489 + + $ ./compiler.exe < manytests/typed/007order.ml + $ clang-16 out.ll runtime.o -lffi -o 007order + $ ./007order + -1421103-55555510000 $ ./compiler.exe < manytests/typed/008ascription.ml $ clang-16 out.ll runtime.o -lffi -o 008ascription @@ -57,4 +53,6 @@ $ ./compiler.exe < manytests/typed/012fibcps.ml $ clang-16 out.ll runtime.o -lffi -o 012fibcps $ ./012fibcps - 8 + Fatal glibc error: malloc.c:2601 (sysmalloc): assertion failed: (old_top == initial_top (av) && old_size == 0) || ((unsigned long) (old_size) >= MINSIZE && prev_inuse (old_top) && ((unsigned long) old_end & (pagesize - 1)) == 0) + 81277 Aborted (core dumped) ./012fibcps + [134] diff --git a/FML/bin/runtime.c b/FML/bin/runtime.c deleted file mode 100644 index ad07c5287..000000000 --- a/FML/bin/runtime.c +++ /dev/null @@ -1,128 +0,0 @@ -#include -#include -#include -#include -#include - -typedef struct closure_t { - int64_t fun_ptr; - int64_t args_num; - int64_t args_applied; - int64_t applied_args[]; -} closure_t; - -closure_t *create_closure(int64_t fun_ptr, int64_t args_num, - int64_t args_applied) { - size_t size = sizeof(closure_t) + args_num * sizeof(int64_t); - closure_t *clos = (closure_t *)malloc(size); - clos->fun_ptr = fun_ptr; - clos->args_num = args_num; - clos->args_applied = args_applied; - return clos; -} - -closure_t *empty_closure(int64_t fun_ptr, int64_t args_num) { - return create_closure(fun_ptr, args_num, 0); -} - -int64_t _copy_closure(closure_t *src_clos, int64_t new_args_num, - va_list *new_args) { - int64_t total_args_applied = src_clos->args_applied + new_args_num; - closure_t *new_clos = - create_closure(src_clos->fun_ptr, src_clos->args_num, total_args_applied); - - for (int i = 0; i < src_clos->args_applied; i++) { - new_clos->applied_args[i] = src_clos->applied_args[i]; - } - - for (int i = 0; i < new_args_num; i++) { - new_clos->applied_args[src_clos->args_applied + i] = - va_arg(*new_args, int64_t); - } - - return (int64_t)new_clos; -} - -int64_t call_closure(closure_t *closure, int64_t new_args_num, - va_list *new_args) { - size_t args_count = closure->args_num; - - ffi_cif cif; - ffi_type *arg_types[args_count]; - int64_t *args[args_count]; - - int64_t buffer_new_args[new_args_num]; - - for (int i = 0; i < args_count; ++i) { - arg_types[i] = &ffi_type_sint64; - if (i < closure->args_applied) { - args[i] = &(closure->applied_args[i]); - } else { - int na_num = i - closure->args_applied; - buffer_new_args[na_num] = va_arg(*new_args, int64_t); - args[i] = &(buffer_new_args[na_num]); - } - } - - int64_t res = 0; - - if (ffi_prep_cif(&cif, FFI_DEFAULT_ABI, args_count, &ffi_type_sint64, - arg_types) == FFI_OK) { - ffi_call(&cif, (void *)closure->fun_ptr, &res, (void **)args); - } else { - fprintf(stderr, "call_closure: Failed to prepare call interface\n"); - exit(1); - } - - return res; -} - -int64_t _apply_args_to_closure(closure_t *closure, int64_t new_args_num, - va_list *new_args) { - int64_t args_num_until_apply = closure->args_num - closure->args_applied; - - if (args_num_until_apply <= new_args_num) { - int64_t call_res = call_closure(closure, args_num_until_apply, new_args); - new_args_num -= args_num_until_apply; - if (new_args_num == 0) { - return call_res; - } else { - return _apply_args_to_closure((closure_t *)call_res, new_args_num, - new_args); - } - } else { - return _copy_closure(closure, new_args_num, new_args); - } -} - -int64_t apply_args(int64_t closure_ptr, int64_t new_args_num, ...) { - va_list new_args; - va_start(new_args, new_args_num); - int64_t res = - _apply_args_to_closure((closure_t *)closure_ptr, new_args_num, &new_args); - va_end(new_args); - return res; -} - -int64_t rt_add(int64_t x, int64_t y) { return x + y; } -int64_t rt_sub(int64_t x, int64_t y) { return x - y; } -int64_t rt_mul(int64_t x, int64_t y) { return x * y; } -int64_t rt_divd(int64_t x, int64_t y) { return x / y; } -int64_t rt_eq(int64_t x, int64_t y) { return x == y; } -int64_t rt_neq(int64_t x, int64_t y) { return x != y; } -int64_t rt_less(int64_t x, int64_t y) { return x < y; } -int64_t rt_leq(int64_t x, int64_t y) { return x <= y; } -int64_t rt_gre(int64_t x, int64_t y) { return x > y; } -int64_t rt_geq(int64_t x, int64_t y) { return x >= y; } -int64_t rt_and(int64_t x, int64_t y) { return x && y; } -int64_t rt_or(int64_t x, int64_t y) { return x || y; } - -int64_t print_int(int64_t x) { - printf("%ld\n", x); - return 0; -} - -int64_t fail_match(int64_t _) { - fprintf(stderr, "Match failure\n"); - exit(1); -} \ No newline at end of file diff --git a/FML/lib/anf/common.ml b/FML/lib/anf/common.ml index 0aa9beb4b..41158aac6 100644 --- a/FML/lib/anf/common.ml +++ b/FML/lib/anf/common.ml @@ -37,6 +37,7 @@ let builtins = ; "hd_list_get" ; "tl_list_get" ; "fail_match" + ; "_start" ] ;; diff --git a/FML/lib/llvm/gen.ml b/FML/lib/llvm/gen.ml index 25d3b2a3f..a576e98d5 100644 --- a/FML/lib/llvm/gen.ml +++ b/FML/lib/llvm/gen.ml @@ -45,8 +45,8 @@ let compile_immexpr = function let fun_ptr = build_ptrtoint f i64_t "" builder in build_call (function_type i64_t [| i64_t; i64_t |]) - (Option.get @@ lookup_function "create_closure" module_) - [| fun_ptr; const_int i64_t (Array.length (params f)); const_int i64_t 0 |] + (Option.get @@ lookup_function "new_closure" module_) + [| fun_ptr; const_int i64_t (Array.length (params f)) |] "empty_closure" builder | None -> @@ -59,6 +59,11 @@ let compile_immexpr = function | _ -> failwith "Not_implemented" ;; +let is_unnop = function + | "( ~+ )" | "( ~- )" -> true + | _ -> false +;; + let is_binop = function | "( + )" | "( - )" @@ -75,6 +80,13 @@ let is_binop = function | _ -> false ;; +let compile_unnop op x = + match op with + | "( ~+ )" -> x + | "( ~- )" -> build_sub (const_int i64_t 0) x "sub" builder + | _ -> failwith ("Invalid operator: " ^ op) +;; + let compile_binop op x y = match op with | "( + )" -> build_add x y "add" builder @@ -96,6 +108,8 @@ let compile_binop op x y = let rec compile_cexpr = function | CImmExpr imm -> compile_immexpr imm + | CEApply (name, [ arg1 ]) when is_unnop name -> + compile_unnop name (compile_immexpr arg1) | CEApply (name, [ arg1; arg2 ]) when is_binop name -> compile_binop name (compile_immexpr arg1) (compile_immexpr arg2) | CEApply (name, args) -> diff --git a/FML/lib/llvm/runtime.c b/FML/lib/llvm/runtime.c index c61fa348f..a37160104 100644 --- a/FML/lib/llvm/runtime.c +++ b/FML/lib/llvm/runtime.c @@ -59,7 +59,7 @@ int64_t call_closure(closure_t *closure) args[i] = &closure->args[i]; } - if (ffi_prep_cif(&cif, FFI_DEFAULT_ABI, 2, &ffi_type_sint64, args_types) != FFI_OK) + if (ffi_prep_cif(&cif, FFI_DEFAULT_ABI, args_n, &ffi_type_sint64, args_types) != FFI_OK) { fprintf(stderr, "Failed to prepare CIF\n"); exit(1); @@ -82,7 +82,7 @@ int64_t _apply(closure_t *closure, int new_args_num, va_list *args) { int64_t arg = va_arg(*args, int64_t); closure->args[closure->args_applied + i] = arg; - closure->args_applied += new_args_num; + closure->args_applied += 1; } return (int64_t)closure; } @@ -95,14 +95,16 @@ int64_t _apply(closure_t *closure, int new_args_num, va_list *args) } int64_t res = call_closure(closure); + new_args_num -= args_to_apply; - free(closure); + // free(closure); if (new_args_num == 0) { return res; } - closure = (closure_t *)res; - return _apply(closure, new_args_num, args); + + closure_t *new_closure = (closure_t *)res; + return _apply(new_closure, new_args_num, args); } } @@ -111,6 +113,6 @@ int64_t apply_args(closure_t *closure, int new_args_num, ...) va_list args; va_start(args, new_args_num); - return _apply(closure, new_args_num, &args); va_end(args); + return _apply(closure, new_args_num, &args); } diff --git a/FML/tests/a_conv_manytest.t b/FML/tests/a_conv_manytest.t index 2c7589d3f..ccff26c70 100644 --- a/FML/tests/a_conv_manytest.t +++ b/FML/tests/a_conv_manytest.t @@ -595,7 +595,7 @@ ] $ ./a_conv_runner.exe < manytests/typed/007order.ml [(NoRecDecl - [(DDeclaration ((PIdentifier "_start"), + [(DDeclaration ((PIdentifier "_start_ac0"), (EFun (PUnit, (EFun (PUnit, (EFun ((PIdentifier "a"), @@ -659,7 +659,8 @@ (EApplication ( (EApplication ( (EApplication ( - (EApplication ((EIdentifier "_start"), + (EApplication ( + (EIdentifier "_start_ac0"), (EApplication ( (EIdentifier "print_int"), (EConst (CInt 1)))) @@ -728,12 +729,12 @@ )) )) )), - (EFun ((PIdentifier "_start"), + (EFun ((PIdentifier "_start_ac0"), (EApplication ( (EApplication ((EIdentifier "( = )"), (EApplication ( (EApplication ((EIdentifier "( / )"), - (EIdentifier "_start"))), + (EIdentifier "_start_ac0"))), (EConst (CInt 2)))) )), (EConst (CInt 0)))) diff --git a/FML/tests/anf_manytest.t b/FML/tests/anf_manytest.t index 957449b9f..df18b2c8e 100644 --- a/FML/tests/anf_manytest.t +++ b/FML/tests/anf_manytest.t @@ -441,7 +441,7 @@ val foo : int -> int -> int -> unit val main : int $ ./anf_runner.exe < manytests/typed/007order.ml - let _start () () a () b _c () d __ = let anf0 = ( + ) a b in + let _start_ac0 () () a () b _c () d __ = let anf0 = ( + ) a b in let () = print_int anf0 in let () = print_int __ in let anf2 = ( * ) a b in @@ -455,7 +455,7 @@ let anf7 = print_int 4 in let anf8 = print_int 2 in let anf9 = print_int 1 in - let anf3 = _start anf9 anf8 3 anf7 100 1000 anf5 10000 anf4 in + let anf3 = _start_ac0 anf9 anf8 3 anf7 100 1000 anf5 10000 anf4 in print_int anf3 ;; @@ -464,7 +464,7 @@ val main : unit Типы после приведения в ANF: - val _start : unit -> unit -> int -> unit -> int -> int -> unit -> int -> int -> int + val _start_ac0 : unit -> unit -> int -> unit -> int -> int -> unit -> int -> int -> int val main : unit $ ./anf_runner.exe < manytests/typed/008ascription.ml let addi f g x = let anf0 = g x in @@ -476,7 +476,7 @@ else ( * ) x 2 ;; - let lam_ll1 _start = let anf1 = ( / ) _start 2 in + let lam_ll1 _start_ac0 = let anf1 = ( / ) _start_ac0 2 in ( = ) anf1 0 ;; diff --git a/FML/tests/c_conv_manytest.t b/FML/tests/c_conv_manytest.t index 52eef2ea4..75428a33a 100644 --- a/FML/tests/c_conv_manytest.t +++ b/FML/tests/c_conv_manytest.t @@ -169,17 +169,17 @@ let main = let () = (((foo 4) 8) 9) in 0 $ ./c_conv_runner.exe < manytests/typed/007order.ml - let _start = (fun () () a () b _c () d __ -> let () = (print_int ((( + ) a) b)) in + let _start_ac0 = (fun () () a () b _c () d __ -> let () = (print_int ((( + ) a) b)) in let () = (print_int __) in ((( + ) ((( / ) ((( * ) a) b)) _c)) d)) - let main = (print_int (((((((((_start (print_int 1)) (print_int 2)) 3) (print_int 4)) 100) 1000) (print_int (( ~- ) 1))) 10000) (( ~- ) 555555))) + let main = (print_int (((((((((_start_ac0 (print_int 1)) (print_int 2)) 3) (print_int 4)) 100) 1000) (print_int (( ~- ) 1))) 10000) (( ~- ) 555555))) $ ./c_conv_runner.exe < manytests/typed/008ascription.ml let addi = (fun f g x -> ((f x) (g x))) let main = let () = (print_int (((addi (fun x b -> if b then ((( + ) x) 1) - else ((( * ) x) 2))) (fun _start -> ((( = ) ((( / ) _start) 2)) 0))) 4)) in + else ((( * ) x) 2))) (fun _start_ac0 -> ((( = ) ((( / ) _start_ac0) 2)) 0))) 4)) in 0 $ ./c_conv_runner.exe < manytests/typed/009let_poly.ml diff --git a/FML/tests/lambda_lift_manytest.t b/FML/tests/lambda_lift_manytest.t index 1a681f06e..705db3864 100644 --- a/FML/tests/lambda_lift_manytest.t +++ b/FML/tests/lambda_lift_manytest.t @@ -218,11 +218,11 @@ let main = let () = (((foo 4) 8) 9) in 0 $ ./lambda_lift_runner.exe < manytests/typed/007order.ml - let _start = (fun () () a () b _c () d __ -> let () = (print_int ((( + ) a) b)) in + let _start_ac0 = (fun () () a () b _c () d __ -> let () = (print_int ((( + ) a) b)) in let () = (print_int __) in ((( + ) ((( / ) ((( * ) a) b)) _c)) d)) - let main = (print_int (((((((((_start (print_int 1)) (print_int 2)) 3) (print_int 4)) 100) 1000) (print_int (( ~- ) 1))) 10000) (( ~- ) 555555))) + let main = (print_int (((((((((_start_ac0 (print_int 1)) (print_int 2)) 3) (print_int 4)) 100) 1000) (print_int (( ~- ) 1))) 10000) (( ~- ) 555555))) $ ./lambda_lift_runner.exe < manytests/typed/008ascription.ml let addi = (fun f g x -> ((f x) (g x))) @@ -230,7 +230,7 @@ then ((( + ) x) 1) else ((( * ) x) 2)) - let lam_ll1 = (fun _start -> ((( = ) ((( / ) _start) 2)) 0)) + let lam_ll1 = (fun _start_ac0 -> ((( = ) ((( / ) _start_ac0) 2)) 0)) let main = let () = (print_int (((addi lam_ll0) lam_ll1) 4)) in 0 diff --git a/FML/tests/match_elimination_manytest.t b/FML/tests/match_elimination_manytest.t index 419f437d5..e770c3d07 100644 --- a/FML/tests/match_elimination_manytest.t +++ b/FML/tests/match_elimination_manytest.t @@ -171,17 +171,17 @@ let main = let () = (((foo 4) 8) 9) in 0 $ ./match_elimination_runner.exe < manytests/typed/007order.ml - let _start = (fun () () a () b _c () d __ -> let () = (print_int ((( + ) a) b)) in + let _start_ac0 = (fun () () a () b _c () d __ -> let () = (print_int ((( + ) a) b)) in let () = (print_int __) in ((( + ) ((( / ) ((( * ) a) b)) _c)) d)) - let main = (print_int (((((((((_start (print_int 1)) (print_int 2)) 3) (print_int 4)) 100) 1000) (print_int (( ~- ) 1))) 10000) (( ~- ) 555555))) + let main = (print_int (((((((((_start_ac0 (print_int 1)) (print_int 2)) 3) (print_int 4)) 100) 1000) (print_int (( ~- ) 1))) 10000) (( ~- ) 555555))) $ ./match_elimination_runner.exe < manytests/typed/008ascription.ml let addi = (fun f g x -> ((f x) (g x))) let main = let () = (print_int (((addi (fun x b -> if b then ((( + ) x) 1) - else ((( * ) x) 2))) (fun _start -> ((( = ) ((( / ) _start) 2)) 0))) 4)) in + else ((( * ) x) 2))) (fun _start_ac0 -> ((( = ) ((( / ) _start_ac0) 2)) 0))) 4)) in 0 $ ./match_elimination_runner.exe < manytests/typed/009let_poly.ml From 1d39388efebc29b4465f69311058de48b3331ad3 Mon Sep 17 00:00:00 2001 From: Dmitry Pilyuk Date: Mon, 28 Apr 2025 14:47:09 +0300 Subject: [PATCH 87/92] fixes --- FML/bin/compiler.ml | 2 +- FML/bin/dune | 2 +- FML/bin/llvm_exec.t | 30 +++-- FML/lib/dune | 2 +- FML/lib/llvm/codegen.ml | 154 ++++++++++++++------------ FML/lib/llvm/dune | 2 +- FML/lib/llvm/gen.ml | 229 --------------------------------------- FML/lib/llvm/runtime.c | 22 +++- FML/tests/anf_manytest.t | 21 ---- 9 files changed, 120 insertions(+), 344 deletions(-) delete mode 100644 FML/lib/llvm/gen.ml diff --git a/FML/bin/compiler.ml b/FML/bin/compiler.ml index 7cded9e95..62e86b02a 100644 --- a/FML/bin/compiler.ml +++ b/FML/bin/compiler.ml @@ -21,6 +21,6 @@ let () = let ast_cc = C_conv.cc_program ast_me in let ast_ll = Lambda_lift.lambda_lift ast_cc in let ast_anf = Anf.anf ast_ll in - Gen.compile_program ast_anf + Codegen.compile_program ast_anf | Error message -> Format.printf "%s" message ;; diff --git a/FML/bin/dune b/FML/bin/dune index 25b73e146..3f6ce286e 100644 --- a/FML/bin/dune +++ b/FML/bin/dune @@ -34,7 +34,7 @@ (applies_to llvm_exec) (deps ./compiler.exe - ./../lib/llvm/runtime.c + ../lib/llvm/runtime.o manytests/do_not_type/001.ml manytests/do_not_type/002if.ml manytests/do_not_type/003occurs.ml diff --git a/FML/bin/llvm_exec.t b/FML/bin/llvm_exec.t index 53c18b2e9..c943f9646 100644 --- a/FML/bin/llvm_exec.t +++ b/FML/bin/llvm_exec.t @@ -1,58 +1,54 @@ - $ clang-16 -c ./../lib/llvm/runtime.c -o runtime.o - $ ./compiler.exe < manytests/typed/001fac.ml - $ clang-16 out.ll runtime.o -lffi -o 001fac + $ clang-16 out.ll ../lib/llvm/runtime.o -lffi -o 001fac $ ./001fac 24 $ ./compiler.exe < manytests/typed/002fac.ml - $ clang-16 out.ll runtime.o -lffi -o 002fac + $ clang-16 out.ll ../lib/llvm/runtime.o -lffi -o 002fac $ ./002fac - 0 + 24 $ ./compiler.exe < manytests/typed/003fib.ml - $ clang-16 out.ll runtime.o -lffi -o 003fib + $ clang-16 out.ll ../lib/llvm/runtime.o -lffi -o 003fib $ ./003fib 33 $ ./compiler.exe < manytests/typed/004manyargs.ml - $ clang-16 out.ll runtime.o -lffi -o 004manyargs + $ clang-16 out.ll ../lib/llvm/runtime.o -lffi -o 004manyargs $ ./004manyargs 1111111111110100 $ ./compiler.exe < manytests/typed/005fix.ml - $ clang-16 out.ll runtime.o -lffi -o 005fix + $ clang-16 out.ll ../lib/llvm/runtime.o -lffi -o 005fix $ ./005fix 720 $ ./compiler.exe < manytests/typed/006partial.ml - $ clang-16 out.ll runtime.o -lffi -o 006partial + $ clang-16 out.ll ../lib/llvm/runtime.o -lffi -o 006partial $ ./006partial 1122 $ ./compiler.exe < manytests/typed/006partial2.ml - $ clang-16 out.ll runtime.o -lffi -o 006partial2 + $ clang-16 out.ll ../lib/llvm/runtime.o -lffi -o 006partial2 $ ./006partial2 1237 $ ./compiler.exe < manytests/typed/006partial3.ml - $ clang-16 out.ll runtime.o -lffi -o 006partial3 + $ clang-16 out.ll ../lib/llvm/runtime.o -lffi -o 006partial3 $ ./006partial3 489 $ ./compiler.exe < manytests/typed/007order.ml - $ clang-16 out.ll runtime.o -lffi -o 007order + $ clang-16 out.ll ../lib/llvm/runtime.o -lffi -o 007order $ ./007order -1421103-55555510000 $ ./compiler.exe < manytests/typed/008ascription.ml - $ clang-16 out.ll runtime.o -lffi -o 008ascription + $ clang-16 out.ll ../lib/llvm/runtime.o -lffi -o 008ascription $ ./008ascription 8 $ ./compiler.exe < manytests/typed/012fibcps.ml - $ clang-16 out.ll runtime.o -lffi -o 012fibcps + $ clang-16 out.ll ../lib/llvm/runtime.o -lffi -o 012fibcps $ ./012fibcps - Fatal glibc error: malloc.c:2601 (sysmalloc): assertion failed: (old_top == initial_top (av) && old_size == 0) || ((unsigned long) (old_size) >= MINSIZE && prev_inuse (old_top) && ((unsigned long) old_end & (pagesize - 1)) == 0) - 81277 Aborted (core dumped) ./012fibcps - [134] + 8 diff --git a/FML/lib/dune b/FML/lib/dune index 61829eddd..d7fa2e35b 100644 --- a/FML/lib/dune +++ b/FML/lib/dune @@ -18,7 +18,7 @@ Anf_ast Anf Lambda_lift - Gen) + Codegen) (modules_without_implementation inf_errors) (libraries base angstrom llvm llvm.analysis llvm.executionengine) (preprocess diff --git a/FML/lib/llvm/codegen.ml b/FML/lib/llvm/codegen.ml index 38ef3b9d4..a576e98d5 100644 --- a/FML/lib/llvm/codegen.ml +++ b/FML/lib/llvm/codegen.ml @@ -11,8 +11,14 @@ let lookup_name name = Hashtbl.find_opt sym_to_value name let lookup_type name = Hashtbl.find_opt sym_to_type name let add_sym name value = Hashtbl.add sym_to_value name value let add_type name ty = Hashtbl.add sym_to_type name ty +let ctx = global_context () +let builder = builder ctx +let module_ = create_module ctx "FML" +let target_triple = Llvm_target.Target.default_triple () +let () = Llvm.set_target_triple target_triple module_ +let i64_t = i64_type ctx -let id_to_runtime_name = function +let get_rt_name = function | "( + )" -> "rt_add" | "( - )" -> "rt_sub" | "( * )" -> "rt_mul" @@ -28,52 +34,19 @@ let id_to_runtime_name = function | other -> other ;; -let ctx = global_context () -let builder = builder ctx -let module_ = create_module ctx "FML" -let target_triple = Llvm_target.Target.default_triple () -let () = Llvm.set_target_triple target_triple module_ -let i64_t = i64_type ctx - -let compile_binop op x y = - match op with - | "( + )" -> build_add x y "add" builder - | "( - )" -> build_sub x y "sub" builder - | "( * )" -> build_mul x y "mul" builder - | "( / )" -> build_sdiv x y "div" builder - | "( = )" | "( == )" -> - build_zext (build_icmp Icmp.Eq x y "eq" builder) i64_t "eq_i64t" builder - | "( <> )" | "( != )" -> - build_zext (build_icmp Icmp.Ne x y "ne" builder) i64_t "ne_i64t" builder - | "( > )" -> build_zext (build_icmp Icmp.Sgt x y "sgt" builder) i64_t "sgt_i64t" builder - | "( >= )" -> - build_zext (build_icmp Icmp.Sge x y "sge" builder) i64_t "sge_i64t" builder - | "( < )" -> build_zext (build_icmp Icmp.Slt x y "slt" builder) i64_t "slt_i64t" builder - | "( <= )" -> - build_zext (build_icmp Icmp.Sle x y "sle" builder) i64_t "sle_i64t" builder - | _ -> failwith ("Invalid operator: " ^ op) -;; - -let is_binop = function - | "( + )" | "( - )" | "( * )" | "( / )" -> true - | "( = )" | "( == )" | "( <> )" | "( != )" | "( > )" | "( >= )" | "( < )" | "( <= )" -> - true - | _ -> false -;; - let compile_immexpr = function | ImmInt n -> const_int i64_t n | ImmBool b -> const_int i64_t (Bool.to_int b) | ImmUnit -> const_int i64_t 0 | ImmIdentifier name -> - let name = id_to_runtime_name name in + let name = get_rt_name name in (match lookup_function name module_ with | Some f -> let fun_ptr = build_ptrtoint f i64_t "" builder in build_call (function_type i64_t [| i64_t; i64_t |]) - (Option.get @@ lookup_function "create_closure" module_) - [| fun_ptr; const_int i64_t (Array.length (params f)); const_int i64_t 0 |] + (Option.get @@ lookup_function "new_closure" module_) + [| fun_ptr; const_int i64_t (Array.length (params f)) |] "empty_closure" builder | None -> @@ -83,11 +56,60 @@ let compile_immexpr = function (match lookup_name name with | Some v -> v | None -> failwith ("Unknown variable: " ^ name)))) - | _ -> failwith "Not implemented" + | _ -> failwith "Not_implemented" +;; + +let is_unnop = function + | "( ~+ )" | "( ~- )" -> true + | _ -> false +;; + +let is_binop = function + | "( + )" + | "( - )" + | "( * )" + | "( / )" + | "( = )" + | "( == )" + | "( <> )" + | "( != )" + | "( > )" + | "( >= )" + | "( < )" + | "( <= )" -> true + | _ -> false +;; + +let compile_unnop op x = + match op with + | "( ~+ )" -> x + | "( ~- )" -> build_sub (const_int i64_t 0) x "sub" builder + | _ -> failwith ("Invalid operator: " ^ op) +;; + +let compile_binop op x y = + match op with + | "( + )" -> build_add x y "add" builder + | "( - )" -> build_sub x y "sub" builder + | "( * )" -> build_mul x y "mul" builder + | "( / )" -> build_sdiv x y "div" builder + | "( = )" | "( == )" -> + build_zext (build_icmp Icmp.Eq x y "eq" builder) i64_t "eq_i64t" builder + | "( <> )" | "( != )" -> + build_zext (build_icmp Icmp.Ne x y "ne" builder) i64_t "ne_i64t" builder + | "( > )" -> build_zext (build_icmp Icmp.Sgt x y "sgt" builder) i64_t "sgt_i64t" builder + | "( >= )" -> + build_zext (build_icmp Icmp.Sge x y "sge" builder) i64_t "sge_i64t" builder + | "( < )" -> build_zext (build_icmp Icmp.Slt x y "slt" builder) i64_t "slt_i64t" builder + | "( <= )" -> + build_zext (build_icmp Icmp.Sle x y "sle" builder) i64_t "sle_i64t" builder + | _ -> failwith ("Invalid operator: " ^ op) ;; let rec compile_cexpr = function - | CImmExpr expr -> compile_immexpr expr + | CImmExpr imm -> compile_immexpr imm + | CEApply (name, [ arg1 ]) when is_unnop name -> + compile_unnop name (compile_immexpr arg1) | CEApply (name, [ arg1; arg2 ]) when is_binop name -> compile_binop name (compile_immexpr arg1) (compile_immexpr arg2) | CEApply (name, args) -> @@ -130,14 +152,14 @@ let rec compile_cexpr = function let (_ : llvalue) = build_br merge_bb builder in position_at_end merge_bb builder; phi - | _ -> failwith "Not impemented" + | _ -> failwith "Not implemented" and compile_aexpr = function - | ACExpr expr -> compile_cexpr expr - | ALetIn (name, ce, ae) -> - let v = compile_cexpr ce in + | ACExpr e -> compile_cexpr e + | ALetIn (name, cexpr, aexpr) -> + let v = compile_cexpr cexpr in add_sym name v; - compile_aexpr ae + compile_aexpr aexpr ;; let declare_func name args = @@ -147,37 +169,35 @@ let declare_func name args = ;; let compile_anf_binding (ALet (name, args, body)) = - if List.length args = 0 && name <> "main" - then ( - let body = compile_aexpr body in - let gvar = define_global name (const_int i64_t 0) module_ in - ignore (build_store body gvar builder)) - else ( - let func = declare_func name args in - let bb = append_block ctx "entry" func in - position_at_end bb builder; - List.iteri - (fun i arg_name -> - let arg_value = param func i in - set_value_name arg_name arg_value; - add_sym arg_name arg_value) - args; - let body_val = compile_aexpr body in - let _ = build_ret body_val builder in - ignore func) + let func = declare_func name args in + let bb = append_block ctx "entry" func in + position_at_end bb builder; + List.iteri + (fun i arg_name -> + let arg_value = param func i in + set_value_name arg_name arg_value; + add_sym arg_name arg_value) + args; + let body_val = compile_aexpr body in + let _ = build_ret body_val builder in + ignore func ;; let compile_anf_decl = function | ADNoRec bindings -> List.iter (fun binding -> ignore (compile_anf_binding binding)) bindings - | ADREC bindings -> + | ADRec bindings -> List.iter (fun (ALet (name, args, _)) -> ignore (declare_func name args)) bindings; List.iter (fun binding -> ignore (compile_anf_binding binding)) bindings + | Based_value (name, body) -> + let body = compile_aexpr body in + let gvar = define_global name (const_int i64_t 0) module_ in + ignore (build_store body gvar builder) ;; let init_runtime = - let runtime_ = - [ "create_closure", function_type i64_t [| i64_t; i64_t; i64_t |] + let runtime_funs = + [ "new_closure", function_type i64_t [| i64_t; i64_t |] ; "apply_args", var_arg_function_type i64_t [| i64_t; i64_t; i64_t |] ; "print_int", function_type i64_t [| i64_t |] ; "rt_add", function_type i64_t [| i64_t; i64_t |] @@ -195,11 +215,11 @@ let init_runtime = ; "fail_match", function_type i64_t [| i64_t |] ] in - List.iter (fun (name, ty) -> ignore (declare_function name ty module_)) runtime_ + List.map (fun (name, ty) -> declare_function name ty module_) runtime_funs ;; let create_main program = - init_runtime; + ignore init_runtime; List.iter (fun decl -> ignore (compile_anf_decl decl)) program ;; diff --git a/FML/lib/llvm/dune b/FML/lib/llvm/dune index ec09360b5..181269991 100644 --- a/FML/lib/llvm/dune +++ b/FML/lib/llvm/dune @@ -1,5 +1,5 @@ (rule - (targets runtime.a) + (targets runtime.o) (deps runtime.c) (action (run clang-16 -c runtime.c -o %{targets}))) diff --git a/FML/lib/llvm/gen.ml b/FML/lib/llvm/gen.ml deleted file mode 100644 index a576e98d5..000000000 --- a/FML/lib/llvm/gen.ml +++ /dev/null @@ -1,229 +0,0 @@ -(** Copyright 2024-2025, Dmitry Pilyuk, Aleksandr Rozhkov *) - -(** SPDX-License-Identifier: LGPL-2.1 *) - -open Llvm -open Anf_ast - -let sym_to_value : (string, llvalue) Hashtbl.t = Hashtbl.create 10 -let sym_to_type : (string, lltype) Hashtbl.t = Hashtbl.create 10 -let lookup_name name = Hashtbl.find_opt sym_to_value name -let lookup_type name = Hashtbl.find_opt sym_to_type name -let add_sym name value = Hashtbl.add sym_to_value name value -let add_type name ty = Hashtbl.add sym_to_type name ty -let ctx = global_context () -let builder = builder ctx -let module_ = create_module ctx "FML" -let target_triple = Llvm_target.Target.default_triple () -let () = Llvm.set_target_triple target_triple module_ -let i64_t = i64_type ctx - -let get_rt_name = function - | "( + )" -> "rt_add" - | "( - )" -> "rt_sub" - | "( * )" -> "rt_mul" - | "( / )" -> "rt_divd" - | "( = )" -> "rt_eq" - | "( != )" -> "rt_neq" - | "( < )" -> "rt_less" - | "( <= )" -> "rt_leq" - | "( > )" -> "rt_gre" - | "( >= )" -> "rt_geq" - | "( && )" -> "rt_and" - | "( || )" -> "rt_or" - | other -> other -;; - -let compile_immexpr = function - | ImmInt n -> const_int i64_t n - | ImmBool b -> const_int i64_t (Bool.to_int b) - | ImmUnit -> const_int i64_t 0 - | ImmIdentifier name -> - let name = get_rt_name name in - (match lookup_function name module_ with - | Some f -> - let fun_ptr = build_ptrtoint f i64_t "" builder in - build_call - (function_type i64_t [| i64_t; i64_t |]) - (Option.get @@ lookup_function "new_closure" module_) - [| fun_ptr; const_int i64_t (Array.length (params f)) |] - "empty_closure" - builder - | None -> - (match lookup_global name module_ with - | Some g -> g - | None -> - (match lookup_name name with - | Some v -> v - | None -> failwith ("Unknown variable: " ^ name)))) - | _ -> failwith "Not_implemented" -;; - -let is_unnop = function - | "( ~+ )" | "( ~- )" -> true - | _ -> false -;; - -let is_binop = function - | "( + )" - | "( - )" - | "( * )" - | "( / )" - | "( = )" - | "( == )" - | "( <> )" - | "( != )" - | "( > )" - | "( >= )" - | "( < )" - | "( <= )" -> true - | _ -> false -;; - -let compile_unnop op x = - match op with - | "( ~+ )" -> x - | "( ~- )" -> build_sub (const_int i64_t 0) x "sub" builder - | _ -> failwith ("Invalid operator: " ^ op) -;; - -let compile_binop op x y = - match op with - | "( + )" -> build_add x y "add" builder - | "( - )" -> build_sub x y "sub" builder - | "( * )" -> build_mul x y "mul" builder - | "( / )" -> build_sdiv x y "div" builder - | "( = )" | "( == )" -> - build_zext (build_icmp Icmp.Eq x y "eq" builder) i64_t "eq_i64t" builder - | "( <> )" | "( != )" -> - build_zext (build_icmp Icmp.Ne x y "ne" builder) i64_t "ne_i64t" builder - | "( > )" -> build_zext (build_icmp Icmp.Sgt x y "sgt" builder) i64_t "sgt_i64t" builder - | "( >= )" -> - build_zext (build_icmp Icmp.Sge x y "sge" builder) i64_t "sge_i64t" builder - | "( < )" -> build_zext (build_icmp Icmp.Slt x y "slt" builder) i64_t "slt_i64t" builder - | "( <= )" -> - build_zext (build_icmp Icmp.Sle x y "sle" builder) i64_t "sle_i64t" builder - | _ -> failwith ("Invalid operator: " ^ op) -;; - -let rec compile_cexpr = function - | CImmExpr imm -> compile_immexpr imm - | CEApply (name, [ arg1 ]) when is_unnop name -> - compile_unnop name (compile_immexpr arg1) - | CEApply (name, [ arg1; arg2 ]) when is_binop name -> - compile_binop name (compile_immexpr arg1) (compile_immexpr arg2) - | CEApply (name, args) -> - let compiled_args = List.map compile_immexpr args in - (match lookup_function name module_ with - | Some f when Array.length (params f) = List.length args -> - let func_type = function_type i64_t (Array.make (List.length args) i64_t) in - build_call func_type f (Array.of_list compiled_args) "call" builder - | _ -> - let f = compile_immexpr (ImmIdentifier name) in - build_call - (var_arg_function_type i64_t [| i64_t; i64_t |]) - (Option.get (lookup_function "apply_args" module_)) - (Array.of_list - ([ f; const_int i64_t (List.length compiled_args) ] @ compiled_args)) - "applied_closure" - builder) - | CEIf (cond, then_e, else_e) -> - let cond_v = - build_icmp Icmp.Ne (compile_immexpr cond) (const_int i64_t 0) "cond_v" builder - in - let entry_block = insertion_block builder in - let parent = block_parent entry_block in - let then_block = append_block ctx "then" parent in - position_at_end then_block builder; - let then_ = compile_aexpr then_e in - let new_then_block = insertion_block builder in - let else_block = append_block ctx "else" parent in - position_at_end else_block builder; - let else_ = compile_aexpr else_e in - let new_else_block = insertion_block builder in - let merge_bb = append_block ctx "merge" parent in - position_at_end merge_bb builder; - let phi = build_phi [ then_, new_then_block; else_, new_else_block ] "phi" builder in - position_at_end entry_block builder; - let (_ : llvalue) = build_cond_br cond_v then_block else_block builder in - position_at_end new_then_block builder; - let (_ : llvalue) = build_br merge_bb builder in - position_at_end new_else_block builder; - let (_ : llvalue) = build_br merge_bb builder in - position_at_end merge_bb builder; - phi - | _ -> failwith "Not implemented" - -and compile_aexpr = function - | ACExpr e -> compile_cexpr e - | ALetIn (name, cexpr, aexpr) -> - let v = compile_cexpr cexpr in - add_sym name v; - compile_aexpr aexpr -;; - -let declare_func name args = - let arg_types = Array.make (List.length args) i64_t in - let func_type = function_type i64_t arg_types in - declare_function name func_type module_ -;; - -let compile_anf_binding (ALet (name, args, body)) = - let func = declare_func name args in - let bb = append_block ctx "entry" func in - position_at_end bb builder; - List.iteri - (fun i arg_name -> - let arg_value = param func i in - set_value_name arg_name arg_value; - add_sym arg_name arg_value) - args; - let body_val = compile_aexpr body in - let _ = build_ret body_val builder in - ignore func -;; - -let compile_anf_decl = function - | ADNoRec bindings -> - List.iter (fun binding -> ignore (compile_anf_binding binding)) bindings - | ADRec bindings -> - List.iter (fun (ALet (name, args, _)) -> ignore (declare_func name args)) bindings; - List.iter (fun binding -> ignore (compile_anf_binding binding)) bindings - | Based_value (name, body) -> - let body = compile_aexpr body in - let gvar = define_global name (const_int i64_t 0) module_ in - ignore (build_store body gvar builder) -;; - -let init_runtime = - let runtime_funs = - [ "new_closure", function_type i64_t [| i64_t; i64_t |] - ; "apply_args", var_arg_function_type i64_t [| i64_t; i64_t; i64_t |] - ; "print_int", function_type i64_t [| i64_t |] - ; "rt_add", function_type i64_t [| i64_t; i64_t |] - ; "rt_sub", function_type i64_t [| i64_t; i64_t |] - ; "rt_mul", function_type i64_t [| i64_t; i64_t |] - ; "rt_div", function_type i64_t [| i64_t; i64_t |] - ; "rt_leq", function_type i64_t [| i64_t; i64_t |] - ; "rt_less", function_type i64_t [| i64_t; i64_t |] - ; "rt_geq", function_type i64_t [| i64_t; i64_t |] - ; "rt_gre", function_type i64_t [| i64_t; i64_t |] - ; "rt_eq", function_type i64_t [| i64_t; i64_t |] - ; "rt_neq", function_type i64_t [| i64_t; i64_t |] - ; "rt_and", function_type i64_t [| i64_t; i64_t |] - ; "rt_or", function_type i64_t [| i64_t; i64_t |] - ; "fail_match", function_type i64_t [| i64_t |] - ] - in - List.map (fun (name, ty) -> declare_function name ty module_) runtime_funs -;; - -let create_main program = - ignore init_runtime; - List.iter (fun decl -> ignore (compile_anf_decl decl)) program -;; - -let compile_program program = - let _ = create_main program in - print_module "out.ll" module_ -;; diff --git a/FML/lib/llvm/runtime.c b/FML/lib/llvm/runtime.c index a37160104..cb4c283fd 100644 --- a/FML/lib/llvm/runtime.c +++ b/FML/lib/llvm/runtime.c @@ -38,15 +38,21 @@ typedef struct } closure_t; int64_t -new_closure(int64_t f_ptr, int64_t args_num) +create_closure(int64_t f_ptr, int64_t args_num, int64_t args_applied) { closure_t *closure = malloc(sizeof(closure_t) + args_num * sizeof(int64_t)); closure->fun_ptr = f_ptr; closure->args_num = args_num; - closure->args_applied = 0; + closure->args_applied = args_applied; return (int64_t)closure; } +int64_t +new_closure(int64_t f_ptr, int64_t args_num) +{ + return create_closure(f_ptr, args_num, 0); +} + int64_t call_closure(closure_t *closure) { int64_t args_n = closure->args_num; @@ -78,13 +84,18 @@ int64_t _apply(closure_t *closure, int new_args_num, va_list *args) if (new_args_num < args_to_apply) { + closure_t *new_closure = (closure_t *)create_closure(closure->fun_ptr, closure->args_num, closure->args_applied + new_args_num); + for (int64_t i = 0; i < closure->args_applied; i++) + { + new_closure->args[i] = closure->args[i]; + } + for (int64_t i = 0; i < new_args_num; i++) { int64_t arg = va_arg(*args, int64_t); - closure->args[closure->args_applied + i] = arg; - closure->args_applied += 1; + new_closure->args[closure->args_applied + i] = arg; } - return (int64_t)closure; + return (int64_t)new_closure; } else { @@ -97,7 +108,6 @@ int64_t _apply(closure_t *closure, int new_args_num, va_list *args) int64_t res = call_closure(closure); new_args_num -= args_to_apply; - // free(closure); if (new_args_num == 0) { return res; diff --git a/FML/tests/anf_manytest.t b/FML/tests/anf_manytest.t index df18b2c8e..68b582767 100644 --- a/FML/tests/anf_manytest.t +++ b/FML/tests/anf_manytest.t @@ -121,27 +121,6 @@ val is_empty_ac0 : int -> int val length : 'a list -> int - $ ./anf_runner.exe << EOF - > let (a, b) = (5,6) - > EOF - let tmp_me0 = (5, 6) - ;; - - let a = tuple_get tmp_me0 0 - ;; - - let b = tuple_get tmp_me0 1 - ;; - - Типы до приведения в ANF: - val a : int - val b : int - - Типы после приведения в ANF: - val tmp_me0 : int * int - val a : int * int - val b : 'a - $ ./anf_runner.exe << EOF > let fac n = > let rec fack n k = From fa9e675eceba58eba97d0a55292291185489f485 Mon Sep 17 00:00:00 2001 From: Dmitry Pilyuk Date: Wed, 30 Apr 2025 01:15:39 +0300 Subject: [PATCH 88/92] Add mli --- FML/lib/anf/a_conv.mli | 7 ++++ FML/lib/anf/anf.mli | 8 ++++ FML/lib/anf/anf_ast.mli | 35 +++++++++++++++++ FML/lib/anf/c_conv.mli | 7 ++++ FML/lib/anf/common.ml | 34 ++++++++--------- FML/lib/anf/common.mli | 52 ++++++++++++++++++++++++++ FML/lib/anf/lambda_lift.mli | 7 ++++ FML/lib/anf/match_elimination.mli | 8 ++++ FML/lib/anf/me_ast.mli | 32 ++++++++++++++++ FML/lib/llvm/codegen.ml | 62 +++++++++++++++---------------- FML/lib/llvm/codegen.mli | 7 ++++ 11 files changed, 210 insertions(+), 49 deletions(-) create mode 100644 FML/lib/anf/a_conv.mli create mode 100644 FML/lib/anf/anf.mli create mode 100644 FML/lib/anf/anf_ast.mli create mode 100644 FML/lib/anf/c_conv.mli create mode 100644 FML/lib/anf/common.mli create mode 100644 FML/lib/anf/lambda_lift.mli create mode 100644 FML/lib/anf/match_elimination.mli create mode 100644 FML/lib/anf/me_ast.mli create mode 100644 FML/lib/llvm/codegen.mli diff --git a/FML/lib/anf/a_conv.mli b/FML/lib/anf/a_conv.mli new file mode 100644 index 000000000..3a99ea2d7 --- /dev/null +++ b/FML/lib/anf/a_conv.mli @@ -0,0 +1,7 @@ +(** Copyright 2024-2025, Dmitry Pilyuk, Aleksandr Rozhkov *) + +(** SPDX-License-Identifier: LGPL-2.1 *) + +open Ast + +val ac_program : program -> program diff --git a/FML/lib/anf/anf.mli b/FML/lib/anf/anf.mli new file mode 100644 index 000000000..01156784f --- /dev/null +++ b/FML/lib/anf/anf.mli @@ -0,0 +1,8 @@ +(** Copyright 2024-2025, Dmitry Pilyuk, Aleksandr Rozhkov *) + +(** SPDX-License-Identifier: LGPL-2.1 *) + +open Anf_ast +open Me_ast + +val anf : me_program -> anf_prog diff --git a/FML/lib/anf/anf_ast.mli b/FML/lib/anf/anf_ast.mli new file mode 100644 index 000000000..392f9bb64 --- /dev/null +++ b/FML/lib/anf/anf_ast.mli @@ -0,0 +1,35 @@ +(** Copyright 2024-2025, Dmitry Pilyuk, Aleksandr Rozhkov *) + +(** SPDX-License-Identifier: LGPL-2.1 *) + +type immexpr = + | ImmInt of int (** 52 *) + | ImmIdentifier of string (** f *) + | ImmBool of bool (** true *) + | ImmUnit (** () *) + | ImmNill (** [] *) + | ImmTuple of immexpr list (** (IE, IE, IE)*) + +type cexpr = + | CEApply of string * immexpr list (** f IE1 IE2 IE3 ... *) + | CEIf of immexpr * aexpr * aexpr (** if IE then AE1 else AE2 *) + | CECons of immexpr * immexpr (** IE::IE*) + | CImmExpr of immexpr (** IE *) + +and aexpr = + | ALetIn of string * cexpr * aexpr (** let a = CE in AE*) + | ACExpr of cexpr (** CE *) + +type anf_binding = ALet of string * string list * aexpr (** f a b c = AE*) + +type anf_decl = + | Based_value of string * aexpr (** let f = AE*) + | ADNoRec of anf_binding list (** let rec anf_binding *) + | ADRec of anf_binding list (** let anf_binding *) + +(** anf_decl;; anf_decl *) +type anf_prog = anf_decl list + +val imm_id : string -> immexpr +val cimmexpr : immexpr -> cexpr +val pp_anf_program : Format.formatter -> anf_decl list -> unit diff --git a/FML/lib/anf/c_conv.mli b/FML/lib/anf/c_conv.mli new file mode 100644 index 000000000..99ba75255 --- /dev/null +++ b/FML/lib/anf/c_conv.mli @@ -0,0 +1,7 @@ +(** Copyright 2024-2025, Dmitry Pilyuk, Aleksandr Rozhkov *) + +(** SPDX-License-Identifier: LGPL-2.1 *) + +open Me_ast + +val cc_program : me_program -> me_program diff --git a/FML/lib/anf/common.ml b/FML/lib/anf/common.ml index 41158aac6..ef7ea5455 100644 --- a/FML/lib/anf/common.ml +++ b/FML/lib/anf/common.ml @@ -9,12 +9,27 @@ module StrMap = struct let empty = Map.empty (module String) let singleton str = Map.singleton (module String) str - let add = Map.add let update = Map.update let find = Map.find let merge_two fst snd = Map.merge_skewed fst snd ~combine:(fun ~key:_ _ v2 -> v2) end +module StrSet = struct + open Base + + type t = (string, String.comparator_witness) Set.t + + let add = Set.add + let empty = Set.empty (module String) + let singleton str = Set.singleton (module String) str + let union = Set.union + let to_list = Set.to_list + let of_list = Set.of_list (module String) + let diff = Set.diff + let union_list lst = Set.union_list (module String) lst + let find = Set.mem +end + let builtins = [ "( + )" ; "( - )" @@ -41,23 +56,6 @@ let builtins = ] ;; -module StrSet = struct - open Base - - type t = (string, String.comparator_witness) Set.t - - let add = Set.add - let empty = Set.empty (module String) - let singleton str = Set.singleton (module String) str - let union = Set.union - let to_list = Set.to_list - let of_list = Set.of_list (module String) - let fold = Set.fold - let diff = Set.diff - let union_list lst = Set.union_list (module String) lst - let find = Set.mem -end - module StateMonad : sig include Base.Monad.Infix diff --git a/FML/lib/anf/common.mli b/FML/lib/anf/common.mli new file mode 100644 index 000000000..45883b3b6 --- /dev/null +++ b/FML/lib/anf/common.mli @@ -0,0 +1,52 @@ +(** Copyright 2024-2025, Dmitry Pilyuk, Aleksandr Rozhkov *) + +(** SPDX-License-Identifier: LGPL-2.1 *) + +module StrMap : sig + type 'a t + + val empty : 'a t + val singleton : string -> 'a -> 'a t + val update : 'a t -> string -> f:('a option -> 'a) -> 'a t + val find : 'a t -> string -> 'a option + val merge_two : 'a t -> 'a t -> 'a t +end + +module StrSet : sig + type t + + val add : t -> string -> t + val empty : t + val singleton : string -> t + val union : t -> t -> t + val to_list : t -> string list + val of_list : string list -> t + val diff : t -> t -> t + val union_list : t list -> t + val find : t -> string -> bool +end + +val builtins : string list + +module StateMonad : sig + include Base.Monad.Infix + + val return : 'a -> 'a t + val ( let* ) : 'a t -> ('a -> 'b t) -> 'b t + + module RList : sig + val fold_left : 'a list -> init:'b t -> f:('b -> 'a -> 'b t) -> 'b t + val fold_right : 'a list -> init:'b t -> f:('a -> 'b -> 'b t) -> 'b t + end + + module RMap : sig + val fold_left + : ('a, 'b, 'c) Base.Map.t + -> init:'d t + -> f:('a -> 'b -> 'd -> 'd t) + -> 'd t + end + + val fresh : int t + val run : 'a t -> 'a +end diff --git a/FML/lib/anf/lambda_lift.mli b/FML/lib/anf/lambda_lift.mli new file mode 100644 index 000000000..262a2061b --- /dev/null +++ b/FML/lib/anf/lambda_lift.mli @@ -0,0 +1,7 @@ +(** Copyright 2024-2025, Dmitry Pilyuk, Aleksandr Rozhkov *) + +(** SPDX-License-Identifier: LGPL-2.1 *) + +open Me_ast + +val lambda_lift : me_program -> me_program diff --git a/FML/lib/anf/match_elimination.mli b/FML/lib/anf/match_elimination.mli new file mode 100644 index 000000000..16d30c079 --- /dev/null +++ b/FML/lib/anf/match_elimination.mli @@ -0,0 +1,8 @@ +(** Copyright 2024-2025, Dmitry Pilyuk, Aleksandr Rozhkov *) + +(** SPDX-License-Identifier: LGPL-2.1 *) + +open Ast +open Me_ast + +val match_elimination : program -> me_program diff --git a/FML/lib/anf/me_ast.mli b/FML/lib/anf/me_ast.mli new file mode 100644 index 000000000..dec82744e --- /dev/null +++ b/FML/lib/anf/me_ast.mli @@ -0,0 +1,32 @@ +(** Copyright 2024-2025, Dmitry Pilyuk, Aleksandr Rozhkov *) + +(** SPDX-License-Identifier: LGPL-2.1 *) + +type rec_flag = + | Rec (** let rec ... *) + | NoRec (** let ... *) + +type me_const = + | Me_Cint of int (** 52 *) + | Me_CBool of bool (** true *) + +type me_expr = + | Me_EUnit (** () *) + | Me_ENill (** [] *) + | Me_EIdentifier of string (** f *) + | Me_EConst of me_const (** 52 || true *) + | Me_EIf of me_expr * me_expr * me_expr (** if E1 then E2 else E3 *) + | Me_EFun of string list * me_expr (** fun a,b,c -> E *) + | Me_EApp of me_expr * me_expr (** E1 E2*) + | Me_ELet of rec_flag * string * me_expr * me_expr (** let [rec] name = E1 in E2 *) + | Me_ECons of me_expr * me_expr (** E1::E2 *) + | Me_ETuple of me_expr list (** (E1, E2, E3) *) + +type me_declaration = + | Me_Nonrec of (string * me_expr) list (** let f = E *) + | Me_Rec of (string * me_expr) list (** let rec f = E *) + +(** me_declaration;; me_declaration *) +type me_program = me_declaration list + +val pp_me_program : Format.formatter -> me_declaration list -> unit diff --git a/FML/lib/llvm/codegen.ml b/FML/lib/llvm/codegen.ml index a576e98d5..8bb119f36 100644 --- a/FML/lib/llvm/codegen.ml +++ b/FML/lib/llvm/codegen.ml @@ -5,12 +5,14 @@ open Llvm open Anf_ast -let sym_to_value : (string, llvalue) Hashtbl.t = Hashtbl.create 10 -let sym_to_type : (string, lltype) Hashtbl.t = Hashtbl.create 10 -let lookup_name name = Hashtbl.find_opt sym_to_value name -let lookup_type name = Hashtbl.find_opt sym_to_type name -let add_sym name value = Hashtbl.add sym_to_value name value -let add_type name ty = Hashtbl.add sym_to_type name ty +module StrMap = struct + open Base + + let empty = Map.empty (module String) + let update = Map.update + let find = Map.find +end + let ctx = global_context () let builder = builder ctx let module_ = create_module ctx "FML" @@ -34,7 +36,7 @@ let get_rt_name = function | other -> other ;; -let compile_immexpr = function +let compile_immexpr env = function | ImmInt n -> const_int i64_t n | ImmBool b -> const_int i64_t (Bool.to_int b) | ImmUnit -> const_int i64_t 0 @@ -51,9 +53,9 @@ let compile_immexpr = function builder | None -> (match lookup_global name module_ with - | Some g -> g + | Some g -> build_load i64_t g "global" builder | None -> - (match lookup_name name with + (match StrMap.find env name with | Some v -> v | None -> failwith ("Unknown variable: " ^ name)))) | _ -> failwith "Not_implemented" @@ -106,20 +108,20 @@ let compile_binop op x y = | _ -> failwith ("Invalid operator: " ^ op) ;; -let rec compile_cexpr = function - | CImmExpr imm -> compile_immexpr imm +let rec compile_cexpr env = function + | CImmExpr imm -> compile_immexpr env imm | CEApply (name, [ arg1 ]) when is_unnop name -> - compile_unnop name (compile_immexpr arg1) + compile_unnop name (compile_immexpr env arg1) | CEApply (name, [ arg1; arg2 ]) when is_binop name -> - compile_binop name (compile_immexpr arg1) (compile_immexpr arg2) + compile_binop name (compile_immexpr env arg1) (compile_immexpr env arg2) | CEApply (name, args) -> - let compiled_args = List.map compile_immexpr args in + let compiled_args = List.map (compile_immexpr env) args in (match lookup_function name module_ with | Some f when Array.length (params f) = List.length args -> let func_type = function_type i64_t (Array.make (List.length args) i64_t) in build_call func_type f (Array.of_list compiled_args) "call" builder | _ -> - let f = compile_immexpr (ImmIdentifier name) in + let f = compile_immexpr env (ImmIdentifier name) in build_call (var_arg_function_type i64_t [| i64_t; i64_t |]) (Option.get (lookup_function "apply_args" module_)) @@ -129,17 +131,17 @@ let rec compile_cexpr = function builder) | CEIf (cond, then_e, else_e) -> let cond_v = - build_icmp Icmp.Ne (compile_immexpr cond) (const_int i64_t 0) "cond_v" builder + build_icmp Icmp.Ne (compile_immexpr env cond) (const_int i64_t 0) "cond_v" builder in let entry_block = insertion_block builder in let parent = block_parent entry_block in let then_block = append_block ctx "then" parent in position_at_end then_block builder; - let then_ = compile_aexpr then_e in + let then_ = compile_aexpr env then_e in let new_then_block = insertion_block builder in let else_block = append_block ctx "else" parent in position_at_end else_block builder; - let else_ = compile_aexpr else_e in + let else_ = compile_aexpr env else_e in let new_else_block = insertion_block builder in let merge_bb = append_block ctx "merge" parent in position_at_end merge_bb builder; @@ -154,12 +156,11 @@ let rec compile_cexpr = function phi | _ -> failwith "Not implemented" -and compile_aexpr = function - | ACExpr e -> compile_cexpr e +and compile_aexpr env = function + | ACExpr e -> compile_cexpr env e | ALetIn (name, cexpr, aexpr) -> - let v = compile_cexpr cexpr in - add_sym name v; - compile_aexpr aexpr + let v = compile_cexpr env cexpr in + compile_aexpr (StrMap.update env name ~f:(fun _ -> v)) aexpr ;; let declare_func name args = @@ -172,13 +173,13 @@ let compile_anf_binding (ALet (name, args, body)) = let func = declare_func name args in let bb = append_block ctx "entry" func in position_at_end bb builder; - List.iteri - (fun i arg_name -> + let _, env = + Base.List.fold args ~init:(0, StrMap.empty) ~f:(fun (i, env) arg_name -> let arg_value = param func i in set_value_name arg_name arg_value; - add_sym arg_name arg_value) - args; - let body_val = compile_aexpr body in + i + 1, StrMap.update env arg_name ~f:(fun _ -> arg_value)) + in + let body_val = compile_aexpr env body in let _ = build_ret body_val builder in ignore func ;; @@ -190,9 +191,8 @@ let compile_anf_decl = function List.iter (fun (ALet (name, args, _)) -> ignore (declare_func name args)) bindings; List.iter (fun binding -> ignore (compile_anf_binding binding)) bindings | Based_value (name, body) -> - let body = compile_aexpr body in - let gvar = define_global name (const_int i64_t 0) module_ in - ignore (build_store body gvar builder) + let body = compile_aexpr StrMap.empty body in + ignore (define_global name body module_) ;; let init_runtime = diff --git a/FML/lib/llvm/codegen.mli b/FML/lib/llvm/codegen.mli new file mode 100644 index 000000000..1586011fe --- /dev/null +++ b/FML/lib/llvm/codegen.mli @@ -0,0 +1,7 @@ +(** Copyright 2024-2025, Dmitry Pilyuk, Aleksandr Rozhkov *) + +(** SPDX-License-Identifier: LGPL-2.1 *) + +open Anf_ast + +val compile_program : anf_prog -> unit From e82ba587a12d1bc1547aea969a8060f207db2095 Mon Sep 17 00:00:00 2001 From: Kakadu Date: Wed, 22 Oct 2025 13:12:24 +0300 Subject: [PATCH 89/92] Why compiler crashes? Signed-off-by: Kakadu --- FML/bin/dune | 4 ++++ FML/bin/llvm_exec.t | 11 +++++++++-- manytests/typed/x013.ml | 18 ++++++++++++++++++ 3 files changed, 31 insertions(+), 2 deletions(-) create mode 100644 manytests/typed/x013.ml diff --git a/FML/bin/dune b/FML/bin/dune index 3f6ce286e..173459578 100644 --- a/FML/bin/dune +++ b/FML/bin/dune @@ -4,6 +4,9 @@ (modules compiler) (libraries fml_lib stdio)) +(cram + (deps manytests/typed/x013.ml)) + (cram (applies_to bitecode) (deps @@ -53,6 +56,7 @@ manytests/typed/009let_poly.ml manytests/typed/011mapcps.ml manytests/typed/012fibcps.ml + ; manytests/typed/x013.ml manytests/typed/013foldfoldr.ml manytests/typed/015tuples.ml manytests/typed/016lists.ml)) diff --git a/FML/bin/llvm_exec.t b/FML/bin/llvm_exec.t index c943f9646..7c89337af 100644 --- a/FML/bin/llvm_exec.t +++ b/FML/bin/llvm_exec.t @@ -49,6 +49,13 @@ 8 $ ./compiler.exe < manytests/typed/012fibcps.ml - $ clang-16 out.ll ../lib/llvm/runtime.o -lffi -o 012fibcps - $ ./012fibcps + $ clang-16 out.ll ../lib/llvm/runtime.o -lffi -o 012fibcps && rm out.ll + $ ./012fibcps && rm -f out.ll 8 + +$ ls manytests/typed + $ ocaml -w -26 manytests/typed/x013.ml + + $ ./compiler.exe < manytests/typed/x013.ml + $ clang-16 out.ll ../lib/llvm/runtime.o -lffi -o 013 + diff --git a/manytests/typed/x013.ml b/manytests/typed/x013.ml new file mode 100644 index 000000000..1cf8f5d95 --- /dev/null +++ b/manytests/typed/x013.ml @@ -0,0 +1,18 @@ +let wrap f = if 1 = 1 then f else f + +let test3 a b c = + let a = print_int a in + let b = print_int b in + let c = print_int c in + 0 + +let apply_args a b c d e f g h i j = a + b + c + d + e + f + g + h + i + j + +let main = + let rez = + (wrap apply_args 1 10 100 1000 10000 100000 1000000 10000000 100000000 + 1000000000) + in + let () = print_int rez in + 0 + From 4db570cbcd6070449c6f43d74801fb95133eca27 Mon Sep 17 00:00:00 2001 From: Dmitry Pilyuk Date: Wed, 22 Oct 2025 14:12:59 +0300 Subject: [PATCH 90/92] Add apply_args and new_closure names in builtins --- FML/bin/llvm_exec.t | 4 +++ FML/lib/anf/common.ml | 2 ++ FML/tests/dune | 78 ------------------------------------------- 3 files changed, 6 insertions(+), 78 deletions(-) diff --git a/FML/bin/llvm_exec.t b/FML/bin/llvm_exec.t index 7c89337af..26695157d 100644 --- a/FML/bin/llvm_exec.t +++ b/FML/bin/llvm_exec.t @@ -55,7 +55,11 @@ $ ls manytests/typed $ ocaml -w -26 manytests/typed/x013.ml + 1111111111 $ ./compiler.exe < manytests/typed/x013.ml $ clang-16 out.ll ../lib/llvm/runtime.o -lffi -o 013 + $ ./013 + 1111111111 + diff --git a/FML/lib/anf/common.ml b/FML/lib/anf/common.ml index ef7ea5455..e2aa74e47 100644 --- a/FML/lib/anf/common.ml +++ b/FML/lib/anf/common.ml @@ -52,6 +52,8 @@ let builtins = ; "hd_list_get" ; "tl_list_get" ; "fail_match" + ; "apply_args" + ; "new_closure" ; "_start" ] ;; diff --git a/FML/tests/dune b/FML/tests/dune index 94835033b..61df4b66f 100644 --- a/FML/tests/dune +++ b/FML/tests/dune @@ -102,58 +102,6 @@ manytests/typed/015tuples.ml manytests/typed/016lists.ml)) -(cram - (applies_to pe_manytests) - (deps - ./pe_runner.exe - manytests/do_not_type/001.ml - manytests/do_not_type/002if.ml - manytests/do_not_type/003occurs.ml - manytests/do_not_type/004let_poly.ml - manytests/do_not_type/015tuples.ml - manytests/typed/001fac.ml - manytests/typed/002fac.ml - manytests/typed/003fib.ml - manytests/typed/004manyargs.ml - manytests/typed/005fix.ml - manytests/typed/006partial.ml - manytests/typed/006partial2.ml - manytests/typed/006partial3.ml - manytests/typed/007order.ml - manytests/typed/008ascription.ml - manytests/typed/009let_poly.ml - manytests/typed/011mapcps.ml - manytests/typed/012fibcps.ml - manytests/typed/013foldfoldr.ml - manytests/typed/015tuples.ml - manytests/typed/016lists.ml)) - -(cram - (applies_to alpha_conv_manytest) - (deps - ./alpha_conv_runner.exe - manytests/do_not_type/001.ml - manytests/do_not_type/002if.ml - manytests/do_not_type/003occurs.ml - manytests/do_not_type/004let_poly.ml - manytests/do_not_type/015tuples.ml - manytests/typed/001fac.ml - manytests/typed/002fac.ml - manytests/typed/003fib.ml - manytests/typed/004manyargs.ml - manytests/typed/005fix.ml - manytests/typed/006partial.ml - manytests/typed/006partial2.ml - manytests/typed/006partial3.ml - manytests/typed/007order.ml - manytests/typed/008ascription.ml - manytests/typed/009let_poly.ml - manytests/typed/011mapcps.ml - manytests/typed/012fibcps.ml - manytests/typed/013foldfoldr.ml - manytests/typed/015tuples.ml - manytests/typed/016lists.ml)) - (cram (applies_to a_conv_manytest) (deps @@ -232,32 +180,6 @@ manytests/typed/015tuples.ml manytests/typed/016lists.ml)) -(cram - (applies_to anf_manytests) - (deps - ./anf_runner.exe - manytests/do_not_type/001.ml - manytests/do_not_type/002if.ml - manytests/do_not_type/003occurs.ml - manytests/do_not_type/004let_poly.ml - manytests/do_not_type/015tuples.ml - manytests/typed/001fac.ml - manytests/typed/002fac.ml - manytests/typed/003fib.ml - manytests/typed/004manyargs.ml - manytests/typed/005fix.ml - manytests/typed/006partial.ml - manytests/typed/006partial2.ml - manytests/typed/006partial3.ml - manytests/typed/007order.ml - manytests/typed/008ascription.ml - manytests/typed/009let_poly.ml - manytests/typed/011mapcps.ml - manytests/typed/012fibcps.ml - manytests/typed/013foldfoldr.ml - manytests/typed/015tuples.ml - manytests/typed/016lists.ml)) - (cram (applies_to match_elimination_manytest) (deps From 9fb9bbfc65e5b228b03d1a8c07e2ead688f19d24 Mon Sep 17 00:00:00 2001 From: Dmitry Pilyuk Date: Thu, 23 Oct 2025 12:56:16 +0300 Subject: [PATCH 91/92] Fixes CI issue due to manytests directory change --- FML/bin/dune | 2 +- FML/bin/llvm_exec.t | 4 ++-- {manytests/typed => FML/bin}/x013.ml | 0 3 files changed, 3 insertions(+), 3 deletions(-) rename {manytests/typed => FML/bin}/x013.ml (100%) diff --git a/FML/bin/dune b/FML/bin/dune index 173459578..8a9268bb8 100644 --- a/FML/bin/dune +++ b/FML/bin/dune @@ -5,7 +5,7 @@ (libraries fml_lib stdio)) (cram - (deps manytests/typed/x013.ml)) + (deps ./x013.ml)) (cram (applies_to bitecode) diff --git a/FML/bin/llvm_exec.t b/FML/bin/llvm_exec.t index 26695157d..cd484a3ee 100644 --- a/FML/bin/llvm_exec.t +++ b/FML/bin/llvm_exec.t @@ -54,10 +54,10 @@ 8 $ ls manytests/typed - $ ocaml -w -26 manytests/typed/x013.ml + $ ocaml -w -26 ./x013.ml 1111111111 - $ ./compiler.exe < manytests/typed/x013.ml + $ ./compiler.exe < ./x013.ml $ clang-16 out.ll ../lib/llvm/runtime.o -lffi -o 013 $ ./013 1111111111 diff --git a/manytests/typed/x013.ml b/FML/bin/x013.ml similarity index 100% rename from manytests/typed/x013.ml rename to FML/bin/x013.ml From b252f7be1565e9134d5e2722d70709c3f70aa5e3 Mon Sep 17 00:00:00 2001 From: Dmitry Pilyuk Date: Thu, 23 Oct 2025 13:09:31 +0300 Subject: [PATCH 92/92] Rename x013.ml --- FML/bin/dune | 2 +- FML/bin/llvm_exec.t | 4 ++-- FML/bin/{x013.ml => x013.ml_test.txt} | 0 3 files changed, 3 insertions(+), 3 deletions(-) rename FML/bin/{x013.ml => x013.ml_test.txt} (100%) diff --git a/FML/bin/dune b/FML/bin/dune index 8a9268bb8..d63383e2c 100644 --- a/FML/bin/dune +++ b/FML/bin/dune @@ -5,7 +5,7 @@ (libraries fml_lib stdio)) (cram - (deps ./x013.ml)) + (deps ./x013.ml_test.txt)) (cram (applies_to bitecode) diff --git a/FML/bin/llvm_exec.t b/FML/bin/llvm_exec.t index cd484a3ee..9c12a0c04 100644 --- a/FML/bin/llvm_exec.t +++ b/FML/bin/llvm_exec.t @@ -54,10 +54,10 @@ 8 $ ls manytests/typed - $ ocaml -w -26 ./x013.ml + $ ocaml -w -26 ./x013.ml_test.txt 1111111111 - $ ./compiler.exe < ./x013.ml + $ ./compiler.exe < ./x013.ml_test.txt $ clang-16 out.ll ../lib/llvm/runtime.o -lffi -o 013 $ ./013 1111111111 diff --git a/FML/bin/x013.ml b/FML/bin/x013.ml_test.txt similarity index 100% rename from FML/bin/x013.ml rename to FML/bin/x013.ml_test.txt