Wasm implementations of hs_bswap and ntohs functions (#763)

.github/workflows/pipeline.yml

@@ -136,6 +136,8 @@ jobs:
 
           stack test asterius:argv --test-arguments="--backend=$ASTERIUS_BACKEND"
 
+          stack test asterius:endianness --test-arguments="--backend=$ASTERIUS_BACKEND"
+
   ghc-testsuite:
     name: ghc-testsuite
     needs: boot

asterius/package.yaml

@@ -40,6 +40,7 @@ extra-source-files:
   - test/time/**/*.hs
   - test/primitive/**/*.hs
   - test/argv/**/*.hs
+  - test/endianness/**/*.hs
 
 data-files:
   - cabal/**
@@ -346,3 +347,10 @@ tests:
     ghc-options: *exe-ghc-options
     dependencies:
       - asterius
+
+  endianness:
+    source-dirs: test
+    main: endianness.hs
+    ghc-options: *exe-ghc-options
+    dependencies:
+      - asterius

asterius/src/Asterius/Builtins.hs

@@ -21,6 +21,7 @@ where
 
 import Asterius.Builtins.Blackhole
 import Asterius.Builtins.CMath
+import Asterius.Builtins.Endianness
 import Asterius.Builtins.Env
 import Asterius.Builtins.Exports
 import Asterius.Builtins.Hashable
@@ -198,6 +199,7 @@ rtsAsteriusModule opts =
     <> timeCBits
     <> primitiveCBits
     <> mathCBits
+    <> endiannessCBits
 
 -- Generate the module consisting of functions which need to be wrapped
 -- for communication with the external runtime.

asterius/src/Asterius/Builtins/Endianness.hs

@@ -0,0 +1,110 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- |
+-- Module      :  Asterius.Builtins.Endianness
+-- Copyright   :  (c) 2018 EURL Tweag
+-- License     :  All rights reserved (see LICENCE file in the distribution).
+--
+-- Wasm implementations of byte-swapping functions (@hs_bswap16@, @hs_bswap32@,
+-- and @hs_bswap64@), and conversions between host (little-endian) and network
+-- (big-endian) byte order (@htonl@, @htons@, @ntohl@, and @ntohs@).
+module Asterius.Builtins.Endianness
+  ( endiannessCBits,
+  )
+where
+
+import Asterius.EDSL
+import Asterius.Types
+
+endiannessCBits :: AsteriusModule
+endiannessCBits =
+  hs_bswap16 <> hs_bswap32 <> hs_bswap64 <> htonl <> htons <> ntohl <> ntohs
+
+-- ----------------------------------------------------------------------------
+
+-- | @uint32_t htonl(uint32_t hostlong);@
+htonl :: AsteriusModule
+htonl = runEDSL "htonl" $ do
+  setReturnTypes [I64]
+  hostlong <- param I64
+  call' "hs_bswap32" [hostlong] I64 >>= emit
+
+-- | @uint16_t htons(uint16_t hostshort);@
+htons :: AsteriusModule
+htons = runEDSL "htons" $ do
+  setReturnTypes [I64]
+  hostshort <- param I64
+  call' "hs_bswap16" [hostshort] I64 >>= emit
+
+-- | @uint32_t ntohl(uint32_t netlong);@
+ntohl :: AsteriusModule
+ntohl = runEDSL "ntohl" $ do
+  setReturnTypes [I64]
+  netlong <- param I64
+  call' "hs_bswap32" [netlong] I64 >>= emit
+
+-- | @uint16_t ntohs(uint16_t netshort);@
+ntohs :: AsteriusModule
+ntohs = runEDSL "ntohs" $ do
+  setReturnTypes [I64]
+  netshort <- param I64
+  call' "hs_bswap16" [netshort] I64 >>= emit
+
+-- ----------------------------------------------------------------------------
+
+-- | @extern StgWord16 hs_bswap16(StgWord16 x);@
+hs_bswap16 :: AsteriusModule
+hs_bswap16 = runEDSL "hs_bswap16" $ do
+  setReturnTypes [I64]
+  x <- param I64
+  emit $ byteSwap16 x
+
+-- | @extern StgWord32 hs_bswap32(StgWord32 x);@
+hs_bswap32 :: AsteriusModule
+hs_bswap32 = runEDSL "hs_bswap32" $ do
+  setReturnTypes [I64]
+  x <- param I64
+  emit $ byteSwap32 x
+
+-- | @extern StgWord64 hs_bswap64(StgWord64 x);@
+hs_bswap64 :: AsteriusModule
+hs_bswap64 = runEDSL "hs_bswap64" $ do
+  setReturnTypes [I64]
+  x <- param I64
+  emit $ byteSwap64 x
+
+-- ----------------------------------------------------------------------------
+
+byteSwap16 :: Expression -> Expression
+byteSwap16 n = msb `orInt64` lsb
+  where
+    msb = (n `andInt64` constI64 0xFF) `shlInt64` constI64 8
+    lsb = (n `shrUInt64` constI64 8) `andInt64` constI64 0xFF
+
+byteSwap32 :: Expression -> Expression
+byteSwap32 n = byte1 `orInt64` byte2 `orInt64` byte3 `orInt64` byte4
+  where
+    byte1 = (n `andInt64` constI64 0xFF) `shlInt64` constI64 24
+    byte2 = (n `andInt64` constI64 0xFF00) `shlInt64` constI64 8
+    byte3 = (n `andInt64` constI64 0xFF0000) `shrUInt64` constI64 8
+    byte4 = (n `andInt64` constI64 0xFF000000) `shrUInt64` constI64 24
+
+byteSwap64 :: Expression -> Expression
+byteSwap64 n =
+  byte1
+    `orInt64` byte2
+    `orInt64` byte3
+    `orInt64` byte4
+    `orInt64` byte5
+    `orInt64` byte6
+    `orInt64` byte7
+    `orInt64` byte8
+  where
+    byte1 = (n `andInt64` constI64 0xFF) `shlInt64` constI64 56
+    byte2 = (n `andInt64` constI64 0xFF00) `shlInt64` constI64 40
+    byte3 = (n `andInt64` constI64 0xFF0000) `shlInt64` constI64 24
+    byte4 = (n `andInt64` constI64 0xFF000000) `shlInt64` constI64 8
+    byte5 = (n `andInt64` constI64 0xFF00000000) `shrUInt64` constI64 8
+    byte6 = (n `andInt64` constI64 0xFF0000000000) `shrUInt64` constI64 24
+    byte7 = (n `andInt64` constI64 0xFF000000000000) `shrUInt64` constI64 40
+    byte8 = (n `andInt64` constI64 0xFF00000000000000) `shrUInt64` constI64 56

asterius/src/Asterius/CodeGen.hs

@@ -406,6 +406,7 @@ marshalCmmHeteroConvMachOp o33 o36 o63 o66 tx32 ty32 tx64 ty64 w0 w1 x = do
 
 marshalCmmMachOp ::
   GHC.MachOp -> [GHC.CmmExpr] -> CodeGen (Expression, ValueType)
+-- Integer operations (insensitive to signed/unsigned)
 marshalCmmMachOp (GHC.MO_Add w) [x, y] =
   marshalCmmBinMachOp AddInt32 I32 I32 I32 AddInt64 I64 I64 I64 w x y
 marshalCmmMachOp (GHC.MO_Sub w) [x, y] =
@@ -416,6 +417,7 @@ marshalCmmMachOp (GHC.MO_Ne w) [x, y] =
   marshalCmmBinMachOp NeInt32 I32 I32 I32 NeInt64 I64 I64 I32 w x y
 marshalCmmMachOp (GHC.MO_Mul w) [x, y] =
   marshalCmmBinMachOp MulInt32 I32 I32 I32 MulInt64 I64 I64 I64 w x y
+-- Signed multiply/divide
 marshalCmmMachOp (GHC.MO_S_Quot w) [x, y] =
   marshalCmmBinMachOp DivSInt32 I32 I32 I32 DivSInt64 I64 I64 I64 w x y
 marshalCmmMachOp (GHC.MO_S_Rem w) [x, y] =
@@ -438,10 +440,12 @@ marshalCmmMachOp (GHC.MO_S_Neg w) [x] =
               I64
             )
       )
+-- Unsigned multiply/divide
 marshalCmmMachOp (GHC.MO_U_Quot w) [x, y] =
   marshalCmmBinMachOp DivUInt32 I32 I32 I32 DivUInt64 I64 I64 I64 w x y
 marshalCmmMachOp (GHC.MO_U_Rem w) [x, y] =
   marshalCmmBinMachOp RemUInt32 I32 I32 I32 RemUInt64 I64 I64 I64 w x y
+-- Signed comparisons
 marshalCmmMachOp (GHC.MO_S_Ge w) [x, y] =
   marshalCmmBinMachOp GeSInt32 I32 I32 I32 GeSInt64 I64 I64 I32 w x y
 marshalCmmMachOp (GHC.MO_S_Le w) [x, y] =
@@ -450,6 +454,7 @@ marshalCmmMachOp (GHC.MO_S_Gt w) [x, y] =
   marshalCmmBinMachOp GtSInt32 I32 I32 I32 GtSInt64 I64 I64 I32 w x y
 marshalCmmMachOp (GHC.MO_S_Lt w) [x, y] =
   marshalCmmBinMachOp LtSInt32 I32 I32 I32 LtSInt64 I64 I64 I32 w x y
+-- Unsigned comparisons
 marshalCmmMachOp (GHC.MO_U_Ge w) [x, y] =
   marshalCmmBinMachOp GeUInt32 I32 I32 I32 GeUInt64 I64 I64 I32 w x y
 marshalCmmMachOp (GHC.MO_U_Le w) [x, y] =
@@ -458,6 +463,7 @@ marshalCmmMachOp (GHC.MO_U_Gt w) [x, y] =
   marshalCmmBinMachOp GtUInt32 I32 I32 I32 GtUInt64 I64 I64 I32 w x y
 marshalCmmMachOp (GHC.MO_U_Lt w) [x, y] =
   marshalCmmBinMachOp LtUInt32 I32 I32 I32 LtUInt64 I64 I64 I32 w x y
+-- Floating point arithmetic
 marshalCmmMachOp (GHC.MO_F_Add w) [x, y] =
   marshalCmmBinMachOp AddFloat32 F32 F32 F32 AddFloat64 F64 F64 F64 w x y
 marshalCmmMachOp (GHC.MO_F_Sub w) [x, y] =
@@ -478,6 +484,7 @@ marshalCmmMachOp (GHC.MO_F_Mul w) [x, y] =
   marshalCmmBinMachOp MulFloat32 F32 F32 F32 MulFloat64 F64 F64 F64 w x y
 marshalCmmMachOp (GHC.MO_F_Quot w) [x, y] =
   marshalCmmBinMachOp DivFloat32 F32 F32 F32 DivFloat64 F64 F64 F64 w x y
+  -- Floating point comparison
 marshalCmmMachOp (GHC.MO_F_Eq w) [x, y] =
   marshalCmmBinMachOp EqFloat32 F32 F32 I32 EqFloat64 F64 F64 I32 w x y
 marshalCmmMachOp (GHC.MO_F_Ne w) [x, y] =
@@ -490,6 +497,8 @@ marshalCmmMachOp (GHC.MO_F_Gt w) [x, y] =
   marshalCmmBinMachOp GtFloat32 F32 F32 I32 GtFloat64 F64 F64 I32 w x y
 marshalCmmMachOp (GHC.MO_F_Lt w) [x, y] =
   marshalCmmBinMachOp LtFloat32 F32 F32 I32 LtFloat64 F64 F64 I32 w x y
+-- Bitwise operations. Not all of these may be supported at all sizes,
+-- and only integral Widths are valid.
 marshalCmmMachOp (GHC.MO_And w) [x, y] =
   marshalCmmBinMachOp AndInt32 I32 I32 I32 AndInt64 I64 I64 I64 w x y
 marshalCmmMachOp (GHC.MO_Or w) [x, y] =
@@ -528,6 +537,8 @@ marshalCmmMachOp (GHC.MO_U_Shr w) [x, y] =
   marshalCmmBinMachOp ShrUInt32 I32 I32 I32 ShrUInt64 I64 I64 I64 w x y
 marshalCmmMachOp (GHC.MO_S_Shr w) [x, y] =
   marshalCmmBinMachOp ShrSInt32 I32 I32 I32 ShrSInt64 I64 I64 I64 w x y
+-- Conversions. Some of these will be NOPs.
+-- Floating-point conversions use the signed variant.
 marshalCmmMachOp (GHC.MO_SF_Conv w0 w1) [x] =
   marshalCmmHeteroConvMachOp
     ConvertSInt32ToFloat32
@@ -560,6 +571,36 @@ marshalCmmMachOp (GHC.MO_UU_Conv w0 w1) [x] =
   marshalCmmHomoConvMachOp ExtendUInt32 WrapInt64 I32 I64 w0 w1 NoSext x
 marshalCmmMachOp (GHC.MO_FF_Conv w0 w1) [x] =
   marshalCmmHomoConvMachOp PromoteFloat32 DemoteFloat64 F32 F64 w0 w1 Sext x
+-- Unhandled cases
+--   -- Signed multiply/divide
+--   MO_S_MulMayOflo Width       -- nonzero if signed multiply overflows
+--   -- Unsigned multiply/divide
+--   MO_U_MulMayOflo Width       -- nonzero if unsigned multiply overflows
+--   -- Vector element insertion and extraction operations
+--   MO_V_Insert  Length Width   -- Insert scalar into vector
+--   MO_V_Extract Length Width   -- Extract scalar from vector
+--   -- Integer vector operations
+--   MO_V_Add Length Width
+--   MO_V_Sub Length Width
+--   MO_V_Mul Length Width
+--   -- Signed vector multiply/divide
+--   MO_VS_Quot Length Width
+--   MO_VS_Rem  Length Width
+--   MO_VS_Neg  Length Width
+--   -- Unsigned vector multiply/divide
+--   MO_VU_Quot Length Width
+--   MO_VU_Rem  Length Width
+--   -- Floting point vector element insertion and extraction operations
+--   MO_VF_Insert  Length Width   -- Insert scalar into vector
+--   MO_VF_Extract Length Width   -- Extract scalar from vector
+--   -- Floating point vector operations
+--   MO_VF_Add  Length Width
+--   MO_VF_Sub  Length Width
+--   MO_VF_Neg  Length Width      -- unary negation
+--   MO_VF_Mul  Length Width
+--   MO_VF_Quot Length Width
+--   -- Alignment check (for -falignment-sanitisation)
+--   MO_AlignmentCheck Int Width
 marshalCmmMachOp op xs =
   liftIO $ throwIO $ UnsupportedCmmExpr $ showBS $ GHC.CmmMachOp op xs
 
@@ -877,6 +918,8 @@ marshalCmmPrimCall (GHC.MO_PopCnt GHC.W8) [r] [x] = do
     I32
     x
     (extendSInt32 . popcntInt32 . andInt32 (constI32 0xFF))
+-- Unhandled: MO_Pdep Width
+-- Unhandled: MO_Pext Width
 marshalCmmPrimCall (GHC.MO_Clz GHC.W64) [r] [x] =
   marshalCmmUnPrimCall I64 r I64 x clzInt64
 marshalCmmPrimCall (GHC.MO_Clz GHC.W32) [r] [x] =
@@ -1199,6 +1242,46 @@ marshalCmmPrimCall (GHC.MO_U_QuotRem2 GHC.W64) [q, r] [lhsHi, lhsLo, rhs] = do
               }
         }
   pure [quotout, remout]
+-- Unhandled: MO_BSwap W8
+marshalCmmPrimCall (GHC.MO_BSwap GHC.W16) [r] [x] = do
+  lr <- marshalTypedCmmLocalReg r I64
+  xe <- marshalAndCastCmmExpr x I64
+  pure
+    [ UnresolvedSetLocal
+        { unresolvedLocalReg = lr,
+          value = Call
+            { target = "hs_bswap16",
+              operands = [xe],
+              callReturnTypes = [I64]
+            }
+        }
+    ]
+marshalCmmPrimCall (GHC.MO_BSwap GHC.W32) [r] [x] = do
+  lr <- marshalTypedCmmLocalReg r I64
+  xe <- marshalAndCastCmmExpr x I64
+  pure
+    [ UnresolvedSetLocal
+        { unresolvedLocalReg = lr,
+          value = Call
+            { target = "hs_bswap32",
+              operands = [xe],
+              callReturnTypes = [I64]
+            }
+        }
+    ]
+marshalCmmPrimCall (GHC.MO_BSwap GHC.W64) [r] [x] = do
+  lr <- marshalTypedCmmLocalReg r I64
+  xe <- marshalAndCastCmmExpr x I64
+  pure
+    [ UnresolvedSetLocal
+        { unresolvedLocalReg = lr,
+          value = Call
+            { target = "hs_bswap64",
+              operands = [xe],
+              callReturnTypes = [I64]
+            }
+        }
+    ]
 -- Atomic operations
 marshalCmmPrimCall (GHC.MO_AtomicRMW GHC.W64 amop) [dst] [addr, n] =
   marshalCmmAtomicMachOpPrimCall amop dst addr n

asterius/test/endianness.hs

@@ -0,0 +1,7 @@
+import System.Environment
+import System.Process
+
+main :: IO ()
+main = do
+  args <- getArgs
+  callProcess "ahc-link" $ ["--input-hs", "test/endianness/endianness.hs", "--run"] <> args

asterius/test/endianness/endianness.hs

@@ -0,0 +1,38 @@
+
+import Data.Word
+
+main :: IO ()
+main = do
+  do let x = 0xABCD
+     let y = 0xCDAB
+     putStr "ntohs: " >> print (ntohs x == y && x == ntohs y)
+  do let x = 0x56789ABC
+     let y = 0xBC9A7856
+     putStr "ntohl: " >> print (ntohl x == y && x == ntohl y)
+  do let x = 0xABCD
+     let y = 0xCDAB
+     putStr "htons: " >> print (htons x == y && x == htons y)
+  do let x = 0x56789ABC
+     let y = 0xBC9A7856
+     putStr "htonl: " >> print (htonl x == y && x == htonl y)
+  --
+  do let x = 0xABCD
+     let y = 0xCDAB
+     putStr "hs_bswap16: " >> print (hs_bswap16 x == y && x == hs_bswap16 y)
+  do let x = 0x56789ABC
+     let y = 0xBC9A7856
+     putStr "hs_bswap32: " >> print (hs_bswap32 x == y && x == hs_bswap32 y)
+
+  do let x = 0x0123456789ABCDEF
+     let y = 0xEFCDAB8967452301
+     putStr "hs_bswap64: " >> print (hs_bswap64 x == y && x == hs_bswap64 y)
+
+foreign import ccall safe "ntohs" ntohs :: Word16 -> Word16
+foreign import ccall safe "ntohl" ntohl :: Word32 -> Word32
+foreign import ccall safe "htons" htons :: Word16 -> Word16
+foreign import ccall safe "htonl" htonl :: Word32 -> Word32
+
+foreign import ccall safe "hs_bswap16" hs_bswap16 :: Word16 -> Word16
+foreign import ccall safe "hs_bswap32" hs_bswap32 :: Word32 -> Word32
+foreign import ccall safe "hs_bswap64" hs_bswap64 :: Word64 -> Word64
+