feat: burning cycles programmatically (#4690)

This adds a new primitive `(prim "cyclesBurn")` and a `prim.mo` function `cyclesBurn : <system> Nat -> Nat`. It can be used to burn (some of the) canister's cycles programmatically using the system interface `ic0.cycles_burn128`.

Building.md

@@ -56,11 +56,11 @@ For more details on our CI and CI setup, see `CI.md`.
 
 ## Making releases
 
-We make frequent releases, at least weekly. The steps to make a release (say, version 0.12.1) are:
+We make frequent releases, at least weekly. The steps to make a release (say, version 0.13.1) are:
 
  * Make sure that the top section of `Changelog.md` has a title like
 
-        ## 0.12.1 (2024-07-29)
+        ## 0.13.1 (2024-09-10)
 
    with today’s date.
 
@@ -77,18 +77,18 @@ We make frequent releases, at least weekly. The steps to make a release (say, ve
 
  * Define a shell variable `export MOC_MINOR=1`
 
- * Look at `git log --first-parent 0.12.$(expr $MOC_MINOR - 1)..HEAD` and check
+ * Look at `git log --first-parent 0.13.$(expr $MOC_MINOR - 1)..HEAD` and check
    that everything relevant is mentioned in the changelog section, and possibly
    clean it up a bit, curating the information for the target audience.
 
- * `git commit -am "chore: Releasing 0.12."$MOC_MINOR`
+ * `git commit -am "chore: Releasing 0.13."$MOC_MINOR`
  * Create a PR from this commit, and label it `automerge-squash`. E.g.
-   with `git push origin HEAD:$USER/0.12.$MOC_MINOR`. Mergify will
+   with `git push origin HEAD:$USER/0.13.$MOC_MINOR`. Mergify will
    merge it into `master` without additional approval, but it will take some
    time as the title (version number) enters into the `nix` dependency tracking.
  * `git switch master; git pull --rebase`. The release commit should be your `HEAD`
- * `git tag 0.12.$MOC_MINOR -m "Motoko 0.12."$MOC_MINOR`
- * `git push origin 0.12.$MOC_MINOR`
+ * `git tag 0.13.$MOC_MINOR -m "Motoko 0.13."$MOC_MINOR`
+ * `git push origin 0.13.$MOC_MINOR`
 
 Pushing the tag should cause GitHub Actions to create a “Release” on the GitHub
 project. This will fail if the changelog is not in order (in this case, fix and
@@ -102,12 +102,12 @@ branch to the `next-moc` branch.
 * Wait ca. 5min after releasing to give the CI/CD pipeline time to upload the release artifacts
 * Change into `motoko-base`
 * `git switch next-moc; git pull`
-* `git switch -c $USER/update-moc-0.12.$MOC_MINOR`
+* `git switch -c $USER/update-moc-0.13.$MOC_MINOR`
 * Update the `CHANGELOG.md` file with an entry at the top
 * Update the `moc_version` env variable in `.github/workflows/{ci, package-set}.yml` and `mops.toml`
   to the new released version:
-  `perl -pi -e "s/moc_version: \"0\.12\.\\d+\"/moc_version: \"0.12.$MOC_MINOR\"/g; s/moc = \"0\.12\.\\d+\"/moc = \"0.12.$MOC_MINOR\"/g; s/version = \"0\.12\.\\d+\"/version = \"0.12.$MOC_MINOR\"/g" .github/workflows/ci.yml .github/workflows/package-set.yml mops.toml`
-* `git add .github/ CHANGELOG.md mops.toml && git commit -m "Motoko 0.12."$MOC_MINOR`
+  `perl -pi -e "s/moc_version: \"0\.13\.\\d+\"/moc_version: \"0.13.$MOC_MINOR\"/g; s/moc = \"0\.13\.\\d+\"/moc = \"0.13.$MOC_MINOR\"/g; s/version = \"0\.13\.\\d+\"/version = \"0.13.$MOC_MINOR\"/g" .github/workflows/ci.yml .github/workflows/package-set.yml mops.toml`
+* `git add .github/ CHANGELOG.md mops.toml && git commit -m "Motoko 0.13."$MOC_MINOR`
 * Revise `CHANGELOG.md`, adding a top entry for the release
 * You can `git push` now
 
@@ -117,8 +117,8 @@ repo by a scheduled `niv-updater-action`.
 
 Finally tag the base release (so the documentation interpreter can do the right thing):
 * `git switch master && git pull`
-* `git tag moc-0.12.$MOC_MINOR`
-* `git push origin moc-0.12.$MOC_MINOR`
+* `git tag moc-0.13.$MOC_MINOR`
+* `git push origin moc-0.13.$MOC_MINOR`
 
 If you want to update the portal documentation, typically to keep in sync with a `dfx` release, follow the instructions in https://github.com/dfinity/portal/blob/master/MAINTENANCE.md.
 

Changelog.md

@@ -2,7 +2,10 @@
 
 * motoko (`moc`)
 
-  * **For beta testing:** Support __enhanced orthogonal persistence__, enabled with new moc flag `--enhanced-orthogonal-persistence` (#4193).
+  * Added a new primitive `cyclesBurn : <system> Nat -> Nat` for burning the canister's cycles
+    programmatically (#4690).
+
+  * **For beta testing:** Support __enhanced orthogonal persistence__, enabled with new `moc` flag `--enhanced-orthogonal-persistence` (#4193).
 
     This implements scalable and efficient orthogonal persistence (stable variables) for Motoko:
     * The Wasm main memory (heap) is retained on upgrade with new program versions directly picking up this state.

src/codegen/compile_classical.ml

@@ -5073,6 +5073,7 @@ module IC = struct
       E.add_func_import env "ic0" "msg_cycles_available128" [I32Type] [];
       E.add_func_import env "ic0" "msg_cycles_refunded128" [I32Type] [];
       E.add_func_import env "ic0" "msg_cycles_accept128" [I64Type; I64Type; I32Type] [];
+      E.add_func_import env "ic0" "cycles_burn128" [I64Type; I64Type; I32Type] [];
       E.add_func_import env "ic0" "certified_data_set" (i32s 2) [];
       E.add_func_import env "ic0" "data_certificate_present" [] [I32Type];
       E.add_func_import env "ic0" "data_certificate_size" [] [I32Type];
@@ -5093,8 +5094,7 @@ module IC = struct
       E.add_func_import env "ic0" "stable64_grow" [I64Type] [I64Type];
       E.add_func_import env "ic0" "time" [] [I64Type];
       if !Flags.global_timer then
-        E.add_func_import env "ic0" "global_timer_set" [I64Type] [I64Type];
-      ()
+        E.add_func_import env "ic0" "global_timer_set" [I64Type] [I64Type]
 
   let system_imports env =
     match E.mode env with
@@ -5490,57 +5490,57 @@ module IC = struct
 
   let cycle_balance env =
     match E.mode env with
-    | Flags.ICMode
-    | Flags.RefMode ->
+    | Flags.(ICMode | RefMode) ->
       system_call env "canister_cycle_balance128"
     | _ ->
       E.trap_with env "cannot read balance when running locally"
 
   let cycles_add env =
     match E.mode env with
-    | Flags.ICMode
-    | Flags.RefMode ->
+    | Flags.(ICMode | RefMode) ->
       system_call env "call_cycles_add128"
     | _ ->
       E.trap_with env "cannot accept cycles when running locally"
 
   let cycles_accept env =
     match E.mode env with
-    | Flags.ICMode
-    | Flags.RefMode ->
+    | Flags.(ICMode | RefMode) ->
       system_call env "msg_cycles_accept128"
     | _ ->
       E.trap_with env "cannot accept cycles when running locally"
 
   let cycles_available env =
     match E.mode env with
-    | Flags.ICMode
-    | Flags.RefMode ->
+    | Flags.(ICMode | RefMode) ->
       system_call env "msg_cycles_available128"
     | _ ->
       E.trap_with env "cannot get cycles available when running locally"
 
   let cycles_refunded env =
     match E.mode env with
-    | Flags.ICMode
-    | Flags.RefMode ->
+    | Flags.(ICMode | RefMode) ->
       system_call env "msg_cycles_refunded128"
     | _ ->
       E.trap_with env "cannot get cycles refunded when running locally"
 
+  let cycles_burn env =
+    match E.mode env with
+    | Flags.(ICMode | RefMode) ->
+      system_call env "cycles_burn128"
+    | _ ->
+      E.trap_with env "cannot burn cycles when running locally"
+
   let set_certified_data env =
     match E.mode env with
-    | Flags.ICMode
-    | Flags.RefMode ->
+    | Flags.(ICMode | RefMode) ->
       Blob.as_ptr_len env ^^
       system_call env "certified_data_set"
     | _ ->
       E.trap_with env "cannot set certified data when running locally"
 
   let get_certificate env =
     match E.mode env with
-    | Flags.ICMode
-    | Flags.RefMode ->
+    | Flags.(ICMode | RefMode) ->
       system_call env "data_certificate_present" ^^
       G.if1 I32Type
       begin
@@ -5649,6 +5649,18 @@ module Cycles = struct
       )
     )
 
+  let burn env =
+    Func.share_code1 Func.Always env "cycle_burn" ("cycles", I32Type) [I32Type] (fun env get_x ->
+      Stack.with_words env "dst" 4l (fun get_dst ->
+        get_x ^^
+        to_two_word64 env ^^
+        get_dst ^^
+        IC.cycles_burn env ^^
+        get_dst ^^
+        from_word128_ptr env
+      )
+    )
+
 end (* Cycles *)
 
 (* Low-level, almost raw access to IC stable memory.
@@ -12067,6 +12079,8 @@ and compile_prim_invocation (env : E.t) ae p es at =
     SR.Vanilla, Cycles.available env
   | SystemCyclesRefundedPrim, [] ->
     SR.Vanilla, Cycles.refunded env
+  | SystemCyclesBurnPrim, [e1] ->
+    SR.Vanilla, compile_exp_vanilla env ae e1 ^^ Cycles.burn env
 
   | SetCertifiedData, [e1] ->
     SR.unit, compile_exp_vanilla env ae e1 ^^ IC.set_certified_data env

src/codegen/compile_enhanced.ml

@@ -4731,6 +4731,7 @@ module IC = struct
       E.add_func_import env "ic0" "msg_cycles_available128" [I64Type] [];
       E.add_func_import env "ic0" "msg_cycles_refunded128" [I64Type] [];
       E.add_func_import env "ic0" "msg_cycles_accept128" (i64s 3) [];
+      E.add_func_import env "ic0" "cycles_burn128" (i64s 3) [];
       E.add_func_import env "ic0" "certified_data_set" (i64s 2) [];
       E.add_func_import env "ic0" "data_certificate_present" [] [I32Type];
       E.add_func_import env "ic0" "data_certificate_size" [] [I64Type];
@@ -4751,8 +4752,7 @@ module IC = struct
       E.add_func_import env "ic0" "stable64_grow" [I64Type] [I64Type];
       E.add_func_import env "ic0" "time" [] [I64Type];
       if !Flags.global_timer then
-        E.add_func_import env "ic0" "global_timer_set" [I64Type] [I64Type];
-      ()
+        E.add_func_import env "ic0" "global_timer_set" [I64Type] [I64Type]
 
   let system_imports env =
     match E.mode env with
@@ -5221,57 +5221,57 @@ module IC = struct
 
   let cycle_balance env =
     match E.mode env with
-    | Flags.ICMode
-    | Flags.RefMode ->
+    | Flags.(ICMode | RefMode) ->
       system_call env "canister_cycle_balance128"
     | _ ->
       E.trap_with env "cannot read balance when running locally"
 
   let cycles_add env =
     match E.mode env with
-    | Flags.ICMode
-    | Flags.RefMode ->
+    | Flags.(ICMode | RefMode) ->
       system_call env "call_cycles_add128"
     | _ ->
       E.trap_with env "cannot accept cycles when running locally"
 
   let cycles_accept env =
     match E.mode env with
-    | Flags.ICMode
-    | Flags.RefMode ->
+    | Flags.(ICMode | RefMode) ->
       system_call env "msg_cycles_accept128"
     | _ ->
       E.trap_with env "cannot accept cycles when running locally"
 
   let cycles_available env =
     match E.mode env with
-    | Flags.ICMode
-    | Flags.RefMode ->
+    | Flags.(ICMode | RefMode) ->
       system_call env "msg_cycles_available128"
     | _ ->
       E.trap_with env "cannot get cycles available when running locally"
 
   let cycles_refunded env =
     match E.mode env with
-    | Flags.ICMode
-    | Flags.RefMode ->
+    | Flags.(ICMode | RefMode) ->
       system_call env "msg_cycles_refunded128"
     | _ ->
       E.trap_with env "cannot get cycles refunded when running locally"
 
+  let cycles_burn env =
+    match E.mode env with
+    | Flags.(ICMode | RefMode) ->
+      system_call env "cycles_burn128"
+    | _ ->
+      E.trap_with env "cannot burn cycles when running locally"
+
   let set_certified_data env =
     match E.mode env with
-    | Flags.ICMode
-    | Flags.RefMode ->
+    | Flags.(ICMode | RefMode) ->
       Blob.as_ptr_len env ^^
       system_call env "certified_data_set"
     | _ ->
       E.trap_with env "cannot set certified data when running locally"
 
   let get_certificate env =
     match E.mode env with
-    | Flags.ICMode
-    | Flags.RefMode ->
+    | Flags.(ICMode | RefMode) ->
       system_call env "data_certificate_present" ^^
       Bool.from_rts_int32 ^^
       E.if1 I64Type
@@ -5338,7 +5338,7 @@ module Cycles = struct
 
   let balance env =
     Func.share_code0 Func.Always env "cycle_balance" [I64Type] (fun env ->
-      Stack.with_words env "dst" 4L (fun get_dst ->
+      Stack.with_words env "dst" 2L (fun get_dst ->
         get_dst ^^
         IC.cycle_balance env ^^
         get_dst ^^
@@ -5355,7 +5355,7 @@ module Cycles = struct
 
   let accept env =
     Func.share_code1 Func.Always env "cycle_accept" ("cycles", I64Type) [I64Type] (fun env get_x ->
-      Stack.with_words env "dst" 4L (fun get_dst ->
+      Stack.with_words env "dst" 2L (fun get_dst ->
         get_x ^^
         to_two_word64 env ^^
         get_dst ^^
@@ -5367,7 +5367,7 @@ module Cycles = struct
 
   let available env =
     Func.share_code0 Func.Always env "cycle_available" [I64Type] (fun env ->
-      Stack.with_words env "dst" 4L (fun get_dst ->
+      Stack.with_words env "dst" 2L (fun get_dst ->
         get_dst ^^
         IC.cycles_available env ^^
         get_dst ^^
@@ -5377,14 +5377,26 @@ module Cycles = struct
 
   let refunded env =
     Func.share_code0 Func.Always env "cycle_refunded" [I64Type] (fun env ->
-      Stack.with_words env "dst" 4L (fun get_dst ->
+      Stack.with_words env "dst" 2L (fun get_dst ->
         get_dst ^^
         IC.cycles_refunded env ^^
         get_dst ^^
         from_word128_ptr env
       )
     )
 
+  let burn env =
+    Func.share_code1 Func.Always env "cycle_burn" ("cycles", I64Type) [I64Type] (fun env get_x ->
+      Stack.with_words env "dst" 2L (fun get_dst ->
+        get_x ^^
+        to_two_word64 env ^^
+        get_dst ^^
+        IC.cycles_burn env ^^
+        get_dst ^^
+        from_word128_ptr env
+      )
+    )
+
 end (* Cycles *)
 
 (* Low-level, almost raw access to IC stable memory.
@@ -12245,6 +12257,8 @@ and compile_prim_invocation (env : E.t) ae p es at =
     SR.Vanilla, Cycles.available env
   | SystemCyclesRefundedPrim, [] ->
     SR.Vanilla, Cycles.refunded env
+  | SystemCyclesBurnPrim, [e1] ->
+    SR.Vanilla, compile_exp_vanilla env ae e1 ^^ Cycles.burn env
 
   | SetCertifiedData, [e1] ->
     SR.unit, compile_exp_vanilla env ae e1 ^^ IC.set_certified_data env

src/ir_def/arrange_ir.ml

@@ -101,6 +101,7 @@ and prim = function
   | SystemCyclesAvailablePrim -> Atom "SystemCyclesAvailablePrim"
   | SystemCyclesBalancePrim -> Atom "SystemCyclesBalancePrim"
   | SystemCyclesRefundedPrim -> Atom "SystemCyclesRefundedPrim"
+  | SystemCyclesBurnPrim -> Atom "SystemCyclesBurnPrim"
   | SetCertifiedData  -> Atom "SetCertifiedData"
   | GetCertificate    -> Atom "GetCertificate"
   | OtherPrim s       -> Atom s

src/ir_def/check_ir.ml

@@ -676,7 +676,7 @@ let rec check_exp env (exp:Ir.exp) : unit =
     (* Cycles *)
     | (SystemCyclesBalancePrim | SystemCyclesAvailablePrim | SystemCyclesRefundedPrim), [] ->
       T.nat <: t
-    | SystemCyclesAcceptPrim, [e1] ->
+    | (SystemCyclesAcceptPrim | SystemCyclesBurnPrim), [e1] ->
       typ e1 <: T.nat;
       T.nat <: t
     | SystemCyclesAddPrim, [e1] ->

src/ir_def/construct.ml

@@ -107,7 +107,8 @@ let primE prim es =
     | RelPrim _ -> T.bool
     | SerializePrim _ -> T.blob
     | SystemCyclesAvailablePrim
-    | SystemCyclesAcceptPrim -> T.nat
+    | SystemCyclesAcceptPrim
+    | SystemCyclesBurnPrim -> T.nat
     | DeserializePrim ts -> T.seq ts
     | DeserializeOptPrim ts -> T.Opt (T.seq ts)
     | OtherPrim "trap" -> T.Non

src/ir_def/ir.ml

@@ -159,6 +159,7 @@ and prim =
   | SystemCyclesAvailablePrim
   | SystemCyclesBalancePrim
   | SystemCyclesRefundedPrim
+  | SystemCyclesBurnPrim
   | SetCertifiedData
   | GetCertificate
 
@@ -308,6 +309,7 @@ let map_prim t_typ t_id p =
   | SystemCyclesAvailablePrim
   | SystemCyclesBalancePrim
   | SystemCyclesRefundedPrim
+  | SystemCyclesBurnPrim
   | SetCertifiedData
   | GetCertificate
   | OtherPrim _ -> p