[Git][ghc/ghc][wip/andreask/fix_arm_linking] Revert "Use `Infinite` in unique generation, and clean up some other partial uni patterns as well."
Andreas Klebinger (@AndreasK)
gitlab at gitlab.haskell.org
Fri Mar 7 11:31:59 UTC 2025
Andreas Klebinger pushed to branch wip/andreask/fix_arm_linking at Glasgow Haskell Compiler / GHC
Commits:
e90e2dac by Andreas Klebinger at 2025-03-07T12:09:44+01:00
Revert "Use `Infinite` in unique generation, and clean up some other partial uni patterns as well."
This reverts commit 643dd3d86968c527ba07ece9cc337728dbdfe2a0.
As described in #25817 this commit introduced a subtle bug in AArch64
code generation. So for the time being I will simply revert it
wholesale.
- - - - -
14 changed files:
- compiler/GHC/Cmm/ThreadSanitizer.hs
- compiler/GHC/CmmToAsm/AArch64/CodeGen.hs
- compiler/GHC/Core/Opt/SetLevels.hs
- compiler/GHC/Core/Opt/Simplify/Utils.hs
- compiler/GHC/Core/Opt/WorkWrap/Utils.hs
- compiler/GHC/Core/Subst.hs
- compiler/GHC/Iface/Env.hs
- compiler/GHC/IfaceToCore.hs
- compiler/GHC/Runtime/Eval.hs
- compiler/GHC/Stg/Unarise.hs
- compiler/GHC/Tc/Gen/HsType.hs
- compiler/GHC/Tc/Utils/Monad.hs
- compiler/GHC/Types/Id.hs
- compiler/GHC/Types/Unique/Supply.hs
Changes:
=====================================
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 (uniqListFromSupply arg_us) args
+ arg_regs = zipWith arg_reg (uniqsFromSupply 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 (uniqListFromSupply us)
+ zipWith mk_reg regs_to_save (uniqsFromSupply us)
where
mk_reg :: GlobalReg -> Unique -> (CmmNode O O, CmmNode O O)
mk_reg reg u =
=====================================
compiler/GHC/CmmToAsm/AArch64/CodeGen.hs
=====================================
@@ -1,6 +1,5 @@
{-# language GADTs, LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE LambdaCase #-}
module GHC.CmmToAsm.AArch64.CodeGen (
cmmTopCodeGen
, generateJumpTableForInstr
@@ -51,9 +50,7 @@ import GHC.Types.Unique.DSM
import GHC.Data.OrdList
import GHC.Utils.Outputable
-import Control.Monad ( join, mapAndUnzipM )
-import Data.List.NonEmpty ( NonEmpty (..), nonEmpty )
-import qualified Data.List.NonEmpty as NE
+import Control.Monad ( mapAndUnzipM )
import GHC.Float
import GHC.Types.Basic
@@ -1590,7 +1587,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 (NonEmpty Instr)
+genCondFarJump :: MonadGetUnique m => Cond -> Target -> m InstrBlock
genCondFarJump cond far_target = do
skip_lbl_id <- newBlockId
jmp_lbl_id <- newBlockId
@@ -1600,13 +1597,11 @@ 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.
- pure
- ( BCOND cond (TBlock jmp_lbl_id) :|
- B (TBlock skip_lbl_id) :
- NEWBLOCK jmp_lbl_id :
- B far_target :
- NEWBLOCK skip_lbl_id :
- [] )
+ return $ toOL [ 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
@@ -2462,49 +2457,48 @@ 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) = 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_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_jump !m !pos instr = do
case instr of
ANN ann instr -> do
- replace_jump m pos instr >>= \
- (idx,instr':|instrs') ->
- pure (idx, ANN ann instr':|instrs')
+ 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)
BCOND cond t
-> case target_in_range m t pos of
- InRange -> pure (pos+long_bc_jump_size, NE.singleton instr)
+ InRange -> pure (pos+long_bc_jump_size,[instr])
NotInRange far_target -> do
jmp_code <- genCondFarJump cond far_target
- pure (pos+long_bc_jump_size, jmp_code)
+ pure (pos+long_bc_jump_size, fromOL 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, NE.singleton instr)
- | otherwise -> pure (pos+1, NE.singleton instr)
+ | isMetaInstr instr -> pure (pos,[instr])
+ | otherwise -> pure (pos+1, [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, NE.singleton instr)
+ InRange -> pure (pos+long_bz_jump_size,[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)) NE.<| jmp_code)
+ pure (pos + long_bz_jump_size, CMP op (OpImm (ImmInt 0)) : fromOL jmp_code)
target_in_range :: LabelMap Int -> Target -> Int -> BlockInRange
=====================================
compiler/GHC/Core/Opt/SetLevels.hs
=====================================
@@ -1,5 +1,7 @@
{-# LANGUAGE PatternSynonyms #-}
+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
+
{-
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
@@ -118,16 +120,12 @@ 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
{-
@@ -453,14 +451,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, Identity case_bndr') = substAndLvlBndrs NonRecursive env incd_lvl (Identity case_bndr)
+ = do { let (alts_env1, [case_bndr']) = substAndLvlBndrs NonRecursive env incd_lvl [case_bndr]
alts_env = extendCaseBndrEnv alts_env1 case_bndr scrut'
; alts' <- mapM (lvl_alt alts_env) alts
; return (Case scrut' case_bndr' ty' alts') }
@@ -651,7 +649,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 Pair bx_bndr ubx_bndr = mkTemplateLocals (Pair box_ty expr_ty)
+ , let [bx_bndr, ubx_bndr] = mkTemplateLocals [box_ty, expr_ty]
= do { expr1 <- lvlExpr rhs_env ann_expr
; let l1r = incMinorLvlFrom rhs_env
float_rhs = mkLams abs_vars_w_lvls $
@@ -1229,7 +1227,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', Identity bndr') = substAndLvlBndrs NonRecursive env bind_lvl (Identity bndr)
+ (env', [bndr']) = substAndLvlBndrs NonRecursive env bind_lvl [bndr]
; return (NonRec bndr' rhs', env') }
-- Otherwise we are going to float
@@ -1237,7 +1235,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', Identity bndr') <- cloneLetVars NonRecursive env dest_lvl (Identity bndr)
+ ; (env', [bndr']) <- cloneLetVars NonRecursive env dest_lvl [bndr]
; let bndr2 = annotateBotStr bndr' 0 mb_bot_str
; return (NonRec (TB bndr2 (FloatMe dest_lvl)) rhs', env') }
@@ -1245,7 +1243,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', Identity bndr') <- newPolyBndrs dest_lvl env abs_vars (Identity bndr)
+ ; (env', [bndr']) <- newPolyBndrs dest_lvl env abs_vars [bndr]
; let bndr2 = annotateBotStr bndr' n_extra mb_bot_str
; return (NonRec (TB bndr2 (FloatMe dest_lvl)) rhs', env') }
@@ -1303,13 +1301,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', Identity new_bndr) <- cloneLetVars Recursive rhs_env rhs_lvl (Identity bndr)
+ (rhs_env', [new_bndr]) <- cloneLetVars Recursive rhs_env rhs_lvl [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, Identity poly_bndr) <- newPolyBndrs dest_lvl env abs_vars (Identity bndr)
+ (poly_env, [poly_bndr]) <- newPolyBndrs dest_lvl env abs_vars [bndr]
return (Rec [(TB poly_bndr (FloatMe dest_lvl)
, mkLams abs_vars_w_lvls $
mkLams lam_bndrs2 $
@@ -1481,26 +1479,24 @@ Use lvlExpr otherwise. A little subtle, and I got it wrong at least twice
************************************************************************
-}
-substAndLvlBndrs :: Traversable f => RecFlag -> LevelEnv -> Level -> f InVar -> (LevelEnv, f LevelledBndr)
+substAndLvlBndrs :: RecFlag -> LevelEnv -> Level -> [InVar] -> (LevelEnv, [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 :: Traversable f => RecFlag -> LevelEnv -> f InVar -> (LevelEnv, f OutVar)
+substBndrsSL :: RecFlag -> LevelEnv -> [InVar] -> (LevelEnv, [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 (toList bndrs `zip` toList bndrs') }
+ , le_env = foldl' add_id id_env (bndrs `zip` bndrs') }
, bndrs')
where
(subst', bndrs') = case is_rec of
NonRecursive -> substBndrs subst bndrs
Recursive -> substRecBndrs subst bndrs
-{-# INLINE substBndrsSL #-}
-lvlLamBndrs :: Traversable f => LevelEnv -> Level -> f OutVar -> (LevelEnv, f LevelledBndr)
+lvlLamBndrs :: LevelEnv -> Level -> [OutVar] -> (LevelEnv, [LevelledBndr])
-- Compute the levels for the binders of a lambda group
lvlLamBndrs env lvl bndrs
= lvlBndrs env new_lvl bndrs
@@ -1514,18 +1510,17 @@ 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 :: Traversable f => LevelEnv -> Level -> RecFlag -> f OutVar
- -> (LevelEnv, f LevelledBndr)
-lvlJoinBndrs env lvl rec = lvlBndrs env new_lvl
+lvlJoinBndrs :: LevelEnv -> Level -> RecFlag -> [OutVar]
+ -> (LevelEnv, [LevelledBndr])
+lvlJoinBndrs env lvl rec bndrs
+ = lvlBndrs env new_lvl bndrs
where
new_lvl | isRec rec = incMajorLvl lvl
| otherwise = incMinorLvl lvl
-- Non-recursive join points are one-shot; recursive ones are not
-{-# INLINE lvlJoinBndrs #-}
-lvlBndrs :: Traversable f => LevelEnv -> Level -> f CoreBndr -> (LevelEnv, f LevelledBndr)
+lvlBndrs :: LevelEnv -> Level -> [CoreBndr] -> (LevelEnv, [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)
@@ -1538,8 +1533,7 @@ lvlBndrs :: Traversable f => LevelEnv -> Level -> f CoreBndr -> (LevelEnv, f Lev
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 }
- , fmap (stayPut new_lvl) bndrs)
-{-# INLINE lvlBndrs #-}
+ , map (stayPut new_lvl) bndrs)
stayPut :: Level -> OutVar -> LevelledBndr
stayPut new_lvl bndr = TB bndr (StayPut new_lvl)
@@ -1699,8 +1693,8 @@ initialEnv float_lams binds
addLvl :: Level -> VarEnv Level -> OutVar -> VarEnv Level
addLvl dest_lvl env v' = extendVarEnv env v' dest_lvl
-addLvls :: Foldable f => Level -> VarEnv Level -> f OutVar -> VarEnv Level
-addLvls = foldl' . addLvl
+addLvls :: Level -> VarEnv Level -> [OutVar] -> VarEnv Level
+addLvls dest_lvl env vs = foldl' (addLvl dest_lvl) env vs
floatLams :: LevelEnv -> Maybe Int
floatLams le = floatOutLambdas (le_switches le)
@@ -1798,15 +1792,17 @@ type LvlM result = UniqSM result
initLvl :: UniqSupply -> UniqSM a -> a
initLvl = initUs_
-newPolyBndrs :: (MonadUnique m, Traversable t) => Level -> LevelEnv -> [OutVar] -> t InId -> m (LevelEnv, t OutId)
+newPolyBndrs :: Level -> LevelEnv -> [OutVar] -> [InId]
+ -> LvlM (LevelEnv, [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 { bndr_prs <- withUniquesM (\ uniq bndr -> (bndr, mk_poly_bndr bndr uniq)) bndrs
- ; let new_bndrs = fmap snd bndr_prs
+ do { uniqs <- getUniquesM
+ ; let new_bndrs = zipWith mk_poly_bndr bndrs uniqs
+ bndr_prs = bndrs `zip` new_bndrs
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 }
@@ -1832,10 +1828,6 @@ 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
@@ -1859,7 +1851,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 :: Traversable t => LevelEnv -> Level -> t Var -> LvlM (LevelEnv, t Var)
+cloneCaseBndrs :: LevelEnv -> Level -> [Var] -> LvlM (LevelEnv, [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
@@ -1868,11 +1860,12 @@ 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 (toList vs `zip` toList vs') }
+ , le_env = foldl' add_id id_env (vs `zip` vs') }
+
; return (env', vs') }
-cloneLetVars
- :: Traversable t => RecFlag -> LevelEnv -> Level -> t InVar -> LvlM (LevelEnv, t OutVar)
+cloneLetVars :: RecFlag -> LevelEnv -> Level -> [InVar]
+ -> LvlM (LevelEnv, [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,
@@ -1880,12 +1873,12 @@ cloneLetVars
cloneLetVars is_rec
env@(LE { le_subst = subst, le_lvl_env = lvl_env, le_env = id_env })
dest_lvl vs
- = do { let vs1 = fmap zap vs
+ = do { let vs1 = map zap vs
; (subst', vs2) <- case is_rec of
NonRecursive -> cloneBndrsM subst vs1
Recursive -> cloneRecIdBndrsM subst vs1
- ; let prs = toList vs `zip` toList vs2
+ ; let prs = vs `zip` vs2
env' = env { le_lvl_env = addLvls dest_lvl lvl_env vs2
, le_subst = subst'
, le_env = foldl' add_id id_env prs }
@@ -1901,10 +1894,6 @@ 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)
=====================================
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 <- getUniqueListM
+ = do { us <- getUniquesM
; 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 <- getUniqueListM
+ do { us <- getUniquesM
; let (ex_tvs, arg_ids) = dataConRepInstPat us (idMult new_bndr) dc
(tyConAppArgs (idType new_bndr))
; return (ex_tvs ++ arg_ids) }
=====================================
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 <- getUniqueListM
+ = do { pat_bndrs_uniqs <- getUniquesM
; 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 <- getUniqueListM
+ pat_bndrs_uniqs <- getUniquesM
let (_exs, arg_ids) =
dataConRepFSInstPat (repeat ww_prefix) pat_bndrs_uniqs cprCaseBndrMult dc tc_args
massert (null _exs) -- Should have been caught by canUnboxResult
=====================================
compiler/GHC/Core/Subst.hs
=====================================
@@ -415,23 +415,20 @@ 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 :: Traversable t => Subst -> UniqSupply -> t Id -> (Subst, t Id)
+cloneIdBndrs :: Subst -> UniqSupply -> [Id] -> (Subst, [Id])
cloneIdBndrs subst us ids
- = mapAccumL (clone_id subst) subst (withUniques (flip (,)) us ids)
-{-# SPECIALIZE cloneIdBndrs :: Subst -> UniqSupply -> [Id] -> (Subst, [Id]) #-}
+ = mapAccumL (clone_id subst) subst (ids `zip` uniqsFromSupply us)
-cloneBndrs :: Traversable t => Subst -> UniqSupply -> t Var -> (Subst, t Var)
+cloneBndrs :: Subst -> UniqSupply -> [Var] -> (Subst, [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 (withUniques (flip (,)) us vs)
-{-# SPECIALIZE cloneBndrs :: Subst -> UniqSupply -> [Var] -> (Subst, [Var]) #-}
+ = mapAccumL (\subst (v, u) -> cloneBndr subst u v) subst (vs `zip` uniqsFromSupply us)
-cloneBndrsM :: (Traversable t, MonadUnique m) => Subst -> t Var -> m (Subst, t Var)
+cloneBndrsM :: MonadUnique m => Subst -> [Var] -> m (Subst, [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
@@ -439,16 +436,14 @@ 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 :: Traversable t => Subst -> UniqSupply -> t Id -> (Subst, t Id)
+cloneRecIdBndrs :: Subst -> UniqSupply -> [Id] -> (Subst, [Id])
cloneRecIdBndrs subst us ids =
- let x@(subst', _) = mapAccumL (clone_id subst') subst (withUniques (flip (,)) us ids)
+ let x@(subst', _) = mapAccumL (clone_id subst') subst (ids `zip` uniqsFromSupply us)
in x
-{-# SPECIALIZE cloneRecIdBndrs :: Subst -> UniqSupply -> [Id] -> (Subst, [Id]) #-}
-- | Clone a mutually recursive group of 'Id's
-cloneRecIdBndrsM :: (Traversable t, MonadUnique m) => Subst -> t Id -> m (Subst, t Id)
+cloneRecIdBndrsM :: MonadUnique m => Subst -> [Id] -> m (Subst, [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
=====================================
compiler/GHC/Iface/Env.hs
=====================================
@@ -262,9 +262,11 @@ newIfaceName occ
= do { uniq <- newUnique
; return $! mkInternalName uniq occ noSrcSpan }
-newIfaceNames :: Traversable t => t OccName -> IfL (t Name)
-newIfaceNames = withUniquesM (\ uniq occ -> mkInternalName uniq occ noSrcSpan)
-{-# INLINE newIfaceNames #-}
+newIfaceNames :: [OccName] -> IfL [Name]
+newIfaceNames occs
+ = do { uniqs <- getUniquesM
+ ; return [ mkInternalName uniq occ noSrcSpan
+ | (occ,uniq) <- occs `zip` uniqs] }
trace_if :: Logger -> SDoc -> IO ()
{-# INLINE trace_if #-} -- see Note [INLINE conditional tracing utilities]
=====================================
compiler/GHC/IfaceToCore.hs
=====================================
@@ -1722,7 +1722,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 <- getUniqueListM
+ = do { uniqs <- getUniquesM
; let (ex_tvs, arg_ids)
= dataConRepFSInstPat (map ifLclNameFS arg_strs) uniqs mult con inst_tys
=====================================
compiler/GHC/Runtime/Eval.hs
=====================================
@@ -629,7 +629,7 @@ bindLocalsAtBreakpoint hsc_env apStack_fhv span (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` uniqListFromSupply us)
+ newTyVars us tvs = foldl' new_tv emptySubst (tvs `zip` uniqsFromSupply us)
new_tv subst (tv,uniq) = extendTCvSubstWithClone subst tv new_tv
where
new_tv = mkRuntimeUnkTyVar (setNameUnique (tyVarName tv) uniq)
=====================================
compiler/GHC/Stg/Unarise.hs
=====================================
@@ -731,8 +731,7 @@ unariseAlts rho (MultiValAlt _) bndr [GenStgAlt{ alt_con = DEFAULT
unariseAlts rho (MultiValAlt _) bndr alts
| isUnboxedSumBndr bndr
- = do (rho_sum_bndrs, scrt_bndrs) <- unariseConArgBinder rho bndr
- let tag_bndr:|real_bndrs = expectNonEmpty scrt_bndrs
+ = do (rho_sum_bndrs, scrt_bndrs@(tag_bndr : real_bndrs)) <- unariseConArgBinder rho bndr
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))
@@ -850,7 +849,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 $ uniqListFromSupply bndr_us
+ cst_opts = zip3 ops types $ uniqsFromSupply bndr_us
out_id = case cst_opts of
[] -> id
_ -> let (_,ty,uq) = last cst_opts
@@ -961,7 +960,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 = uniqListFromSupply us1
+ cast_uqs = uniqsFromSupply us1
cast_opts = zip3 ops types cast_uqs
(_op,out_ty,out_uq) = last cast_opts
casts = castArgRename cast_opts arg :: StgExpr -> StgExpr
=====================================
compiler/GHC/Tc/Gen/HsType.hs
=====================================
@@ -3939,7 +3939,9 @@ splitTyConKind skol_info in_scope avoid_occs kind
name = mkInternalName uniq occ loc
tv = mkTcTyVar name arg' details
subst' = extendSubstInScope subst tv
- Inf uniq uniqs' = uniqs
+ (uniq,uniqs') = case uniqs of
+ uniq:uniqs' -> (uniq,uniqs')
+ _ -> panic "impossible"
Inf occ occs' = occs
Just (Named (Bndr tv vis), kind')
=====================================
compiler/GHC/Tc/Utils/Monad.hs
=====================================
@@ -745,9 +745,11 @@ newSysLocalId fs w ty
= do { u <- newUnique
; return (mkSysLocal fs u w ty) }
-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 #-}
+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) }
instance MonadUnique (IOEnv (Env gbl lcl)) where
getUniqueM = newUnique
=====================================
compiler/GHC/Types/Id.hs
=====================================
@@ -172,8 +172,6 @@ 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`,
@@ -400,14 +398,12 @@ mkScaledTemplateLocal i (Scaled w ty) = mkSysLocalOrCoVar (fsLit "v") (mkBuiltin
-- and "~" and "~~" have coercion "superclasses".
-- | Create a template local for a series of types
-mkTemplateLocals :: Traversable f => f Type -> f Id
+mkTemplateLocals :: [Type] -> [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 :: 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] #-}
+mkTemplateLocalsNum :: Int -> [Type] -> [Id]
+mkTemplateLocalsNum n tys = zipWith mkTemplateLocal [n..] tys
{- Note [Exported LocalIds]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
compiler/GHC/Types/Unique/Supply.hs
=====================================
@@ -14,14 +14,12 @@ module GHC.Types.Unique.Supply (
UniqSupply, -- Abstractly
-- ** Operations on supplies
- uniqFromSupply, uniqsFromSupply, uniqListFromSupply, -- basic ops
+ uniqFromSupply, uniqsFromSupply, -- basic ops
takeUniqFromSupply, uniqFromTag,
mkSplitUniqSupply,
splitUniqSupply, listSplitUniqSupply,
- withUniques, withUniquesM,
-
-- * Unique supply monad and its abstraction
UniqSM, MonadUnique(..),
@@ -29,26 +27,23 @@ 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
@@ -297,9 +292,7 @@ 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 -> Infinite Unique
--- ^ Obtain an infinite list of 'Unique' that can be generated by constant splitting of the supply
-uniqListFromSupply :: UniqSupply -> [Unique]
+uniqsFromSupply :: UniqSupply -> [Unique] -- Infinite
-- ^ 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
@@ -308,24 +301,11 @@ splitUniqSupply (MkSplitUniqSupply _ s1 s2) = (s1, s2)
listSplitUniqSupply (MkSplitUniqSupply _ s1 s2) = s1 : listSplitUniqSupply s2
uniqFromSupply (MkSplitUniqSupply n _ _) = mkUniqueGrimily n
-uniqsFromSupply (MkSplitUniqSupply n _ s2) = mkUniqueGrimily n `Inf` uniqsFromSupply s2
-uniqListFromSupply (MkSplitUniqSupply n _ s2) = mkUniqueGrimily n : uniqListFromSupply s2
+uniqsFromSupply (MkSplitUniqSupply n _ s2) = mkUniqueGrimily n : uniqsFromSupply 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' #-}
-
{-
************************************************************************
* *
@@ -350,6 +330,10 @@ 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) }
@@ -374,17 +358,14 @@ class Monad m => MonadUnique m where
-- | Get a new unique identifier
getUniqueM :: m Unique
-- | Get an infinite list of new unique identifiers
- getUniquesM :: m (Infinite Unique)
- -- | Get an infinite list of new unique identifiers
- getUniqueListM :: m [Unique]
+ getUniquesM :: 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 = fmap uniqFromSupply getUniqueSupplyM
- getUniquesM = fmap uniqsFromSupply getUniqueSupplyM
- getUniqueListM = fmap uniqListFromSupply getUniqueSupplyM
+ getUniqueM = liftM uniqFromSupply getUniqueSupplyM
+ getUniquesM = liftM uniqsFromSupply getUniqueSupplyM
instance MonadUnique UniqSM where
getUniqueSupplyM = getUs
@@ -395,6 +376,6 @@ getUniqueUs :: UniqSM Unique
getUniqueUs = mkUniqSM (\us0 -> case takeUniqFromSupply us0 of
(u,us1) -> UniqResult u us1)
-getUniquesUs :: UniqSM (Infinite Unique)
+getUniquesUs :: UniqSM [Unique]
getUniquesUs = mkUniqSM (\us0 -> case splitUniqSupply us0 of
(us1,us2) -> UniqResult (uniqsFromSupply us1) us2)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e90e2dacb24ef486cc2e3a270a229e847f87eed3
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e90e2dacb24ef486cc2e3a270a229e847f87eed3
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/20250307/a2ddccb0/attachment-0001.html>
More information about the ghc-commits
mailing list