[Git][ghc/ghc][master] Misc cleanup
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Mon Apr 17 22:44:26 UTC 2023
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
10364818 by Krzysztof Gogolewski at 2023-04-17T18:44:03-04:00
Misc cleanup
- Use dedicated list functions
- Make cloneBndrs and cloneRecIdBndrs monadic
- Fix invalid haddock comments in libraries/base
- - - - -
13 changed files:
- compiler/GHC/CmmToAsm/X86/CodeGen.hs
- compiler/GHC/Core/Make.hs
- compiler/GHC/Core/Opt/SetLevels.hs
- compiler/GHC/Core/Opt/Specialise.hs
- compiler/GHC/Core/Opt/WorkWrap/Utils.hs
- compiler/GHC/Core/Subst.hs
- compiler/GHC/StgToJS/Linker/Utils.hs
- libraries/base/GHC/Event/Manager.hs
- libraries/base/GHC/Event/TimerManager.hs
- libraries/base/GHC/Fingerprint.hs
- libraries/base/GHC/Fingerprint/Type.hs
- libraries/base/GHC/IO/Encoding/Types.hs
- utils/deriveConstants/Main.hs
Changes:
=====================================
compiler/GHC/CmmToAsm/X86/CodeGen.hs
=====================================
@@ -2715,7 +2715,7 @@ genCCall64 addr conv dest_regs args = do
<- load_args prom_args (allIntArgRegs platform)
(allFPArgRegs platform)
nilOL nilOL
- let used_regs rs as = reverse (drop (length rs) (reverse as))
+ let used_regs rs as = dropTail (length rs) as
fregs_used = used_regs fregs (allFPArgRegs platform)
aregs_used = used_regs aregs (allIntArgRegs platform)
return (stack_args, aregs_used, fregs_used, load_args_code
=====================================
compiler/GHC/Core/Make.hs
=====================================
@@ -556,7 +556,8 @@ chunkify xs
where
n_xs = length xs
split [] = []
- split xs = take mAX_TUPLE_SIZE xs : split (drop mAX_TUPLE_SIZE xs)
+ split xs = let (as, bs) = splitAt mAX_TUPLE_SIZE xs
+ in as : split bs
{-
=====================================
compiler/GHC/Core/Opt/SetLevels.hs
=====================================
@@ -1752,13 +1752,12 @@ newLvlVar lvld_rhs join_arity_maybe is_mk_static
cloneCaseBndrs :: LevelEnv -> Level -> [Var] -> LvlM (LevelEnv, [Var])
cloneCaseBndrs env@(LE { le_subst = subst, le_lvl_env = lvl_env, le_env = id_env })
new_lvl vs
- = do { us <- getUniqueSupplyM
- ; let (subst', vs') = cloneBndrs subst us vs
+ = do { (subst', vs') <- cloneBndrs subst vs
-- N.B. We are not moving the body of the case, merely its case
-- binders. Consequently we should *not* set le_ctxt_lvl and
-- le_join_ceil. See Note [Setting levels when floating
-- single-alternative cases].
- env' = env { le_lvl_env = addLvls new_lvl lvl_env vs'
+ ; let env' = env { le_lvl_env = addLvls new_lvl lvl_env vs'
, le_subst = subst'
, le_env = foldl' add_id id_env (vs `zip` vs') }
@@ -1773,13 +1772,13 @@ cloneLetVars :: RecFlag -> LevelEnv -> Level -> [InVar]
cloneLetVars is_rec
env@(LE { le_subst = subst, le_lvl_env = lvl_env, le_env = id_env })
dest_lvl vs
- = do { us <- getUniqueSupplyM
- ; let vs1 = map zap vs
+ = do { let vs1 = map zap vs
-- See Note [Zapping the demand info]
- (subst', vs2) = case is_rec of
- NonRecursive -> cloneBndrs subst us vs1
- Recursive -> cloneRecIdBndrs subst us vs1
- prs = vs `zip` vs2
+ ; (subst', vs2) <- case is_rec of
+ NonRecursive -> cloneBndrs subst vs1
+ Recursive -> cloneRecIdBndrs subst vs1
+
+ ; let prs = vs `zip` vs2
env' = env { le_lvl_env = addLvls dest_lvl lvl_env vs2
, le_subst = subst'
, le_env = foldl' add_id id_env prs }
=====================================
compiler/GHC/Core/Opt/Specialise.hs
=====================================
@@ -3461,9 +3461,8 @@ cloneBndrSM env@(SE { se_subst = subst }) bndr
cloneRecBndrsSM :: SpecEnv -> [Id] -> SpecM (SpecEnv, [Id])
cloneRecBndrsSM env@(SE { se_subst = subst }) bndrs
- = do { us <- getUniqueSupplyM
- ; let (subst', bndrs') = Core.cloneRecIdBndrs subst us bndrs
- env' = env { se_subst = subst' }
+ = do { (subst', bndrs') <- Core.cloneRecIdBndrs subst bndrs
+ ; let env' = env { se_subst = subst' }
; return (env', bndrs') }
newDictBndr :: SpecEnv -> CoreBndr -> SpecM (SpecEnv, CoreBndr)
=====================================
compiler/GHC/Core/Opt/WorkWrap/Utils.hs
=====================================
@@ -213,12 +213,11 @@ mkWwBodies opts fun_id arg_vars res_ty demands res_cpr
-- Clone and prepare arg_vars of the original fun RHS
-- See Note [Freshen WW arguments]
-- and Note [Zap IdInfo on worker args]
- ; uniq_supply <- getUniqueSupplyM
; let args_free_tcvs = tyCoVarsOfTypes (res_ty : map varType arg_vars)
empty_subst = mkEmptySubst (mkInScopeSet args_free_tcvs)
zapped_arg_vars = map zap_var arg_vars
- (subst, cloned_arg_vars) = cloneBndrs empty_subst uniq_supply zapped_arg_vars
- res_ty' = substTyUnchecked subst res_ty
+ ; (subst, cloned_arg_vars) <- cloneBndrs empty_subst zapped_arg_vars
+ ; let res_ty' = substTyUnchecked subst res_ty
init_str_marks = map (const NotMarkedStrict) cloned_arg_vars
; (useful1, work_args_str, wrap_fn_str, fn_args)
=====================================
compiler/GHC/Core/Subst.hs
=====================================
@@ -417,11 +417,12 @@ cloneIdBndrs :: Subst -> UniqSupply -> [Id] -> (Subst, [Id])
cloneIdBndrs subst us ids
= mapAccumL (clone_id subst) subst (ids `zip` uniqsFromSupply us)
-cloneBndrs :: Subst -> UniqSupply -> [Var] -> (Subst, [Var])
+cloneBndrs :: MonadUnique m => Subst -> [Var] -> m (Subst, [Var])
-- Works for all kinds of variables (typically case binders)
-- not just Ids
-cloneBndrs subst us vs
- = mapAccumL (\subst (v, u) -> cloneBndr subst u v) subst (vs `zip` uniqsFromSupply us)
+cloneBndrs subst vs
+ = do us <- getUniquesM
+ pure $ mapAccumL (\subst (v, u) -> cloneBndr subst u v) subst (vs `zip` us)
cloneBndr :: Subst -> Unique -> Var -> (Subst, Var)
cloneBndr subst uniq v
@@ -429,12 +430,11 @@ cloneBndr subst uniq v
| otherwise = clone_id subst subst (v,uniq) -- Works for coercion variables too
-- | Clone a mutually recursive group of 'Id's
-cloneRecIdBndrs :: Subst -> UniqSupply -> [Id] -> (Subst, [Id])
-cloneRecIdBndrs subst us ids
- = (subst', ids')
- where
- (subst', ids') = mapAccumL (clone_id subst') subst
- (ids `zip` uniqsFromSupply us)
+cloneRecIdBndrs :: MonadUnique m => Subst -> [Id] -> m (Subst, [Id])
+cloneRecIdBndrs subst ids
+ = do us <- getUniquesM
+ let (subst', ids') = mapAccumL (clone_id subst') subst (ids `zip` us)
+ pure (subst', ids')
-- Just like substIdBndr, except that it always makes a new unique
-- It is given the unique to use
=====================================
compiler/GHC/StgToJS/Linker/Utils.hs
=====================================
@@ -41,6 +41,7 @@ import GHC.StgToJS.Types
import Prelude
import GHC.Platform
+import GHC.Utils.Misc
import Data.List (isPrefixOf)
import System.IO
import Data.Char (isSpace)
@@ -299,7 +300,7 @@ getJsOptions handle = do
parseJsOptions :: String -> [JSOption]
parseJsOptions xs = go xs
where
- trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace
+ trim = dropWhileEndLE isSpace . dropWhile isSpace
go [] = []
go xs = let (tok, rest) = break (== ',') xs
tok' = trim tok
=====================================
libraries/base/GHC/Event/Manager.hs
=====================================
@@ -467,7 +467,7 @@ onFdEvent mgr fd evs
IT.delete (fromIntegral fd) tbl >>= maybe (return []) (selectCallbacks tbl)
forM_ fdds $ \(FdData reg _ cb) -> cb reg evs
where
- -- | Here we look through the list of registrations for the fd of interest
+ -- Here we look through the list of registrations for the fd of interest
-- and sort out which match the events that were triggered. We,
--
-- 1. re-arm the fd as appropriate
=====================================
libraries/base/GHC/Event/TimerManager.hs
=====================================
@@ -175,7 +175,7 @@ step mgr = do
state `seq` return (state == Running)
where
- -- | Call all expired timer callbacks and return the time to the
+ -- Call all expired timer callbacks and return the time to the
-- next timeout.
mkTimeout :: IO Timeout
mkTimeout = do
=====================================
libraries/base/GHC/Fingerprint.hs
=====================================
@@ -84,7 +84,7 @@ getFileHash path = withBinaryFile path ReadMode $ \h ->
where
_BUFSIZE = 4096
- -- | Loop over _BUFSIZE sized chunks read from the handle,
+ -- Loop over _BUFSIZE sized chunks read from the handle,
-- passing the callback a block of bytes and its size.
processChunks :: Handle -> (Ptr Word8 -> Int -> IO ()) -> IO ()
processChunks h f = allocaBytes _BUFSIZE $ \arrPtr ->
=====================================
libraries/base/GHC/Fingerprint/Type.hs
=====================================
@@ -30,7 +30,7 @@ data Fingerprint = Fingerprint {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64
instance Show Fingerprint where
show (Fingerprint w1 w2) = hex16 w1 ++ hex16 w2
where
- -- | Formats a 64 bit number as 16 digits hex.
+ -- Formats a 64 bit number as 16 digits hex.
hex16 :: Word64 -> String
hex16 i = let hex = showHex i ""
in replicate (16 - length hex) '0' ++ hex
=====================================
libraries/base/GHC/IO/Encoding/Types.hs
=====================================
@@ -119,7 +119,6 @@ data TextEncoding
-- | @since 4.3.0.0
instance Show TextEncoding where
- -- | Returns the value of 'textEncodingName'
show te = textEncodingName te
-- | @since 4.4.0.0
=====================================
utils/deriveConstants/Main.hs
=====================================
@@ -27,7 +27,6 @@ needing to run the program, by inspecting the object file using 'nm'.
import Control.Monad (when, unless)
import Data.Bits (shiftL)
-import Data.Char (toLower)
import Data.List (elemIndex, stripPrefix, intercalate)
import Data.Map (Map)
import qualified Data.Map as Map
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1036481824fed7f8d5c9f70816b3dadd22098e42
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1036481824fed7f8d5c9f70816b3dadd22098e42
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/20230417/f9fc4325/attachment-0001.html>
More information about the ghc-commits
mailing list