From 9a3f5a2a7a840423370b6c54ce721b89f15cc260 Mon Sep 17 00:00:00 2001
From: luc-blaeser <luc.blaeser@dfinity.org>
Date: Mon, 18 Mar 2024 19:21:02 +0100
Subject: [PATCH 1/9] Object pooling

---
 rts/motoko-rts/src/gc/incremental/roots.rs |  28 +--
 src/codegen/compile.ml                     | 193 ++++++++++++++-------
 2 files changed, 143 insertions(+), 78 deletions(-)

diff --git a/rts/motoko-rts/src/gc/incremental/roots.rs b/rts/motoko-rts/src/gc/incremental/roots.rs
index 3dca8d6df38..43d8dff5638 100644
--- a/rts/motoko-rts/src/gc/incremental/roots.rs
+++ b/rts/motoko-rts/src/gc/incremental/roots.rs
@@ -2,11 +2,13 @@ use motoko_rts_macros::ic_mem_fn;
 
 use crate::{types::Value, visitor::is_non_null_pointer_field};
 
-/// Root referring to all canister variables.
-/// This root is reinitialized on each canister upgrade.
+/// An array referring to the static program variables, being
+/// - All canister variables.
+/// - Pooled shared objects.
+/// The array constitutes a GC root that is reinitialized on each canister upgrade.
 /// The scalar sentinel denotes an uninitialized root.
 #[cfg(feature = "ic")]
-static mut STATIC_ROOT: Value = Value::from_scalar(0);
+static mut STATIC_VARIABLES: Value = Value::from_scalar(0);
 
 /// GC root set.
 pub type Roots = [*mut Value; 6];
