diff --git a/src/lib_utils/environment.ml b/src/lib_utils/environment.ml deleted file mode 100644 index ecb5839d2..000000000 --- a/src/lib_utils/environment.ml +++ /dev/null @@ -1,53 +0,0 @@ -module type PARAMETER = sig - type key - type value - val key_cmp : key -> key -> int - val value_cmp : value -> value -> int -end - -let parameter (type key value) ?key_cmp ?value_cmp () : (module PARAMETER with type key = key and type value = value) = - (module struct - type nonrec key = key - type nonrec value = value - let key_cmp = Option.unopt ~default:compare key_cmp - let value_cmp = Option.unopt ~default:compare value_cmp - end) - -let int_parameter = (parameter () : (module PARAMETER with type key = int and type value = int)) -module INT_PARAMETER = (val ((parameter () : (module PARAMETER with type key = int and type value = int)))) - -module type ENVIRONMENT = sig - type key - type value - type t - - val empty : t - val get_opt : t -> key -> value option - val gets : t -> key -> value list - val set : t -> key -> value -> t - val del : t -> key -> t -end - -module Make(P:PARAMETER) : ENVIRONMENT with type key = P.key and type value = P.value = struct - type key = P.key - type value = P.value - type t = (key * value) list - - let empty : t = [] - - let gets lst k = - let kvs = List.filter (fun (k', _) -> P.key_cmp k k' = 0) lst in - List.map snd kvs - let get_opt lst k = match gets lst k with - | [] -> None - | v :: _ -> Some v - - let set lst k v = (k, v) :: lst - - let del lst k = - let rec aux acc = function - | [] -> List.rev acc - | (key, _) :: tl when P.key_cmp key k = 0 -> List.rev acc @ tl - | hd :: tl -> aux (hd :: acc) tl in - aux [] lst -end diff --git a/src/lib_utils/location.ml b/src/lib_utils/location.ml index 8c85c9ee8..2c2bba58b 100644 --- a/src/lib_utils/location.ml +++ b/src/lib_utils/location.ml @@ -31,3 +31,6 @@ type 'a wrap = { let wrap ~loc wrap_content = { wrap_content ; location = loc } let unwrap { wrap_content ; _ } = wrap_content let map f x = { x with wrap_content = f x.wrap_content } + +let lift_region : 'a Region.reg -> 'a wrap = fun x -> + wrap ~loc:(File x.region) x.value diff --git a/src/lib_utils/tezos_utils.ml b/src/lib_utils/tezos_utils.ml index efa7804e7..3c7086378 100644 --- a/src/lib_utils/tezos_utils.ml +++ b/src/lib_utils/tezos_utils.ml @@ -19,7 +19,6 @@ module Cast = Cast module Tuple = Tuple module Map = X_map module Dictionary = Dictionary -module Environment = Environment module Tree = Tree module Region = Region module Pos = Pos diff --git a/src/lib_utils/x_memory_proto_alpha.ml b/src/lib_utils/x_memory_proto_alpha.ml index 90ad7803a..0fedfbd4f 100644 --- a/src/lib_utils/x_memory_proto_alpha.ml +++ b/src/lib_utils/x_memory_proto_alpha.ml @@ -25,11 +25,13 @@ let ty_eq (type a b) let parse_michelson (type aft) ?(tezos_context = dummy_environment.tezos_context) ?(top_level = Lambda) (michelson:Michelson.t) + ?type_logger (bef:'a Script_typed_ir.stack_ty) (aft:aft Script_typed_ir.stack_ty) = let michelson = Michelson.strip_annots michelson in let michelson = Michelson.strip_nops michelson in parse_instr + ?type_logger top_level tezos_context michelson bef >>=?? fun (j, _) -> match j with diff --git a/src/lib_utils/x_tezos_micheline.ml b/src/lib_utils/x_tezos_micheline.ml index 1cfea900f..8b6479b13 100644 --- a/src/lib_utils/x_tezos_micheline.ml +++ b/src/lib_utils/x_tezos_micheline.ml @@ -41,6 +41,7 @@ module Michelson = struct let i_some = prim I_SOME let i_lambda arg ret body = prim ~children:[arg;ret;body] I_LAMBDA let i_drop = prim I_DROP + let i_exec = prim I_EXEC let i_if a b = prim ~children:[a;b] I_IF let i_if_none a b = prim ~children:[a;b] I_IF_NONE diff --git a/src/ligo/ast_simplified.ml b/src/ligo/ast_simplified/ast_simplified.ml similarity index 100% rename from src/ligo/ast_simplified.ml rename to src/ligo/ast_simplified/ast_simplified.ml diff --git a/src/ligo/ast_simplified/dune b/src/ligo/ast_simplified/dune new file mode 100644 index 000000000..f0ffcc2f3 --- /dev/null +++ b/src/ligo/ast_simplified/dune @@ -0,0 +1,10 @@ +(library + (name ast_simplified) + (public_name ligo.ast_simplified) + (libraries + tezos-utils + ) + (preprocess + (pps ppx_let) + ) +) diff --git a/src/ligo/ast_typed.ml b/src/ligo/ast_typed/ast_typed.ml similarity index 100% rename from src/ligo/ast_typed.ml rename to src/ligo/ast_typed/ast_typed.ml diff --git a/src/ligo/ast_typed/dune b/src/ligo/ast_typed/dune new file mode 100644 index 000000000..0bda9cc00 --- /dev/null +++ b/src/ligo/ast_typed/dune @@ -0,0 +1,11 @@ +(library + (name ast_typed) + (public_name ligo.ast_typed) + (libraries + tezos-utils + ast_simplified ; Is that a good idea? + ) + (preprocess + (pps ppx_let) + ) +) diff --git a/src/ligo/compiler/compiler.ml b/src/ligo/compiler/compiler.ml new file mode 100644 index 000000000..1a306f0dc --- /dev/null +++ b/src/ligo/compiler/compiler.ml @@ -0,0 +1,4 @@ +module Uncompiler = Uncompiler +module Program = Compiler_program +module Type = Compiler_type +module Environment = Compiler_environment diff --git a/src/ligo/mini_c/compiler_environment.ml b/src/ligo/compiler/compiler_environment.ml similarity index 73% rename from src/ligo/mini_c/compiler_environment.ml rename to src/ligo/compiler/compiler_environment.ml index d7ea26e4d..727c706e2 100644 --- a/src/ligo/mini_c/compiler_environment.ml +++ b/src/ligo/compiler/compiler_environment.ml @@ -1,5 +1,6 @@ open Trace -open Types +open Mini_c +open Environment open Micheline open Memory_proto_alpha.Script_ir_translator @@ -8,61 +9,9 @@ module Stack = Meta_michelson.Stack type element = environment_element module Small = struct + open Small open Append_tree - type t' = environment_small' - type t = environment_small - - let not_in_env' ?source s t' = - let title () = match source with - | None -> "Not in environment" - | Some source -> Format.asprintf "Not in environment' (%s)" source in - let content () = - Format.asprintf "Variable : %s, Environment' : %a" - s PP.environment_small' t' in - error title content - - let not_in_env ?source s t = - let title () = match source with - | None -> "Not in environment" - | Some source -> Format.asprintf "Not in environment (%s)" source in - let content () = - Format.asprintf "Variable : %s, Environment : %a" - s PP.environment_small t in - error title content - - - let has' s = exists' (fun ((x, _):element) -> x = s) - let has s = function - | Empty -> false - | Full x -> has' s x - - let empty : t = empty - - let get_opt = assoc_opt - - let append s (e:t) = if has (fst s) e then e else append s e - - let of_list lst = - let rec aux = function - | [] -> Empty - | hd :: tl -> append hd (aux tl) - in - aux @@ List.rev lst - - - let rec to_list' (e:t') = - match e with - | Leaf x -> [x] - | Node {a;b} -> (to_list' a) @ (to_list' b) - - let to_list (e:t) = - match e with - | Empty -> [] - | Full x -> to_list' x - - type bound = string list - open Michelson let rec get_path' = fun s env' -> @@ -117,17 +66,6 @@ module Small = struct | Empty -> ok (dip i_drop) | Full x -> to_michelson_append' x - (* let rec to_mini_c_capture' env : _ -> expression result = function - * | Leaf (n, tv) -> ok (E_variable n, tv, env) - * | Node {a;b} -> - * let%bind ((_, ty_a, _) as a) = to_mini_c_capture' env a in - * let%bind ((_, ty_b, _) as b) = to_mini_c_capture' env b in - * ok (E_constant ("PAIR", [a;b]), (T_pair(ty_a, ty_b) : type_value), env) - * - * let to_mini_c_capture env = function - * | Empty -> simple_fail "to_mini_c_capture" - * | Full x -> to_mini_c_capture' env x *) - let rec to_mini_c_type' : _ -> type_value = function | Leaf (_, t) -> t | Node {a;b} -> T_pair(to_mini_c_type' a, to_mini_c_type' b) @@ -137,44 +75,14 @@ module Small = struct | Full x -> to_mini_c_type' x end -type t = environment - -let empty : t = [Small.empty] -let extend t : t = Small.empty :: t -let restrict t : t = List.tl t -let of_small small : t = [small] - -let rec get_opt : t -> string -> type_value option = fun t k -> - match t with - | [] -> None - | hd :: tl -> ( - match Small.get_opt hd k with - | None -> get_opt tl k - | Some v -> Some v - ) - -let rec has x : t -> bool = function - | [] -> raise (Failure "Schema.Big.has") - | [hd] -> Small.has x hd - | hd :: tl -> Small.has x hd || has x tl -let add x : t -> t = function - | [] -> raise (Failure "Schema.Big.add") - | hd :: tl -> Small.append x hd :: tl - -(* let init_function (f:type_value) (binder:string) : t = [Small.init_function binder f] *) - let to_michelson_extend : t -> Michelson.t = fun _e -> Michelson.i_comment "empty_extend" - (* Michelson.( - * seq [i_push_unit ; i_pair] - * ) *) let to_michelson_restrict : t -> Michelson.t result = fun e -> match e with | [] -> simple_fail "Restrict empty env" | Empty :: _ -> ok @@ Michelson.i_comment "restrict empty" | _ -> ok @@ Michelson.(seq [i_comment "restrict" ; i_cdr]) - (* Michelson.i_cdr *) let to_ty = Compiler_type.Ty.environment let to_michelson_type = Compiler_type.environment @@ -183,9 +91,6 @@ let rec to_mini_c_type = function | [hd] -> Small.to_mini_c_type hd | Append_tree.Empty :: tl -> to_mini_c_type tl | hd :: tl -> T_pair(Small.to_mini_c_type hd, to_mini_c_type tl) -(* let to_mini_c_capture = function - * | [a] -> Small.to_mini_c_capture a - * | _ -> raise (Failure "Schema.Big.to_mini_c_capture") *) type path = [`Left | `Right] list let pp_path : _ -> path -> unit = diff --git a/src/ligo/mini_c/compiler.ml b/src/ligo/compiler/compiler_program.ml similarity index 84% rename from src/ligo/mini_c/compiler.ml rename to src/ligo/compiler/compiler_program.ml index 5fb3969bb..1a1e8660c 100644 --- a/src/ligo/mini_c/compiler.ml +++ b/src/ligo/compiler/compiler_program.ml @@ -1,71 +1,32 @@ open Trace -open Types +open Mini_c module Michelson = Micheline.Michelson open Michelson -module Environment = Compiler_environment module Stack = Meta_michelson.Stack module Contract_types = Meta_michelson.Types open Memory_proto_alpha.Script_ir_translator -type predicate = - | Constant of michelson - | Unary of michelson - | Binary of michelson - | Ternary of michelson +open Operators.Compiler -let simple_constant c = Constant ( seq [ - c ; i_pair ; - ]) +let get_predicate : string -> expression list -> predicate result = fun s lst -> + match Map.String.find_opt s Operators.Compiler.predicates with + | Some x -> ok x + | None -> ( + match s with + | "MAP_REMOVE" -> + let%bind v = match lst with + | [ _ ; expr ] -> + let%bind (_, v) = Mini_c.Combinators.(get_t_map (Expression.get_type expr)) in + ok v + | _ -> simple_fail "mini_c . MAP_REMOVE" in + let%bind v_ty = Compiler_type.type_ v in + ok @@ simple_binary @@ seq [dip (i_none v_ty) ; prim I_UPDATE ] + | x -> simple_fail ("predicate \"" ^ x ^ "\" doesn't exist") + ) -let simple_unary c = Unary ( seq [ - i_unpair ; c ; i_pair ; - ]) - -let simple_binary c = Binary ( seq [ - i_unpair ; dip i_unpair ; i_swap ; c ; i_pair ; - ]) - -let simple_ternary c = Ternary ( seq [ - i_unpair ; dip i_unpair ; dip (dip i_unpair) ; i_swap ; dip i_swap ; i_swap ; c ; i_pair ; - ]) - -let rec get_predicate : string -> expression list -> predicate result = fun s lst -> - match s with - | "ADD_INT" -> ok @@ simple_binary @@ prim I_ADD - | "ADD_NAT" -> ok @@ simple_binary @@ prim I_ADD - | "TIMES_INT" -> ok @@ simple_binary @@ prim I_MUL - | "TIMES_NAT" -> ok @@ simple_binary @@ prim I_MUL - | "NEG" -> ok @@ simple_unary @@ prim I_NEG - | "OR" -> ok @@ simple_binary @@ prim I_OR - | "AND" -> ok @@ simple_binary @@ prim I_AND - | "PAIR" -> ok @@ simple_binary @@ prim I_PAIR - | "CAR" -> ok @@ simple_unary @@ prim I_CAR - | "CDR" -> ok @@ simple_unary @@ prim I_CDR - | "EQ" -> ok @@ simple_binary @@ seq [prim I_COMPARE ; prim I_EQ] - | "LT" -> ok @@ simple_binary @@ seq [prim I_COMPARE ; prim I_LT] - | "UPDATE" -> ok @@ simple_ternary @@ prim I_UPDATE - | "SOME" -> ok @@ simple_unary @@ prim I_SOME - | "GET_FORCE" -> ok @@ simple_binary @@ seq [prim I_GET ; i_assert_some] - | "GET" -> ok @@ simple_binary @@ prim I_GET - | "SIZE" -> ok @@ simple_unary @@ prim I_SIZE - | "INT" -> ok @@ simple_unary @@ prim I_INT - | "CONS" -> ok @@ simple_binary @@ prim I_CONS - (* | "CONS" -> ok @@ simple_binary @@ seq [prim I_SWAP ; prim I_CONS] *) - | "MAP_REMOVE" -> - let%bind v = match lst with - | [ _ ; expr ] -> - let%bind (_, v) = Combinators.(get_t_map (Expression.get_type expr)) in - ok v - | _ -> simple_fail "mini_c . MAP_REMOVE" in - let%bind v_ty = Compiler_type.type_ v in - ok @@ simple_binary @@ seq [dip (i_none v_ty) ; prim I_UPDATE ] - | "MAP_UPDATE" -> - ok @@ simple_ternary @@ seq [dip (i_some) ; prim I_UPDATE ] - | x -> simple_fail ("predicate \"" ^ x ^ "\" doesn't exist") - -and translate_value (v:value) : michelson result = match v with +let rec translate_value (v:value) : michelson result = match v with | D_bool b -> ok @@ prim (if b then D_True else D_False) | D_int n -> ok @@ int (Z.of_int n) | D_nat n -> ok @@ int (Z.of_int n) @@ -118,7 +79,7 @@ and translate_expression (expr:expression) : michelson result = let error_message () = Format.asprintf "%a" PP.expression expr in let return code = - let%bind (Ex_ty schema_ty) = Environment.to_ty env in + let%bind (Ex_ty schema_ty) = Compiler_environment.to_ty env in let%bind output_type = Compiler_type.type_ ty in let%bind (Ex_ty output_ty) = let error_message () = Format.asprintf "%a" Michelson.pp output_type in @@ -127,7 +88,7 @@ and translate_expression (expr:expression) : michelson result = let input_stack_ty = Stack.(Contract_types.unit @: schema_ty @: nil) in let output_stack_ty = Stack.(Contract_types.(pair output_ty unit) @: schema_ty @: nil) in let error_message () = - let%bind schema_michelson = Environment.to_michelson_type env in + let%bind schema_michelson = Compiler_environment.to_michelson_type env in ok @@ Format.asprintf "expression : %a\ncode : %a\nschema type : %a\noutput type : %a" PP.expression expr @@ -212,7 +173,7 @@ and translate_expression (expr:expression) : michelson result = | _ -> simple_fail "E_applicationing something not appliable" ) | E_variable x -> - let%bind (get, _) = Environment.to_michelson_get env x in + let%bind (get, _) = Compiler_environment.to_michelson_get env x in return @@ seq [ dip (seq [prim I_DUP ; get]) ; i_piar ; @@ -324,9 +285,9 @@ and translate_statement ((s', w_env) as s:statement) : michelson result = let%bind (code : michelson) = trace (fun () -> error (thunk "compiling statement") error_message ()) @@ match s' with | S_environment_extend -> - ok @@ Environment.to_michelson_extend w_env.pre_environment + ok @@ Compiler_environment.to_michelson_extend w_env.pre_environment | S_environment_restrict -> - Environment.to_michelson_restrict w_env.pre_environment + Compiler_environment.to_michelson_restrict w_env.pre_environment | S_environment_add _ -> simple_fail "not ready yet" (* | S_environment_add (name, tv) -> @@ -334,7 +295,7 @@ and translate_statement ((s', w_env) as s:statement) : michelson result = | S_declaration (s, expr) -> let tv = Combinators.Expression.get_type expr in let%bind expr = translate_expression expr in - let%bind add = Environment.to_michelson_add (s, tv) w_env.pre_environment in + let%bind add = Compiler_environment.to_michelson_add (s, tv) w_env.pre_environment in ok (seq [ i_comment "declaration" ; seq [ @@ -348,7 +309,7 @@ and translate_statement ((s', w_env) as s:statement) : michelson result = ]) | S_assignment (s, expr) -> let%bind expr = translate_expression expr in - let%bind set = Environment.to_michelson_set s w_env.pre_environment in + let%bind set = Compiler_environment.to_michelson_set s w_env.pre_environment in ok (seq [ i_comment "assignment" ; seq [ @@ -376,7 +337,7 @@ and translate_statement ((s', w_env) as s:statement) : michelson result = let%bind some' = translate_regular_block some in let%bind add = let env' = Environment.extend w_env.pre_environment in - Environment.to_michelson_add (name, tv) env' in + Compiler_environment.to_michelson_add (name, tv) env' in ok @@ (seq [ i_push_unit ; expr ; i_car ; prim ~children:[ @@ -389,11 +350,11 @@ and translate_statement ((s', w_env) as s:statement) : michelson result = let%bind block' = translate_regular_block block in let%bind restrict_block = let env_while = (snd block).pre_environment in - Environment.to_michelson_restrict env_while in + Compiler_environment.to_michelson_restrict env_while in ok @@ (seq [ i_push_unit ; expr ; i_car ; prim ~children:[seq [ - Environment.to_michelson_extend w_env.pre_environment; + Compiler_environment.to_michelson_extend w_env.pre_environment; block' ; restrict_block ; i_push_unit ; expr ; i_car]] I_LOOP ; @@ -402,7 +363,7 @@ and translate_statement ((s', w_env) as s:statement) : michelson result = let%bind expr' = translate_expression expr in let%bind (name_path, _) = Environment.get_path name w_env.pre_environment in let path = name_path @ lrs in - let set_code = Environment.path_to_michelson_set path in + let set_code = Compiler_environment.path_to_michelson_set path in ok @@ seq [ i_push_unit ; expr' ; i_car ; set_code ; @@ -410,13 +371,13 @@ and translate_statement ((s', w_env) as s:statement) : michelson result = in let%bind () = - let%bind (Ex_ty pre_ty) = Environment.to_ty w_env.pre_environment in + let%bind (Ex_ty pre_ty) = Compiler_environment.to_ty w_env.pre_environment in let input_stack_ty = Stack.(pre_ty @: nil) in - let%bind (Ex_ty post_ty) = Environment.to_ty w_env.post_environment in + let%bind (Ex_ty post_ty) = Compiler_environment.to_ty w_env.post_environment in let output_stack_ty = Stack.(post_ty @: nil) in let error_message () = - let%bind pre_env_michelson = Environment.to_michelson_type w_env.pre_environment in - let%bind post_env_michelson = Environment.to_michelson_type w_env.post_environment in + let%bind pre_env_michelson = Compiler_environment.to_michelson_type w_env.pre_environment in + let%bind post_env_michelson = Compiler_environment.to_michelson_type w_env.post_environment in ok @@ Format.asprintf "statement : %a\ncode : %a\npre type : %a\npost type : %a\n" PP.statement s @@ -446,7 +407,7 @@ and translate_regular_block ((b, env):block) : michelson result = in let%bind codes = let error_message () = - let%bind schema_michelson = Environment.to_michelson_type env.pre_environment in + let%bind schema_michelson = Compiler_environment.to_michelson_type env.pre_environment in ok @@ Format.asprintf "\nblock : %a\nschema : %a\n" PP.block (b, env) Tezos_utils.Micheline.Michelson.pp schema_michelson diff --git a/src/ligo/mini_c/compiler_type.ml b/src/ligo/compiler/compiler_type.ml similarity index 99% rename from src/ligo/mini_c/compiler_type.ml rename to src/ligo/compiler/compiler_type.ml index 482102f55..7bdccadc8 100644 --- a/src/ligo/mini_c/compiler_type.ml +++ b/src/ligo/compiler/compiler_type.ml @@ -1,5 +1,5 @@ open Trace -open Types +open Mini_c.Types open Tezos_utils.Memory_proto_alpha open Script_ir_translator diff --git a/src/ligo/compiler/dune b/src/ligo/compiler/dune new file mode 100644 index 000000000..29e2a801e --- /dev/null +++ b/src/ligo/compiler/dune @@ -0,0 +1,14 @@ +(library + (name compiler) + (public_name ligo.compiler) + (libraries + tezos-utils + meta_michelson + mini_c + operators + ) + (preprocess + (pps ppx_let) + ) + (flags (:standard -w +1..62-4-9-44-40-42-48-30@39@33 -open Tezos_utils )) +) diff --git a/src/ligo/mini_c/uncompiler.ml b/src/ligo/compiler/uncompiler.ml similarity index 99% rename from src/ligo/mini_c/uncompiler.ml rename to src/ligo/compiler/uncompiler.ml index 9cfb7199b..ce811b67b 100644 --- a/src/ligo/mini_c/uncompiler.ml +++ b/src/ligo/compiler/uncompiler.ml @@ -1,5 +1,5 @@ open Trace -open Types +open Mini_c.Types open Memory_proto_alpha open Script_typed_ir open Script_ir_translator diff --git a/src/ligo/contracts/arithmetic.ligo b/src/ligo/contracts/arithmetic.ligo index e229115cb..56e270120 100644 --- a/src/ligo/contracts/arithmetic.ligo +++ b/src/ligo/contracts/arithmetic.ligo @@ -1,6 +1,9 @@ function plus_op (const n : int) : int is begin skip end with n + 42 +function minus_op (const n : int) : int is + begin skip end with n - 42 + function times_op (const n : int) : int is begin skip end with n * 42 diff --git a/src/ligo/dune b/src/ligo/dune index 01f23cc07..f356faee8 100644 --- a/src/ligo/dune +++ b/src/ligo/dune @@ -15,8 +15,13 @@ tezos-micheline meta_michelson ligo_parser - mini_c multifix + ast_typed + ast_simplified + mini_c + operators + compiler + run ) (preprocess (pps ppx_let) diff --git a/src/ligo/ligo.ml b/src/ligo/ligo.ml index baaaa0795..154078da7 100644 --- a/src/ligo/ligo.ml +++ b/src/ligo/ligo.ml @@ -122,13 +122,13 @@ let transpile_value in let input = Mini_c.Combinators.d_unit in - let%bind r = Mini_c.Run.run_entry f input in + let%bind r = Run.Mini_c.run_entry f input in ok r let untranspile_value (v : Mini_c.value) (e:AST_Typed.type_value) : AST_Typed.annotated_expression result = Transpiler.untranspile v e -let compile : Mini_c.program -> string -> Mini_c.Compiler.compiled_program result = Mini_c.Compiler.translate_program +let compile : Mini_c.program -> string -> Compiler.Program.compiled_program result = Compiler.Program.translate_program let type_file ?(debug_simplify = false) ?(debug_typed = false) (path:string) : AST_Typed.program result = @@ -152,7 +152,7 @@ let easy_evaluate_typed (entry:string) (program:AST_Typed.program) : AST_Typed.a let%bind result = let%bind mini_c_main = transpile_entry program entry in - Mini_c.Run.run_entry mini_c_main (Mini_c.Combinators.d_unit) in + Run.Mini_c.run_entry mini_c_main (Mini_c.Combinators.d_unit) in let%bind typed_result = let%bind typed_main = Ast_typed.get_entry program entry in untranspile_value result typed_main.type_annotation in @@ -180,7 +180,7 @@ let easy_run_typed in error title content in trace error @@ - Mini_c.Run.run_entry mini_c_main mini_c_value in + Run.Mini_c.run_entry mini_c_main mini_c_value in let%bind typed_result = let%bind main_result_type = let%bind typed_main = Ast_typed.get_functional_entry program entry in diff --git a/src/ligo/mini_c/combinators_smart.ml b/src/ligo/mini_c/combinators_smart.ml index e5b0710aa..5733089cf 100644 --- a/src/ligo/mini_c/combinators_smart.ml +++ b/src/ligo/mini_c/combinators_smart.ml @@ -3,20 +3,20 @@ open Types open Combinators let basic_int_quote_env : environment = - let e = Compiler_environment.empty in - Compiler_environment.add ("input", t_int) e + let e = Environment.empty in + Environment.add ("input", t_int) e let statement s' env : statement = match s' with - | S_environment_extend -> s', environment_wrap env (Compiler_environment.extend env) - | S_environment_restrict -> s', environment_wrap env (Compiler_environment.restrict env) - | S_environment_add (name, tv) -> s' , environment_wrap env (Compiler_environment.add (name , tv) env) + | S_environment_extend -> s', environment_wrap env (Environment.extend env) + | S_environment_restrict -> s', environment_wrap env (Environment.restrict env) + | S_environment_add (name, tv) -> s' , environment_wrap env (Environment.add (name , tv) env) | S_cond _ -> s' , id_environment_wrap env | S_if_none _ -> s' , id_environment_wrap env | S_while _ -> s' , id_environment_wrap env | S_patch _ -> s' , id_environment_wrap env - | S_declaration (name , e) -> s', environment_wrap env (Compiler_environment.add (name , (Expression.get_type e)) env) - | S_assignment (name , e) -> s', environment_wrap env (Compiler_environment.add (name , (Expression.get_type e)) env) + | S_declaration (name , e) -> s', environment_wrap env (Environment.add (name , (Expression.get_type e)) env) + | S_assignment (name , e) -> s', environment_wrap env (Environment.add (name , (Expression.get_type e)) env) let block (statements:statement list) : block result = match statements with diff --git a/src/ligo/mini_c/environment.ml b/src/ligo/mini_c/environment.ml new file mode 100644 index 000000000..c16b70a1a --- /dev/null +++ b/src/ligo/mini_c/environment.ml @@ -0,0 +1,119 @@ +open Trace +open Types + +type element = environment_element + +module Small = struct + open Append_tree + + type t' = environment_small' + type t = environment_small + + let not_in_env' ?source s t' = + let title () = match source with + | None -> "Not in environment" + | Some source -> Format.asprintf "Not in environment' (%s)" source in + let content () = + Format.asprintf "Variable : %s, Environment' : %a" + s PP.environment_small' t' in + error title content + + let not_in_env ?source s t = + let title () = match source with + | None -> "Not in environment" + | Some source -> Format.asprintf "Not in environment (%s)" source in + let content () = + Format.asprintf "Variable : %s, Environment : %a" + s PP.environment_small t in + error title content + + + let has' s = exists' (fun ((x, _):element) -> x = s) + let has s = function + | Empty -> false + | Full x -> has' s x + + let empty : t = empty + + let get_opt = assoc_opt + + let append s (e:t) = if has (fst s) e then e else append s e + + let of_list lst = + let rec aux = function + | [] -> Empty + | hd :: tl -> append hd (aux tl) + in + aux @@ List.rev lst + + + let rec to_list' (e:t') = + match e with + | Leaf x -> [x] + | Node {a;b} -> (to_list' a) @ (to_list' b) + + let to_list (e:t) = + match e with + | Empty -> [] + | Full x -> to_list' x + + type bound = string list + + let rec get_path' = fun s env' -> + match env' with + | Leaf (n, v) when n = s -> ok ([], v) + | Leaf _ -> fail @@ not_in_env' ~source:"get_path'" s env' + | Node {a;b} -> + match%bind bind_lr @@ Tezos_utils.Tuple.map2 (get_path' s) (a,b) with + | `Left (lst, v) -> ok ((`Left :: lst), v) + | `Right (lst, v) -> ok ((`Right :: lst), v) + + let get_path = fun s env -> + match env with + | Empty -> fail @@ not_in_env ~source:"get_path" s env + | Full x -> get_path' s x +end + +type t = environment + +let empty : t = [Small.empty] +let extend t : t = Small.empty :: t +let restrict t : t = List.tl t +let of_small small : t = [small] + +let rec get_opt : t -> string -> type_value option = fun t k -> + match t with + | [] -> None + | hd :: tl -> ( + match Small.get_opt hd k with + | None -> get_opt tl k + | Some v -> Some v + ) + +let rec has x : t -> bool = function + | [] -> raise (Failure "Schema.Big.has") + | [hd] -> Small.has x hd + | hd :: tl -> Small.has x hd || has x tl +let add x : t -> t = function + | [] -> raise (Failure "Schema.Big.add") + | hd :: tl -> Small.append x hd :: tl + +type path = [`Left | `Right] list +let pp_path : _ -> path -> unit = + let open Format in + let aux ppf lr = match lr with + | `Left -> fprintf ppf "L" + | `Right -> fprintf ppf "R" + in + PP_helpers.(list_sep aux (const " ")) + +let rec get_path : string -> environment -> ([`Left | `Right] list * type_value) result = fun s t -> + match t with + | [] -> simple_fail "Get path : empty big schema" + | [ x ] -> Small.get_path s x + | Empty :: tl -> get_path s tl + | hd :: tl -> ( + match%bind bind_lr_lazy (Small.get_path s hd, (fun () -> get_path s tl)) with + | `Left (lst, v) -> ok (`Left :: lst, v) + | `Right (lst, v) -> ok (`Right :: lst, v) + ) diff --git a/src/ligo/mini_c/mini_c.ml b/src/ligo/mini_c/mini_c.ml index aa7f86780..c919abaae 100644 --- a/src/ligo/mini_c/mini_c.ml +++ b/src/ligo/mini_c/mini_c.ml @@ -1,3 +1,4 @@ +module Types = Types include Types module PP = PP @@ -5,8 +6,4 @@ module Combinators = struct include Combinators include Combinators_smart end -module Environment = Compiler_environment -module Compiler_type = Compiler_type -module Compiler = Compiler -module Uncompiler = Uncompiler -module Run = Run +module Environment = Environment diff --git a/src/ligo/operators/dune b/src/ligo/operators/dune index ad20103e6..7012dad18 100644 --- a/src/ligo/operators/dune +++ b/src/ligo/operators/dune @@ -1,4 +1,12 @@ (library (name operators) (public_name ligo.operators) + (libraries + tezos-utils + ast_typed + mini_c + ) + (preprocess + (pps ppx_let) + ) ) diff --git a/src/ligo/operators.ml b/src/ligo/operators/operators.ml similarity index 72% rename from src/ligo/operators.ml rename to src/ligo/operators/operators.ml index 257b48a01..4671fd348 100644 --- a/src/ligo/operators.ml +++ b/src/ligo/operators/operators.ml @@ -114,6 +114,11 @@ module Typer = struct | Some t -> ok ("NONE", t)) ] + let sub = "SUB" , 2 , [ + eq_2 (t_int ()) , constant_2 "SUB_INT" (t_int ()) ; + eq_2 (t_nat ()) , constant_2 "SUB_NAT" (t_int ()) ; + ] + let some = "SOME" , 1 , [ true_1 , typer'_1 (fun s -> ok ("SOME", t_option s ())) ; ] @@ -166,6 +171,7 @@ module Typer = struct ("TIMES_INT" , t_int ()) ; ("TIMES_NAT" , t_nat ()) ; ] ; + sub ; none ; some ; comparator "EQ" ; @@ -184,3 +190,56 @@ module Typer = struct end +module Compiler = struct + + module Michelson = Micheline.Michelson + open Michelson + + type predicate = + | Constant of michelson + | Unary of michelson + | Binary of michelson + | Ternary of michelson + + let simple_constant c = Constant ( seq [ + c ; i_pair ; + ]) + + let simple_unary c = Unary ( seq [ + i_unpair ; c ; i_pair ; + ]) + + let simple_binary c = Binary ( seq [ + i_unpair ; dip i_unpair ; i_swap ; c ; i_pair ; + ]) + + let simple_ternary c = Ternary ( seq [ + i_unpair ; dip i_unpair ; dip (dip i_unpair) ; i_swap ; dip i_swap ; i_swap ; c ; i_pair ; + ]) + + let predicates = Map.String.of_list [ + ("ADD_INT" , simple_binary @@ prim I_ADD) ; + ("ADD_NAT" , simple_binary @@ prim I_ADD) ; + ("SUB_INT" , simple_binary @@ prim I_SUB) ; + ("SUB_NAT" , simple_binary @@ prim I_SUB) ; + ("TIMES_INT" , simple_binary @@ prim I_MUL) ; + ("TIMES_NAT" , simple_binary @@ prim I_MUL) ; + ("NEG" , simple_unary @@ prim I_NEG) ; + ("OR" , simple_binary @@ prim I_OR) ; + ("AND" , simple_binary @@ prim I_AND) ; + ("PAIR" , simple_binary @@ prim I_PAIR) ; + ("CAR" , simple_unary @@ prim I_CAR) ; + ("CDR" , simple_unary @@ prim I_CDR) ; + ("EQ" , simple_binary @@ seq [prim I_COMPARE ; prim I_EQ]) ; + ("LT" , simple_binary @@ seq [prim I_COMPARE ; prim I_LT]) ; + ("UPDATE" , simple_ternary @@ prim I_UPDATE) ; + ("SOME" , simple_unary @@ prim I_SOME) ; + ("GET_FORCE" , simple_binary @@ seq [prim I_GET ; i_assert_some]) ; + ("GET" , simple_binary @@ prim I_GET) ; + ("SIZE" , simple_unary @@ prim I_SIZE) ; + ("INT" , simple_unary @@ prim I_INT) ; + ("CONS" , simple_binary @@ prim I_CONS) ; + ( "MAP_UPDATE" , simple_ternary @@ seq [dip (i_some) ; prim I_UPDATE ]) ; + ] + +end diff --git a/src/ligo/run/dune b/src/ligo/run/dune new file mode 100644 index 000000000..e83df6416 --- /dev/null +++ b/src/ligo/run/dune @@ -0,0 +1,14 @@ +(library + (name run) + (public_name ligo.run) + (libraries + tezos-utils + meta_michelson + mini_c + compiler + ) + (preprocess + (pps ppx_let) + ) + (flags (:standard -w +1..62-4-9-44-40-42-48-30@39@33 -open Tezos_utils )) +) diff --git a/src/ligo/mini_c/run.ml b/src/ligo/run/from_mini_c.ml similarity index 89% rename from src/ligo/mini_c/run.ml rename to src/ligo/run/from_mini_c.ml index 5d77d1fb3..9919b73b4 100644 --- a/src/ligo/mini_c/run.ml +++ b/src/ligo/run/from_mini_c.ml @@ -1,10 +1,10 @@ open Trace -open Types -open Compiler +open Mini_c +open Compiler.Program open Memory_proto_alpha.Script_ir_translator let run_aux (program:compiled_program) (input_michelson:Michelson.t) : ex_typed_value result = - let Compiler.{input;output;body} : compiled_program = program in + let Compiler.Program.{input;output;body} : compiled_program = program in let (Ex_ty input_ty) = input in let (Ex_ty output_ty) = output in let%bind input = @@ -41,14 +41,14 @@ let run_entry (entry:anon_function) (input:value) : value result = translate_entry entry in let%bind input_michelson = translate_value input in let%bind ex_ty_value = run_aux compiled input_michelson in - let%bind (result : value) = Uncompiler.translate_value ex_ty_value in + let%bind (result : value) = Compiler.Uncompiler.translate_value ex_ty_value in ok result let run (program:program) (input:value) : value result = let%bind input_michelson = translate_value input in let%bind compiled = translate_program program "main" in let%bind ex_ty_value = run_aux compiled input_michelson in - let%bind (result : value) = Uncompiler.translate_value ex_ty_value in + let%bind (result : value) = Compiler.Uncompiler.translate_value ex_ty_value in ok result let expression_to_value (e:expression) : value result = diff --git a/src/ligo/run/run.ml b/src/ligo/run/run.ml new file mode 100644 index 000000000..566d43c8a --- /dev/null +++ b/src/ligo/run/run.ml @@ -0,0 +1 @@ +module Mini_c = From_mini_c diff --git a/src/ligo/simplify.ml b/src/ligo/simplify.ml index 30cf4af65..47ae1154c 100644 --- a/src/ligo/simplify.ml +++ b/src/ligo/simplify.ml @@ -144,6 +144,8 @@ let rec simpl_expression (t:Raw.expr) : ae result = ok @@ annotated_expression (E_constant ("NONE", [])) (Some (Combinators.t_option type_expr')) | EArith (Add c) -> simpl_binop "ADD" c.value + | EArith (Sub c) -> + simpl_binop "SUB" c.value | EArith (Mult c) -> simpl_binop "TIMES" c.value | EArith (Int n) -> diff --git a/src/ligo/test/compiler_tests.ml b/src/ligo/test/compiler_tests.ml index 3d0176410..439b00651 100644 --- a/src/ligo/test/compiler_tests.ml +++ b/src/ligo/test/compiler_tests.ml @@ -5,7 +5,7 @@ open Test_helpers let run_entry_int (e:anon_function) (n:int) : int result = let param : value = D_int n in - let%bind result = Run.run_entry e param in + let%bind result = Run.Mini_c.run_entry e param in match result with | D_int n -> ok n | _ -> simple_fail "result is not an int" diff --git a/src/ligo/test/integration_tests.ml b/src/ligo/test/integration_tests.ml index bf1dca41b..576a1289e 100644 --- a/src/ligo/test/integration_tests.ml +++ b/src/ligo/test/integration_tests.ml @@ -164,8 +164,9 @@ let arithmetic () : unit result = @@ List.map aux @@ [ ("plus_op", fun n -> e_a_int (n + 42)) ; + ("minus_op", fun n -> e_a_int (n - 42)) ; ("times_op", fun n -> e_a_int (n * 42)) ; - (* ("int_op", fun n -> e_a_int n) ; *) + ("int_op", fun n -> e_a_int n) ; ] in ok ()