[Git][ghc/ghc][master] Minor misc cleanups
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Tue Mar 19 18:52:04 UTC 2024
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
594bee0b by Krzysztof Gogolewski at 2024-03-19T14:50:36-04:00
Minor misc cleanups
- GHC.HsToCore.Foreign.JavaScript: remove dropRuntimeRepArgs;
boxed tuples don't take RuntimeRep args
- GHC.HsToCore.Foreign.Call: avoid partial pattern matching
- GHC.Stg.Unarise: strengthen the assertion; we can assert that
non-rubbish literals are unary rather than just non-void
- GHC.Tc.Gen.HsType: make sure the fsLit "literal" rule fires
- users_guide/using-warnings.rst: remove -Wforall-identifier,
now deprecated and does nothing
- users_guide/using.rst: fix formatting
- andy_cherry/test.T: remove expect_broken_for(23272...), 23272 is fixed
The rest are simple cleanups.
- - - - -
15 changed files:
- compiler/GHC/Core/LateCC/OverloadedCalls.hs
- compiler/GHC/Core/Opt/Simplify/Iteration.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/HsToCore/Foreign/Call.hs
- compiler/GHC/HsToCore/Foreign/JavaScript.hs
- compiler/GHC/Stg/Unarise.hs
- compiler/GHC/Stg/Utils.hs
- compiler/GHC/StgToCmm/DataCon.hs
- compiler/GHC/StgToJS/CodeGen.hs
- compiler/GHC/StgToJS/Expr.hs
- compiler/GHC/Tc/Gen/HsType.hs
- docs/users_guide/using-warnings.rst
- docs/users_guide/using.rst
- testsuite/tests/programs/andy_cherry/test.T
Changes:
=====================================
compiler/GHC/Core/LateCC/OverloadedCalls.hs
=====================================
@@ -107,7 +107,7 @@ overloadedCallsCC =
let
cc_name :: FastString
cc_name =
- fsLit $ maybe "<no name available>" getOccString (exprName app)
+ maybe (fsLit "<no name available>") getOccFS (exprName app)
cc_srcspan <-
fmap (Strict.fromMaybe (UnhelpfulSpan UnhelpfulNoLocationInfo)) $
=====================================
compiler/GHC/Core/Opt/Simplify/Iteration.hs
=====================================
@@ -586,7 +586,7 @@ tryCastWorkerWrapper env bind_cxt old_bndr occ_info bndr (Cast rhs co)
-- a DFunUnfolding in mk_worker_unfolding
, not (exprIsTrivial rhs) -- Not x = y |> co; Wrinkle 1
, not (hasInlineUnfolding info) -- Not INLINE things: Wrinkle 4
- , isConcreteType (typeKind work_ty) -- Don't peel off a cast if doing so would
+ , typeHasFixedRuntimeRep work_ty -- Don't peel off a cast if doing so would
-- lose the underlying runtime representation.
-- See Note [Preserve RuntimeRep info in cast w/w]
, not (isOpaquePragma (idInlinePragma old_bndr)) -- Not for OPAQUE bindings
=====================================
compiler/GHC/Driver/Main.hs
=====================================
@@ -617,7 +617,7 @@ extract_renamed_stuff mod_summary tc_result = do
-- Validate HIE files
when (gopt Opt_ValidateHie dflags) $ do
- hs_env <- Hsc $ \e w -> return (e, w)
+ hs_env <- getHscEnv
liftIO $ do
-- Validate Scopes
case validateScopes (hie_module hieFile) $ getAsts $ hie_asts hieFile of
=====================================
compiler/GHC/HsToCore/Expr.hs
=====================================
@@ -526,10 +526,9 @@ dsExpr (HsStatic (_, whole_ty) expr@(L loc _)) = do
, srcLocCol $ realSrcSpanStart r
)
_ -> (0, 0)
- srcLoc = mkCoreConApps (tupleDataCon Boxed 2)
- [ Type intTy , Type intTy
- , mkIntExprInt platform line, mkIntExprInt platform col
- ]
+ srcLoc = mkCoreTup [ mkIntExprInt platform line
+ , mkIntExprInt platform col
+ ]
putSrcSpanDsA loc $ return $
mkCoreApps (Var makeStaticId) [ Type ty, srcLoc, expr_ds ]
=====================================
compiler/GHC/HsToCore/Foreign/Call.hs
=====================================
@@ -172,8 +172,8 @@ unboxArg arg
-- data ByteArray ix = ByteArray ix ix ByteArray#
-- data MutableByteArray s ix = MutableByteArray ix ix (MutableByteArray# s)
| is_product_type &&
- data_con_arity == 3 &&
- isJust maybe_arg3_tycon &&
+ data_con_arity == 3,
+ Just arg3_tycon <- maybe_arg3_tycon,
(arg3_tycon == byteArrayPrimTyCon ||
arg3_tycon == mutableByteArrayPrimTyCon)
= do case_bndr <- newSysLocalDs ManyTy arg_ty
@@ -196,7 +196,6 @@ unboxArg arg
(_ : _ : data_con_arg_ty3 : _) = data_con_arg_tys
maybe_arg3_tycon = tyConAppTyCon_maybe data_con_arg_ty3
- Just arg3_tycon = maybe_arg3_tycon
boxResult :: Type
-> DsM (Type, CoreExpr -> CoreExpr)
=====================================
compiler/GHC/HsToCore/Foreign/JavaScript.hs
=====================================
@@ -446,8 +446,8 @@ unboxJsArg arg
-- data ByteArray ix = ByteArray ix ix ByteArray#
-- data MutableByteArray s ix = MutableByteArray ix ix (MutableByteArray# s)
| is_product_type &&
- data_con_arity == 3 &&
- isJust maybe_arg3_tycon &&
+ data_con_arity == 3,
+ Just arg3_tycon <- maybe_arg3_tycon,
(arg3_tycon == byteArrayPrimTyCon ||
arg3_tycon == mutableByteArrayPrimTyCon)
= do case_bndr <- newSysLocalDs ManyTy arg_ty
@@ -469,7 +469,6 @@ unboxJsArg arg
(_ : _ : data_con_arg_ty3 : _) = data_con_arg_tys
maybe_arg3_tycon = tyConAppTyCon_maybe (scaledThing data_con_arg_ty3)
- Just arg3_tycon = maybe_arg3_tycon
-- Takes the result of the user-level ccall:
@@ -545,7 +544,7 @@ mk_alt return_result (Just prim_res_ty, wrap_result)
-- The ccall returns a non-() value
| isUnboxedTupleType prim_res_ty = do
let
- Just ls = fmap dropRuntimeRepArgs (tyConAppArgs_maybe prim_res_ty)
+ ls = dropRuntimeRepArgs (tyConAppArgs prim_res_ty)
arity = 1 + length ls
args_ids <- mapM (newSysLocalDs ManyTy) ls
state_id <- newSysLocalDs ManyTy realWorldStatePrimTy
@@ -612,15 +611,13 @@ jsResultWrapper result_ty
| isPrimitiveType result_ty
= return (Just result_ty, \e -> e)
-- Base case 1c: boxed tuples
- -- fixme: levity args?
- | Just (tc, args) <- splitTyConApp_maybe result_ty
+ | Just (tc, args) <- maybe_tc_app
, isBoxedTupleTyCon tc = do
- let args' = dropRuntimeRepArgs args
- innerTy = mkTupleTy Unboxed args'
+ let innerTy = mkTupleTy Unboxed args
(inner_res, w) <- jsResultWrapper innerTy
- matched <- mapM (newSysLocalDs ManyTy) args'
+ matched <- mapM (newSysLocalDs ManyTy) args
let inner e = mkWildCase (w e) (unrestricted innerTy) result_ty
- [ Alt (DataAlt (tupleDataCon Unboxed (length args')))
+ [ Alt (DataAlt (tupleDataCon Unboxed (length args)))
matched
(mkCoreTup (map Var matched))
-- mkCoreConApps (tupleDataCon Boxed (length args)) (map Type args ++ map Var matched)
=====================================
compiler/GHC/Stg/Unarise.hs
=====================================
@@ -759,13 +759,11 @@ mapTupleIdBinders
mapTupleIdBinders ids args0 rho0
= assert (not (any (null . stgArgRep) args0)) $
let
- ids_unarised :: [(Id, [PrimRep])]
- ids_unarised = map (\id -> (id, typePrimRep (idType id))) ids
-
- map_ids :: UnariseEnv -> [(Id, [PrimRep])] -> [StgArg] -> UnariseEnv
+ map_ids :: UnariseEnv -> [Id] -> [StgArg] -> UnariseEnv
map_ids rho [] _ = rho
- map_ids rho ((x, x_reps) : xs) args =
+ map_ids rho (x : xs) args =
let
+ x_reps = typePrimRep (idType x)
x_arity = length x_reps
(x_args, args') =
assert (args `lengthAtLeast` x_arity)
@@ -780,7 +778,7 @@ mapTupleIdBinders ids args0 rho0
in
map_ids rho' xs args'
in
- map_ids rho0 ids_unarised args0
+ map_ids rho0 ids args0
mapSumIdBinders
:: InId -- Binder (in the case alternative).
@@ -1094,7 +1092,7 @@ unariseConArg _ arg@(StgLitArg lit)
| Just as <- unariseLiteral_maybe lit
= as
| otherwise
- = assert (not (isZeroBitTy (literalType lit))) -- We have no non-rubbish void literals
+ = assert (isNvUnaryRep (typePrimRep (literalType lit))) -- We have no non-rubbish non-unary literals
[arg]
unariseConArgs :: UnariseEnv -> [InStgArg] -> [OutStgArg]
@@ -1110,10 +1108,10 @@ unariseConArgBinder = unariseArgBinder True
--------------------------------------------------------------------------------
-mkIds :: FastString -> [UnaryType] -> UniqSM [Id]
+mkIds :: FastString -> [NvUnaryType] -> UniqSM [Id]
mkIds fs tys = mkUnarisedIds fs tys
-mkId :: FastString -> UnaryType -> UniqSM Id
+mkId :: FastString -> NvUnaryType -> UniqSM Id
mkId s t = mkUnarisedId s t
isMultiValBndr :: Id -> Bool
=====================================
compiler/GHC/Stg/Utils.hs
=====================================
@@ -30,10 +30,10 @@ import GHC.Utils.Panic
import GHC.Data.FastString
-mkUnarisedIds :: MonadUnique m => FastString -> [UnaryType] -> m [Id]
+mkUnarisedIds :: MonadUnique m => FastString -> [NvUnaryType] -> m [Id]
mkUnarisedIds fs tys = mapM (mkUnarisedId fs) tys
-mkUnarisedId :: MonadUnique m => FastString -> UnaryType -> m Id
+mkUnarisedId :: MonadUnique m => FastString -> NvUnaryType -> m Id
mkUnarisedId s t = mkSysLocalM s ManyTy t
-- Checks if id is a top level error application.
=====================================
compiler/GHC/StgToCmm/DataCon.hs
=====================================
@@ -335,7 +335,7 @@ precomputedStaticConInfo_maybe cfg binder con [arg]
, platformOS platform /= OSMinGW32 || not (stgToCmmPIE cfg || stgToCmmPIC cfg)
, Just val <- getClosurePayload arg
, inRange val
- = let intlike_lbl = mkCmmClosureLabel rtsUnitId (fsLit label)
+ = let intlike_lbl = mkCmmClosureLabel rtsUnitId label
val_int = fromIntegral val :: Int
offsetW = (val_int - fromIntegral min_static_range) * (fixedHdrSizeW profile + 1)
-- INTLIKE/CHARLIKE closures consist of a header and one word payload
@@ -366,8 +366,8 @@ precomputedStaticConInfo_maybe cfg binder con [arg]
| charClosure = fromIntegral (pc_MAX_CHARLIKE constants)
| otherwise = panic "precomputedStaticConInfo_maybe: Unknown closure type"
label
- | intClosure = "stg_INTLIKE"
- | charClosure = "stg_CHARLIKE"
+ | intClosure = fsLit "stg_INTLIKE"
+ | charClosure = fsLit "stg_CHARLIKE"
| otherwise = panic "precomputedStaticConInfo_maybe: Unknown closure type"
precomputedStaticConInfo_maybe _ _ _ _ = Nothing
=====================================
compiler/GHC/StgToJS/CodeGen.hs
=====================================
@@ -297,13 +297,13 @@ genSetConInfo i d l {- srt -} = do
emitClosureInfo $ ClosureInfo ei
(CIRegs 0 [PtrV])
(mkFastString $ renderWithContext defaultSDocContext (ppr d))
- (fixedLayout $ map unaryTypeJSRep fields)
+ (fixedLayout fields)
(CICon $ dataConTag d)
sr
return (mkDataEntry ei)
where
-- dataConRepArgTys sometimes returns unboxed tuples. is that a bug?
- fields = concatMap (map primRepToType . typePrimRep . unwrapType . scaledThing)
+ fields = concatMap (typeJSRep . unwrapType . scaledThing)
(dataConRepArgTys d)
-- concatMap (map slotTyToType . repTypeSlots . repType) (dataConRepArgTys d)
=====================================
compiler/GHC/StgToJS/Expr.hs
=====================================
@@ -491,7 +491,7 @@ optimizeFree offset ids = do
-- this line goes wrong vvvvvvv
let -- ids' = concat $ map (\i -> map (i,) [1..varSize . unaryTypeJSRep . idType $ i]) ids
idSize :: Id -> Int
- idSize i = sum $ map varSize (typeJSRep . idType $ i)
+ idSize i = typeSize $ idType i
ids' = concatMap (\i -> map (i,) [1..idSize i]) ids
-- 1..varSize] . unaryTypeJSRep . idType $ i]) (typeJSRep ids)
l = length ids'
=====================================
compiler/GHC/Tc/Gen/HsType.hs
=====================================
@@ -2216,7 +2216,7 @@ tcAnonWildCardOcc is_extra (TcTyMode { mode_holes = Just (hole_lvl, hole_mode) }
= do { kv_details <- newTauTvDetailsAtLevel hole_lvl
; kv_name <- newMetaTyVarName (fsLit "k")
; wc_details <- newTauTvDetailsAtLevel hole_lvl
- ; wc_name <- newMetaTyVarName (fsLit wc_nm)
+ ; wc_name <- newMetaTyVarName wc_nm
; let kv = mkTcTyVar kv_name liftedTypeKind kv_details
wc_kind = mkTyVarTy kv
wc_tv = mkTcTyVar wc_name wc_kind wc_details
@@ -2235,10 +2235,10 @@ tcAnonWildCardOcc is_extra (TcTyMode { mode_holes = Just (hole_lvl, hole_mode) }
where
-- See Note [Wildcard names]
wc_nm = case hole_mode of
- HM_Sig -> "w"
- HM_FamPat -> "_"
- HM_VTA -> "w"
- HM_TyAppPat -> "_"
+ HM_Sig -> fsLit "w"
+ HM_FamPat -> fsLit "_"
+ HM_VTA -> fsLit "w"
+ HM_TyAppPat -> fsLit "_"
emit_holes = case hole_mode of
HM_Sig -> True
=====================================
docs/users_guide/using-warnings.rst
=====================================
@@ -75,7 +75,6 @@ as ``-Wno-...`` for every individual warning in the group.
* :ghc-flag:`-Woperator-whitespace-ext-conflict`
* :ghc-flag:`-Wambiguous-fields`
* :ghc-flag:`-Wunicode-bidirectional-format-characters`
- * :ghc-flag:`-Wforall-identifier`
* :ghc-flag:`-Wgadt-mono-local-binds`
* :ghc-flag:`-Wtype-equality-requires-operators`
* :ghc-flag:`-Wtype-equality-out-of-scope`
=====================================
docs/users_guide/using.rst
=====================================
@@ -799,7 +799,7 @@ There are two kinds of participants in the GHC Jobserver protocol:
processes through the semaphore ⟨sem⟩ (specified as a string).
Error if the semaphore doesn't exist.
- Use of ``-jsem`` will override use of :ghc-flag:``-j[⟨n⟩]``,
+ Use of ``-jsem`` will override use of :ghc-flag:`-j[⟨n⟩]`,
and vice-versa.
.. _multi-home-units:
=====================================
testsuite/tests/programs/andy_cherry/test.T
=====================================
@@ -2,6 +2,5 @@
test('andy_cherry',
[extra_files(['DataTypes.hs', 'GenUtils.hs', 'Interp.hs', 'InterpUtils.hs', 'Main.hs', 'Parser.hs', 'PrintTEX.hs', 'mygames.pgn']),
when(fast(), skip),
- expect_broken_for(23272, ['ghci-opt']),
extra_run_opts('.')],
multimod_compile_and_run, ['Main', '-cpp'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/594bee0bb1b5df2f0459acbd5fa69e44a6036e5f
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/594bee0bb1b5df2f0459acbd5fa69e44a6036e5f
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/20240319/646ab700/attachment-0001.html>
More information about the ghc-commits
mailing list