@@ -19,7 +21,7 @@ pub unsafe fn root_set() -> Roots {
         region::region0_get_ptr_loc,
     };
     [
-        static_root_location(),
+        static_variables_location(),
         continuation_table_loc(),
         stable_actor_location(),
         stable_type_descriptor().candid_data_location(),
@@ -41,21 +43,23 @@ pub unsafe fn visit_roots<C, V: Fn(&mut C, *mut Value)>(
 }
 
 #[cfg(feature = "ic")]
-unsafe fn static_root_location() -> *mut Value {
-    &mut STATIC_ROOT as *mut Value
+unsafe fn static_variables_location() -> *mut Value {
+    &mut STATIC_VARIABLES as *mut Value
 }
 
 #[ic_mem_fn(ic_only)]
-pub unsafe fn set_static_root<M: crate::memory::Memory>(mem: &mut M, value: Value) {
+pub unsafe fn set_static_variables<M: crate::memory::Memory>(mem: &mut M, array: Value) {
     use super::barriers::write_with_barrier;
+    use crate::types::TAG_ARRAY;
 
-    let location = &mut STATIC_ROOT as *mut Value;
-    write_with_barrier(mem, location, value);
+    assert_eq!(array.tag(), TAG_ARRAY);
+    let location = &mut STATIC_VARIABLES as *mut Value;
+    write_with_barrier(mem, location, array);
 }
 
 #[no_mangle]
 #[cfg(feature = "ic")]
-pub unsafe extern "C" fn get_static_root() -> Value {
-    debug_assert!(STATIC_ROOT.is_non_null_ptr());
-    STATIC_ROOT
+pub unsafe extern "C" fn get_static_variable(index: u32) -> Value {
+    debug_assert!(STATIC_VARIABLES.is_non_null_ptr());
+    STATIC_VARIABLES.as_array().get(index)
 }
diff --git a/src/codegen/compile.ml b/src/codegen/compile.ml
index af2bb5043cd..00f9c5264d0 100644
--- a/src/codegen/compile.ml
+++ b/src/codegen/compile.ml
@@ -389,7 +389,18 @@ module E = struct
     type_offsets_segment : int32;
     idl_types_segment : int32;
   }
-  type t = {
+  (* Object allocation code. *)
+  type object_allocation = t -> G.t
+  (* Pool of shared objects.
+     Alllocated in the dynamic heap on program initialization/upgrade.
+     Identified by the index position in this list and accessed via the runtime system.
+     Registered as GC root set and replaced on program upgrade. 
+  *)
+  and object_pool = {
+    objects: object_allocation list ref;
+    frozen: bool ref;
+  }
+  and t = {
     (* Global fields *)
     (* Static *)
     mode : Flags.compile_mode;
@@ -414,10 +425,8 @@ module E = struct
     built_in_funcs : lazy_function NameEnv.t ref;
     static_strings : int32 StringEnv.t ref;
     data_segments : string list ref; (* Passive data segments *)
-    static_variables : int32 ref;
-      (* Number of static variables (MutBox), accessed by index via the runtime system,
-         and belonging to the GC root set. *)
-
+    object_pool : object_pool;
+      
     (* Types accumulated in global typtbl (for candid subtype checks)
        See Note [Candid subtype checks]
     *)
@@ -448,6 +457,10 @@ module E = struct
     global_type_descriptor : type_descriptor option ref;
   }
 
+  (* Compile-time-known value, either a plain vanilla constant or a shared object. *)
+  type shared_value = 
+  | Vanilla of int32
+  | SharedObject of object_allocation
 
   (* The initial global environment *)
   let mk_global mode rts trap_with : t = {
@@ -467,7 +480,7 @@ module E = struct
     built_in_funcs = ref NameEnv.empty;
     static_strings = ref StringEnv.empty;
     data_segments = ref [];
-    static_variables = ref 0l;
+    object_pool = { objects = ref []; frozen = ref false };
     typtbl_typs = ref [];
     (* Metadata *)
     args = ref None;
@@ -714,13 +727,17 @@ module E = struct
   let get_data_segments (env : t) =
     !(env.data_segments)
 
-  let add_static_variable (env : t) : int32 =
-    let variable_index = !(env.static_variables) in
-    env.static_variables := Int32.add variable_index 1l;
-    variable_index
+  let object_pool_add (env : t) (allocation : t -> G.t) : int32 =
+    if !(env.object_pool.frozen) then raise (Invalid_argument "Object pool frozen");
+    let index = List.length !(env.object_pool.objects) in
+    env.object_pool.objects := !(env.object_pool.objects) @ [ allocation ];
+    Int32.of_int index
+
+  let object_pool_size (env : t) : int =
+    List.length !(env.object_pool.objects)
 
-  let count_static_variables (env : t) =
-    !(env.static_variables)
+  let iterate_object_pool (env : t) f =
+    G.concat_mapi f !(env.object_pool.objects)
 
   let collect_garbage env force =
     let name = "incremental_gc" in
@@ -1074,8 +1091,8 @@ module RTS = struct
     E.add_func_import env "rts" "save_stable_actor" [I32Type] [];
     E.add_func_import env "rts" "free_stable_actor" [] [];
     E.add_func_import env "rts" "contains_field" [I32Type; I32Type] [I32Type];
-    E.add_func_import env "rts" "set_static_root" [I32Type] [];
-    E.add_func_import env "rts" "get_static_root" [] [I32Type];
+    E.add_func_import env "rts" "set_static_variables" [I32Type] [];
+    E.add_func_import env "rts" "get_static_variable" [I32Type] [I32Type];
     E.add_func_import env "rts" "set_upgrade_instructions" [I64Type] [];
     E.add_func_import env "rts" "get_upgrade_instructions" [] [I64Type];
     E.add_func_import env "rts" "memcpy" [I32Type; I32Type; I32Type] [I32Type]; (* standard libc memcpy *)
@@ -1336,6 +1353,10 @@ module Heap = struct
   let get_heap_size env =
     E.call_import env "rts" "get_heap_size"
 
+  let get_static_variable env index = 
+    compile_unboxed_const index ^^
+    E.call_import env "rts" "get_static_variable"
+
 end (* Heap *)
 
 module Stack = struct
@@ -1966,8 +1987,8 @@ module Tagged = struct
      Null tests are possible without resolving the forwarding pointer of a non-null comparand.
   *)
 
-  let null_sentinel_pointer = 0xffff_fffbl (* skewed, pointing to last unallocated Wasm page *)
-  let null_pointer = compile_unboxed_const null_sentinel_pointer
+  let null_vanilla_pointer = 0xffff_fffbl (* skewed, pointing to last unallocated Wasm page *)
+  let null_pointer = compile_unboxed_const null_vanilla_pointer
 
   let not_null env =
     (* null test works without forwarding pointer resolution of a non-null comparand *)
@@ -2162,6 +2183,10 @@ module Tagged = struct
     get_object ^^
     allocation_barrier env
 
+  let share env allocation =
+    let index = E.object_pool_add env allocation in
+    Heap.get_static_variable env index
+
 end (* Tagged *)
 
 module MutBox = struct
@@ -2190,6 +2215,9 @@ module MutBox = struct
     Tagged.load_forwarding_pointer env ^^
     get_mutbox_value ^^
     Tagged.store_field env field
+  
+  let add_global_mutbox env =
+    E.object_pool_add env alloc
 end
 
 
@@ -2219,7 +2247,9 @@ module Opt = struct
 
   let some_payload_field = Tagged.header_size
 
+  let null_vanilla_lit = Tagged.null_vanilla_pointer
   let null_lit env = Tagged.null_pointer
+
   let is_some = Tagged.not_null
 
   let alloc_some env get_payload =
@@ -2244,6 +2274,11 @@ module Opt = struct
         )
     )
 
+  let constant env = function
+  | E.Vanilla value when value = null_vanilla_lit -> E.SharedObject (fun env -> alloc_some env (null_lit env)) (* ?ⁿnull for n > 0 *)
+  | E.Vanilla value -> E.Vanilla value (* not null and no `Opt` object *)
+  | E.SharedObject allocation -> E.SharedObject (fun env -> inject env (allocation env)) (* potentially wrap in new `Opt` *)
+
   (* This function is used where conceptually, Opt.inject should be used, but
   we know for sure that it wouldn’t do anything anyways, except dereferencing the forwarding pointer *)
   let inject_simple env e =
@@ -2355,11 +2390,12 @@ module Closure = struct
     G.i (CallIndirect (nr ty)) ^^
     FakeMultiVal.load env (Lib.List.make n_res I32Type)
 
-  let alloc env fi =
-    Tagged.obj env Tagged.Closure [
-      compile_unboxed_const (E.add_fun_ptr env fi);
+  let constant env get_fi =
+    let fi = E.add_fun_ptr env (get_fi ()) in
+    E.SharedObject (fun env -> Tagged.obj env Tagged.Closure [
+      compile_unboxed_const fi;
       compile_unboxed_const 0l
-    ]
+    ])
 
 end (* Closure *)
 
@@ -2392,12 +2428,12 @@ module BoxedWord64 = struct
     get_i ^^
     Tagged.allocation_barrier env
 
-  let lit env pty i =
+  let constant env pty i =
     if BitTagged.can_tag_const pty i
     then 
-      compile_unboxed_const (BitTagged.tag_const pty i)
+      E.Vanilla (BitTagged.tag_const pty i)
     else
-      compile_box env pty (compile_const_64 i)
+      E.SharedObject (fun env -> compile_box env pty (compile_const_64 i))
 
   let box env pty = 
     Func.share_code1 Func.Never env 
@@ -2514,14 +2550,14 @@ module BoxedSmallWord = struct
 
   let payload_field = Tagged.header_size
 
-  let lit env pty i =
+  let constant env pty i =
     if BitTagged.can_tag_const pty (Int64.of_int (Int32.to_int i))
     then
-      compile_unboxed_const (BitTagged.tag_const pty (Int64.of_int (Int32.to_int i)))
+      E.Vanilla (BitTagged.tag_const pty (Int64.of_int (Int32.to_int i)))
     else
-      Tagged.obj env (heap_tag env pty) [
+      E.SharedObject (fun env -> (Tagged.obj env (heap_tag env pty) [
         compile_unboxed_const i
-      ]
+      ]))
 
   let compile_box env pty compile_elem : G.t =
     let (set_i, get_i) = new_local env "boxed_i32" in
@@ -2807,7 +2843,9 @@ module Float = struct
 
   let unbox env = Tagged.load_forwarding_pointer env ^^ Tagged.load_field_float64 env payload_field
 
-  let lit env f = compile_unboxed_const f ^^ box env
+  let constant env f = E.SharedObject (fun env -> 
+    compile_unboxed_const f ^^ 
+    box env)
 
 end (* Float *)
 
@@ -8318,20 +8356,25 @@ end
 
 module GCRoots = struct
   let create_root_array env = Func.share_code0 Func.Always env "create_root_array" [I32Type] (fun env ->
-    let length = Int32.to_int (E.count_static_variables env) in
-    let variables = Lib.List.table length (fun _ -> MutBox.alloc env) in
-    Arr.lit env variables
+    E.(env.object_pool.frozen) := true;
+    let (set_array, get_array) = new_local env "root_array" in
+    let length = Int32.of_int (E.object_pool_size env) in
+    compile_unboxed_const length ^^
+    Arr.alloc env ^^
+    set_array ^^
+    E.iterate_object_pool env (fun index allocation ->
+      get_array ^^
+      compile_unboxed_const (Int32.of_int index) ^^
+      Arr.unsafe_idx env ^^
+      allocation env ^^
+      store_ptr
+    ) ^^
+    get_array
   )
 
   let register_static_variables env =
     create_root_array env ^^
-    E.call_import env "rts" "set_static_root"
-
-  let get_static_variable env index = 
-    E.call_import env "rts" "get_static_root" ^^
-    compile_unboxed_const index ^^
-    Arr.idx env ^^
-    load_ptr
+    E.call_import env "rts" "set_static_variables"
 end (* GCRoots *)
 
 module StackRep = struct
@@ -8412,26 +8455,44 @@ module StackRep = struct
     | UnboxedTuple n -> G.table n (fun _ -> G.i Drop)
     | Const _ | Unreachable -> G.nop
 
-  let rec materialize_constant env = function
-    | Const.Lit (Const.Vanilla value) -> compile_unboxed_const value
-    | Const.Lit (Const.Bool number) -> Bool.lit number
-    | Const.Lit (Const.Blob payload) -> Blob.lit env payload
-    | Const.Lit (Const.Null) -> Opt.null_lit env
-    | Const.Lit (Const.BigInt number) -> BigNum.lit env number
-    | Const.Lit (Const.Word32 (pty, number)) -> BoxedSmallWord.lit env pty number
-    | Const.Lit (Const.Word64 (pty, number)) -> BoxedWord64.lit env pty number
-    | Const.Lit (Const.Float64 number) -> Float.lit env number
-    | Const.Opt value -> Opt.inject env (materialize_constant env value)
-    | Const.Fun (get_fi, _) -> Closure.alloc env (get_fi ())
-    | Const.Message _ -> assert false
-    | Const.Unit -> Tuple.compile_unit env
-    | Const.Tag (tag, value) -> Variant.inject env tag (materialize_constant env value)
-    | Const.Array elements -> 
-        let materialized_elements = List.map (materialize_constant env) elements in
-        Arr.lit env materialized_elements
-    | Const.Obj fields -> 
-        let materialized_fields = List.map (fun (name, value) -> (name, (fun () -> materialize_constant env value))) fields in
-        Object.lit_raw env materialized_fields
+  let rec materialize_constant_value env = function
+  | Const.Lit (Const.Vanilla value) -> E.Vanilla value
+  | Const.Lit (Const.Bool number) -> E.Vanilla (Bool.vanilla_lit number)
+  | Const.Lit (Const.Blob payload) -> E.SharedObject (fun env -> Blob.lit env payload)
+  | Const.Lit (Const.Null) -> E.Vanilla Opt.null_vanilla_lit
+  | Const.Lit (Const.BigInt number) -> E.SharedObject (fun env -> BigNum.lit env number)
+  | Const.Lit (Const.Word32 (pty, number)) -> BoxedSmallWord.constant env pty number
+  | Const.Lit (Const.Word64 (pty, number)) -> BoxedWord64.constant env pty number
+  | Const.Lit (Const.Float64 number) -> Float.constant env number
+  | Const.Opt value -> Opt.constant env (materialize_constant_value env value)
+  | Const.Fun (get_fi, _) -> Closure.constant env get_fi
+  | Const.Message _ -> assert false
+  | Const.Unit -> E.Vanilla (Tuple.unit_vanilla_lit env)
+  | Const.Tag (tag, value) -> 
+      let payload = materialize_constant_element env value in
+      E.SharedObject (fun env -> Variant.inject env tag (payload env))
+  | Const.Array elements -> 
+      let materialized_elements = List.map (materialize_constant_element env) elements in
+      E.SharedObject (fun env -> 
+        let compiled_elements = List.map (fun allocation -> allocation env) materialized_elements in
+        Arr.lit env compiled_elements
+      )
+  | Const.Obj fields -> 
+      let materialized_fields = List.map (fun (name, value) -> (name, materialize_constant_element env value)) fields in
+      E.SharedObject (fun env -> 
+        let compile_fields = List.map (fun (name, allocation) -> (name, fun () -> allocation env)) materialized_fields in
+        Object.lit_raw env compile_fields
+      )
+
+  and materialize_constant_element env value = 
+    match materialize_constant_value env value with
+    | E.Vanilla vanilla -> fun env -> compile_unboxed_const vanilla
+    | E.SharedObject allocation -> allocation
+
+  let materialize_shared_constant env value = 
+    match materialize_constant_value env value with
+    | E.Vanilla vanilla -> compile_unboxed_const vanilla
+    | E.SharedObject allocation -> Tagged.share env allocation
 
   let adjust env (sr_in : t) sr_out =
     if eq sr_in sr_out
@@ -8469,7 +8530,7 @@ module StackRep = struct
     | Vanilla, UnboxedFloat64 -> Float.unbox env
 
     | Const value, Vanilla -> 
-        materialize_constant env value
+        materialize_shared_constant env value
     | Const Const.Lit (Const.Vanilla n), UnboxedWord32 ty ->
         compile_unboxed_const n ^^
         TaggedSmallWord.untag env ty
@@ -8481,7 +8542,7 @@ module StackRep = struct
     | Const c, UnboxedTuple 0 -> G.nop
     | Const Const.Array cs, UnboxedTuple n ->
       assert (n = List.length cs);
-      G.concat_map (fun c -> materialize_constant env c) cs
+      G.concat_map (fun c -> materialize_shared_constant env c) cs
     | _, _ ->
       Printf.eprintf "Unknown stack_rep conversion %s -> %s\n"
         (to_string sr_in) (to_string sr_out);
@@ -8598,7 +8659,7 @@ module VarEnv = struct
         let ae' = { ae with vars = NameEnv.add name ((Local (SR.Vanilla, i)), typ) ae.vars } in
         add_arguments env ae' as_local remainder
       else
-        let index = E.add_static_variable env in
+        let index = MutBox.add_global_mutbox env in
         let ae' = add_static_variable ae name index typ in
         add_arguments env ae' as_local remainder
 
@@ -8658,14 +8719,14 @@ module Var = struct
       SR.Vanilla,
       MutBox.store_field env
     | Some ((Static index), typ) when potential_pointer typ ->
-      GCRoots.get_static_variable env index ^^
+      Heap.get_static_variable env index ^^
       Tagged.load_forwarding_pointer env ^^
       compile_add_const ptr_unskew ^^
       compile_add_const (Int32.mul MutBox.field Heap.word_size),
       SR.Vanilla,
       Tagged.write_with_barrier env
     | Some ((Static index), typ) ->
-      GCRoots.get_static_variable env index,
+      Heap.get_static_variable env index,
       SR.Vanilla,
       MutBox.store_field env
     | Some ((Const _), _) -> fatal "set_val: %s is const" var
@@ -8698,7 +8759,7 @@ module Var = struct
       SR.Vanilla, G.i (LocalGet (nr i)) ^^ MutBox.load_field env
     | Some (Static index) ->
       SR.Vanilla, 
-      GCRoots.get_static_variable env index ^^
+      Heap.get_static_variable env index ^^
       MutBox.load_field env
     | Some (Const c) ->
       SR.Const c, G.nop
@@ -8745,7 +8806,7 @@ module Var = struct
   *)
   let get_aliased_box env ae var = match VarEnv.lookup_var ae var with
     | Some (HeapInd i) -> G.i (LocalGet (nr i))
-    | Some (Static index) -> GCRoots.get_static_variable env index
+    | Some (Static index) -> Heap.get_static_variable env index
     | _ -> assert false
 
   let capture_aliased_box env ae var = match VarEnv.lookup_var ae var with
@@ -9503,7 +9564,7 @@ module AllocHow = struct
       let alloc_code = MutBox.alloc env ^^ G.i (LocalSet (nr i)) in
       (ae1, alloc_code)
     | StoreStatic ->
-      let index = E.add_static_variable env in
+      let index = MutBox.add_global_mutbox env in
       let ae1 = VarEnv.add_static_variable ae name index typ in
       (ae1, G.nop)
 

From b19d8719317c01d0d1432a0de87c333f1e5c2081 Mon Sep 17 00:00:00 2001
From: luc-blaeser <luc.blaeser@dfinity.org>
Date: Tue, 19 Mar 2024 11:01:09 +0100
Subject: [PATCH 2/9] Update benchmark results

---
 test/bench/ok/alloc.drun-run.ok       |  6 +++---
 test/bench/ok/bignum.drun-run.ok      |  4 ++--
 test/bench/ok/heap-32.drun-run.ok     |  4 ++--
 test/bench/ok/nat16.drun-run.ok       |  2 +-
 test/bench/ok/palindrome.drun-run.ok  | 12 ++++++------
 test/bench/ok/region-mem.drun-run.ok  |  2 +-
 test/bench/ok/region0-mem.drun-run.ok |  2 +-
 test/bench/ok/stable-mem.drun-run.ok  |  2 +-
 8 files changed, 17 insertions(+), 17 deletions(-)

diff --git a/test/bench/ok/alloc.drun-run.ok b/test/bench/ok/alloc.drun-run.ok
index e8bb0b9613a..44990526d5a 100644
--- a/test/bench/ok/alloc.drun-run.ok
+++ b/test/bench/ok/alloc.drun-run.ok
@@ -1,8 +1,8 @@
 ingress Completed: Reply: 0x4449444c016c01b3c4b1f204680100010a00000000000000000101
 ingress Completed: Reply: 0x4449444c0000
-debug.print: (+335_544_320, 4_613_740_069)
+debug.print: (+335_544_320, 5_955_917_429)
 ingress Completed: Reply: 0x4449444c0000
-debug.print: (+335_544_320, 4_613_737_156)
+debug.print: (+335_544_320, 5_955_914_516)
 ingress Completed: Reply: 0x4449444c0000
-debug.print: (+335_544_320, 4_613_737_171)
+debug.print: (+335_544_320, 5_955_914_531)
 ingress Completed: Reply: 0x4449444c0000
diff --git a/test/bench/ok/bignum.drun-run.ok b/test/bench/ok/bignum.drun-run.ok
index eaa51f4ce20..2901e701e1e 100644
--- a/test/bench/ok/bignum.drun-run.ok
+++ b/test/bench/ok/bignum.drun-run.ok
@@ -1,6 +1,6 @@
 ingress Completed: Reply: 0x4449444c016c01b3c4b1f204680100010a00000000000000000101
 ingress Completed: Reply: 0x4449444c0000
-debug.print: {cycles = 2_630_422; size = +60_608}
+debug.print: {cycles = 2_630_290; size = +60_608}
 ingress Completed: Reply: 0x4449444c0000
-debug.print: {cycles = 107_963_240; size = +1_827_460}
+debug.print: {cycles = 107_963_055; size = +1_827_444}
 ingress Completed: Reply: 0x4449444c0000
diff --git a/test/bench/ok/heap-32.drun-run.ok b/test/bench/ok/heap-32.drun-run.ok
index 377af51b5fd..9faf5a03826 100644
--- a/test/bench/ok/heap-32.drun-run.ok
+++ b/test/bench/ok/heap-32.drun-run.ok
@@ -1,5 +1,5 @@
 ingress Completed: Reply: 0x4449444c016c01b3c4b1f204680100010a00000000000000000101
 ingress Completed: Reply: 0x4449444c0000
-debug.print: (50_227, +40_579_412, 879_264_651)
-debug.print: (50_070, +42_103_788, 913_585_900)
+debug.print: (50_227, +37_379_412, 875_769_251)
+debug.print: (50_070, +38_903_788, 910_087_360)
 ingress Completed: Reply: 0x4449444c0000
diff --git a/test/bench/ok/nat16.drun-run.ok b/test/bench/ok/nat16.drun-run.ok
index 9bb141f2499..5170a88f005 100644
--- a/test/bench/ok/nat16.drun-run.ok
+++ b/test/bench/ok/nat16.drun-run.ok
@@ -1,4 +1,4 @@
 ingress Completed: Reply: 0x4449444c016c01b3c4b1f204680100010a00000000000000000101
 ingress Completed: Reply: 0x4449444c0000
-debug.print: (0, 55_575_377)
+debug.print: (0, 55_576_037)
 ingress Completed: Reply: 0x4449444c0000
diff --git a/test/bench/ok/palindrome.drun-run.ok b/test/bench/ok/palindrome.drun-run.ok
index 9ae9db84a1a..f82af80bade 100644
--- a/test/bench/ok/palindrome.drun-run.ok
+++ b/test/bench/ok/palindrome.drun-run.ok
@@ -1,9 +1,9 @@
 ingress Completed: Reply: 0x4449444c016c01b3c4b1f204680100010a00000000000000000101
 ingress Completed: Reply: 0x4449444c0000
-debug.print: (true, +1_544, 20_367)
-debug.print: (false, +1_544, 19_294)
-debug.print: (false, +1_544, 20_344)
-debug.print: (true, +1_156, 19_126)
-debug.print: (false, +1_144, 17_514)
-debug.print: (false, +1_144, 18_984)
+debug.print: (true, +1_480, 20_073)
+debug.print: (false, +1_480, 19_000)
+debug.print: (false, +1_480, 20_050)
+debug.print: (true, +1_108, 18_905)
+debug.print: (false, +1_096, 17_293)
+debug.print: (false, +1_096, 18_763)
 ingress Completed: Reply: 0x4449444c0000
diff --git a/test/bench/ok/region-mem.drun-run.ok b/test/bench/ok/region-mem.drun-run.ok
index 8f451caf42d..996b7e106eb 100644
--- a/test/bench/ok/region-mem.drun-run.ok
+++ b/test/bench/ok/region-mem.drun-run.ok
@@ -1,4 +1,4 @@
 ingress Completed: Reply: 0x4449444c016c01b3c4b1f204680100010a00000000000000000101
 ingress Completed: Reply: 0x4449444c0000
-debug.print: {heap_diff = 0; instr_diff = 8_782_872_996}
+debug.print: {heap_diff = 0; instr_diff = 8_380_219_796}
 ingress Completed: Reply: 0x4449444c0000
diff --git a/test/bench/ok/region0-mem.drun-run.ok b/test/bench/ok/region0-mem.drun-run.ok
index 565f4aaa72a..e0f81d95884 100644
--- a/test/bench/ok/region0-mem.drun-run.ok
+++ b/test/bench/ok/region0-mem.drun-run.ok
@@ -1,4 +1,4 @@
 ingress Completed: Reply: 0x4449444c016c01b3c4b1f204680100010a00000000000000000101
 ingress Completed: Reply: 0x4449444c0000
-debug.print: {heap_diff = 0; instr_diff = 8_480_883_108}
+debug.print: {heap_diff = 0; instr_diff = 8_279_556_500}
 ingress Completed: Reply: 0x4449444c0000
diff --git a/test/bench/ok/stable-mem.drun-run.ok b/test/bench/ok/stable-mem.drun-run.ok
index 9b58bba8c7a..b64bd840aaf 100644
--- a/test/bench/ok/stable-mem.drun-run.ok
+++ b/test/bench/ok/stable-mem.drun-run.ok
@@ -1,4 +1,4 @@
 ingress Completed: Reply: 0x4449444c016c01b3c4b1f204680100010a00000000000000000101
 ingress Completed: Reply: 0x4449444c0000
-debug.print: {heap_diff = 0; instr_diff = 4_655_677_860}
+debug.print: {heap_diff = 0; instr_diff = 4_454_351_252}
 ingress Completed: Reply: 0x4449444c0000

From 290f31eff98890e69e36091d814169ee952e1de0 Mon Sep 17 00:00:00 2001
From: luc-blaeser <luc.blaeser@dfinity.org>
Date: Tue, 19 Mar 2024 11:40:07 +0100
Subject: [PATCH 3/9] Optimize further (BigNum pooling)

---
 src/codegen/compile.ml          | 32 +++++++++++++++++---------------
 test/bench/ok/nat16.drun-run.ok |  2 +-
 2 files changed, 18 insertions(+), 16 deletions(-)

diff --git a/src/codegen/compile.ml b/src/codegen/compile.ml
index 00f9c5264d0..72d4176ad22 100644
--- a/src/codegen/compile.ml
+++ b/src/codegen/compile.ml
@@ -2187,6 +2187,10 @@ module Tagged = struct
     let index = E.object_pool_add env allocation in
     Heap.get_static_variable env index
 
+  let share_constant env = function
+  | E.Vanilla vanilla -> compile_unboxed_const vanilla
+  | E.SharedObject allocation -> share env allocation
+
 end (* Tagged *)
 
 module MutBox = struct
@@ -3001,8 +3005,8 @@ sig
    *)
   val compile_load_from_data_buf : E.t -> G.t -> bool -> G.t
 
