From 40a4132a28315ad154e951203cedb8bf55a1924f Mon Sep 17 00:00:00 2001 From: y-tak6 Date: Thu, 8 Aug 2024 22:06:47 +0900 Subject: [PATCH 1/4] anormal revise --- src/anormal.ml | 5 ++++- src/normalized_ast.ml | 2 -- src/yul_compile.ml | 2 ++ 3 files changed, 6 insertions(+), 3 deletions(-) diff --git a/src/anormal.ml b/src/anormal.ml index 35e6855..130de39 100644 --- a/src/anormal.ml +++ b/src/anormal.ml @@ -66,7 +66,10 @@ let rec remove_tuple rename e mut : exp * Abi.state_mutability = | ACexp e' -> let e, mut = rename_cexp rename e' mut in (match e with - | AIf _ -> (cexp_to_exp e, mut) + | AIf (v, e1, e2) -> ( + let e1', mut1 = remove_tuple rename e1 mut in + let e2', mut2 = remove_tuple rename e2 mut in + (If(v, e1', e2'), Abi.stronger_mutability mut1 mut2)) | _ -> (cexp_to_exp e, mut)) | ASeq (e1, e2) -> ( match rename_cexp rename e1 mut with diff --git a/src/normalized_ast.ml b/src/normalized_ast.ml index 5805c4c..af30ccb 100644 --- a/src/normalized_ast.ml +++ b/src/normalized_ast.ml @@ -1,7 +1,5 @@ open Normalized_common_ast -exception Whoo of int - type resexp = RVal of value | RTuple of value list type letexp = LVal of value | LApp of (value * value list) | LIf of value * exp * exp diff --git a/src/yul_compile.ml b/src/yul_compile.ml index cfaad3f..1b8cf45 100644 --- a/src/yul_compile.ml +++ b/src/yul_compile.ml @@ -49,6 +49,7 @@ let letexp_to_yul = function EVM (Sload (FunctionCall (get_hash_slot, [ aval_to_yul h; aval_to_yul x ]))) | LApp (Caller, [ UnitV ]) -> EVM Caller + | LIf _ -> assert false | _ -> assert false let return_exp vals acc = @@ -76,6 +77,7 @@ let rec translate_body_aux e acc = | Letin (vars, e1, e2) -> let acc = Let ((List.hd vars, List.tl vars), letexp_to_yul e1) :: acc in translate_body_aux e2 acc + | If _ -> assert false let translate_function_body e = let statements, return_vars = translate_body_aux e [] in From 56c49fbe0af54bdf49452b64d4f9d58bae1ea8ba Mon Sep 17 00:00:00 2001 From: y-tak6 Date: Sat, 7 Sep 2024 01:30:29 +0900 Subject: [PATCH 2/4] added if-expression to yul_compile.ml --- src/anormal.ml | 28 ++++++++++++------ src/yul_compile.ml | 73 +++++++++++++++++++++++++++++++--------------- 2 files changed, 69 insertions(+), 32 deletions(-) diff --git a/src/anormal.ml b/src/anormal.ml index 130de39..1d87ec4 100644 --- a/src/anormal.ml +++ b/src/anormal.ml @@ -26,18 +26,23 @@ let application_mut mut = function | _ -> Abi.stronger_mutability Nonpayable mut let cexp_to_exp e = + let open Types in match e with | AVal v -> Rexp (RVal v) | AApp (f, args, t) -> ( - match Utils.count_vars_in_type t with - | Some vars -> - Letin - ( vars, - LApp (f, args), - Rexp (RTuple (List.map (fun x -> Var x) vars)) ) - | None -> - let res_var = Utils.fresh_var () in - Letin ([ res_var ], LApp (f, args), Rexp (RVal (Var res_var)))) + let x = (match get_desc t with Tconstr (Path.Pident p, [], _) -> if Ident.name p = "unit" then Some (Seq(LApp (f, args),Rexp (RVal UnitV))) else None| _ -> None) in + match x with + Some x' -> x' + | _ ->( + match Utils.count_vars_in_type t with + | Some vars -> + Letin + ( vars, + LApp (f, args), + Rexp (RTuple (List.map (fun x -> Var x) vars)) ) + | None -> + let res_var = Utils.fresh_var () in + Letin ([ res_var ], LApp (f, args), Rexp (RVal (Var res_var))))) | ATuple el -> Rexp (RTuple el) | AIf _ -> assert false @@ -76,6 +81,11 @@ let rec remove_tuple rename e mut : exp * Abi.state_mutability = | AApp (f, args, _), mut -> let e, mut = remove_tuple rename e2 mut in (Seq (LApp (f, args), e), mut) + | AIf (v, e11, e12), mut -> + let e11', mut1 = remove_tuple rename e11 mut in + let e12', mut2 = remove_tuple rename e12 mut in + let e, mut = remove_tuple rename e2 (Abi.stronger_mutability mut1 mut2) in + (Seq (LIf (v, e11', e12'), e), mut) | _ -> assert false) | ALetin ((vars, new_rename), e1, e2) -> ( let rename = new_rename @ rename in diff --git a/src/yul_compile.ml b/src/yul_compile.ml index 1b8cf45..d63cf2e 100644 --- a/src/yul_compile.ml +++ b/src/yul_compile.ml @@ -12,6 +12,22 @@ let aval_to_yul = function let translate_aval_args v = match v with UnitV -> None | _ -> Some (aval_to_yul v) +(* The case is divided by whether new variables for the return values are needed. + If ret_vars is empty, new variables are needed, and if not, ret_vars is the list of names of return values. *) +let return_exp vals acc (ret_vars:id list (*option*)) = + let vals = List.filter (fun x -> not (x = UnitV)) vals in + let rec assign_rets vals acc_exp acc_rets ret_vars'= + match vals with + | [] -> (acc_exp, acc_rets) + | v :: vs -> + let ret, ret_vars' = (match ret_vars' with [] -> Utils.fresh_var (), [] | hd :: tl -> hd, tl ) in + assign_rets vs + (Assign ((ret, []), aval_to_yul v) :: acc_exp) + (ret :: acc_rets) + ret_vars' + in + assign_rets vals acc [] ret_vars + let letexp_to_yul = function | LVal v -> aval_to_yul v | LApp (Var s, vals) -> @@ -49,38 +65,49 @@ let letexp_to_yul = function EVM (Sload (FunctionCall (get_hash_slot, [ aval_to_yul h; aval_to_yul x ]))) | LApp (Caller, [ UnitV ]) -> EVM Caller - | LIf _ -> assert false | _ -> assert false -let return_exp vals acc = - let vals = List.filter (fun x -> not (x = UnitV)) vals in - let rec assign_rets vals acc_exp acc_rets = - match vals with - | [] -> (acc_exp, acc_rets) - | v :: vs -> - let ret = Utils.fresh_var () in - assign_rets vs - (Assign ((ret, []), aval_to_yul v) :: acc_exp) - (ret :: acc_rets) - in - assign_rets vals acc [] - -let rec translate_body_aux e acc = + (* an argument "ret_vars" denotes the list of names of return variables. + if ret_vars is empty, it means we have to make new variables.*) +let rec translate_body_aux e acc ret_vars= match e with | Rexp e' -> ( match e' with - | RTuple vals -> return_exp vals acc - | RVal v -> return_exp [ v ] acc) + | RTuple vals -> return_exp vals acc ret_vars + | RVal v -> return_exp [ v ] acc ret_vars) | Seq (e1, e2) -> - let acc = Exp (letexp_to_yul e1) :: acc in - translate_body_aux e2 acc + let acc = (match e1 with LIf (v, e1', e2') -> + let e1_block, _ = translate_body_aux e1' [] [] in + let e1_block = List.rev e1_block in + let e2_block, _ = translate_body_aux e2' [] ret_vars in + let e2_block = List.rev e2_block in + let v = aval_to_yul v in + Switch (v, [Case(Bool true, e1_block); Case(Bool false, e2_block)], Default []) :: acc (*initialization with 0*) + | _ -> Exp (letexp_to_yul e1) :: acc) in + (* let acc = Exp (letexp_to_yul e1) :: acc in *) + translate_body_aux e2 acc ret_vars | Letin (vars, e1, e2) -> - let acc = Let ((List.hd vars, List.tl vars), letexp_to_yul e1) :: acc in - translate_body_aux e2 acc - | If _ -> assert false + let a = (match e1 with LIf (v, e1', e2') -> + let e1_block, _ = translate_body_aux e1' [] vars in + let e1_block = List.rev e1_block in + let e2_block, _ = translate_body_aux e2' [] vars in + let e2_block = List.rev e2_block in + let v = aval_to_yul v in + let acc = Switch (v, [Case(Bool true, e1_block); Case(Bool false, e2_block)], Default []) :: (Let((List.hd vars, List.tl vars), Literal (Dec 0))) :: acc in (*initialization with 0*) + translate_body_aux e2 acc ret_vars + |_ -> let acc = Let ((List.hd vars, List.tl vars), letexp_to_yul e1) :: acc in + translate_body_aux e2 acc ret_vars) in a + | If (v, e1, e2) -> + let e1', vars1 = translate_body_aux e1 acc ret_vars in + let e1' = List.rev e1' in + let e2', vars2 = translate_body_aux e2 acc vars1 in + let e2' = List.rev e2' in + assert (vars1 = vars2); + let v = aval_to_yul v in + Switch (v, [Case(Bool true, e1'); Case(Bool false, e2')], Default []) :: acc, vars1 let translate_function_body e = - let statements, return_vars = translate_body_aux e [] in + let statements, return_vars = translate_body_aux e [] [] in (List.rev statements, List.rev return_vars) let translate_function From a4ccb53736550918f82de718f0bbbfdeaa1992de Mon Sep 17 00:00:00 2001 From: y-tak6 Date: Thu, 19 Sep 2024 00:38:19 +0900 Subject: [PATCH 3/4] add a test for if, and a small revise --- sample/src/simple_hash_if.ml | 31 +++++++++++++++++++++++++++++++ src/ocamyul.ml | 2 +- src/yul_compile.ml | 2 +- 3 files changed, 33 insertions(+), 2 deletions(-) create mode 100644 sample/src/simple_hash_if.ml diff --git a/sample/src/simple_hash_if.ml b/sample/src/simple_hash_if.ml new file mode 100644 index 0000000..70acd17 --- /dev/null +++ b/sample/src/simple_hash_if.ml @@ -0,0 +1,31 @@ +open OCamYul.Primitives + +module SimpleHashIf : sig + type storage + type mut_storage + + val set : address * uint -> storage -> mut_storage -> unit * storage + val get : address -> storage -> mut_storage -> uint * storage + val set_caller : uint -> storage -> mut_storage -> unit * storage +end = struct + type storage = unit + type mut_storage = (address, uint) Hashtbl.t + + let set (x, y) () h = + (if true then let a = UInt 2 in let b = UInt 3 in let c = a +^ b in Hashtbl.replace h x y else ()); let a = if false then SInt 1 else SInt 2 in let b = SInt 2 in let c = a + b in + ((), ()) + + let get x () h = + let a = + if let c = true in c + then SInt 1 + else let b = if false + then SInt 3 + else SInt 4 in b + b + in (Hashtbl.find h x, ()) + + + let set_caller x () h = + Hashtbl.replace h (caller ()) x; + ((), ()) +end diff --git a/src/ocamyul.ml b/src/ocamyul.ml index e263236..29237ef 100644 --- a/src/ocamyul.ml +++ b/src/ocamyul.ml @@ -509,7 +509,7 @@ let backend source_file Typedtree.{ structure; _ } = ((dispatcher :: funcs) @ get_default_function_defs ()), None )) ) in - (* print_endline (string_of_yul yul_code) *) + (* print_endline (string_of_yul yul_code); *) let result_json = json_of_yul abis yul_code contract_name in write_json_contract source_file contract_name result_json | _ -> raise Not_implemented diff --git a/src/yul_compile.ml b/src/yul_compile.ml index d63cf2e..9b06fa4 100644 --- a/src/yul_compile.ml +++ b/src/yul_compile.ml @@ -82,7 +82,7 @@ let rec translate_body_aux e acc ret_vars= let e2_block, _ = translate_body_aux e2' [] ret_vars in let e2_block = List.rev e2_block in let v = aval_to_yul v in - Switch (v, [Case(Bool true, e1_block); Case(Bool false, e2_block)], Default []) :: acc (*initialization with 0*) + Switch (v, [Case(Dec 1, e1_block); Case(Dec 0, e2_block)], Default []) :: acc (*initialization with 0*) | _ -> Exp (letexp_to_yul e1) :: acc) in (* let acc = Exp (letexp_to_yul e1) :: acc in *) translate_body_aux e2 acc ret_vars From 653e1e01cbd5476bd2f2749ad58a9945a6c7446d Mon Sep 17 00:00:00 2001 From: y-tak6 Date: Mon, 23 Sep 2024 23:26:01 +0900 Subject: [PATCH 4/4] fix,and add readme about dune build --- README.md | 1 + src/yul_compile.ml | 4 ++-- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/README.md b/README.md index 15b3168..4176290 100644 --- a/README.md +++ b/README.md @@ -9,6 +9,7 @@ The compiler that: ## How to Build +At First, do `dune build` (this only needs to be done at the first build). By `dune exec ocamyulc //.ml`, `.json` file for `.ml` is generated and saved in `/contracts` directory. diff --git a/src/yul_compile.ml b/src/yul_compile.ml index 9b06fa4..a4790d6 100644 --- a/src/yul_compile.ml +++ b/src/yul_compile.ml @@ -93,7 +93,7 @@ let rec translate_body_aux e acc ret_vars= let e2_block, _ = translate_body_aux e2' [] vars in let e2_block = List.rev e2_block in let v = aval_to_yul v in - let acc = Switch (v, [Case(Bool true, e1_block); Case(Bool false, e2_block)], Default []) :: (Let((List.hd vars, List.tl vars), Literal (Dec 0))) :: acc in (*initialization with 0*) + let acc = Switch (v, [Case(Dec 1, e1_block); Case(Dec 0, e2_block)], Default []) :: (Let((List.hd vars, List.tl vars), Literal (Dec 0))) :: acc in (*initialization with 0*) translate_body_aux e2 acc ret_vars |_ -> let acc = Let ((List.hd vars, List.tl vars), letexp_to_yul e1) :: acc in translate_body_aux e2 acc ret_vars) in a @@ -104,7 +104,7 @@ let rec translate_body_aux e acc ret_vars= let e2' = List.rev e2' in assert (vars1 = vars2); let v = aval_to_yul v in - Switch (v, [Case(Bool true, e1'); Case(Bool false, e2')], Default []) :: acc, vars1 + Switch (v, [Case(Dec 1, e1'); Case(Dec 0, e2')], Default []) :: acc, vars1 let translate_function_body e = let statements, return_vars = translate_body_aux e [] [] in