Merge pull request #6060 from unisonweb/topic/ffi-types

Author: aryairani

parser-typechecker/src/Unison/Builtin.hs

@@ -815,9 +815,14 @@ builtinsSrc =
     B "Natural.isEven" $ natural --> boolean,
     B "Natural.isOdd" $ natural --> boolean,
     B "FFI.openDLL" $ text --> ioexn dll,
+    B "FFI.int16" $ ffiType int,
+    B "FFI.int32" $ ffiType int,
     B "FFI.int64" $ ffiType int,
     B "FFI.uint64" $ ffiType nat,
+    B "FFI.uint32" $ ffiType nat,
+    B "FFI.uint16" $ ffiType nat,
     B "FFI.double" $ ffiType float,
+    B "FFI.float" $ ffiType float,
     B "FFI.void" $ ffiType unit,
     B "FFI.base" . forall2 "a" "b" $ \a b ->
       ffiType a --> ffiType b --> ffiSpec (a --> Type.effect () [] b),

unison-runtime/src/Unison/Runtime/Builtin.hs

@@ -1406,8 +1406,13 @@ declareForeigns = do
   declareForeign Untracked 3 Avro_decodeBinary
   declareForeign Tracked 1 FFI_openDLL
   declareForeignWrap Untracked direct FFI_int64
+  declareForeignWrap Untracked direct FFI_int32
+  declareForeignWrap Untracked direct FFI_int16
   declareForeignWrap Untracked direct FFI_uint64
+  declareForeignWrap Untracked direct FFI_uint32
+  declareForeignWrap Untracked direct FFI_uint16
   declareForeignWrap Untracked direct FFI_double
+  declareForeignWrap Untracked direct FFI_float
   declareForeignWrap Untracked direct FFI_void
   declareForeign Untracked 2 FFI_base
   declareForeign Untracked 2 FFI_baseIO

unison-runtime/src/Unison/Runtime/Foreign/Dynamic.hs

@@ -15,36 +15,40 @@ import Unison.Runtime.FFI.DLL
 import Unison.Runtime.Foreign
 import Unison.Type (ffiFuncRef, ffiSpecRef, ffiTypeRef)
 
-data FFType = I64 | U64 | D64 | Void
+data FFType = I16 | I32 | I64 | U16 | U32 | U64 | F32 | D64 | Void
   deriving (Eq, Ord, Show)
 
 instance BuiltinForeign FFType where
   foreignName = Tagged "FFI.Type"
   foreignRef = Tagged ffiTypeRef
 
 -- arguments and return type