-  (* literals *)
-  val lit : E.t -> Big_int.big_int -> G.t
+  (* constant *)
+  val constant : E.t -> Big_int.big_int -> E.shared_value
 
   (* arithmetic *)
   val compile_abs : E.t -> G.t
@@ -3332,10 +3336,10 @@ module MakeCompact (Num : BigNumType) : BigNumType = struct
       (get_n ^^ clear_tag env ^^ compile_unboxed_const 0l ^^ G.i (Compare (Wasm.Values.I32 I32Op.LtS)))
       (get_n ^^ Num.compile_is_negative env)
 
-  let lit env = function
+  let constant env = function
     | n when Big_int.is_int_big_int n && BitTagged.can_tag_const Type.Int (Big_int.int64_of_big_int n) ->
-      compile_unboxed_const (BitTagged.tag_const Type.Int (Big_int.int64_of_big_int n))
-    | n -> Num.lit env n
+      E.Vanilla (BitTagged.tag_const Type.Int (Big_int.int64_of_big_int n))
+    | n -> Num.constant env n
 
   let compile_neg env =
     let sminl = Int32.shift_left 1l (BitTagged.sbits_of Type.Int) in
@@ -3687,7 +3691,7 @@ module BigNumLibtommath : BigNumType = struct
     | false -> get_data_buf ^^ E.call_import env "rts" "bigint_leb128_decode"
     | true -> get_data_buf ^^ E.call_import env "rts" "bigint_sleb128_decode"
 
