[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 3 commits: rts: Don't hint inlining of appendToRunQueue
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Wed Oct 12 14:10:32 UTC 2022
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
481467a5 by Ben Gamari at 2022-10-12T08:08:37-04:00
rts: Don't hint inlining of appendToRunQueue
These hints have resulted in compile-time warnings due to failed
inlinings for quite some time. Moreover, it's quite unlikely that
inlining them is all that beneficial given that they are rather sizeable
functions.
Resolves #22280.
- - - - -
f1636285 by Curran McConnell at 2022-10-12T10:10:09-04:00
remove name shadowing
- - - - -
f3799362 by Charles Taylor at 2022-10-12T10:10:13-04:00
Unrestricted OverloadedLabels (#11671)
Implements GHC proposal:
https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0170-unrestricted-overloadedlabels.rst
- - - - -
8 changed files:
- compiler/GHC/Parser/Lexer.x
- docs/users_guide/9.6.1-notes.rst
- ghc/GHCi/UI/Monad.hs
- rts/Schedule.c
- rts/Schedule.h
- + testsuite/tests/overloadedrecflds/should_run/T11671_run.hs
- + testsuite/tests/overloadedrecflds/should_run/T11671_run.stdout
- testsuite/tests/overloadedrecflds/should_run/all.T
Changes:
=====================================
compiler/GHC/Parser/Lexer.x
=====================================
@@ -163,6 +163,7 @@ $small = [$ascsmall $unismall \_]
$uniidchar = \x07 -- Trick Alex into handling Unicode. See Note [Unicode in Alex].
$idchar = [$small $large $digit $uniidchar \']
+$labelchar = [$small $large $digit $uniidchar \' \.]
$unigraphic = \x06 -- Trick Alex into handling Unicode. See Note [Unicode in Alex].
$graphic = [$small $large $symbol $digit $idchar $special $unigraphic \"\']
@@ -451,7 +452,8 @@ $tab { warnTab }
}
<0> {
- "#" @varid / { ifExtension OverloadedLabelsBit } { skip_one_varid ITlabelvarid }
+ "#" $labelchar+ / { ifExtension OverloadedLabelsBit } { skip_one_varid ITlabelvarid }
+ "#" \" / { ifExtension OverloadedLabelsBit } { lex_quoted_label }
}
<0> {
@@ -2023,46 +2025,64 @@ lex_string_prag_comment mkTok span _buf _len _buf2
lex_string_tok :: Action
lex_string_tok span buf _len _buf2 = do
- tok <- lex_string ""
+ lexed <- lex_string
(AI end bufEnd) <- getInput
let
- tok' = case tok of
- ITprimstring _ bs -> ITprimstring (SourceText src) bs
- ITstring _ s -> ITstring (SourceText src) s
- _ -> panic "lex_string_tok"
+ tok = case lexed of
+ LexedPrimString s -> ITprimstring (SourceText src) (unsafeMkByteString s)
+ LexedRegularString s -> ITstring (SourceText src) (mkFastString s)
src = lexemeToString buf (cur bufEnd - cur buf)
- return (L (mkPsSpan (psSpanStart span) end) tok')
+ return $ L (mkPsSpan (psSpanStart span) end) tok
-lex_string :: String -> P Token
-lex_string s = do
+
+lex_quoted_label :: Action
+lex_quoted_label span _buf _len _buf2 = do
+ s <- lex_string_helper ""
+ (AI end _) <- getInput
+ let
+ token = ITlabelvarid (mkFastString s)
+ start = psSpanStart span
+
+ return $ L (mkPsSpan start end) token
+
+
+data LexedString = LexedRegularString String | LexedPrimString String
+
+lex_string :: P LexedString
+lex_string = do
+ s <- lex_string_helper ""
+ magicHash <- getBit MagicHashBit
+ if magicHash
+ then do
+ i <- getInput
+ case alexGetChar' i of
+ Just ('#',i) -> do
+ setInput i
+ when (any (> '\xFF') s) $ do
+ pState <- getPState
+ let msg = PsErrPrimStringInvalidChar
+ let err = mkPlainErrorMsgEnvelope (mkSrcSpanPs (last_loc pState)) msg
+ addError err
+ return $ LexedPrimString s
+ _other ->
+ return $ LexedRegularString s
+ else
+ return $ LexedRegularString s
+
+
+lex_string_helper :: String -> P String
+lex_string_helper s = do
i <- getInput
case alexGetChar' i of
Nothing -> lit_error i
Just ('"',i) -> do
- setInput i
- let s' = reverse s
- magicHash <- getBit MagicHashBit
- if magicHash
- then do
- i <- getInput
- case alexGetChar' i of
- Just ('#',i) -> do
- setInput i
- when (any (> '\xFF') s') $ do
- pState <- getPState
- let msg = PsErrPrimStringInvalidChar
- let err = mkPlainErrorMsgEnvelope (mkSrcSpanPs (last_loc pState)) msg
- addError err
- return (ITprimstring (SourceText s') (unsafeMkByteString s'))
- _other ->
- return (ITstring (SourceText s') (mkFastString s'))
- else
- return (ITstring (SourceText s') (mkFastString s'))
+ setInput i
+ return (reverse s)
Just ('\\',i)
| Just ('&',i) <- next -> do
- setInput i; lex_string s
+ setInput i; lex_string_helper s
| Just (c,i) <- next, c <= '\x7f' && is_space c -> do
-- is_space only works for <= '\x7f' (#3751, #5425)
setInput i; lex_stringgap s
@@ -2070,16 +2090,17 @@ lex_string s = do
Just (c, i1) -> do
case c of
- '\\' -> do setInput i1; c' <- lex_escape; lex_string (c':s)
- c | isAny c -> do setInput i1; lex_string (c:s)
+ '\\' -> do setInput i1; c' <- lex_escape; lex_string_helper (c':s)
+ c | isAny c -> do setInput i1; lex_string_helper (c:s)
_other -> lit_error i
-lex_stringgap :: String -> P Token
+
+lex_stringgap :: String -> P String
lex_stringgap s = do
i <- getInput
c <- getCharOrFail i
case c of
- '\\' -> lex_string s
+ '\\' -> lex_string_helper s
c | c <= '\x7f' && is_space c -> lex_stringgap s
-- is_space only works for <= '\x7f' (#3751, #5425)
_other -> lit_error i
=====================================
docs/users_guide/9.6.1-notes.rst
=====================================
@@ -78,6 +78,15 @@ Language
Then GHC will use the second quantified constraint to solve ``C a b Int``,
as it has a strictly weaker precondition.
+- GHC proposal `#170 Unrestricted OverloadedLabels
+ <https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0170-unrestricted-overloadedlabels.rst>`_
+ has been implemented.
+ This extends the variety syntax for constructing labels under :extension:`OverloadedLabels`.
+ Examples of newly allowed syntax:
+ - Leading capital letters: `#Foo` equivalant to `getLabel @"Foo"`
+ - Numeric characters: `#3.14` equivalent to `getLabel @"3.14"`
+ - Arbitrary strings: `#"Hello, World!"` equivalent to `getLabel @"Hello, World!"`
+
Compiler
~~~~~~~~
=====================================
ghc/GHCi/UI/Monad.hs
=====================================
@@ -1,6 +1,5 @@
{-# LANGUAGE FlexibleInstances, DeriveFunctor, DerivingVia #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-{-# OPTIONS -fno-warn-name-shadowing #-}
-----------------------------------------------------------------------------
--
@@ -474,10 +473,10 @@ printStats dflags ActionStats{actionAllocs = mallocs, actionElapsedTime = secs}
Just allocs ->
text (separateThousands allocs) <+> text "bytes")))
where
- separateThousands n = reverse . sep . reverse . show $ n
- where sep n'
+ separateThousands n = reverse . separate . reverse . show $ n
+ where separate n'
| n' `lengthAtMost` 3 = n'
- | otherwise = take 3 n' ++ "," ++ sep (drop 3 n')
+ | otherwise = take 3 n' ++ "," ++ separate (drop 3 n')
-----------------------------------------------------------------------------
-- reverting CAFs
@@ -526,13 +525,13 @@ turnOffBuffering_ fhv = do
liftIO $ evalIO interp fhv
mkEvalWrapper :: GhcMonad m => String -> [String] -> m ForeignHValue
-mkEvalWrapper progname args =
+mkEvalWrapper progname' args' =
runInternal $ GHC.compileParsedExprRemote
- $ evalWrapper `GHC.mkHsApp` nlHsString progname
- `GHC.mkHsApp` nlList (map nlHsString args)
+ $ evalWrapper' `GHC.mkHsApp` nlHsString progname'
+ `GHC.mkHsApp` nlList (map nlHsString args')
where
nlHsString = nlHsLit . mkHsString
- evalWrapper =
+ evalWrapper' =
GHC.nlHsVar $ RdrName.mkOrig gHC_GHCI_HELPERS (mkVarOcc "evalWrapper")
-- | Run a 'GhcMonad' action to compile an expression for internal usage.
=====================================
rts/Schedule.c
=====================================
@@ -2915,6 +2915,61 @@ deleteThread_(StgTSO *tso)
}
#endif
+/*
+ * Run queue manipulation
+ */
+
+void
+appendToRunQueue (Capability *cap, StgTSO *tso)
+{
+ ASSERT(tso->_link == END_TSO_QUEUE);
+ if (cap->run_queue_hd == END_TSO_QUEUE) {
+ cap->run_queue_hd = tso;
+ tso->block_info.prev = END_TSO_QUEUE;
+ } else {
+ setTSOLink(cap, cap->run_queue_tl, tso);
+ setTSOPrev(cap, tso, cap->run_queue_tl);
+ }
+ cap->run_queue_tl = tso;
+ cap->n_run_queue++;
+}
+
+void
+pushOnRunQueue (Capability *cap, StgTSO *tso)
+{
+ setTSOLink(cap, tso, cap->run_queue_hd);
+ tso->block_info.prev = END_TSO_QUEUE;
+ if (cap->run_queue_hd != END_TSO_QUEUE) {
+ setTSOPrev(cap, cap->run_queue_hd, tso);
+ }
+ cap->run_queue_hd = tso;
+ if (cap->run_queue_tl == END_TSO_QUEUE) {
+ cap->run_queue_tl = tso;
+ }
+ cap->n_run_queue++;
+}
+
+StgTSO *popRunQueue (Capability *cap)
+{
+ ASSERT(cap->n_run_queue > 0);
+ StgTSO *t = cap->run_queue_hd;
+ ASSERT(t != END_TSO_QUEUE);
+ cap->run_queue_hd = t->_link;
+
+ StgTSO *link = RELAXED_LOAD(&t->_link);
+ if (link != END_TSO_QUEUE) {
+ link->block_info.prev = END_TSO_QUEUE;
+ }
+ RELAXED_STORE(&t->_link, END_TSO_QUEUE); // no write barrier req'd
+
+ if (cap->run_queue_hd == END_TSO_QUEUE) {
+ cap->run_queue_tl = END_TSO_QUEUE;
+ }
+ cap->n_run_queue--;
+ return t;
+}
+
+
/* -----------------------------------------------------------------------------
raiseExceptionHelper
=====================================
rts/Schedule.h
=====================================
@@ -136,67 +136,16 @@ void resurrectThreads (StgTSO *);
* NOTE: tso->link should be END_TSO_QUEUE before calling this macro.
* ASSUMES: cap->running_task is the current task.
*/
-EXTERN_INLINE void
-appendToRunQueue (Capability *cap, StgTSO *tso);
-
-EXTERN_INLINE void
-appendToRunQueue (Capability *cap, StgTSO *tso)
-{
- ASSERT(tso->_link == END_TSO_QUEUE);
- if (cap->run_queue_hd == END_TSO_QUEUE) {
- cap->run_queue_hd = tso;
- tso->block_info.prev = END_TSO_QUEUE;
- } else {
- setTSOLink(cap, cap->run_queue_tl, tso);
- setTSOPrev(cap, tso, cap->run_queue_tl);
- }
- cap->run_queue_tl = tso;
- cap->n_run_queue++;
-}
+void appendToRunQueue (Capability *cap, StgTSO *tso);
/* Push a thread on the beginning of the run queue.
* ASSUMES: cap->running_task is the current task.
*/
-EXTERN_INLINE void
-pushOnRunQueue (Capability *cap, StgTSO *tso);
-
-EXTERN_INLINE void
-pushOnRunQueue (Capability *cap, StgTSO *tso)
-{
- setTSOLink(cap, tso, cap->run_queue_hd);
- tso->block_info.prev = END_TSO_QUEUE;
- if (cap->run_queue_hd != END_TSO_QUEUE) {
- setTSOPrev(cap, cap->run_queue_hd, tso);
- }
- cap->run_queue_hd = tso;
- if (cap->run_queue_tl == END_TSO_QUEUE) {
- cap->run_queue_tl = tso;
- }
- cap->n_run_queue++;
-}
+void pushOnRunQueue (Capability *cap, StgTSO *tso);
/* Pop the first thread off the runnable queue.
*/
-INLINE_HEADER StgTSO *
-popRunQueue (Capability *cap)
-{
- ASSERT(cap->n_run_queue > 0);
- StgTSO *t = cap->run_queue_hd;
- ASSERT(t != END_TSO_QUEUE);
- cap->run_queue_hd = t->_link;
-
- StgTSO *link = RELAXED_LOAD(&t->_link);
- if (link != END_TSO_QUEUE) {
- link->block_info.prev = END_TSO_QUEUE;
- }
- RELAXED_STORE(&t->_link, END_TSO_QUEUE); // no write barrier req'd
-
- if (cap->run_queue_hd == END_TSO_QUEUE) {
- cap->run_queue_tl = END_TSO_QUEUE;
- }
- cap->n_run_queue--;
- return t;
-}
+StgTSO *popRunQueue (Capability *cap);
INLINE_HEADER StgTSO *
peekRunQueue (Capability *cap)
=====================================
testsuite/tests/overloadedrecflds/should_run/T11671_run.hs
=====================================
@@ -0,0 +1,47 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedLabels #-}
+{-# LANGUAGE MagicHash #-}
+
+import Data.Foldable (traverse_)
+import Data.Proxy (Proxy(..))
+import GHC.OverloadedLabels (IsLabel(..))
+import GHC.TypeLits (KnownSymbol, symbolVal)
+import GHC.Prim (Addr#)
+
+instance KnownSymbol symbol => IsLabel symbol String where
+ fromLabel = symbolVal (Proxy :: Proxy symbol)
+
+(#) :: String -> Int -> String
+(#) _ i = show i
+
+f :: Addr# -> Int -> String
+f _ i = show i
+
+main :: IO ()
+main = traverse_ putStrLn
+ [ #a
+ , #number17
+ , #do
+ , #type
+ , #Foo
+ , #3
+ , #199.4
+ , #17a23b
+ , #f'a'
+ , #'a'
+ , #'
+ , #''notTHSplice
+ , #...
+ , #привет
+ , #こんにちは
+ , #"3"
+ , #":"
+ , #"Foo"
+ , #"The quick brown fox"
+ , #"\""
+ , (++) #hello#world
+ , (++) #"hello"#"world"
+ , #"hello"# 1 -- equivalent to `(fromLabel @"hello") # 1`
+ , f "hello"#2 -- equivalent to `f ("hello"# :: Addr#) 2`
+ ]
=====================================
testsuite/tests/overloadedrecflds/should_run/T11671_run.stdout
=====================================
@@ -0,0 +1,24 @@
+a
+number17
+do
+type
+Foo
+3
+199.4
+17a23b
+f'a'
+'a'
+'
+''notTHSplice
+...
+привет
+こんにちは
+3
+:
+Foo
+The quick brown fox
+"
+helloworld
+helloworld
+1
+2
=====================================
testsuite/tests/overloadedrecflds/should_run/all.T
=====================================
@@ -17,3 +17,4 @@ test('hasfieldrun01', normal, compile_and_run, [''])
test('hasfieldrun02', normal, compile_and_run, [''])
test('T12243', normal, compile_and_run, [''])
test('T11228', normal, compile_and_run, [''])
+test('T11671_run', normal, compile_and_run, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8b4b224a3770669e1c49f7425283322bfaa11332...f3799362d9a5582ea433f7be582efe6d04d2369e
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8b4b224a3770669e1c49f7425283322bfaa11332...f3799362d9a5582ea433f7be582efe6d04d2369e
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/20221012/9e46c62d/attachment-0001.html>
More information about the ghc-commits
mailing list