[Git][ghc/ghc][wip/misc-cleanup4] Misc cleanup

Krzysztof Gogolewski (@monoidal) gitlab at gitlab.haskell.org
Mon Jan 9 23:44:21 UTC 2023



Krzysztof Gogolewski pushed to branch wip/misc-cleanup4 at Glasgow Haskell Compiler / GHC


Commits:
327cd746 by Krzysztof Gogolewski at 2023-01-10T00:43:51+01:00
Misc cleanup

- Remove unused mkWildEvBinder
- Use typeTypeOrConstraint - more symmetric and asserts that
  that the type is Type or Constraint
- Use text "foo" in JS, to make sure the rule fires
- Fix escape sequences in Python; they raise a deprecation warning
  with -Wdefault

- - - - -


13 changed files:

- compiler/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs
- compiler/GHC/Core/Make.hs
- compiler/GHC/Core/Opt/WorkWrap.hs
- compiler/GHC/Core/Type.hs
- compiler/GHC/HsToCore/Utils.hs
- compiler/GHC/JS/Ppr.hs
- compiler/GHC/Tc/Validity.hs
- testsuite/driver/runtests.py
- testsuite/tests/cabal/all.T
- testsuite/tests/cmm/should_compile/all.T
- testsuite/tests/codeGen/should_compile/all.T
- testsuite/tests/simplStg/should_compile/all.T
- testsuite/tests/stranal/sigs/all.T


Changes:

=====================================
compiler/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs
=====================================
@@ -199,8 +199,7 @@ joinToTargets_again
                         (return ())
                 -}
                 delta           <- getDeltaR
-                fixUpInstrs_    <- mapM (handleComponent delta instr) sccs
-                let fixUpInstrs = concat fixUpInstrs_
+                fixUpInstrs     <- concatMapM (handleComponent delta instr) sccs
 
                 -- make a new basic block containing the fixup code.
                 --      A the end of the current block we will jump to the fixup one,


=====================================
compiler/GHC/Core/Make.hs
=====================================
@@ -6,7 +6,7 @@ module GHC.Core.Make (
         mkCoreLet, mkCoreLets,
         mkCoreApp, mkCoreApps, mkCoreConApps,
         mkCoreLams, mkWildCase, mkIfThenElse,
-        mkWildValBinder, mkWildEvBinder,
+        mkWildValBinder,
         mkSingleAltCase,
         sortQuantVars, castBottomExpr,
 
@@ -54,7 +54,7 @@ import GHC.Prelude
 import GHC.Platform
 
 import GHC.Types.Id
-import GHC.Types.Var  ( EvVar, setTyVarUnique, visArgConstraintLike )
+import GHC.Types.Var  ( setTyVarUnique, visArgConstraintLike )
 import GHC.Types.TyThing
 import GHC.Types.Id.Info
 import GHC.Types.Cpr
@@ -173,9 +173,6 @@ mkCoreAppTyped d (fun, fun_ty) arg
 *                                                                      *
 ********************************************************************* -}
 
-mkWildEvBinder :: PredType -> EvVar
-mkWildEvBinder pred = mkWildValBinder ManyTy pred
-
 -- | Make a /wildcard binder/. This is typically used when you need a binder
 -- that you expect to use only at a *binding* site.  Do not use it at
 -- occurrence sites because it has a single, fixed unique, and it's very
@@ -1082,8 +1079,9 @@ mkImpossibleExpr :: Type -> String -> CoreExpr
 mkImpossibleExpr res_ty str
   = mkRuntimeErrorApp err_id res_ty str
   where    -- See Note [Type vs Constraint for error ids]