-  let lit env n =
+  let constant env n =
     (* See enum mp_sign *)
     let sign = if Big_int.sign_big_int n >= 0 then 0l else 1l in
 
@@ -3708,12 +3712,12 @@ module BigNumLibtommath : BigNumType = struct
     let size = Int32.of_int (List.length limbs) in
 
     (* cf. mp_int in tommath.h *)
-    Tagged.obj env Tagged.BigInt ([
+    E.SharedObject (fun env -> Tagged.obj env Tagged.BigInt ([
       compile_unboxed_const size; (* used *)
       compile_unboxed_const size; (* size; relying on Heap.word_size == size_of(mp_digit) *)
       compile_unboxed_const sign;
       compile_unboxed_const 0l; (* dp; this will be patched in BigInt::mp_int_ptr in the RTS when used *)
-    ] @ limbs)
+    ] @ limbs))
 
   let assert_nonneg env =
     Func.share_code1 Func.Never env "assert_nonneg" ("n", I32Type) [I32Type] (fun env get_n ->
@@ -5277,7 +5281,7 @@ module Cycles = struct
     let (set_val, get_val) = new_local env "cycles" in
     set_val ^^
     get_val ^^
-    BigNum.lit env (Big_int.power_int_positive_int 2 128) ^^
+    Tagged.share_constant env (BigNum.constant env (Big_int.power_int_positive_int 2 128)) ^^
     BigNum.compile_relop env Lt ^^
     E.else_trap_with env "cycles out of bounds" ^^
 
@@ -8460,7 +8464,7 @@ module StackRep = struct
   | Const.Lit (Const.Bool number) -> E.Vanilla (Bool.vanilla_lit number)
   | Const.Lit (Const.Blob payload) -> E.SharedObject (fun env -> Blob.lit env payload)
   | Const.Lit (Const.Null) -> E.Vanilla Opt.null_vanilla_lit
-  | Const.Lit (Const.BigInt number) -> E.SharedObject (fun env -> BigNum.lit env number)
+  | Const.Lit (Const.BigInt number) -> BigNum.constant env number
   | Const.Lit (Const.Word32 (pty, number)) -> BoxedSmallWord.constant env pty number
   | Const.Lit (Const.Word64 (pty, number)) -> BoxedWord64.constant env pty number
   | Const.Lit (Const.Float64 number) -> Float.constant env number
@@ -8484,15 +8488,13 @@ module StackRep = struct
         Object.lit_raw env compile_fields
       )
 
