Fixed ocaml backend so it correctly compiles registers passed by name.

Added a test case for this behavior

2 files changed, 9 insertions, 2 deletions

diff --git a/src/ocaml_backend.ml b/src/ocaml_backend.ml
index 28bf624d..e8fd34b1 100644
--- a/src/ocaml_backend.ml
+++ b/src/ocaml_backend.ml
@@ -91,6 +91,7 @@ let ocaml_typ_id ctx = function
   | id when Id.compare id (mk_id "bool") = 0 -> string "bool"
   | id when Id.compare id (mk_id "unit") = 0 -> string "unit"
   | id when Id.compare id (mk_id "real") = 0 -> string "Num.num"
+  | id when Id.compare id (mk_id "register") = 0 -> string "ref"
   | id -> zencode ctx id
 
 let rec ocaml_typ ctx (Typ_aux (typ_aux, _)) =
@@ -151,6 +152,11 @@ let rec ocaml_pat ctx (P_aux (pat_aux, _) as pat) =
 
 let begin_end doc = group (string "begin" ^^ nest 2 (break 1 ^^ doc) ^/^ string "end")
 
+(* Returns true if a type is a register being passed by name *)
+let is_passed_by_name = function
+  | (Typ_aux (Typ_app (tid, _), _)) -> string_of_id tid = "register"
+  | _ -> false
+
 let rec ocaml_exp ctx (E_aux (exp_aux, _) as exp) =
   match exp_aux with
   | E_app (f, [x]) when Env.is_union_constructor f (env_of exp) -> zencode_upper ctx f ^^ space ^^ ocaml_atomic_exp ctx x
@@ -259,6 +265,7 @@ and ocaml_atomic_exp ctx (E_aux (exp_aux, _) as exp) =
        match Env.lookup_id id (env_of exp) with
        | Local (Immutable, _) | Unbound -> zencode ctx id
        | Enum _ | Union _ -> zencode_upper ctx id
+       | Register _ when is_passed_by_name (typ_of exp) -> zencode ctx id
        | Register typ ->
           if !opt_trace_ocaml then
             let var = gensym () in
diff --git a/src/type_check.ml b/src/type_check.ml
index f7716bc9..87e747f9 100644
--- a/src/type_check.ml
+++ b/src/type_check.ml
@@ -2170,10 +2170,10 @@ let rec check_exp env (E_aux (exp_aux, (l, ())) as exp : unit exp) (Typ_aux (typ
      then annot_exp_effect (E_lit lit) typ (mk_effect [BE_undef])
      else typ_error l ("Type " ^ string_of_typ typ ^ " failed undefined monomorphism restriction")
   (* This rule allows registers of type t to be passed by name with type register<t>*)
-  | E_id reg, Typ_app (id, [Typ_arg_aux (Typ_arg_typ typ, _)])
+  | E_id reg, Typ_app (id, [Typ_arg_aux (Typ_arg_typ arg_typ, _)])
     when string_of_id id = "register" && Env.is_register reg env ->
      let rtyp = Env.get_register reg env in
-     subtyp l env rtyp typ; annot_exp (E_id reg) typ (* CHECK: is this subtyp the correct way around? *)
+     subtyp l env rtyp arg_typ; annot_exp (E_id reg) typ (* CHECK: is this subtyp the correct way around? *)
   | E_id id, _ when is_union_id id env ->
      begin
        match Env.lookup_id id env with