-    err_id | isConstraintLikeKind (typeKind res_ty) = iMPOSSIBLE_CONSTRAINT_ERROR_ID
-           | otherwise                              = iMPOSSIBLE_ERROR_ID
+    err_id = case typeTypeOrConstraint res_ty of
+               TypeLike       -> iMPOSSIBLE_ERROR_ID
+               ConstraintLike -> iMPOSSIBLE_CONSTRAINT_ERROR_ID
 
 {- Note [Type vs Constraint for error ids]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1207,8 +1205,9 @@ mkAbsentErrorApp :: Type         -- The type to instantiate 'a'
 mkAbsentErrorApp res_ty err_msg
   = mkApps (Var err_id) [ Type res_ty, err_string ]
   where
-    err_id | isConstraintLikeKind (typeKind res_ty) = aBSENT_CONSTRAINT_ERROR_ID
-           | otherwise                              = aBSENT_ERROR_ID
+    err_id = case typeTypeOrConstraint res_ty of
+               TypeLike       -> aBSENT_ERROR_ID
+               ConstraintLike -> aBSENT_CONSTRAINT_ERROR_ID
     err_string = Lit (mkLitString err_msg)
 
 absentErrorName, absentConstraintErrorName :: Name


=====================================
compiler/GHC/Core/Opt/WorkWrap.hs
=====================================
@@ -68,9 +68,7 @@ info for exported values).
 wwTopBinds :: WwOpts -> UniqSupply -> CoreProgram -> CoreProgram
 
 wwTopBinds ww_opts us top_binds
