[Git][ghc/ghc][master] 4 commits: compiler: remove obsolete commented code in wasm NCG
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Sat Dec 17 13:06:59 UTC 2022
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
1f3abd85 by Cheng Shao at 2022-12-16T21:16:28+00:00
compiler: remove obsolete commented code in wasm NCG
It was just a temporary hack to workaround a bug in the relooper, that
bug has been fixed long before the wasm backend is merged.
- - - - -
e3104eab by Cheng Shao at 2022-12-16T21:16:28+00:00
compiler: add missing export list of GHC.CmmToAsm.Wasm.FromCmm
Also removes some unreachable code here.
- - - - -
1c6930bf by Cheng Shao at 2022-12-16T21:16:28+00:00
compiler: change fallback function signature to Cmm function signature in wasm NCG
In the wasm NCG, when handling a `CLabel` of undefined function
without knowing its function signature, we used to fallback to `() ->
()` which is accepted by `wasm-ld`. This patch changes it to the
signature of Cmm functions, which equally works, but would be required
when we emit tail call instructions.
- - - - -
8a81d9d9 by Cheng Shao at 2022-12-16T21:16:28+00:00
compiler: add optional tail-call support in wasm NCG
When the `-mtail-call` clang flag is passed at configure time, wasm
tail-call extension is enabled, and the wasm NCG will emit
`return_call`/`return_call_indirect` instructions to take advantage of
it and avoid the `StgRun` trampoline overhead.
Closes #22461.
- - - - -
8 changed files:
- compiler/GHC/CmmToAsm.hs
- compiler/GHC/CmmToAsm/Wasm.hs
- compiler/GHC/CmmToAsm/Wasm/Asm.hs
- compiler/GHC/CmmToAsm/Wasm/FromCmm.hs
- compiler/GHC/CmmToAsm/Wasm/Types.hs
- compiler/GHC/Driver/CodeOutput.hs
- compiler/GHC/Wasm/ControlFlow.hs
- compiler/GHC/Wasm/ControlFlow/FromCmm.hs
Changes:
=====================================
compiler/GHC/CmmToAsm.hs
=====================================
@@ -136,6 +136,7 @@ import GHC.Types.Unique.Set
import GHC.Unit
import GHC.Data.Stream (Stream)
import qualified GHC.Data.Stream as Stream
+import GHC.Settings
import Data.List (sortBy)
import Data.List.NonEmpty (groupAllWith, head)
@@ -146,10 +147,10 @@ import System.IO
import System.Directory ( getCurrentDirectory )
--------------------
-nativeCodeGen :: forall a . Logger -> NCGConfig -> ModLocation -> Handle -> UniqSupply
+nativeCodeGen :: forall a . Logger -> ToolSettings -> NCGConfig -> ModLocation -> Handle -> UniqSupply
-> Stream IO RawCmmGroup a
-> IO a
-nativeCodeGen logger config modLoc h us cmms
+nativeCodeGen logger ts config modLoc h us cmms
= let platform = ncgPlatform config
nCG' :: ( OutputableP Platform statics, Outputable jumpDest, Instruction instr)
=> NcgImpl statics instr jumpDest -> IO a
@@ -169,7 +170,7 @@ nativeCodeGen logger config modLoc h us cmms
ArchLoongArch64->panic "nativeCodeGen: No NCG for LoongArch64"
ArchUnknown -> panic "nativeCodeGen: No NCG for unknown arch"
ArchJavaScript-> panic "nativeCodeGen: No NCG for JavaScript"
- ArchWasm32 -> Wasm32.ncgWasm platform us modLoc h cmms
+ ArchWasm32 -> Wasm32.ncgWasm platform ts us modLoc h cmms
-- | Data accumulated during code generation. Mostly about statistics,
-- but also collects debug data for DWARF generation.
=====================================
compiler/GHC/CmmToAsm/Wasm.hs
=====================================
@@ -14,22 +14,28 @@ import GHC.CmmToAsm.Wasm.Types
import GHC.Data.Stream (Stream, StreamS (..), runStream)
import GHC.Platform
import GHC.Prelude
+import GHC.Settings
import GHC.Types.Unique.Supply
import GHC.Unit
+import GHC.Utils.CliOption
import System.IO
ncgWasm ::
Platform ->
+ ToolSettings ->
UniqSupply ->
ModLocation ->
Handle ->
Stream IO RawCmmGroup a ->
IO a
-ncgWasm platform us loc h cmms = do
+ncgWasm platform ts us loc h cmms = do
(r, s) <- streamCmmGroups platform us cmms
hPutBuilder h $ "# " <> string7 (fromJust $ ml_hs_file loc) <> "\n\n"
- hPutBuilder h $ execWasmAsmM $ asmTellEverything TagI32 s
+ hPutBuilder h $ execWasmAsmM do_tail_call $ asmTellEverything TagI32 s
pure r
+ where
+ -- See Note [WasmTailCall]
+ do_tail_call = doTailCall ts
streamCmmGroups ::
Platform ->
@@ -43,3 +49,8 @@ streamCmmGroups platform us cmms =
go s (Done r) = pure (r, s)
go s (Effect m) = m >>= go s
go s (Yield cmm k) = go (wasmExecM (onCmmGroup cmm) s) k
+
+doTailCall :: ToolSettings -> Bool
+doTailCall ts = Option "-mtail-call" `elem` as_args
+ where
+ (_, as_args) = toolSettings_pgm_a ts
=====================================
compiler/GHC/CmmToAsm/Wasm/Asm.hs
=====================================
@@ -1,5 +1,6 @@
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE GADTs #-}
+{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE Strict #-}
@@ -32,13 +33,13 @@ import GHC.Utils.Outputable hiding ((<>))
import GHC.Utils.Panic (panic)
-- | Reads current indentation, appends result to state
-newtype WasmAsmM a = WasmAsmM (Builder -> State Builder a)
+newtype WasmAsmM a = WasmAsmM (Bool -> Builder -> State Builder a)
deriving
( Functor,
Applicative,
Monad
)
- via (ReaderT Builder (State Builder))
+ via (ReaderT Bool (ReaderT Builder (State Builder)))
instance Semigroup a => Semigroup (WasmAsmM a) where
(<>) = liftA2 (<>)
@@ -46,27 +47,33 @@ instance Semigroup a => Semigroup (WasmAsmM a) where
instance Monoid a => Monoid (WasmAsmM a) where
mempty = pure mempty
+-- | To tail call or not, that is the question
+doTailCall :: WasmAsmM Bool
+doTailCall = WasmAsmM $ \do_tail_call _ -> pure do_tail_call
+
-- | Default indent level is none
-execWasmAsmM :: WasmAsmM a -> Builder
-execWasmAsmM (WasmAsmM m) = execState (m mempty) mempty
+execWasmAsmM :: Bool -> WasmAsmM a -> Builder
+execWasmAsmM do_tail_call (WasmAsmM m) =
+ execState (m do_tail_call mempty) mempty
-- | Increase indent level by a tab
asmWithTab :: WasmAsmM a -> WasmAsmM a
-asmWithTab (WasmAsmM m) = WasmAsmM $ \t -> m $! char7 '\t' <> t
+asmWithTab (WasmAsmM m) =
+ WasmAsmM $ \do_tail_call t -> m do_tail_call $! char7 '\t' <> t
-- | Writes a single line starting with the current indent
asmTellLine :: Builder -> WasmAsmM ()
-asmTellLine b = WasmAsmM $ \t -> modify $ \acc -> acc <> t <> b <> char7 '\n'
+asmTellLine b = WasmAsmM $ \_ t -> modify $ \acc -> acc <> t <> b <> char7 '\n'
-- | Writes a single line break
asmTellLF :: WasmAsmM ()
-asmTellLF = WasmAsmM $ \_ -> modify $ \acc -> acc <> char7 '\n'
+asmTellLF = WasmAsmM $ \_ _ -> modify $ \acc -> acc <> char7 '\n'
-- | Writes a line starting with a single tab, ignoring current indent
-- level
asmTellTabLine :: Builder -> WasmAsmM ()
asmTellTabLine b =
- WasmAsmM $ \_ -> modify $ \acc -> acc <> char7 '\t' <> b <> char7 '\n'
+ WasmAsmM $ \_ _ -> modify $ \acc -> acc <> char7 '\t' <> b <> char7 '\n'
asmFromWasmType :: WasmTypeTag t -> Builder
asmFromWasmType ty = case ty of
@@ -374,7 +381,6 @@ asmTellWasmControl ty_word c = case c of
WasmLoop bt c -> do
asmTellLine $ "loop" <> asmFromWasmBlockType ty_word bt
asmWithTab $ asmTellWasmControl ty_word c
- -- asmTellLine "br 0"
asmTellLine "end_loop"
WasmIfTop bt t f -> do
asmTellLine $ "if" <> asmFromWasmBlockType ty_word bt
@@ -387,7 +393,25 @@ asmTellWasmControl ty_word c = case c of
WasmBrTable (WasmExpr e) _ ts t -> do
asmTellWasmInstr ty_word e
asmTellLine $ "br_table {" <> builderCommas intDec (ts <> [t]) <> "}"
- WasmReturnTop _ -> asmTellLine "return"
+ -- See Note [WasmTailCall]
+ WasmTailCall (WasmExpr e) -> do
+ do_tail_call <- doTailCall
+ if
+ | do_tail_call,
+ WasmSymConst sym <- e ->
+ asmTellLine $ "return_call " <> asmFromSymName sym
+ | do_tail_call ->
+ do
+ asmTellWasmInstr ty_word e
+ asmTellLine $
+ "return_call_indirect "
+ <> asmFromFuncType
+ []
+ [SomeWasmType ty_word]
+ | otherwise ->
+ do
+ asmTellWasmInstr ty_word e
+ asmTellLine "return"
WasmActions (WasmStatements a) -> asmTellWasmInstr ty_word a
WasmSeq c0 c1 -> do
asmTellWasmControl ty_word c0
@@ -466,18 +490,20 @@ asmTellProducers = do
asmTellTargetFeatures :: WasmAsmM ()
asmTellTargetFeatures = do
+ do_tail_call <- doTailCall
asmTellSectionHeader ".custom_section.target_features"
asmTellVec
[ do
asmTellTabLine ".int8 0x2b"
asmTellBS feature
| feature <-
- [ "bulk-memory",
- "mutable-globals",
- "nontrapping-fptoint",
- "reference-types",
- "sign-ext"
- ]
+ ["tail-call" | do_tail_call]
+ <> [ "bulk-memory",
+ "mutable-globals",
+ "nontrapping-fptoint",
+ "reference-types",
+ "sign-ext"
+ ]
]
asmTellEverything :: WasmTypeTag w -> WasmCodeGenState w -> WasmAsmM ()
=====================================
compiler/GHC/CmmToAsm/Wasm/FromCmm.hs
=====================================
@@ -13,7 +13,13 @@
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
{-# HLINT ignore "Use camelCase" #-}
-module GHC.CmmToAsm.Wasm.FromCmm where
+module GHC.CmmToAsm.Wasm.FromCmm
+ ( alignmentFromWordType,
+ globalInfoFromCmmGlobalReg,
+ supportedCmmGlobalRegs,
+ onCmmGroup,
+ )
+where
import Control.Monad
import qualified Data.ByteString as BS
@@ -196,41 +202,6 @@ supportedCmmGlobalRegs =
<> [LongReg i | i <- [1 .. 1]]
<> [Sp, SpLim, Hp, HpLim, CCCS]
--- | Allocate a fresh symbol for an internal data section.
-allocDataSection :: DataSection -> WasmCodeGenM w SymName
-allocDataSection sec = do
- u <- wasmUniq
- let sym = fromString $ ".L" <> show u
- wasmModifyM $ \s ->
- s
- { dataSections =
- addToUniqMap (dataSections s) sym sec
- }
- pure sym
-
--- | Print a debug message to stderr by calling @fputs()@. We don't
--- bother to check @fputs()@ return value.
-wasmDebugMsg :: String -> WasmCodeGenM w (WasmStatements w)
-wasmDebugMsg msg = do
- ty_word_cmm <- wasmWordCmmTypeM
- sym_buf <-
- allocDataSection
- DataSection
- { dataSectionKind =
- SectionROData,
- dataSectionAlignment =
- mkAlignment 1,
- dataSectionContents =
- [DataASCII $ fromString $ msg <> "\NUL"]
- }
- onFuncSym "fputs" [ty_word_cmm, ty_word_cmm] [b32]
- pure $
- WasmStatements $
- WasmSymConst sym_buf
- `WasmConcat` WasmSymConst "__stderr_FILE"
- `WasmConcat` WasmCCall "fputs"
- `WasmConcat` WasmDrop
-
-- | Truncate a subword.
truncSubword :: Width -> WasmTypeTag t -> WasmExpr w t -> WasmExpr w t
truncSubword W8 ty (WasmExpr instr) =
@@ -1060,33 +1031,6 @@ lower_CMO_Un_Homo lbl op [reg] [x] = do
x_instr `WasmConcat` WasmCCall op `WasmConcat` WasmLocalSet ty ri
lower_CMO_Un_Homo _ _ _ _ = panic "lower_CMO_Un_Homo: unreachable"
--- | Lower an unary homogeneous 'CallishMachOp' to inline assembly.
-lower_CMO_Un_Prim ::
- CLabel ->
- (forall pre t. WasmTypeTag t -> WasmInstr w (t : pre) (t : pre)) ->
- [CmmFormal] ->
- [CmmActual] ->
- WasmCodeGenM w (WasmStatements w)
-lower_CMO_Un_Prim lbl op [reg] [x] = do
- (ri, SomeWasmType ty) <- onCmmLocalReg reg
- SomeWasmExpr ty_x (WasmExpr x_instr) <- lower_CmmExpr lbl x
- if
- | Just Refl <- ty `testEquality` ty_x ->
- pure $
- WasmStatements $
- x_instr `WasmConcat` op ty_x `WasmConcat` WasmLocalSet ty ri
- | TagI32 <- ty,
- TagI64 <-
- ty_x ->
- pure $
- WasmStatements $
- x_instr
- `WasmConcat` op ty_x
- `WasmConcat` WasmI32WrapI64
- `WasmConcat` WasmLocalSet ty ri
- | otherwise -> panic "lower_CMO_Un_Prim: unreachable"
-lower_CMO_Un_Prim _ _ _ _ = panic "lower_CMO_Un_Prim: unreachable"
-
-- | Lower a binary homogeneous 'CallishMachOp' to a ccall.
lower_CMO_Bin_Homo ::
CLabel ->
@@ -1573,8 +1517,10 @@ onFuncSym sym arg_tys ret_tys = wasmModifyM $
-- 'CmmStatic's or 'CmmExpr's.
onAnySym :: CLabel -> WasmCodeGenM w ()
onAnySym lbl = case sym_kind of
- SymFunc -> wasmModifyM $ \s at WasmCodeGenState {..} ->
- s {funcTypes = addToUniqMap_C const funcTypes sym ([], [])}
+ SymFunc -> do
+ ty_word <- wasmWordTypeM
+ wasmModifyM $ \s at WasmCodeGenState {..} ->
+ s {funcTypes = addToUniqMap_C const funcTypes sym ([], [SomeWasmType ty_word])}
_ -> pure ()
where
sym = symNameFromCLabel lbl
=====================================
compiler/GHC/CmmToAsm/Wasm/Types.hs
=====================================
@@ -352,9 +352,30 @@ data WasmControl :: Type -> Type -> [WasmType] -> [WasmType] -> Type where
WasmControl s e dropped destination
-- invariant: the table interval is contained
-- within [0 .. pred (length targets)]
- WasmReturnTop ::
- WasmTypeTag t ->
- WasmControl s e (t : t1star) t2star -- as per type system
+
+ -- Note [WasmTailCall]
+ -- ~~~~~~~~~~~~~~~~~~~
+ -- This represents the exit point of each CmmGraph: tail calling the
+ -- destination in CmmCall. The STG stack may grow before the call,
+ -- but it's always a tail call in the sense that the C call stack is
+ -- guaranteed not to grow.
+ --
+ -- In the wasm backend, WasmTailCall is lowered to different
+ -- assembly code given whether the wasm tail-call extension is
+ -- enabled:
+ --
+ -- When tail-call is not enabled (which is the default as of today),
+ -- a WasmTailCall is lowered to code that pushes the callee function
+ -- pointer onto the value stack and returns immediately. The actual
+ -- call is done by the trampoline in StgRun.
+ --
+ -- When tail-call is indeed enabled via passing -mtail-call in
+ -- CONF_CC_OPTS_STAGE2 at configure time, a WasmTailCall is lowered
+ -- to return_call/return_call_indirect, thus tail calling into its
+ -- callee without returning to StgRun.
+ WasmTailCall ::
+ e ->
+ WasmControl s e t1star t2star -- as per type system
WasmActions ::
s ->
WasmControl s e stack stack -- basic block: one entry, one exit
=====================================
compiler/GHC/Driver/CodeOutput.hs
=====================================
@@ -201,7 +201,7 @@ outputAsm logger dflags this_mod location filenm cmm_stream = do
let ncg_config = initNCGConfig dflags this_mod
{-# SCC "OutputAsm" #-} doOutput filenm $
\h -> {-# SCC "NativeCodeGen" #-}
- nativeCodeGen logger ncg_config location h ncg_uniqs cmm_stream
+ nativeCodeGen logger (toolSettings dflags) ncg_config location h ncg_uniqs cmm_stream
{-
************************************************************************
@@ -397,4 +397,3 @@ ipInitCode do_info_table platform this_mod
ipe_buffer_decl =
text "extern IpeBufferListNode" <+> ipe_buffer_label <> text ";"
-
=====================================
compiler/GHC/Wasm/ControlFlow.hs
=====================================
@@ -1,10 +1,10 @@
{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE DataKinds, GADTs, RankNTypes, TypeOperators, KindSignatures #-}
+{-# LANGUAGE DataKinds, GADTs, RankNTypes, KindSignatures #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE PatternSynonyms #-}
module GHC.Wasm.ControlFlow
- ( WasmControl(..), (<>), pattern WasmIf, wasmReturn
+ ( WasmControl(..), (<>), pattern WasmIf
, BrTableInterval(..), inclusiveInterval
, WasmType, WasmTypeTag(..)
@@ -47,7 +47,3 @@ pattern WasmIf :: WasmFunctionType pre post
pattern WasmIf ty e t f =
WasmPush TagI32 e `WasmSeq` WasmIfTop ty t f
-
--- More syntactic sugar.
-wasmReturn :: WasmTypeTag t -> e -> WasmControl s e (t ': t1star) t2star
-wasmReturn tag e = WasmPush tag e `WasmSeq` WasmReturnTop tag
=====================================
compiler/GHC/Wasm/ControlFlow/FromCmm.hs
=====================================
@@ -198,7 +198,7 @@ structuredControl platform txExpr txBlock g =
<$> txExpr xlabel e
<*> doBranch fty xlabel t (IfThenElse maybeMarks `inside` context)
<*> doBranch fty xlabel f (IfThenElse maybeMarks `inside` context)
- TailCall e -> (WasmPush TagI32 <$> txExpr xlabel e) <<>> pure (WasmReturnTop TagI32)
+ TailCall e -> WasmTailCall <$> txExpr xlabel e
Switch e range targets default' ->
WasmBrTable <$> txExpr xlabel e
<$~> range
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ef9ac9d2bcf8286024b6a007d5d46e49a314e9af...8a81d9d933089b6ed72478342a0070d7c8f82ff8
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ef9ac9d2bcf8286024b6a007d5d46e49a314e9af...8a81d9d933089b6ed72478342a0070d7c8f82ff8
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20221217/f458873d/attachment-0001.html>
More information about the ghc-commits
mailing list