Support 128-bit system API for cycles

default.nix

@@ -11,8 +11,8 @@ let universal-canister = (naersk.buildPackage rec {
     name = "universal-canister";
     src = subpath ./universal-canister;
     root = ./universal-canister;
-    CARGO_TARGET_WASM32_UNKNOWN_UNKNOWN_LINKER = "${nixpkgs.llvmPackages_11.lld}/bin/lld";
-    RUSTFLAGS = "-C link-arg=-s"; # much smaller wasm
+    CARGO_TARGET_WASM32_UNKNOWN_UNKNOWN_LINKER = "${nixpkgs.llvmPackages_12.lld}/bin/lld";
+    RUSTFLAGS = "-C link-arg=-s -C target-feature=+multivalue"; # much smaller wasm
     cargoBuildOptions = x : x ++ [ "--target wasm32-unknown-unknown" ];
     doCheck = false;
     release = true;

src/IC/Canister/Imp.hs

@@ -5,6 +5,7 @@
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE NumericUnderscores #-}
 
 {-|
 The canister interface, presented imperatively (or impurely), i.e. without rollback
@@ -33,6 +34,7 @@ import qualified Data.ByteString.Lazy.UTF8 as BSU
 import Control.Monad.Primitive
 import Control.Monad.ST
 import Control.Monad.Except
+import Data.Bits
 import Data.STRef
 import Data.Maybe
 import Data.Int -- TODO: Should be Word32 in most cases
@@ -204,10 +206,16 @@ systemAPI esref =
   , toImport "ic0" "msg_cycles_accept" msg_cycles_accept
   , toImport "ic0" "canister_cycle_balance" canister_cycle_balance
 
+  , toImport "ic0" "msg_cycles_available128" msg_cycles_available128
+  , toImport "ic0" "msg_cycles_refunded128" msg_cycles_refunded128
+  , toImport "ic0" "msg_cycles_accept128" msg_cycles_accept128
+  , toImport "ic0" "canister_cycle_balance128" canister_cycle_balance128
+
   , toImport "ic0" "call_new" call_new
   , toImport "ic0" "call_on_cleanup" call_on_cleanup
   , toImport "ic0" "call_data_append" call_data_append
   , toImport "ic0" "call_cycles_add" call_cycles_add
+  , toImport "ic0" "call_cycles_add128" call_cycles_add128
   , toImport "ic0" "call_perform" call_perform
 
   , toImport "ic0" "stable_size" stable_size
@@ -335,27 +343,52 @@ systemAPI esref =
         Stopping -> 2
         Stopped -> 3
 
+    splitBitsIntoHalves :: Natural -> (Word64, Word64)
+    splitBitsIntoHalves n = (fromIntegral $ highBits n, fromIntegral $ lowBits n)
+        where highBits = flip shiftR 64
+              lowBits = (0xFFFFFFFF_FFFFFFFF .&.)
+
+    combineBitHalves :: (Word64, Word64) -> Natural
+    combineBitHalves (high, low) = fromIntegral high `shiftL` 64 .|. fromIntegral low
+
+    low64BitsOrErr :: (Word64, Word64) -> HostM s Word64
+    low64BitsOrErr (0, low) = return low
+    low64BitsOrErr (high, low) = throwError $ "The number of cycles does not fit in 64 bits: " ++ show (combineBitHalves (high, low))
+
     msg_cycles_refunded :: () -> HostM s Word64
-    msg_cycles_refunded () = fromIntegral <$> getRefunded esref
+    msg_cycles_refunded () =  msg_cycles_refunded128 () >>= low64BitsOrErr
 
     msg_cycles_available :: () -> HostM s Word64
-    msg_cycles_available () = fromIntegral <$> getAvailable esref
+    msg_cycles_available () = msg_cycles_available128 () >>= low64BitsOrErr
 
     msg_cycles_accept :: Word64 -> HostM s Word64
-    msg_cycles_accept max_amount = do
-      available <- fromIntegral <$> getAvailable esref
+    msg_cycles_accept max_amount = msg_cycles_accept128 (0, max_amount) >>= low64BitsOrErr
+
+    canister_cycle_balance :: () -> HostM s Word64
+    canister_cycle_balance () = canister_cycle_balance128 () >>= low64BitsOrErr
+
+    msg_cycles_refunded128 :: () -> HostM s (Word64, Word64)
+    msg_cycles_refunded128 () = splitBitsIntoHalves <$> getRefunded esref
+
+    msg_cycles_available128 :: () -> HostM s (Word64, Word64)
+    msg_cycles_available128 () = splitBitsIntoHalves <$> getAvailable esref
+
+    msg_cycles_accept128 :: (Word64, Word64) -> HostM s (Word64, Word64)
+    msg_cycles_accept128 (max_amount_high, max_amount_low) = do
+      available <- getAvailable esref
       balance <- gets balance
+      let max_amount = combineBitHalves (max_amount_high, max_amount_low)
       let amount = minimum
-            [ fromIntegral max_amount
+            [ max_amount
             , available
             , cMAX_CANISTER_BALANCE - balance]
       subtractAvailable esref amount
       addBalance esref amount
       addAccepted esref amount
-      return (fromIntegral amount)
+      return $ splitBitsIntoHalves amount
 
-    canister_cycle_balance :: () -> HostM s Word64
-    canister_cycle_balance () = fromIntegral <$> gets balance
+    canister_cycle_balance128 :: () -> HostM s (Word64, Word64)
+    canister_cycle_balance128 () = splitBitsIntoHalves <$> gets balance
 
     call_new :: ( Int32, Int32, Int32, Int32, Int32, Int32, Int32, Int32 ) -> HostM s ()
     call_new ( callee_src, callee_size, name_src, name_size
@@ -388,8 +421,11 @@ systemAPI esref =
       changePendingCall $ \pc -> return $ pc { call_arg = call_arg pc <> arg }
 
     call_cycles_add :: Word64 -> HostM s ()
-    call_cycles_add amount = do
-      let cycles = fromIntegral amount
+    call_cycles_add amount = call_cycles_add128 (0, amount)
+
+    call_cycles_add128 :: (Word64, Word64) -> HostM s ()
+    call_cycles_add128 amount = do
+      let cycles = combineBitHalves amount
       changePendingCall $ \pc -> do
         subtractBalance esref cycles
         return $ pc { call_transferred_cycles = call_transferred_cycles pc + cycles }

src/IC/Constants.hs

@@ -3,4 +3,4 @@ module IC.Constants where
 import Numeric.Natural
 
 cMAX_CANISTER_BALANCE :: Natural
-cMAX_CANISTER_BALANCE = 2^(60::Int)
+cMAX_CANISTER_BALANCE = 2^(120::Int)

src/IC/Test/Agent.hs

@@ -57,6 +57,7 @@ import Data.Time.Clock.POSIX
 import Codec.Candid (Principal(..), prettyPrincipal)
 import qualified Data.Binary.Get as Get
 import qualified Codec.Candid as Candid
+import Data.Bits
 import Data.Row
 import qualified Data.Row.Records as R
 import qualified Data.Row.Variants as V
@@ -526,6 +527,9 @@ asWord64 = runGet Get.getWord64le
 as2Word64 :: HasCallStack => Blob -> IO (Word64, Word64)
 as2Word64 = runGet $ (,) <$> Get.getWord64le <*> Get.getWord64le
 
+asPairWord64 :: HasCallStack => Blob -> IO (Word64, Word64)
+asPairWord64 = runGet $ flip (,) <$> Get.getWord64le <*> Get.getWord64le
+
 bothSame :: (Eq a, Show a) => (a, a) -> Assertion
 bothSame (x,y) = x @?= y
 
@@ -839,3 +843,6 @@ textual = T.unpack . prettyPrincipal . Principal
 shorten :: Int -> String -> String
 shorten n s = a ++ (if null b then "" else "…")
   where (a,b) = splitAt n s
+
+toI128 :: (Word64, Word64) -> Natural
+toI128 (high, low) = fromIntegral high `shiftL` 64 .|. fromIntegral low

src/IC/Test/Spec.hs

@@ -643,10 +643,14 @@ icTests = withAgentConfig $ testGroup "Interface Spec acceptance tests"
     , t "msg_reply"                    never           reply -- due to double reply
     , t "msg_reject"                   never         $ reject "rejecting" -- due to double reply
     , t "msg_cycles_available"         "U Rt Ry"     $ ignore getAvailableCycles
+    , t "msg_cycles_available128"      "U Rt Ry"     $ ignore getAvailableCycles128
     , t "msg_cycles_refunded"          "Rt Ry"       $ ignore getRefund
+    , t "msg_cycles_refunded128"       "Rt Ry"       $ ignore getRefund128
     , t "msg_cycles_accept"            "U Rt Ry"     $ ignore (acceptCycles (int64 0))
+    , t "msg_cycles_accept128"         "U Rt Ry"     $ ignore (acceptCycles128 (int64 0) (int64 0))
     , t "canister_self"                star          $ ignore self
     , t "canister_cycle_balance"       star          $ ignore getBalance
+    , t "canister_cycle_balance128"    star          $ ignore getBalance128
     , t "call_new…call_perform"        "U Rt Ry H"   $
         callNew "foo" "bar" "baz" "quux" >>>
         callDataAppend "foo" >>>
@@ -655,6 +659,7 @@ icTests = withAgentConfig $ testGroup "Interface Spec acceptance tests"
     , t "call_set_cleanup"             never           $ callOnCleanup (callback noop)
     , t "call_data_append"             never           $ callDataAppend "foo"
     , t "call_cycles_add"              never           $ callCyclesAdd (int64 0)
+    , t "call_cycles_add128"           never           $ callCyclesAdd128 (int64 0) (int64 0)
     , t "call_perform"                 never             callPerform
     , t "stable_size"                  star            $ ignore stableSize
     , t "stable_grow"                  star            $ ignore $ stableGrow (int 1)
@@ -1542,12 +1547,14 @@ icTests = withAgentConfig $ testGroup "Interface Spec acceptance tests"
 
   , testGroup "cycles" $
     let replyBalance = replyData (i64tob getBalance)
+        replyBalance128 = replyData (pairToB getBalance128)
         rememberBalance =
           ignore (stableGrow (int 1)) >>>
           stableWrite (int 0) (i64tob getBalance)
         recallBalance = replyData (stableRead (int 0) (int 8))
         acceptAll = ignore (acceptCycles getAvailableCycles)
         queryBalance cid = query cid replyBalance >>= asWord64
+        queryBalance128 cid = query cid replyBalance128 >>= asPairWord64
 
         -- At the time of writing, creating a canister needs at least 1T
         -- and the freezing limit is 5T
@@ -1579,7 +1586,19 @@ icTests = withAgentConfig $ testGroup "Interface Spec acceptance tests"
           ic_install (ic00via cid) (enum #install) cid2 universal_wasm (run noop)
           return cid2
     in
-    [ testGroup "can use balance API" $
+    [ testGroup "cycles API - backward compatibility" $
+        [ simpleTestCase "canister_cycle_balance = canister_cycle_balance128 for numbers fitting in 64 bits" $ \cid -> do
+          a <- queryBalance cid
+          b <- queryBalance128 cid
+          bothSame ((0,a),b)
+        , testCase "legacy API traps when a result is too big" $ do
+          cid <- create noop
+          let large = 2^(65::Int)
+          ic_top_up ic00 cid large
+          query' cid replyBalance >>= isReject [5]
+          toI128 <$> queryBalance128 cid >>= isRoughly (large + fromIntegral def_cycles)
+        ]
+    , testGroup "can use balance API" $
         let getBalanceTwice = join cat (i64tob getBalance)
             test = replyData getBalanceTwice
         in
@@ -1606,8 +1625,8 @@ icTests = withAgentConfig $ testGroup "Interface Spec acceptance tests"
         call cid (replyData (i64tob (acceptCycles (int64 0)))) >>= asWord64 >>= is 0
     , simpleTestCase "can accept more than available cycles" $ \cid ->
         call cid (replyData (i64tob (acceptCycles (int64 1)))) >>= asWord64 >>= is 0
-    , simpleTestCase "cant accept absurd amount of cycles" $ \cid ->
-        call cid (replyData (i64tob (acceptCycles (int64 maxBound)))) >>= asWord64 >>= is 0
+    , simpleTestCase "can accept absurd amount of cycles" $ \cid ->
+        call cid (replyData (pairToB (acceptCycles128 (int64 maxBound) (int64 maxBound)))) >>= asPairWord64 >>= is (0,0)
 
     , testGroup "provisional_create_canister_with_cycles"
       [ testCase "balance as expected" $ do
@@ -1617,13 +1636,13 @@ icTests = withAgentConfig $ testGroup "Interface Spec acceptance tests"
       , testCaseSteps "default (i.e. max) balance" $ \step -> do
         cid <- ic_provisional_create ic00 Nothing empty
         installAt cid noop
-        cycles <- queryBalance cid
+        cycles <- queryBalance128 cid
         step $ "Cycle balance now at " ++ show cycles
 
       , testCaseSteps "> 2^128 succeeds" $ \step -> do
         cid <- ic_provisional_create ic00 (Just (10 * 2^(128::Int))) empty
         installAt cid noop
-        cycles <- queryBalance cid
+        cycles <- queryBalance128 cid
         step $ "Cycle balance now at " ++ show cycles
       ]
 
@@ -1824,7 +1843,7 @@ icTests = withAgentConfig $ testGroup "Interface Spec acceptance tests"
       , testCaseSteps "more than 2^128" $ \step -> do
         cid <- create noop
         ic_top_up ic00 cid (10 * 2^(128::Int))
-        cycles <- queryBalance cid
+        cycles <- queryBalance128 cid
         step $ "Cycle balance now at " ++ show cycles
       , testCase "nonexisting canister" $ do
         ic_top_up' ic00 doesn'tExist (fromIntegral def_cycles)
@@ -2349,7 +2368,7 @@ install prog = do
     return cid
 
 create :: (HasCallStack, HasAgentConfig) => IO Blob
-create = ic_provisional_create ic00 Nothing empty
+create = ic_provisional_create ic00 (Just (2^(60::Int))) empty
 
 upgrade' :: (HasCallStack, HasAgentConfig) => Blob -> Prog -> IO ReqResponse
 upgrade' cid prog = do

src/IC/Test/Universal.hs

@@ -24,9 +24,9 @@ import Data.ByteString.Builder
 import Data.Word
 import Data.String
 
--- The types of our little language are i32, i64 and blobs
+-- The types of our little language are i32, i64, pair of i64s and blobs
 
-data T = I | I64 | B
+data T = I | I64 | B | PairI64
 
 
 -- We deal with expressions (return a value, thus have a type) and programs (do
@@ -228,6 +228,24 @@ onHeartbeat = op 49
 performanceCounter :: Exp 'I64
 performanceCounter = op 50
 
+getBalance128 :: Exp 'PairI64
+getBalance128 = op 51
+
+getAvailableCycles128 :: Exp 'PairI64
+getAvailableCycles128 = op 52
+
+getRefund128 :: Exp 'PairI64
+getRefund128 = op 53
+
+acceptCycles128 :: Exp 'I64 -> Exp 'I64 -> Exp 'PairI64
+acceptCycles128 = op 54
+
+callCyclesAdd128 :: Exp 'I64 -> Exp 'I64 -> Prog
+callCyclesAdd128 = op 55
+
+pairToB :: Exp 'PairI64 -> Exp 'B
+pairToB = op 56
+
 -- Some convenience combinators
 
 -- This allows us to write byte expressions as plain string literals

universal-canister/src/api.rs

@@ -4,11 +4,19 @@ extern crate wee_alloc;
 #[global_allocator]
 static ALLOC: wee_alloc::WeeAlloc<'_> = wee_alloc::WeeAlloc::INIT;
 
+#[repr(C)]
+// Note: tuples are not FFI-safe causing the compiler to complain. To avoid this,
+// we represent pair as a tuple struct which has known memory layout and the same semantics as
+// a plain pair.
+pub struct Pair(pub u64, pub u64);
+
 mod ic0 {
+    use api::Pair;
     #[link(wasm_import_module = "ic0")]
     extern "C" {
         pub fn accept_message() -> ();
         pub fn canister_cycle_balance() -> u64;
+        pub fn canister_cycle_balance128() -> Pair;
         pub fn canister_self_copy(dst: u32, offset: u32, size: u32) -> ();
         pub fn canister_self_size() -> u32;
         pub fn canister_status() -> u32;
@@ -20,6 +28,9 @@ mod ic0 {
         pub fn msg_cycles_accept(max_amount: u64) -> u64;
         pub fn msg_cycles_available() -> u64;
         pub fn msg_cycles_refunded() -> u64;
+        pub fn msg_cycles_accept128(max_amount_high: u64, max_amount_low: u64) -> Pair;
+        pub fn msg_cycles_available128() -> Pair;
+        pub fn msg_cycles_refunded128() -> Pair;
         pub fn msg_method_name_copy(dst: u32, offset: u32, size: u32) -> ();
         pub fn msg_method_name_size() -> u32;
         pub fn msg_reject_code() -> u32;
@@ -42,6 +53,7 @@ mod ic0 {
         pub fn call_on_cleanup(fun: u32, env: u32) -> ();
         pub fn call_data_append(src: u32, size: u32) -> ();
         pub fn call_cycles_add(amount: u64) -> ();
+        pub fn call_cycles_add128(amount_high: u64, amount_low: u64) -> ();
         pub fn call_perform() -> u32;
         pub fn stable_size() -> u32;
         pub fn stable_grow(additional_pages: u32) -> u32;
@@ -101,6 +113,12 @@ pub fn call_cycles_add(amount: u64) {
     }
 }
 
+pub fn call_cycles_add128(amount_high: u64, amount_low: u64) {
+    unsafe {
+        ic0::call_cycles_add128(amount_high, amount_low);
+    }
+}
+
 pub fn call_perform() -> u32 {
     unsafe { ic0::call_perform() }
 }
@@ -176,18 +194,34 @@ pub fn cycles_available() -> u64 {
     unsafe { ic0::msg_cycles_available() }
 }
 
+pub fn cycles_available128() -> Pair{
+    unsafe { ic0::msg_cycles_available128() }
+}
+
 pub fn cycles_refunded() -> u64 {
     unsafe { ic0::msg_cycles_refunded() }
 }
 
+pub fn cycles_refunded128() -> Pair {
+   unsafe { ic0::msg_cycles_refunded128() }
+}
+
 pub fn accept(amount: u64) -> u64 {
     unsafe { ic0::msg_cycles_accept(amount) }
 }
 
+pub fn accept128(high: u64, low: u64) -> Pair {
+   unsafe { ic0::msg_cycles_accept128(high, low) }
+}
+
 pub fn balance() -> u64 {
     unsafe { ic0::canister_cycle_balance() }
 }
 
+pub fn balance128() -> Pair {
+    unsafe { ic0::canister_cycle_balance128() }
+}
+
 pub fn stable_size() -> u32 {
     unsafe { ic0::stable_size() }
 }