diff --git a/.github/workflows/pipeline.yml b/.github/workflows/pipeline.yml index 501009e4..040c9e36 100644 --- a/.github/workflows/pipeline.yml +++ b/.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 diff --git a/asterius/package.yaml b/asterius/package.yaml index 419c458d..a6e8d639 100644 --- a/asterius/package.yaml +++ b/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 diff --git a/asterius/src/Asterius/Builtins.hs b/asterius/src/Asterius/Builtins.hs index a79e9e4a..9844cb1c 100644 --- a/asterius/src/Asterius/Builtins.hs +++ b/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. diff --git a/asterius/src/Asterius/Builtins/Endianness.hs b/asterius/src/Asterius/Builtins/Endianness.hs new file mode 100644 index 00000000..d6d79c93 --- /dev/null +++ b/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 diff --git a/asterius/src/Asterius/CodeGen.hs b/asterius/src/Asterius/CodeGen.hs index 7d1cfb4b..8b83194a 100644 --- a/asterius/src/Asterius/CodeGen.hs +++ b/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 diff --git a/asterius/test/endianness.hs b/asterius/test/endianness.hs new file mode 100644 index 00000000..2bcc6aae --- /dev/null +++ b/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 diff --git a/asterius/test/endianness/endianness.hs b/asterius/test/endianness/endianness.hs new file mode 100644 index 00000000..4dccfad5 --- /dev/null +++ b/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 +