-data FFSpec = FFSpec [FFType] !FFType deriving (Eq, Ord, Show)
-
-ffArgs :: FFSpec -> [FFType]
-ffArgs (FFSpec as _) = as
+data FFSpec = FFSpec {ffArgs :: ![FFType], ffResult :: !FFType}
+  deriving (Eq, Ord, Show)
 
 instance BuiltinForeign FFSpec where
   foreignName = Tagged "FFI.Spec"
   foreignRef = Tagged ffiSpecRef
 
 data CSpec = CSpec
   { cInterface :: !(ForeignPtr CIF),
-    numArgs :: !Int
+    numArgs :: !Int,
+    ffSpec :: !FFSpec
   }
 
 data CDynFunc = forall a.
   CDynFunc
   { cName :: String,
-    cResult :: !FFType,
     cSpec :: {-# UNPACK #-} !CSpec,
     cFun :: !(FunPtr a)
   }
 
+cffArgs :: CDynFunc -> [FFType]
+cffArgs = ffArgs . ffSpec . cSpec
+
+cffResult :: CDynFunc -> FFType
+cffResult = ffResult . ffSpec . cSpec
+
 instance Show CDynFunc where
   show f = "<" ++ cName f ++ ">"
 
@@ -53,9 +57,14 @@ instance BuiltinForeign CDynFunc where
   foreignRef = Tagged ffiFuncRef
 
 encodeType :: FFType -> Ptr CType
+encodeType I16 = ffi_type_sint16
+encodeType I32 = ffi_type_sint32
 encodeType I64 = ffi_type_sint64
+encodeType U16 = ffi_type_uint16
+encodeType U32 = ffi_type_uint32
 encodeType U64 = ffi_type_uint64
 encodeType D64 = ffi_type_double
+encodeType F32 = ffi_type_float
 encodeType Void = ffi_type_void
 
 encodeTypes :: [FFType] -> Ptr (Ptr CType) -> IO ()
@@ -78,7 +87,7 @@ adjustSpec sp@(FFSpec as r)
 
 prepareSpec :: FFSpec -> IO CSpec
 prepareSpec spec = do
-  FFSpec args ret <- adjustSpec spec
+  ffSpec@(FFSpec args ret) <- adjustSpec spec
   let numArgs = length args
       n = fromIntegral numArgs
 
@@ -91,11 +100,11 @@ prepareSpec spec = do
       unless (status == ffi_ok) $
         throwIO BadInit
 
-  pure $ CSpec {cInterface, numArgs}
+  pure $ CSpec {cInterface, numArgs, ffSpec}
 
 loadForeign :: DLL -> FFSpec -> String -> IO CDynFunc
-loadForeign dll fspec@(FFSpec _ r) sym =
-  CDynFunc name r <$> prepareSpec fspec <*> getDLLSym dll sym
+loadForeign dll fspec sym =
+  CDynFunc name <$> prepareSpec fspec <*> getDLLSym dll sym
   where
     name = getDLLPath dll ++ "$" ++ sym
 
@@ -112,6 +121,6 @@ loadForeign dll fspec@(FFSpec _ r) sym =
 --
 --     Store.poke (castPtr (plusPtr p i)) <smaller-value>
 callForeign :: CDynFunc -> Ptr (Ptr a) -> Ptr r -> IO ()
-callForeign (CDynFunc _ _ (CSpec cInterface _) fun) cArgs cRet =
+callForeign (CDynFunc _ (CSpec cInterface _ _) fun) cArgs cRet =
   withForeignPtr cInterface \cif ->
     ffi_call cif fun (castPtr cRet) (castPtr cArgs)

unison-runtime/src/Unison/Runtime/Foreign/Function.hs

@@ -1160,8 +1160,13 @@ foreignCallHelper = \case
   FFI_openDLL -> mkForeignIOExn $ \(fname :: Text) ->
     evaluate =<< openDLL (unpack fname)
   FFI_int64 -> mkForeign \() -> pure $ I64
+  FFI_int32 -> mkForeign \() -> pure $ I32
+  FFI_int16 -> mkForeign \() -> pure $ I16
   FFI_uint64 -> mkForeign \() -> pure $ U64
+  FFI_uint32 -> mkForeign \() -> pure $ U32
+  FFI_uint16 -> mkForeign \() -> pure $ U16
   FFI_double -> mkForeign \() -> pure $ D64
+  FFI_float -> mkForeign \() -> pure $ F32
   FFI_void -> mkForeign \() -> pure $ Void
   FFI_base -> mkForeign $ \(a, r) -> evaluate $ FFSpec [a] r
   FFI_baseIO -> mkForeign $ \(a, r) -> evaluate $ FFSpec [a] r

unison-runtime/src/Unison/Runtime/Foreign/Function/Type.hs

@@ -368,8 +368,13 @@ data ForeignFunc
   | Universal_murmurHashUntyped
   | FFI_openDLL
   | FFI_int64
+  | FFI_int32
+  | FFI_int16
   | FFI_uint64
+  | FFI_uint32
+  | FFI_uint16
   | FFI_double
+  | FFI_float
   | FFI_void
   | FFI_base
   | FFI_baseIO
@@ -739,8 +744,13 @@ foreignFuncBuiltinName = \case
   Universal_murmurHashUntyped -> "Universal.murmurHashUntyped"
   FFI_openDLL -> "FFI.openDLL"
   FFI_int64 -> "FFI.int64"
+  FFI_int32 -> "FFI.int32"
+  FFI_int16 -> "FFI.int16"
   FFI_uint64 -> "FFI.uint64"
+  FFI_uint32 -> "FFI.uint32"
+  FFI_uint16 -> "FFI.uint16"
   FFI_double -> "FFI.double"
+  FFI_float -> "FFI.float"
   FFI_void -> "FFI.void"
   FFI_base -> "FFI.base"
   FFI_baseIO -> "FFI.baseIO"

unison-runtime/src/Unison/Runtime/Machine.hs

@@ -48,6 +48,7 @@ import Foreign.Marshal.Array (allocaArray)
 import Foreign.Ptr
 import Foreign.Storable qualified as Store
 import GHC.Conc as STM (unsafeIOToSTM)
+import GHC.Float (double2Float, float2Double)
 import GHC.Stack
 import Unison.Builtin.Decls (exceptionRef)
 import Unison.Builtin.Decls qualified as Rf
@@ -490,33 +491,79 @@ exec _ henv !_activeThreads !stk !k _ DLLCall = do
   allocaArray n \storage ->
     allocaArray n \cArgs ->
       alloca \(cRet :: Ptr Int) -> do
-        copyArgs stk n storage cArgs
+        copyArgs stk (DLL.cffArgs cf) storage cArgs
         DLL.callForeign cf cArgs cRet
-        case DLL.cResult cf of
+        case DLL.cffResult cf of
+          DLL.I16 -> Store.peek (castPtr cRet) >>= pokeI stk . fi16
+          DLL.I32 -> Store.peek (castPtr cRet) >>= pokeI stk . fi32
           DLL.I64 -> Store.peek cRet >>= pokeI stk
+          DLL.U16 -> Store.peek (castPtr cRet) >>= pokeN stk . fu16
+          DLL.U32 -> Store.peek (castPtr cRet) >>= pokeN stk . fu32
           DLL.U64 -> Store.peek (castPtr cRet) >>= pokeN stk
+          DLL.F32 -> Store.peek (castPtr cRet) >>= pokeD stk . ff32
           DLL.D64 -> Store.peek (castPtr cRet) >>= pokeD stk
           DLL.Void -> poke stk unitValue
   pure (False, henv, stk, k)
 exec _ _ !_ !_ !_ _ (SandboxingFailure t) = do
   die [] $ "Attempted to use disallowed builtin in sandboxed environment: " <> DTx.unpack t
 {-# INLINE exec #-}
 
+fi16 :: Int16 -> Int
+fi16 = fromIntegral
+
+ti16 :: Int -> Int16
+ti16 = fromIntegral
+
+fi32 :: Int32 -> Int
+fi32 = fromIntegral
+
+ti32 :: Int -> Int32
+ti32 = fromIntegral
+
+fu32 :: Word32 -> Word64
+fu32 = fromIntegral
+
+tu32 :: Word64 -> Word32
+tu32 = fromIntegral
+
+fu16 :: Word16 -> Word64
+fu16 = fromIntegral
+
+tu16 :: Word64 -> Word16
+tu16 = fromIntegral
+
+tf32 :: Double -> Float
+tf32 = double2Float
+
+ff32 :: Float -> Double
+ff32 = float2Double
+
 -- Copies unison stack values into temporary space appropriate for
 -- calling libffi. The latter takes all arguments as pointers, so we
 -- need to copy the arguments to pinned memory to have a stable
--- location. All our FFI arguments are 64-bit, though, so we can just
--- use a contiguous array.
-copyArgs :: Stack -> Int -> Ptr Int -> Ptr (Ptr CValue) -> IO ()
-copyArgs !stk n = go 2
+-- location. All our FFI arguments are 64-bit or smaller, though, so
+-- we can just use a contiguous array with as many 8 byte slots as
+-- there are arguments, possibly using only portions of some slots.
+copyArgs ::
+  Stack -> [DLL.FFType] -> Ptr Int -> Ptr (Ptr CValue) -> IO ()
+copyArgs !stk = go 2
   where
-    go i !p !h
-      | i <= n + 1 = do
-          k <- upeekOff stk i
-          Store.poke p k
-          Store.poke h (castPtr p)
-          go (i + 1) (plusPtr p szp) (plusPtr h szh)
-      | otherwise = pure ()
+    go !i (a : as) !p !h = do
+      store a i p
+      Store.poke h (castPtr p)
+      go (i + 1) as (plusPtr p szp) (plusPtr h szh)
+    go _ _ _ _ = pure ()
+
+    -- special case non-64-bit values for conversions, otherwise just
+    -- copy bytes.
+    store DLL.I32 i p = upeekOff stk i >>= Store.poke (castPtr p) . ti32
+    store DLL.U32 i p = peekOffN stk i >>= Store.poke (castPtr p) . tu32
+    store DLL.I16 i p = upeekOff stk i >>= Store.poke (castPtr p) . ti16
+    store DLL.U16 i p = peekOffN stk i >>= Store.poke (castPtr p) . tu16
+    store DLL.F32 i p = peekOffD stk i >>= Store.poke (castPtr p) . tf32
+    store _ i p = upeekOff stk i >>= Store.poke p
+    {-# INLINE store #-}
+
     szp = Store.sizeOf (0 :: Int)
     szh = Store.sizeOf (undefined :: Ptr CValue)
 {-# INLINE copyArgs #-}

unison-src/transcripts-manual/dll-ffi-unix.md

@@ -3,13 +3,32 @@ scratch/dll-ffi> builtins.mergeio
 ```
 
 ``` unison
-testSpec = arr int64 (base int64 int64)
+testu64Spec = arr uint64 (base uint64 uint64)
+testu32Spec = arr uint32 (base uint32 uint32)
+testu16Spec = arr uint16 (base uint16 uint16)
+testi64Spec = arr int64 (base int64 int64)
+testi32Spec = arr int32 (base int32 int32)
+testi16Spec = arr int16 (base int16 int16)
+testdSpec = arr double (base double double)
+testfSpec = arr float (base float float)
+
+
 libtest = do openDLL "unison-src/transcripts-manual/dll-ffi/libtest.so"
 
 doTest = do
   dll = libtest()
-  f = getDLLSym dll "test" testSpec
-  f +1 +2
+  tu64 = getDLLSym dll "testu64" testu64Spec
+  tu32 = getDLLSym dll "testu32" testu32Spec
+  tu16 = getDLLSym dll "testu16" testu16Spec
+  ti64 = getDLLSym dll "testi64" testi64Spec
+  ti32 = getDLLSym dll "testi32" testi32Spec
+  ti16 = getDLLSym dll "testi16" testi16Spec
+  td = getDLLSym dll "testd" testdSpec
+  tf = getDLLSym dll "testf" testfSpec
+  ( tu64 1 2, tu32 1 2, tu16 1 2
+  , ti64 +1 +2, ti32 +1 +2, ti16 +1 +2
+  , td 1.0 2.0, tf 1.0 2.0
+  )
 ```
 
 ``` ucm

unison-src/transcripts-manual/dll-ffi-unix.output.md

@@ -3,27 +3,60 @@ scratch/dll-ffi> builtins.mergeio
 ```
 
 ``` unison
-testSpec = arr int64 (base int64 int64)
+testu64Spec = arr uint64 (base uint64 uint64)
+testu32Spec = arr uint32 (base uint32 uint32)
+testu16Spec = arr uint16 (base uint16 uint16)
+testi64Spec = arr int64 (base int64 int64)
+testi32Spec = arr int32 (base int32 int32)
+testi16Spec = arr int16 (base int16 int16)
+testdSpec = arr double (base double double)
+testfSpec = arr float (base float float)
+
+
 libtest = do openDLL "unison-src/transcripts-manual/dll-ffi/libtest.so"
 
 doTest = do
   dll = libtest()
-  f = getDLLSym dll "test" testSpec
-  f +1 +2
+  tu64 = getDLLSym dll "testu64" testu64Spec
+  tu32 = getDLLSym dll "testu32" testu32Spec
+  tu16 = getDLLSym dll "testu16" testu16Spec
+  ti64 = getDLLSym dll "testi64" testi64Spec
+  ti32 = getDLLSym dll "testi32" testi32Spec
+  ti16 = getDLLSym dll "testi16" testi16Spec
+  td = getDLLSym dll "testd" testdSpec
+  tf = getDLLSym dll "testf" testfSpec
+  ( tu64 1 2, tu32 1 2, tu16 1 2
+  , ti64 +1 +2, ti32 +1 +2, ti16 +1 +2
+  , td 1.0 2.0, tf 1.0 2.0
+  )
 ```
 
 ``` ucm :added-by-ucm
   Loading changes detected in scratch.u.
 
-  + doTest   : '{IO, Exception} Int
-  + libtest  : '{IO, Exception} DLL
-  + testSpec : Spec (Int -> Int -> Int)
+  + doTest      : '{IO, Exception} ( Nat,
+                    Nat,
+                    Nat,
+                    Int,
+                    Int,
+                    Int,
+                    Float,
+                    Float)
+  + libtest     : '{IO, Exception} DLL
+  + testdSpec   : Spec (Float -> Float -> Float)
+  + testfSpec   : Spec (Float -> Float -> Float)
+  + testi16Spec : Spec (Int -> Int -> Int)
+  + testi32Spec : Spec (Int -> Int -> Int)
+  + testi64Spec : Spec (Int -> Int -> Int)
+  + testu16Spec : Spec (Nat -> Nat -> Nat)
+  + testu32Spec : Spec (Nat -> Nat -> Nat)
+  + testu64Spec : Spec (Nat -> Nat -> Nat)
 
   Run `update` to apply these changes to your codebase.
 ```
 
 ``` ucm
 scratch/dll-ffi> run doTest
 
-  +4
+  (4, 4, 4, +4, +4, +4, 4.0, 4.0)
 ```