diff --git a/compiler/GHC/Cmm/ThreadSanitizer.hs b/compiler/GHC/Cmm/ThreadSanitizer.hs
index 22ffd353a8d65e3603a17baf61719da0f5ba73e1..ad33bb7f6cdff1754e6ae63233384e0961b05341 100644
--- a/compiler/GHC/Cmm/ThreadSanitizer.hs
+++ b/compiler/GHC/Cmm/ThreadSanitizer.hs
@@ -145,7 +145,7 @@ mkUnsafeCall env ftgt formals args =
-- arguments as Cmm-Lint checks this. To accomplish this we instead bind
-- the arguments to local registers.
arg_regs :: [CmmReg]
- arg_regs = zipWith arg_reg (uniqsFromSupply arg_us) args
+ arg_regs = zipWith arg_reg (uniqListFromSupply arg_us) args
where
arg_reg :: Unique -> CmmExpr -> CmmReg
arg_reg u expr = CmmLocal $ LocalReg u (cmmExprType (platform env) expr)
@@ -169,7 +169,7 @@ saveRestoreCallerRegs us platform =
nodes :: [(CmmNode O O, CmmNode O O)]
nodes =
- zipWith mk_reg regs_to_save (uniqsFromSupply us)
+ zipWith mk_reg regs_to_save (uniqListFromSupply us)
where
mk_reg :: GlobalReg -> Unique -> (CmmNode O O, CmmNode O O)
mk_reg reg u =
diff --git a/compiler/GHC/CmmToAsm/AArch64/CodeGen.hs b/compiler/GHC/CmmToAsm/AArch64/CodeGen.hs
index e3ca72f0fcdcfa21504abf993ddbf0d02c1b448c..6d642c560a5cc266dfe4ab62332d0193804922a3 100644
--- a/compiler/GHC/CmmToAsm/AArch64/CodeGen.hs
+++ b/compiler/GHC/CmmToAsm/AArch64/CodeGen.hs
@@ -1,5 +1,6 @@
{-# language GADTs, LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE LambdaCase #-}
module GHC.CmmToAsm.AArch64.CodeGen (
cmmTopCodeGen
, generateJumpTableForInstr
@@ -50,7 +51,9 @@ import GHC.Types.Unique.DSM
import GHC.Data.OrdList
import GHC.Utils.Outputable
-import Control.Monad ( mapAndUnzipM )
+import Control.Monad ( join, mapAndUnzipM )
+import Data.List.NonEmpty ( NonEmpty (..), nonEmpty )
+import qualified Data.List.NonEmpty as NE
import GHC.Float
import GHC.Types.Basic
@@ -1587,7 +1590,7 @@ genCondJump bid expr = do
_ -> pprPanic "AArch64.genCondJump: " (text $ show expr)
-- A conditional jump with at least +/-128M jump range
-genCondFarJump :: MonadGetUnique m => Cond -> Target -> m InstrBlock
+genCondFarJump :: MonadGetUnique m => Cond -> Target -> m (NonEmpty Instr)
genCondFarJump cond far_target = do
skip_lbl_id <- newBlockId
jmp_lbl_id <- newBlockId
@@ -1597,11 +1600,13 @@ genCondFarJump cond far_target = do
-- need to consider float orderings.
-- So we take the hit of the additional jump in the false
-- case for now.
- return $ toOL [ BCOND cond (TBlock jmp_lbl_id)
- , B (TBlock skip_lbl_id)
- , NEWBLOCK jmp_lbl_id
- , B far_target
- , NEWBLOCK skip_lbl_id]
+ pure
+ ( BCOND cond (TBlock jmp_lbl_id) :|
+ B (TBlock skip_lbl_id) :
+ NEWBLOCK jmp_lbl_id :
+ B far_target :
+ NEWBLOCK skip_lbl_id :
+ [] )
genCondBranch :: BlockId -- the true branch target
-> BlockId -- the false branch target
@@ -2457,48 +2462,49 @@ makeFarBranches {- only used when debugging -} _platform statics basic_blocks =
-- Replace out of range conditional jumps with unconditional jumps.
replace_blk :: LabelMap Int -> Int -> GenBasicBlock Instr -> UniqDSM (Int, [GenBasicBlock Instr])
- replace_blk !m !pos (BasicBlock lbl instrs) = do
- -- Account for a potential info table before the label.
- let !block_pos = pos + infoTblSize_maybe lbl
- (!pos', instrs') <- mapAccumLM (replace_jump m) block_pos instrs
- let instrs'' = concat instrs'
- -- We might have introduced new labels, so split the instructions into basic blocks again if neccesary.
- let (top, split_blocks, no_data) = foldr mkBlocks ([],[],[]) instrs''
- -- There should be no data in the instruction stream at this point
- massert (null no_data)
-
- let final_blocks = BasicBlock lbl top : split_blocks
- pure (pos', final_blocks)
-
- replace_jump :: LabelMap Int -> Int -> Instr -> UniqDSM (Int, [Instr])
+ replace_blk !m !pos (BasicBlock lbl instrs) = case nonEmpty instrs of
+ Nothing -> pure (0, [])
+ Just instrs -> do
+ -- Account for a potential info table before the label.
+ let !block_pos = pos + infoTblSize_maybe lbl
+ (!pos', instrs') <- mapAccumLM (replace_jump m) block_pos instrs
+ let instrs'' = join instrs'
+ -- We might have introduced new labels, so split the instructions into basic blocks again if neccesary.
+ let (top, split_blocks, no_data) = foldr mkBlocks ([],[],[]) instrs''
+ -- There should be no data in the instruction stream at this point
+ massert (null no_data)
+
+ let final_blocks = BasicBlock lbl top : split_blocks
+ pure (pos', final_blocks)
+
+ replace_jump :: LabelMap Int -> Int -> Instr -> UniqDSM (Int, NonEmpty Instr)
replace_jump !m !pos instr = do
case instr of
ANN ann instr -> do
- replace_jump m pos instr >>= \case
- (idx,instr':instrs') ->
- pure (idx, ANN ann instr':instrs')
- (idx,[]) -> pprPanic "replace_jump" (text "empty return list for " <+> ppr idx)
+ replace_jump m pos instr >>= \
+ (idx,instr':|instrs') ->
+ pure (idx, ANN ann instr':|instrs')
BCOND cond t
-> case target_in_range m t pos of
- InRange -> pure (pos+long_bc_jump_size,[instr])
+ InRange -> pure (pos+long_bc_jump_size, NE.singleton instr)
NotInRange far_target -> do
jmp_code <- genCondFarJump cond far_target
- pure (pos+long_bc_jump_size, fromOL jmp_code)
+ pure (pos+long_bc_jump_size, jmp_code)
CBZ op t -> long_zero_jump op t EQ
CBNZ op t -> long_zero_jump op t NE
instr
- | isMetaInstr instr -> pure (pos,[instr])
- | otherwise -> pure (pos+1, [instr])
+ | isMetaInstr instr -> pure (pos, NE.singleton instr)
+ | otherwise -> pure (pos+1, NE.singleton instr)
where
-- cmp_op: EQ = CBZ, NEQ = CBNZ
long_zero_jump op t cmp_op =
case target_in_range m t pos of
- InRange -> pure (pos+long_bz_jump_size,[instr])
+ InRange -> pure (pos+long_bz_jump_size, NE.singleton instr)
NotInRange far_target -> do
jmp_code <- genCondFarJump cmp_op far_target
-- TODO: Fix zero reg so we can use it here
- pure (pos + long_bz_jump_size, CMP op (OpImm (ImmInt 0)) : fromOL jmp_code)
+ pure (pos + long_bz_jump_size, CMP op (OpImm (ImmInt 0)) NE.<| jmp_code)
target_in_range :: LabelMap Int -> Target -> Int -> BlockInRange
diff --git a/compiler/GHC/Core/Opt/SetLevels.hs b/compiler/GHC/Core/Opt/SetLevels.hs
index 8948cc209579fefcf9fc602727ad98f80f87b9ea..6e3cb64d2e595e4b7b590510cf14001def2bb2ed 100644
--- a/compiler/GHC/Core/Opt/SetLevels.hs
+++ b/compiler/GHC/Core/Opt/SetLevels.hs
@@ -1,7 +1,5 @@
{-# LANGUAGE PatternSynonyms #-}
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-
{-
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
@@ -120,12 +118,16 @@ import GHC.Builtin.Types
import GHC.Builtin.Names ( runRWKey )
import GHC.Data.FastString
+import GHC.Data.Pair ( Pair (..) )
import GHC.Utils.FV
import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Utils.Panic
+import Data.Foldable ( toList )
+import Data.Functor.Identity ( Identity (..) )
+import Data.List.NonEmpty ( NonEmpty (..) )
import Data.Maybe
{-
@@ -451,14 +453,14 @@ lvlCase env scrut_fvs scrut' case_bndr ty alts
, ManyTy <- idMult case_bndr -- See Note [Floating linear case]
= -- Always float the case if possible
-- Unlike lets we don't insist that it escapes a value lambda
- do { (env1, (case_bndr' : bs')) <- cloneCaseBndrs env dest_lvl (case_bndr : bs)
+ do { (env1, case_bndr' :| bs') <- cloneCaseBndrs env dest_lvl (case_bndr :| bs)
; let rhs_env = extendCaseBndrEnv env1 case_bndr scrut'
; body' <- lvlMFE rhs_env True body
; let alt' = Alt con (map (stayPut dest_lvl) bs') body'
; return (Case scrut' (TB case_bndr' (FloatMe dest_lvl)) ty' [alt']) }
| otherwise -- Stays put
- = do { let (alts_env1, [case_bndr']) = substAndLvlBndrs NonRecursive env incd_lvl [case_bndr]
+ = do { let (alts_env1, Identity case_bndr') = substAndLvlBndrs NonRecursive env incd_lvl (Identity case_bndr)
alts_env = extendCaseBndrEnv alts_env1 case_bndr scrut'
; alts' <- mapM (lvl_alt alts_env) alts
; return (Case scrut' case_bndr' ty' alts') }
@@ -649,7 +651,7 @@ lvlMFE env strict_ctxt ann_expr
-- See Note [Test cheapness with exprOkForSpeculation]
, BI_Box { bi_data_con = box_dc, bi_inst_con = boxing_expr
, bi_boxed_type = box_ty } <- boxingDataCon expr_ty
- , let [bx_bndr, ubx_bndr] = mkTemplateLocals [box_ty, expr_ty]
+ , let Pair bx_bndr ubx_bndr = mkTemplateLocals (Pair box_ty expr_ty)
= do { expr1 <- lvlExpr rhs_env ann_expr
; let l1r = incMinorLvlFrom rhs_env
float_rhs = mkLams abs_vars_w_lvls $
@@ -1227,7 +1229,7 @@ lvlBind env (AnnNonRec bndr rhs)
= -- No float
do { rhs' <- lvlRhs env NonRecursive is_bot_lam mb_join_arity rhs
; let bind_lvl = incMinorLvl (le_ctxt_lvl env)
- (env', [bndr']) = substAndLvlBndrs NonRecursive env bind_lvl [bndr]
+ (env', Identity bndr') = substAndLvlBndrs NonRecursive env bind_lvl (Identity bndr)
; return (NonRec bndr' rhs', env') }
-- Otherwise we are going to float
@@ -1235,7 +1237,7 @@ lvlBind env (AnnNonRec bndr rhs)
= do { -- No type abstraction; clone existing binder
rhs' <- lvlFloatRhs [] dest_lvl env NonRecursive
is_bot_lam NotJoinPoint rhs
- ; (env', [bndr']) <- cloneLetVars NonRecursive env dest_lvl [bndr]
+ ; (env', Identity bndr') <- cloneLetVars NonRecursive env dest_lvl (Identity bndr)
; let bndr2 = annotateBotStr bndr' 0 mb_bot_str
; return (NonRec (TB bndr2 (FloatMe dest_lvl)) rhs', env') }
@@ -1243,7 +1245,7 @@ lvlBind env (AnnNonRec bndr rhs)
= do { -- Yes, type abstraction; create a new binder, extend substitution, etc
rhs' <- lvlFloatRhs abs_vars dest_lvl env NonRecursive
is_bot_lam NotJoinPoint rhs
- ; (env', [bndr']) <- newPolyBndrs dest_lvl env abs_vars [bndr]
+ ; (env', Identity bndr') <- newPolyBndrs dest_lvl env abs_vars (Identity bndr)
; let bndr2 = annotateBotStr bndr' n_extra mb_bot_str
; return (NonRec (TB bndr2 (FloatMe dest_lvl)) rhs', env') }
@@ -1301,13 +1303,13 @@ lvlBind env (AnnRec pairs)
let (rhs_env, abs_vars_w_lvls) = lvlLamBndrs env dest_lvl abs_vars
rhs_lvl = le_ctxt_lvl rhs_env
- (rhs_env', [new_bndr]) <- cloneLetVars Recursive rhs_env rhs_lvl [bndr]
+ (rhs_env', Identity new_bndr) <- cloneLetVars Recursive rhs_env rhs_lvl (Identity bndr)
let
(lam_bndrs, rhs_body) = collectAnnBndrs rhs
(body_env1, lam_bndrs1) = substBndrsSL NonRecursive rhs_env' lam_bndrs
(body_env2, lam_bndrs2) = lvlLamBndrs body_env1 rhs_lvl lam_bndrs1
new_rhs_body <- lvlRhs body_env2 Recursive is_bot NotJoinPoint rhs_body
- (poly_env, [poly_bndr]) <- newPolyBndrs dest_lvl env abs_vars [bndr]
+ (poly_env, Identity poly_bndr) <- newPolyBndrs dest_lvl env abs_vars (Identity bndr)
return (Rec [(TB poly_bndr (FloatMe dest_lvl)
, mkLams abs_vars_w_lvls $
mkLams lam_bndrs2 $
@@ -1479,24 +1481,26 @@ Use lvlExpr otherwise. A little subtle, and I got it wrong at least twice
************************************************************************
-}
-substAndLvlBndrs :: RecFlag -> LevelEnv -> Level -> [InVar] -> (LevelEnv, [LevelledBndr])
+substAndLvlBndrs :: Traversable f => RecFlag -> LevelEnv -> Level -> f InVar -> (LevelEnv, f LevelledBndr)
substAndLvlBndrs is_rec env lvl bndrs
= lvlBndrs subst_env lvl subst_bndrs
where
(subst_env, subst_bndrs) = substBndrsSL is_rec env bndrs
+{-# INLINE substAndLvlBndrs #-}
-substBndrsSL :: RecFlag -> LevelEnv -> [InVar] -> (LevelEnv, [OutVar])
+substBndrsSL :: Traversable f => RecFlag -> LevelEnv -> f InVar -> (LevelEnv, f OutVar)
-- So named only to avoid the name clash with GHC.Core.Subst.substBndrs
substBndrsSL is_rec env@(LE { le_subst = subst, le_env = id_env }) bndrs
= ( env { le_subst = subst'
- , le_env = foldl' add_id id_env (bndrs `zip` bndrs') }
+ , le_env = foldl' add_id id_env (toList bndrs `zip` toList bndrs') }
, bndrs')
where
(subst', bndrs') = case is_rec of
NonRecursive -> substBndrs subst bndrs
Recursive -> substRecBndrs subst bndrs
+{-# INLINE substBndrsSL #-}
-lvlLamBndrs :: LevelEnv -> Level -> [OutVar] -> (LevelEnv, [LevelledBndr])
+lvlLamBndrs :: Traversable f => LevelEnv -> Level -> f OutVar -> (LevelEnv, f LevelledBndr)
-- Compute the levels for the binders of a lambda group
lvlLamBndrs env lvl bndrs
= lvlBndrs env new_lvl bndrs
@@ -1510,17 +1514,18 @@ lvlLamBndrs env lvl bndrs
-- true of a type variable -- there is no point in floating
-- out of a big lambda.
-- See Note [Computing one-shot info] in GHC.Types.Demand
+{-# INLINE lvlLamBndrs #-}
-lvlJoinBndrs :: LevelEnv -> Level -> RecFlag -> [OutVar]
- -> (LevelEnv, [LevelledBndr])
-lvlJoinBndrs env lvl rec bndrs
- = lvlBndrs env new_lvl bndrs
+lvlJoinBndrs :: Traversable f => LevelEnv -> Level -> RecFlag -> f OutVar
+ -> (LevelEnv, f LevelledBndr)
+lvlJoinBndrs env lvl rec = lvlBndrs env new_lvl
where
new_lvl | isRec rec = incMajorLvl lvl
| otherwise = incMinorLvl lvl
-- Non-recursive join points are one-shot; recursive ones are not
+{-# INLINE lvlJoinBndrs #-}
-lvlBndrs :: LevelEnv -> Level -> [CoreBndr] -> (LevelEnv, [LevelledBndr])
+lvlBndrs :: Traversable f => LevelEnv -> Level -> f CoreBndr -> (LevelEnv, f LevelledBndr)
-- The binders returned are exactly the same as the ones passed,
-- apart from applying the substitution, but they are now paired
-- with a (StayPut level)
@@ -1533,7 +1538,8 @@ lvlBndrs :: LevelEnv -> Level -> [CoreBndr] -> (LevelEnv, [LevelledBndr])
lvlBndrs env@(LE { le_lvl_env = lvl_env }) new_lvl bndrs
= ( env { le_ctxt_lvl = new_lvl
, le_lvl_env = addLvls new_lvl lvl_env bndrs }
- , map (stayPut new_lvl) bndrs)
+ , fmap (stayPut new_lvl) bndrs)
+{-# INLINE lvlBndrs #-}
stayPut :: Level -> OutVar -> LevelledBndr
stayPut new_lvl bndr = TB bndr (StayPut new_lvl)
@@ -1693,8 +1699,8 @@ initialEnv float_lams binds
addLvl :: Level -> VarEnv Level -> OutVar -> VarEnv Level
addLvl dest_lvl env v' = extendVarEnv env v' dest_lvl
-addLvls :: Level -> VarEnv Level -> [OutVar] -> VarEnv Level
-addLvls dest_lvl env vs = foldl' (addLvl dest_lvl) env vs
+addLvls :: Foldable f => Level -> VarEnv Level -> f OutVar -> VarEnv Level
+addLvls = foldl' . addLvl
floatLams :: LevelEnv -> Maybe Int
floatLams le = floatOutLambdas (le_switches le)
@@ -1792,17 +1798,15 @@ type LvlM result = UniqSM result
initLvl :: UniqSupply -> UniqSM a -> a
initLvl = initUs_
-newPolyBndrs :: Level -> LevelEnv -> [OutVar] -> [InId]
- -> LvlM (LevelEnv, [OutId])
+newPolyBndrs :: (MonadUnique m, Traversable t) => Level -> LevelEnv -> [OutVar] -> t InId -> m (LevelEnv, t OutId)
-- The envt is extended to bind the new bndrs to dest_lvl, but
-- the le_ctxt_lvl is unaffected
newPolyBndrs dest_lvl
env@(LE { le_lvl_env = lvl_env, le_subst = subst, le_env = id_env })
abs_vars bndrs
= assert (all (not . isCoVar) bndrs) $ -- What would we add to the CoSubst in this case. No easy answer.
- do { uniqs <- getUniquesM
- ; let new_bndrs = zipWith mk_poly_bndr bndrs uniqs
- bndr_prs = bndrs `zip` new_bndrs
+ do { bndr_prs <- withUniquesM (\ uniq bndr -> (bndr, mk_poly_bndr bndr uniq)) bndrs
+ ; let new_bndrs = fmap snd bndr_prs
env' = env { le_lvl_env = addLvls dest_lvl lvl_env new_bndrs
, le_subst = foldl' add_subst subst bndr_prs
, le_env = foldl' add_id id_env bndr_prs }
@@ -1828,6 +1832,10 @@ newPolyBndrs dest_lvl
= new_bndr `asJoinId` join_arity + length abs_vars
| otherwise
= new_bndr
+{-# SPECIALIZE newPolyBndrs :: (MonadUnique m) => Level -> LevelEnv -> [OutVar] -> [InId] -> m (LevelEnv, [OutId]) #-}
+{-# SPECIALIZE newPolyBndrs :: (MonadUnique m) => Level -> LevelEnv -> [OutVar] -> Identity InId -> m (LevelEnv, Identity OutId) #-}
+{-# SPECIALIZE newPolyBndrs :: (MonadUnique m) => Level -> LevelEnv -> [OutVar] -> NonEmpty InId -> m (LevelEnv, NonEmpty OutId) #-}
+{-# SPECIALIZE newPolyBndrs :: (MonadUnique m) => Level -> LevelEnv -> [OutVar] -> Pair InId -> m (LevelEnv, Pair OutId) #-}
newLvlVar :: LevelledExpr -- The RHS of the new binding
-> JoinPointHood -- Its join arity, if it is a join point
@@ -1851,7 +1859,7 @@ newLvlVar lvld_rhs join_arity_maybe is_mk_static
= mkSysLocal (mkFastString "lvl") uniq ManyTy rhs_ty
-- | Clone the binders bound by a single-alternative case.
-cloneCaseBndrs :: LevelEnv -> Level -> [Var] -> LvlM (LevelEnv, [Var])
+cloneCaseBndrs :: Traversable t => LevelEnv -> Level -> t Var -> LvlM (LevelEnv, t Var)
cloneCaseBndrs env@(LE { le_subst = subst, le_lvl_env = lvl_env, le_env = id_env })
new_lvl vs
= do { (subst', vs') <- cloneBndrsM subst vs
@@ -1860,12 +1868,11 @@ cloneCaseBndrs env@(LE { le_subst = subst, le_lvl_env = lvl_env, le_env = id_env
-- See Note [Setting levels when floating single-alternative cases].
; 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') }
-
+ , le_env = foldl' add_id id_env (toList vs `zip` toList vs') }
; return (env', vs') }
-cloneLetVars :: RecFlag -> LevelEnv -> Level -> [InVar]
- -> LvlM (LevelEnv, [OutVar])
+cloneLetVars
+ :: Traversable t => RecFlag -> LevelEnv -> Level -> t InVar -> LvlM (LevelEnv, t OutVar)
-- See Note [Need for cloning during float-out]
-- Works for Ids bound by let(rec)
-- The dest_lvl is attributed to the binders in the new env,
@@ -1873,12 +1880,12 @@ 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 { let vs1 = map zap vs
+ = do { let vs1 = fmap zap vs
; (subst', vs2) <- case is_rec of
NonRecursive -> cloneBndrsM subst vs1
Recursive -> cloneRecIdBndrsM subst vs1
- ; let prs = vs `zip` vs2
+ ; let prs = toList vs `zip` toList vs2
env' = env { le_lvl_env = addLvls dest_lvl lvl_env vs2
, le_subst = subst'
, le_env = foldl' add_id id_env prs }
@@ -1894,6 +1901,10 @@ cloneLetVars is_rec
-- See Note [Zapping JoinId when floating]
zap_join | isTopLvl dest_lvl = zapJoinId
| otherwise = id
+{-# SPECIALIZE cloneLetVars :: RecFlag -> LevelEnv -> Level -> [InVar] -> LvlM (LevelEnv, [OutVar]) #-}
+{-# SPECIALIZE cloneLetVars :: RecFlag -> LevelEnv -> Level -> Identity InVar -> LvlM (LevelEnv, Identity OutVar) #-}
+{-# SPECIALIZE cloneLetVars :: RecFlag -> LevelEnv -> Level -> NonEmpty InVar -> LvlM (LevelEnv, NonEmpty OutVar) #-}
+{-# SPECIALIZE cloneLetVars :: RecFlag -> LevelEnv -> Level -> Pair InVar -> LvlM (LevelEnv, Pair OutVar) #-}
add_id :: IdEnv ([Var], LevelledExpr) -> (Var, Var) -> IdEnv ([Var], LevelledExpr)
add_id id_env (v, v1)
diff --git a/compiler/GHC/Core/Opt/Simplify/Utils.hs b/compiler/GHC/Core/Opt/Simplify/Utils.hs
index e07dd57a30bb8a39f22de19d8a0f57da03a3f409..85ff74b8bd4364b1341ad40bc903aee56cc6405e 100644
--- a/compiler/GHC/Core/Opt/Simplify/Utils.hs
+++ b/compiler/GHC/Core/Opt/Simplify/Utils.hs
@@ -2414,7 +2414,7 @@ prepareAlts :: OutExpr -> InId -> [InAlt] -> SimplM ([AltCon], [InAlt])
-- Note that case_bndr is an InId; see Note [Shadowing in prepareAlts]
prepareAlts scrut case_bndr alts
| Just (tc, tys) <- splitTyConApp_maybe (idType case_bndr)
- = do { us <- getUniquesM
+ = do { us <- getUniqueListM
; let (idcs1, alts1) = filterAlts tc tys imposs_cons alts
(yes2, alts2) = refineDefaultAlt us (idMult case_bndr) tc tys idcs1 alts1
-- The multiplicity on case_bndr's is the multiplicity of the
@@ -2765,7 +2765,7 @@ mkCase2 mode scrut bndr alts_ty alts
| not (isNullaryRepDataCon dc)
= -- For non-nullary data cons we must invent some fake binders
-- See Note [caseRules for dataToTag] in GHC.Core.Opt.ConstantFold
- do { us <- getUniquesM
+ do { us <- getUniqueListM
; let (ex_tvs, arg_ids) = dataConRepInstPat us (idMult new_bndr) dc
(tyConAppArgs (idType new_bndr))
; return (ex_tvs ++ arg_ids) }
diff --git a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs
index 94dd2a1fe4a0972f3647029a06bf84b8e9e2d020..16f038649b707237603ad00cf2d7ea33ff79b618 100644
--- a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs
+++ b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs
@@ -971,7 +971,7 @@ unbox_one_arg :: WwOpts
unbox_one_arg opts arg_var
DataConPatContext { dcpc_dc = dc, dcpc_tc_args = tc_args
, dcpc_co = co, dcpc_args = ds }
- = do { pat_bndrs_uniqs <- getUniquesM
+ = do { pat_bndrs_uniqs <- getUniqueListM
; let ex_name_fss = map getOccFS $ dataConExTyCoVars dc
-- Create new arguments we get when unboxing dc
@@ -1563,7 +1563,7 @@ unbox_one_result opts res_bndr
-- ( case i of I# a -> ) |
-- ( case j of I# b -> ) | ( (<i>, <j>) )
-- ( <hole> ) |
- pat_bndrs_uniqs <- getUniquesM
+ pat_bndrs_uniqs <- getUniqueListM
let (_exs, arg_ids) =
dataConRepFSInstPat (repeat ww_prefix) pat_bndrs_uniqs cprCaseBndrMult dc tc_args
massert (null _exs) -- Should have been caught by canUnboxResult
diff --git a/compiler/GHC/Core/Subst.hs b/compiler/GHC/Core/Subst.hs
index 7df997412d38f08dcb5e978309df377248396d8b..e3f4df4af5d95715ef4d0a8e2345ddc27b4fffd1 100644
--- a/compiler/GHC/Core/Subst.hs
+++ b/compiler/GHC/Core/Subst.hs
@@ -415,20 +415,23 @@ cloneIdBndr subst us old_id
-- | Applies 'cloneIdBndr' to a number of 'Id's, accumulating a final
-- substitution from left to right
-- Discards non-Stable unfoldings
-cloneIdBndrs :: Subst -> UniqSupply -> [Id] -> (Subst, [Id])
+cloneIdBndrs :: Traversable t => Subst -> UniqSupply -> t Id -> (Subst, t Id)
cloneIdBndrs subst us ids
- = mapAccumL (clone_id subst) subst (ids `zip` uniqsFromSupply us)
+ = mapAccumL (clone_id subst) subst (withUniques (flip (,)) us ids)
+{-# SPECIALIZE cloneIdBndrs :: Subst -> UniqSupply -> [Id] -> (Subst, [Id]) #-}
-cloneBndrs :: Subst -> UniqSupply -> [Var] -> (Subst, [Var])
+cloneBndrs :: Traversable t => Subst -> UniqSupply -> t Var -> (Subst, t 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)
+ = mapAccumL (\subst (v, u) -> cloneBndr subst u v) subst (withUniques (flip (,)) us vs)
+{-# SPECIALIZE cloneBndrs :: Subst -> UniqSupply -> [Var] -> (Subst, [Var]) #-}
-cloneBndrsM :: MonadUnique m => Subst -> [Var] -> m (Subst, [Var])
+cloneBndrsM :: (Traversable t, MonadUnique m) => Subst -> t Var -> m (Subst, t Var)
-- Works for all kinds of variables (typically case binders)
-- not just Ids
cloneBndrsM subst vs = cloneBndrs subst `flip` vs <$> getUniqueSupplyM
+{-# INLINE cloneBndrsM #-}
cloneBndr :: Subst -> Unique -> Var -> (Subst, Var)
cloneBndr subst uniq v
@@ -436,14 +439,16 @@ 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 :: Traversable t => Subst -> UniqSupply -> t Id -> (Subst, t Id)
cloneRecIdBndrs subst us ids =
- let x@(subst', _) = mapAccumL (clone_id subst') subst (ids `zip` uniqsFromSupply us)
+ let x@(subst', _) = mapAccumL (clone_id subst') subst (withUniques (flip (,)) us ids)
in x
+{-# SPECIALIZE cloneRecIdBndrs :: Subst -> UniqSupply -> [Id] -> (Subst, [Id]) #-}
-- | Clone a mutually recursive group of 'Id's
-cloneRecIdBndrsM :: MonadUnique m => Subst -> [Id] -> m (Subst, [Id])
+cloneRecIdBndrsM :: (Traversable t, MonadUnique m) => Subst -> t Id -> m (Subst, t Id)
cloneRecIdBndrsM subst ids = cloneRecIdBndrs subst `flip` ids <$> getUniqueSupplyM
+{-# INLINE cloneRecIdBndrsM #-}
-- Just like substIdBndr, except that it always makes a new unique
-- It is given the unique to use
diff --git a/compiler/GHC/Iface/Env.hs b/compiler/GHC/Iface/Env.hs
index 430fdcbdcc57013b3edfc485a862a7c6709d6a53..2fea7626d983ac8645314309ae957ed29fdd845b 100644
--- a/compiler/GHC/Iface/Env.hs
+++ b/compiler/GHC/Iface/Env.hs
@@ -262,11 +262,9 @@ newIfaceName occ
= do { uniq <- newUnique
; return $! mkInternalName uniq occ noSrcSpan }
-newIfaceNames :: [OccName] -> IfL [Name]
-newIfaceNames occs
- = do { uniqs <- getUniquesM
- ; return [ mkInternalName uniq occ noSrcSpan
- | (occ,uniq) <- occs `zip` uniqs] }
+newIfaceNames :: Traversable t => t OccName -> IfL (t Name)
+newIfaceNames = withUniquesM (\ uniq occ -> mkInternalName uniq occ noSrcSpan)
+{-# INLINE newIfaceNames #-}
trace_if :: Logger -> SDoc -> IO ()
{-# INLINE trace_if #-} -- see Note [INLINE conditional tracing utilities]
diff --git a/compiler/GHC/IfaceToCore.hs b/compiler/GHC/IfaceToCore.hs
index 71eb13855887b2292721d1233a8b13a8cebbafe1..6df6812b75a44521f98c0bda997da9b2f3f1dbcd 100644
--- a/compiler/GHC/IfaceToCore.hs
+++ b/compiler/GHC/IfaceToCore.hs
@@ -1721,7 +1721,7 @@ tcIfaceAlt scrut mult (tycon, inst_tys) (IfaceAlt (IfaceDataAlt data_occ) arg_st
tcIfaceDataAlt :: Mult -> DataCon -> [Type] -> [IfLclName] -> IfaceExpr
-> IfL CoreAlt
tcIfaceDataAlt mult con inst_tys arg_strs rhs
- = do { uniqs <- getUniquesM
+ = do { uniqs <- getUniqueListM
; let (ex_tvs, arg_ids)
= dataConRepFSInstPat (map ifLclNameFS arg_strs) uniqs mult con inst_tys
diff --git a/compiler/GHC/Runtime/Eval.hs b/compiler/GHC/Runtime/Eval.hs
index 4303d445c6b85530175c2921949acd2bd37e163a..62723bf4d6b7b43f21b020802d890a757710074e 100644
--- a/compiler/GHC/Runtime/Eval.hs
+++ b/compiler/GHC/Runtime/Eval.hs
@@ -642,7 +642,7 @@ bindLocalsAtBreakpoint hsc_env apStack_fhv (Just ibi) = do
newTyVars :: UniqSupply -> [TcTyVar] -> Subst
-- Similarly, clone the type variables mentioned in the types
-- we have here, *and* make them all RuntimeUnk tyvars
- newTyVars us tvs = foldl' new_tv emptySubst (tvs `zip` uniqsFromSupply us)
+ newTyVars us tvs = foldl' new_tv emptySubst (tvs `zip` uniqListFromSupply us)
new_tv subst (tv,uniq) = extendTCvSubstWithClone subst tv new_tv
where
new_tv = mkRuntimeUnkTyVar (setNameUnique (tyVarName tv) uniq)
diff --git a/compiler/GHC/Stg/Unarise.hs b/compiler/GHC/Stg/Unarise.hs
index d9444ee501f8bf7ba7033677ad6b6727c1f5d325..b6271ce7ca3c5263ca56792185be4162060f941d 100644
--- a/compiler/GHC/Stg/Unarise.hs
+++ b/compiler/GHC/Stg/Unarise.hs
@@ -731,7 +731,10 @@ unariseAlts rho (MultiValAlt _) bndr [GenStgAlt{ alt_con = DEFAULT
unariseAlts rho (MultiValAlt _) bndr alts
| isUnboxedSumBndr bndr
- = do (rho_sum_bndrs, scrt_bndrs@(tag_bndr : real_bndrs)) <- unariseConArgBinder rho bndr
+ = do (rho_sum_bndrs, scrt_bndrs) <- unariseConArgBinder rho bndr
+ let (tag_bndr, real_bndrs) = case scrt_bndrs of
+ [] -> panic "unariseAlts: empty scrt_bndrs"
+ x:xs -> (x, xs)
alts' <- unariseSumAlts rho_sum_bndrs (map StgVarArg real_bndrs) alts
let inner_case = StgCase (StgApp tag_bndr []) tag_bndr tagAltTy alts'
return [GenStgAlt{ alt_con = DataAlt (tupleDataCon Unboxed (length scrt_bndrs))
@@ -849,7 +852,7 @@ mapSumIdBinders alt_bndr args rhs rho0
mkCastInput :: (Id,PrimRep,UniqSupply) -> ([(PrimOp,Type,Unique)],Id,Id)
mkCastInput (id,rep,bndr_us) =
let (ops,types) = unzip $ getCasts (typePrimRepU $ idType id) rep
- cst_opts = zip3 ops types $ uniqsFromSupply bndr_us
+ cst_opts = zip3 ops types $ uniqListFromSupply bndr_us
out_id = case cst_opts of
[] -> id
_ -> let (_,ty,uq) = last cst_opts
@@ -960,7 +963,7 @@ mkUbxSum dc ty_args args0 us
, (ops,types) <- unzip $ getCasts (stgArgRepU arg) $ slotPrimRep slot_ty
, not . null $ ops
= let (us1,us2) = splitUniqSupply us
- cast_uqs = uniqsFromSupply us1
+ cast_uqs = uniqListFromSupply us1
cast_opts = zip3 ops types cast_uqs
(_op,out_ty,out_uq) = last cast_opts
casts = castArgRename cast_opts arg :: StgExpr -> StgExpr
diff --git a/compiler/GHC/Tc/Gen/HsType.hs b/compiler/GHC/Tc/Gen/HsType.hs
index 98985cf8873e5ff053574cb301a2986719e17002..e8232a1553eb2c053657db4e779175a5288b2a0c 100644
--- a/compiler/GHC/Tc/Gen/HsType.hs
+++ b/compiler/GHC/Tc/Gen/HsType.hs
@@ -3941,7 +3941,7 @@ splitTyConKind skol_info in_scope avoid_occs kind
name = mkInternalName uniq occ loc
tv = mkTcTyVar name arg' details
subst' = extendSubstInScope subst tv
- uniq:uniqs' = uniqs
+ Inf uniq uniqs' = uniqs
Inf occ occs' = occs
Just (Named (Bndr tv vis), kind')
diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs
index 216d862d3ed8567643ecb69bf3cdd66ca54d2e90..a723d252f39f8ee648b01f680b93c90afdf37361 100644
--- a/compiler/GHC/Tc/Utils/Monad.hs
+++ b/compiler/GHC/Tc/Utils/Monad.hs
@@ -744,11 +744,9 @@ newSysLocalId fs w ty
= do { u <- newUnique
; return (mkSysLocal fs u w ty) }
-newSysLocalIds :: FastString -> [Scaled TcType] -> TcRnIf gbl lcl [TcId]
-newSysLocalIds fs tys
- = do { us <- getUniquesM
- ; let mkId' n (Scaled w t) = mkSysLocal fs n w t
- ; return (zipWith mkId' us tys) }
+newSysLocalIds :: (Traversable t) => FastString -> t (Scaled TcType) -> TcRnIf gbl lcl (t TcId)
+newSysLocalIds fs = withUniquesM (\ u (Scaled w t) -> mkSysLocal fs u w t)
+{-# INLINE newSysLocalIds #-}
instance MonadUnique (IOEnv (Env gbl lcl)) where
getUniqueM = newUnique
diff --git a/compiler/GHC/Types/Id.hs b/compiler/GHC/Types/Id.hs
index 8abbeebbc903c70a56ccc837a59fd1c1685733a8..2d1dfd6ac4f6823c40d409e1a2edbce01943720e 100644
--- a/compiler/GHC/Types/Id.hs
+++ b/compiler/GHC/Types/Id.hs
@@ -172,6 +172,8 @@ import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Utils.Panic
+import Control.Monad.Trans.State (evalState, state)
+
-- infixl so you can say (id `set` a `set` b)
infixl 1 `setIdUnfolding`,
`setIdArity`,
@@ -398,12 +400,14 @@ mkScaledTemplateLocal i (Scaled w ty) = mkSysLocalOrCoVar (fsLit "v") (mkBuiltin
-- and "~" and "~~" have coercion "superclasses".
-- | Create a template local for a series of types
-mkTemplateLocals :: [Type] -> [Id]
+mkTemplateLocals :: Traversable f => f Type -> f Id
mkTemplateLocals = mkTemplateLocalsNum 1
+{-# SPECIALIZE mkTemplateLocals :: [Type] -> [Id] #-}
-- | Create a template local for a series of type, but start from a specified template local
-mkTemplateLocalsNum :: Int -> [Type] -> [Id]
-mkTemplateLocalsNum n tys = zipWith mkTemplateLocal [n..] tys
+mkTemplateLocalsNum :: Traversable f => Int -> f Type -> f Id
+mkTemplateLocalsNum n = flip evalState n . traverse (state . \ ty n -> (mkTemplateLocal n ty, succ n))
+{-# SPECIALIZE mkTemplateLocalsNum :: Int -> [Type] -> [Id] #-}
{- Note [Exported LocalIds]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/compiler/GHC/Types/Unique/Supply.hs b/compiler/GHC/Types/Unique/Supply.hs
index fa67ae61f7961e61ed88f831d0d17251fdc75498..6c85ee356785332e13ed799eb8fbdfa11febc3a8 100644
--- a/compiler/GHC/Types/Unique/Supply.hs
+++ b/compiler/GHC/Types/Unique/Supply.hs
@@ -14,12 +14,14 @@ module GHC.Types.Unique.Supply (
UniqSupply, -- Abstractly
-- ** Operations on supplies
- uniqFromSupply, uniqsFromSupply, -- basic ops
+ uniqFromSupply, uniqsFromSupply, uniqListFromSupply, -- basic ops
takeUniqFromSupply, uniqFromTag,
mkSplitUniqSupply,
splitUniqSupply, listSplitUniqSupply,
+ withUniques, withUniquesM,
+
-- * Unique supply monad and its abstraction
UniqSM, MonadUnique(..),
@@ -27,23 +29,26 @@ module GHC.Types.Unique.Supply (
initUs, initUs_,
-- * Set supply strategy
- initUniqSupply
+ initUniqSupply,
) where
import GHC.Prelude
+import GHC.Data.List.Infinite
import GHC.Types.Unique
-import GHC.Utils.Panic.Plain
import GHC.IO
import GHC.Utils.Monad
-import Control.Monad
import Data.Word
import GHC.Exts( Ptr(..), noDuplicate#, oneShot )
import Foreign.Storable
import GHC.Utils.Monad.State.Strict as Strict
+#if defined(DEBUG)
+import GHC.Utils.Panic.Plain
+#endif
+
#include "MachDeps.h"
#if WORD_SIZE_IN_BITS != 64
@@ -292,7 +297,9 @@ listSplitUniqSupply :: UniqSupply -> [UniqSupply]
-- ^ Create an infinite list of 'UniqSupply' from a single one
uniqFromSupply :: UniqSupply -> Unique
-- ^ Obtain the 'Unique' from this particular 'UniqSupply'
-uniqsFromSupply :: UniqSupply -> [Unique] -- Infinite
+uniqsFromSupply :: UniqSupply -> Infinite Unique
+-- ^ Obtain an infinite list of 'Unique' that can be generated by constant splitting of the supply
+uniqListFromSupply :: UniqSupply -> [Unique]
-- ^ Obtain an infinite list of 'Unique' that can be generated by constant splitting of the supply
takeUniqFromSupply :: UniqSupply -> (Unique, UniqSupply)
-- ^ Obtain the 'Unique' from this particular 'UniqSupply', and a new supply
@@ -301,11 +308,24 @@ splitUniqSupply (MkSplitUniqSupply _ s1 s2) = (s1, s2)
listSplitUniqSupply (MkSplitUniqSupply _ s1 s2) = s1 : listSplitUniqSupply s2
uniqFromSupply (MkSplitUniqSupply n _ _) = mkUniqueGrimily n
-uniqsFromSupply (MkSplitUniqSupply n _ s2) = mkUniqueGrimily n : uniqsFromSupply s2
+uniqsFromSupply (MkSplitUniqSupply n _ s2) = mkUniqueGrimily n `Inf` uniqsFromSupply s2
+uniqListFromSupply (MkSplitUniqSupply n _ s2) = mkUniqueGrimily n : uniqListFromSupply s2
takeUniqFromSupply (MkSplitUniqSupply n s1 _) = (mkUniqueGrimily n, s1)
{-# INLINE splitUniqSupply #-}
+withUniques :: Traversable t => (Unique -> a -> b) -> UniqSupply -> t a -> t b
+withUniques f us = initUs_ us . traverse (\ a -> flip f a <$> getUniqueUs)
+{-# INLINE withUniques #-}
+
+withUniquesM :: (MonadUnique m, Traversable t) => (Unique -> a -> b) -> t a -> m (t b)
+withUniquesM f = \ as -> ($ as) <$> withUniquesM' f
+{-# INLINE withUniquesM #-}
+
+withUniquesM' :: (MonadUnique m, Traversable t) => (Unique -> a -> b) -> m (t a -> t b)
+withUniquesM' f = withUniques f <$> getUniqueSupplyM
+{-# INLINE withUniquesM' #-}
+
{-
************************************************************************
* *
@@ -330,10 +350,6 @@ mkUniqSM :: (UniqSupply -> UniqResult a) -> UniqSM a
mkUniqSM f = USM (oneShot f)
{-# INLINE mkUniqSM #-}
--- TODO: try to get rid of this instance
-instance MonadFail UniqSM where
- fail = panic
-
-- | Run the 'UniqSM' action, returning the final 'UniqSupply'
initUs :: UniqSupply -> UniqSM a -> (a, UniqSupply)
initUs init_us m = case unUSM m init_us of { UniqResult r us -> (r, us) }
@@ -358,14 +374,17 @@ class Monad m => MonadUnique m where
-- | Get a new unique identifier
getUniqueM :: m Unique
-- | Get an infinite list of new unique identifiers
- getUniquesM :: m [Unique]
+ getUniquesM :: m (Infinite Unique)
+ -- | Get an infinite list of new unique identifiers
+ getUniqueListM :: m [Unique]
-- This default definition of getUniqueM, while correct, is not as
-- efficient as it could be since it needlessly generates and throws away
-- an extra Unique. For your instances consider providing an explicit
-- definition for 'getUniqueM' which uses 'takeUniqFromSupply' directly.
- getUniqueM = liftM uniqFromSupply getUniqueSupplyM
- getUniquesM = liftM uniqsFromSupply getUniqueSupplyM
+ getUniqueM = fmap uniqFromSupply getUniqueSupplyM
+ getUniquesM = fmap uniqsFromSupply getUniqueSupplyM
+ getUniqueListM = fmap uniqListFromSupply getUniqueSupplyM
instance MonadUnique UniqSM where
getUniqueSupplyM = getUs
@@ -376,6 +395,6 @@ getUniqueUs :: UniqSM Unique
getUniqueUs = mkUniqSM (\us0 -> case takeUniqFromSupply us0 of
(u,us1) -> UniqResult u us1)
-getUniquesUs :: UniqSM [Unique]
+getUniquesUs :: UniqSM (Infinite Unique)
getUniquesUs = mkUniqSM (\us0 -> case splitUniqSupply us0 of
(us1,us2) -> UniqResult (uniqsFromSupply us1) us2)