--------------------------------------------------------------------------------- The register liveness determinator---- (c) The University of Glasgow 2004-------------------------------------------------------------------------------{-# OPTIONS -Wall -fno-warn-name-shadowing #-}moduleRegAlloc.Liveness(RegSet,RegMap,emptyRegMap,BlockMap,emptyBlockMap,LiveCmmTop,LiveInstr(..),Liveness(..),LiveInfo(..),LiveBasicBlock,mapBlockTop,mapBlockTopM,mapGenBlockTop,mapGenBlockTopM,stripLive,stripLiveBlock,slurpConflicts,slurpReloadCoalesce,eraseDeltasLive,patchEraseLive,patchRegsLiveInstr,regLiveness)whereimportRegimportInstructionimportBlockIdimportCmmhiding(RegSet)importPprCmm()importDigraphimportOutputableimportUniqueimportUniqSetimportUniqFMimportUniqSupplyimportBagimportStateimportFastStringimportData.ListimportData.Maybe-----------------------------------------------------------------------------typeRegSet=UniqSetRegtypeRegMapa=UniqFMaemptyRegMap::UniqFMaemptyRegMap=emptyUFMtypeBlockMapa=BlockEnvaemptyBlockMap::BlockEnvaemptyBlockMap=emptyBlockEnv-- | A top level thing which carries liveness information.typeLiveCmmTopinstr=GenCmmTopCmmStaticLiveInfo(ListGraph(GenBasicBlock(LiveInstrinstr)))-- the "instructions" here are actually more blocks,-- single blocks are acyclic-- multiple blocks are taken to be cyclic.-- | An instruction with liveness information.dataLiveInstrinstr=Instrinstr(MaybeLiveness)-- | spill this reg to a stack slot|SPILLRegInt-- | reload this reg from a stack slot|RELOADIntReg-- | Liveness information.-- The regs which die are ones which are no longer live in the *next* instruction-- in this sequence.-- (NB. if the instruction is a jump, these registers might still be live-- at the jump target(s) - you have to check the liveness at the destination-- block to find out).dataLiveness=Liveness{liveBorn::RegSet-- ^ registers born in this instruction (written to for first time).,liveDieRead::RegSet-- ^ registers that died because they were read for the last time.,liveDieWrite::RegSet}-- ^ registers that died because they were clobbered by something.-- | Stash regs live on entry to each basic block in the info part of the cmm code.dataLiveInfo=LiveInfo[CmmStatic]-- cmm static stuff(MaybeBlockId)-- id of the first block(BlockMapRegSet)-- argument locals live on entry to this block-- | A basic block with liveness information.typeLiveBasicBlockinstr=GenBasicBlock(LiveInstrinstr)instanceOutputableinstr=>Outputable(LiveInstrinstr)whereppr(SPILLregslot)=hcat[ptext(sLit"\tSPILL"),char' ',pprreg,comma,ptext(sLit"SLOT")<>parens(intslot)]ppr(RELOADslotreg)=hcat[ptext(sLit"\tRELOAD"),char' ',ptext(sLit"SLOT")<>parens(intslot),comma,pprreg]ppr(InstrinstrNothing)=pprinstrppr(Instrinstr(Justlive))=pprinstr$$(nest8$vcat[pprRegs(ptext(sLit"# born: "))(liveBornlive),pprRegs(ptext(sLit"# r_dying: "))(liveDieReadlive),pprRegs(ptext(sLit"# w_dying: "))(liveDieWritelive)]$+$space)wherepprRegs::SDoc->RegSet->SDocpprRegsnameregs|isEmptyUniqSetregs=empty|otherwise=name<>(hcat$punctuatespace$mapppr$uniqSetToListregs)instanceOutputableLiveInfowhereppr(LiveInfostaticfirstIdliveOnEntry)=(vcat$mappprstatic)$$text"# firstId = "<>pprfirstId$$text"# liveOnEntry = "<>pprliveOnEntry-- | map a function across all the basic blocks in this code--mapBlockTop::(LiveBasicBlockinstr->LiveBasicBlockinstr)->LiveCmmTopinstr->LiveCmmTopinstrmapBlockTopfcmm=evalState(mapBlockTopM(\x->return$fx)cmm)()-- | map a function across all the basic blocks in this code (monadic version)--mapBlockTopM::Monadm=>(LiveBasicBlockinstr->m(LiveBasicBlockinstr))->LiveCmmTopinstr->m(LiveCmmTopinstr)mapBlockTopM_cmm@(CmmData{})=returncmmmapBlockTopMf(CmmProcheaderlabelparams(ListGraphcomps))=docomps'<-mapM(mapBlockCompMf)compsreturn$CmmProcheaderlabelparams(ListGraphcomps')mapBlockCompM::Monadm=>(a->ma')->(GenBasicBlocka)->m(GenBasicBlocka')mapBlockCompMf(BasicBlockiblocks)=doblocks'<-mapMfblocksreturn$BasicBlockiblocks'-- map a function across all the basic blocks in this codemapGenBlockTop::(GenBasicBlocki->GenBasicBlocki)->(GenCmmTopdh(ListGraphi)->GenCmmTopdh(ListGraphi))mapGenBlockTopfcmm=evalState(mapGenBlockTopM(\x->return$fx)cmm)()-- | map a function across all the basic blocks in this code (monadic version)mapGenBlockTopM::Monadm=>(GenBasicBlocki->m(GenBasicBlocki))->(GenCmmTopdh(ListGraphi)->m(GenCmmTopdh(ListGraphi)))mapGenBlockTopM_cmm@(CmmData{})=returncmmmapGenBlockTopMf(CmmProcheaderlabelparams(ListGraphblocks))=doblocks'<-mapMfblocksreturn$CmmProcheaderlabelparams(ListGraphblocks')-- | Slurp out the list of register conflicts and reg-reg moves from this top level thing.-- Slurping of conflicts and moves is wrapped up together so we don't have-- to make two passes over the same code when we want to build the graph.--slurpConflicts::Instructioninstr=>LiveCmmTopinstr->(Bag(UniqSetReg),Bag(Reg,Reg))slurpConflictslive=slurpCmm(emptyBag,emptyBag)livewhereslurpCmmrsCmmData{}=rsslurpCmmrs(CmmProcinfo__(ListGraphblocks))=foldl'(slurpCompinfo)rsblocksslurpCompinfors(BasicBlock_blocks)=foldl'(slurpBlockinfo)rsblocksslurpBlockinfors(BasicBlockblockIdinstrs)|LiveInfo__blockLive<-info,JustrsLiveEntry<-lookupBlockEnvblockLiveblockId,(conflicts,moves)<-slurpLIsrsLiveEntryrsinstrs=(consBagrsLiveEntryconflicts,moves)|otherwise=panic"Liveness.slurpConflicts: bad block"slurpLIsrsLive(conflicts,moves)[]=(consBagrsLiveconflicts,moves)slurpLIsrsLivers(Instr_Nothing:lis)=slurpLIsrsLiverslis-- we're not expecting to be slurping conflicts from spilled codeslurpLIs__(SPILL__:_)=panic"Liveness.slurpConflicts: unexpected SPILL"slurpLIs__(RELOAD__:_)=panic"Liveness.slurpConflicts: unexpected RELOAD"slurpLIsrsLiveEntry(conflicts,moves)(Instrinstr(Justlive):lis)=let-- regs that die because they are read for the last time at the start of an instruction-- are not live across it.rsLiveAcross=rsLiveEntry`minusUniqSet`(liveDieReadlive)-- regs live on entry to the next instruction.-- be careful of orphans, make sure to delete dying regs _after_ unioning-- in the ones that are born here.rsLiveNext=(rsLiveAcross`unionUniqSets`(liveBornlive))`minusUniqSet`(liveDieWritelive)-- orphan vregs are the ones that die in the same instruction they are born in.-- these are likely to be results that are never used, but we still-- need to assign a hreg to them..rsOrphans=intersectUniqSets(liveBornlive)(unionUniqSets(liveDieWritelive)(liveDieReadlive))--rsConflicts=unionUniqSetsrsLiveNextrsOrphansincasetakeRegRegMoveInstrinstrofJustrr->slurpLIsrsLiveNext(consBagrsConflictsconflicts,consBagrrmoves)lisNothing->slurpLIsrsLiveNext(consBagrsConflictsconflicts,moves)lis-- | For spill\/reloads---- SPILL v1, slot1-- ...-- RELOAD slot1, v2---- If we can arrange that v1 and v2 are allocated to the same hreg it's more likely-- the spill\/reload instrs can be cleaned and replaced by a nop reg-reg move.----slurpReloadCoalesce::Instructioninstr=>LiveCmmTopinstr->Bag(Reg,Reg)slurpReloadCoalescelive=slurpCmmemptyBaglivewhereslurpCmmcsCmmData{}=csslurpCmmcs(CmmProc___(ListGraphblocks))=foldl'slurpCompcsblocksslurpCompcscomp=let(moveBags,_)=runState(slurpCompMcomp)emptyUFMinunionManyBags(cs:moveBags)slurpCompM(BasicBlock_blocks)=do-- run the analysis once to record the mapping across jumps.mapM_(slurpBlockFalse)blocks-- run it a second time while using the information from the last pass.-- We /could/ run this many more times to deal with graphical control-- flow and propagating info across multiple jumps, but it's probably-- not worth the trouble.mapM(slurpBlockTrue)blocksslurpBlockpropagate(BasicBlockblockIdinstrs)=do-- grab the slot map for entry to this blockslotMap<-ifpropagatethengetSlotMapblockIdelsereturnemptyUFM(_,mMoves)<-mapAccumLMslurpLIslotMapinstrsreturn$listToBag$catMaybesmMovesslurpLI::Instructioninstr=>UniqFMReg-- current slotMap->LiveInstrinstr->State(UniqFM[UniqFMReg])-- blockId -> [slot -> reg]-- for tracking slotMaps across jumps(UniqFMReg-- new slotMap,Maybe(Reg,Reg))-- maybe a new coalesce edgeslurpLIslotMapli-- remember what reg was stored into the slot|SPILLregslot<-li,slotMap'<-addToUFMslotMapslotreg=return(slotMap',Nothing)-- add an edge betwen the this reg and the last one stored into the slot|RELOADslotreg<-li=caselookupUFMslotMapslotofJustreg2|reg/=reg2->return(slotMap,Just(reg,reg2))|otherwise->return(slotMap,Nothing)Nothing->return(slotMap,Nothing)-- if we hit a jump, remember the current slotMap|Instrinstr_<-li,targets<-jumpDestsOfInstrinstr,not$nulltargets=domapM_(accSlotMapslotMap)targetsreturn(slotMap,Nothing)|otherwise=return(slotMap,Nothing)-- record a slotmap for an in edge to this blockaccSlotMapslotMapblockId=modify(\s->addToUFM_C(++)sblockId[slotMap])-- work out the slot map on entry to this block-- if we have slot maps for multiple in-edges then we need to merge them.getSlotMapblockId=domap<-getletslotMaps=fromMaybe[](lookupUFMmapblockId)return$foldrmergeSlotMapsemptyUFMslotMapsmergeSlotMaps::UniqFMReg->UniqFMReg->UniqFMRegmergeSlotMapsmap1map2=listToUFM$[(k,r1)|(k,r1)<-ufmToListmap1,caselookupUFMmap2kofNothing->FalseJustr2->r1==r2]-- | Strip away liveness information, yielding NatCmmTopstripLive::Instructioninstr=>LiveCmmTopinstr->NatCmmTopinstrstripLivelive=stripCmmlivewherestripCmm(CmmDatasecds)=CmmDatasecdsstripCmm(CmmProc(LiveInfoinfo__)labelparams(ListGraphcomps))=CmmProcinfolabelparams(ListGraph$concatMapstripCompcomps)stripComp(BasicBlock_blocks)=mapstripLiveBlockblocks-- | Strip away liveness information from a basic block,-- and make real spill instructions out of SPILL, RELOAD pseudos along the way.stripLiveBlock::Instructioninstr=>LiveBasicBlockinstr->NatBasicBlockinstrstripLiveBlock(BasicBlockilis)=BasicBlockiinstrs'where(instrs',_)=runState(spillNat[]lis)0spillNatacc[]=return(reverseacc)spillNatacc(SPILLregslot:instrs)=dodelta<-getspillNat(mkSpillInstrregdeltaslot:acc)instrsspillNatacc(RELOADslotreg:instrs)=dodelta<-getspillNat(mkLoadInstrregdeltaslot:acc)instrsspillNatacc(Instrinstr_:instrs)|Justi<-takeDeltaInstrinstr=doputispillNataccinstrsspillNatacc(Instrinstr_:instrs)=spillNat(instr:acc)instrs-- | Erase Delta instructions.eraseDeltasLive::Instructioninstr=>LiveCmmTopinstr->LiveCmmTopinstreraseDeltasLivecmm=mapBlockToperaseBlockcmmwhereeraseBlock(BasicBlockidlis)=BasicBlockid$filter(\(Instri_)->not$isJust$takeDeltaInstri)$lis-- | Patch the registers in this code according to this register mapping.-- also erase reg -> reg moves when the reg is the same.-- also erase reg -> reg moves when the destination dies in this instr.patchEraseLive::Instructioninstr=>(Reg->Reg)->LiveCmmTopinstr->LiveCmmTopinstrpatchEraseLivepatchFcmm=patchCmmcmmwherepatchCmmcmm@CmmData{}=cmmpatchCmm(CmmProcinfolabelparams(ListGraphcomps))|LiveInfostaticidblockMap<-info=letpatchRegSetset=mkUniqSet$mappatchF$uniqSetToListsetblockMap'=mapBlockEnvpatchRegSetblockMapinfo'=LiveInfostaticidblockMap'inCmmProcinfo'labelparams$ListGraph$mappatchCompcompspatchComp(BasicBlockidblocks)=BasicBlockid$mappatchBlockblockspatchBlock(BasicBlockidlis)=BasicBlockid$patchInstrslispatchInstrs[]=[]patchInstrs(li:lis)|Instri(Justlive)<-li',Just(r1,r2)<-takeRegRegMoveInstri,eatMer1r2live=patchInstrslis|otherwise=li':patchInstrsliswhereli'=patchRegsLiveInstrpatchFlieatMer1r2live-- source and destination regs are the same|r1==r2=True-- desination reg is never used|elementOfUniqSetr2(liveBornlive),elementOfUniqSetr2(liveDieReadlive)||elementOfUniqSetr2(liveDieWritelive)=True|otherwise=False-- | Patch registers in this LiveInstr, including the liveness information.--patchRegsLiveInstr::Instructioninstr=>(Reg->Reg)->LiveInstrinstr->LiveInstrinstrpatchRegsLiveInstrpatchFli=caseliofInstrinstrNothing->Instr(patchRegsOfInstrinstrpatchF)NothingInstrinstr(Justlive)->Instr(patchRegsOfInstrinstrpatchF)(Justlive{-- WARNING: have to go via lists here because patchF changes the uniq in the RegliveBorn=mkUniqSet$mappatchF$uniqSetToList$liveBornlive,liveDieRead=mkUniqSet$mappatchF$uniqSetToList$liveDieReadlive,liveDieWrite=mkUniqSet$mappatchF$uniqSetToList$liveDieWritelive})SPILLregslot->SPILL(patchFreg)slotRELOADslotreg->RELOADslot(patchFreg)----------------------------------------------------------------------------------- Annotate code with register liveness information--regLiveness::Instructioninstr=>NatCmmTopinstr->UniqSM(LiveCmmTopinstr)regLiveness(CmmDataid)=returnUs$CmmDataidregLiveness(CmmProcinfolblparams(ListGraph[]))=returnUs$CmmProc(LiveInfoinfoNothingemptyBlockEnv)lblparams(ListGraph[])regLiveness(CmmProcinfolblparams(ListGraphblocks@(first:_)))=letfirst_id=blockIdfirstsccs=sccBlocksblocks(ann_sccs,block_live)=computeLivenesssccsliveBlocks=map(\scc->casesccofAcyclicSCCb@(BasicBlockl_)->BasicBlockl[b]CyclicSCCbs@(BasicBlockl_:_)->BasicBlocklbsCyclicSCC[]->panic"RegLiveness.regLiveness: no blocks in scc list")$ann_sccsinreturnUs$CmmProc(LiveInfoinfo(Justfirst_id)block_live)lblparams(ListGraphliveBlocks)sccBlocks::Instructioninstr=>[NatBasicBlockinstr]->[SCC(NatBasicBlockinstr)]sccBlocksblocks=stronglyConnCompFromEdgedVerticesgraphwheregetOutEdges::Instructioninstr=>[instr]->[BlockId]getOutEdgesinstrs=concat$mapjumpDestsOfInstrinstrsgraph=[(block,getUniqueid,mapgetUnique(getOutEdgesinstrs))|block@(BasicBlockidinstrs)<-blocks]-- ------------------------------------------------------------------------------- Computing livenesscomputeLiveness::Instructioninstr=>[SCC(NatBasicBlockinstr)]->([SCC(LiveBasicBlockinstr)],-- instructions annotated with list of registers-- which are "dead after this instruction".BlockMapRegSet)-- blocks annontated with set of live registers-- on entry to the block.-- NOTE: on entry, the SCCs are in "reverse" order: later blocks may transfer-- control to earlier ones only. The SCCs returned are in the *opposite* -- order, which is exactly what we want for the next pass.computeLivenesssccs=livenessSCCsemptyBlockMap[]sccslivenessSCCs::Instructioninstr=>BlockMapRegSet->[SCC(LiveBasicBlockinstr)]-- accum->[SCC(NatBasicBlockinstr)]->([SCC(LiveBasicBlockinstr)],BlockMapRegSet)livenessSCCsblockmapdone[]=(done,blockmap)livenessSCCsblockmapdone(AcyclicSCCblock:sccs)=let(blockmap',block')=livenessBlockblockmapblockinlivenessSCCsblockmap'(AcyclicSCCblock':done)sccslivenessSCCsblockmapdone(CyclicSCCblocks:sccs)=livenessSCCsblockmap'(CyclicSCCblocks':done)sccswhere(blockmap',blocks')=iterateUntilUnchangedlinearLivenessequalBlockMapsblockmapblocksiterateUntilUnchanged::(a->b->(a,c))->(a->a->Bool)->a->b->(a,c)iterateUntilUnchangedfeqab=head$concatMaptail$groupBy(\(a1,_)(a2,_)->eqa1a2)$iterate(\(a,_)->fab)$(a,panic"RegLiveness.livenessSCCs")linearLiveness::Instructioninstr=>BlockMapRegSet->[NatBasicBlockinstr]->(BlockMapRegSet,[LiveBasicBlockinstr])linearLiveness=mapAccumLlivenessBlock-- probably the least efficient way to compare two-- BlockMaps for equality.equalBlockMapsab=a'==b'wherea'=mapf$blockEnvToListab'=mapf$blockEnvToListbf(key,elt)=(key,uniqSetToListelt)-- | Annotate a basic block with register liveness information.--livenessBlock::Instructioninstr=>BlockMapRegSet->NatBasicBlockinstr->(BlockMapRegSet,LiveBasicBlockinstr)livenessBlockblockmap(BasicBlockblock_idinstrs)=let(regsLiveOnEntry,instrs1)=livenessBackemptyUniqSetblockmap[](reverseinstrs)blockmap'=extendBlockEnvblockmapblock_idregsLiveOnEntryinstrs2=livenessForwardregsLiveOnEntryinstrs1output=BasicBlockblock_idinstrs2in(blockmap',output)-- | Calculate liveness going forwards,-- filling in when regs are bornlivenessForward::Instructioninstr=>RegSet-- regs live on this instr->[LiveInstrinstr]->[LiveInstrinstr]livenessForward_[]=[]livenessForwardrsLiveEntry(li@(InstrinstrmLive):lis)|Nothing<-mLive=li:livenessForwardrsLiveEntrylis|Justlive<-mLive,RU_written<-regUsageOfInstrinstr=let-- Regs that are written to but weren't live on entry to this instruction-- are recorded as being born here.rsBorn=mkUniqSet$filter(\r->not$elementOfUniqSetrrsLiveEntry)writtenrsLiveNext=(rsLiveEntry`unionUniqSets`rsBorn)`minusUniqSet`(liveDieReadlive)`minusUniqSet`(liveDieWritelive)inInstrinstr(Justlive{liveBorn=rsBorn}):livenessForwardrsLiveNextlislivenessForward__=panic"RegLiveness.livenessForward: no match"-- | Calculate liveness going backwards,-- filling in when regs die, and what regs are live across each instructionlivenessBack::Instructioninstr=>RegSet-- regs live on this instr->BlockMapRegSet-- regs live on entry to other BBs->[LiveInstrinstr]-- instructions (accum)->[instr]-- instructions->(RegSet,[LiveInstrinstr])livenessBackliveregs_done[]=(liveregs,done)livenessBackliveregsblockmapacc(instr:instrs)=let(liveregs',instr')=liveness1liveregsblockmapinstrinlivenessBackliveregs'blockmap(instr':acc)instrs-- don't bother tagging comments or deltas with livenessliveness1::Instructioninstr=>RegSet->BlockMapRegSet->instr->(RegSet,LiveInstrinstr)liveness1liveregs_instr|isMetaInstrinstr=(liveregs,InstrinstrNothing)liveness1liveregsblockmapinstr|not_a_branch=(liveregs1,Instrinstr(Just$Liveness{liveBorn=emptyUniqSet,liveDieRead=mkUniqSetr_dying,liveDieWrite=mkUniqSetw_dying}))|otherwise=(liveregs_br,Instrinstr(Just$Liveness{liveBorn=emptyUniqSet,liveDieRead=mkUniqSetr_dying_br,liveDieWrite=mkUniqSetw_dying}))whereRUreadwritten=regUsageOfInstrinstr-- registers that were written here are dead going backwards.-- registers that were read here are live going backwards.liveregs1=(liveregs`delListFromUniqSet`written)`addListToUniqSet`read-- registers that are not live beyond this point, are recorded-- as dying here.r_dying=[reg|reg<-read,reg`notElem`written,not(elementOfUniqSetregliveregs)]w_dying=[reg|reg<-written,not(elementOfUniqSetregliveregs)]-- union in the live regs from all the jump destinations of this-- instruction.targets=jumpDestsOfInstrinstr-- where we go from herenot_a_branch=nulltargetstargetLiveRegstarget=caselookupBlockEnvblockmaptargetofJustra->raNothing->emptyRegMaplive_from_branch=unionManyUniqSets(maptargetLiveRegstargets)liveregs_br=liveregs1`unionUniqSets`live_from_branch-- registers that are live only in the branch targets should-- be listed as dying here.live_branch_only=live_from_branch`minusUniqSet`liveregsr_dying_br=uniqSetToList(mkUniqSetr_dying`unionUniqSets`live_branch_only)