[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: Revert "Use fix-sized bit-fiddling primops for fixed size boxed types"
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Sat Feb 4 21:48:45 UTC 2023
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
25537dfd by Ben Gamari at 2023-02-04T04:12:57-05:00
Revert "Use fix-sized bit-fiddling primops for fixed size boxed types"
This reverts commit 4512ad2d6a8e65ea43c86c816411cb13b822f674.
This was never applied to master/9.6 originally.
(cherry picked from commit a44bdc2720015c03d57f470b759ece7fab29a57a)
- - - - -
7612dc71 by Krzysztof Gogolewski at 2023-02-04T04:13:34-05:00
Minor refactor
* Introduce refactorDupsOn f = refactorDups (comparing f)
* Make mkBigTupleCase and coreCaseTuple monadic.
Every call to those functions was preceded by calling newUniqueSupply.
* Use mkUserLocalOrCoVar, which is equivalent to combining
mkLocalIdOrCoVar with mkInternalName.
- - - - -
da0d9939 by Bodigrim at 2023-02-04T16:48:23-05:00
Fix colors in emacs terminal
- - - - -
35b15d67 by Bodigrim at 2023-02-04T16:48:24-05:00
base changelog: move entries which were not backported to ghc-9.6 to base-4.19 section
- - - - -
24 changed files:
- compiler/GHC/Core/Lint.hs
- compiler/GHC/Core/Make.hs
- compiler/GHC/Core/Utils.hs
- compiler/GHC/Data/List/SetOps.hs
- compiler/GHC/HsToCore/Arrows.hs
- compiler/GHC/HsToCore/ListComp.hs
- compiler/GHC/HsToCore/Pmc/Solver.hs
- compiler/GHC/HsToCore/Pmc/Utils.hs
- compiler/GHC/Iface/Env.hs
- compiler/GHC/IfaceToCore.hs
- compiler/GHC/Rename/Expr.hs
- compiler/GHC/Rename/Module.hs
- compiler/GHC/Rename/Utils.hs
- compiler/GHC/Stg/Lift/Monad.hs
- compiler/GHC/SysTools/Terminal.hs
- compiler/GHC/Tc/Gen/HsType.hs
- compiler/GHC/Tc/Utils/Monad.hs
- compiler/GHC/Tc/Utils/TcMType.hs
- libraries/base/GHC/Int.hs
- libraries/base/GHC/Word.hs
- libraries/base/changelog.md
- testsuite/tests/simplCore/should_run/T20203.stderr-ws-32
- testsuite/tests/simplCore/should_run/T20203.stderr-ws-64
- utils/ghc-pkg/Main.hs
Changes:
=====================================
compiler/GHC/Core/Lint.hs
=====================================
@@ -96,7 +96,6 @@ import Data.Foldable ( for_, toList )
import Data.List.NonEmpty ( NonEmpty(..), groupWith )
import Data.List ( partition )
import Data.Maybe
-import Data.Ord ( comparing )
import GHC.Data.Pair
import GHC.Base (oneShot)
import GHC.Data.Unboxed
@@ -478,7 +477,7 @@ lintCoreBindings' cfg binds
-- M.n{r3} = ...
-- M.n{r29} = ...
-- because they both get the same linker symbol
- ext_dups = snd $ removeDups (comparing ord_ext) $
+ ext_dups = snd $ removeDupsOn ord_ext $
filter isExternalName $ map Var.varName binders
ord_ext n = (nameModule n, nameOccName n)
=====================================
compiler/GHC/Core/Make.hs
=====================================
@@ -648,12 +648,12 @@ mkSmallTupleSelector1 vars the_var scrut_var scrut
-- To avoid shadowing, we use uniques to invent new variables.
--
-- If necessary we pattern match on a "big" tuple.
-mkBigTupleCase :: UniqSupply -- ^ For inventing names of intermediate variables
- -> [Id] -- ^ The tuple identifiers to pattern match on;
+mkBigTupleCase :: MonadUnique m -- For inventing names of intermediate variables
+ => [Id] -- ^ The tuple identifiers to pattern match on;
-- Bring these into scope in the body
-> CoreExpr -- ^ Body of the case
-> CoreExpr -- ^ Scrutinee
- -> CoreExpr
+ -> m CoreExpr
-- ToDo: eliminate cases where none of the variables are needed.
--
-- mkBigTupleCase uniqs [a,b,c,d] body v e
@@ -661,11 +661,11 @@ mkBigTupleCase :: UniqSupply -- ^ For inventing names of intermediate vari
-- case p of p { (a,b) ->
-- case q of q { (c,d) ->
-- body }}}
-mkBigTupleCase us vars body scrut
- = mk_tuple_case wrapped_us (chunkify wrapped_vars) wrapped_body
+mkBigTupleCase vars body scrut
+ = do us <- getUniqueSupplyM
+ let (wrapped_us, wrapped_vars, wrapped_body) = foldr unwrap (us,[],body) vars
+ return $ mk_tuple_case wrapped_us (chunkify wrapped_vars) wrapped_body
where
- (wrapped_us, wrapped_vars, wrapped_body) = foldr unwrap (us,[],body) vars
-
scrut_ty = exprType scrut
unwrap var (us,vars,body)
=====================================
compiler/GHC/Core/Utils.hs
=====================================
@@ -2090,9 +2090,8 @@ dataConInstPat fss uniqs mult con inst_tys
arg_ids = zipWith4 mk_id_var id_uniqs id_fss arg_tys arg_strs
mk_id_var uniq fs (Scaled m ty) str
= setCaseBndrEvald str $ -- See Note [Mark evaluated arguments]
- mkLocalIdOrCoVar name (mult `mkMultMul` m) (Type.substTy full_subst ty)
- where
- name = mkInternalName uniq (mkVarOccFS fs) noSrcSpan
+ mkUserLocalOrCoVar (mkVarOccFS fs) uniq
+ (mult `mkMultMul` m) (Type.substTy full_subst ty) noSrcSpan
{-
Note [Mark evaluated arguments]
=====================================
compiler/GHC/Data/List/SetOps.hs
=====================================
@@ -18,7 +18,7 @@ module GHC.Data.List.SetOps (
Assoc, assoc, assocMaybe, assocUsing, assocDefault, assocDefaultUsing,
-- Duplicate handling
- hasNoDups, removeDups, nubOrdBy, findDupsEq,
+ hasNoDups, removeDups, removeDupsOn, nubOrdBy, findDupsEq,
equivClasses,
-- Indexing
@@ -37,6 +37,7 @@ import GHC.Utils.Misc
import qualified Data.List as L
import qualified Data.List.NonEmpty as NE
import Data.List.NonEmpty (NonEmpty(..))
+import Data.Ord (comparing)
import qualified Data.Set as S
getNth :: Outputable a => [a] -> Int -> a
@@ -193,6 +194,9 @@ removeDups cmp xs
collect_dups dups_so_far (x :| []) = (dups_so_far, x)
collect_dups dups_so_far dups@(x :| _) = (dups:dups_so_far, x)
+removeDupsOn :: Ord b => (a -> b) -> [a] -> ([a], [NonEmpty a])
+removeDupsOn f x = removeDups (comparing f) x
+
-- | Remove the duplicates from a list using the provided
-- comparison function.
nubOrdBy :: (a -> a -> Ordering) -> [a] -> [a]
=====================================
compiler/GHC/HsToCore/Arrows.hs
=====================================
@@ -158,9 +158,9 @@ because the list of variables is typically not yet defined.
-- = case v of v { (x1, .., xn) -> body }
-- But the matching may be nested if the tuple is very big
-coreCaseTuple :: UniqSupply -> Id -> [Id] -> CoreExpr -> CoreExpr
-coreCaseTuple uniqs scrut_var vars body
- = mkBigTupleCase uniqs vars body (Var scrut_var)
+coreCaseTuple :: Id -> [Id] -> CoreExpr -> DsM CoreExpr
+coreCaseTuple scrut_var vars body
+ = mkBigTupleCase vars body (Var scrut_var)
coreCasePair :: Id -> Id -> Id -> CoreExpr -> CoreExpr
coreCasePair scrut_var var1 var2 body
@@ -231,9 +231,8 @@ matchEnvStack :: [Id] -- x1..xn
-> CoreExpr -- e
-> DsM CoreExpr
matchEnvStack env_ids stack_id body = do
- uniqs <- newUniqueSupply
tup_var <- newSysLocalDs ManyTy (mkBigCoreVarTupTy env_ids)
- let match_env = coreCaseTuple uniqs tup_var env_ids body
+ match_env <- coreCaseTuple tup_var env_ids body
pair_id <- newSysLocalDs ManyTy (mkCorePairTy (idType tup_var) (idType stack_id))
return (Lam pair_id (coreCasePair pair_id tup_var stack_id match_env))
@@ -250,9 +249,9 @@ matchEnv :: [Id] -- x1..xn
-> CoreExpr -- e
-> DsM CoreExpr
matchEnv env_ids body = do
- uniqs <- newUniqueSupply
tup_id <- newSysLocalDs ManyTy (mkBigCoreVarTupTy env_ids)
- return (Lam tup_id (coreCaseTuple uniqs tup_id env_ids body))
+ tup_case <- coreCaseTuple tup_id env_ids body
+ return (Lam tup_id tup_case)
----------------------------------------------
-- matchVarStack
@@ -957,11 +956,10 @@ dsCmdStmt ids local_vars out_ids (BindStmt _ pat cmd) env_ids = do
-- \ (p, (xs2)) -> (zs)
env_id <- newSysLocalDs ManyTy env_ty2
- uniqs <- newUniqueSupply
let
after_c_ty = mkCorePairTy pat_ty env_ty2
out_ty = mkBigCoreVarTupTy out_ids
- body_expr = coreCaseTuple uniqs env_id env_ids2 (mkBigCoreVarTup out_ids)
+ body_expr <- coreCaseTuple env_id env_ids2 (mkBigCoreVarTup out_ids)
fail_expr <- mkFailExpr (StmtCtxt (HsDoStmt (DoExpr Nothing))) out_ty
pat_id <- selectSimpleMatchVarL ManyTy pat
@@ -1029,12 +1027,11 @@ dsCmdStmt ids local_vars out_ids
-- post_loop_fn = \((later_ids),(env2_ids)) -> (out_ids)
- uniqs <- newUniqueSupply
env2_id <- newSysLocalDs ManyTy env2_ty
let
later_ty = mkBigCoreVarTupTy later_ids
post_pair_ty = mkCorePairTy later_ty env2_ty
- post_loop_body = coreCaseTuple uniqs env2_id env2_ids (mkBigCoreVarTup out_ids)
+ post_loop_body <- coreCaseTuple env2_id env2_ids (mkBigCoreVarTup out_ids)
post_loop_fn <- matchEnvStack later_ids env2_id post_loop_body
=====================================
compiler/GHC/HsToCore/ListComp.hs
=====================================
@@ -444,15 +444,13 @@ mkUnzipBind _ elt_tys
; unzip_fn <- newSysLocalDs ManyTy unzip_fn_ty
- ; [us1, us2] <- sequence [newUniqueSupply, newUniqueSupply]
-
; let nil_tuple = mkBigCoreTup (map mkNilExpr elt_tys)
concat_expressions = map mkConcatExpression (zip3 elt_tys (map Var xs) (map Var xss))
tupled_concat_expression = mkBigCoreTup concat_expressions
- folder_body_inner_case = mkBigTupleCase us1 xss tupled_concat_expression (Var axs)
- folder_body_outer_case = mkBigTupleCase us2 xs folder_body_inner_case (Var ax)
- folder_body = mkLams [ax, axs] folder_body_outer_case
+ ; folder_body_inner_case <- mkBigTupleCase xss tupled_concat_expression (Var axs)
+ ; folder_body_outer_case <- mkBigTupleCase xs folder_body_inner_case (Var ax)
+ ; let folder_body = mkLams [ax, axs] folder_body_outer_case
; unzip_body <- mkFoldrExpr elt_tuple_ty elt_list_tuple_ty folder_body nil_tuple (Var ys)
; return (Just (unzip_fn, mkLams [ys] unzip_body)) }
@@ -546,9 +544,8 @@ dsMcStmt (TransStmt { trS_stmts = stmts, trS_bndrs = bndrs
; body <- dsMcStmts stmts_rest
; n_tup_var' <- newSysLocalDs ManyTy n_tup_ty'
; tup_n_expr' <- mkMcUnzipM form fmap_op n_tup_var' from_bndr_tys
- ; us <- newUniqueSupply
; let rhs' = mkApps usingExpr' usingArgs'
- body' = mkBigTupleCase us to_bndrs body tup_n_expr'
+ ; body' <- mkBigTupleCase to_bndrs body tup_n_expr'
; dsSyntaxExpr bind_op [rhs', Lam n_tup_var' body'] }
@@ -592,9 +589,9 @@ matchTuple :: [Id] -> CoreExpr -> DsM CoreExpr
-- returns the Core term
-- \x. case x of (a,b,c) -> body
matchTuple ids body
- = do { us <- newUniqueSupply
- ; tup_id <- newSysLocalDs ManyTy (mkBigCoreVarTupTy ids)
- ; return (Lam tup_id $ mkBigTupleCase us ids body (Var tup_id)) }
+ = do { tup_id <- newSysLocalDs ManyTy (mkBigCoreVarTupTy ids)
+ ; tup_case <- mkBigTupleCase ids body (Var tup_id)
+ ; return (Lam tup_id tup_case) }
-- general `rhs' >>= \pat -> stmts` desugaring where `rhs'` is already a
-- desugared `CoreExpr`
=====================================
compiler/GHC/HsToCore/Pmc/Solver.hs
=====================================
@@ -640,8 +640,7 @@ nameTyCt :: PredType -> DsM EvVar
nameTyCt pred_ty = do
unique <- getUniqueM
let occname = mkVarOccFS (fsLit ("pm_"++show unique))
- idname = mkInternalName unique occname noSrcSpan
- return (mkLocalIdOrCoVar idname ManyTy pred_ty)
+ return (mkUserLocalOrCoVar occname unique ManyTy pred_ty noSrcSpan)
-----------------------------
-- ** Adding term constraints
=====================================
compiler/GHC/HsToCore/Pmc/Utils.hs
=====================================
@@ -51,8 +51,7 @@ traceWhenFailPm herald doc act = MaybeT $ do
mkPmId :: Type -> DsM Id
mkPmId ty = getUniqueM >>= \unique ->
let occname = mkVarOccFS $ fsLit "pm"
- name = mkInternalName unique occname noSrcSpan
- in return (mkLocalIdOrCoVar name ManyTy ty)
+ in return (mkUserLocalOrCoVar occname unique ManyTy ty noSrcSpan)
{-# NOINLINE mkPmId #-} -- We'll CPR deeply, that should be enough
-- | All warning flags that need to run the pattern match checker.
=====================================
compiler/GHC/Iface/Env.hs
=====================================
@@ -262,9 +262,9 @@ newIfaceName occ
newIfaceNames :: [OccName] -> IfL [Name]
newIfaceNames occs
- = do { uniqs <- newUniqueSupply
+ = do { uniqs <- getUniquesM
; return [ mkInternalName uniq occ noSrcSpan
- | (occ,uniq) <- occs `zip` uniqsFromSupply uniqs] }
+ | (occ,uniq) <- occs `zip` uniqs] }
trace_if :: Logger -> SDoc -> IO ()
{-# INLINE trace_if #-}
=====================================
compiler/GHC/IfaceToCore.hs
=====================================
@@ -1674,8 +1674,7 @@ tcIfaceAlt scrut mult (tycon, inst_tys) (IfaceAlt (IfaceDataAlt data_occ) arg_st
tcIfaceDataAlt :: Mult -> DataCon -> [Type] -> [FastString] -> IfaceExpr
-> IfL CoreAlt
tcIfaceDataAlt mult con inst_tys arg_strs rhs
- = do { us <- newUniqueSupply
- ; let uniqs = uniqsFromSupply us
+ = do { uniqs <- getUniquesM
; let (ex_tvs, arg_ids)
= dataConRepFSInstPat arg_strs uniqs mult con inst_tys
=====================================
compiler/GHC/Rename/Expr.hs
=====================================
@@ -64,7 +64,7 @@ import GHC.Types.Name.Reader
import GHC.Types.Unique.Set
import GHC.Types.SourceText
import GHC.Utils.Misc
-import GHC.Data.List.SetOps ( removeDups )
+import GHC.Data.List.SetOps ( removeDupsOn )
import GHC.Utils.Error
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
@@ -1305,7 +1305,7 @@ rnParallelStmts ctxt return_op segs thing_inside
-> [Name] -> [ParStmtBlock GhcPs GhcPs]
-> RnM (([ParStmtBlock GhcRn GhcRn], thing), FreeVars)
rn_segs _ bndrs_so_far []
- = do { let (bndrs', dups) = removeDups cmpByOcc bndrs_so_far
+ = do { let (bndrs', dups) = removeDupsOn nameOccName bndrs_so_far
; mapM_ dupErr dups
; (thing, fvs) <- bindLocalNames bndrs' (thing_inside bndrs')
; return (([], thing), fvs) }
@@ -1321,7 +1321,6 @@ rnParallelStmts ctxt return_op segs thing_inside
; let seg' = ParStmtBlock x stmts' used_bndrs return_op
; return ((seg':segs', thing), fvs) }
- cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2
dupErr vs = addErr $ TcRnListComprehensionDuplicateBinding (NE.head vs)
lookupQualifiedDoStmtName :: HsStmtContext GhcRn -> Name -> RnM (SyntaxExpr GhcRn, FreeVars)
=====================================
compiler/GHC/Rename/Module.hs
=====================================
@@ -62,7 +62,7 @@ import GHC.Driver.Session
import GHC.Utils.Misc ( lengthExceeds, partitionWith )
import GHC.Utils.Panic
import GHC.Driver.Env ( HscEnv(..), hsc_home_unit)
-import GHC.Data.List.SetOps ( findDupsEq, removeDups, equivClasses )
+import GHC.Data.List.SetOps ( findDupsEq, removeDupsOn, equivClasses )
import GHC.Data.Graph.Directed ( SCC, flattenSCC, flattenSCCs, Node(..)
, stronglyConnCompFromEdgedVerticesUniq )
import GHC.Types.Unique.Set
@@ -1604,7 +1604,7 @@ rnStandaloneKindSignatures
-> [LStandaloneKindSig GhcPs]
-> RnM [(LStandaloneKindSig GhcRn, FreeVars)]
rnStandaloneKindSignatures tc_names kisigs
- = do { let (no_dups, dup_kisigs) = removeDups (compare `on` get_name) kisigs
+ = do { let (no_dups, dup_kisigs) = removeDupsOn get_name kisigs
get_name = standaloneKindSigName . unLoc
; mapM_ dupKindSig_Err dup_kisigs
; mapM (wrapLocFstMA (rnStandaloneKindSignature tc_names)) no_dups
@@ -1682,7 +1682,7 @@ rnRoleAnnots :: NameSet
rnRoleAnnots tc_names role_annots
= do { -- Check for duplicates *before* renaming, to avoid
-- lumping together all the unboundNames
- let (no_dups, dup_annots) = removeDups (compare `on` get_name) role_annots
+ let (no_dups, dup_annots) = removeDupsOn get_name role_annots
get_name = roleAnnotDeclName . unLoc
; mapM_ dupRoleAnnotErr dup_annots
; mapM (wrapLocMA rn_role_annot1) no_dups }
=====================================
compiler/GHC/Rename/Utils.hs
=====================================
@@ -57,7 +57,7 @@ import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Misc
import GHC.Types.Basic ( TopLevelFlag(..), Origin(Generated) )
-import GHC.Data.List.SetOps ( removeDups )
+import GHC.Data.List.SetOps ( removeDupsOn )
import GHC.Data.Maybe ( whenIsJust )
import GHC.Driver.Session
import GHC.Data.FastString
@@ -114,14 +114,14 @@ checkDupRdrNames :: [LocatedN RdrName] -> RnM ()
checkDupRdrNames rdr_names_w_loc
= mapM_ (dupNamesErr getLocA) dups
where
- (_, dups) = removeDups (\n1 n2 -> unLoc n1 `compare` unLoc n2) rdr_names_w_loc
+ (_, dups) = removeDupsOn unLoc rdr_names_w_loc
checkDupRdrNamesN :: [LocatedN RdrName] -> RnM ()
-- Check for duplicated names in a binding group
checkDupRdrNamesN rdr_names_w_loc
= mapM_ (dupNamesErr getLocA) dups
where
- (_, dups) = removeDups (\n1 n2 -> unLoc n1 `compare` unLoc n2) rdr_names_w_loc
+ (_, dups) = removeDupsOn unLoc rdr_names_w_loc
checkDupNames :: [Name] -> RnM ()
-- Check for duplicated names in a binding group
@@ -132,7 +132,7 @@ check_dup_names :: [Name] -> RnM ()
check_dup_names names
= mapM_ (dupNamesErr nameSrcSpan) dups
where
- (_, dups) = removeDups (\n1 n2 -> nameOccName n1 `compare` nameOccName n2) names
+ (_, dups) = removeDupsOn nameOccName names
---------------------
checkShadowedRdrNames :: [LocatedN RdrName] -> RnM ()
=====================================
compiler/GHC/Stg/Lift/Monad.hs
=====================================
@@ -275,15 +275,13 @@ withSubstBndrs = runContT . traverse (ContT . withSubstBndr)
-- binder and fresh name generation.
withLiftedBndr :: DIdSet -> Id -> (Id -> LiftM a) -> LiftM a
withLiftedBndr abs_ids bndr inner = do
- uniq <- getUniqueM
let str = fsLit "$l" `appendFS` occNameFS (getOccName bndr)
let ty = mkLamTypes (dVarSetElems abs_ids) (idType bndr)
- let bndr'
+ bndr' <-
-- See Note [transferPolyIdInfo] in GHC.Types.Id. We need to do this at least
-- for arity information.
- = transferPolyIdInfo bndr (dVarSetElems abs_ids)
- . mkSysLocal str uniq ManyTy
- $ ty
+ transferPolyIdInfo bndr (dVarSetElems abs_ids)
+ <$> mkSysLocalM str ManyTy ty
LiftM $ RWS.local
(\e -> e
{ e_subst = extendSubst bndr bndr' $ extendInScope bndr' $ e_subst e
=====================================
compiler/GHC/SysTools/Terminal.hs
=====================================
@@ -5,6 +5,7 @@ module GHC.SysTools.Terminal (stderrSupportsAnsiColors) where
import GHC.Prelude
#if !defined(mingw32_HOST_OS)
+import System.Environment (lookupEnv)
import System.IO (hIsTerminalDevice, stderr)
#else
import GHC.IO (catchException)
@@ -36,8 +37,10 @@ stderrSupportsAnsiColors = unsafePerformIO stderrSupportsAnsiColors'
stderrSupportsAnsiColors' :: IO Bool
stderrSupportsAnsiColors' = do
#if !defined(mingw32_HOST_OS)
- -- Coloured text is a part of ANSI standard, no reason to query terminfo
- hIsTerminalDevice stderr
+ -- Equivalent of https://hackage.haskell.org/package/ansi-terminal/docs/System-Console-ANSI.html#v:hSupportsANSI
+ isTerminal <- hIsTerminalDevice stderr
+ term <- lookupEnv "TERM"
+ pure $ isTerminal && term /= Just "dumb"
#else
h <- Win32.getStdHandle Win32.sTD_ERROR_HANDLE
`catchException` \ (_ :: IOError) ->
=====================================
compiler/GHC/Tc/Gen/HsType.hs
=====================================
@@ -3692,14 +3692,13 @@ splitTyConKind :: SkolemInfo
-- See also Note [Datatype return kinds] in GHC.Tc.TyCl
splitTyConKind skol_info in_scope avoid_occs kind
= do { loc <- getSrcSpanM
- ; uniqs <- newUniqueSupply
+ ; new_uniqs <- getUniquesM
; rdr_env <- getLocalRdrEnv
; lvl <- getTcLevel
; let new_occs = Inf.filter (\ occ ->
isNothing (lookupLocalRdrOcc rdr_env occ) &&
-- Note [Avoid name clashes for associated data types]
not (occ `elem` avoid_occs)) $ mkOccName tvName <$> allNameStrings
- new_uniqs = uniqsFromSupply uniqs
subst = mkEmptySubst in_scope
details = SkolemTv skol_info (pushTcLevel lvl) False
-- As always, allocate skolems one level in
=====================================
compiler/GHC/Tc/Utils/Monad.hs
=====================================
@@ -729,9 +729,9 @@ newSysLocalId fs w ty
newSysLocalIds :: FastString -> [Scaled TcType] -> TcRnIf gbl lcl [TcId]
newSysLocalIds fs tys
- = do { us <- newUniqueSupply
+ = do { us <- getUniquesM
; let mkId' n (Scaled w t) = mkSysLocal fs n w t
- ; return (zipWith mkId' (uniqsFromSupply us) tys) }
+ ; return (zipWith mkId' us tys) }
instance MonadUnique (IOEnv (Env gbl lcl)) where
getUniqueM = newUnique
=====================================
compiler/GHC/Tc/Utils/TcMType.hs
=====================================
@@ -770,13 +770,11 @@ newMetaTyVarName :: FastString -> TcM Name
-- the unifier; see GHC.Tc.Utils.Unify.nicer_to_update_tv1, and
-- GHC.Tc.Solver.Canonical.canEqTyVarTyVar (nicer_to_update_tv2)
newMetaTyVarName str
- = do { uniq <- newUnique
- ; return (mkSystemName uniq (mkTyVarOccFS str)) }
+ = newSysName (mkTyVarOccFS str)
cloneMetaTyVarName :: Name -> TcM Name
cloneMetaTyVarName name
- = do { uniq <- newUnique
- ; return (mkSystemName uniq (nameOccName name)) }
+ = newSysName (nameOccName name)
-- See Note [Name of an instantiated type variable]
{- Note [Name of an instantiated type variable]
=====================================
libraries/base/GHC/Int.hs
=====================================
@@ -194,29 +194,29 @@ instance Bits Int8 where
{-# INLINE testBit #-}
{-# INLINE popCount #-}
- (I8# x#) .&. (I8# y#) = I8# (word8ToInt8# (int8ToWord8# x# `andWord8#` int8ToWord8# y#))
- (I8# x#) .|. (I8# y#) = I8# (word8ToInt8# (int8ToWord8# x# `orWord8#` int8ToWord8# y#))
- (I8# x#) `xor` (I8# y#) = I8# (word8ToInt8# (int8ToWord8# x# `xorWord8#` int8ToWord8# y#))
- complement (I8# x#) = I8# (word8ToInt8# (notWord8# (int8ToWord8# x#)))
+ (I8# x#) .&. (I8# y#) = I8# (intToInt8# ((int8ToInt# x#) `andI#` (int8ToInt# y#)))
+ (I8# x#) .|. (I8# y#) = I8# (intToInt8# ((int8ToInt# x#) `orI#` (int8ToInt# y#)))
+ (I8# x#) `xor` (I8# y#) = I8# (intToInt8# ((int8ToInt# x#) `xorI#` (int8ToInt# y#)))
+ complement (I8# x#) = I8# (intToInt8# (notI# (int8ToInt# x#)))
(I8# x#) `shift` (I# i#)
- | isTrue# (i# >=# 0#) = I8# (x# `shiftLInt8#` i#)
- | otherwise = I8# (x# `shiftRAInt8#` negateInt# i#)
+ | isTrue# (i# >=# 0#) = I8# (intToInt8# ((int8ToInt# x#) `iShiftL#` i#))
+ | otherwise = I8# (intToInt8# ((int8ToInt# x#) `iShiftRA#` negateInt# i#))
(I8# x#) `shiftL` (I# i#)
- | isTrue# (i# >=# 0#) = I8# (x# `shiftLInt8#` i#)
+ | isTrue# (i# >=# 0#) = I8# (intToInt8# ((int8ToInt# x#) `iShiftL#` i#))
| otherwise = overflowError
- (I8# x#) `unsafeShiftL` (I# i#) = I8# (x# `uncheckedShiftLInt8#` i#)
+ (I8# x#) `unsafeShiftL` (I# i#) = I8# (intToInt8# ((int8ToInt# x#) `uncheckedIShiftL#` i#))
(I8# x#) `shiftR` (I# i#)
- | isTrue# (i# >=# 0#) = I8# (x# `shiftRAInt8#` i#)
+ | isTrue# (i# >=# 0#) = I8# (intToInt8# ((int8ToInt# x#) `iShiftRA#` i#))
| otherwise = overflowError
- (I8# x#) `unsafeShiftR` (I# i#) = I8# (x# `uncheckedShiftRAInt8#` i#)
+ (I8# x#) `unsafeShiftR` (I# i#) = I8# (intToInt8# ((int8ToInt# x#) `uncheckedIShiftRA#` i#))
(I8# x#) `rotate` (I# i#)
| isTrue# (i'# ==# 0#)
= I8# x#
| otherwise
- = I8# (word8ToInt8# ((x'# `uncheckedShiftLWord8#` i'#) `orWord8#`
- (x'# `uncheckedShiftRLWord8#` (8# -# i'#))))
+ = I8# (intToInt8# (word2Int# ((x'# `uncheckedShiftL#` i'#) `or#`
+ (x'# `uncheckedShiftRL#` (8# -# i'#)))))
where
- !x'# = int8ToWord8# x#
+ !x'# = narrow8Word# (int2Word# (int8ToInt# x#))
!i'# = word2Int# (int2Word# i# `and#` 7##)
bitSizeMaybe i = Just (finiteBitSize i)
bitSize i = finiteBitSize i
@@ -405,29 +405,29 @@ instance Bits Int16 where
{-# INLINE testBit #-}
{-# INLINE popCount #-}
- (I16# x#) .&. (I16# y#) = I16# (word16ToInt16# (int16ToWord16# x# `andWord16#` int16ToWord16# y#))
- (I16# x#) .|. (I16# y#) = I16# (word16ToInt16# (int16ToWord16# x# `orWord16#` int16ToWord16# y#))
- (I16# x#) `xor` (I16# y#) = I16# (word16ToInt16# (int16ToWord16# x# `xorWord16#` int16ToWord16# y#))
- complement (I16# x#) = I16# (word16ToInt16# (notWord16# (int16ToWord16# x#)))
+ (I16# x#) .&. (I16# y#) = I16# (intToInt16# ((int16ToInt# x#) `andI#` (int16ToInt# y#)))
+ (I16# x#) .|. (I16# y#) = I16# (intToInt16# ((int16ToInt# x#) `orI#` (int16ToInt# y#)))
+ (I16# x#) `xor` (I16# y#) = I16# (intToInt16# ((int16ToInt# x#) `xorI#` (int16ToInt# y#)))
+ complement (I16# x#) = I16# (intToInt16# (notI# (int16ToInt# x#)))
(I16# x#) `shift` (I# i#)
- | isTrue# (i# >=# 0#) = I16# (x# `shiftLInt16#` i#)
- | otherwise = I16# (x# `shiftRAInt16#` negateInt# i#)
+ | isTrue# (i# >=# 0#) = I16# (intToInt16# ((int16ToInt# x#) `iShiftL#` i#))
+ | otherwise = I16# (intToInt16# ((int16ToInt# x#) `iShiftRA#` negateInt# i#))
(I16# x#) `shiftL` (I# i#)
- | isTrue# (i# >=# 0#) = I16# (x# `shiftLInt16#` i#)
+ | isTrue# (i# >=# 0#) = I16# (intToInt16# ((int16ToInt# x#) `iShiftL#` i#))
| otherwise = overflowError
- (I16# x#) `unsafeShiftL` (I# i#) = I16# (x# `uncheckedShiftLInt16#` i#)
+ (I16# x#) `unsafeShiftL` (I# i#) = I16# (intToInt16# ((int16ToInt# x#) `uncheckedIShiftL#` i#))
(I16# x#) `shiftR` (I# i#)
- | isTrue# (i# >=# 0#) = I16# (x# `shiftRAInt16#` i#)
+ | isTrue# (i# >=# 0#) = I16# (intToInt16# ((int16ToInt# x#) `iShiftRA#` i#))
| otherwise = overflowError
- (I16# x#) `unsafeShiftR` (I# i#) = I16# (x# `uncheckedShiftRAInt16#` i#)
+ (I16# x#) `unsafeShiftR` (I# i#) = I16# (intToInt16# ((int16ToInt# x#) `uncheckedIShiftRA#` i#))
(I16# x#) `rotate` (I# i#)
| isTrue# (i'# ==# 0#)
= I16# x#
| otherwise
- = I16# (word16ToInt16# ((x'# `uncheckedShiftLWord16#` i'#) `orWord16#`
- (x'# `uncheckedShiftRLWord16#` (16# -# i'#))))
+ = I16# (intToInt16# (word2Int# ((x'# `uncheckedShiftL#` i'#) `or#`
+ (x'# `uncheckedShiftRL#` (16# -# i'#)))))
where
- !x'# = int16ToWord16# x#
+ !x'# = narrow16Word# (int2Word# (int16ToInt# x#))
!i'# = word2Int# (int2Word# i# `and#` 15##)
bitSizeMaybe i = Just (finiteBitSize i)
bitSize i = finiteBitSize i
@@ -607,25 +607,25 @@ instance Bits Int32 where
(I32# x#) `xor` (I32# y#) = I32# (intToInt32# ((int32ToInt# x#) `xorI#` (int32ToInt# y#)))
complement (I32# x#) = I32# (intToInt32# (notI# (int32ToInt# x#)))
(I32# x#) `shift` (I# i#)
- | isTrue# (i# >=# 0#) = I32# (x# `shiftLInt32#` i#)
- | otherwise = I32# (x# `shiftRAInt32#` negateInt# i#)
+ | isTrue# (i# >=# 0#) = I32# (intToInt32# ((int32ToInt# x#) `iShiftL#` i#))
+ | otherwise = I32# (intToInt32# ((int32ToInt# x#) `iShiftRA#` negateInt# i#))
(I32# x#) `shiftL` (I# i#)
- | isTrue# (i# >=# 0#) = I32# (x# `shiftLInt32#` i#)
+ | isTrue# (i# >=# 0#) = I32# (intToInt32# ((int32ToInt# x#) `iShiftL#` i#))
| otherwise = overflowError
(I32# x#) `unsafeShiftL` (I# i#) =
- I32# (x# `uncheckedShiftLInt32#` i#)
+ I32# (intToInt32# ((int32ToInt# x#) `uncheckedIShiftL#` i#))
(I32# x#) `shiftR` (I# i#)
- | isTrue# (i# >=# 0#) = I32# (x# `shiftRAInt32#` i#)
+ | isTrue# (i# >=# 0#) = I32# (intToInt32# ((int32ToInt# x#) `iShiftRA#` i#))
| otherwise = overflowError
- (I32# x#) `unsafeShiftR` (I# i#) = I32# (x# `uncheckedShiftRAInt32#` i#)
+ (I32# x#) `unsafeShiftR` (I# i#) = I32# (intToInt32# ((int32ToInt# x#) `uncheckedIShiftRA#` i#))
(I32# x#) `rotate` (I# i#)
| isTrue# (i'# ==# 0#)
= I32# x#
| otherwise
- = I32# (word32ToInt32# ((x'# `uncheckedShiftLWord32#` i'#) `orWord32#`
- (x'# `uncheckedShiftRLWord32#` (32# -# i'#))))
+ = I32# (intToInt32# (word2Int# ((x'# `uncheckedShiftL#` i'#) `or#`
+ (x'# `uncheckedShiftRL#` (32# -# i'#)))))
where
- !x'# = int32ToWord32# x#
+ !x'# = narrow32Word# (int2Word# (int32ToInt# x#))
!i'# = word2Int# (int2Word# i# `and#` 31##)
bitSizeMaybe i = Just (finiteBitSize i)
bitSize i = finiteBitSize i
@@ -1095,31 +1095,10 @@ a `shiftRLInt32#` b = uncheckedShiftRLInt32# a b `andInt32#` intToInt32# (shift_
-shiftLInt8# :: Int8# -> Int# -> Int8#
-a `shiftLInt8#` b = uncheckedShiftLInt8# a b `andInt8#` intToInt8# (shift_mask 8# b)
-
-shiftLInt16# :: Int16# -> Int# -> Int16#
-a `shiftLInt16#` b = uncheckedShiftLInt16# a b `andInt16#` intToInt16# (shift_mask 16# b)
-
-shiftLInt32# :: Int32# -> Int# -> Int32#
-a `shiftLInt32#` b = uncheckedShiftLInt32# a b `andInt32#` intToInt32# (shift_mask 32# b)
-
shiftLInt64# :: Int64# -> Int# -> Int64#
a `shiftLInt64#` b = uncheckedIShiftL64# a b `andInt64#` intToInt64# (shift_mask 64# b)
-shiftRAInt8# :: Int8# -> Int# -> Int8#
-a `shiftRAInt8#` b | isTrue# (b >=# 8#) = intToInt8# (negateInt# (a `ltInt8#` (intToInt8# 0#)))
- | otherwise = a `uncheckedShiftRAInt8#` b
-
-shiftRAInt16# :: Int16# -> Int# -> Int16#
-a `shiftRAInt16#` b | isTrue# (b >=# 16#) = intToInt16# (negateInt# (a `ltInt16#` (intToInt16# 0#)))
- | otherwise = a `uncheckedShiftRAInt16#` b
-
-shiftRAInt32# :: Int32# -> Int# -> Int32#
-a `shiftRAInt32#` b | isTrue# (b >=# 32#) = intToInt32# (negateInt# (a `ltInt32#` (intToInt32# 0#)))
- | otherwise = a `uncheckedShiftRAInt32#` b
-
shiftRAInt64# :: Int64# -> Int# -> Int64#
a `shiftRAInt64#` b | isTrue# (b >=# 64#) = intToInt64# (negateInt# (a `ltInt64#` (intToInt64# 0#)))
| otherwise = a `uncheckedIShiftRA64#` b
=====================================
libraries/base/GHC/Word.hs
=====================================
@@ -184,26 +184,26 @@ instance Bits Word8 where
{-# INLINE testBit #-}
{-# INLINE popCount #-}
- (W8# x#) .&. (W8# y#) = W8# (x# `andWord8#` y#)
- (W8# x#) .|. (W8# y#) = W8# (x# `orWord8#` y#)
- (W8# x#) `xor` (W8# y#) = W8# (x# `xorWord8#` y#)
- complement (W8# x#) = W8# (notWord8# x#)
+ (W8# x#) .&. (W8# y#) = W8# (wordToWord8# ((word8ToWord# x#) `and#` (word8ToWord# y#)))
+ (W8# x#) .|. (W8# y#) = W8# (wordToWord8# ((word8ToWord# x#) `or#` (word8ToWord# y#)))
+ (W8# x#) `xor` (W8# y#) = W8# (wordToWord8# ((word8ToWord# x#) `xor#` (word8ToWord# y#)))
+ complement (W8# x#) = W8# (wordToWord8# (not# (word8ToWord# x#)))
(W8# x#) `shift` (I# i#)
- | isTrue# (i# >=# 0#) = W8# (x# `shiftLWord8#` i#)
- | otherwise = W8# (x# `shiftRLWord8#` negateInt# i#)
+ | isTrue# (i# >=# 0#) = W8# (wordToWord8# ((word8ToWord# x#) `shiftL#` i#))
+ | otherwise = W8# (wordToWord8# ((word8ToWord# x#) `shiftRL#` negateInt# i#))
(W8# x#) `shiftL` (I# i#)
- | isTrue# (i# >=# 0#) = W8# (x# `shiftLWord8#` i#)
+ | isTrue# (i# >=# 0#) = W8# (wordToWord8# ((word8ToWord# x#) `shiftL#` i#))
| otherwise = overflowError
(W8# x#) `unsafeShiftL` (I# i#) =
- W8# (x# `uncheckedShiftLWord8#` i#)
+ W8# (wordToWord8# ((word8ToWord# x#) `uncheckedShiftL#` i#))
(W8# x#) `shiftR` (I# i#)
- | isTrue# (i# >=# 0#) = W8# (x# `shiftRLWord8#` i#)
+ | isTrue# (i# >=# 0#) = W8# (wordToWord8# ((word8ToWord# x#) `shiftRL#` i#))
| otherwise = overflowError
- (W8# x#) `unsafeShiftR` (I# i#) = W8# (x# `uncheckedShiftRLWord8#` i#)
+ (W8# x#) `unsafeShiftR` (I# i#) = W8# (wordToWord8# ((word8ToWord# x#) `uncheckedShiftRL#` i#))
(W8# x#) `rotate` (I# i#)
| isTrue# (i'# ==# 0#) = W8# x#
- | otherwise = W8# ((x# `uncheckedShiftLWord8#` i'#) `orWord8#`
- (x# `uncheckedShiftRLWord8#` (8# -# i'#)))
+ | otherwise = W8# (wordToWord8# (((word8ToWord# x#) `uncheckedShiftL#` i'#) `or#`
+ ((word8ToWord# x#) `uncheckedShiftRL#` (8# -# i'#))))
where
!i'# = word2Int# (int2Word# i# `and#` 7##)
bitSizeMaybe i = Just (finiteBitSize i)
@@ -374,26 +374,26 @@ instance Bits Word16 where
{-# INLINE testBit #-}
{-# INLINE popCount #-}
- (W16# x#) .&. (W16# y#) = W16# (x# `andWord16#` y#)
- (W16# x#) .|. (W16# y#) = W16# (x# `orWord16#` y#)
- (W16# x#) `xor` (W16# y#) = W16# (x# `xorWord16#` y#)
- complement (W16# x#) = W16# (notWord16# x#)
+ (W16# x#) .&. (W16# y#) = W16# (wordToWord16# ((word16ToWord# x#) `and#` (word16ToWord# y#)))
+ (W16# x#) .|. (W16# y#) = W16# (wordToWord16# ((word16ToWord# x#) `or#` (word16ToWord# y#)))
+ (W16# x#) `xor` (W16# y#) = W16# (wordToWord16# ((word16ToWord# x#) `xor#` (word16ToWord# y#)))
+ complement (W16# x#) = W16# (wordToWord16# (not# (word16ToWord# x#)))
(W16# x#) `shift` (I# i#)
- | isTrue# (i# >=# 0#) = W16# (x# `shiftLWord16#` i#)
- | otherwise = W16# (x# `shiftRLWord16#` negateInt# i#)
+ | isTrue# (i# >=# 0#) = W16# (wordToWord16# ((word16ToWord# x#) `shiftL#` i#))
+ | otherwise = W16# (wordToWord16# ((word16ToWord# x#) `shiftRL#` negateInt# i#))
(W16# x#) `shiftL` (I# i#)
- | isTrue# (i# >=# 0#) = W16# (x# `shiftLWord16#` i#)
+ | isTrue# (i# >=# 0#) = W16# (wordToWord16# ((word16ToWord# x#) `shiftL#` i#))
| otherwise = overflowError
(W16# x#) `unsafeShiftL` (I# i#) =
- W16# (x# `uncheckedShiftLWord16#` i#)
+ W16# (wordToWord16# ((word16ToWord# x#) `uncheckedShiftL#` i#))
(W16# x#) `shiftR` (I# i#)
- | isTrue# (i# >=# 0#) = W16# (x# `shiftRLWord16#` i#)
+ | isTrue# (i# >=# 0#) = W16# (wordToWord16# ((word16ToWord# x#) `shiftRL#` i#))
| otherwise = overflowError
- (W16# x#) `unsafeShiftR` (I# i#) = W16# (x# `uncheckedShiftRLWord16#` i#)
+ (W16# x#) `unsafeShiftR` (I# i#) = W16# (wordToWord16# ((word16ToWord# x#) `uncheckedShiftRL#` i#))
(W16# x#) `rotate` (I# i#)
| isTrue# (i'# ==# 0#) = W16# x#
- | otherwise = W16# ((x# `uncheckedShiftLWord16#` i'#) `orWord16#`
- (x# `uncheckedShiftRLWord16#` (16# -# i'#)))
+ | otherwise = W16# (wordToWord16# (((word16ToWord# x#) `uncheckedShiftL#` i'#) `or#`
+ ((word16ToWord# x#) `uncheckedShiftRL#` (16# -# i'#))))
where
!i'# = word2Int# (int2Word# i# `and#` 15##)
bitSizeMaybe i = Just (finiteBitSize i)
@@ -601,26 +601,26 @@ instance Bits Word32 where
{-# INLINE testBit #-}
{-# INLINE popCount #-}
- (W32# x#) .&. (W32# y#) = W32# (x# `andWord32#` y#)
- (W32# x#) .|. (W32# y#) = W32# (x# `orWord32#` y#)
- (W32# x#) `xor` (W32# y#) = W32# (x# `xorWord32#` y#)
- complement (W32# x#) = W32# (notWord32# x#)
+ (W32# x#) .&. (W32# y#) = W32# (wordToWord32# ((word32ToWord# x#) `and#` (word32ToWord# y#)))
+ (W32# x#) .|. (W32# y#) = W32# (wordToWord32# ((word32ToWord# x#) `or#` (word32ToWord# y#)))
+ (W32# x#) `xor` (W32# y#) = W32# (wordToWord32# ((word32ToWord# x#) `xor#` (word32ToWord# y#)))
+ complement (W32# x#) = W32# (wordToWord32# (not# (word32ToWord# x#)))
(W32# x#) `shift` (I# i#)
- | isTrue# (i# >=# 0#) = W32# (x# `shiftLWord32#` i#)
- | otherwise = W32# (x# `shiftRLWord32#` negateInt# i#)
+ | isTrue# (i# >=# 0#) = W32# (wordToWord32# ((word32ToWord# x#) `shiftL#` i#))
+ | otherwise = W32# (wordToWord32# ((word32ToWord# x#) `shiftRL#` negateInt# i#))
(W32# x#) `shiftL` (I# i#)
- | isTrue# (i# >=# 0#) = W32# (x# `shiftLWord32#` i#)
+ | isTrue# (i# >=# 0#) = W32# (wordToWord32# ((word32ToWord# x#) `shiftL#` i#))
| otherwise = overflowError
(W32# x#) `unsafeShiftL` (I# i#) =
- W32# (x# `uncheckedShiftLWord32#` i#)
+ W32# (wordToWord32# ((word32ToWord# x#) `uncheckedShiftL#` i#))
(W32# x#) `shiftR` (I# i#)
- | isTrue# (i# >=# 0#) = W32# (x# `shiftRLWord32#` i#)
+ | isTrue# (i# >=# 0#) = W32# (wordToWord32# ((word32ToWord# x#) `shiftRL#` i#))
| otherwise = overflowError
- (W32# x#) `unsafeShiftR` (I# i#) = W32# (x# `uncheckedShiftRLWord32#` i#)
+ (W32# x#) `unsafeShiftR` (I# i#) = W32# (wordToWord32# ((word32ToWord# x#) `uncheckedShiftRL#` i#))
(W32# x#) `rotate` (I# i#)
| isTrue# (i'# ==# 0#) = W32# x#
- | otherwise = W32# ((x# `uncheckedShiftLWord32#` i'#) `orWord32#`
- (x# `uncheckedShiftRLWord32#` (32# -# i'#)))
+ | otherwise = W32# (wordToWord32# (((word32ToWord# x#) `uncheckedShiftL#` i'#) `or#`
+ ((word32ToWord# x#) `uncheckedShiftRL#` (32# -# i'#))))
where
!i'# = word2Int# (int2Word# i# `and#` 31##)
bitSizeMaybe i = Just (finiteBitSize i)
@@ -894,34 +894,10 @@ bitReverse64 (W64# w#) = W64# (bitReverse64# w#)
-- The following safe shift operations wrap unchecked primops to take this into
-- account: 0 is consistently returned when the shift amount is too big.
-shiftRLWord8# :: Word8# -> Int# -> Word8#
-a `shiftRLWord8#` b = uncheckedShiftRLWord8# a b
- `andWord8#` wordToWord8# (int2Word# (shift_mask 8# b))
-
-shiftRLWord16# :: Word16# -> Int# -> Word16#
-a `shiftRLWord16#` b = uncheckedShiftRLWord16# a b
- `andWord16#` wordToWord16# (int2Word# (shift_mask 16# b))
-
-shiftRLWord32# :: Word32# -> Int# -> Word32#
-a `shiftRLWord32#` b = uncheckedShiftRLWord32# a b
- `andWord32#` wordToWord32# (int2Word# (shift_mask 32# b))
-
shiftRLWord64# :: Word64# -> Int# -> Word64#
a `shiftRLWord64#` b = uncheckedShiftRL64# a b
`and64#` int64ToWord64# (intToInt64# (shift_mask 64# b))
-shiftLWord8# :: Word8# -> Int# -> Word8#
-a `shiftLWord8#` b = uncheckedShiftLWord8# a b
- `andWord8#` wordToWord8# (int2Word# (shift_mask 8# b))
-
-shiftLWord16# :: Word16# -> Int# -> Word16#
-a `shiftLWord16#` b = uncheckedShiftLWord16# a b
- `andWord16#` wordToWord16# (int2Word# (shift_mask 16# b))
-
-shiftLWord32# :: Word32# -> Int# -> Word32#
-a `shiftLWord32#` b = uncheckedShiftLWord32# a b
- `andWord32#` wordToWord32# (int2Word# (shift_mask 32# b))
-
shiftLWord64# :: Word64# -> Int# -> Word64#
a `shiftLWord64#` b = uncheckedShiftL64# a b
`and64#` int64ToWord64# (intToInt64# (shift_mask 64# b))
=====================================
libraries/base/changelog.md
=====================================
@@ -1,5 +1,10 @@
# Changelog for [`base` package](http://hackage.haskell.org/package/base)
+## 4.19.0.0 *TBA*
+ * Add `Data.List.!?` ([CLC proposal #110](https://github.com/haskell/core-libraries-committee/issues/110))
+ * `maximumBy`/`minimumBy` are now marked as `INLINE` improving performance for unpackable
+ types significantly.
+
## 4.18.0.0 *TBA*
* `Foreign.C.ConstPtr.ConstrPtr` was added to encode `const`-qualified
pointer types in foreign declarations when using `CApiFFI` extension. ([CLC proposal #117](https://github.com/haskell/core-libraries-committee/issues/117))
@@ -63,9 +68,6 @@
* Add `Data.Typeable.heqT`, a kind-heterogeneous version of
`Data.Typeable.eqT`
([CLC proposal #99](https://github.com/haskell/core-libraries-committee/issues/99))
- * Add `Data.List.!?` ([CLC proposal #110](https://github.com/haskell/core-libraries-committee/issues/110))
- * `maximumBy`/`minimumBy` are now marked as `INLINE` improving performance for unpackable
- types significantly.
## 4.17.0.0 *August 2022*
=====================================
testsuite/tests/simplCore/should_run/T20203.stderr-ws-32
=====================================
@@ -1,7 +1,7 @@
==================== Tidy Core ====================
Result size of Tidy Core
- = {terms: 290, types: 141, coercions: 0, joins: 0/0}
+ = {terms: 340, types: 140, coercions: 0, joins: 0/0}
bitOrTwoVarInt
= \ x y ->
@@ -24,33 +24,50 @@ bitOrTwoVarInt8
case x of { I8# x# ->
case y of { I8# x#1 ->
I8#
- (word8ToInt8#
- (orWord8# 17#Word8 (orWord8# (int8ToWord8# x#) (int8ToWord8# x#1))))
+ (intToInt8#
+ (orI#
+ (int8ToInt# (intToInt8# (orI# (int8ToInt# x#) 1#)))
+ (int8ToInt# (intToInt8# (orI# (int8ToInt# x#1) 16#)))))
}
}
-bitAndInt1 = I8# 0#Int8
-
bitAndTwoVarInt8
= \ x y ->
- case x of { I8# x# -> case y of { I8# x#1 -> bitAndInt1 } }
+ case x of { I8# x# ->
+ case y of { I8# x#1 ->
+ I8#
+ (intToInt8#
+ (andI#
+ (int8ToInt# (intToInt8# (andI# (int8ToInt# x#) 1#)))
+ (int8ToInt# (intToInt8# (andI# (int8ToInt# x#1) 16#)))))
+ }
+ }
bitOrInt8
= \ x ->
case x of { I8# x# ->
- I8# (word8ToInt8# (orWord8# 17#Word8 (int8ToWord8# x#)))
+ I8#
+ (intToInt8#
+ (orI# (int8ToInt# (intToInt8# (orI# (int8ToInt# x#) 1#))) 16#))
}
-bitAndInt8 = \ x -> case x of { I8# x# -> bitAndInt1 }
+bitAndInt8
+ = / x ->
+ case x of { I8# x# ->
+ I8#
+ (intToInt8#
+ (andI# (int8ToInt# (intToInt8# (andI# (int8ToInt# x#) 1#))) 16#))
+ }
bitOrTwoVarInt16
= \ x y ->
case x of { I16# x# ->
case y of { I16# x#1 ->
I16#
- (word16ToInt16#
- (orWord16#
- 255#Word16 (orWord16# (int16ToWord16# x#) (int16ToWord16# x#1))))
+ (intToInt16#
+ (orI#
+ (int16ToInt# (intToInt16# (orI# (int16ToInt# x#) 250#)))
+ (int16ToInt# (intToInt16# (orI# (int16ToInt# x#1) 175#)))))
}
}
@@ -59,22 +76,28 @@ bitAndTwoVarInt16
case x of { I16# x# ->
case y of { I16# x#1 ->
I16#
- (word16ToInt16#
- (andWord16#
- 170#Word16 (andWord16# (int16ToWord16# x#) (int16ToWord16# x#1))))
- }
+ (intToInt16#
+ (andI#
+ (int16ToInt# (intToInt16# (andI# (int16ToInt# x#) 250#)))
+ (int16ToInt# (intToInt16# (andI# (int16ToInt# x#1) 175#))))) }
}
bitOrInt16
= \ x ->
case x of { I16# x# ->
- I16# (word16ToInt16# (orWord16# 255#Word16 (int16ToWord16# x#)))
+ I16#
+ (intToInt16#
+ (orI#
+ (int16ToInt# (intToInt16# (orI# (int16ToInt# x#) 250#))) 175#))
}
bitAndInt16
= \ x ->
case x of { I16# x# ->
- I16# (word16ToInt16# (andWord16# 170#Word16 (int16ToWord16# x#)))
+ I16#
+ (intToInt16#
+ (andI#
+ (int16ToInt# (intToInt16# (andI# (int16ToInt# x#) 250#))) 175#))
}
bitOrTwoVarInt32
@@ -125,7 +148,7 @@ bitOrTwoVarInt64
case y of { I64# x#1 ->
I64#
(word64ToInt64#
- (or64# 255#Word64 (or64# (int64ToWord64# x#) (int64ToWord64# x#1))))
+ (or64# 255#Word64 (or64# (int64ToWord64# x#) (int64ToWord64# x#1))))
}
}
@@ -135,7 +158,7 @@ bitAndTwoVarInt64
case y of { I64# x#1 ->
I64#
(word64ToInt64#
- (and64# 170#Word64 (and64# (int64ToWord64# x#) (int64ToWord64# x#1))))
+ (and64# 170#Word64 (and64# (int64ToWord64# x#) (int64ToWord64# x#1))))
}
}
@@ -144,7 +167,7 @@ bitOrInt64
case x of { I64# x# ->
I64# (word64ToInt64# (or64# 255#Word64 (int64ToWord64# x#)))
}
-
+
bitAndInt64
= / x ->
case x of { I64# x# ->
=====================================
testsuite/tests/simplCore/should_run/T20203.stderr-ws-64
=====================================
@@ -1,7 +1,7 @@
==================== Tidy Core ====================
Result size of Tidy Core
- = {terms: 290, types: 141, coercions: 0, joins: 0/0}
+ = {terms: 340, types: 140, coercions: 0, joins: 0/0}
bitOrTwoVarInt
= \ x y ->
@@ -24,34 +24,50 @@ bitOrTwoVarInt8
case x of { I8# x# ->
case y of { I8# x#1 ->
I8#
- (word8ToInt8#
- (orWord8#
- 17#Word8 (orWord8# (int8ToWord8# x#) (int8ToWord8# x#1))))
+ (intToInt8#
+ (orI#
+ (int8ToInt# (intToInt8# (orI# (int8ToInt# x#) 1#)))
+ (int8ToInt# (intToInt8# (orI# (int8ToInt# x#1) 16#)))))
}
}
-bitAndInt1 = I8# 0#Int8
-
bitAndTwoVarInt8
= \ x y ->
- case x of { I8# x# -> case y of { I8# x#1 -> bitAndInt1 } }
+ case x of { I8# x# ->
+ case y of { I8# x#1 ->
+ I8#
+ (intToInt8#
+ (andI#
+ (int8ToInt# (intToInt8# (andI# (int8ToInt# x#) 1#)))
+ (int8ToInt# (intToInt8# (andI# (int8ToInt# x#1) 16#)))))
+ }
+ }
bitOrInt8
= \ x ->
case x of { I8# x# ->
- I8# (word8ToInt8# (orWord8# 17#Word8 (int8ToWord8# x#)))
+ I8#
+ (intToInt8#
+ (orI# (int8ToInt# (intToInt8# (orI# (int8ToInt# x#) 1#))) 16#))
}
-bitAndInt8 = \ x -> case x of { I8# x# -> bitAndInt1 }
+bitAndInt8
+ = \ x ->
+ case x of { I8# x# ->
+ I8#
+ (intToInt8#
+ (andI# (int8ToInt# (intToInt8# (andI# (int8ToInt# x#) 1#))) 16#))
+ }
bitOrTwoVarInt16
= \ x y ->
case x of { I16# x# ->
case y of { I16# x#1 ->
I16#
- (word16ToInt16#
- (orWord16#
- 255#Word16 (orWord16# (int16ToWord16# x#) (int16ToWord16# x#1))))
+ (intToInt16#
+ (orI#
+ (int16ToInt# (intToInt16# (orI# (int16ToInt# x#) 250#)))
+ (int16ToInt# (intToInt16# (orI# (int16ToInt# x#1) 175#)))))
}
}
@@ -60,22 +76,29 @@ bitAndTwoVarInt16
case x of { I16# x# ->
case y of { I16# x#1 ->
I16#
- (word16ToInt16#
- (andWord16#
- 170#Word16 (andWord16# (int16ToWord16# x#) (int16ToWord16# x#1))))
+ (intToInt16#
+ (andI#
+ (int16ToInt# (intToInt16# (andI# (int16ToInt# x#) 250#)))
+ (int16ToInt# (intToInt16# (andI# (int16ToInt# x#1) 175#)))))
}
}
bitOrInt16
= \ x ->
case x of { I16# x# ->
- I16# (word16ToInt16# (orWord16# 255#Word16 (int16ToWord16# x#)))
+ I16#
+ (intToInt16#
+ (orI#
+ (int16ToInt# (intToInt16# (orI# (int16ToInt# x#) 250#))) 175#))
}
bitAndInt16
= \ x ->
case x of { I16# x# ->
- I16# (word16ToInt16# (andWord16# 170#Word16 (int16ToWord16# x#)))
+ I16#
+ (intToInt16#
+ (andI#
+ (int16ToInt# (intToInt16# (andI# (int16ToInt# x#) 250#))) 175#))
}
bitOrTwoVarInt32
=====================================
utils/ghc-pkg/Main.hs
=====================================
@@ -86,6 +86,7 @@ import qualified Data.ByteString as BS
#if defined(mingw32_HOST_OS)
import GHC.ConsoleHandler
#else
+import System.Environment (lookupEnv)
import System.Posix hiding (fdToHandle)
#endif
@@ -1591,8 +1592,9 @@ listPackages verbosity my_flags mPackageName mModuleName = do
pkg = display (mungedId p)
is_tty <- hIsTerminalDevice stdout
- -- Coloured text is a part of ANSI standard, no reason to query terminfo
- mapM_ (if is_tty then show_colour else show_normal) stack
+ -- Equivalent of https://hackage.haskell.org/package/ansi-terminal/docs/System-Console-ANSI.html#v:hSupportsANSI
+ term <- lookupEnv "TERM"
+ mapM_ (if is_tty && term /= Just "dumb" then show_colour else show_normal) stack
#endif
simplePackageList :: [Flag] -> [InstalledPackageInfo] -> IO ()
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8d95d06c6c23a2577416fdff4ad0e6bc07916437...35b15d67e762520818b5983a2fabd92477bb776e
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8d95d06c6c23a2577416fdff4ad0e6bc07916437...35b15d67e762520818b5983a2fabd92477bb776e
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/20230204/7e4e9075/attachment-0001.html>
More information about the ghc-commits
mailing list