-  and materialize_constant_element env value = 
+  and materialize_constant_element env value =
     match materialize_constant_value env value with
     | E.Vanilla vanilla -> fun env -> compile_unboxed_const vanilla
     | E.SharedObject allocation -> allocation
 
-  let materialize_shared_constant env value = 
-    match materialize_constant_value env value with
-    | E.Vanilla vanilla -> compile_unboxed_const vanilla
-    | E.SharedObject allocation -> Tagged.share env allocation
+  let materialize_shared_constant env value =
+    Tagged.share_constant env (materialize_constant_value env value)
 
   let adjust env (sr_in : t) sr_out =
     if eq sr_in sr_out
diff --git a/test/bench/ok/nat16.drun-run.ok b/test/bench/ok/nat16.drun-run.ok
index 5170a88f005..9bb141f2499 100644
--- a/test/bench/ok/nat16.drun-run.ok
+++ b/test/bench/ok/nat16.drun-run.ok
@@ -1,4 +1,4 @@
 ingress Completed: Reply: 0x4449444c016c01b3c4b1f204680100010a00000000000000000101
 ingress Completed: Reply: 0x4449444c0000
-debug.print: (0, 55_576_037)
+debug.print: (0, 55_575_377)
 ingress Completed: Reply: 0x4449444c0000

