Commit c0758c6b authored by MARCHE Claude's avatar MARCHE Claude

Merge branch '239-extracting-higher-order-calls' into 'master'

Resolve "Extracting higher-order calls"

Closes #239

See merge request !90
parents 70bd7a85 d13f0525
let f (g: unit -> 'a) : 'a = g ()
let g (_:unit) = ()
let good = f (fun x -> g x)
let bad = f g
let ugly = g
let main () = ugly ()
...@@ -359,15 +359,18 @@ module Translate = struct ...@@ -359,15 +359,18 @@ module Translate = struct
(* partial application of constructors *) (* partial application of constructors *)
mk_eta_expansion rs pvl cty mk_eta_expansion rs pvl cty
| Eexec ({c_node = Capp (rs, pvl); c_cty = cty}, _) -> | Eexec ({c_node = Capp (rs, pvl); c_cty = cty}, _) ->
Debug.dprintf debug_compile "compiling total application of %s@." Debug.dprintf debug_compile "compiling application of %s@."
rs.rs_name.id_string; rs.rs_name.id_string;
Debug.dprintf debug_compile "pvl: %d@." (List.length pvl);
Debug.dprintf debug_compile "cty_args: %d@." (List.length cty.cty_args); Debug.dprintf debug_compile "cty_args: %d@." (List.length cty.cty_args);
let rs = Hrs.find_def ht_rs rs rs in let rs = Hrs.find_def ht_rs rs rs in
let add_unit = function [] -> [ML.e_unit] | args -> args in let add_unit = function [] -> [ML.e_unit] | args -> args in
let id_f = fun x -> x in let id_f = fun x -> x in
let f_zero = match rs.rs_logic with RLnone -> let f_zero = match rs.rs_logic with
Debug.dprintf debug_compile "it is a RLnone@."; add_unit | RLnone when cty.cty_args = [] ->
| _ -> id_f in Debug.dprintf debug_compile "it is a fully applied RLnone@.";
add_unit
| _ -> id_f in
let pvl = app pvl rs.rs_cty.cty_args f_zero in let pvl = app pvl rs.rs_cty.cty_args f_zero in
begin match pvl with begin match pvl with
| [pv_expr] when is_optimizable_record_rs info rs -> pv_expr | [pv_expr] when is_optimizable_record_rs info rs -> pv_expr
......
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