Commit 7dfce3f8 authored by Mário Pereira's avatar Mário Pereira

Extraction: recognize [val x: t] as a valid functor argument

parent b4380d74
...@@ -227,7 +227,8 @@ module Print = struct ...@@ -227,7 +227,8 @@ module Print = struct
| Lany (rs, _, _) -> | Lany (rs, _, _) ->
check_val_in_drv info rs check_val_in_drv info rs
and print_expr ?(paren=false) info fmt e = match e.e_node with and print_expr ?(paren=false) info fmt e =
match e.e_node with
| Econst c -> | Econst c ->
let n = Number.compute_int_constant c in let n = Number.compute_int_constant c in
let n = BigInt.to_string n in let n = BigInt.to_string n in
...@@ -246,6 +247,7 @@ module Print = struct ...@@ -246,6 +247,7 @@ module Print = struct
| Eabsurd -> | Eabsurd ->
fprintf fmt (protect_on paren "assert false (* absurd *)") fprintf fmt (protect_on paren "assert false (* absurd *)")
| Ehole -> () | Ehole -> ()
| Eany _ -> assert false
| Eapp (rs, []) when rs_equal rs rs_true -> | Eapp (rs, []) when rs_equal rs rs_true ->
fprintf fmt "true" fprintf fmt "true"
| Eapp (rs, []) when rs_equal rs rs_false -> | Eapp (rs, []) when rs_equal rs rs_false ->
......
...@@ -494,6 +494,11 @@ module Translate = struct ...@@ -494,6 +494,11 @@ module Translate = struct
if eff_pure e.e_effect then [] if eff_pure e.e_effect then []
else let unit_ = pv (* create_pvsymbol (id_fresh "_") ity_unit *) in else let unit_ = pv (* create_pvsymbol (id_fresh "_") ity_unit *) in
[ML.Dlet (ML.Lvar (unit_, expr info Stv.empty MaskGhost e))] [ML.Dlet (ML.Lvar (unit_, expr info Stv.empty MaskGhost e))]
| PDlet (LDvar (pv, {e_node = Eexec ({c_node = Cany}, cty)})) ->
Debug.dprintf debug_compile "compiling undifined constant %a@"
print_pv pv;
let ty = mlty_of_ity cty.cty_mask cty.cty_result in
[ML.Dlet (ML.Lvar (pv, ML.e_any ty cty))]
| PDlet (LDvar (pv, e)) -> | PDlet (LDvar (pv, e)) ->
Debug.dprintf debug_compile "compiling top-level symbol %a@." Debug.dprintf debug_compile "compiling top-level symbol %a@."
print_pv pv; print_pv pv;
...@@ -674,7 +679,7 @@ module Transform = struct ...@@ -674,7 +679,7 @@ module Transform = struct
mk (Eraise (exn, Some e)), spv mk (Eraise (exn, Some e)), spv
| Eassign _al -> | Eassign _al ->
e, Spv.empty e, Spv.empty
| Econst _ | Eabsurd | Ehole -> e, Spv.empty | Econst _ | Eabsurd | Ehole | Eany _ -> e, Spv.empty
| Eignore e -> | Eignore e ->
let e, spv = expr info subst e in let e, spv = expr info subst e in
mk (Eignore e), spv mk (Eignore e), spv
......
...@@ -1011,7 +1011,7 @@ module MLToC = struct ...@@ -1011,7 +1011,7 @@ module MLToC = struct
| None, None -> raise (Unsupported ("assign not in driver")) in | None, None -> raise (Unsupported ("assign not in driver")) in
[], C.(Sexpr(Ebinop(Bassign, t, C.Evar v.pv_vs.vs_name))) [], C.(Sexpr(Ebinop(Bassign, t, C.Evar v.pv_vs.vs_name)))
| Eassign _ -> raise (Unsupported "assign") | Eassign _ -> raise (Unsupported "assign")
| Ehole -> assert false | Ehole | Eany _ -> assert false
| Eexn _ -> raise (Unsupported "exception") | Eexn _ -> raise (Unsupported "exception")
| Eignore e -> | Eignore e ->
[], C.Sseq(C.Sblock(expr info {env with computes_return_value = false} e), [], C.Sseq(C.Sblock(expr info {env with computes_return_value = false} e),
......
...@@ -769,6 +769,8 @@ let rec interp_expr info (e:Mltree.expr) : value = ...@@ -769,6 +769,8 @@ let rec interp_expr info (e:Mltree.expr) : value =
raise CannotReduce raise CannotReduce
| Ehole -> Debug.dprintf debug_interp "Ehole@."; | Ehole -> Debug.dprintf debug_interp "Ehole@.";
raise CannotReduce raise CannotReduce
| Eany _ -> Debug.dprintf debug_interp "Eany@.";
raise CannotReduce
| Ematch (e, l, bl) -> | Ematch (e, l, bl) ->
Debug.dprintf debug_interp "Ematch@."; Debug.dprintf debug_interp "Ematch@.";
begin match interp_expr info e with begin match interp_expr info e with
......
...@@ -63,6 +63,7 @@ and expr_node = ...@@ -63,6 +63,7 @@ and expr_node =
| Eraise of xsymbol * expr option | Eraise of xsymbol * expr option
| Eexn of xsymbol * ty option * expr | Eexn of xsymbol * ty option * expr
| Eignore of expr | Eignore of expr
| Eany of ty
| Eabsurd | Eabsurd
| Ehole | Ehole
...@@ -183,7 +184,7 @@ and iter_deps_pat f = function ...@@ -183,7 +184,7 @@ and iter_deps_pat f = function
| Pas (p, _) -> iter_deps_pat f p | Pas (p, _) -> iter_deps_pat f p
and iter_deps_expr f e = match e.e_node with and iter_deps_expr f e = match e.e_node with
| Econst _ | Evar _ | Eabsurd | Ehole -> () | Econst _ | Evar _ | Eabsurd | Ehole | Eany _ -> ()
| Eapp (rs, exprl) -> | Eapp (rs, exprl) ->
f rs.rs_name; List.iter (iter_deps_expr f) exprl f rs.rs_name; List.iter (iter_deps_expr f) exprl
| Efun (args, e) -> | Efun (args, e) ->
...@@ -280,6 +281,9 @@ let is_unit = function ...@@ -280,6 +281,9 @@ let is_unit = function
let enope = Eblock [] let enope = Eblock []
let e_any ty c =
mk_expr (Eany ty) (C c) MaskVisible Ity.eff_empty Sattr.empty
let mk_hole = let mk_hole =
mk_expr Ehole (I Ity.ity_unit) MaskVisible Ity.eff_empty Sattr.empty mk_expr Ehole (I Ity.ity_unit) MaskVisible Ity.eff_empty Sattr.empty
......
...@@ -387,6 +387,10 @@ module Print = struct ...@@ -387,6 +387,10 @@ module Print = struct
(print_expr info) e (print_expr info) e
and print_let_def ?(functor_arg=false) info fmt = function and print_let_def ?(functor_arg=false) info fmt = function
| Lvar (pv, {e_node = Eany ty}) when functor_arg ->
fprintf fmt "@[<hov 2>val %a : %a@]"
(print_lident info) (pv_name pv)
(print_ty info) ty;
| Lvar (pv, e) -> | Lvar (pv, e) ->
fprintf fmt "@[<hov 2>let %a =@ %a@]" fprintf fmt "@[<hov 2>let %a =@ %a@]"
(print_lident info) (pv_name pv) (print_lident info) (pv_name pv)
...@@ -424,7 +428,8 @@ module Print = struct ...@@ -424,7 +428,8 @@ module Print = struct
forget_vars args forget_vars args
| Lany (rs, _, _) -> check_val_in_drv info rs | Lany (rs, _, _) -> check_val_in_drv info rs
and print_expr ?(paren=false) info fmt e = match e.e_node with and print_expr ?(paren=false) info fmt e =
match e.e_node with
| Econst c -> | Econst c ->
let n = Number.compute_int_constant c in let n = Number.compute_int_constant c in
let n = BigInt.to_string n in let n = BigInt.to_string n in
...@@ -445,6 +450,7 @@ module Print = struct ...@@ -445,6 +450,7 @@ module Print = struct
| Eabsurd -> | Eabsurd ->
fprintf fmt (protect_on paren "assert false (* absurd *)") fprintf fmt (protect_on paren "assert false (* absurd *)")
| Ehole -> () | Ehole -> ()
| Eany _ -> assert false
| Eapp (rs, []) when rs_equal rs rs_true -> | Eapp (rs, []) when rs_equal rs rs_true ->
fprintf fmt "true" fprintf fmt "true"
| Eapp (rs, []) when rs_equal rs rs_false -> | Eapp (rs, []) when rs_equal rs rs_false ->
...@@ -612,6 +618,7 @@ module Print = struct ...@@ -612,6 +618,7 @@ module Print = struct
let rec is_signature_decl info = function let rec is_signature_decl info = function
| Dtype _ -> true | Dtype _ -> true
| Dlet (Lany _) -> true | Dlet (Lany _) -> true
| Dlet (Lvar (_, {e_node = Eany _})) -> true
| Dlet _ -> false | Dlet _ -> false
| Dexn _ -> true | Dexn _ -> true
| Dmodule (_, dl) -> is_signature info dl | Dmodule (_, dl) -> is_signature info dl
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment