summaryrefslogtreecommitdiff
path: root/src/Pure.ml
diff options
context:
space:
mode:
Diffstat (limited to 'src/Pure.ml')
-rw-r--r--src/Pure.ml154
1 files changed, 121 insertions, 33 deletions
diff --git a/src/Pure.ml b/src/Pure.ml
index ee4e74bb..61d2d130 100644
--- a/src/Pure.ml
+++ b/src/Pure.ml
@@ -95,22 +95,10 @@ type var = {
itself.
*)
-type var_or_dummy = Var of var | Dummy (** Ignored value: `_`. *)
-
-(** A left value (which appears on the left of assignments *)
-type lvalue =
- | LvVar of var_or_dummy
- | LvTuple of typed_lvalue list
- (** Rk.: for now we don't support general ADTs *)
-
-and typed_lvalue = { value : lvalue; ty : ty }
-
type projection_elem = { pkind : E.field_proj_kind; field_id : FieldId.id }
type projection = projection_elem list
-type place = { var : VarId.id; projection : projection }
-
type mplace = { name : string option; projection : projection }
(** "Meta" place.
@@ -119,6 +107,112 @@ type mplace = { name : string option; projection : projection }
we introduce.
*)
+type place = { var : VarId.id; projection : projection }
+
+(** Ancestor for [iter_var_or_dummy] iter visitor *)
+class ['self] iter_value_base =
+ object (_self : 'self)
+ inherit [_] VisitorsRuntime.iter
+
+ method visit_var : 'env -> var -> unit = fun _ _ -> ()
+
+ method visit_mplace : 'env -> mplace -> unit = fun _ _ -> ()
+
+ method visit_ty : 'env -> ty -> unit = fun _ _ -> ()
+ end
+
+(** Ancestor for [map_var_or_dummy] visitor *)
+class ['self] map_value_base =
+ object (_self : 'self)
+ inherit [_] VisitorsRuntime.map
+
+ method visit_var : 'env -> var -> var = fun _ x -> x
+
+ method visit_mplace : 'env -> mplace -> mplace = fun _ x -> x
+
+ method visit_ty : 'env -> ty -> ty = fun _ x -> x
+ end
+
+(** Ancestor for [reduce_var_or_dummy] visitor *)
+class virtual ['self] reduce_value_base =
+ object (self : 'self)
+ inherit [_] VisitorsRuntime.reduce
+
+ method visit_var : 'env -> var -> 'a = fun _ _ -> self#zero
+
+ method visit_mplace : 'env -> mplace -> 'a = fun _ _ -> self#zero
+
+ method visit_ty : 'env -> ty -> 'a = fun _ _ -> self#zero
+ end
+
+type var_or_dummy =
+ | Var of var * mplace option
+ | Dummy (** Ignored value: `_`. *)
+[@@deriving
+ visitors
+ {
+ name = "iter_var_or_dummy";
+ variety = "iter";
+ ancestors = [ "iter_value_base" ];
+ nude = true (* Don't inherit [VisitorsRuntime.iter] *);
+ concrete = true;
+ polymorphic = false;
+ },
+ visitors
+ {
+ name = "map_var_or_dummy";
+ variety = "map";
+ ancestors = [ "map_value_base" ];
+ nude = true (* Don't inherit [VisitorsRuntime.map] *);
+ concrete = true;
+ polymorphic = false;
+ },
+ visitors
+ {
+ name = "reduce_var_or_dummy";
+ variety = "reduce";
+ ancestors = [ "reduce_value_base" ];
+ nude = true (* Don't inherit [VisitorsRuntime.reduce] *);
+ polymorphic = false;
+ }]
+
+(** A left value (which appears on the left of assignments *)
+type lvalue = LvVar of var_or_dummy | LvAdt of adt_lvalue
+
+and adt_lvalue = {
+ variant_id : (VariantId.id option[@opaque]);
+ field_values : typed_lvalue list;
+}
+
+and typed_lvalue = { value : lvalue; ty : ty }
+[@@deriving
+ visitors
+ {
+ name = "iter_typed_lvalue";
+ variety = "iter";
+ ancestors = [ "iter_var_or_dummy" ];
+ nude = true (* Don't inherit [VisitorsRuntime.iter] *);
+ concrete = true;
+ polymorphic = false;
+ },
+ visitors
+ {
+ name = "map_typed_lvalue";
+ variety = "map";
+ ancestors = [ "map_var_or_dummy" ];
+ nude = true (* Don't inherit [VisitorsRuntime.iter] *);
+ concrete = true;
+ polymorphic = false;
+ },
+ visitors
+ {
+ name = "reduce_typed_lvalue";
+ variety = "reduce";
+ ancestors = [ "reduce_var_or_dummy" ];
+ nude = true (* Don't inherit [VisitorsRuntime.iter] *);
+ polymorphic = false;
+ }]
+
type rvalue =
| RvConcrete of constant_value
| RvPlace of place
@@ -159,17 +253,15 @@ type call = {
args_mplaces : mplace option list; (** Meta data *)
}
+(* TODO: we might want to merge Call and Assign *)
type let_bindings =
- | Call of (typed_lvalue * mplace option) list * call
+ | Call of typed_lvalue * call
(** The called function and the tuple of returned values. *)
- | Assign of typed_lvalue * mplace option * typed_rvalue * mplace option
- (** Variable assignment: the introduced pattern and the place we read *)
- | Deconstruct of
- (var_or_dummy * mplace option) list
- * (TypeDefId.id * VariantId.id) option
- * typed_rvalue
- * mplace option
- (** This is used in two cases.
+ | Assign of typed_lvalue * typed_rvalue * mplace option
+ (** Variable assignment: the introduced pattern and the place we read.
+
+ We are quite general for the left-value on purpose; this is used
+ in several situations:
1. When deconstructing a tuple:
```
@@ -186,18 +278,13 @@ type let_bindings =
...
```
- Later, depending on the language we extract to, we can eventually
- update it to something like this (for F*, for instance):
+ Note that later, depending on the language we extract to, we can
+ eventually update it to something like this (for F*, for instance):
```
let x = Cons?.v ls in
let tl = Cons?.tl ls in
...
```
-
- Note that we prefer not handling this case through a match.
-
- TODO: why don't we merge this with Assign? It would make things a lot
- simpler (before: introduce general ADTs in lvalue).
*)
(** Meta-information stored in the AST *)
@@ -210,6 +297,8 @@ class ['self] iter_expression_base =
method visit_typed_rvalue : 'env -> typed_rvalue -> unit = fun _ _ -> ()
+ method visit_typed_lvalue : 'env -> typed_lvalue -> unit = fun _ _ -> ()
+
method visit_let_bindings : 'env -> let_bindings -> unit = fun _ _ -> ()
method visit_mplace : 'env -> mplace -> unit = fun _ _ -> ()
@@ -233,6 +322,9 @@ class ['self] map_expression_base =
method visit_typed_rvalue : 'env -> typed_rvalue -> typed_rvalue =
fun _ x -> x
+ method visit_typed_lvalue : 'env -> typed_lvalue -> typed_lvalue =
+ fun _ x -> x
+
method visit_let_bindings : 'env -> let_bindings -> let_bindings =
fun _ x -> x
@@ -274,11 +366,7 @@ and switch_body =
| SwitchInt of T.integer_type * (scalar_value * expression) list * expression
| Match of match_branch list
-and match_branch = {
- variant_id : VariantId.id;
- vars : var_or_dummy list;
- branch : expression;
-}
+and match_branch = { pat : typed_lvalue; branch : expression }
[@@deriving
visitors
{