From da39fe12060771b7fdd4f1559a29eefe5c850857 Mon Sep 17 00:00:00 2001
From: luc-blaeser <luc.blaeser@dfinity.org>
Date: Tue, 19 Mar 2024 11:40:23 +0100
Subject: [PATCH 4/9] Update benchmark results

---
 test/bench/ok/alloc.drun-run.ok   | 6 +++---
 test/bench/ok/bignum.drun-run.ok  | 4 ++--
 test/bench/ok/heap-32.drun-run.ok | 4 ++--
 3 files changed, 7 insertions(+), 7 deletions(-)

diff --git a/test/bench/ok/alloc.drun-run.ok b/test/bench/ok/alloc.drun-run.ok
index 44990526d5a..e8bb0b9613a 100644
--- a/test/bench/ok/alloc.drun-run.ok
+++ b/test/bench/ok/alloc.drun-run.ok
@@ -1,8 +1,8 @@
 ingress Completed: Reply: 0x4449444c016c01b3c4b1f204680100010a00000000000000000101
 ingress Completed: Reply: 0x4449444c0000
-debug.print: (+335_544_320, 5_955_917_429)
+debug.print: (+335_544_320, 4_613_740_069)
 ingress Completed: Reply: 0x4449444c0000
-debug.print: (+335_544_320, 5_955_914_516)
+debug.print: (+335_544_320, 4_613_737_156)
 ingress Completed: Reply: 0x4449444c0000
-debug.print: (+335_544_320, 5_955_914_531)
+debug.print: (+335_544_320, 4_613_737_171)
 ingress Completed: Reply: 0x4449444c0000
diff --git a/test/bench/ok/bignum.drun-run.ok b/test/bench/ok/bignum.drun-run.ok
index 2901e701e1e..cfee0d0fc5e 100644
--- a/test/bench/ok/bignum.drun-run.ok
+++ b/test/bench/ok/bignum.drun-run.ok
@@ -1,6 +1,6 @@
 ingress Completed: Reply: 0x4449444c016c01b3c4b1f204680100010a00000000000000000101
 ingress Completed: Reply: 0x4449444c0000
-debug.print: {cycles = 2_630_290; size = +60_608}
+debug.print: {cycles = 2_629_640; size = +60_608}
 ingress Completed: Reply: 0x4449444c0000
-debug.print: {cycles = 107_963_055; size = +1_827_444}
+debug.print: {cycles = 107_963_085; size = +1_827_444}
 ingress Completed: Reply: 0x4449444c0000
