[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