experiment: attach optional migration expression to actor (class) as actor [exp]?

doc/md/examples/grammar.txt

@@ -14,7 +14,7 @@
 
 <obj_sort> ::= 
     'object'
-    'persistent'? 'actor'
+    'persistent'? 'actor' ('[' <exp> ']')?
     'module'
 
 <query> ::= 

src/docs/extract.ml

@@ -140,7 +140,7 @@ struct
           _;
         } -> (
         match rhs with
-        | Source.{ it = Syntax.ObjBlockE (sort, _, fields); _ } ->
+        | Source.{ it = Syntax.ObjBlockE (sort, _, _, fields); _ } ->
             let mk_field_xref xref = mk_xref (Xref.XClass (name, xref)) in
             Some
               ( mk_xref (Xref.XType name),
@@ -155,7 +155,7 @@ struct
         )
     | Source.{ it = Syntax.VarD ({ it = name; _ }, rhs); _ } -> (
         match rhs with
-        | Source.{ it = Syntax.ObjBlockE (sort, _, fields); _ } ->
+        | Source.{ it = Syntax.ObjBlockE (sort, _, _, fields); _ } ->
             let mk_field_xref xref = mk_xref (Xref.XClass (name, xref)) in
             Some
               ( mk_xref (Xref.XType name),
@@ -184,7 +184,15 @@ struct
         {
           it =
             Syntax.ClassD
-              (shared_pat, name, type_args, ctor, _, obj_sort, _, fields);
+              ( shared_pat,
+                exp_opt,
+                name,
+                type_args,
+                ctor,
+                _,
+                obj_sort,
+                _,
+                fields );
           _;
         } ->
         let mk_field_xref xref = mk_xref (Xref.XClass (name.it, xref)) in

src/docs/namespace.ml

@@ -32,7 +32,7 @@ let from_module =
         | Syntax.ExpD _ -> acc
         | Syntax.LetD
             ( { it = Syntax.VarP id; _ },
-              { it = Syntax.ObjBlockE (_, _, decs); _ },
+              { it = Syntax.ObjBlockE (_, _, _, decs); _ },
               _ ) ->
             let mk_nested x = mk_xref (Xref.XNested (id.it, x)) in
             {
@@ -69,7 +69,7 @@ let from_module =
                   (mk_xref (Xref.XValue id.it), None)
                   acc.values;
             }
-        | Syntax.ClassD (_, id, _, _, _, _, _, _) ->
+        | Syntax.ClassD (_, _, id, _, _, _, _, _, _) ->
             {
               acc with
               types = StringMap.add id.it (mk_xref (Xref.XType id.it)) acc.types;

src/ir_def/check_ir.ml

@@ -241,7 +241,7 @@ let rec check_typ env typ : unit =
     if not (Lib.List.is_strictly_ordered T.compare_field fields) then
       error env no_region "variant type's fields are not distinct and sorted %s" (T.string_of_typ typ)
   | T.Mut typ ->
-    error env no_region "unexpected T.Mut"
+    error env no_region "unexpected T.Mut %s" (T.string_of_typ typ)
   | T.Typ c ->
     error env no_region "unexpected T.Typ"
 

src/ir_def/construct.ml

@@ -790,8 +790,42 @@ let objE sort typ_flds flds =
   in
   go [] [] [] flds
 
+
 let recordE flds = objE T.Object [] flds
 
+let objectE sort flds (tfs : T.field list) =
+  let rec go ds fields = function
+    | [] ->
+      blockE
+        (List.rev ds)
+        (newObjE sort fields
+          (T.Obj (sort, List.sort T.compare_field tfs)))
+    | (lab, exp)::flds ->
+       let v, typ, ds =
+         match T.lookup_val_field_opt lab tfs with
+         | None -> assert false
+         | Some typ ->
+           if T.is_mut typ
+           then
+             let v = fresh_var lab typ in
+             v, typ, varD v exp :: ds
+           else
+             match exp.it with
+             | VarE (Const, v) ->
+                var v typ, typ, ds
+             | _ ->
+                let v = fresh_var lab typ in
+                v, typ, letD v exp :: ds
+       in
+       let field = {
+         it = {name = lab; var = id_of_var v};
+         at = no_region;
+         note = typ
+       } in
+      go ds (field::fields) flds
+  in
+  go [] [] flds
+
 let check_call_perform_status success mk_failure =
   ifE
     (callE

src/ir_def/construct.mli

@@ -147,6 +147,8 @@ val (-*-) : exp -> exp -> exp (* application *)
 
 val objE : obj_sort -> (lab * con) list -> (lab * exp) list -> exp
 
+val objectE : obj_sort -> (lab * exp) list -> field list -> exp
+
 (* Records *)
 
 val recordE : (lab * exp) list -> exp

src/languageServer/declaration_index.ml

@@ -251,7 +251,7 @@ let populate_definitions (project_root : string) (libs : Syntax.lib list)
   let is_type_def dec_field =
     match dec_field.it.Syntax.dec.it with
     | Syntax.TypD (typ_id, _, _) -> Some typ_id
-    | Syntax.ClassD (_, typ_id, _, _, _, _, _, _) -> Some typ_id
+    | Syntax.ClassD (_, _, typ_id, _, _, _, _, _, _) -> Some typ_id
     | _ -> None
   in
   let extract_binders env (pat : Syntax.pat) = gather_pat env pat in

src/lowering/desugar.ml

@@ -90,8 +90,8 @@ and exp' at note = function
       (breakE "!" (nullE()))
       (* case ? v : *)
       (varP v) (varE v) ty).it
-  | S.ObjBlockE (s, (self_id_opt, _), dfs) ->
-    obj_block at s self_id_opt dfs note.Note.typ
+  | S.ObjBlockE (s, exp_opt, (self_id_opt, _), dfs) ->
+    obj_block at s exp_opt self_id_opt dfs note.Note.typ
   | S.ObjE (bs, efs) ->
     obj note.Note.typ efs bs
   | S.TagE (c, e) -> (tagE c.it (exp e)).it
@@ -326,12 +326,12 @@ and mut m = match m.it with
   | S.Const -> Ir.Const
   | S.Var -> Ir.Var
 
-and obj_block at s self_id dfs obj_typ =
+and obj_block at s exp_opt self_id dfs obj_typ =
   match s.it with
   | T.Object | T.Module ->
     build_obj at s.it self_id dfs obj_typ
   | T.Actor ->
-    build_actor at [] self_id dfs obj_typ
+    build_actor at [] exp_opt self_id dfs obj_typ
   | T.Memory -> assert false
 
 and build_field {T.lab; T.typ;_} =
@@ -532,7 +532,7 @@ and export_runtime_information self_id =
   )],
   [{ it = I.{ name = lab; var = v }; at = no_region; note = typ }])
 
-and build_actor at ts self_id es obj_typ =
+and build_actor at ts exp_opt self_id es obj_typ =
   let candid = build_candid ts obj_typ in
   let fs = build_fields obj_typ in
   let es = List.filter (fun ef -> is_not_typD ef.it.S.dec) es in
@@ -550,8 +550,60 @@ and build_actor at ts self_id es obj_typ =
   let state = fresh_var "state" (T.Mut (T.Opt ty)) in
   let get_state = fresh_var "getState" (T.Func(T.Local, T.Returns, [], [], [ty])) in
   let ds = List.map (fun mk_d -> mk_d get_state) mk_ds in
+  let migration = match exp_opt with
+    | None -> primE (I.ICStableRead ty) [] (* as before *)
+    | Some exp0 ->
+      let e = exp exp0 in
+      let [@warning "-8"] (_s,_c, [], [dom], [rng]) = T.as_func (exp0.note.S.note_typ) in
+      let [@warning "-8"] (T.Object, dom_fields) = T.as_obj dom in
+      let [@warning "-8"] (T.Object, rng_fields) = T.as_obj rng in
+      ifE (primE (Ir.RelPrim (T.nat, Operator.EqOp)) [
+               primE (I.OtherPrim "rts_stable_memory_size") [];
+               natE Numerics.Nat.zero])
+        (primE (I.ICStableRead ty) [])
+        (let fields' =
+           List.map
+             (fun (i,t) ->
+                T.{lab = i; typ = T.Opt (T.as_immut t); src = T.empty_src})
+             ((List.map (fun T.{lab;typ;_} -> (lab,typ)) dom_fields) @
+                (List.filter_map
+                   (fun (i,t) ->
+                     match T.lookup_val_field_opt i dom_fields with
+                     | Some t -> None (* ignore overriden *)
+                     | None -> Some (i, t) (* retain others *))
+                   ids)) in
+         let ty' = T.Obj (T.Memory, List.sort T.compare_field fields') in
+         let v = fresh_var "v" ty' in
+         let v_dom = fresh_var "v_dom" dom in
+         let v_rng = fresh_var "v_rng" rng in
+         letE v (primE (I.ICStableRead ty') [])
+           (letE v_dom
+              (objectE T.Object
+                 (List.map (fun T.{lab=i;typ=t;_} ->
+                  let vi = fresh_var ("v_"^i) (T.as_immut t) in
+                  (i, switch_optE (dotE (varE v) i (T.Opt (T.as_immut t)))
+                       (primE (Ir.OtherPrim "trap")
+                          [textE (Printf.sprintf
+                             "stable variable `%s` of type `%s` expected but not found" i (T.string_of_typ t))])
+                       (varP vi) (varE vi)
+                       (T.as_immut t))) dom_fields) dom_fields)
+              (letE v_rng (callE e [] (varE v_dom))
+                 (objectE T.Memory
+                    (List.map (fun T.{lab=i;typ=t;_} ->
+                     i,
+                     match T.lookup_val_field_opt i rng_fields with
+                       (* produced by migration *)
+                     | Some t -> optE (dotE (varE v_rng) i (T.as_immut t)) (* wrap in ?_*)
+                     | None ->
+                         (* not produced by migration *)
+                         match T.lookup_val_field_opt i dom_fields with
+                         | Some t -> nullE() (* consumed by migration (not produced) *)
+                            (*TBR: could also reuse if compatible *)
+                         | None -> dotE (varE v) i t)
+                       fields) fields))))
+  in
   let ds =
-    varD state (optE (primE (I.ICStableRead ty) []))
+    varD state (optE migration)
     ::
     nary_funcD get_state []
       (let v = fresh_var "v" ty in
@@ -812,7 +864,8 @@ and dec' at n = function
     end
   | S.VarD (i, e) -> I.VarD (i.it, e.note.S.note_typ, exp e)
   | S.TypD _ -> assert false
-  | S.ClassD (sp, id, tbs, p, _t_opt, s, self_id, dfs) ->
+  | S.ClassD (sp, exp_opt, id, tbs, p, _t_opt, s, self_id, dfs) ->
+     (* TODO exp_opt *)
     let id' = {id with note = ()} in
     let sort, _, _, _, _ = Type.as_func n.S.note_typ in
     let op = match sp.it with
@@ -839,13 +892,13 @@ and dec' at n = function
         let (_, _, obj_typ) = T.as_async rng_typ in
         let c = Cons.fresh T.default_scope_var (T.Abs ([], T.scope_bound)) in
         asyncE T.Fut (typ_arg c T.Scope T.scope_bound) (* TBR *)
-          (wrap { it = obj_block at s (Some self_id) dfs (T.promote obj_typ);
+          (wrap { it = obj_block at  s exp_opt (Some self_id) dfs (T.promote obj_typ);
             at = at;
             note = Note.{def with typ = obj_typ } })
           (List.hd inst)
       else
        wrap
-        { it = obj_block at s (Some self_id) dfs rng_typ;
+        { it = obj_block at s exp_opt (Some self_id) dfs rng_typ;
           at = at;
           note = Note.{ def with typ = rng_typ } }
     in
@@ -1023,7 +1076,7 @@ let import_compiled_class (lib : S.comp_unit) wasm : import_declaration =
   let f = lib.note.filename in
   let { body; _ } = lib.it in
   let id = match body.it with
-    | S.ActorClassU (_, id, _, _, _, _, _) -> id.it
+    | S.ActorClassU (_, _, id, _, _, _, _, _) -> id.it
     | _ -> assert false
   in
   let fun_typ = T.normalize body.note.S.note_typ in
@@ -1118,7 +1171,8 @@ let transform_unit_body (u : S.comp_unit_body) : Ir.comp_unit =
     I.LibU ([], {
       it = build_obj u.at T.Module self_id fields u.note.S.note_typ;
       at = u.at; note = typ_note u.note})
-  | S.ActorClassU (sp, typ_id, _tbs, p, _, self_id, fields) ->
+  | S.ActorClassU (sp, exp_opt, typ_id, _tbs, p, _, self_id, fields) ->
+    (* TODO exp_opt *)
     let fun_typ = u.note.S.note_typ in
     let op = match sp.it with
       | T.Local -> None
@@ -1134,7 +1188,7 @@ let transform_unit_body (u : S.comp_unit_body) : Ir.comp_unit =
         T.promote rng
       | _ -> assert false
     in
-    let actor_expression = build_actor u.at ts (Some self_id) fields obj_typ in
+    let actor_expression = build_actor u.at ts exp_opt (Some self_id) fields obj_typ in
     let e = wrap {
        it = actor_expression;
        at = no_region;
@@ -1145,8 +1199,8 @@ let transform_unit_body (u : S.comp_unit_body) : Ir.comp_unit =
       I.ActorU (Some args, ds, fs, u, t)
     | _ -> assert false
     end
-  | S.ActorU (self_id, fields) ->
-    let actor_expression = build_actor u.at [] self_id fields u.note.S.note_typ in
+  | S.ActorU (exp_opt, self_id, fields) ->
+    let actor_expression = build_actor u.at [] exp_opt self_id fields u.note.S.note_typ in
     begin match actor_expression with
     | I.ActorE (ds, fs, u, t) ->
       I.ActorU (None, ds, fs, u, t)
@@ -1182,7 +1236,7 @@ let import_unit (u : S.comp_unit) : import_declaration =
     raise (Invalid_argument "Desugar: Cannot import actor")
   | I.ActorU (Some as_, ds, fs, up, actor_t) ->
     let id = match body.it with
-      | S.ActorClassU (_, id, _, _, _, _, _) -> id.it
+      | S.ActorClassU (_, _, id, _, _, _, _, _) -> id.it
       | _ -> assert false
     in
     let s, cntrl, tbs, ts1, ts2 = T.as_func t in

src/mo_def/arrange.ml

@@ -69,7 +69,10 @@ module Make (Cfg : Config) = struct
     | FromCandidE e       -> "FromCandidE" $$ [exp e]
     | TupE es             -> "TupE"      $$ exps es
     | ProjE (e, i)        -> "ProjE"     $$ [exp e; Atom (string_of_int i)]
-    | ObjBlockE (s, nt, dfs) -> "ObjBlockE" $$ [obj_sort s;
+    | ObjBlockE (s, po, nt, dfs) -> "ObjBlockE" $$ [obj_sort s;
+                                                (match po with
+                                                |  None -> Atom "_"
+                                                |  Some e -> exp e);
                                                 match nt with
                                                 | None, None -> Atom "_"
                                                 | None, Some t -> typ t
@@ -267,8 +270,9 @@ module Make (Cfg : Config) = struct
     | VarD (x, e) -> "VarD" $$ [id x; exp e]
     | TypD (x, tp, t) ->
       "TypD" $$ [id x] @ List.map typ_bind tp @ [typ t]
-    | ClassD (sp, x, tp, p, rt, s, i', dfs) ->
-      "ClassD" $$ shared_pat sp :: id x :: List.map typ_bind tp @ [
+    | ClassD (sp, po, x, tp, p, rt, s, i', dfs) ->
+       "ClassD" $$ shared_pat sp :: id x :: List.map typ_bind tp @ [
+        (match po with None -> Atom "_" | Some e -> exp e);
         pat p;
         (match rt with None -> Atom "_" | Some t -> typ t);
         obj_sort s; id i'