...
 
Commits (41)
......@@ -59,6 +59,7 @@ ghc-linters:
- ./boot
- ./configure $CONFIGURE_ARGS
- hadrian/build.cabal.sh -j`mk/detect-cpu-count.sh`
- hadrian/build.cabal.sh -j`mk/detect-cpu-count.sh` docs-haddock
cache:
key: hadrian
paths:
......@@ -428,6 +429,7 @@ cleanup-darwin:
tags:
- x86_64-darwin
when: always
dependencies: []
before_script:
- echo "Time to clean up"
script:
......
......@@ -1264,10 +1264,14 @@ proxyHashId
(noCafIdInfo `setUnfoldingInfo` evaldUnfolding -- Note [evaldUnfoldings]
`setNeverLevPoly` ty )
where
-- proxy# :: forall k (a:k). Proxy# k a
bndrs = mkTemplateKiTyVars [liftedTypeKind] id
[k,t] = mkTyVarTys bndrs
ty = mkSpecForAllTys bndrs (mkProxyPrimTy k t)
-- proxy# :: forall {k} (a:k). Proxy# k a
--
-- The visibility of the `k` binder is Inferred to match the type of the
-- Proxy data constructor (#16293).
[kv,tv] = mkTemplateKiTyVars [liftedTypeKind] id
kv_ty = mkTyVarTy kv
tv_ty = mkTyVarTy tv
ty = mkInvForAllTy kv $ mkSpecForAllTy tv $ mkProxyPrimTy kv_ty tv_ty
------------------------------------------------
unsafeCoerceId :: Id
......
......@@ -596,9 +596,9 @@ repTyArgs f [] = f
repTyArgs f (HsValArg ty : as) = do { f' <- f
; ty' <- repLTy ty
; repTyArgs (repTapp f' ty') as }
repTyArgs f (HsTypeArg ki : as) = do { f' <- f
; ki' <- repLTy ki
; repTyArgs (repTappKind f' ki') as }
repTyArgs f (HsTypeArg _ ki : as) = do { f' <- f
; ki' <- repLTy ki
; repTyArgs (repTappKind f' ki') as }
repTyArgs f (HsArgPar _ : as) = repTyArgs f as
repDataFamInstD :: DataFamInstDecl GhcRn -> DsM (Core TH.DecQ)
......
......@@ -482,9 +482,6 @@ endif
ifneq "$(BINDIST)" "YES"
compiler_stage2_TAGS_HC_OPTS = -package ghc
$(eval $(call tags-package,compiler,stage2))
$(compiler_stage1_depfile_haskell) : compiler/stage1/$(PLATFORM_H)
$(compiler_stage2_depfile_haskell) : compiler/stage2/$(PLATFORM_H)
$(compiler_stage3_depfile_haskell) : compiler/stage3/$(PLATFORM_H)
......
......@@ -332,7 +332,7 @@ instance (HasLoc a, HasLoc b) => HasLoc (FamEqn s a b) where
loc _ = noSrcSpan
instance (HasLoc tm, HasLoc ty) => HasLoc (HsArg tm ty) where
loc (HsValArg tm) = loc tm
loc (HsTypeArg ty) = loc ty
loc (HsTypeArg _ ty) = loc ty
loc (HsArgPar sp) = sp
instance HasLoc (HsDataDefn GhcRn) where
......@@ -1459,7 +1459,7 @@ instance ToHie (TScoped (LHsType GhcRn)) where
instance (ToHie tm, ToHie ty) => ToHie (HsArg tm ty) where
toHie (HsValArg tm) = toHie tm
toHie (HsTypeArg ty) = toHie ty
toHie (HsTypeArg _ ty) = toHie ty
toHie (HsArgPar sp) = pure $ locOnly sp
instance ToHie (TVScoped (LHsTyVarBndr GhcRn)) where
......
......@@ -1520,8 +1520,8 @@ mk_apps head_ty type_args = do
case arg of
HsValArg ty -> do p_ty <- add_parens ty
mk_apps (HsAppTy noExt phead_ty p_ty) args
HsTypeArg ki -> do p_ki <- add_parens ki
mk_apps (HsAppKindTy noExt phead_ty p_ki) args
HsTypeArg l ki -> do p_ki <- add_parens ki
mk_apps (HsAppKindTy l phead_ty p_ki) args
HsArgPar _ -> mk_apps (HsParTy noExt phead_ty) args
go type_args
......@@ -1533,7 +1533,7 @@ mk_apps head_ty type_args = do
wrap_tyarg :: LHsTypeArg GhcPs -> LHsTypeArg GhcPs
wrap_tyarg (HsValArg ty) = HsValArg $ parenthesizeHsType appPrec ty
wrap_tyarg (HsTypeArg ki) = HsTypeArg $ parenthesizeHsType appPrec ki
wrap_tyarg (HsTypeArg l ki) = HsTypeArg l $ parenthesizeHsType appPrec ki
wrap_tyarg ta@(HsArgPar {}) = ta -- Already parenthesized
-- ---------------------------------------------------------------------
......@@ -1570,7 +1570,8 @@ split_ty_app :: TH.Type -> CvtM (TH.Type, [LHsTypeArg GhcPs])
split_ty_app ty = go ty []
where
go (AppT f a) as' = do { a' <- cvtType a; go f (HsValArg a':as') }
go (AppKindT ty ki) as' = do { ki' <- cvtKind ki; go ty (HsTypeArg ki':as') }
go (AppKindT ty ki) as' = do { ki' <- cvtKind ki
; go ty (HsTypeArg noSrcSpan ki':as') }
go (ParensT t) as' = do { loc <- getL; go t (HsArgPar loc: as') }
go f as = return (f,as)
......
......@@ -680,7 +680,9 @@ countTyClDecls decls
-- | Does this declaration have a complete, user-supplied kind signature?
-- See Note [CUSKs: complete user-supplied kind signatures]
hsDeclHasCusk :: TyClDecl GhcRn -> Bool
hsDeclHasCusk (FamDecl { tcdFam = fam_decl }) = famDeclHasCusk Nothing fam_decl
hsDeclHasCusk (FamDecl { tcdFam = fam_decl })
= famDeclHasCusk False fam_decl
-- False: this is not: an associated type of a class with no cusk
hsDeclHasCusk (SynDecl { tcdTyVars = tyvars, tcdRhs = rhs })
-- NB: Keep this synchronized with 'getInitialKind'
= hsTvbAllKinded tyvars && rhs_annotated rhs
......@@ -1078,15 +1080,22 @@ data FamilyInfo pass
-- | Does this family declaration have a complete, user-supplied kind signature?
-- See Note [CUSKs: complete user-supplied kind signatures]
famDeclHasCusk :: Maybe Bool
-- ^ if associated, does the enclosing class have a CUSK?
-> FamilyDecl pass -> Bool
famDeclHasCusk _ (FamilyDecl { fdInfo = ClosedTypeFamily _
, fdTyVars = tyvars
, fdResultSig = L _ resultSig })
= hsTvbAllKinded tyvars && hasReturnKindSignature resultSig
famDeclHasCusk mb_class_cusk _ = mb_class_cusk `orElse` True
-- all un-associated open families have CUSKs
famDeclHasCusk :: Bool -- ^ True <=> this is an associated type family,
-- and the parent class has /no/ CUSK
-> FamilyDecl pass
-> Bool
famDeclHasCusk assoc_with_no_cusk
(FamilyDecl { fdInfo = fam_info
, fdTyVars = tyvars
, fdResultSig = L _ resultSig })
= case fam_info of
ClosedTypeFamily {} -> hsTvbAllKinded tyvars
&& hasReturnKindSignature resultSig
_ -> not assoc_with_no_cusk
-- Un-associated open type/data families have CUSKs
-- Associated type families have CUSKs iff the parent class does
famDeclHasCusk _ (XFamilyDecl {}) = panic "famDeclHasCusk"
-- | Does this family declaration have user-supplied return kind signature?
hasReturnKindSignature :: FamilyResultSig a -> Bool
......
......@@ -710,7 +710,7 @@ type instance XIParamTy (GhcPass _) = NoExt
type instance XStarTy (GhcPass _) = NoExt
type instance XKindSig (GhcPass _) = NoExt
type instance XAppKindTy (GhcPass _) = NoExt
type instance XAppKindTy (GhcPass _) = SrcSpan -- Where the `@` lives
type instance XSpliceTy GhcPs = NoExt
type instance XSpliceTy GhcRn = NoExt
......@@ -1045,10 +1045,10 @@ mkHsAppTys :: LHsType (GhcPass p) -> [LHsType (GhcPass p)]
-> LHsType (GhcPass p)
mkHsAppTys = foldl' mkHsAppTy
mkHsAppKindTy :: LHsType (GhcPass p) -> LHsType (GhcPass p)
mkHsAppKindTy :: XAppKindTy (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)
-> LHsType (GhcPass p)
mkHsAppKindTy ty k
= addCLoc ty k (HsAppKindTy noExt ty k)
mkHsAppKindTy ext ty k
= addCLoc ty k (HsAppKindTy ext ty k)
{-
************************************************************************
......@@ -1107,7 +1107,8 @@ hsTyGetAppHead_maybe = go
-- Arguments in an expression/type after splitting
data HsArg tm ty
= HsValArg tm -- Argument is an ordinary expression (f arg)
| HsTypeArg ty -- Argument is a visible type application (f @ty)
| HsTypeArg SrcSpan ty -- Argument is a visible type application (f @ty)
-- SrcSpan is location of the `@`
| HsArgPar SrcSpan -- See Note [HsArgPar]
numVisibleArgs :: [HsArg tm ty] -> Arity
......@@ -1119,9 +1120,9 @@ numVisibleArgs = count is_vis
type LHsTypeArg p = HsArg (LHsType p) (LHsKind p)
instance (Outputable tm, Outputable ty) => Outputable (HsArg tm ty) where
ppr (HsValArg tm) = ppr tm
ppr (HsTypeArg ty) = char '@' <> ppr ty
ppr (HsArgPar sp) = text "HsArgPar" <+> ppr sp
ppr (HsValArg tm) = ppr tm
ppr (HsTypeArg _ ty) = char '@' <> ppr ty
ppr (HsArgPar sp) = text "HsArgPar" <+> ppr sp
{-
Note [HsArgPar]
A HsArgPar indicates that everything to the left of this in the argument list is
......@@ -1142,7 +1143,7 @@ splitHsAppTys e = go (noLoc e) []
go :: LHsType GhcRn -> [LHsTypeArg GhcRn]
-> (LHsType GhcRn, [LHsTypeArg GhcRn])
go (L _ (HsAppTy _ f a)) as = go f (HsValArg a : as)
go (L _ (HsAppKindTy _ ty k)) as = go ty (HsTypeArg k : as)
go (L _ (HsAppKindTy l ty k)) as = go ty (HsTypeArg l k : as)
go (L sp (HsParTy _ f)) as = go f (HsArgPar sp : as)
go f as = (f,as)
--------------------------------
......
......@@ -502,7 +502,8 @@ nlHsTyConApp tycon tys = foldl' nlHsAppTy (nlHsTyVar tycon) tys
nlHsAppKindTy ::
LHsType (GhcPass p) -> LHsKind (GhcPass p) -> LHsType (GhcPass p)
nlHsAppKindTy f k = noLoc (HsAppKindTy noExt f (parenthesizeHsType appPrec k))
nlHsAppKindTy f k
= noLoc (HsAppKindTy noSrcSpan f (parenthesizeHsType appPrec k))
{-
Tuples. All these functions are *pre-typechecker* because they lack
......
......@@ -713,7 +713,7 @@ pprIfaceDecl ss (IfaceData { ifName = tycon, ifCType = ctype,
, nest 2 (vcat pp_cons)
, nest 2 $ ppShowIface ss pp_extra ]
| otherwise = vcat [ pp_roles
, hang (pp_nd <+> pp_lhs <+> pp_kind) 2 (add_bars pp_cons)
, hang (pp_nd <+> pp_lhs) 2 (add_bars pp_cons)
, nest 2 $ ppShowIface ss pp_extra ]
where
is_data_instance = isIfaceDataInstance parent
......
......@@ -608,14 +608,26 @@ cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count
$ allocatableRegs ncgImpl
-- do the graph coloring register allocation
let ((alloced, regAllocStats), usAlloc)
let ((alloced, maybe_more_stack, regAllocStats), usAlloc)
= {-# SCC "RegAlloc-color" #-}
initUs usLive
$ Color.regAlloc
dflags
alloc_regs
(mkUniqSet [0 .. maxSpillSlots ncgImpl])
(maxSpillSlots ncgImpl)
withLiveness
livenessCfg
let ((alloced', stack_updt_blks), usAlloc')
= initUs usAlloc $
case maybe_more_stack of
Nothing -> return (alloced, [])
Just amount -> do
(alloced',stack_updt_blks) <- unzip <$>
(mapM ((ncgAllocMoreStack ncgImpl) amount) alloced)
return (alloced', concat stack_updt_blks )
-- dump out what happened during register allocation
dumpIfSet_dyn dflags
......@@ -637,10 +649,10 @@ cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count
-- force evaluation of the Maybe to avoid space leak
mPprStats `seq` return ()
return ( alloced, usAlloc
return ( alloced', usAlloc'
, mPprStats
, Nothing
, [], [])
, [], stack_updt_blks)
else do
-- do linear register allocation
......
......@@ -24,6 +24,7 @@ module CFG
, getSuccEdgesSorted, weightedEdgeList
, getEdgeInfo
, getCfgNodes, hasNode
, loopMembers
--Construction/Misc
, getCfg, getCfgProc, pprEdgeWeights, sanityCheckCfg
......@@ -636,3 +637,20 @@ optimizeCFG weights (CmmProc info _lab _live graph) cfg =
| CmmSource (CmmBranch {}) <- source = True
| CmmSource (CmmCondBranch {}) <- source = True
| otherwise = False
-- | Determine loop membership of blocks based on SCC analysis
-- Ideally we would replace this with a variant giving us loop
-- levels instead but the SCC code will do for now.
loopMembers :: CFG -> LabelMap Bool
loopMembers cfg =
foldl' (flip setLevel) mapEmpty sccs
where
mkNode :: BlockId -> Node BlockId BlockId
mkNode bid = DigraphNode bid bid (getSuccessors cfg bid)
nodes = map mkNode (setElems $ getCfgNodes cfg)
sccs = stronglyConnCompFromEdgedVerticesOrd nodes
setLevel :: SCC BlockId -> LabelMap Bool -> LabelMap Bool
setLevel (AcyclicSCC bid) m = mapInsert bid False m
setLevel (CyclicSCC bids) m = foldl' (\m k -> mapInsert k True m) m bids
......@@ -26,6 +26,7 @@ import UniqFM
import UniqSet
import UniqSupply
import Util (seqList)
import CFG
import Data.Maybe
import Control.Monad
......@@ -46,12 +47,15 @@ regAlloc
=> DynFlags
-> UniqFM (UniqSet RealReg) -- ^ registers we can use for allocation
-> UniqSet Int -- ^ set of available spill slots.
-> Int -- ^ current number of spill slots
-> [LiveCmmDecl statics instr] -- ^ code annotated with liveness information.
-> UniqSM ( [NatCmmDecl statics instr], [RegAllocStats statics instr] )
-- ^ code with registers allocated and stats for each stage of
-- allocation
-> Maybe CFG -- ^ CFG of basic blocks if available
-> UniqSM ( [NatCmmDecl statics instr]
, Maybe Int, [RegAllocStats statics instr] )
-- ^ code with registers allocated, additional stacks required
-- and stats for each stage of allocation
regAlloc dflags regsFree slotsFree code
regAlloc dflags regsFree slotsFree slotsCount code cfg
= do
-- TODO: the regClass function is currently hard coded to the default
-- target architecture. Would prefer to determine this from dflags.
......@@ -61,12 +65,19 @@ regAlloc dflags regsFree slotsFree code
(targetVirtualRegSqueeze platform)
(targetRealRegSqueeze platform)
(code_final, debug_codeGraphs, _)
(code_final, debug_codeGraphs, slotsCount', _)
<- regAlloc_spin dflags 0
triv
regsFree slotsFree [] code
regsFree slotsFree slotsCount [] code cfg
let needStack
| slotsCount == slotsCount'
= Nothing
| otherwise
= Just slotsCount'
return ( code_final
, needStack
, reverse debug_codeGraphs )
......@@ -88,13 +99,16 @@ regAlloc_spin
-- colourable.
-> UniqFM (UniqSet RealReg) -- ^ Free registers that we can allocate.
-> UniqSet Int -- ^ Free stack slots that we can use.
-> Int -- ^ Number of spill slots in use
-> [RegAllocStats statics instr] -- ^ Current regalloc stats to add to.
-> [LiveCmmDecl statics instr] -- ^ Liveness annotated code to allocate.
-> Maybe CFG
-> UniqSM ( [NatCmmDecl statics instr]
, [RegAllocStats statics instr]
, Int -- Slots in use
, Color.Graph VirtualReg RegClass RealReg)
regAlloc_spin dflags spinCount triv regsFree slotsFree debug_codeGraphs code
regAlloc_spin dflags spinCount triv regsFree slotsFree slotsCount debug_codeGraphs code cfg
= do
let platform = targetPlatform dflags
......@@ -134,7 +148,7 @@ regAlloc_spin dflags spinCount triv regsFree slotsFree debug_codeGraphs code
-- This is a lazy binding, so the map will only be computed if we
-- actually have to spill to the stack.
let spillCosts = foldl' plusSpillCostInfo zeroSpillCostInfo
$ map (slurpSpillCostInfo platform) code
$ map (slurpSpillCostInfo platform cfg) code
-- The function to choose regs to leave uncolored.
let spill = chooseSpill spillCosts
......@@ -227,6 +241,7 @@ regAlloc_spin dflags spinCount triv regsFree slotsFree debug_codeGraphs code
return ( code_final
, statList
, slotsCount
, graph_colored_lint)
-- Coloring was unsuccessful. We need to spill some register to the
......@@ -241,8 +256,8 @@ regAlloc_spin dflags spinCount triv regsFree slotsFree debug_codeGraphs code
else graph_colored
-- Spill uncolored regs to the stack.
(code_spilled, slotsFree', spillStats)
<- regSpill platform code_coalesced slotsFree rsSpill
(code_spilled, slotsFree', slotsCount', spillStats)
<- regSpill platform code_coalesced slotsFree slotsCount rsSpill
-- Recalculate liveness information.
-- NOTE: we have to reverse the SCCs here to get them back into
......@@ -273,8 +288,7 @@ regAlloc_spin dflags spinCount triv regsFree slotsFree debug_codeGraphs code
seqList statList (return ())
regAlloc_spin dflags (spinCount + 1) triv regsFree slotsFree'
statList
code_relive
slotsCount' statList code_relive cfg
-- | Build a graph from the liveness and coalesce information in this code.
......
......@@ -33,6 +33,9 @@ import qualified Data.IntSet as IntSet
-- | Spill all these virtual regs to stack slots.
--
-- Bumps the number of required stack slots if required.
--
--
-- TODO: See if we can split some of the live ranges instead of just globally
-- spilling the virtual reg. This might make the spill cleaner's job easier.
--
......@@ -45,20 +48,22 @@ regSpill
=> Platform
-> [LiveCmmDecl statics instr] -- ^ the code
-> UniqSet Int -- ^ available stack slots
-> Int -- ^ current number of spill slots.
-> UniqSet VirtualReg -- ^ the regs to spill
-> UniqSM
([LiveCmmDecl statics instr]
-- code with SPILL and RELOAD meta instructions added.
, UniqSet Int -- left over slots
, Int -- slot count in use now.
, SpillStats ) -- stats about what happened during spilling
regSpill platform code slotsFree regs
regSpill platform code slotsFree slotCount regs
-- Not enough slots to spill these regs.
| sizeUniqSet slotsFree < sizeUniqSet regs
= pprPanic "regSpill: out of spill slots!"
( text " regs to spill = " <> ppr (sizeUniqSet regs)
$$ text " slots left = " <> ppr (sizeUniqSet slotsFree))
= -- pprTrace "Bumping slot count:" (ppr slotCount <> text " -> " <> ppr (slotCount+512)) $
let slotsFree' = (addListToUniqSet slotsFree [slotCount+1 .. slotCount+512])
in regSpill platform code slotsFree' (slotCount+512) regs
| otherwise
= do
......@@ -80,6 +85,7 @@ regSpill platform code slotsFree regs
return ( code'
, minusUniqSet slotsFree (mkUniqSet slots)
, slotCount
, makeSpillStats state')
......
{-# LANGUAGE ScopedTypeVariables #-}
module RegAlloc.Graph.SpillCost (
SpillCostRecord,
plusSpillCostRecord,
......@@ -30,9 +30,11 @@ import Digraph (flattenSCCs)
import Outputable
import Platform
import State
import CFG
import Data.List (nub, minimumBy)
import Data.Maybe
import Control.Monad (join)
-- | Records the expected cost to spill some regster.
......@@ -47,6 +49,10 @@ type SpillCostRecord
type SpillCostInfo
= UniqFM SpillCostRecord
-- | Block membership in a loop
type LoopMember = Bool
type SpillCostState = State (UniqFM SpillCostRecord) ()
-- | An empty map of spill costs.
zeroSpillCostInfo :: SpillCostInfo
......@@ -71,12 +77,13 @@ plusSpillCostRecord (r1, a1, b1, c1) (r2, a2, b2, c2)
-- For each vreg, the number of times it was written to, read from,
-- and the number of instructions it was live on entry to (lifetime)
--
slurpSpillCostInfo :: (Outputable instr, Instruction instr)
slurpSpillCostInfo :: forall instr statics. (Outputable instr, Instruction instr)
=> Platform
-> Maybe CFG
-> LiveCmmDecl statics instr
-> SpillCostInfo
slurpSpillCostInfo platform cmm
slurpSpillCostInfo platform cfg cmm
= execState (countCmm cmm) zeroSpillCostInfo
where
countCmm CmmData{} = return ()
......@@ -90,35 +97,36 @@ slurpSpillCostInfo platform cmm
| LiveInfo _ _ (Just blockLive) _ <- info
, Just rsLiveEntry <- mapLookup blockId blockLive
, rsLiveEntry_virt <- takeVirtuals rsLiveEntry
= countLIs rsLiveEntry_virt instrs
= countLIs (loopMember blockId) rsLiveEntry_virt instrs
| otherwise
= error "RegAlloc.SpillCost.slurpSpillCostInfo: bad block"
countLIs _ []
countLIs :: LoopMember -> UniqSet VirtualReg -> [LiveInstr instr] -> SpillCostState
countLIs _ _ []
= return ()
-- Skip over comment and delta pseudo instrs.
countLIs rsLive (LiveInstr instr Nothing : lis)
countLIs inLoop rsLive (LiveInstr instr Nothing : lis)
| isMetaInstr instr
= countLIs rsLive lis
= countLIs inLoop rsLive lis
| otherwise
= pprPanic "RegSpillCost.slurpSpillCostInfo"
$ text "no liveness information on instruction " <> ppr instr
countLIs rsLiveEntry (LiveInstr instr (Just live) : lis)
countLIs inLoop rsLiveEntry (LiveInstr instr (Just live) : lis)
= do
-- Increment the lifetime counts for regs live on entry to this instr.
mapM_ incLifetime $ nonDetEltsUniqSet rsLiveEntry
mapM_ (incLifetime (loopCount inLoop)) $ nonDetEltsUniqSet rsLiveEntry
-- This is non-deterministic but we do not
-- currently support deterministic code-generation.
-- See Note [Unique Determinism and code generation]
-- Increment counts for what regs were read/written from.
let (RU read written) = regUsageOfInstr platform instr
mapM_ incUses $ catMaybes $ map takeVirtualReg $ nub read
mapM_ incDefs $ catMaybes $ map takeVirtualReg $ nub written
mapM_ (incUses (loopCount inLoop)) $ catMaybes $ map takeVirtualReg $ nub read
mapM_ (incDefs (loopCount inLoop)) $ catMaybes $ map takeVirtualReg $ nub written
-- Compute liveness for entry to next instruction.
let liveDieRead_virt = takeVirtuals (liveDieRead live)
......@@ -132,12 +140,21 @@ slurpSpillCostInfo platform cmm
= (rsLiveAcross `unionUniqSets` liveBorn_virt)
`minusUniqSet` liveDieWrite_virt
countLIs rsLiveNext lis
incDefs reg = modify $ \s -> addToUFM_C plusSpillCostRecord s reg (reg, 1, 0, 0)
incUses reg = modify $ \s -> addToUFM_C plusSpillCostRecord s reg (reg, 0, 1, 0)
incLifetime reg = modify $ \s -> addToUFM_C plusSpillCostRecord s reg (reg, 0, 0, 1)
countLIs inLoop rsLiveNext lis
loopCount inLoop
| inLoop = 10
| otherwise = 1
incDefs count reg = modify $ \s -> addToUFM_C plusSpillCostRecord s reg (reg, count, 0, 0)
incUses count reg = modify $ \s -> addToUFM_C plusSpillCostRecord s reg (reg, 0, count, 0)
incLifetime count reg = modify $ \s -> addToUFM_C plusSpillCostRecord s reg (reg, 0, 0, count)
loopBlocks = CFG.loopMembers <$> cfg
loopMember bid
| Just isMember <- join (mapLookup bid <$> loopBlocks)
= isMember
| otherwise
= False
-- | Take all the virtual registers from this set.
takeVirtuals :: UniqSet Reg -> UniqSet VirtualReg
......
......@@ -2129,7 +2129,7 @@ genCCall dflags is32Bit (PrimTarget (MO_Ctz width)) [dst] [src] bid
src_r <- getNewRegNat (intFormat width)
return $ appOL (code_src src_r) $ case width of
W8 -> toOL
[ OR II32 (OpImm (ImmInt 0xFFFFFF00)) (OpReg src_r)
[ OR II32 (OpImm (ImmInteger 0xFFFFFF00)) (OpReg src_r)
, TZCNT II32 (OpReg src_r) dst_r
]
W16 -> toOL
......
......@@ -946,7 +946,7 @@ x86_mkStackAllocInstr platform amount
]
ArchX86_64 | needs_probe_call platform amount ->
[ MOV II64 (OpImm (ImmInt amount)) (OpReg rax)
, CALL (Left $ strImmLit "__chkstk_ms") [rax]
, CALL (Left $ strImmLit "___chkstk_ms") [rax]
, SUB II64 (OpReg rax) (OpReg rsp)
]
| otherwise ->
......@@ -1063,6 +1063,8 @@ is_G_instr instr
-- Otherwise, we would repeat the $rsp adjustment for each branch to
-- L.
--
-- Returns a list of (L,Lnew) pairs.
--
allocMoreStack
:: Platform
-> Int
......
This diff is collapsed.
......@@ -2697,23 +2697,23 @@ alternativeLayoutRuleToken t
do setAlrExpectingOCurly Nothing
setALRContext (ALRLayout expectingOCurly thisCol : context)
setNextToken t
return (L thisLoc ITocurly)
return (L thisLoc ITvocurly)
| otherwise ->
do setAlrExpectingOCurly Nothing
setPendingImplicitTokens [L lastLoc ITccurly]
setPendingImplicitTokens [L lastLoc ITvccurly]
setNextToken t
return (L lastLoc ITocurly)
return (L lastLoc ITvocurly)
(_, _, Just expectingOCurly) ->
do setAlrExpectingOCurly Nothing
setALRContext (ALRLayout expectingOCurly thisCol : context)
setNextToken t
return (L thisLoc ITocurly)
return (L thisLoc ITvocurly)
-- We do the [] cases earlier than in the spec, as we
-- have an actual EOF token
(ITeof, ALRLayout _ _ : ls, _) ->
do setALRContext ls
setNextToken t
return (L thisLoc ITccurly)
return (L thisLoc ITvccurly)
(ITeof, _, _) ->
return t
-- the other ITeof case omitted; general case below covers it
......@@ -2724,7 +2724,7 @@ alternativeLayoutRuleToken t
| newLine ->
do setPendingImplicitTokens [t]
setALRContext ls
return (L thisLoc ITccurly)
return (L thisLoc ITvccurly)
-- This next case is to handle a transitional issue:
(ITwhere, ALRLayout _ col : ls, _)
| newLine && thisCol == col && transitional ->
......@@ -2736,7 +2736,7 @@ alternativeLayoutRuleToken t
setNextToken t
-- Note that we use lastLoc, as we may need to close
-- more layouts, or give a semicolon
return (L lastLoc ITccurly)
return (L lastLoc ITvccurly)
-- This next case is to handle a transitional issue:
(ITvbar, ALRLayout _ col : ls, _)
| newLine && thisCol == col && transitional ->
......@@ -2748,17 +2748,19 @@ alternativeLayoutRuleToken t
setNextToken t
-- Note that we use lastLoc, as we may need to close
-- more layouts, or give a semicolon
return (L lastLoc ITccurly)
return (L lastLoc ITvccurly)
(_, ALRLayout _ col : ls, _)
| newLine && thisCol == col ->
do setNextToken t
return (L thisLoc ITsemi)
let loc = realSrcSpanStart thisLoc
zeroWidthLoc = mkRealSrcSpan loc loc
return (L zeroWidthLoc ITsemi)
| newLine && thisCol < col ->
do setALRContext ls
setNextToken t
-- Note that we use lastLoc, as we may need to close
-- more layouts, or give a semicolon
return (L lastLoc ITccurly)
return (L lastLoc ITvccurly)
-- We need to handle close before open, as 'then' is both
-- an open and a close
(u, _, _)
......@@ -2767,7 +2769,7 @@ alternativeLayoutRuleToken t
ALRLayout _ _ : ls ->
do setALRContext ls
setNextToken t
return (L thisLoc ITccurly)
return (L thisLoc ITvccurly)
ALRNoLayout _ isLet : ls ->
do let ls' = if isALRopen u
then ALRNoLayout (containsCommas u) False : ls
......@@ -2790,21 +2792,21 @@ alternativeLayoutRuleToken t
(ITin, ALRLayout ALRLayoutLet _ : ls, _) ->
do setALRContext ls
setPendingImplicitTokens [t]
return (L thisLoc ITccurly)
return (L thisLoc ITvccurly)
(ITin, ALRLayout _ _ : ls, _) ->
do setALRContext ls
setNextToken t
return (L thisLoc ITccurly)
return (L thisLoc ITvccurly)
-- the other ITin case omitted; general case below covers it
(ITcomma, ALRLayout _ _ : ls, _)
| topNoLayoutContainsCommas ls ->
do setALRContext ls
setNextToken t
return (L thisLoc ITccurly)
return (L thisLoc ITvccurly)
(ITwhere, ALRLayout ALRLayoutDo _ : ls, _) ->
do setALRContext ls
setPendingImplicitTokens [t]
return (L thisLoc ITccurly)
return (L thisLoc ITvccurly)
-- the other ITwhere case omitted; general case below covers it
(_, _, _) -> return t
......@@ -2898,7 +2900,7 @@ lexTokenStream :: StringBuffer -> RealSrcLoc -> DynFlags -> ParseResult [Located
lexTokenStream buf loc dflags = unP go initState{ options = opts' }
where dflags' = gopt_set (gopt_unset dflags Opt_Haddock) Opt_KeepRawTokenStream
initState@PState{ options = opts } = mkPState dflags' buf loc
opts' = opts{ pExtsBitmap = xbit UsePosPragsBit .|. pExtsBitmap opts }
opts' = opts{ pExtsBitmap = complement (xbit UsePosPragsBit) .&. pExtsBitmap opts }
go = do
ltok <- lexer False return
case ltok of
......
-- -*-haskell-*-
-- ---------------------------------------------------------------------------
-- (c) The University of Glasgow 1997-2003
......@@ -1142,20 +1141,20 @@ inst_decl :: { LInstDecl GhcPs }
-- data/newtype instance declaration
| data_or_newtype 'instance' capi_ctype tycl_hdr_inst constrs
maybe_derivings
{% amms (mkDataFamInst (comb4 $1 $4 $5 $6) (snd $ unLoc $1) $3 $4
{% amms (mkDataFamInst (comb4 $1 $4 $5 $6) (snd $ unLoc $1) $3 (snd $ unLoc $4)
Nothing (reverse (snd $ unLoc $5))
(fmap reverse $6))
((fst $ unLoc $1):mj AnnInstance $2:(fst $ unLoc $5)) }
((fst $ unLoc $1):mj AnnInstance $2:(fst $ unLoc $4)++(fst $ unLoc $5)) }
-- GADT instance declaration
| data_or_newtype 'instance' capi_ctype tycl_hdr_inst opt_kind_sig
gadt_constrlist
maybe_derivings
{% amms (mkDataFamInst (comb4 $1 $4 $6 $7) (snd $ unLoc $1) $3 $4
{% amms (mkDataFamInst (comb4 $1 $4 $6 $7) (snd $ unLoc $1) $3 (snd $ unLoc $4)
(snd $ unLoc $5) (snd $ unLoc $6)
(fmap reverse $7))
((fst $ unLoc $1):mj AnnInstance $2
:(fst $ unLoc $5)++(fst $ unLoc $6)) }
:(fst $ unLoc $4)++(fst $ unLoc $5)++(fst $ unLoc $6)) }
overlap_pragma :: { Maybe (Located OverlapMode) }
: '{-# OVERLAPPABLE' '#-}' {% ajs (Just (sLL $1 $> (Overlappable (getOVERLAPPABLE_PRAGs $1))))
......@@ -1241,8 +1240,8 @@ ty_fam_inst_eqn :: { Located ([AddAnn],TyFamInstEqn GhcPs) }
: 'forall' tv_bndrs '.' type '=' ktype
{% do { hintExplicitForall (getLoc $1)
; (eqn,ann) <- mkTyFamInstEqn (Just $2) $4 $6
; ams (sLL $4 $> (mj AnnEqual $5:ann, eqn))
[mu AnnForall $1, mj AnnDot $3] } }
; return (sLL $1 $>
(mu AnnForall $1:mj AnnDot $3:mj AnnEqual $5:ann,eqn)) } }
| type '=' ktype
{% do { (eqn,ann) <- mkTyFamInstEqn Nothing $1 $3
; return (sLL $1 $> (mj AnnEqual $2:ann, eqn)) } }
......@@ -1312,16 +1311,16 @@ at_decl_inst :: { LInstDecl GhcPs }
-- data/newtype instance declaration, with optional 'instance' keyword
-- (can't use opt_instance because you get reduce/reduce errors)
| data_or_newtype capi_ctype tycl_hdr_inst constrs maybe_derivings
{% amms (mkDataFamInst (comb4 $1 $3 $4 $5) (snd $ unLoc $1) $2 $3
{% amms (mkDataFamInst (comb4 $1 $3 $4 $5) (snd $ unLoc $1) $2 (snd $ unLoc $3)
Nothing (reverse (snd $ unLoc $4))
(fmap reverse $5))
((fst $ unLoc $1):(fst $ unLoc $4)) }
((fst $ unLoc $1):(fst $ unLoc $3) ++ (fst $ unLoc $4)) }
| data_or_newtype 'instance' capi_ctype tycl_hdr_inst constrs maybe_derivings
{% amms (mkDataFamInst (comb4 $1 $4 $5 $6) (snd $ unLoc $1) $3 $4
{% amms (mkDataFamInst (comb4 $1 $4 $5 $6) (snd $ unLoc $1) $3 (snd $ unLoc $4)
Nothing (reverse (snd $ unLoc $5))
(fmap reverse $6))
((fst $ unLoc $1):mj AnnInstance $2:(fst $ unLoc $5)) }
((fst $ unLoc $1):mj AnnInstance $2:(fst $ unLoc $4)++(fst $ unLoc $5)) }
-- GADT instance declaration, with optional 'instance' keyword
-- (can't use opt_instance because you get reduce/reduce errors)
......@@ -1329,17 +1328,17 @@ at_decl_inst :: { LInstDecl GhcPs }
gadt_constrlist
maybe_derivings
{% amms (mkDataFamInst (comb4 $1 $3 $5 $6) (snd $ unLoc $1) $2
$3 (snd $ unLoc $4) (snd $ unLoc $5)
(snd $ unLoc $3) (snd $ unLoc $4) (snd $ unLoc $5)
(fmap reverse $6))
((fst $ unLoc $1):(fst $ unLoc $4)++(fst $ unLoc $5)) }
((fst $ unLoc $1):(fst $ unLoc $3)++(fst $ unLoc $4)++(fst $ unLoc $5)) }
| data_or_newtype 'instance' capi_ctype tycl_hdr_inst opt_kind_sig
gadt_constrlist
maybe_derivings
{% amms (mkDataFamInst (comb4 $1 $4 $6 $7) (snd $ unLoc $1) $3
$4 (snd $ unLoc $5) (snd $ unLoc $6)
(snd $ unLoc $4) (snd $ unLoc $5) (snd $ unLoc $6)
(fmap reverse $7))
((fst $ unLoc $1):mj AnnInstance $2:(fst $ unLoc $5)++(fst $ unLoc $6)) }
((fst $ unLoc $1):mj AnnInstance $2:(fst $ unLoc $4)++(fst $ unLoc $5)++(fst $ unLoc $6)) }
data_or_newtype :: { Located (AddAnn, NewOrData) }
: 'data' { sL1 $1 (mj AnnData $1,DataType) }
......@@ -1382,20 +1381,21 @@ tycl_hdr :: { Located (Maybe (LHsContext GhcPs), LHsType GhcPs) }
}
| type { sL1 $1 (Nothing, $1) }
tycl_hdr_inst :: { Located (Maybe (LHsContext GhcPs), Maybe [LHsTyVarBndr GhcPs], LHsType GhcPs) }
tycl_hdr_inst :: { Located ([AddAnn],(Maybe (LHsContext GhcPs), Maybe [LHsTyVarBndr GhcPs], LHsType GhcPs)) }
: 'forall' tv_bndrs '.' context '=>' type {% hintExplicitForall (getLoc $1)
>> (addAnnotation (gl $4) (toUnicodeAnn AnnDarrow $5) (gl $5)
>> ams (sLL $1 $> $ (Just $4, Just $2, $6))
[mu AnnForall $1, mj AnnDot $3])
>> return (sLL $1 $> ([mu AnnForall $1, mj AnnDot $3]
, (Just $4, Just $2, $6)))
)
}
| 'forall' tv_bndrs '.' type {% hintExplicitForall (getLoc $1)
>> ams (sLL $1 $> $ (Nothing, Just $2, $4))
[mu AnnForall $1, mj AnnDot $3]
>> return (sLL $1 $> ([mu AnnForall $1, mj AnnDot $3]
, (Nothing, Just $2, $4)))
}
| context '=>' type {% addAnnotation (gl $1) (toUnicodeAnn AnnDarrow $2) (gl $2)
>> (return (sLL $1 $> (Just $1, Nothing, $3)))
>> (return (sLL $1 $>([], (Just $1, Nothing, $3))))
}
| type { sL1 $1 (Nothing, Nothing, $1) }
| type { sL1 $1 ([], (Nothing, Nothing, $1)) }
capi_ctype :: { Maybe (Located CType) }
......@@ -1988,7 +1988,7 @@ tyapps :: { [Located TyEl] } -- NB: This list is reversed
tyapp :: { Located TyEl }
: atype { sL1 $1 $ TyElOpd (unLoc $1) }
| TYPEAPP atype { sLL $1 $> $ (TyElKindApp (getLoc $1) $2) }
| TYPEAPP atype { sLL $1 $> $ (TyElKindApp (comb2 $1 $2) $2) }
| qtyconop { sL1 $1 $ TyElOpr (unLoc $1) }
| tyvarop { sL1 $1 $ TyElOpr (unLoc $1) }
| SIMPLEQUOTE qconop {% ams (sLL $1 $> $ TyElOpr (unLoc $2))
......@@ -2580,7 +2580,7 @@ exp10 :: { LHsExpr GhcPs }
| scc_annot exp {% ams (sLL $1 $> $ HsSCC noExt (snd $ fst $ unLoc $1) (snd $ unLoc $1) $2)
(fst $ fst $ unLoc $1) }
optSemi :: { ([Located a],Bool) }
optSemi :: { ([Located Token],Bool) }
: ';' { ([$1],True) }
| {- empty -} { ([],False) }
......
......@@ -263,13 +263,13 @@ mkTyFamInstEqn bndrs lhs rhs
mkDataFamInst :: SrcSpan
-> NewOrData
-> Maybe (Located CType)
-> Located ( Maybe (LHsContext GhcPs), Maybe [LHsTyVarBndr GhcPs]
, LHsType GhcPs)
-> (Maybe ( LHsContext GhcPs), Maybe [LHsTyVarBndr GhcPs]
, LHsType GhcPs)
-> Maybe (LHsKind GhcPs)
-> [LConDecl GhcPs]
-> HsDeriving GhcPs
-> P (LInstDecl GhcPs)
mkDataFamInst loc new_or_data cType (dL->L _ (mcxt, bndrs, tycl_hdr))
mkDataFamInst loc new_or_data cType (mcxt, bndrs, tycl_hdr)
ksig data_cons maybe_deriv
= do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr
; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
......@@ -831,7 +831,8 @@ checkTyVars pp_what equals_or_where tc tparms
= do { (tvs, anns) <- fmap unzip $ mapM check tparms
; return (mkHsQTvs tvs, concat anns) }
where
check (HsTypeArg ki@(L loc _)) = Left (loc,
check (HsTypeArg _ ki@(L loc _))
= Left (loc,
vcat [ text "Unexpected type application" <+>
text "@" <> ppr ki
, text "In the" <+> pp_what <+>
......@@ -956,10 +957,10 @@ checkTyClHdr is_cls ty
goL (dL->L l ty) acc ann fix = go l ty acc ann fix
-- workaround to define '*' despite StarIsType
go _ (HsParTy _ (dL->L l (HsStarTy _ isUni))) acc ann fix
go lp (HsParTy _ (dL->L l (HsStarTy _ isUni))) acc ann fix
= do { warnStarBndr l
; let name = mkOccName tcClsName (if isUni then "★" else "*")
; return (cL l (Unqual name), acc, fix, ann) }
; return (cL l (Unqual name), acc, fix, (ann ++ mkParensApiAnn lp)) }
go l (HsTyVar _ _ (dL->L _ tc)) acc ann fix
| isRdrTc tc = return (cL l tc, acc, fix, ann)
......@@ -967,7 +968,7 @@ checkTyClHdr is_cls ty
| isRdrTc tc = return (ltc, HsValArg t1:HsValArg t2:acc, Infix, ann)
go l (HsParTy _ ty) acc ann fix = goL ty acc (ann ++mkParensApiAnn l) fix
go _ (HsAppTy _ t1 t2) acc ann fix = goL t1 (HsValArg t2:acc) ann fix
go _ (HsAppKindTy _ ty ki) acc ann fix = goL ty (HsTypeArg ki:acc) ann fix
go _ (HsAppKindTy l ty ki) acc ann fix = goL ty (HsTypeArg l ki:acc) ann fix
go l (HsTupleTy _ HsBoxedOrConstraintTuple ts) [] ann fix
= return (cL l (nameRdrName tup_name), map HsValArg ts, fix, ann)
where
......@@ -1374,10 +1375,26 @@ isFunLhs e = go e [] []
-- | Either an operator or an operand.
data TyEl = TyElOpr RdrName | TyElOpd (HsType GhcPs)
| TyElKindApp SrcSpan (LHsType GhcPs)
-- See Note [TyElKindApp SrcSpan interpretation]
| TyElTilde | TyElBang
| TyElUnpackedness ([AddAnn], SourceText, SrcUnpackedness)
| TyElDocPrev HsDocString
{- Note [TyElKindApp SrcSpan interpretation]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
A TyElKindApp captures type application written in haskell as
@ Foo
where Foo is some type.
The SrcSpan reflects both elements, and there are AnnAt and AnnVal API
Annotations attached to this SrcSpan for the specific locations of
each within it.
-}
instance Outputable TyEl where
ppr (TyElOpr name) = ppr name
ppr (TyElOpd ty) = ppr ty
......@@ -1458,12 +1475,11 @@ mergeOps all_xs = go (0 :: Int) [] id all_xs
-- handle (NO)UNPACK pragmas
go k acc ops_acc ((dL->L l (TyElUnpackedness (anns, unpkSrc, unpk))):xs) =
if not (null acc) && null xs
then do { (addAccAnns, acc') <- eitherToP $ mergeOpsAcc acc
then do { acc' <- eitherToP $ mergeOpsAcc acc
; let a = ops_acc acc'
strictMark = HsSrcBang unpkSrc unpk NoSrcStrict
bl = combineSrcSpans l (getLoc a)
bt = HsBangTy noExt strictMark a
; addAccAnns
; addAnnsAt bl anns
; return (cL bl bt) }
else parseErrorSDoc l unpkError
......@@ -1499,8 +1515,7 @@ mergeOps all_xs = go (0 :: Int) [] id all_xs
-- due to #15884
in guess xs
= if not (null acc) && (k > 1 || length acc > 1)
then do { (_, a) <- eitherToP (mergeOpsAcc acc)
-- no need to add annotations since it fails anyways!
then do { a <- eitherToP (mergeOpsAcc acc)
; failOpStrictnessCompound (cL l str) (ops_acc a) }
else failOpStrictnessPosition (cL l str)
......@@ -1511,8 +1526,7 @@ mergeOps all_xs = go (0 :: Int) [] id all_xs
go k acc ops_acc ((dL->L l (TyElOpr op)):xs) =
if null acc || null (filter isTyElOpd xs)
then failOpFewArgs (cL l op)
else do { (addAccAnns, acc') <- eitherToP (mergeOpsAcc acc)
; addAccAnns
else do { acc' <- eitherToP (mergeOpsAcc acc)
; go (k + 1) [] (\c -> mkLHsOpTy c (cL l op) (ops_acc acc')) xs }
where
isTyElOpd (dL->L _ (TyElOpd _)) = True
......@@ -1534,33 +1548,32 @@ mergeOps all_xs = go (0 :: Int) [] id all_xs
-- clause [tyapp]:
-- whenever a type application is encountered, it is added to the accumulator
go k acc ops_acc ((dL->L _ (TyElKindApp l a)):xs) = go k (HsTypeArg (l, a):acc) ops_acc xs
go k acc ops_acc ((dL->L _ (TyElKindApp l a)):xs) = go k (HsTypeArg l a:acc) ops_acc xs
-- clause [end]
-- See Note [Non-empty 'acc' in mergeOps clause [end]]
go _ acc ops_acc [] = do { (addAccAnns, acc') <- eitherToP (mergeOpsAcc acc)
; addAccAnns
go _ acc ops_acc [] = do { acc' <- eitherToP (mergeOpsAcc acc)
; return (ops_acc acc') }
go _ _ _ _ = panic "mergeOps.go: Impossible Match"
-- due to #15884
mergeOpsAcc :: [HsArg (LHsType GhcPs) (SrcSpan, LHsKind GhcPs)]
-> Either (SrcSpan, SDoc) (P (), LHsType GhcPs)
mergeOpsAcc :: [HsArg (LHsType GhcPs) (LHsKind GhcPs)]
-> Either (SrcSpan, SDoc) (LHsType GhcPs)
mergeOpsAcc [] = panic "mergeOpsAcc: empty input"
mergeOpsAcc (HsTypeArg (_, L loc ki):_)
mergeOpsAcc (HsTypeArg _ (L loc ki):_)
= Left (loc, text "Unexpected type application:" <+> ppr ki)
mergeOpsAcc (HsValArg ty : xs) = go1 (pure ()) ty xs
mergeOpsAcc (HsValArg ty : xs) = go1 ty xs
where
go1 :: P () -> LHsType GhcPs
-> [HsArg (LHsType GhcPs) (SrcSpan, LHsKind GhcPs)]
-> Either (SrcSpan, SDoc) (P (), LHsType GhcPs)
go1 anns lhs [] = Right (anns, lhs)
go1 anns lhs (x:xs) = case x of
HsValArg ty -> go1 anns (mkHsAppTy lhs ty) xs
HsTypeArg (loc, ki) -> let ty = mkHsAppKindTy lhs ki
in go1 (addAnnotation (getLoc ty) AnnAt loc >> anns) ty xs
HsArgPar _ -> go1 anns lhs xs
go1 :: LHsType GhcPs
-> [HsArg (LHsType GhcPs) (LHsKind GhcPs)]
-> Either (SrcSpan, SDoc) (LHsType GhcPs)
go1 lhs [] = Right lhs
go1 lhs (x:xs) = case x of
HsValArg ty -> go1 (mkHsAppTy lhs ty) xs
HsTypeArg loc ki -> let ty = mkHsAppKindTy loc lhs ki
in go1 ty xs
HsArgPar _ -> go1 lhs xs
mergeOpsAcc (HsArgPar _: xs) = mergeOpsAcc xs
{- Note [Impossible case in mergeOps clause [unpk]]
......@@ -1623,19 +1636,19 @@ pInfixSide (el:xs1)
| Just t1 <- pLHsTypeArg el
= go [t1] xs1
where
go :: [HsArg (LHsType GhcPs) (SrcSpan, LHsKind GhcPs)]
go :: [HsArg (LHsType GhcPs) (LHsKind GhcPs)]
-> [Located TyEl] -> Maybe (LHsType GhcPs, P (), [Located TyEl])
go acc (el:xs)
| Just t <- pLHsTypeArg el
= go (t:acc) xs
go acc xs = case mergeOpsAcc acc of
Left _ -> Nothing
Right (addAnns, acc') -> Just (acc', addAnns, xs)
Right acc' -> Just (acc', pure (), xs)
pInfixSide _ = Nothing
pLHsTypeArg :: Located TyEl -> Maybe (HsArg (LHsType GhcPs) (SrcSpan, LHsKind GhcPs))
pLHsTypeArg :: Located TyEl -> Maybe (HsArg (LHsType GhcPs) (LHsKind GhcPs))
pLHsTypeArg (dL->L l (TyElOpd a)) = Just (HsValArg (L l a))
pLHsTypeArg (dL->L _ (TyElKindApp l a)) = Just (HsTypeArg (l,a))
pLHsTypeArg (dL->L _ (TyElKindApp l a)) = Just (HsTypeArg l a)
pLHsTypeArg _ = Nothing
pDocPrev :: [Located TyEl] -> (Maybe LHsDocString, [Located TyEl])
......
......@@ -360,7 +360,7 @@ basicKnownKeyNames
-- Others
otherwiseIdName, inlineIdName,
eqStringName, assertName, breakpointName, breakpointCondName,
breakpointAutoName, opaqueTyConName,
opaqueTyConName,
assertErrorName, traceName,
printName, fstName, sndName,
dollarName,
......@@ -1081,7 +1081,7 @@ groupWithName = varQual gHC_EXTS (fsLit "groupWith") groupWithIdKey
-- Random PrelBase functions
fromStringName, otherwiseIdName, foldrName, buildName, augmentName,
mapName, appendName, assertName,
breakpointName, breakpointCondName, breakpointAutoName,
breakpointName, breakpointCondName,
opaqueTyConName, dollarName :: Name
dollarName = varQual gHC_BASE (fsLit "$") dollarIdKey
otherwiseIdName = varQual gHC_BASE (fsLit "otherwise") otherwiseIdKey
......@@ -1093,29 +1093,9 @@ appendName = varQual gHC_BASE (fsLit "++") appendIdKey
assertName = varQual gHC_BASE (fsLit "assert") assertIdKey
breakpointName = varQual gHC_BASE (fsLit "breakpoint") breakpointIdKey
breakpointCondName= varQual gHC_BASE (fsLit "breakpointCond") breakpointCondIdKey
breakpointAutoName= varQual gHC_BASE (fsLit "breakpointAuto") breakpointAutoIdKey
opaqueTyConName = tcQual gHC_BASE (fsLit "Opaque") opaqueTyConKey
fromStringName = varQual dATA_STRING (fsLit "fromString") fromStringClassOpKey
breakpointJumpName :: Name
breakpointJumpName
= mkInternalName
breakpointJumpIdKey
(mkOccNameFS varName (fsLit "breakpointJump"))
noSrcSpan
breakpointCondJumpName :: Name
breakpointCondJumpName
= mkInternalName
breakpointCondJumpIdKey
(mkOccNameFS varName (fsLit "breakpointCondJump"))
noSrcSpan
breakpointAutoJumpName :: Name
breakpointAutoJumpName
= mkInternalName
breakpointAutoJumpIdKey
(mkOccNameFS varName (fsLit "breakpointAutoJump"))
noSrcSpan
-- PrelTup
fstName, sndName :: Name
fstName = varQual dATA_TUPLE (fsLit "fst") fstIdKey
......@@ -2224,15 +2204,9 @@ runRWKey = mkPreludeMiscIdUnique 107
traceKey :: Unique
traceKey = mkPreludeMiscIdUnique 108
breakpointIdKey, breakpointCondIdKey, breakpointAutoIdKey,
breakpointJumpIdKey, breakpointCondJumpIdKey,
breakpointAutoJumpIdKey :: Unique
breakpointIdKey, breakpointCondIdKey :: Unique
breakpointIdKey = mkPreludeMiscIdUnique 110
breakpointCondIdKey = mkPreludeMiscIdUnique 111
breakpointAutoIdKey = mkPreludeMiscIdUnique 112
breakpointJumpIdKey = mkPreludeMiscIdUnique 113
breakpointCondJumpIdKey = mkPreludeMiscIdUnique 114
breakpointAutoJumpIdKey = mkPreludeMiscIdUnique 115
inlineIdKey, noinlineIdKey :: Unique
inlineIdKey = mkPreludeMiscIdUnique 120
......
......@@ -855,9 +855,9 @@ mkProxyPrimTy :: Type -> Type -> Type
mkProxyPrimTy k ty = TyConApp proxyPrimTyCon [k, ty]
proxyPrimTyCon :: TyCon
proxyPrimTyCon = mkPrimTyCon proxyPrimTyConName binders res_kind [Nominal,Nominal]
proxyPrimTyCon = mkPrimTyCon proxyPrimTyConName binders res_kind [Nominal,Phantom]
where
-- Kind: forall k. k -> Void#
-- Kind: forall k. k -> TYPE (Tuple '[])
binders = mkTemplateTyConBinders [liftedTypeKind] id
res_kind = unboxedTupleKind []
......@@ -873,7 +873,7 @@ eqPrimTyCon :: TyCon -- The representation type for equality predicates
-- See Note [The equality types story]
eqPrimTyCon = mkPrimTyCon eqPrimTyConName binders res_kind roles
where
-- Kind :: forall k1 k2. k1 -> k2 -> Void#
-- Kind :: forall k1 k2. k1 -> k2 -> TYPE (Tuple '[])
binders = mkTemplateTyConBinders [liftedTypeKind, liftedTypeKind] id
res_kind = unboxedTupleKind []
roles = [Nominal, Nominal, Nominal, Nominal]
......@@ -884,7 +884,7 @@ eqPrimTyCon = mkPrimTyCon eqPrimTyConName binders res_kind roles
eqReprPrimTyCon :: TyCon -- See Note [The equality types story]
eqReprPrimTyCon = mkPrimTyCon eqReprPrimTyConName binders res_kind roles
where
-- Kind :: forall k1 k2. k1 -> k2 -> Void#
-- Kind :: forall k1 k2. k1 -> k2 -> TYPE (Tuple '[])
binders = mkTemplateTyConBinders [liftedTypeKind, liftedTypeKind] id
res_kind = unboxedTupleKind []
roles = [Nominal, Nominal, Representational, Representational]
......@@ -895,7 +895,7 @@ eqReprPrimTyCon = mkPrimTyCon eqReprPrimTyConName binders res_kind roles
eqPhantPrimTyCon :: TyCon
eqPhantPrimTyCon = mkPrimTyCon eqPhantPrimTyConName binders res_kind roles
where
-- Kind :: forall k1 k2. k1 -> k2 -> Void#
-- Kind :: forall k1 k2. k1 -> k2 -> TYPE (Tuple '[])
binders = mkTemplateTyConBinders [liftedTypeKind, liftedTypeKind] id
res_kind = unboxedTupleKind []
roles = [Nominal, Nominal, Phantom, Phantom]
......
......@@ -486,9 +486,9 @@ rnLHsTypeArg :: HsDocContext -> LHsTypeArg GhcPs
rnLHsTypeArg ctxt (HsValArg ty)
= do { (tys_rn, fvs) <- rnLHsType ctxt ty
; return (HsValArg tys_rn, fvs) }
rnLHsTypeArg ctxt (HsTypeArg ki)
rnLHsTypeArg ctxt (HsTypeArg l ki)
= do { (kis_rn, fvs) <- rnLHsKind ctxt ki
; return (HsTypeArg kis_rn, fvs) }
; return (HsTypeArg l kis_rn, fvs) }
rnLHsTypeArg _ (HsArgPar sp)
= return (HsArgPar sp, emptyFVs)
......@@ -636,12 +636,12 @@ rnHsTyKi env (HsAppTy _ ty1 ty2)
; (ty2', fvs2) <- rnLHsTyKi env ty2
; return (HsAppTy noExt ty1' ty2', fvs1 `plusFV` fvs2) }
rnHsTyKi env (HsAppKindTy _ ty k)
rnHsTyKi env (HsAppKindTy l ty k)
= do { kind_app <- xoptM LangExt.TypeApplications
; unless kind_app (addErr (typeAppErr "kind" k))
; (ty', fvs1) <- rnLHsTyKi env ty
; (k', fvs2) <- rnLHsTyKi (env {rtke_level = KindLevel }) k
; return (HsAppKindTy noExt ty' k', fvs1 `plusFV` fvs2) }
; return (HsAppKindTy l ty' k', fvs1 `plusFV` fvs2) }
rnHsTyKi env t@(HsIParamTy _ n ty)
= do { notInKinds env t
......@@ -1632,7 +1632,7 @@ inScope rdr_env rdr = rdr `elemLocalRdrEnv` rdr_env
extract_tyarg :: LHsTypeArg GhcPs -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
extract_tyarg (HsValArg ty) acc = extract_lty TypeLevel ty acc
extract_tyarg (HsTypeArg ki) acc = extract_lty KindLevel ki acc
extract_tyarg (HsTypeArg _ ki) acc = extract_lty KindLevel ki acc
extract_tyarg (HsArgPar _) acc = acc
extract_tyargs :: [LHsTypeArg GhcPs] -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
......
......@@ -2210,17 +2210,45 @@ extendFvs env s
Note [Binder swap]
~~~~~~~~~~~~~~~~~~
We do these two transformations right here:
The "binder swap" tranformation swaps occurence of the
scrutinee of a case for occurrences of the case-binder:
(1) case x of b { pi -> ri }
==>
(1) case x of b { pi -> ri }
==>
case x of b { pi -> let x=b in ri }
(2) case (x |> co) of b { pi -> ri }
==>
==>
case (x |> co) of b { pi -> let x = b |> sym co in ri }
Why (2)? See Note [Case of cast]
In both cases, the trivial 'let' can be eliminated by the
immediately following simplifier pass.
There are two reasons for making this swap:
(A) It reduces the number of occurrences of the scrutinee, x.
That in turn might reduce its occurrences to one, so we
can inline it and save an allocation. E.g.