CatalaLang/catala
1
1
Fork 0
mirror of https://github.com/CatalaLang/catala.git synced 2024-09-19 16:28:12 +03:00
Code Issues Projects Releases Wiki Activity

Additional cleanup/fixes on the compiler refactoring

Browse Source 
following review ^^
This commit is contained in:
Louis Gesbert 2022-08-22 18:53:30 +02:00
parent 576e0fb3ff
commit 4caf828e48
31 changed files with 249 additions and 288 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
compiler/dcalc/interpreter.ml
View File

@ -18,7 +18,6 @@
open Utils
open Shared_ast
module A = Ast
module Runtime = Runtime_ocaml.Runtime
(** {1 Helpers} *)
@ -48,15 +47,15 @@ let rec evaluate_operator
"division by zero at runtime"
in
let get_binop_args_pos = function
| (arg0 :: arg1 :: _ : 'm A.marked_expr list) ->
| (arg0 :: arg1 :: _ : 'm Ast.marked_expr list) ->
[None, Expr.pos arg0; None, Expr.pos arg1]
| _ -> assert false
in
(* Try to apply [cmp] and if a [UncomparableDurations] exceptions is catched,
use [args] to raise multispanned errors. *)
let apply_cmp_or_raise_err
(cmp : unit -> 'm A.expr)
(args : 'm A.marked_expr list) : 'm A.expr =
(cmp : unit -> 'm Ast.expr)
(args : 'm Ast.marked_expr list) : 'm Ast.expr =
try cmp ()
with Runtime.UncomparableDurations ->
Errors.raise_multispanned_error (get_binop_args_pos args)

24
compiler/dcalc/typing.ml
View File

@ -46,22 +46,22 @@ and typ =
let rec typ_to_ast (ty : unionfind_typ) : A.marked_typ =
let ty, pos = UnionFind.get (UnionFind.find ty) in
match ty with
| TLit l -> TLit l, pos
| TTuple (ts, s) -> TTuple (List.map typ_to_ast ts, s), pos
| TEnum (ts, e) -> TEnum (List.map typ_to_ast ts, e), pos
| TArrow (t1, t2) -> TArrow (typ_to_ast t1, typ_to_ast t2), pos
| TAny _ -> TAny, pos
| TArray t1 -> TArray (typ_to_ast t1), pos
| TLit l -> A.TLit l, pos
| TTuple (ts, s) -> A.TTuple (List.map typ_to_ast ts, s), pos
| TEnum (ts, e) -> A.TEnum (List.map typ_to_ast ts, e), pos
| TArrow (t1, t2) -> A.TArrow (typ_to_ast t1, typ_to_ast t2), pos
| TAny _ -> A.TAny, pos
| TArray t1 -> A.TArray (typ_to_ast t1), pos
let rec ast_to_typ (ty : A.marked_typ) : unionfind_typ =
let ty' =
match Marked.unmark ty with
| TLit l -> TLit l
| TArrow (t1, t2) -> TArrow (ast_to_typ t1, ast_to_typ t2)
| TTuple (ts, s) -> TTuple (List.map (fun t -> ast_to_typ t) ts, s)
| TEnum (ts, e) -> TEnum (List.map (fun t -> ast_to_typ t) ts, e)
| TArray t -> TArray (ast_to_typ t)
| TAny -> TAny (Any.fresh ())
| A.TLit l -> TLit l
| A.TArrow (t1, t2) -> TArrow (ast_to_typ t1, ast_to_typ t2)
| A.TTuple (ts, s) -> TTuple (List.map (fun t -> ast_to_typ t) ts, s)
| A.TEnum (ts, e) -> TEnum (List.map (fun t -> ast_to_typ t) ts, e)
| A.TArray t -> TArray (ast_to_typ t)
| A.TAny -> TAny (Any.fresh ())
in
UnionFind.make (Marked.same_mark_as ty' ty)

2
compiler/desugared/ast.ml
View File

@ -460,7 +460,7 @@ let make_let_in
(e2 : expr Marked.pos Bindlib.box) : expr Marked.pos Bindlib.box =
Bindlib.box_apply2
(fun e u -> EApp (e, u), Marked.get_mark (Bindlib.unbox e2))
(make_abs (Array.of_list [x]) e2 [tau] (Marked.get_mark (Bindlib.unbox e2)))
(make_abs [| x |] e2 [tau] (Marked.get_mark (Bindlib.unbox e2)))
(Bindlib.box_list [e1])
module VarMap = Map.Make (Var)

2
compiler/desugared/desugared_to_scope.ml
View File

@ -297,7 +297,7 @@ let rec rule_tree_to_expr
default
in
Scopelang.Ast.make_abs
(Array.of_list [Ast.VarMap.find new_param ctx.var_mapping])
[| Ast.VarMap.find new_param ctx.var_mapping |]
default [typ] def_pos
else default
| _ -> (* should not happen *) assert false

65
compiler/lcalc/ast.ml
View File

@ -16,7 +16,6 @@
open Utils
include Shared_ast
module D = Dcalc.Ast
type lit = lcalc glit
@ -24,48 +23,7 @@ type 'm expr = (lcalc, 'm mark) gexpr
and 'm marked_expr = (lcalc, 'm mark) marked_gexpr
type 'm program = 'm expr Shared_ast.program
type 'm var = 'm expr Var.t
type 'm vars = 'm expr Var.vars
let make_var (x, mark) =
Bindlib.box_apply (fun x -> x, mark) (Bindlib.box_var x)
let make_abs xs e taus mark =
Bindlib.box_apply (fun b -> EAbs (b, taus), mark) (Bindlib.bind_mvar xs e)
let make_app e u mark =
Bindlib.box_apply2 (fun e u -> EApp (e, u), mark) e (Bindlib.box_list u)
let make_let_in x tau e1 e2 pos =
let m_e1 = Marked.get_mark (Bindlib.unbox e1) in
let m_e2 = Marked.get_mark (Bindlib.unbox e2) in
let m_abs =
Expr.map_mark2
(fun _ _ -> pos)
(fun m1 m2 -> TArrow (m1.ty, m2.ty), m1.pos)
m_e1 m_e2
in
make_app (make_abs [| x |] e2 [tau] m_abs) [e1] m_e2
let make_multiple_let_in xs taus e1s e2 pos =
(* let m_e1s = List.map (fun e -> Marked.get_mark (Bindlib.unbox e)) e1s in *)
let m_e1s =
Expr.fold_marks List.hd
(fun tys ->
TTuple (List.map (fun t -> t.ty) tys, None), (List.hd tys).pos)
(List.map (fun e -> Marked.get_mark (Bindlib.unbox e)) e1s)
in
let m_e2 = Marked.get_mark (Bindlib.unbox e2) in
let m_abs =
Expr.map_mark2
(fun _ _ -> pos)
(fun m1 m2 -> Marked.mark pos (TArrow (m1.ty, m2.ty)))
m_e1s m_e2
in
make_app (make_abs xs e2 taus m_abs) e1s m_e2
let ( let+ ) x f = Bindlib.box_apply f x
let ( and+ ) x y = Bindlib.box_pair x y
let option_enum : EnumName.t = EnumName.fresh ("eoption", Pos.no_pos)
let none_constr : EnumConstructor.t = EnumConstructor.fresh ("ENone", Pos.no_pos)
let some_constr : EnumConstructor.t = EnumConstructor.fresh ("ESome", Pos.no_pos)
@ -91,10 +49,15 @@ let make_none m =
let make_some e =
let m = Marked.get_mark @@ Bindlib.unbox e in
let mark = Marked.mark m in
let+ e in
mark
@@ EInj
(e, 1, option_enum, [TLit TUnit, Expr.mark_pos m; TAny, Expr.mark_pos m])
Bindlib.box_apply
(fun e ->
mark
@@ EInj
( e,
1,
option_enum,
[TLit TUnit, Expr.mark_pos m; TAny, Expr.mark_pos m] ))
e
(** [make_matchopt_with_abs_arms arg e_none e_some] build an expression
[match arg with |None -> e_none | Some -> e_some] and requires e_some and
@ -102,8 +65,10 @@ let make_some e =
let make_matchopt_with_abs_arms arg e_none e_some =
let m = Marked.get_mark @@ Bindlib.unbox arg in
let mark = Marked.mark m in
let+ arg and+ e_none and+ e_some in
mark @@ EMatch (arg, [e_none; e_some], option_enum)
Bindlib.box_apply3
(fun arg e_none e_some ->
mark @@ EMatch (arg, [e_none; e_some], option_enum))
arg e_none e_some
(** [make_matchopt pos v tau arg e_none e_some] builds an expression
[match arg with | None () -> e_none | Some v -> e_some]. It binds v to
@ -113,8 +78,8 @@ let make_matchopt m v tau arg e_none e_some =
let x = Var.make "_" in
make_matchopt_with_abs_arms arg
(make_abs (Array.of_list [x]) e_none [TLit TUnit, Expr.mark_pos m] m)
(make_abs (Array.of_list [v]) e_some [tau] m)
(Expr.make_abs [| x |] e_none [TLit TUnit, Expr.mark_pos m] m)
(Expr.make_abs [| v |] e_some [tau] m)
let handle_default = Var.make "handle_default"
let handle_default_opt = Var.make "handle_default_opt"

42
compiler/lcalc/ast.mli
View File

@ -28,44 +28,8 @@ and 'm marked_expr = (lcalc, 'm mark) marked_gexpr
type 'm program = 'm expr Shared_ast.program
(** {1 Variable helpers} *)
type 'm var = 'm expr Var.t
type 'm vars = 'm expr Var.vars
(** {1 Language terms construction}*)
val make_var : ('m var, 'm mark) Marked.t -> 'm marked_expr Bindlib.box
val make_abs :
'm vars ->
'm marked_expr Bindlib.box ->
typ Marked.pos list ->
'm mark ->
'm marked_expr Bindlib.box
val make_app :
'm marked_expr Bindlib.box ->
'm marked_expr Bindlib.box list ->
'm mark ->
'm marked_expr Bindlib.box
val make_let_in :
'm var ->
typ Marked.pos ->
'm marked_expr Bindlib.box ->
'm marked_expr Bindlib.box ->
Pos.t ->
'm marked_expr Bindlib.box
val make_multiple_let_in :
'm vars ->
typ Marked.pos list ->
'm marked_expr Bindlib.box list ->
'm marked_expr Bindlib.box ->
Pos.t ->
'm marked_expr Bindlib.box
val option_enum : EnumName.t
val none_constr : EnumConstructor.t
val some_constr : EnumConstructor.t
@ -81,7 +45,7 @@ val make_matchopt_with_abs_arms :
val make_matchopt :
'm mark ->
'm var ->
'm expr Var.t ->
typ Marked.pos ->
'm marked_expr Bindlib.box ->
'm marked_expr Bindlib.box ->
@ -92,5 +56,5 @@ val make_matchopt :
(** {1 Special symbols} *)
val handle_default : untyped var
val handle_default_opt : untyped var
val handle_default : untyped expr Var.t
val handle_default_opt : untyped expr Var.t

10
compiler/lcalc/closure_conversion.ml
View File

@ -139,7 +139,7 @@ let closure_conversion_expr (type m) (ctx : m ctx) (e : m marked_expr) :
let inner_c_var = Var.make "env" in
let any_ty = TAny, binder_pos in
let new_closure_body =
make_multiple_let_in
Expr.make_multiple_let_in
(Array.of_list extra_vars_list)
(List.map (fun _ -> any_ty) extra_vars_list)
(List.mapi
@ -158,13 +158,13 @@ let closure_conversion_expr (type m) (ctx : m ctx) (e : m marked_expr) :
(Expr.mark_pos binder_mark)
in
let new_closure =
make_abs
Expr.make_abs
(Array.concat [Array.make 1 inner_c_var; vars])
new_closure_body
((TAny, binder_pos) :: typs)
(Marked.get_mark e)
in
( make_let_in code_var
( Expr.make_let_in code_var
(TAny, Expr.pos e)
new_closure
(Bindlib.box_apply2
@ -223,7 +223,7 @@ let closure_conversion_expr (type m) (ctx : m ctx) (e : m marked_expr) :
args ([], free_vars)
in
let call_expr =
make_let_in code_var
Expr.make_let_in code_var
(TAny, Expr.pos e)
(Bindlib.box_apply
(fun env_var ->
@ -241,7 +241,7 @@ let closure_conversion_expr (type m) (ctx : m ctx) (e : m marked_expr) :
(Bindlib.box_list new_args))
(Expr.pos e)
in
( make_let_in env_var (TAny, Expr.pos e) new_e1 call_expr (Expr.pos e),
( Expr.make_let_in env_var (TAny, Expr.pos e) new_e1 call_expr (Expr.pos e),
free_vars )
| EAssert e1 ->
let new_e1, free_vars = aux e1 in

8
compiler/lcalc/compile_with_exceptions.ml
View File

@ -37,7 +37,7 @@ let translate_lit (l : D.lit) : 'm A.expr =
let thunk_expr (e : 'm A.marked_expr Bindlib.box) (mark : 'm mark) :
'm A.marked_expr Bindlib.box =
let dummy_var = Var.make "_" in
A.make_abs [| dummy_var |] e [TAny, Expr.mark_pos mark] mark
Expr.make_abs [| dummy_var |] e [TAny, Expr.mark_pos mark] mark
let rec translate_default
(ctx : 'm ctx)
@ -51,8 +51,8 @@ let rec translate_default
exceptions
in
let exceptions =
A.make_app
(A.make_var (Var.translate A.handle_default, mark_default))
Expr.make_app
(Expr.make_var (Var.translate A.handle_default, mark_default))
[
Expr.earray exceptions mark_default;
thunk_expr (translate_expr ctx just) mark_default;
@ -65,7 +65,7 @@ let rec translate_default
and translate_expr (ctx : 'm ctx) (e : 'm D.marked_expr) :
'm A.marked_expr Bindlib.box =
match Marked.unmark e with
| EVar v -> A.make_var (Var.Map.find v ctx, Marked.get_mark e)
| EVar v -> Expr.make_var (Var.Map.find v ctx, Marked.get_mark e)
| ETuple (args, s) ->
Expr.etuple (List.map (translate_expr ctx) args) s (Marked.get_mark e)
| ETupleAccess (e1, i, s, ts) ->

24
compiler/lcalc/compile_without_exceptions.ml
View File

@ -103,7 +103,7 @@ let add_var
(is_pure : bool)
(ctx : 'm ctx) : 'm ctx =
let new_var = Var.make (Bindlib.name_of var) in
let expr = A.make_var (new_var, mark) in
let expr = Expr.make_var (new_var, mark) in
(* Cli.debug_print @@ Format.asprintf "D.%a |-> A.%a" Print.var var Print.var
new_var; *)
@ -185,23 +185,23 @@ let rec translate_and_hoist (ctx : 'm ctx) (e : 'm D.marked_expr) :
let v' = Var.make (Bindlib.name_of v) in
(* Cli.debug_print @@ Format.asprintf "Found an unpure variable %a,
created a variable %a to replace it" Print.var v Print.var v'; *)
A.make_var (v', pos), Var.Map.singleton v' e
Expr.make_var (v', pos), Var.Map.singleton v' e
else (find ~info:"should never happend" v ctx).expr, Var.Map.empty
| EApp ((EVar v, p), [(ELit LUnit, _)]) ->
if not (find ~info:"search for a variable" v ctx).is_pure then
let v' = Var.make (Bindlib.name_of v) in
(* Cli.debug_print @@ Format.asprintf "Found an unpure variable %a,
created a variable %a to replace it" Print.var v Print.var v'; *)
A.make_var (v', pos), Var.Map.singleton v' (EVar v, p)
Expr.make_var (v', pos), Var.Map.singleton v' (EVar v, p)
else
Errors.raise_spanned_error (Expr.pos e)
"Internal error: an pure variable was found in an unpure environment."
| EDefault (_exceptions, _just, _cons) ->
let v' = Var.make "default_term" in
A.make_var (v', pos), Var.Map.singleton v' e
Expr.make_var (v', pos), Var.Map.singleton v' e
| ELit LEmptyError ->
let v' = Var.make "empty_litteral" in
A.make_var (v', pos), Var.Map.singleton v' e
Expr.make_var (v', pos), Var.Map.singleton v' e
(* This one is a very special case. It transform an unpure expression
environement to a pure expression. *)
| ErrorOnEmpty arg ->
@ -212,11 +212,11 @@ let rec translate_and_hoist (ctx : 'm ctx) (e : 'm D.marked_expr) :
let arg' = translate_expr ctx arg in
( A.make_matchopt_with_abs_arms arg'
(A.make_abs [| silent_var |]
(Expr.make_abs [| silent_var |]
(Bindlib.box (ERaise NoValueProvided, pos))
[TAny, Expr.pos e]
pos)
(A.make_abs [| x |] (A.make_var (x, pos)) [TAny, Expr.pos e] pos),
(Expr.make_abs [| x |] (Expr.make_var (x, pos)) [TAny, Expr.pos e] pos),
Var.Map.empty )
(* pure terms *)
| ELit l -> Expr.elit (translate_lit l (Expr.pos e)) pos, Var.Map.empty
@ -323,8 +323,8 @@ and translate_expr ?(append_esome = true) (ctx : 'm ctx) (e : 'm D.marked_expr)
let just' = translate_expr ctx just in
let cons' = translate_expr ctx cons in
(* calls handle_option. *)
A.make_app
(A.make_var (Var.translate A.handle_default_opt, mark_hoist))
Expr.make_app
(Expr.make_var (Var.translate A.handle_default_opt, mark_hoist))
[
Bindlib.box_apply
(fun excep' -> EArray excep', mark_hoist)
@ -343,14 +343,14 @@ and translate_expr ?(append_esome = true) (ctx : 'm ctx) (e : 'm D.marked_expr)
let x = Var.make "assertion_argument" in
A.make_matchopt_with_abs_arms arg'
(A.make_abs [| silent_var |]
(Expr.make_abs [| silent_var |]
(Bindlib.box (ERaise NoValueProvided, mark_hoist))
[TAny, Expr.mark_pos mark_hoist]
mark_hoist)
(A.make_abs [| x |]
(Expr.make_abs [| x |]
(Bindlib.box_apply
(fun arg -> EAssert arg, mark_hoist)
(A.make_var (x, mark_hoist)))
(Expr.make_var (x, mark_hoist)))
[TAny, Expr.mark_pos mark_hoist]
mark_hoist)
| _ ->

2
compiler/lcalc/to_ocaml.ml
View File

@ -231,7 +231,7 @@ let rec format_typ (fmt : Format.formatter) (typ : typ Marked.pos) : unit =
| TArray t1 -> Format.fprintf fmt "@[%a@ array@]" format_typ_with_parens t1
| TAny -> Format.fprintf fmt "_"
let format_var (fmt : Format.formatter) (v : 'm var) : unit =
let format_var (fmt : Format.formatter) (v : 'm Var.t) : unit =
let lowercase_name = to_snake_case (to_ascii (Bindlib.name_of v)) in
let lowercase_name =
Re.Pcre.substitute ~rex:(Re.Pcre.regexp "\\.")

2
compiler/lcalc/to_ocaml.mli
View File

@ -42,7 +42,7 @@ val format_to_module_name :
val format_lit : Format.formatter -> lit Marked.pos -> unit
val format_uid_list : Format.formatter -> Uid.MarkedString.info list -> unit
val format_var : Format.formatter -> 'm var -> unit
val format_var : Format.formatter -> 'm Var.t -> unit
val format_program :
Format.formatter ->

2
compiler/plugins/api_web.ml
View File

@ -121,7 +121,7 @@ module To_jsoo = struct
format_typ_of_jsoo t
| _ -> Format.fprintf fmt ""
let format_var_camel_case (fmt : Format.formatter) (v : 'm var) : unit =
let format_var_camel_case (fmt : Format.formatter) (v : 'm Var.t) : unit =
let lowercase_name =
Bindlib.name_of v
|> to_ascii

2
compiler/scopelang/ast.ml
View File

@ -307,7 +307,7 @@ let make_let_in
(e2 : expr Marked.pos Bindlib.box) : expr Marked.pos Bindlib.box =
Bindlib.box_apply2
(fun e u -> EApp (e, u), Marked.get_mark (Bindlib.unbox e2))
(make_abs (Array.of_list [x]) e2 [tau] (Marked.get_mark (Bindlib.unbox e2)))
(make_abs [| x |] e2 [tau] (Marked.get_mark (Bindlib.unbox e2)))
(Bindlib.box_list [e1])
let make_default ?(pos = Pos.no_pos) exceptions just cons =

4
compiler/scopelang/scope_to_dcalc.ml
View File

@ -455,9 +455,7 @@ let translate_rule
(fun new_e -> ErrorOnEmpty new_e, pos_mark_as subs_var)
new_e
| Reentrant ->
Expr.make_abs
(Array.of_list [silent_var])
new_e
Expr.make_abs [| silent_var |] new_e
[TLit TUnit, var_def_pos]
(pos_mark var_def_pos)
in

13
compiler/shared_ast/types.ml → compiler/shared_ast/definitions.ml
View File

@ -221,7 +221,6 @@ type 'e anyexpr = 'e constraint 'e = (_ any, _) gexpr
type untyped = { pos : Pos.t } [@@ocaml.unboxed]
type typed = { pos : Pos.t; ty : marked_typ }
(* type inferring = { pos : Pos.t; uf : Infer.unionfind_typ } *)
(** The generic type of AST markings. Using a GADT allows functions to be
polymorphic in the marking, but still do transformations on types when
@ -232,6 +231,9 @@ type typed = { pos : Pos.t; ty : marked_typ }
type _ mark = Untyped : untyped -> untyped mark | Typed : typed -> typed mark
type 'e marked = ('e, 'm mark) Marked.t constraint 'e = ('a, 'm mark) gexpr
(** [('a, 't) gexpr marked] is equivalent to [('a, 'm mark) marked_gexpr] but
often more convenient to write since we generally use the type of
expressions ['e = (_, _ mark) gexpr] as type parameter. *)
(** Useful for errors and printing, for example *)
type any_marked_expr =
@ -239,10 +241,11 @@ type any_marked_expr =
(** {2 Higher-level program structure} *)
(** Constructs scopes and programs on top of expressions. We may use the [gexpr]
type above at some point, but at the moment this is polymorphic in the types
of the expressions. Their markings are constrained to belong to the [mark]
GADT defined above. *)
(** Constructs scopes and programs on top of expressions. The ['e] type
parameter throughout is expected to match instances of the [gexpr] type
defined above. Markings are constrained to the [mark] GADT defined above.
Note that this structure is at the moment only relevant for [dcalc] and
[lcalc], as [scopelang] has its own scope structure, as the name implies. *)
(** This kind annotation signals that the let-binding respects a structural
invariant. These invariants concern the shape of the expression in the

228
compiler/shared_ast/expr.ml
View File

@ -16,7 +16,7 @@
the License. *)
open Utils
open Types
open Definitions
(** Functions handling the types of [shared_ast] *)
@ -72,7 +72,7 @@ let ecatch e1 exn e2 pos =
(* - Manipulation of marks - *)
let no_mark (type m) : m mark -> m mark = function
let no_mark : type m. m mark -> m mark = function
| Untyped _ -> Untyped { pos = Pos.no_pos }
| Typed _ -> Typed { pos = Pos.no_pos; ty = Marked.mark Pos.no_pos TAny }
@ -208,6 +208,23 @@ let make_let_in x tau e1 e2 pos =
in
make_app (make_abs [| x |] e2 [tau] m_abs) [e1] m_e2
let make_multiple_let_in xs taus e1s e2 pos =
(* let m_e1s = List.map (fun e -> Marked.get_mark (Bindlib.unbox e)) e1s in *)
let m_e1s =
fold_marks List.hd
(fun tys ->
TTuple (List.map (fun t -> t.ty) tys, None), (List.hd tys).pos)
(List.map (fun e -> Marked.get_mark (Bindlib.unbox e)) e1s)
in
let m_e2 = Marked.get_mark (Bindlib.unbox e2) in
let m_abs =
map_mark2
(fun _ _ -> pos)
(fun m1 m2 -> Marked.mark pos (TArrow (m1.ty, m2.ty)))
m_e1s m_e2
in
make_app (make_abs xs e2 taus m_abs) e1s m_e2
(* Tests *)
let is_value (type a) (e : (a, 'm mark) gexpr marked) =
@ -223,13 +240,10 @@ let rec equal_typs ty1 ty2 =
| TArrow (t1, t1'), TArrow (t2, t2') -> equal_typs t1 t2 && equal_typs t1' t2'
| TArray t1, TArray t2 -> equal_typs t1 t2
| TAny, TAny -> true
| _, _ -> false
| (TLit _ | TTuple _ | TEnum _ | TArrow _ | TArray _ | TAny), _ -> false
and equal_typs_list tys1 tys2 =
List.length tys1 = List.length tys2
&& (* OCaml && operator short-circuits when a clause is false, we can safely
assume here that both lists have equal length *)
List.for_all (fun (x, y) -> equal_typs x y) (List.combine tys1 tys2)
try List.for_all2 equal_typs tys1 tys2 with Invalid_argument _ -> false
let equal_log_entries l1 l2 =
match l1, l2 with
@ -241,8 +255,13 @@ let equal_unops op1 op2 =
(* Log entries contain a typ which contain position information, we thus need
to descend into them *)
| Log (l1, info1), Log (l2, info2) -> equal_log_entries l1 l2 && info1 = info2
| Log _, _ | _, Log _ -> false
(* All the other cases can be discharged through equality *)
| _ -> op1 = op2
| ( ( Not | Minus _ | Length | IntToRat | MoneyToRat | RatToMoney | GetDay
| GetMonth | GetYear | FirstDayOfMonth | LastDayOfMonth | RoundMoney
| RoundDecimal ),
_ ) ->
op1 = op2
let equal_ops op1 op2 =
match op1, op2 with
@ -260,86 +279,71 @@ let rec equal_list :
fun es1 es2 ->
try List.for_all2 equal es1 es2 with Invalid_argument _ -> false
and equal : 'a. ('a, 't) gexpr marked -> ('a, 't) gexpr marked -> bool =
fun (type a) (e1 : (a, 't) gexpr marked) (e2 : (a, 't) gexpr marked) ->
match Marked.unmark e1, Marked.unmark e2 with
| EVar v1, EVar v2 -> Bindlib.eq_vars v1 v2
| ETuple (es1, n1), ETuple (es2, n2) -> n1 = n2 && equal_list es1 es2
| ETupleAccess (e1, id1, n1, tys1), ETupleAccess (e2, id2, n2, tys2) ->
equal e1 e2 && id1 = id2 && n1 = n2 && equal_typs_list tys1 tys2
| EInj (e1, id1, n1, tys1), EInj (e2, id2, n2, tys2) ->
equal e1 e2 && id1 = id2 && n1 = n2 && equal_typs_list tys1 tys2
| EMatch (e1, cases1, n1), EMatch (e2, cases2, n2) ->
n1 = n2 && equal e1 e2 && equal_list cases1 cases2
| EArray es1, EArray es2 -> equal_list es1 es2
| ELit l1, ELit l2 -> l1 = l2
| EAbs (b1, tys1), EAbs (b2, tys2) ->
equal_typs_list tys1 tys2
&&
let vars1, body1 = Bindlib.unmbind b1 in
let body2 = Bindlib.msubst b2 (Array.map (fun x -> EVar x) vars1) in
equal body1 body2
| EAssert e1, EAssert e2 -> equal e1 e2
| EOp op1, EOp op2 -> equal_ops op1 op2
| EDefault (exc1, def1, cons1), EDefault (exc2, def2, cons2) ->
equal def1 def2 && equal cons1 cons2 && equal_list exc1 exc2
| EIfThenElse (if1, then1, else1), EIfThenElse (if2, then2, else2) ->
equal if1 if2 && equal then1 then2 && equal else1 else2
| ErrorOnEmpty e1, ErrorOnEmpty e2 -> equal e1 e2
| ERaise ex1, ERaise ex2 -> equal_except ex1 ex2
| ECatch (etry1, ex1, ewith1), ECatch (etry2, ex2, ewith2) ->
equal etry1 etry2 && equal_except ex1 ex2 && equal ewith1 ewith2
| _, _ -> false
and equal : type a. (a, 't) gexpr marked -> (a, 't) gexpr marked -> bool =
fun e1 e2 ->
match Marked.unmark e1, Marked.unmark e2 with
| EVar v1, EVar v2 -> Bindlib.eq_vars v1 v2
| ETuple (es1, n1), ETuple (es2, n2) -> n1 = n2 && equal_list es1 es2
| ETupleAccess (e1, id1, n1, tys1), ETupleAccess (e2, id2, n2, tys2) ->
equal e1 e2 && id1 = id2 && n1 = n2 && equal_typs_list tys1 tys2
| EInj (e1, id1, n1, tys1), EInj (e2, id2, n2, tys2) ->
equal e1 e2 && id1 = id2 && n1 = n2 && equal_typs_list tys1 tys2
| EMatch (e1, cases1, n1), EMatch (e2, cases2, n2) ->
n1 = n2 && equal e1 e2 && equal_list cases1 cases2
| EArray es1, EArray es2 -> equal_list es1 es2
| ELit l1, ELit l2 -> l1 = l2
| EAbs (b1, tys1), EAbs (b2, tys2) ->
equal_typs_list tys1 tys2
&&
let vars1, body1 = Bindlib.unmbind b1 in
let body2 = Bindlib.msubst b2 (Array.map (fun x -> EVar x) vars1) in
equal body1 body2
| EApp (e1, args1), EApp (e2, args2) -> equal e1 e2 && equal_list args1 args2
| EAssert e1, EAssert e2 -> equal e1 e2
| EOp op1, EOp op2 -> equal_ops op1 op2
| EDefault (exc1, def1, cons1), EDefault (exc2, def2, cons2) ->
equal def1 def2 && equal cons1 cons2 && equal_list exc1 exc2
| EIfThenElse (if1, then1, else1), EIfThenElse (if2, then2, else2) ->
equal if1 if2 && equal then1 then2 && equal else1 else2
| ErrorOnEmpty e1, ErrorOnEmpty e2 -> equal e1 e2
| ERaise ex1, ERaise ex2 -> equal_except ex1 ex2
| ECatch (etry1, ex1, ewith1), ECatch (etry2, ex2, ewith2) ->
equal etry1 etry2 && equal_except ex1 ex2 && equal ewith1 ewith2
| ( ( EVar _ | ETuple _ | ETupleAccess _ | EInj _ | EMatch _ | EArray _
| ELit _ | EAbs _ | EApp _ | EAssert _ | EOp _ | EDefault _
| EIfThenElse _ | ErrorOnEmpty _ | ERaise _ | ECatch _ ),
_ ) ->
false
let free_vars : 'a. ('a, 't) gexpr marked -> ('a, 't) gexpr Var.Set.t =
fun (type a) (e : (a, 't) gexpr marked) ->
let rec aux : (a, 't) gexpr marked -> (a, 't) gexpr Var.Set.t =
fun e ->
match Marked.unmark e with
| EOp _ | ELit _ | ERaise _ -> Var.Set.empty
| EVar v -> Var.Set.singleton v
| ETuple (es, _) ->
es |> List.map aux |> List.fold_left Var.Set.union Var.Set.empty
| EArray es ->
es |> List.map aux |> List.fold_left Var.Set.union Var.Set.empty
| _ -> Var.Set.empty
in
aux e
let rec free_vars : 'a. ('a, 't) gexpr marked -> ('a, 't) gexpr Var.Set.t =
fun (type a) (e : (a, 't) gexpr marked) : (a, 't) gexpr Var.Set.t ->
match Marked.unmark e with
| EOp _ | ELit _ | ERaise _ -> Var.Set.empty
| EVar v -> Var.Set.singleton v
| ETuple (es, _) ->
es |> List.map free_vars |> List.fold_left Var.Set.union Var.Set.empty
| EArray es ->
es |> List.map free_vars |> List.fold_left Var.Set.union Var.Set.empty
| ETupleAccess (e1, _, _, _) -> free_vars e1
| EAssert e1 -> free_vars e1
| EInj (e1, _, _, _) -> free_vars e1
| ErrorOnEmpty e1 -> free_vars e1
| ECatch (etry, ex, ewith) ->
Var.Set.union (free_vars etry) (free_vars ewith)
| EApp (e1, es) ->
e1 :: es
|> List.map free_vars
|> List.fold_left Var.Set.union Var.Set.empty
| EMatch (e1, es, _) ->
e1 :: es
|> List.map free_vars
|> List.fold_left Var.Set.union Var.Set.empty
| EDefault (es, ejust, econs) ->
ejust :: econs :: es
|> List.map free_vars
|> List.fold_left Var.Set.union Var.Set.empty
| EIfThenElse (e1, e2, e3) ->
[e1; e2; e3]
|> List.map free_vars
|> List.fold_left Var.Set.union Var.Set.empty
| EAbs (binder, _) ->
let vs, body = Bindlib.unmbind binder in
Array.fold_right Var.Set.remove vs (free_vars body)
let rec free_vars : type a. (a, 't) gexpr marked -> (a, 't) gexpr Var.Set.t =
fun e ->
match Marked.unmark e with
| EOp _ | ELit _ | ERaise _ -> Var.Set.empty
| EVar v -> Var.Set.singleton v
| ETuple (es, _) ->
es |> List.map free_vars |> List.fold_left Var.Set.union Var.Set.empty
| EArray es ->
es |> List.map free_vars |> List.fold_left Var.Set.union Var.Set.empty
| ETupleAccess (e1, _, _, _) -> free_vars e1
| EAssert e1 -> free_vars e1
| EInj (e1, _, _, _) -> free_vars e1
| ErrorOnEmpty e1 -> free_vars e1
| ECatch (etry, _, ewith) -> Var.Set.union (free_vars etry) (free_vars ewith)
| EApp (e1, es) ->
e1 :: es |> List.map free_vars |> List.fold_left Var.Set.union Var.Set.empty
| EMatch (e1, es, _) ->
e1 :: es |> List.map free_vars |> List.fold_left Var.Set.union Var.Set.empty
| EDefault (es, ejust, econs) ->
ejust :: econs :: es
|> List.map free_vars
|> List.fold_left Var.Set.union Var.Set.empty
| EIfThenElse (e1, e2, e3) ->
[e1; e2; e3]
|> List.map free_vars
|> List.fold_left Var.Set.union Var.Set.empty
| EAbs (binder, _) ->
let vs, body = Bindlib.unmbind binder in
Array.fold_right Var.Set.remove vs (free_vars body)
let remove_logging_calls e =
let rec f () e =
@ -351,28 +355,28 @@ let remove_logging_calls e =
let format ?debug decl_ctx ppf e = Print.expr ?debug decl_ctx ppf e
let rec size : 'a. ('a, 't) gexpr marked -> int =
fun (type a) (e : (a, 't) gexpr marked) ->
match Marked.unmark e with
| EVar _ | ELit _ | EOp _ -> 1
| ETuple (args, _) -> List.fold_left (fun acc arg -> acc + size arg) 1 args
| EArray args -> List.fold_left (fun acc arg -> acc + size arg) 1 args
| ETupleAccess (e1, _, _, _) -> size e1 + 1
| EInj (e1, _, _, _) -> size e1 + 1
| EAssert e1 -> size e1 + 1
| ErrorOnEmpty e1 -> size e1 + 1
| EMatch (arg, args, _) ->
List.fold_left (fun acc arg -> acc + size arg) (1 + size arg) args
| EApp (arg, args) ->
List.fold_left (fun acc arg -> acc + size arg) (1 + size arg) args
| EAbs (binder, _) ->
let _, body = Bindlib.unmbind binder in
1 + size body
| EIfThenElse (e1, e2, e3) -> 1 + size e1 + size e2 + size e3
| EDefault (exceptions, just, cons) ->
List.fold_left
(fun acc except -> acc + size except)
(1 + size just + size cons)
exceptions
| ERaise _ -> 1
| ECatch (etry, _, ewith) -> 1 + size etry + size ewith
let rec size : type a. (a, 't) gexpr marked -> int =
fun e ->
match Marked.unmark e with
| EVar _ | ELit _ | EOp _ -> 1
| ETuple (args, _) -> List.fold_left (fun acc arg -> acc + size arg) 1 args
| EArray args -> List.fold_left (fun acc arg -> acc + size arg) 1 args
| ETupleAccess (e1, _, _, _) -> size e1 + 1
| EInj (e1, _, _, _) -> size e1 + 1
| EAssert e1 -> size e1 + 1
| ErrorOnEmpty e1 -> size e1 + 1
| EMatch (arg, args, _) ->
List.fold_left (fun acc arg -> acc + size arg) (1 + size arg) args
| EApp (arg, args) ->
List.fold_left (fun acc arg -> acc + size arg) (1 + size arg) args
| EAbs (binder, _) ->
let _, body = Bindlib.unmbind binder in
1 + size body
| EIfThenElse (e1, e2, e3) -> 1 + size e1 + size e2 + size e3
| EDefault (exceptions, just, cons) ->
List.fold_left
(fun acc except -> acc + size except)
(1 + size just + size cons)
exceptions
| ERaise _ -> 1
| ECatch (etry, _, ewith) -> 1 + size etry + size ewith

14
compiler/shared_ast/expr.mli
View File

@ -18,7 +18,7 @@
(** Functions handling the expressions of [shared_ast] *)
open Utils
open Types
open Definitions
(** {2 Boxed constructors} *)
@ -191,12 +191,20 @@ val empty_thunked_term :
val make_let_in :
'e Bindlib.var ->
typ Utils.Marked.pos ->
((_ any, 'm mark) gexpr as 'e) marked Bindlib.box ->
marked_typ ->
'e anyexpr marked Bindlib.box ->
'e marked Bindlib.box ->
Utils.Pos.t ->
'e marked Bindlib.box
val make_multiple_let_in :
'e Var.vars ->
marked_typ list ->
'e marked Bindlib.box list ->
'e marked Bindlib.box ->
Pos.t ->
'e marked Bindlib.box
(** {2 Transformations} *)
val remove_logging_calls :

2
compiler/shared_ast/print.ml
View File

@ -16,7 +16,7 @@
open Utils
open String_common
open Types
open Definitions
let typ_needs_parens (e : typ) : bool =
match e with TArrow _ | TArray _ -> true | _ -> false

2
compiler/shared_ast/print.mli
View File

@ -17,7 +17,7 @@
(** Printing functions for the default calculus AST *)
open Utils
open Types
open Definitions
(** {1 Common syntax highlighting helpers}*)

19
compiler/shared_ast/program.ml
View File

@ -15,16 +15,17 @@
License for the specific language governing permissions and limitations under
the License. *)
open Types
open Definitions
let untype (prg : ('a, 'm mark) gexpr program) :
('a, untyped mark) gexpr program =
{
prg with
scopes =
Bindlib.unbox
(Scope.map_exprs ~f:Expr.untype ~varf:Var.translate prg.scopes);
}
let map_exprs ~f ~varf { scopes; decl_ctx } =
Bindlib.box_apply
(fun scopes -> { scopes; decl_ctx })
(Scope.map_exprs ~f ~varf scopes)
let untype : 'm. ('a, 'm mark) gexpr program -> ('a, untyped mark) gexpr program
=
fun (prg : ('a, 'm mark) gexpr program) ->
Bindlib.unbox (map_exprs ~f:Expr.untype ~varf:Var.translate prg)
let rec find_scope name vars = function
| Nil -> raise Not_found

17
compiler/shared_ast/program.mli
View File

@ -15,13 +15,24 @@
License for the specific language governing permissions and limitations under
the License. *)
open Types
open Definitions
(** {2 Transformations} *)
val untype : ('a any, 'm mark) gexpr program -> ('a, untyped mark) gexpr program
val map_exprs :
f:('expr1 marked -> 'expr2 marked Bindlib.box) ->
varf:('expr1 Bindlib.var -> 'expr2 Bindlib.var) ->
'expr1 program ->
'expr2 program Bindlib.box
val to_expr : 'e anyexpr program -> ScopeName.t -> 'e marked Bindlib.box
val untype :
(([< dcalc | lcalc ] as 'a), 'm mark) gexpr program ->
('a, untyped mark) gexpr program
val to_expr :
(([< dcalc | lcalc ], _) gexpr as 'e) program ->
ScopeName.t ->
'e marked Bindlib.box
(** Usage: [build_whole_program_expr program main_scope] builds an expression
corresponding to the main program and returning the main scope as a
function. *)

2
compiler/shared_ast/scope.ml
View File

@ -16,7 +16,7 @@
the License. *)
open Utils
open Types
open Definitions
let rec fold_left_lets ~f ~init scope_body_expr =
match scope_body_expr with

2
compiler/shared_ast/scope.mli
View File

@ -18,7 +18,7 @@
(** Functions handling the scope structures of [shared_ast] *)
open Utils
open Types
open Definitions
(** {2 Traversal functions} *)

2
compiler/shared_ast/shared_ast.ml
View File

@ -14,7 +14,7 @@
License for the specific language governing permissions and limitations under
the License. *)
include Types
include Definitions
module Var = Var
module Expr = Expr
module Scope = Scope

18
compiler/shared_ast/shared_ast.mld
View File

@ -3,11 +3,12 @@
This module contains a generic AST structure, various type definitions and
helpers that are reused in various passes of the compiler.
{1 The {!modules: Shared_ast.Types} module}
{1 The {!modules: Shared_ast.Definitions} module}
The main module {!modules: Shared_ast.Types} is exposed at top-level of the library (so that [open
Shared_ast] gives access to the structures). It defines literals, operators,
and in particular the type {!types: Shared_ast.gexpr}.
The main module {!modules: Shared_ast.Definitions} is exposed at top-level of
the library (so that [open Shared_ast] gives access to the structures). It
defines literals, operators, and in particular the type {!types:
Shared_ast.gexpr}.
The {!types: Shared_ast.gexpr} type regroups all the cases for the {{:
../dcalc.html} Dcalc} and {{: ../lcalc.html} Lcalc} ASTs, with unconstrained
@ -19,7 +20,8 @@ For example, Lcalc expressions are then defined as
[type 'm expr = (Shared_ast.lcalc, 'm mark) Shared_ast.gexpr].
This makes it possible to write a single function that works on the different
ASTs, by having it take a [('a, _) gexpr] as input.
ASTs, by having it take a [('a, _) gexpr] as input, while retaining a much
stricter policy than polymorphic variants.
The module additionally defines the encompassing [scope] and [program]
structures that are also shared between different compiler passes.
@ -30,5 +32,9 @@ The {!modules: Shared_ast.Var} defines ['e Var.Set.t] and [('e, _) Var.Map.t]
types that are useful to handle variables for the different ['e] expression
types without re-instanciating [Set.Make] and [Map.Make] each time.
[!modules: Shared_ast.Expr} contains various helpers to build well-formed
{!modules: Shared_ast.Expr} contains various helpers to build well-formed
expressions, and for traversal.
{!modules: Shared_ast.Scope Shared_ast.Program} are dedicated to handling the
program structure around expressions. Note that these don't make sense for the
early compiler passes (up to [Scopelang]).

3
compiler/shared_ast/var.ml
View File

@ -14,7 +14,7 @@
License for the specific language governing permissions and limitations under
the License. *)
open Types
open Definitions
(** {1 Variables and their collections} *)
@ -24,6 +24,7 @@ open Types
type 'e t = 'e anyexpr Bindlib.var
type 'e vars = 'e anyexpr Bindlib.mvar
type 'e binder = ('e, 'e marked) Bindlib.binder
let make (name : string) : 'e t = Bindlib.new_var (fun x -> EVar x) name
let compare = Bindlib.compare_vars
let eq = Bindlib.eq_vars

2
compiler/shared_ast/var.mli
View File

@ -14,7 +14,7 @@
License for the specific language governing permissions and limitations under
the License. *)
open Types
open Definitions
(** {1 Variables and their collections} *)

6
compiler/surface/desugaring.ml
View File

@ -913,7 +913,7 @@ and disambiguate_match_and_build_expression
let case_body =
translate_expr scope inside_definition_of ctxt case.Ast.match_case_expr
in
let e_binder = Bindlib.bind_mvar (Array.of_list [param_var]) case_body in
let e_binder = Bindlib.bind_mvar [| param_var |] case_body in
let case_expr = bind_case_body c_uid e_uid ctxt case_body e_binder in
( Scopelang.Ast.EnumConstructorMap.add c_uid case_expr cases_d,
Some e_uid,
@ -968,9 +968,7 @@ and disambiguate_match_and_build_expression
let case_body =
translate_expr scope inside_definition_of ctxt match_case_expr
in
let e_binder =
Bindlib.bind_mvar (Array.of_list [payload_var]) case_body
in
let e_binder = Bindlib.bind_mvar [| payload_var |] case_body in
(* For each missing cases, binds the wildcard payload. *)
Scopelang.Ast.EnumConstructorMap.fold

2
compiler/utils/uid.ml
View File

@ -28,6 +28,7 @@ module type Id = sig
val fresh : info -> t
val get_info : t -> info
val compare : t -> t -> int
val equal : t -> t -> bool
val format_t : Format.formatter -> t -> unit
val hash : t -> int
end
@ -44,6 +45,7 @@ module Make (X : Info) () : Id with type info = X.info = struct
let get_info (uid : t) : X.info = uid.info
let compare (x : t) (y : t) : int = compare x.id y.id
let equal x y = Int.equal x.id y.id
let format_t (fmt : Format.formatter) (x : t) : unit =
X.format_info fmt x.info

1
compiler/utils/uid.mli
View File

@ -39,6 +39,7 @@ module type Id = sig
val fresh : info -> t
val get_info : t -> info
val compare : t -> t -> int
val equal : t -> t -> bool
val format_t : Format.formatter -> t -> unit
val hash : t -> int
end

8
compiler/verification/conditions.ml
View File

@ -132,10 +132,10 @@ let rec generate_vc_must_not_return_empty (ctx : ctx) (e : typed marked_expr) :
(generate_vc_must_not_return_empty ctx) body
in
( vc_body_expr,
List.fold_left
(fun acc (var, ty) -> Var.Map.add var ty acc)
vc_body_ty
(List.map2 (fun x y -> x, y) (Array.to_list vars) typs) )
snd
@@ List.fold_left
(fun (i, acc) ty -> i + 1, Var.Map.add vars.(i) ty acc)
(0, vc_body_ty) typs )
| EApp (f, args) ->
(* We assume here that function calls never return empty error, which implies
all functions have been checked never to return empty errors. *)