diff --git a/test/bench/ok/heap-32.drun-run.ok b/test/bench/ok/heap-32.drun-run.ok
index 9faf5a03826..baa9116ccca 100644
--- a/test/bench/ok/heap-32.drun-run.ok
+++ b/test/bench/ok/heap-32.drun-run.ok
@@ -1,5 +1,5 @@
 ingress Completed: Reply: 0x4449444c016c01b3c4b1f204680100010a00000000000000000101
 ingress Completed: Reply: 0x4449444c0000
-debug.print: (50_227, +37_379_412, 875_769_251)
-debug.print: (50_070, +38_903_788, 910_087_360)
+debug.print: (50_227, +37_379_412, 870_764_651)
+debug.print: (50_070, +38_903_788, 905_085_900)
 ingress Completed: Reply: 0x4449444c0000

From 03170a200e28e8dde7c63c10ada64e90c4f93515 Mon Sep 17 00:00:00 2001
From: luc-blaeser <luc.blaeser@dfinity.org>
Date: Tue, 19 Mar 2024 11:56:52 +0100
Subject: [PATCH 5/9] Adjust tests

---
 test/run/const-func-static.mo     | 2 +-
 test/run/idl.mo                   | 2 +-
 test/run/ok/array-len.wasm-run.ok | 2 +-
 3 files changed, 3 insertions(+), 3 deletions(-)

diff --git a/test/run/const-func-static.mo b/test/run/const-func-static.mo
index 3c66c93986e..a6a4eb0de69 100644
--- a/test/run/const-func-static.mo
+++ b/test/run/const-func-static.mo
@@ -5,7 +5,7 @@ func higher_order(foo: () -> ()) = foo();
 func bar() = ();
 higher_order(bar);
 let after = Prim.rts_heap_size();
