feat: Implement heartbeat support

Changelog.md

@@ -1,5 +1,9 @@
 # Motoko compiler changelog
 
+* motoko
+
+  * Implement support for `heartbeat` system methods (thanks to Paul Liu) (#2971)
+
 ## 0.6.19 (2022-01-05)
 
 * motoko-base

doc/modules/language-guide/examples/Alarm.mo

@@ -0,0 +1,18 @@
+import Debug "mo:base/Debug";
+
+actor Alarm {
+
+  let n = 5;
+  var count = 0;
+
+  public shared func ring() : async () {
+    Debug.print("Ring!");
+  };
+
+  system func heartbeat() : async () {
+    if (count % n == 0) {
+      await ring();
+    };
+    count += 1;
+  }
+}

doc/modules/language-guide/lang-nav.adoc

@@ -18,6 +18,7 @@
 ** xref:upgrades.adoc[Stable variables and upgrade methods]
 ** xref:compatibility.adoc[Upgrade compatibility]
 ** xref:stablememory.adoc[The ExperimentalStableMemory library]
+** xref:heartbeats.adoc[Heartbeats]
 //** xref:advanced-discussion.adoc[Advanced discussion topics]
 ** xref:language-manual.adoc[Language quick reference]
 ** xref:compiler-ref.adoc[Compiler reference]

doc/modules/language-guide/pages/heartbeats.adoc

@@ -0,0 +1,29 @@
+= Heartbeats
+:proglang: Motoko
+:company-id: DFINITY
+
+{IC} canisters can elect to receive regular heartbeat messages by exposing a particular `canister_heartbeat` function (see https://smartcontracts.org/docs/interface-spec/index.html#_heartbeat[heartbeat]).
+
+In {proglang}, an actor can receive heartbeat messages by declaring a `system` function, named `heartbeat`, with no arguments, returning a future of unit type (``async ()``).
+
+A simple, contrived example is a recurrent alarm, that sends a message to itself every ``n``-th heartbeat:
+
+[source,motoko]
+----
+include::../examples/Alarm.mo[]
+----
+
+The `heartbeat` function, when declared, is called on every {IC}
+subnet _heartbeat_, by scheduling an asynchronous call to the
+`heartbeat` function.
+Due to its `async` return type, a heartbeat
+function may send further messages and await results.
+The result of a
+heartbeat call, including any trap or thrown error, is ignored.
+The implicit context switch inherent to calling every Motoko async function,
+means that the time the `heartbeat` body is executed may be later than
+the time the heartbeat was issued by the subnet.
+
+As an `async` function, ``Alarm``'s `hearbeat` function is free to call other
+asynchronous functions (the inner call to `ring()` above is an example),
+as well as shared functions of other canisters.

doc/modules/language-guide/pages/language-manual.adoc

@@ -1269,15 +1269,21 @@ The declaration `<dec>` of a `system` field must be a manifest `func` declaratio
 |===
 |  name | type | description
 
+| `heartbeat`  | `+() -> async ()+` | hearbeat action
 | `preupgrade`  | `+() -> ()+` | pre upgrade action
 | `postupgrade` | `+() -> ()+` | post upgrade action
 |===
 
+* `heartbeat`, when declared, is called on every Internet Computer subnet *heartbeat*,
+scheduling an asynchronous call to the `heartbeat` function. Due to its `async` return type, a heartbeat function may send messages and await results. The result of a heartbeat call, including
+any trap or thrown error, is ignored. The implicit context switch means that
+the time the heartbeat body is executed may be later than the time the
+heartbeat was issued by the subnet.
 * `preupgrade`, when declared, is called during an upgrade, immediately _before_ the (current) values of the (retired) actor's stable variables are transferred to the replacement actor.
 * `postupgrade`, when declared, is called during an upgrade, immediately _after_ the (replacement) actor body has initialized its fields
 (inheriting values of the retired actors' stable variables), and before its first message is processed.
 
-These system methods provide the opportunity to save and restore in-flight data structures (e.g. caches) that are better represented using non-stable types.
+These `preupgrade` and `postupgrade` system methods provide the opportunity to save and restore in-flight data structures (e.g. caches) that are better represented using non-stable types.
 
 During an upgrade, a trap occuring in the implicit call to `preupgrade()` or `postupgrade()` causes the entire upgrade to trap, preserving the pre-upgrade actor.
 

src/codegen/compile.ml

@@ -3581,6 +3581,18 @@ module IC = struct
       edesc = nr (FuncExport (nr fi))
       })
 
+  let export_heartbeat env =
+    assert (E.mode env = Flags.ICMode || E.mode env = Flags.RefMode);
+    let fi = E.add_fun env "canister_heartbeat"
+      (Func.of_body env [] [] (fun env ->
+        G.i (Call (nr (E.built_in env "heartbeat_exp"))) ^^
+        E.collect_garbage env))
+    in
+    E.add_export env (nr {
+      name = Wasm.Utf8.decode "canister_heartbeat";
+      edesc = nr (FuncExport (nr fi))
+    })
+
   let export_wasi_start env =
     assert (E.mode env = Flags.WASIMode);
     let fi = E.add_fun env "_start" (Func.of_body env [] [] (fun env1 ->
@@ -8827,6 +8839,15 @@ and main_actor as_opt mod_env ds fs up =
       compile_exp_as env ae2 SR.unit up.postupgrade);
     IC.export_upgrade_methods env;
 
+    (* Export heartbeat (but only when required) *)
+    begin match up.heartbeat.it with
+     | Ir.PrimE (Ir.TupPrim, []) -> ()
+     | _ ->
+       Func.define_built_in env "heartbeat_exp" [] [] (fun env ->
+         compile_exp_as env ae2 SR.unit up.heartbeat);
+       IC.export_heartbeat env;
+    end;
+
     (* Export metadata *)
     env.E.stable_types :=
       Some (
@@ -8841,17 +8862,18 @@ and main_actor as_opt mod_env ds fs up =
         List.mem "candid:args" !Flags.public_metadata_names,
         up.meta.candid.args);
 
+
     (* Deserialize any arguments *)
     begin match as_opt with
-     | None
-     | Some [] ->
-       (* Liberally accept empty as well as unit argument *)
-       assert (arg_tys = []);
-       IC.system_call env "ic0" "msg_arg_data_size" ^^
-       G.if0 (Serialization.deserialize env arg_tys) G.nop
-     | Some (_ :: _) ->
-       Serialization.deserialize env arg_tys ^^
-       G.concat_map (Var.set_val env ae1) (List.rev arg_names)
+      | None
+      | Some [] ->
+        (* Liberally accept empty as well as unit argument *)
+        assert (arg_tys = []);
+        IC.system_call env "ic0" "msg_arg_data_size" ^^
+        G.if0 (Serialization.deserialize env arg_tys) G.nop
+      | Some (_ :: _) ->
+        Serialization.deserialize env arg_tys ^^
+        G.concat_map (Var.set_val env ae1) (List.rev arg_names)
     end ^^
     (* Continue with decls *)
     decls_codeW G.nop

src/ir_def/arrange_ir.ml

@@ -33,8 +33,8 @@ let rec exp e = match e.it with
   | NewObjE (s, fs, t)  -> "NewObjE" $$ (Arrange_type.obj_sort s :: fields fs @ [typ t])
   | TryE (e, cs)        -> "TryE" $$ [exp e] @ List.map case cs
 
-and system { preupgrade; postupgrade; meta } = (* TODO: show meta? *)
-  "System" $$ ["Pre" $$ [exp preupgrade]; "Post" $$ [exp postupgrade]]
+and system { meta; preupgrade; postupgrade; heartbeat } = (* TODO: show meta? *)
+  "System" $$ ["Pre" $$ [exp preupgrade]; "Post" $$ [exp postupgrade]; "Heartbeat" $$ [exp heartbeat]]
 
 and lexp le = match le.it with
   | VarLE i             -> "VarLE" $$ [id i]

src/ir_def/check_ir.ml

@@ -772,16 +772,18 @@ let rec check_exp env (exp:Ir.exp) : unit =
     typ exp_f <: T.unit;
     typ exp_k <: T.Func (T.Local, T.Returns, [], ts, []);
     typ exp_r <: T.Func (T.Local, T.Returns, [], [T.error], []);
-  | ActorE (ds, fs, { preupgrade; postupgrade; meta }, t0) ->
+  | ActorE (ds, fs, { preupgrade; postupgrade; meta; heartbeat }, t0) ->
     (* TODO: check meta *)
     let env' = { env with async = None } in
     let scope1 = gather_block_decs env' ds in
     let env'' = adjoin env' scope1 in
     check_decs env'' ds;
     check_exp env'' preupgrade;
     check_exp env'' postupgrade;
+    check_exp env'' heartbeat;
     typ preupgrade <: T.unit;
     typ postupgrade <: T.unit;
+    typ heartbeat <: T.unit;
     check (T.is_obj t0) "bad annotation (object type expected)";
     let (s0, tfs0) = T.as_obj t0 in
     let val_tfs0 = List.filter (fun tf -> not (T.is_typ tf.T.typ)) tfs0 in
@@ -1092,7 +1094,7 @@ let check_comp_unit env = function
     let scope = gather_block_decs env ds in
     let env' = adjoin env scope in
     check_decs env' ds
-  | ActorU (as_opt, ds, fs, { preupgrade; postupgrade; meta}, t0) ->
+  | ActorU (as_opt, ds, fs, { preupgrade; postupgrade; meta; heartbeat }, t0) ->
     let check p = check env no_region p in
     let (<:) t1 t2 = check_sub env no_region t1 t2 in
     let env' = match as_opt with
@@ -1107,6 +1109,7 @@ let check_comp_unit env = function
     check_decs env'' ds;
     check_exp env'' preupgrade;
     check_exp env'' postupgrade;
+    check_exp env'' heartbeat;
     typ preupgrade <: T.unit;
     typ postupgrade <: T.unit;
     check (T.is_obj t0) "bad annotation (object type expected)";

src/ir_def/freevars.ml

@@ -118,7 +118,7 @@ let rec exp e : f = match e.it with
 
 and actor ds fs u = close (decs ds +++ fields fs +++ system u)
 
-and system {meta; preupgrade; postupgrade} = under_lambda (exp preupgrade) ++ under_lambda (exp postupgrade)
+and system {meta; preupgrade; postupgrade; heartbeat} = under_lambda (exp preupgrade) ++ under_lambda (exp postupgrade) ++ under_lambda (exp heartbeat)
 
 and exps es : f = unions exp es
 

src/ir_def/ir.ml

@@ -79,7 +79,8 @@ and exp' =
 and system = {
   meta : meta;
   preupgrade : exp;
-  postupgrade : exp
+  postupgrade : exp;
+  heartbeat : exp
 }
 
 and candid = {

src/ir_def/rename.ml

@@ -27,12 +27,12 @@ and exp' rho e  = match e with
   | VarE i              -> VarE (id rho i)
   | LitE l              -> e
   | PrimE (p, es)       -> PrimE (prim rho p, List.map (exp rho) es)
-  | ActorE (ds, fs, { meta; preupgrade; postupgrade }, t) ->
+  | ActorE (ds, fs, { meta; preupgrade; postupgrade; heartbeat }, t) ->
     let ds', rho' = decs rho ds in
     ActorE
       (ds',
        fields rho' fs,
-       {meta; preupgrade = exp rho' preupgrade; postupgrade = exp rho' postupgrade},
+       {meta; preupgrade = exp rho' preupgrade; postupgrade = exp rho' postupgrade; heartbeat = exp rho' heartbeat},
        t)
   | AssignE (e1, e2)    -> AssignE (lexp rho e1, exp rho e2)
   | BlockE (ds, e1)     -> let ds', rho' = decs rho ds
@@ -150,7 +150,7 @@ let comp_unit rho cu = match cu with
   | LibU (ds, e) ->
     let ds', rho' = decs rho ds
     in LibU (ds', exp rho' e)
-  | ActorU (as_opt, ds, fs, { meta; preupgrade; postupgrade }, t) ->
+  | ActorU (as_opt, ds, fs, { meta; preupgrade; postupgrade; heartbeat }, t) ->
     let as_opt', rho' = match as_opt with
       | None -> None, rho
       | Some as_ ->
@@ -159,4 +159,4 @@ let comp_unit rho cu = match cu with
     in
     let ds', rho'' = decs rho' ds in
     ActorU (as_opt', ds', fields rho'' fs,
-      { meta; preupgrade = exp rho'' preupgrade; postupgrade = exp rho'' postupgrade }, t)
+      { meta; preupgrade = exp rho'' preupgrade; postupgrade = exp rho'' postupgrade; heartbeat = exp rho'' heartbeat }, t)

src/ir_passes/async.ml

@@ -374,8 +374,8 @@ let transform mode prog =
             | Replies,_ -> assert false
           end
       end
-    | ActorE (ds, fs, {meta; preupgrade; postupgrade}, typ) ->
-      ActorE (t_decs ds, t_fields fs, {meta; preupgrade = t_exp preupgrade; postupgrade = t_exp postupgrade}, t_typ typ)
+    | ActorE (ds, fs, {meta; preupgrade; postupgrade; heartbeat}, typ) ->
+      ActorE (t_decs ds, t_fields fs, {meta; preupgrade = t_exp preupgrade; postupgrade = t_exp postupgrade; heartbeat = t_exp heartbeat}, t_typ typ)
     | NewObjE (sort, ids, t) ->
       NewObjE (sort, t_fields ids, t_typ t)
     | SelfCallE _ -> assert false
@@ -444,9 +444,9 @@ let transform mode prog =
   and t_comp_unit = function
     | LibU _ -> raise (Invalid_argument "cannot compile library")
     | ProgU ds -> ProgU (t_decs ds)
-    | ActorU (args_opt, ds, fs, {meta; preupgrade; postupgrade}, t) ->
+    | ActorU (args_opt, ds, fs, {meta; preupgrade; postupgrade; heartbeat}, t) ->
       ActorU (Option.map t_args args_opt, t_decs ds, t_fields fs,
-        { meta; preupgrade = t_exp preupgrade; postupgrade = t_exp postupgrade }, t_typ t)
+        { meta; preupgrade = t_exp preupgrade; postupgrade = t_exp postupgrade; heartbeat = t_exp heartbeat }, t_typ t)
 
   and t_prog (cu, flavor) = (t_comp_unit cu, { flavor with has_async_typ = false } )
 in

src/ir_passes/await.ml

@@ -119,11 +119,12 @@ and t_exp' context exp' =
   | FuncE (x, s, c, typbinds, pat, typ, exp) ->
     let context' = LabelEnv.add Return Label LabelEnv.empty in
     FuncE (x, s, c, typbinds, pat, typ,t_exp context' exp)
-  | ActorE (ds, ids, { meta; preupgrade; postupgrade }, t) ->
+  | ActorE (ds, ids, { meta; preupgrade; postupgrade; heartbeat }, t) ->
     ActorE (t_decs context ds, ids,
       { meta;
         preupgrade = t_exp LabelEnv.empty preupgrade;
-        postupgrade = t_exp LabelEnv.empty postupgrade},
+        postupgrade = t_exp LabelEnv.empty postupgrade;
+        heartbeat = t_exp LabelEnv.empty heartbeat},
       t)
   | NewObjE (sort, ids, typ) -> exp'
   | SelfCallE _ -> assert false
@@ -525,11 +526,12 @@ and t_comp_unit context = function
           expD (c_block context' ds (tupE []) (meta (T.unit) (fun v1 -> tupE [])))
         ]
     end
-  | ActorU (as_opt, ds, ids, { meta; preupgrade; postupgrade }, t) ->
+  | ActorU (as_opt, ds, ids, { meta; preupgrade; postupgrade; heartbeat }, t) ->
     ActorU (as_opt, t_decs context ds, ids,
       { meta;
         preupgrade = t_exp LabelEnv.empty preupgrade;
-        postupgrade = t_exp LabelEnv.empty postupgrade},
+        postupgrade = t_exp LabelEnv.empty postupgrade;
+        heartbeat = t_exp LabelEnv.empty heartbeat},
       t)
 
 and t_prog (prog, flavor) =

src/ir_passes/const.ml

@@ -159,11 +159,12 @@ let rec exp lvl (env : env) e : Lbool.t =
       surely_false
     | NewObjE _ -> (* mutable objects *)
       surely_false
-    | ActorE (ds, fs, {meta; preupgrade; postupgrade}, _typ) ->
+    | ActorE (ds, fs, {meta; preupgrade; postupgrade; heartbeat}, _typ) ->
       (* this may well be “the” top-level actor, so don’t update lvl here *)
       let (env', _) = decs lvl env ds in
       exp_ lvl env' preupgrade;
       exp_ lvl env' postupgrade;
+      exp_ lvl env' heartbeat;
       surely_false
   in
   set_lazy_const e lb;
@@ -217,14 +218,15 @@ and block lvl env (ds, body) =
 and comp_unit = function
   | LibU _ -> raise (Invalid_argument "cannot compile library")
   | ProgU ds -> decs_ TopLvl M.empty ds
-  | ActorU (as_opt, ds, fs, {meta; preupgrade; postupgrade}, typ) ->
+  | ActorU (as_opt, ds, fs, {meta; preupgrade; postupgrade; heartbeat}, typ) ->
     let env = match as_opt with
       | None -> M.empty
       | Some as_ -> args TopLvl M.empty as_
     in
     let (env', _) = decs TopLvl env ds in
     exp_ TopLvl env' preupgrade;
-    exp_ TopLvl env' postupgrade
+    exp_ TopLvl env' postupgrade;
+    exp_ TopLvl env' heartbeat
 
 let analyze ((cu, _flavor) : prog) =
   ignore (comp_unit cu)

src/ir_passes/eq.ml

@@ -250,15 +250,16 @@ and t_exp' env = function
     NewObjE (sort, ids, t)
   | SelfCallE (ts, e1, e2, e3) ->
     SelfCallE (ts, t_exp env e1, t_exp env e2, t_exp env e3)
-  | ActorE (ds, fields, {meta; preupgrade; postupgrade}, typ) ->
+  | ActorE (ds, fields, {meta; preupgrade; postupgrade; heartbeat}, typ) ->
     (* Until Actor expressions become their own units,
        we repeat what we do in `comp_unit` below *)
     let env1 = empty_env () in
     let ds' = t_decs env1 ds in
     let preupgrade' = t_exp env1 preupgrade in
     let postupgrade' = t_exp env1 postupgrade in
+    let heartbeat' = t_exp env1 heartbeat in
     let decls = eq_decls !(env1.params) in
-    ActorE (decls @ ds', fields, {meta; preupgrade = preupgrade'; postupgrade = postupgrade'}, typ)
+    ActorE (decls @ ds', fields, {meta; preupgrade = preupgrade'; postupgrade = postupgrade'; heartbeat = heartbeat'}, typ)
 
 and t_lexp env (e : Ir.lexp) = { e with it = t_lexp' env e.it }
 and t_lexp' env = function
@@ -286,13 +287,14 @@ and t_comp_unit = function
     let ds' = t_decs env ds in
     let decls = eq_decls !(env.params) in
     ProgU (decls @ ds')
-  | ActorU (as_opt, ds, fields, {meta; preupgrade; postupgrade}, typ) ->
+  | ActorU (as_opt, ds, fields, {meta; preupgrade; postupgrade; heartbeat}, typ) ->
     let env = empty_env () in
     let ds' = t_decs env ds in
     let preupgrade' = t_exp env preupgrade in
     let postupgrade' = t_exp env postupgrade in
+    let heartbeat' = t_exp env heartbeat in
     let decls = eq_decls !(env.params) in
-    ActorU (as_opt, decls @ ds', fields, {meta; preupgrade = preupgrade'; postupgrade = postupgrade'}, typ)
+    ActorU (as_opt, decls @ ds', fields, {meta; preupgrade = preupgrade'; postupgrade = postupgrade'; heartbeat = heartbeat'}, typ)
 
 (* Entry point for the program transformation *)
 

src/ir_passes/erase_typ_field.ml

@@ -126,9 +126,9 @@ let transform prog =
       DefineE (id, mut, t_exp exp1)
     | FuncE (x, s, c, typbinds, args, ret_tys, exp) ->
       FuncE (x, s, c, t_typ_binds typbinds, t_args args, List.map t_typ ret_tys, t_exp exp)
-    | ActorE (ds, fs, {meta; preupgrade; postupgrade}, typ) ->
+    | ActorE (ds, fs, {meta; preupgrade; postupgrade; heartbeat}, typ) ->
       ActorE (t_decs ds, t_fields fs,
-        {meta; preupgrade = t_exp preupgrade; postupgrade = t_exp postupgrade}, t_typ typ)
+        {meta; preupgrade = t_exp preupgrade; postupgrade = t_exp postupgrade; heartbeat = t_exp heartbeat}, t_typ typ)
     | NewObjE (sort, ids, t) ->
       NewObjE (sort, t_fields ids, t_typ t)
     | SelfCallE _ -> assert false
@@ -200,9 +200,9 @@ let transform prog =
   and t_comp_unit = function
     | LibU _ -> raise (Invalid_argument "cannot compile library")
     | ProgU ds -> ProgU (t_decs ds)
-    | ActorU (args_opt, ds, fs, {meta; preupgrade; postupgrade}, t) ->
+    | ActorU (args_opt, ds, fs, {meta; preupgrade; postupgrade; heartbeat}, t) ->
       ActorU (Option.map t_args args_opt, t_decs ds, t_fields fs,
-        { meta; preupgrade = t_exp preupgrade; postupgrade = t_exp postupgrade }, t_typ t)
+        { meta; preupgrade = t_exp preupgrade; postupgrade = t_exp postupgrade; heartbeat = t_exp heartbeat }, t_typ t)
   and t_prog (cu, flavor) = (t_comp_unit cu, { flavor with has_typ_field = false } )
 in
   t_prog prog