diff options
author | Cheng Shao <terrorjack@type.dance> | 2023-01-28 17:56:13 +0000 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2023-01-28 17:16:48 -0500 |
commit | 78c07219d5dad9730bbe3ec26ad22912ff22f058 (patch) | |
tree | 8ba9088dcbe546da1c77f8e50718550f52ab1f9d /compiler/GHC/CmmToAsm/Wasm/FromCmm.hs | |
parent | 2b62739d7e6cc65f444029f252578f2dddb95ce3 (diff) | |
download | haskell-78c07219d5dad9730bbe3ec26ad22912ff22f058.tar.gz |
compiler: properly handle ForeignHints in the wasm NCG
Properly handle ForeignHints of ccall arguments/return value, insert
sign extends and truncations when handling signed subwords. Fixes #22852.
Diffstat (limited to 'compiler/GHC/CmmToAsm/Wasm/FromCmm.hs')
-rw-r--r-- | compiler/GHC/CmmToAsm/Wasm/FromCmm.hs | 65 |
1 files changed, 52 insertions, 13 deletions
diff --git a/compiler/GHC/CmmToAsm/Wasm/FromCmm.hs b/compiler/GHC/CmmToAsm/Wasm/FromCmm.hs index c07399836a..52cba6f0a8 100644 --- a/compiler/GHC/CmmToAsm/Wasm/FromCmm.hs +++ b/compiler/GHC/CmmToAsm/Wasm/FromCmm.hs @@ -7,6 +7,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE Strict #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE UndecidableInstances #-} @@ -1203,6 +1204,7 @@ lower_CallishMachOp lbl (MO_Memcmp {}) rs xs = lower_CmmUnsafeForeignCall lbl (Left "memcmp") + Nothing CmmMayReturn rs xs @@ -1210,6 +1212,7 @@ lower_CallishMachOp lbl (MO_PopCnt w0) rs xs = lower_CmmUnsafeForeignCall lbl (Left $ fromString $ "hs_popcnt" <> show (widthInBits w0)) + Nothing CmmMayReturn rs xs @@ -1217,6 +1220,7 @@ lower_CallishMachOp lbl (MO_Pdep w0) rs xs = lower_CmmUnsafeForeignCall lbl (Left $ fromString $ "hs_pdep" <> show (widthInBits w0)) + Nothing CmmMayReturn rs xs @@ -1224,6 +1228,7 @@ lower_CallishMachOp lbl (MO_Pext w0) rs xs = lower_CmmUnsafeForeignCall lbl (Left $ fromString $ "hs_pext" <> show (widthInBits w0)) + Nothing CmmMayReturn rs xs @@ -1231,6 +1236,7 @@ lower_CallishMachOp lbl (MO_Clz w0) rs xs = lower_CmmUnsafeForeignCall lbl (Left $ fromString $ "hs_clz" <> show (widthInBits w0)) + Nothing CmmMayReturn rs xs @@ -1238,6 +1244,7 @@ lower_CallishMachOp lbl (MO_Ctz w0) rs xs = lower_CmmUnsafeForeignCall lbl (Left $ fromString $ "hs_ctz" <> show (widthInBits w0)) + Nothing CmmMayReturn rs xs @@ -1245,6 +1252,7 @@ lower_CallishMachOp lbl (MO_BSwap w0) rs xs = lower_CmmUnsafeForeignCall lbl (Left $ fromString $ "hs_bswap" <> show (widthInBits w0)) + Nothing CmmMayReturn rs xs @@ -1252,6 +1260,7 @@ lower_CallishMachOp lbl (MO_BRev w0) rs xs = lower_CmmUnsafeForeignCall lbl (Left $ fromString $ "hs_bitrev" <> show (widthInBits w0)) + Nothing CmmMayReturn rs xs @@ -1270,6 +1279,7 @@ lower_CallishMachOp lbl (MO_AtomicRMW w0 op) rs xs = ) <> show (widthInBits w0) ) + Nothing CmmMayReturn rs xs @@ -1289,6 +1299,7 @@ lower_CallishMachOp lbl (MO_Xchg w0) rs xs = lower_CmmUnsafeForeignCall lbl (Left $ fromString $ "hs_xchg" <> show (widthInBits w0)) + Nothing CmmMayReturn rs xs @@ -1296,6 +1307,7 @@ lower_CallishMachOp lbl MO_SuspendThread rs xs = lower_CmmUnsafeForeignCall lbl (Left "suspendThread") + Nothing CmmMayReturn rs xs @@ -1303,6 +1315,7 @@ lower_CallishMachOp lbl MO_ResumeThread rs xs = lower_CmmUnsafeForeignCall lbl (Left "resumeThread") + Nothing CmmMayReturn rs xs @@ -1324,6 +1337,7 @@ lower_CmmUnsafeForeignCall_Drop lbl sym_callee ret_cmm_ty arg_exprs = do lower_CmmUnsafeForeignCall lbl (Left sym_callee) + Nothing CmmMayReturn [ret_local] arg_exprs @@ -1335,34 +1349,52 @@ lower_CmmUnsafeForeignCall_Drop lbl sym_callee ret_cmm_ty arg_exprs = do lower_CmmUnsafeForeignCall :: CLabel -> (Either SymName CmmExpr) -> + Maybe + ([ForeignHint], [ForeignHint]) -> CmmReturnInfo -> [CmmFormal] -> [CmmActual] -> - WasmCodeGenM - w - (WasmStatements w) -lower_CmmUnsafeForeignCall lbl target ret_info ret_locals arg_exprs = do + WasmCodeGenM w (WasmStatements w) +lower_CmmUnsafeForeignCall lbl target mb_hints ret_info ret_locals arg_exprs = do + platform <- wasmPlatformM SomeWasmPreCCall arg_tys args_instr <- foldrM - ( \arg_expr (SomeWasmPreCCall acc_tys acc_instr) -> do - SomeWasmExpr arg_ty (WasmExpr arg_instr) <- - lower_CmmExpr lbl arg_expr + ( \(arg_expr, arg_hint) (SomeWasmPreCCall acc_tys acc_instr) -> do + SomeWasmExpr arg_ty arg_wasm_expr <- lower_CmmExpr lbl arg_expr + let WasmExpr arg_instr = case arg_hint of + SignedHint -> + extendSubword + (cmmExprWidth platform arg_expr) + arg_ty + arg_wasm_expr + _ -> arg_wasm_expr pure $ SomeWasmPreCCall (arg_ty `TypeListCons` acc_tys) $ arg_instr `WasmConcat` acc_instr ) (SomeWasmPreCCall TypeListNil WasmNop) - arg_exprs + arg_exprs_hints SomeWasmPostCCall ret_tys ret_instr <- foldrM - ( \reg (SomeWasmPostCCall acc_tys acc_instr) -> do + ( \(reg, ret_hint) (SomeWasmPostCCall acc_tys acc_instr) -> do (reg_i, SomeWasmType reg_ty) <- onCmmLocalReg reg pure $ SomeWasmPostCCall (reg_ty `TypeListCons` acc_tys) $ - acc_instr `WasmConcat` WasmLocalSet reg_ty reg_i + case (# ret_hint, cmmRegWidth platform $ CmmLocal reg #) of + (# SignedHint, W8 #) -> + acc_instr + `WasmConcat` WasmConst reg_ty 0xFF + `WasmConcat` WasmAnd reg_ty + `WasmConcat` WasmLocalSet reg_ty reg_i + (# SignedHint, W16 #) -> + acc_instr + `WasmConcat` WasmConst reg_ty 0xFFFF + `WasmConcat` WasmAnd reg_ty + `WasmConcat` WasmLocalSet reg_ty reg_i + _ -> acc_instr `WasmConcat` WasmLocalSet reg_ty reg_i ) (SomeWasmPostCCall TypeListNil WasmNop) - ret_locals + ret_locals_hints case target of Left sym_callee -> do platform <- wasmPlatformM @@ -1388,6 +1420,11 @@ lower_CmmUnsafeForeignCall lbl target ret_info ret_locals arg_exprs = do CmmMayReturn -> ret_instr CmmNeverReturns -> WasmUnreachable ) + where + (# arg_exprs_hints, ret_locals_hints #) = case mb_hints of + Just (arg_hints, ret_hints) -> + (# zip arg_exprs arg_hints, zip ret_locals ret_hints #) + _ -> (# map (,NoHint) arg_exprs, map (,NoHint) ret_locals #) -- | Lower a 'CmmStore'. lower_CmmStore :: @@ -1443,7 +1480,7 @@ lower_CmmAction lbl act = do CmmUnsafeForeignCall ( ForeignTarget (CmmLit (CmmLabel lbl_callee)) - (ForeignConvention conv _ _ ret_info) + (ForeignConvention conv arg_hints ret_hints ret_info) ) ret_locals arg_exprs @@ -1451,17 +1488,19 @@ lower_CmmAction lbl act = do lower_CmmUnsafeForeignCall lbl (Left $ symNameFromCLabel lbl_callee) + (Just (arg_hints, ret_hints)) ret_info ret_locals arg_exprs CmmUnsafeForeignCall - (ForeignTarget target_expr (ForeignConvention conv _ _ ret_info)) + (ForeignTarget target_expr (ForeignConvention conv arg_hints ret_hints ret_info)) ret_locals arg_exprs | conv `elem` [CCallConv, CApiConv] -> lower_CmmUnsafeForeignCall lbl (Right target_expr) + (Just (arg_hints, ret_hints)) ret_info ret_locals arg_exprs |