balsoft/ligo
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

major refactoring ; now easy to add new operators

Browse Source
This commit is contained in:
Galfour 2019-04-19 09:27:34 +00:00
parent eaf749cbc5
commit 280981c73b
29 changed files with 317 additions and 251 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

53
src/lib_utils/environment.ml
View File

@ -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

3
src/lib_utils/location.ml
View File

@ -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

1
src/lib_utils/tezos_utils.ml
View File

@ -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

2
src/lib_utils/x_memory_proto_alpha.ml
View File

@ -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

1
src/lib_utils/x_tezos_micheline.ml
View File

@ -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

0
src/ligo/ast_simplified.ml → src/ligo/ast_simplified/ast_simplified.ml
View File

10
src/ligo/ast_simplified/dune Normal file
View File

@ -0,0 +1,10 @@
(library
(name ast_simplified)
(public_name ligo.ast_simplified)
(libraries
tezos-utils
)
(preprocess
(pps ppx_let)
)
)

0
src/ligo/ast_typed.ml → src/ligo/ast_typed/ast_typed.ml
View File

11
src/ligo/ast_typed/dune Normal file
View File

@ -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)
)
)

4
src/ligo/compiler/compiler.ml Normal file
View File

@ -0,0 +1,4 @@
module Uncompiler = Uncompiler
module Program = Compiler_program
module Type = Compiler_type
module Environment = Compiler_environment

101
src/ligo/mini_c/compiler_environment.ml → src/ligo/compiler/compiler_environment.ml
View File

@ -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 =

107
src/ligo/mini_c/compiler.ml → src/ligo/compiler/compiler_program.ml
View File

@ -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

2
src/ligo/mini_c/compiler_type.ml → src/ligo/compiler/compiler_type.ml
View File

@ -1,5 +1,5 @@
open Trace
open Types
open Mini_c.Types
open Tezos_utils.Memory_proto_alpha
open Script_ir_translator

14
src/ligo/compiler/dune Normal file
View File

@ -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 ))
)

2
src/ligo/mini_c/uncompiler.ml → src/ligo/compiler/uncompiler.ml
View File

@ -1,5 +1,5 @@
open Trace
open Types
open Mini_c.Types
open Memory_proto_alpha
open Script_typed_ir
open Script_ir_translator

3
src/ligo/contracts/arithmetic.ligo
View File

@ -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

7
src/ligo/dune
View File

@ -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)

8
src/ligo/ligo.ml
View File

@ -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

14
src/ligo/mini_c/combinators_smart.ml
View File

@ -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

119
src/ligo/mini_c/environment.ml Normal file
View File

@ -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)
)

7
src/ligo/mini_c/mini_c.ml
View File

@ -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

8
src/ligo/operators/dune
View File

@ -1,4 +1,12 @@
(library
(name operators)
(public_name ligo.operators)
(libraries
tezos-utils
ast_typed
mini_c
)
(preprocess
(pps ppx_let)
)
)

59
src/ligo/operators.ml → src/ligo/operators/operators.ml
View File

@ -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

14
src/ligo/run/dune Normal file
View File

@ -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 ))
)

10
src/ligo/mini_c/run.ml → src/ligo/run/from_mini_c.ml
View File

@ -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 =

1
src/ligo/run/run.ml Normal file
View File

@ -0,0 +1 @@
module Mini_c = From_mini_c

2
src/ligo/simplify.ml
View File

@ -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) ->

2
src/ligo/test/compiler_tests.ml
View File

@ -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"

3
src/ligo/test/integration_tests.ml
View File

@ -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 ()