From dfac40452a6f97796c2d095c674a3eaec9d81743 Mon Sep 17 00:00:00 2001
From: Chris Penner <christopher.penner@gmail.com>
Date: Mon, 9 Dec 2024 13:22:40 -0800
Subject: [PATCH] Get Stack unboxing more reliably

---
 .../src/Unison/Runtime/Foreign/Function.hs    | 100 ++-
 .../src/Unison/Runtime/Foreign/Impl.hs        | 636 +++++++++++++++++-
 unison-runtime/src/Unison/Runtime/Machine.hs  |   5 +-
 unison-runtime/src/Unison/Runtime/Stack.hs    |  14 +-
 4 files changed, 737 insertions(+), 18 deletions(-)

diff --git a/unison-runtime/src/Unison/Runtime/Foreign/Function.hs b/unison-runtime/src/Unison/Runtime/Foreign/Function.hs
index 335d9ff61d..e322c5920c 100644
--- a/unison-runtime/src/Unison/Runtime/Foreign/Function.hs
+++ b/unison-runtime/src/Unison/Runtime/Foreign/Function.hs
@@ -7,10 +7,7 @@
 {-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE ViewPatterns #-}
 
-module Unison.Runtime.Foreign.Function
-  ( ForeignConvention (..),
-  )
-where
+module Unison.Runtime.Foreign.Function () where
 
 import Control.Concurrent (ThreadId)
 import Control.Concurrent.MVar (MVar)
@@ -58,81 +55,111 @@ class ForeignConvention a where
 instance ForeignConvention Int where
   readForeign (i : args) stk = (args,) <$> peekOffI stk i
   readForeign [] _ = foreignCCError "Int"
+  {-# INLINE readForeign #-}
   writeForeign stk i = do
     stk <- bump stk
     stk <$ pokeI stk i
+  {-# INLINE writeForeign #-}
 
 instance ForeignConvention Word64 where
   readForeign (i : args) stk = (args,) <$> peekOffN stk i
   readForeign [] _ = foreignCCError "Word64"
+  {-# INLINE readForeign #-}
   writeForeign stk n = do
     stk <- bump stk
     stk <$ pokeN stk n
+  {-# INLINE writeForeign #-}
 
 -- We don't have a clear mapping from these types to Unison types, most are just mapped to Nats.
 
 instance ForeignConvention Word8 where
   readForeign = readForeignAs (fromIntegral :: Word64 -> Word8)
+  {-# INLINE readForeign #-}
   writeForeign = writeForeignAs (fromIntegral :: Word8 -> Word64)
+  {-# INLINE writeForeign #-}
 
 instance ForeignConvention Word16 where
   readForeign = readForeignAs (fromIntegral :: Word64 -> Word16)
+  {-# INLINE readForeign #-}
   writeForeign = writeForeignAs (fromIntegral :: Word16 -> Word64)
+  {-# INLINE writeForeign #-}
 
 instance ForeignConvention Word32 where
   readForeign = readForeignAs (fromIntegral :: Word64 -> Word32)
+  {-# INLINE readForeign #-}
   writeForeign = writeForeignAs (fromIntegral :: Word32 -> Word64)
+  {-# INLINE writeForeign #-}
 
 instance ForeignConvention Char where
   readForeign (i : args) stk = (args,) <$> peekOffC stk i
   readForeign [] _ = foreignCCError "Char"
+  {-# INLINE readForeign #-}
   writeForeign stk ch = do
     stk <- bump stk
     stk <$ pokeC stk ch
+  {-# INLINE writeForeign #-}
 
 instance ForeignConvention Val where
   readForeign (i : args) stk = (args,) <$> peekOff stk i
   readForeign [] _ = foreignCCError "Val"
+  {-# INLINE readForeign #-}
   writeForeign stk v = do
     stk <- bump stk
     stk <$ (poke stk =<< evaluate v)
+  {-# INLINE writeForeign #-}
 
 -- In reality this fixes the type to be 'RClosure', but allows us to defer
 -- the typechecker a bit and avoid a bunch of annoying type annotations.
 instance ForeignConvention Closure where
   readForeign (i : args) stk = (args,) <$> bpeekOff stk i
   readForeign [] _ = foreignCCError "Closure"
+  {-# INLINE readForeign #-}
   writeForeign stk c = do
     stk <- bump stk
     stk <$ (bpoke stk =<< evaluate c)
+  {-# INLINE writeForeign #-}
 
 instance ForeignConvention Text where
   readForeign = readForeignBuiltin
+  {-# INLINE readForeign #-}
   writeForeign = writeForeignBuiltin
+  {-# INLINE writeForeign #-}
 
 instance ForeignConvention Bytes where
   readForeign = readForeignBuiltin
+  {-# INLINE readForeign #-}
   writeForeign = writeForeignBuiltin
+  {-# INLINE writeForeign #-}
 
 instance ForeignConvention Socket where
   readForeign = readForeignBuiltin
+  {-# INLINE readForeign #-}
   writeForeign = writeForeignBuiltin
+  {-# INLINE writeForeign #-}
 
 instance ForeignConvention UDPSocket where
   readForeign = readForeignBuiltin
+  {-# INLINE readForeign #-}
   writeForeign = writeForeignBuiltin
+  {-# INLINE writeForeign #-}
 
 instance ForeignConvention ThreadId where
   readForeign = readForeignBuiltin
+  {-# INLINE readForeign #-}
   writeForeign = writeForeignBuiltin
+  {-# INLINE writeForeign #-}
 
 instance ForeignConvention Handle where
   readForeign = readForeignBuiltin
+  {-# INLINE readForeign #-}
   writeForeign = writeForeignBuiltin
+  {-# INLINE writeForeign #-}
 
 instance ForeignConvention POSIXTime where
   readForeign = readForeignAs (fromIntegral :: Int -> POSIXTime)
+  {-# INLINE readForeign #-}
   writeForeign = writeForeignAs (round :: POSIXTime -> Int)
+  {-# INLINE writeForeign #-}
 
 instance (ForeignConvention a) => ForeignConvention (Maybe a) where
   readForeign (i : args) stk =
@@ -141,6 +168,7 @@ instance (ForeignConvention a) => ForeignConvention (Maybe a) where
       1 -> fmap Just <$> readForeign args stk
       _ -> foreignCCError "Maybe"
   readForeign [] _ = foreignCCError "Maybe"
+  {-# INLINE readForeign #-}
 
   writeForeign stk Nothing = do
     stk <- bump stk
@@ -149,6 +177,7 @@ instance (ForeignConvention a) => ForeignConvention (Maybe a) where
     stk <- writeForeign stk x
     stk <- bump stk
     stk <$ pokeTag stk 1
+  {-# INLINE writeForeign #-}
 
 instance
   (ForeignConvention a, ForeignConvention b) =>
@@ -160,6 +189,7 @@ instance
       1 -> readForeignAs Right args stk
       _ -> foreignCCError "Either"
   readForeign _ _ = foreignCCError "Either"
+  {-# INLINE readForeign #-}
 
   writeForeign stk (Left a) = do
     stk <- writeForeign stk a
@@ -169,6 +199,7 @@ instance
     stk <- writeForeign stk b
     stk <- bump stk
     stk <$ pokeTag stk 1
+  {-# INLINE writeForeign #-}
 
 ioeDecode :: Int -> IOErrorType
 ioeDecode 0 = AlreadyExists
@@ -196,8 +227,10 @@ instance ForeignConvention IOException where
   readForeign = readForeignAs (bld . ioeDecode)
     where
       bld t = IOError Nothing t "" "" Nothing Nothing
+  {-# INLINE readForeign #-}
 
   writeForeign = writeForeignAs (ioeEncode . ioe_type)
+  {-# INLINE writeForeign #-}
 
 readForeignAs ::
   (ForeignConvention a) =>
@@ -258,36 +291,48 @@ readTypelink = readForeignAs (unwrapForeign . marshalToForeign)
 instance ForeignConvention Double where
   readForeign (i : args) stk = (args,) <$> peekOffD stk i
   readForeign _ _ = foreignCCError "Double"
+  {-# INLINE readForeign #-}
   writeForeign stk d =
     bump stk >>= \stk -> do
       pokeD stk d
       pure stk
+  {-# INLINE writeForeign #-}
 
 instance ForeignConvention Bool where
   readForeign (i : args) stk = do
     b <- peekOffBool stk i
     pure (args, b)
   readForeign _ _ = foreignCCError "Bool"
+  {-# INLINE readForeign #-}
   writeForeign stk b = do
     stk <- bump stk
     pokeBool stk b
     pure stk
+  {-# INLINE writeForeign #-}
 
 instance ForeignConvention String where
   readForeign = readForeignAs unpack
+  {-# INLINE readForeign #-}
   writeForeign = writeForeignAs pack
+  {-# INLINE writeForeign #-}
 
 instance ForeignConvention SeekMode where
   readForeign = readForeignEnum
+  {-# INLINE readForeign #-}
   writeForeign = writeForeignEnum
+  {-# INLINE writeForeign #-}
 
 instance ForeignConvention IOMode where
   readForeign = readForeignEnum
+  {-# INLINE readForeign #-}
   writeForeign = writeForeignEnum
+  {-# INLINE writeForeign #-}
 
 instance ForeignConvention () where
   readForeign args _ = pure (args, ())
+  {-# INLINE readForeign #-}
   writeForeign stk _ = pure stk
+  {-# INLINE writeForeign #-}
 
 instance
   (ForeignConvention a, ForeignConvention b) =>
@@ -297,10 +342,12 @@ instance
     (args, a) <- readForeign args stk
     (args, b) <- readForeign args stk
     pure (args, (a, b))
+  {-# INLINE readForeign #-}
 
   writeForeign stk (x, y) = do
     stk <- writeForeign stk y
     writeForeign stk x
+  {-# INLINE writeForeign #-}
 
 instance (ForeignConvention a) => ForeignConvention (Failure a) where
   readForeign args stk = do
@@ -308,11 +355,13 @@ instance (ForeignConvention a) => ForeignConvention (Failure a) where
     (args, message) <- readForeign args stk
     (args, any) <- readForeign args stk
     pure (args, Failure typeref message any)
+  {-# INLINE readForeign #-}
 
   writeForeign stk (Failure typeref message any) = do
     stk <- writeForeign stk any
     stk <- writeForeign stk message
     writeTypeLink stk typeref
+  {-# INLINE writeForeign #-}
 
 instance
   ( ForeignConvention a,
@@ -326,11 +375,13 @@ instance
     (args, b) <- readForeign args stk
     (args, c) <- readForeign args stk
     pure (args, (a, b, c))
+  {-# INLINE readForeign #-}
 
   writeForeign stk (a, b, c) = do
     stk <- writeForeign stk c
     stk <- writeForeign stk b
     writeForeign stk a
+  {-# INLINE writeForeign #-}
 
 instance
   ( ForeignConvention a,
@@ -346,12 +397,14 @@ instance
     (args, c) <- readForeign args stk
     (args, d) <- readForeign args stk
     pure (args, (a, b, c, d))
+  {-# INLINE readForeign #-}
 
   writeForeign stk (a, b, c, d) = do
     stk <- writeForeign stk d
     stk <- writeForeign stk c
     stk <- writeForeign stk b
     writeForeign stk a
+  {-# INLINE writeForeign #-}
 
 instance
   ( ForeignConvention a,
@@ -369,6 +422,7 @@ instance
     (args, d) <- readForeign args stk
     (args, e) <- readForeign args stk
     pure (args, (a, b, c, d, e))
+  {-# INLINE readForeign #-}
 
   writeForeign stk (a, b, c, d, e) = do
     stk <- writeForeign stk e
@@ -376,6 +430,7 @@ instance
     stk <- writeForeign stk c
     stk <- writeForeign stk b
     writeForeign stk a
+  {-# INLINE writeForeign #-}
 
 no'buf, line'buf, block'buf, sblock'buf :: Word64
 no'buf = fromIntegral Ty.bufferModeNoBufferingId
@@ -397,6 +452,7 @@ instance ForeignConvention BufferMode where
             foreignCCError $
               "BufferMode (unknown tag: " <> show t <> ")"
   readForeign _ _ = foreignCCError $ "BufferMode (empty stack)"
+  {-# INLINE readForeign #-}
 
   writeForeign stk bm =
     bump stk >>= \stk ->
@@ -408,6 +464,7 @@ instance ForeignConvention BufferMode where
           pokeI stk n
           stk <- bump stk
           stk <$ pokeN stk sblock'buf
+  {-# INLINE writeForeign #-}
 
 -- In reality this fixes the type to be 'RClosure', but allows us to defer
 -- the typechecker a bit and avoid a bunch of annoying type annotations.
@@ -415,9 +472,11 @@ instance {-# OVERLAPPING #-} ForeignConvention [Val] where
   readForeign (i : args) stk =
     (args,) . toList <$> peekOffS stk i
   readForeign _ _ = foreignCCError "[Val]"
+  {-# INLINE readForeign #-}
   writeForeign stk l = do
     stk <- bump stk
     stk <$ pokeS stk (Sq.fromList l)
+  {-# INLINE writeForeign #-}
 
 -- In reality this fixes the type to be 'RClosure', but allows us to defer
 -- the typechecker a bit and avoid a bunch of annoying type annotations.
@@ -425,65 +484,95 @@ instance {-# OVERLAPPING #-} ForeignConvention [Closure] where
   readForeign (i : args) stk =
     (args,) . fmap getBoxedVal . toList <$> peekOffS stk i
   readForeign _ _ = foreignCCError "[Closure]"
+  {-# INLINE readForeign #-}
   writeForeign stk l = do
     stk <- bump stk
     stk <$ pokeS stk (Sq.fromList . fmap BoxedVal $ l)
+  {-# INLINE writeForeign #-}
 
 instance ForeignConvention [Foreign] where
   readForeign = readForeignAs (fmap marshalToForeign)
+  {-# INLINE readForeign #-}
   writeForeign = writeForeignAs (fmap Foreign)
+  {-# INLINE writeForeign #-}
 
 instance ForeignConvention (MVar Val) where
   readForeign = readForeignAs (unwrapForeign . marshalToForeign)
+  {-# INLINE readForeign #-}
   writeForeign = writeForeignAs (Foreign . Wrap mvarRef)
+  {-# INLINE writeForeign #-}
 
 instance ForeignConvention (TVar Val) where
   readForeign = readForeignAs (unwrapForeign . marshalToForeign)
+  {-# INLINE readForeign #-}
   writeForeign = writeForeignAs (Foreign . Wrap tvarRef)
+  {-# INLINE writeForeign #-}
 
 instance ForeignConvention (IORef Val) where
   readForeign = readForeignAs (unwrapForeign . marshalToForeign)
+  {-# INLINE readForeign #-}
   writeForeign = writeForeignAs (Foreign . Wrap refRef)
+  {-# INLINE writeForeign #-}
 
 instance ForeignConvention (Ticket Val) where
   readForeign = readForeignAs (unwrapForeign . marshalToForeign)
+  {-# INLINE readForeign #-}
   writeForeign = writeForeignAs (Foreign . Wrap ticketRef)
+  {-# INLINE writeForeign #-}
 
 instance ForeignConvention (Promise Val) where
   readForeign = readForeignAs (unwrapForeign . marshalToForeign)
+  {-# INLINE readForeign #-}
   writeForeign = writeForeignAs (Foreign . Wrap promiseRef)
+  {-# INLINE writeForeign #-}
 
 instance ForeignConvention Code where
   readForeign = readForeignBuiltin
+  {-# INLINE readForeign #-}
   writeForeign = writeForeignBuiltin
+  {-# INLINE writeForeign #-}
 
 instance ForeignConvention Value where
   readForeign = readForeignBuiltin
+  {-# INLINE readForeign #-}
   writeForeign = writeForeignBuiltin
+  {-# INLINE writeForeign #-}
 
 instance ForeignConvention Foreign where
   readForeign = readForeignAs marshalToForeign
+  {-# INLINE readForeign #-}
   writeForeign = writeForeignAs Foreign
+  {-# INLINE writeForeign #-}
 
 instance ForeignConvention (PA.MutableArray s Val) where
   readForeign = readForeignAs (unwrapForeign . marshalToForeign)
+  {-# INLINE readForeign #-}
   writeForeign = writeForeignAs (Foreign . Wrap marrayRef)
+  {-# INLINE writeForeign #-}
 
 instance ForeignConvention (PA.MutableByteArray s) where
   readForeign = readForeignAs (unwrapForeign . marshalToForeign)
+  {-# INLINE readForeign #-}
   writeForeign = writeForeignAs (Foreign . Wrap mbytearrayRef)
+  {-# INLINE writeForeign #-}
 
 instance ForeignConvention (PA.Array Val) where
   readForeign = readForeignAs (unwrapForeign . marshalToForeign)
+  {-# INLINE readForeign #-}
   writeForeign = writeForeignAs (Foreign . Wrap iarrayRef)
+  {-# INLINE writeForeign #-}
 
 instance ForeignConvention PA.ByteArray where
   readForeign = readForeignAs (unwrapForeign . marshalToForeign)
+  {-# INLINE readForeign #-}
   writeForeign = writeForeignAs (Foreign . Wrap ibytearrayRef)
+  {-# INLINE writeForeign #-}
 
 instance {-# OVERLAPPABLE #-} (BuiltinForeign b) => ForeignConvention b where
   readForeign = readForeignBuiltin
+  {-# INLINE readForeign #-}
   writeForeign = writeForeignBuiltin
+  {-# INLINE writeForeign #-}
 
 fromUnisonPair :: (BuiltinForeign a, BuiltinForeign b) => Closure -> (a, b)
 fromUnisonPair (DataC _ _ [BoxedVal x, BoxedVal (DataC _ _ [BoxedVal y, BoxedVal _unit])]) =
@@ -511,6 +600,7 @@ instance {-# OVERLAPPABLE #-} (BuiltinForeign a, BuiltinForeign b) => ForeignCon
       . toList
       <$> peekOffS stk i
   readForeign _ _ = foreignCCError "[(a,b)]"
+  {-# INLINE readForeign #-}
 
   writeForeign stk l = do
     stk <- bump stk
@@ -523,9 +613,11 @@ instance {-# OVERLAPPABLE #-} (BuiltinForeign b) => ForeignConvention [b] where
       . toList
       <$> peekOffS stk i
   readForeign _ _ = foreignCCError "[b]"
+  {-# INLINE readForeign #-}
   writeForeign stk l = do
     stk <- bump stk
     stk <$ pokeS stk (boxedVal . Foreign . wrapBuiltin <$> Sq.fromList l)
+  {-# INLINE writeForeign #-}
 
 foreignCCError :: String -> IO a
 foreignCCError nm =
diff --git a/unison-runtime/src/Unison/Runtime/Foreign/Impl.hs b/unison-runtime/src/Unison/Runtime/Foreign/Impl.hs
index e924243759..961498bd82 100644
--- a/unison-runtime/src/Unison/Runtime/Foreign/Impl.hs
+++ b/unison-runtime/src/Unison/Runtime/Foreign/Impl.hs
@@ -1,3 +1,6 @@
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE UndecidableInstances #-}
+
 module Unison.Runtime.Foreign.Impl (foreignCall) where
 
 import Control.Concurrent (ThreadId)
@@ -6,6 +9,7 @@ import Control.Concurrent as SYS
     threadDelay,
   )
 import Control.Concurrent.MVar as SYS
+import Control.Concurrent.STM (TVar)
 import Control.Concurrent.STM qualified as STM
 import Control.DeepSeq (NFData)
 import Control.Exception
@@ -18,16 +22,20 @@ import Crypto.MAC.HMAC qualified as HMAC
 import Crypto.PubKey.Ed25519 qualified as Ed25519
 import Crypto.PubKey.RSA.PKCS15 qualified as RSA
 import Crypto.Random (getRandomBytes)
+import Data.Atomics (Ticket)
 import Data.Bits (shiftL, shiftR, (.|.))
 import Data.ByteArray qualified as BA
 import Data.ByteString (hGet, hGetSome, hPut)
 import Data.ByteString.Lazy qualified as L
 import Data.Default (def)
 import Data.Digest.Murmur64 (asWord64, hash64)
+import Data.IORef (IORef)
 import Data.IP (IP)
 import Data.PEM (PEM, pemContent, pemParseLBS)
+import Data.Sequence qualified as Sq
 import Data.Text qualified
 import Data.Text.IO qualified as Text.IO
+import Data.Time.Clock.POSIX (POSIXTime)
 import Data.Time.Clock.POSIX as SYS
   ( getPOSIXTime,
     posixSecondsToUTCTime,
@@ -39,6 +47,7 @@ import Data.X509.CertificateStore qualified as X
 import Data.X509.Memory qualified as X
 import GHC.Conc qualified as STM
 import GHC.IO (IO (IO))
+import GHC.IO.Exception (IOErrorType (..), IOException (..))
 import Network.Simple.TCP as SYS
   ( HostPreference (..),
     bindSock,
@@ -48,6 +57,7 @@ import Network.Simple.TCP as SYS
     recv,
     send,
   )
+import Network.Socket (Socket)
 import Network.Socket as SYS
   ( PortNumber,
     Socket,
@@ -56,10 +66,10 @@ import Network.Socket as SYS
   )
 import Network.TLS as TLS
 import Network.TLS.Extra.Cipher as Cipher
+import Network.UDP (UDPSocket)
 import Network.UDP as UDP
   ( ClientSockAddr,
     ListenSocket,
-    UDPSocket (..),
     clientSocket,
     close,
     recv,
@@ -91,7 +101,7 @@ import System.Environment as SYS
   )
 import System.Exit as SYS (ExitCode (..))
 import System.FilePath (isPathSeparator)
-import System.IO (Handle)
+import System.IO (BufferMode (..), Handle, IOMode, SeekMode)
 import System.IO as SYS
   ( IOMode (..),
     hClose,
@@ -125,21 +135,34 @@ import Unison.Builtin.Decls qualified as Ty
 import Unison.Prelude hiding (Text, some)
 import Unison.Reference
 import Unison.Referent (Referent, pattern Ref)
+import Unison.Runtime.ANF (Code, PackedTag (..), Value, internalBug)
 import Unison.Runtime.ANF qualified as ANF
 import Unison.Runtime.ANF.Rehash (checkGroupHashes)
 import Unison.Runtime.ANF.Serialize qualified as ANF
 import Unison.Runtime.Array qualified as PA
 import Unison.Runtime.Builtin
 import Unison.Runtime.Crypto.Rsa qualified as Rsa
-import Unison.Runtime.Exception (die)
+import Unison.Runtime.Exception
 import Unison.Runtime.Foreign hiding (Failure)
 import Unison.Runtime.Foreign qualified as F
-import Unison.Runtime.Foreign.Function (ForeignConvention (..))
 import Unison.Runtime.Foreign.Function.Type (ForeignFunc (..))
 import Unison.Runtime.MCode
 import Unison.Runtime.Stack
 import Unison.Symbol
+import Unison.Type
+  ( iarrayRef,
+    ibytearrayRef,
+    marrayRef,
+    mbytearrayRef,
+    mvarRef,
+    promiseRef,
+    refRef,
+    ticketRef,
+    tvarRef,
+    typeLinkRef,
+  )
 import Unison.Type qualified as Ty
+import Unison.Util.Bytes (Bytes)
 import Unison.Util.Bytes qualified as Bytes
 import Unison.Util.RefPromise
   ( Promise,
@@ -148,13 +171,18 @@ import Unison.Util.RefPromise
     tryReadPromise,
     writePromise,
   )
-import Unison.Util.Text (Text)
+import Unison.Util.Text (Text, pack, unpack)
 import Unison.Util.Text qualified as Util.Text
 import Unison.Util.Text.Pattern qualified as TPat
 import UnliftIO qualified
 
-foreignCall :: ForeignFunc -> Args -> Stack -> IO Stack
-foreignCall = \case
+foreignCall :: ForeignFunc -> Args -> XStack -> IOXStack
+foreignCall !ff !args !xstk =
+  stackIOToIOX $ foreignCallHelper ff args (packXStack xstk)
+{-# INLINE foreignCall #-}
+
+foreignCallHelper :: ForeignFunc -> Args -> Stack -> IO Stack
+foreignCallHelper = \case
   IO_UDP_clientSocket_impl_v1 -> mkForeignIOF $ \(host :: Util.Text.Text, port :: Util.Text.Text) ->
     let hostStr = Util.Text.toString host
         portStr = Util.Text.toString port
@@ -861,16 +889,16 @@ foreignCall = \case
       pure $ case e of
         Left se -> Left (Util.Text.pack (show se))
         Right a -> Right a
-{-# INLINE foreignCall #-}
+{-# INLINE foreignCallHelper #-}
 
 mkForeign :: (ForeignConvention a, ForeignConvention b) => (a -> IO b) -> Args -> Stack -> IO Stack
-mkForeign f args stk = do
+mkForeign !f !args !stk = do
   args <- decodeArgs args stk
   res <- f args
   writeForeign stk res
   where
     decodeArgs :: (ForeignConvention x) => Args -> Stack -> IO x
-    decodeArgs args stk =
+    decodeArgs !args !stk =
       readForeign (argsToLists args) stk >>= \case
         ([], a) -> pure a
         _ ->
@@ -910,6 +938,7 @@ mkForeignTls f = mkForeign $ \a -> fmap flatten (tryIO2 (tryIO1 (f a)))
     flatten (Left e) = Left (F.Failure Ty.ioFailureRef (Util.Text.pack (show e)) unitValue)
     flatten (Right (Left e)) = Left (F.Failure Ty.tlsFailureRef (Util.Text.pack (show e)) unitValue)
     flatten (Right (Right a)) = Right a
+{-# INLINE mkForeignTls #-}
 
 mkForeignTlsE ::
   forall a r.
@@ -929,9 +958,11 @@ mkForeignTlsE f = mkForeign $ \a -> fmap flatten (tryIO2 (tryIO1 (f a)))
     flatten (Right (Left e)) = Left (F.Failure Ty.tlsFailureRef (Util.Text.pack (show e)) unitValue)
     flatten (Right (Right (Left e))) = Left e
     flatten (Right (Right (Right a))) = Right a
+{-# INLINE mkForeignTlsE #-}
 
 unsafeSTMToIO :: STM.STM a -> IO a
 unsafeSTMToIO (STM.STM m) = IO m
+{-# INLINE unsafeSTMToIO #-}
 
 signEd25519Wrapper ::
   (Bytes.Bytes, Bytes.Bytes, Bytes.Bytes) -> Either Failure Bytes.Bytes
@@ -1275,3 +1306,588 @@ checkedIndex64 name (arr, i) =
           (PA.indexByteArray arr (j + 5))
           (PA.indexByteArray arr (j + 6))
           (PA.indexByteArray arr (j + 7))
+
+class ForeignConvention a where
+  readForeign ::
+    [Int] -> Stack -> IO ([Int], a)
+  writeForeign ::
+    Stack -> a -> IO Stack
+
+instance ForeignConvention Int where
+  readForeign !(i : args) !stk = (args,) <$> peekOffI stk i
+  readForeign ![] !_ = foreignCCError "Int"
+  {-# INLINE readForeign #-}
+  writeForeign !stk !i = do
+    stk <- bump stk
+    stk <$ pokeI stk i
+  {-# INLINE writeForeign #-}
+
+instance ForeignConvention Word64 where
+  readForeign !(i : args) !stk = (args,) <$> peekOffN stk i
+  readForeign ![] !_ = foreignCCError "Word64"
+  {-# INLINE readForeign #-}
+  writeForeign !stk !n = do
+    stk <- bump stk
+    stk <$ pokeN stk n
+  {-# INLINE writeForeign #-}
+
+-- We don't have a clear mapping from these types to Unison types, most are just mapped to Nats.
+
+instance ForeignConvention Word8 where
+  readForeign = readForeignAs (fromIntegral :: Word64 -> Word8)
+  {-# INLINE readForeign #-}
+  writeForeign = writeForeignAs (fromIntegral :: Word8 -> Word64)
+  {-# INLINE writeForeign #-}
+
+instance ForeignConvention Word16 where
+  readForeign = readForeignAs (fromIntegral :: Word64 -> Word16)
+  {-# INLINE readForeign #-}
+  writeForeign = writeForeignAs (fromIntegral :: Word16 -> Word64)
+  {-# INLINE writeForeign #-}
+
+instance ForeignConvention Word32 where
+  readForeign = readForeignAs (fromIntegral :: Word64 -> Word32)
+  {-# INLINE readForeign #-}
+  writeForeign = writeForeignAs (fromIntegral :: Word32 -> Word64)
+  {-# INLINE writeForeign #-}
+
+instance ForeignConvention Char where
+  readForeign !(i : args) !stk = (args,) <$> peekOffC stk i
+  readForeign ![] !_ = foreignCCError "Char"
+  {-# INLINE readForeign #-}
+  writeForeign !stk !ch = do
+    stk <- bump stk
+    stk <$ pokeC stk ch
+  {-# INLINE writeForeign #-}
+
+instance ForeignConvention Val where
+  readForeign !(i : args) !stk = (args,) <$> peekOff stk i
+  readForeign ![] !_ = foreignCCError "Val"
+  {-# INLINE readForeign #-}
+  writeForeign !stk !v = do
+    stk <- bump stk
+    stk <$ (poke stk =<< evaluate v)
+  {-# INLINE writeForeign #-}
+
+-- In reality this fixes the type to be 'RClosure', but allows us to defer
+-- the typechecker a bit and avoid a bunch of annoying type annotations.
+instance ForeignConvention Closure where
+  readForeign !(i : args) !stk = (args,) <$> bpeekOff stk i
+  readForeign ![] !_ = foreignCCError "Closure"
+  {-# INLINE readForeign #-}
+  writeForeign !stk !c = do
+    stk <- bump stk
+    stk <$ (bpoke stk =<< evaluate c)
+  {-# INLINE writeForeign #-}
+
+instance ForeignConvention Text where
+  readForeign = readForeignBuiltin
+  {-# INLINE readForeign #-}
+  writeForeign = writeForeignBuiltin
+  {-# INLINE writeForeign #-}
+
+instance ForeignConvention Unison.Util.Bytes.Bytes where
+  readForeign = readForeignBuiltin
+  {-# INLINE readForeign #-}
+  writeForeign = writeForeignBuiltin
+  {-# INLINE writeForeign #-}
+
+instance ForeignConvention Socket where
+  readForeign = readForeignBuiltin
+  {-# INLINE readForeign #-}
+  writeForeign = writeForeignBuiltin
+  {-# INLINE writeForeign #-}
+
+instance ForeignConvention UDPSocket where
+  readForeign = readForeignBuiltin
+  {-# INLINE readForeign #-}
+  writeForeign = writeForeignBuiltin
+  {-# INLINE writeForeign #-}
+
+instance ForeignConvention ThreadId where
+  readForeign = readForeignBuiltin
+  {-# INLINE readForeign #-}
+  writeForeign = writeForeignBuiltin
+  {-# INLINE writeForeign #-}
+
+instance ForeignConvention Handle where
+  readForeign = readForeignBuiltin
+  {-# INLINE readForeign #-}
+  writeForeign = writeForeignBuiltin
+  {-# INLINE writeForeign #-}
+
+instance ForeignConvention POSIXTime where
+  readForeign = readForeignAs (fromIntegral :: Int -> POSIXTime)
+  {-# INLINE readForeign #-}
+  writeForeign = writeForeignAs (round :: POSIXTime -> Int)
+  {-# INLINE writeForeign #-}
+
+instance (ForeignConvention a) => ForeignConvention (Maybe a) where
+  readForeign !(i : args) !stk =
+    upeekOff stk i >>= \case
+      0 -> pure (args, Nothing)
+      1 -> fmap Just <$> readForeign args stk
+      _ -> foreignCCError "Maybe"
+  readForeign ![] !_ = foreignCCError "Maybe"
+  {-# INLINE readForeign #-}
+
+  writeForeign !stk !Nothing = do
+    stk <- bump stk
+    stk <$ pokeTag stk 0
+  writeForeign !stk !(Just x) = do
+    stk <- writeForeign stk x
+    stk <- bump stk
+    stk <$ pokeTag stk 1
+  {-# INLINE writeForeign #-}
+
+instance
+  (ForeignConvention a, ForeignConvention b) =>
+  ForeignConvention (Either a b)
+  where
+  readForeign !(i : args) !stk =
+    peekTagOff stk i >>= \case
+      0 -> readForeignAs Left args stk
+      1 -> readForeignAs Right args stk
+      _ -> foreignCCError "Either"
+  readForeign !_ !_ = foreignCCError "Either"
+  {-# INLINE readForeign #-}
+
+  writeForeign !stk !(Left a) = do
+    stk <- writeForeign stk a
+    stk <- bump stk
+    stk <$ pokeTag stk 0
+  writeForeign !stk !(Right b) = do
+    stk <- writeForeign stk b
+    stk <- bump stk
+    stk <$ pokeTag stk 1
+  {-# INLINE writeForeign #-}
+
+ioeDecode :: Int -> IOErrorType
+ioeDecode 0 = AlreadyExists
+ioeDecode 1 = NoSuchThing
+ioeDecode 2 = ResourceBusy
+ioeDecode 3 = ResourceExhausted
+ioeDecode 4 = EOF
+ioeDecode 5 = IllegalOperation
+ioeDecode 6 = PermissionDenied
+ioeDecode 7 = UserError
+ioeDecode _ = internalBug "ioeDecode"
+
+ioeEncode :: IOErrorType -> Int
+ioeEncode AlreadyExists = 0
+ioeEncode NoSuchThing = 1
+ioeEncode ResourceBusy = 2
+ioeEncode ResourceExhausted = 3
+ioeEncode EOF = 4
+ioeEncode IllegalOperation = 5
+ioeEncode PermissionDenied = 6
+ioeEncode UserError = 7
+ioeEncode _ = internalBug "ioeDecode"
+
+instance ForeignConvention IOException where
+  readForeign = readForeignAs (bld . ioeDecode)
+    where
+      bld t = IOError Nothing t "" "" Nothing Nothing
+  {-# INLINE readForeign #-}
+
+  writeForeign = writeForeignAs (ioeEncode . ioe_type)
+  {-# INLINE writeForeign #-}
+
+readForeignAs ::
+  (ForeignConvention a) =>
+  (a -> b) ->
+  [Int] ->
+  Stack ->
+  IO ([Int], b)
+readForeignAs !f !args !stk = fmap f <$> readForeign args stk
+{-# INLINE readForeignAs #-}
+
+writeForeignAs ::
+  (ForeignConvention b) =>
+  (a -> b) ->
+  Stack ->
+  a ->
+  IO Stack
+writeForeignAs !f !stk !x = writeForeign stk (f x)
+{-# INLINE writeForeignAs #-}
+
+readForeignEnum ::
+  (Enum a) =>
+  [Int] ->
+  Stack ->
+  IO ([Int], a)
+readForeignEnum = readForeignAs toEnum
+{-# INLINE readForeignEnum #-}
+
+writeForeignEnum ::
+  (Enum a) =>
+  Stack ->
+  a ->
+  IO Stack
+writeForeignEnum = writeForeignAs fromEnum
+{-# INLINE writeForeignEnum #-}
+
+readForeignBuiltin ::
+  (BuiltinForeign b) =>
+  [Int] ->
+  Stack ->
+  IO ([Int], b)
+readForeignBuiltin = readForeignAs (unwrapBuiltin . marshalToForeign)
+{-# INLINE readForeignBuiltin #-}
+
+writeForeignBuiltin ::
+  (BuiltinForeign b) =>
+  Stack ->
+  b ->
+  IO Stack
+writeForeignBuiltin = writeForeignAs (Foreign . wrapBuiltin)
+{-# INLINE writeForeignBuiltin #-}
+
+writeTypeLink ::
+  Stack ->
+  Reference ->
+  IO Stack
+writeTypeLink = writeForeignAs (Foreign . Wrap typeLinkRef)
+{-# INLINE writeTypeLink #-}
+
+readTypelink ::
+  [Int] ->
+  Stack ->
+  IO ([Int], Reference)
+readTypelink = readForeignAs (unwrapForeign . marshalToForeign)
+{-# INLINE readTypelink #-}
+
+instance ForeignConvention Double where
+  readForeign !(i : args) !stk = (args,) <$> peekOffD stk i
+  readForeign !_ !_ = foreignCCError "Double"
+  {-# INLINE readForeign #-}
+  writeForeign !stk !d =
+    bump stk >>= \(!stk) -> do
+      pokeD stk d
+      pure stk
+  {-# INLINE writeForeign #-}
+
+instance ForeignConvention Bool where
+  readForeign !(i : args) !stk = do
+    b <- peekOffBool stk i
+    pure (args, b)
+  readForeign !_ !_ = foreignCCError "Bool"
+  {-# INLINE readForeign #-}
+  writeForeign !stk !b = do
+    stk <- bump stk
+    pokeBool stk b
+    pure stk
+  {-# INLINE writeForeign #-}
+
+instance ForeignConvention String where
+  readForeign = readForeignAs unpack
+  {-# INLINE readForeign #-}
+  writeForeign = writeForeignAs pack
+  {-# INLINE writeForeign #-}
+
+instance ForeignConvention SeekMode where
+  readForeign = readForeignEnum
+  {-# INLINE readForeign #-}
+  writeForeign = writeForeignEnum
+  {-# INLINE writeForeign #-}
+
+instance ForeignConvention IOMode where
+  readForeign = readForeignEnum
+  {-# INLINE readForeign #-}
+  writeForeign = writeForeignEnum
+  {-# INLINE writeForeign #-}
+
+instance ForeignConvention () where
+  readForeign args !_ = pure (args, ())
+  {-# INLINE readForeign #-}
+  writeForeign !stk !_ = pure stk
+  {-# INLINE writeForeign #-}
+
+instance
+  (ForeignConvention a, ForeignConvention b) =>
+  ForeignConvention (a, b)
+  where
+  readForeign !args !stk = do
+    (args, a) <- readForeign args stk
+    (args, b) <- readForeign args stk
+    pure (args, (a, b))
+  {-# INLINE readForeign #-}
+
+  writeForeign !stk !(x, y) = do
+    stk <- writeForeign stk y
+    writeForeign stk x
+  {-# INLINE writeForeign #-}
+
+instance (ForeignConvention a) => ForeignConvention (F.Failure a) where
+  readForeign !args !stk = do
+    (args, typeref) <- readTypelink args stk
+    (args, message) <- readForeign args stk
+    (args, any) <- readForeign args stk
+    pure (args, F.Failure typeref message any)
+  {-# INLINE readForeign #-}
+
+  writeForeign !stk !(F.Failure typeref message any) = do
+    stk <- writeForeign stk any
+    stk <- writeForeign stk message
+    writeTypeLink stk typeref
+  {-# INLINE writeForeign #-}
+
+instance
+  ( ForeignConvention a,
+    ForeignConvention b,
+    ForeignConvention c
+  ) =>
+  ForeignConvention (a, b, c)
+  where
+  readForeign args !stk = do
+    (args, a) <- readForeign args stk
+    (args, b) <- readForeign args stk
+    (args, c) <- readForeign args stk
+    pure (args, (a, b, c))
+  {-# INLINE readForeign #-}
+
+  writeForeign !stk !(a, b, c) = do
+    stk <- writeForeign stk c
+    stk <- writeForeign stk b
+    writeForeign stk a
+  {-# INLINE writeForeign #-}
+
+instance
+  ( ForeignConvention a,
+    ForeignConvention b,
+    ForeignConvention c,
+    ForeignConvention d
+  ) =>
+  ForeignConvention (a, b, c, d)
+  where
+  readForeign !args !stk = do
+    (args, a) <- readForeign args stk
+    (args, b) <- readForeign args stk
+    (args, c) <- readForeign args stk
+    (args, d) <- readForeign args stk
+    pure (args, (a, b, c, d))
+  {-# INLINE readForeign #-}
+
+  writeForeign !stk !(a, b, c, d) = do
+    stk <- writeForeign stk d
+    stk <- writeForeign stk c
+    stk <- writeForeign stk b
+    writeForeign stk a
+  {-# INLINE writeForeign #-}
+
+instance
+  ( ForeignConvention a,
+    ForeignConvention b,
+    ForeignConvention c,
+    ForeignConvention d,
+    ForeignConvention e
+  ) =>
+  ForeignConvention (a, b, c, d, e)
+  where
+  readForeign !args !stk = do
+    (args, a) <- readForeign args stk
+    (args, b) <- readForeign args stk
+    (args, c) <- readForeign args stk
+    (args, d) <- readForeign args stk
+    (args, e) <- readForeign args stk
+    pure (args, (a, b, c, d, e))
+  {-# INLINE readForeign #-}
+
+  writeForeign !stk !(a, b, c, d, e) = do
+    stk <- writeForeign stk e
+    stk <- writeForeign stk d
+    stk <- writeForeign stk c
+    stk <- writeForeign stk b
+    writeForeign stk a
+  {-# INLINE writeForeign #-}
+
+no'buf, line'buf, block'buf, sblock'buf :: Word64
+no'buf = fromIntegral Ty.bufferModeNoBufferingId
+line'buf = fromIntegral Ty.bufferModeLineBufferingId
+block'buf = fromIntegral Ty.bufferModeBlockBufferingId
+sblock'buf = fromIntegral Ty.bufferModeSizedBlockBufferingId
+
+instance ForeignConvention BufferMode where
+  readForeign !(i : args) !stk =
+    peekOffN stk i >>= \case
+      t
+        | t == no'buf -> pure (args, NoBuffering)
+        | t == line'buf -> pure (args, LineBuffering)
+        | t == block'buf -> pure (args, BlockBuffering Nothing)
+        | t == sblock'buf ->
+            fmap (BlockBuffering . Just)
+              <$> readForeign args stk
+        | otherwise ->
+            foreignCCError $
+              "BufferMode (unknown tag: " <> show t <> ")"
+  readForeign !_ !_ = foreignCCError $ "BufferMode (empty stack)"
+  {-# INLINE readForeign #-}
+
+  writeForeign !stk !bm =
+    bump stk >>= \(!stk) ->
+      case bm of
+        NoBuffering -> stk <$ pokeN stk no'buf
+        LineBuffering -> stk <$ pokeN stk line'buf
+        BlockBuffering Nothing -> stk <$ pokeN stk block'buf
+        BlockBuffering (Just n) -> do
+          pokeI stk n
+          stk <- bump stk
+          stk <$ pokeN stk sblock'buf
+  {-# INLINE writeForeign #-}
+
+-- In reality this fixes the type to be 'RClosure', but allows us to defer
+-- the typechecker a bit and avoid a bunch of annoying type annotations.
+instance {-# OVERLAPPING #-} ForeignConvention [Val] where
+  readForeign !(i : args) !stk =
+    (args,) . toList <$> peekOffS stk i
+  readForeign !_ !_ = foreignCCError "[Val]"
+  {-# INLINE readForeign #-}
+  writeForeign !stk !l = do
+    stk <- bump stk
+    stk <$ pokeS stk (Sq.fromList l)
+  {-# INLINE writeForeign #-}
+
+-- In reality this fixes the type to be 'RClosure', but allows us to defer
+-- the typechecker a bit and avoid a bunch of annoying type annotations.
+instance {-# OVERLAPPING #-} ForeignConvention [Closure] where
+  readForeign !(i : args) !stk =
+    (args,) . fmap getBoxedVal . toList <$> peekOffS stk i
+  readForeign !_ !_ = foreignCCError "[Closure]"
+  {-# INLINE readForeign #-}
+  writeForeign !stk !l = do
+    stk <- bump stk
+    stk <$ pokeS stk (Sq.fromList . fmap BoxedVal $ l)
+  {-# INLINE writeForeign #-}
+
+instance ForeignConvention [Foreign] where
+  readForeign = readForeignAs (fmap marshalToForeign)
+  {-# INLINE readForeign #-}
+  writeForeign = writeForeignAs (fmap Foreign)
+  {-# INLINE writeForeign #-}
+
+instance ForeignConvention (MVar Val) where
+  readForeign = readForeignAs (unwrapForeign . marshalToForeign)
+  {-# INLINE readForeign #-}
+  writeForeign = writeForeignAs (Foreign . Wrap mvarRef)
+  {-# INLINE writeForeign #-}
+
+instance ForeignConvention (TVar Val) where
+  readForeign = readForeignAs (unwrapForeign . marshalToForeign)
+  {-# INLINE readForeign #-}
+  writeForeign = writeForeignAs (Foreign . Wrap tvarRef)
+  {-# INLINE writeForeign #-}
+
+instance ForeignConvention (IORef Val) where
+  readForeign = readForeignAs (unwrapForeign . marshalToForeign)
+  {-# INLINE readForeign #-}
+  writeForeign = writeForeignAs (Foreign . Wrap refRef)
+  {-# INLINE writeForeign #-}
+
+instance ForeignConvention (Ticket Val) where
+  readForeign = readForeignAs (unwrapForeign . marshalToForeign)
+  {-# INLINE readForeign #-}
+  writeForeign = writeForeignAs (Foreign . Wrap ticketRef)
+  {-# INLINE writeForeign #-}
+
+instance ForeignConvention (Promise Val) where
+  readForeign = readForeignAs (unwrapForeign . marshalToForeign)
+  {-# INLINE readForeign #-}
+  writeForeign = writeForeignAs (Foreign . Wrap promiseRef)
+  {-# INLINE writeForeign #-}
+
+instance ForeignConvention Code where
+  readForeign = readForeignBuiltin
+  {-# INLINE readForeign #-}
+  writeForeign = writeForeignBuiltin
+  {-# INLINE writeForeign #-}
+
+instance ForeignConvention Value where
+  readForeign = readForeignBuiltin
+  {-# INLINE readForeign #-}
+  writeForeign = writeForeignBuiltin
+  {-# INLINE writeForeign #-}
+
+instance ForeignConvention Foreign where
+  readForeign = readForeignAs marshalToForeign
+  {-# INLINE readForeign #-}
+  writeForeign = writeForeignAs Foreign
+  {-# INLINE writeForeign #-}
+
+instance ForeignConvention (PA.MutableArray s Val) where
+  readForeign = readForeignAs (unwrapForeign . marshalToForeign)
+  {-# INLINE readForeign #-}
+  writeForeign = writeForeignAs (Foreign . Wrap marrayRef)
+  {-# INLINE writeForeign #-}
+
+instance ForeignConvention (PA.MutableByteArray s) where
+  readForeign = readForeignAs (unwrapForeign . marshalToForeign)
+  {-# INLINE readForeign #-}
+  writeForeign = writeForeignAs (Foreign . Wrap mbytearrayRef)
+  {-# INLINE writeForeign #-}
+
+instance ForeignConvention (PA.Array Val) where
+  readForeign = readForeignAs (unwrapForeign . marshalToForeign)
+  {-# INLINE readForeign #-}
+  writeForeign = writeForeignAs (Foreign . Wrap iarrayRef)
+  {-# INLINE writeForeign #-}
+
+instance ForeignConvention PA.ByteArray where
+  readForeign = readForeignAs (unwrapForeign . marshalToForeign)
+  {-# INLINE readForeign #-}
+  writeForeign = writeForeignAs (Foreign . Wrap ibytearrayRef)
+  {-# INLINE writeForeign #-}
+
+instance {-# OVERLAPPABLE #-} (BuiltinForeign b) => ForeignConvention b where
+  readForeign = readForeignBuiltin
+  {-# INLINE readForeign #-}
+  writeForeign = writeForeignBuiltin
+  {-# INLINE writeForeign #-}
+
+fromUnisonPair :: (BuiltinForeign a, BuiltinForeign b) => Closure -> (a, b)
+fromUnisonPair (DataC _ _ [BoxedVal x, BoxedVal (DataC _ _ [BoxedVal y, BoxedVal _unit])]) =
+  (unwrapForeignClosure x, unwrapForeignClosure y)
+fromUnisonPair _ = error "fromUnisonPair: invalid closure"
+
+toUnisonPair ::
+  (BuiltinForeign a, BuiltinForeign b) => (a, b) -> Closure
+toUnisonPair (x, y) =
+  DataC
+    Ty.pairRef
+    (PackedTag 0)
+    [BoxedVal $ wr x, BoxedVal $ DataC Ty.pairRef (PackedTag 0) [BoxedVal $ wr y, BoxedVal $ un]]
+  where
+    un = DataC Ty.unitRef (PackedTag 0) []
+    wr z = Foreign $ wrapBuiltin z
+
+unwrapForeignClosure :: Closure -> a
+unwrapForeignClosure = unwrapForeign . marshalToForeign
+
+instance {-# OVERLAPPABLE #-} (BuiltinForeign a, BuiltinForeign b) => ForeignConvention [(a, b)] where
+  readForeign !(i : args) !stk =
+    (args,)
+      . fmap (fromUnisonPair . getBoxedVal)
+      . toList
+      <$> peekOffS stk i
+  readForeign !_ !_ = foreignCCError "[(a,b)]"
+  {-# INLINE readForeign #-}
+
+  writeForeign !stk !l = do
+    stk <- bump stk
+    stk <$ pokeS stk (boxedVal . toUnisonPair <$> Sq.fromList l)
+
+instance {-# OVERLAPPABLE #-} (BuiltinForeign b) => ForeignConvention [b] where
+  readForeign !(i : args) !stk =
+    (args,)
+      . fmap (unwrapForeignClosure . getBoxedVal)
+      . toList
+      <$> peekOffS stk i
+  readForeign !_ !_ = foreignCCError "[b]"
+  {-# INLINE readForeign #-}
+  writeForeign !stk !l = do
+    stk <- bump stk
+    stk <$ pokeS stk (boxedVal . Foreign . wrapBuiltin <$> Sq.fromList l)
+  {-# INLINE writeForeign #-}
+
+foreignCCError :: String -> IO a
+foreignCCError nm =
+  die $ "mismatched foreign calling convention for `" ++ nm ++ "`"
diff --git a/unison-runtime/src/Unison/Runtime/Machine.hs b/unison-runtime/src/Unison/Runtime/Machine.hs
index 9356bd4dc0..e05cc558c2 100644
--- a/unison-runtime/src/Unison/Runtime/Machine.hs
+++ b/unison-runtime/src/Unison/Runtime/Machine.hs
@@ -591,8 +591,9 @@ exec !_ !denv !_activeThreads !stk !k _ (Seq as) = do
   stk <- bump stk
   pokeS stk $ Sq.fromList l
   pure (denv, stk, k)
-exec !_env !denv !_activeThreads !stk !k _ (ForeignCall _ func args) =
-  (denv,,k) <$> foreignCall func args stk
+exec !_env !denv !_activeThreads !stk !k _ (ForeignCall _ func args) = do
+  stk <- xStackIOToIO $ foreignCall func args (unpackXStack stk)
+  pure (denv, stk, k)
 exec !env !denv !activeThreads !stk !k _ (Fork i)
   | sandboxed env = die "attempted to use sandboxed operation: fork"
   | otherwise = do
diff --git a/unison-runtime/src/Unison/Runtime/Stack.hs b/unison-runtime/src/Unison/Runtime/Stack.hs
index 3747114de6..33e5e8bd0e 100644
--- a/unison-runtime/src/Unison/Runtime/Stack.hs
+++ b/unison-runtime/src/Unison/Runtime/Stack.hs
@@ -34,7 +34,9 @@ module Unison.Runtime.Stack
     pattern XStack,
     packXStack,
     unpackXStack,
-    IOStack,
+    xStackIOToIO,
+    stackIOToIOX,
+    IOXStack,
     apX,
     fpX,
     spX,
@@ -639,7 +641,7 @@ data Stack = Stack
 -- Unboxed representation of the Stack, used to force GHC optimizations in a few spots.
 type XStack = (# Int#, Int#, Int#, MutableByteArray# (PrimState IO), MutableArray# (PrimState IO) Closure #)
 
-type IOStack = State# RealWorld -> (# State# RealWorld, XStack #)
+type IOXStack = State# RealWorld -> (# State# RealWorld, XStack #)
 
 pattern XStack :: Int# -> Int# -> Int# -> MutableByteArray# RealWorld -> MutableArray# RealWorld Closure -> Stack
 pattern XStack {apX, fpX, spX, ustkX, bstkX} = Stack (I# apX) (I# fpX) (I# spX) (MutableByteArray ustkX) (MutableArray bstkX)
@@ -656,6 +658,14 @@ unpackXStack :: Stack -> XStack
 unpackXStack (Stack (I# ap) (I# fp) (I# sp) (MutableByteArray ustk) (MutableArray bstk)) = (# ap, fp, sp, ustk, bstk #)
 {-# INLINE unpackXStack #-}
 
+xStackIOToIO :: IOXStack -> IO Stack
+xStackIOToIO f = IO $ \s -> case f s of (# s', x #) -> (# s', packXStack x #)
+{-# INLINE xStackIOToIO #-}
+
+stackIOToIOX :: IO Stack -> IOXStack
+stackIOToIOX (IO f) = \s -> case f s of (# s', x #) -> (# s', unpackXStack x #)
+{-# INLINE stackIOToIOX #-}
+
 instance Show Stack where
   show (Stack ap fp sp _ _) =
     "Stack " ++ show ap ++ " " ++ show fp ++ " " ++ show sp