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/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/anormal.ml b/src/anormal.ml index 35e6855..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 @@ -66,13 +71,21 @@ 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 | 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/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/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 cfaad3f..a4790d6 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) -> @@ -51,34 +67,47 @@ let letexp_to_yul = function | LApp (Caller, [ UnitV ]) -> EVM Caller | _ -> 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(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 | Letin (vars, e1, e2) -> - let acc = Let ((List.hd vars, List.tl vars), letexp_to_yul e1) :: acc in - translate_body_aux e2 acc + 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(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 + | 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(Dec 1, e1'); Case(Dec 0, 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