-assert(+after-before == 16);
+assert(+after-before == 0);
 Prim.debugPrint("Ignore Diff: heap size increase " # debug_show (+after-before));
 
 //SKIP run
diff --git a/test/run/idl.mo b/test/run/idl.mo
index e4ca01f179b..cc44bc6935e 100644
--- a/test/run/idl.mo
+++ b/test/run/idl.mo
@@ -45,7 +45,7 @@ assert(arrayNat == deserArrayInt (serArrayNat arrayNat));
 assert(arrayNat == deserArrayInt (serArrayInt arrayNat));
 assert(arrayInt == deserArrayInt (serArrayInt arrayInt));
 let heapDifference = Prim.rts_heap_size() : Int - started_with;
-assert(heapDifference == 20_412);  
+assert(heapDifference == 17_276);  
 
 //SKIP run
 //SKIP run-ir
diff --git a/test/run/ok/array-len.wasm-run.ok b/test/run/ok/array-len.wasm-run.ok
index 79d6e3a21c5..49fd311aadf 100644
--- a/test/run/ok/array-len.wasm-run.ok
+++ b/test/run/ok/array-len.wasm-run.ok
@@ -1,4 +1,4 @@
-Allocation delta:  68
+Allocation delta:  0
 a
 b
 c

From 43238e24d2d8edf40e0db10cd4e30663de3a18ff Mon Sep 17 00:00:00 2001
From: luc-blaeser <luc.blaeser@dfinity.org>
Date: Tue, 19 Mar 2024 16:47:41 +0100
Subject: [PATCH 6/9] Optimize static blobs

---
 src/codegen/compile.ml | 31 ++++++++++++++++++++-----------
 1 file changed, 20 insertions(+), 11 deletions(-)

diff --git a/src/codegen/compile.ml b/src/codegen/compile.ml
index 72d4176ad22..4915622c328 100644
--- a/src/codegen/compile.ml
+++ b/src/codegen/compile.ml
@@ -3833,15 +3833,20 @@ module Blob = struct
     Tagged.load_forwarding_pointer env ^^
     compile_add_const (unskewed_payload_offset env)
 
-  let lit env s = 
-    let blob_length = Int32.of_int (String.length s) in
-    let (set_new_blob, get_new_blob) = new_local env "new_blob" in
-    compile_unboxed_const blob_length ^^ alloc env ^^ set_new_blob ^^
-    get_new_blob ^^ payload_ptr_unskewed env ^^ (* target address *)
-    compile_unboxed_const 0l ^^ (* data offset *)
-    compile_unboxed_const blob_length ^^ (* data length *)
-    load_static_data env s ^^
-    get_new_blob
+  let constant env payload =
+    E.SharedObject (fun env -> 
+      let blob_length = Int32.of_int (String.length payload) in
+      let (set_new_blob, get_new_blob) = new_local env "new_blob" in
+      compile_unboxed_const blob_length ^^ alloc env ^^ set_new_blob ^^
+      get_new_blob ^^ payload_ptr_unskewed env ^^ (* target address *)
+      compile_unboxed_const 0l ^^ (* data offset *)
+      compile_unboxed_const blob_length ^^ (* data length *)
+      load_static_data env payload ^^
+      get_new_blob
+    )
+
+  let lit env payload =
+    Tagged.share_constant env (constant env payload)
 
   let as_ptr_len env = Func.share_code1 Func.Never env "as_ptr_size" ("x", I32Type) [I32Type; I32Type] (
     fun env get_x ->
@@ -4066,7 +4071,11 @@ module Object = struct
         List.sort compare in
       let hash_blob env =
         let hash_payload = StaticBytes.[ i32s hashes ] in
-        Blob.lit env (StaticBytes.as_bytes hash_payload) in
+        let blob_constant = Blob.constant env (StaticBytes.as_bytes hash_payload) in
+        match blob_constant with
+        | E.SharedObject allocation -> allocation env
+        | E.Vanilla _ -> assert false
+      in
 
       (* Allocate memory *)
       let (set_ri, get_ri, ri) = new_local_ env I32Type "obj" in
@@ -8462,7 +8471,7 @@ module StackRep = struct
   let rec materialize_constant_value env = function
   | Const.Lit (Const.Vanilla value) -> E.Vanilla value
   | Const.Lit (Const.Bool number) -> E.Vanilla (Bool.vanilla_lit number)
-  | Const.Lit (Const.Blob payload) -> E.SharedObject (fun env -> Blob.lit env payload)
+  | Const.Lit (Const.Blob payload) -> Blob.constant env payload
   | Const.Lit (Const.Null) -> E.Vanilla Opt.null_vanilla_lit
   | Const.Lit (Const.BigInt number) -> BigNum.constant env number
   | Const.Lit (Const.Word32 (pty, number)) -> BoxedSmallWord.constant env pty number

From b09fb389bd152012ea3c7c3694ebe601d7030338 Mon Sep 17 00:00:00 2001
From: luc-blaeser <luc.blaeser@dfinity.org>
Date: Tue, 19 Mar 2024 16:54:15 +0100
Subject: [PATCH 7/9] Adjust test and benchmark results

---
 test/bench/ok/bignum.drun-run.ok | 4 ++--
 test/run/idl.mo                  | 2 +-
 2 files changed, 3 insertions(+), 3 deletions(-)

diff --git a/test/bench/ok/bignum.drun-run.ok b/test/bench/ok/bignum.drun-run.ok
index cfee0d0fc5e..2dd7f220987 100644
--- a/test/bench/ok/bignum.drun-run.ok
+++ b/test/bench/ok/bignum.drun-run.ok
@@ -1,6 +1,6 @@
 ingress Completed: Reply: 0x4449444c016c01b3c4b1f204680100010a00000000000000000101
 ingress Completed: Reply: 0x4449444c0000
-debug.print: {cycles = 2_629_640; size = +60_608}
+debug.print: {cycles = 2_626_994; size = +60_128}
 ingress Completed: Reply: 0x4449444c0000
-debug.print: {cycles = 107_963_085; size = +1_827_444}
+debug.print: {cycles = 107_960_332; size = +1_826_940}
 ingress Completed: Reply: 0x4449444c0000
diff --git a/test/run/idl.mo b/test/run/idl.mo
index cc44bc6935e..5343e1364a6 100644
--- a/test/run/idl.mo
+++ b/test/run/idl.mo
@@ -45,7 +45,7 @@ assert(arrayNat == deserArrayInt (serArrayNat arrayNat));
 assert(arrayNat == deserArrayInt (serArrayInt arrayNat));
 assert(arrayInt == deserArrayInt (serArrayInt arrayInt));
 let heapDifference = Prim.rts_heap_size() : Int - started_with;
-assert(heapDifference == 17_276);  
+assert(heapDifference == 5_340);  
 
 //SKIP run
 //SKIP run-ir

From 5e86daa0542e77b02d4065d4c968798f49857c27 Mon Sep 17 00:00:00 2001
From: luc-blaeser <luc.blaeser@dfinity.org>
Date: Tue, 19 Mar 2024 17:12:18 +0100
Subject: [PATCH 8/9] Update documentation

---
 design/OrthogonalPersistence.md | 12 ++++++------
 1 file changed, 6 insertions(+), 6 deletions(-)

diff --git a/design/OrthogonalPersistence.md b/design/OrthogonalPersistence.md
index deefe972d66..96c8236e1c9 100644
--- a/design/OrthogonalPersistence.md
+++ b/design/OrthogonalPersistence.md
@@ -88,11 +88,11 @@ This is because these objects may also need to survive upgrades and must not be
 
 The incremental GC also operates on these objects, meaning that forwarding pointer resolution is also necessary for these objects.
 
+For memory and runtime efficiency, object pooling is implemented for compile-time-known constant objects (with side-effect-free initialization), i.e. those objects are already created on program initialization/upgrade in the dynamic heap and thereafter the reference to the corresponding prefabricated object is looked up whenever the constant value is needed at runtime.
+
 The runtime systems avoids any global Wasm variables for state that needs to be preserved on upgrades.
 Instead, such global runtime state is stored in the persistent metadata.
 
-Sharing optimization (pooling) is possible for compile-time-known objects, see below.
-
 ### Wasm Data Segments
 Only passive Wasm data segments are used by the compiler and runtime system. In contrast to ordinary active data segments, passive segments can be explicitly loaded to a dynamic address.
 
@@ -115,10 +115,10 @@ Once operating on the stable heap, the system prevents downgrade attempts to the
 ### Old Stable Memory
 The old stable memory remains equally accessible as secondary memory with the new support.
 
-## Possible Extensions
-The following extensions or optimization could be applied in the future:
-* 64-bit memory: Extend the main memory to 64-bit by using Wasm64, see https://github.com/dfinity/motoko/pull/4136. The memory layout would need to be extended. Moreover, it would be beneficial to introduce a dynamic partition table for the GC. Ideally, stable heap support is directly rolled out for 64-bit to avoid complicated memory layout upgrades from 32-bit to 64-bit.
-* Object pooling: Compile-time-known objects can be shared in the dynamic heap by remembering them in an additional pool table. The pool table needs to be registered as a transient GC root and is recreated on canister upgrades.
+## Current Limitations
+* Freeing old object fields: While new program versions can drop object fields, the runtime system should also delete the redundant fields of persistent objects of previous program versions. This could be realized during garbage collection when objects are copied. For this purpose, the runtime system may maintain a set of field hashes in use and consult this table during garbage collection.
+* Bounded Rust call stack size: The Rust call stack size needs to be bounded and can no longer be configured by the user.
+* The Wasm profiler (only used for the flamegraphs) is no longer applicable because the underlying `parity-wasm` crate lacks full support of passive data segments. A re-implementation of the profiler would be needed.
 
 ## Related PRs
 

From d3bf6a28238bb19e37d32a37dae98e50ee56c8a8 Mon Sep 17 00:00:00 2001
From: luc-blaeser <luc.blaeser@dfinity.org>
Date: Wed, 20 Mar 2024 09:59:08 +0100
Subject: [PATCH 9/9] Manual merge conflict resolution

---
 rts/motoko-rts/src/gc/incremental/roots.rs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/rts/motoko-rts/src/gc/incremental/roots.rs b/rts/motoko-rts/src/gc/incremental/roots.rs
index 43d8dff5638..c1bdda0b421 100644
--- a/rts/motoko-rts/src/gc/incremental/roots.rs
+++ b/rts/motoko-rts/src/gc/incremental/roots.rs
@@ -59,7 +59,7 @@ pub unsafe fn set_static_variables<M: crate::memory::Memory>(mem: &mut M, array:
 
 #[no_mangle]
 #[cfg(feature = "ic")]
-pub unsafe extern "C" fn get_static_variable(index: u32) -> Value {
+pub unsafe extern "C" fn get_static_variable(index: usize) -> Value {
     debug_assert!(STATIC_VARIABLES.is_non_null_ptr());
     STATIC_VARIABLES.as_array().get(index)
 }