-  = initUs_ us $ do
-    top_binds' <- mapM (wwBind ww_opts) top_binds
-    return (concat top_binds')
+  = initUs_ us $ concatMapM (wwBind ww_opts) top_binds
 
 {-
 ************************************************************************


=====================================
compiler/GHC/Core/Type.hs
=====================================
@@ -770,7 +770,7 @@ isBoxedRuntimeRep rep = isJust (isBoxedRuntimeRep_maybe rep)
 -- expands to `Boxed lev` and returns `Nothing` otherwise.
 --
 -- Types with this runtime rep are represented by pointers on the GC'd heap.
-isBoxedRuntimeRep_maybe :: RuntimeRepType -> Maybe Type
+isBoxedRuntimeRep_maybe :: RuntimeRepType -> Maybe LevityType
 isBoxedRuntimeRep_maybe rep
   | Just (rr_tc, args) <- splitRuntimeRep_maybe rep
   , rr_tc `hasKey` boxedRepDataConKey


=====================================
compiler/GHC/HsToCore/Utils.hs
=====================================
@@ -81,7 +81,6 @@ import GHC.Types.Tickish
 import GHC.Utils.Misc
 import GHC.Driver.Session
 import GHC.Driver.Ppr
-import GHC.Data.FastString
 import qualified GHC.LanguageExtensions as LangExt
 
 import GHC.Tc.Types.Evidence
@@ -995,19 +994,10 @@ mkOptTickBox = flip (foldr Tick)
 
 mkBinaryTickBox :: Int -> Int -> CoreExpr -> DsM CoreExpr
 mkBinaryTickBox ixT ixF e = do
-       uq <- newUnique
        this_mod <- getModule
-       let bndr1 = mkSysLocal (fsLit "t1") uq OneTy boolTy
-         -- It's always sufficient to pattern-match on a boolean with
-         -- multiplicity 'One'.
-       let
+       let trueBox  = Tick (HpcTick this_mod ixT) (Var trueDataConId)
            falseBox = Tick (HpcTick this_mod ixF) (Var falseDataConId)
-           trueBox  = Tick (HpcTick this_mod ixT) (Var trueDataConId)
-       --
-       return $ Case e bndr1 boolTy
-                       [ Alt (DataAlt falseDataCon) [] falseBox
-                       , Alt (DataAlt trueDataCon)  [] trueBox
-                       ]
+       return $ mkIfThenElse e trueBox falseBox
 
 
 


=====================================
compiler/GHC/JS/Ppr.hs
=====================================
@@ -152,9 +152,9 @@ defRenderJsS r = \case
     ValExpr (JFunc is b) -> sep [jsToDocR r i <+> text "= function" <> parens (hsep . punctuate comma . map (jsToDocR r) $ is) <> char '{', nest 2 (jsToDocR r b), text "}"]
     _                    -> jsToDocR r i <+> char '=' <+> jsToDocR r x
   UOpStat op x
-    | isPre op && isAlphaOp op -> ftext (uOpText op) <+> optParens r x
-    | isPre op                 -> ftext (uOpText op) <> optParens r x
-    | otherwise                -> optParens r x <> ftext (uOpText op)
+    | isPre op && isAlphaOp op -> uOpText op <+> optParens r x
+    | isPre op                 -> uOpText op <> optParens r x
+    | otherwise                -> optParens r x <> uOpText op
   BlockStat xs -> jsToDocR r (flattenBlocks xs)
 
 flattenBlocks :: [JStat] -> [JStat]
@@ -174,11 +174,11 @@ defRenderJsE r = \case
   SelExpr x y       -> jsToDocR r x <> char '.' <> jsToDocR r y
   IdxExpr x y       -> jsToDocR r x <> brackets (jsToDocR r y)
   IfExpr x y z      -> parens (jsToDocR r x <+> char '?' <+> jsToDocR r y <+> char ':' <+> jsToDocR r z)
-  InfixExpr op x y  -> parens $ hsep [jsToDocR r x, ftext (opText op), jsToDocR r y]
+  InfixExpr op x y  -> parens $ hsep [jsToDocR r x, opText op, jsToDocR r y]
   UOpExpr op x
-    | isPre op && isAlphaOp op -> ftext (uOpText op) <+> optParens r x
-    | isPre op                 -> ftext (uOpText op) <> optParens r x
-    | otherwise                -> optParens r x <> ftext (uOpText op)
+    | isPre op && isAlphaOp op -> uOpText op <+> optParens r x
+    | isPre op                 -> uOpText op <> optParens r x
+    | otherwise                -> optParens r x <> uOpText op
   ApplExpr je xs -> jsToDocR r je <> (parens . hsep . punctuate comma $ map (jsToDocR r) xs)
   UnsatExpr e    -> jsToDocR r $ pseudoSaturate e
 
@@ -235,47 +235,47 @@ encodeJsonChar = \case
             let h = showHex cp ""
             in  text (prefix ++ replicate (pad - length h) '0' ++ h)
 
-uOpText :: JUOp -> FastString
+uOpText :: JUOp -> Doc
 uOpText = \case
-  NotOp     -> "!"
-  BNotOp    -> "~"
-  NegOp     -> "-"
-  PlusOp    -> "+"
-  NewOp     -> "new"
-  TypeofOp  -> "typeof"
-  DeleteOp  -> "delete"
-  YieldOp   -> "yield"
-  VoidOp    -> "void"
-  PreIncOp  -> "++"
-  PostIncOp -> "++"
-  PreDecOp  -> "--"
-  PostDecOp -> "--"
-
-opText :: JOp -> FastString
+  NotOp     -> text "!"
+  BNotOp    -> text "~"
+  NegOp     -> text "-"
+  PlusOp    -> text "+"
+  NewOp     -> text "new"
+  TypeofOp  -> text "typeof"
+  DeleteOp  -> text "delete"
+  YieldOp   -> text "yield"
+  VoidOp    -> text "void"
+  PreIncOp  -> text "++"
+  PostIncOp -> text "++"
+  PreDecOp  -> text "--"
+  PostDecOp -> text "--"
+
+opText :: JOp -> Doc
 opText = \case
-  EqOp          -> "=="
-  StrictEqOp    -> "==="
-  NeqOp         -> "!="
-  StrictNeqOp   -> "!=="
-  GtOp          -> ">"
-  GeOp          -> ">="
-  LtOp          -> "<"
-  LeOp          -> "<="
-  AddOp         -> "+"
-  SubOp         -> "-"
-  MulOp         -> "*"
-  DivOp         -> "/"
-  ModOp         -> "%"
-  LeftShiftOp   -> "<<"
-  RightShiftOp  -> ">>"
-  ZRightShiftOp -> ">>>"
-  BAndOp        -> "&"
-  BOrOp         -> "|"
-  BXorOp        -> "^"
-  LAndOp        -> "&&"
-  LOrOp         -> "||"
-  InstanceofOp  -> "instanceof"
-  InOp          -> "in"
+  EqOp          -> text "=="
+  StrictEqOp    -> text "==="
+  NeqOp         -> text "!="
+  StrictNeqOp   -> text "!=="
+  GtOp          -> text ">"
+  GeOp          -> text ">="
+  LtOp          -> text "<"
+  LeOp          -> text "<="
+  AddOp         -> text "+"
+  SubOp         -> text "-"
+  MulOp         -> text "*"
+  DivOp         -> text "/"
+  ModOp         -> text "%"
+  LeftShiftOp   -> text "<<"
+  RightShiftOp  -> text ">>"
+  ZRightShiftOp -> text ">>>"
+  BAndOp        -> text "&"
+  BOrOp         -> text "|"
+  BXorOp        -> text "^"
+  LAndOp        -> text "&&"
+  LOrOp         -> text "||"
+  InstanceofOp  -> text "instanceof"
+  InOp          -> text "in"
 
 
 isPre :: JUOp -> Bool


=====================================
compiler/GHC/Tc/Validity.hs
=====================================
@@ -774,7 +774,8 @@ check_type (ve at ValidityEnv{ ve_tidy_env = env, ve_ctxt = ctxt
   where
     (arg_rank, res_rank) = funArgResRank rank
 
-check_type _ ty = pprPanic "check_type" (ppr ty)
+check_type _ ty@(ForAllTy {}) = pprPanic "check_type" (ppr ty)
+check_type _ ty@(CoercionTy {}) = pprPanic "check_type" (ppr ty)
 
 ----------------------------------------
 check_syn_tc_app :: ValidityEnv


=====================================
testsuite/driver/runtests.py
=====================================
@@ -224,7 +224,7 @@ else:
         h.close()
         if v != '':
             # If it does then use the first utf8 locale that is available
-            h = os.popen('locale -a | grep -i "utf8\|utf-8" 2>/dev/null', 'r')
+            h = os.popen(r'locale -a | grep -i "utf8\|utf-8" 2>/dev/null', 'r')
             v = h.readline().strip()
             h.close()
             if v != '':


=====================================
testsuite/tests/cabal/all.T
=====================================
@@ -1,5 +1,5 @@
 def normaliseDynlibNames(str):
-    return re.sub('-ghc[0-9.]+\.', '-ghc<VERSION>.', str)
+    return re.sub(r'-ghc[0-9.]+\.', '-ghc<VERSION>.', str)
 
 def ignore_warnings(str):
     return re.sub(r'Warning:.*\n', '', str)


=====================================
testsuite/tests/cmm/should_compile/all.T
=====================================
@@ -3,7 +3,7 @@ setTestOpts(
   ])
 
 test('selfloop', [cmm_src], compile, ['-no-hs-main'])
-test('cmm_sink_sp', [ only_ways(['optasm']), grep_errmsg('(\[Sp.*\]).*(=).*(\[.*R1.*\]).*;',[1,2,3]), cmm_src], compile, ['-no-hs-main -ddump-cmm -dsuppress-uniques -O'])
+test('cmm_sink_sp', [ only_ways(['optasm']), grep_errmsg(r'(\[Sp.*\]).*(=).*(\[.*R1.*\]).*;',[1,2,3]), cmm_src], compile, ['-no-hs-main -ddump-cmm -dsuppress-uniques -O'])
 
 test('T16930', normal, makefile_test, ['T16930'])
 test('T17442', normal, compile, [''])


=====================================
testsuite/tests/codeGen/should_compile/all.T
=====================================
@@ -75,9 +75,9 @@ test('T14373',
       [ js_skip # JS backend doesn't produce Cmm
       ],
      multimod_compile_filter, ['T14373', '-fasm -O2 -c -ddump-cmm-from-stg',
-     'grep -e "const T14373\.._closure+.;"'])
+     r'grep -e "const T14373\.._closure+.;"'])
 
-switch_skeleton_only = 'grep -e "switch \[" -e "case " -e "default: " | sed -e "s|\] .*|\]|g" -e "s|goto .*|goto |g"'
+switch_skeleton_only = r'grep -e "switch \[" -e "case " -e "default: " | sed -e "s|\] .*|\]|g" -e "s|goto .*|goto |g"'
 
 test('T14373a',
       [ js_skip # JS backend doesn't produce Cmm
@@ -95,8 +95,8 @@ test('T14373c',
      multimod_compile_filter, ['T14373c', '-fasm -O2 -c -ddump-cmm-from-stg',
      switch_skeleton_only])
 
-switch_skeleton_and_entries_only = ('grep -e "switch \[" -e "case " -e "default: " -e "Default_entry(" -e "R1 = .*_closure+2;"'
-                                    '| sed -e "s|\] .*|\]|g" -e "s|goto .*|goto |g" -e "s|R1 = .*_closure+2;.*|R1 = XYZ_closure+2;|g" -e "s|//.*|//|g"')
+switch_skeleton_and_entries_only = (r'grep -e "switch \[" -e "case " -e "default: " -e "Default_entry(" -e "R1 = .*_closure+2;"'
+                                     '| sed -e "s|\] .*|\]|g" -e "s|goto .*|goto |g" -e "s|R1 = .*_closure+2;.*|R1 = XYZ_closure+2;|g" -e "s|//.*|//|g"')
 
 test('T14373d',
       [ js_skip # JS backend doesn't produce Cmm


=====================================
testsuite/tests/simplStg/should_compile/all.T
=====================================
@@ -11,6 +11,6 @@ setTestOpts(f)
 
 test('T13588', [ grep_errmsg('case') ] , compile, ['-dverbose-stg2stg -fno-worker-wrapper'])
 test('T19717', normal, compile, ['-ddump-stg-final -dsuppress-uniques -dno-typeable-binds'])
-test('inferTags002', [ only_ways(['optasm']), grep_errmsg('(call stg\_ap\_0)', [1])], compile, ['-ddump-cmm -dsuppress-uniques -dno-typeable-binds -O'])
+test('inferTags002', [ only_ways(['optasm']), grep_errmsg(r'(call stg\_ap\_0)', [1])], compile, ['-ddump-cmm -dsuppress-uniques -dno-typeable-binds -O'])
 
 test('T22212', normal, compile, ['-O'])


=====================================
testsuite/tests/stranal/sigs/all.T
=====================================
@@ -23,7 +23,7 @@ test('T13380c', expect_broken('!3014'), compile, [''])
 test('T13380f', normal, compile, [''])
 test('T18086', normal, compile, ['-package ghc'])
 test('T18957', normal, compile, [''])
-test('T16197b', [grep_errmsg('\$wf')], compile, ['-ddump-simpl -dsuppress-uniques -dsuppress-all'])
+test('T16197b', [grep_errmsg(r'\$wf')], compile, ['-ddump-simpl -dsuppress-uniques -dsuppress-all'])
 test('T19407', normal, compile, [''])
 test('T19871', normal, compile, [''])
 test('T16859', normal, compile, ['-package ghc'])



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/327cd74684f6b1d70aa2e4c54f09e4a9d789962f

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/327cd74684f6b1d70aa2e4c54f09e4a9d789962f
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/20230109/7aa54d9b/attachment-0001.html>


More information about the ghc-commits mailing list