Simon Jakobi pushed to branch wip/sjakobi/T26665-fr at Glasgow Haskell Compiler / GHC Commits: 6911fbea by Simon Jakobi at 2026-06-17T15:19:53+02:00 Reg.Linear: drop Platform from most FR (FreeRegs) methods The Platform argument of the FR class methods is redundant for all but frInitFreeRegs: each architecture has its own instance, so the arch is already fixed by instance selection. frAllocateReg and frReleaseReg ignored Platform in every instance, and frGetFreeRegs used it only in the X86/X86_64 instances to choose the integer/xmm register ranges. Those ranges depend on the platform only through its word size, so parameterise lastint/lastxmm/intregnos/xmmregnos in GHC.CmmToAsm.X86.Regs on PlatformWordSize and have the X86/X86_64 getFreeRegs pass a fixed PW4/PW8 -- keeping a single source of truth and leaving getFreeRegs Platform-free. frInitFreeRegs keeps its Platform argument: AArch64 reserves x18 on Darwin/Windows, an OS distinction within a single instance that instance selection cannot resolve. Fixes #26665 Co-Authored-By: Claude Opus 4.8 - - - - - 7 changed files: - compiler/GHC/CmmToAsm/Reg/Linear.hs - compiler/GHC/CmmToAsm/Reg/Linear/FreeRegs.hs - compiler/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs - compiler/GHC/CmmToAsm/Reg/Linear/X86.hs - compiler/GHC/CmmToAsm/Reg/Linear/X86_64.hs - compiler/GHC/CmmToAsm/X86/RegInfo.hs - compiler/GHC/CmmToAsm/X86/Regs.hs Changes: ===================================== compiler/GHC/CmmToAsm/Reg/Linear.hs ===================================== @@ -367,7 +367,7 @@ initBlock id block_live Nothing -> setFreeRegsR (frInitFreeRegs platform) Just live -> - setFreeRegsR $ foldl' (flip $ frAllocateReg platform) (frInitFreeRegs platform) + setFreeRegsR $ foldl' (flip frAllocateReg) (frInitFreeRegs platform) (nonDetEltsUniqSet $ takeRealRegs $ getRegs live) -- See Note [Unique Determinism and code generation] setAssigR emptyRegMap @@ -638,20 +638,19 @@ genRaInsn block_live new_instrs block_id instr r_dying w_dying = do releaseRegs :: FR freeRegs => [Reg] -> RegM freeRegs () releaseRegs regs = do - platform <- getPlatform assig <- getAssigR free <- getFreeRegsR let loop assig !free [] = do setAssigR assig; setFreeRegsR free; return () - loop assig !free (RegReal rr : rs) = loop assig (frReleaseReg platform rr free) rs + loop assig !free (RegReal rr : rs) = loop assig (frReleaseReg rr free) rs loop assig !free (r:rs) = case lookupUFM assig r of Just (Loc (InBoth real _) _) -> loop (delFromUFM assig r) - (frReleaseReg platform real free) rs + (frReleaseReg real free) rs Just (Loc (InReg real) _) -> loop (delFromUFM assig r) - (frReleaseReg platform real free) rs + (frReleaseReg real free) rs _ -> loop (delFromUFM assig r) free rs loop assig free regs @@ -716,7 +715,7 @@ saveClobberedTemps clobbered dying freeRegs <- getFreeRegsR let regclass = targetClassOfRealReg platform reg - freeRegs_thisClass = frGetFreeRegs platform regclass freeRegs + freeRegs_thisClass = frGetFreeRegs regclass freeRegs case filter (`notElem` clobbered) freeRegs_thisClass of @@ -724,7 +723,7 @@ saveClobberedTemps clobbered dying -- clobbered by this instruction; use it to save the -- clobbered value. (my_reg : _) -> do - setFreeRegsR (frAllocateReg platform my_reg freeRegs) + setFreeRegsR (frAllocateReg my_reg freeRegs) let new_assign = addToUFM_Directly assig temp (Loc (InReg my_reg) fmt) let instr = mkRegRegMoveInstr config fmt @@ -763,13 +762,13 @@ clobberRegs clobbered Unified -> Unified.allRegClasses Separate -> Separate.allRegClasses NoVectors -> NoVectors.allRegClasses - allFreeRegs = foldMap (\ rc -> frGetFreeRegs platform rc freeregs) allRegClasses + allFreeRegs = foldMap (\ rc -> frGetFreeRegs rc freeregs) allRegClasses let extra_clobbered = [ r | r <- clobbered, r `elem` allFreeRegs ] - setFreeRegsR $! foldl' (flip $ frAllocateReg platform) freeregs extra_clobbered + setFreeRegsR $! foldl' (flip frAllocateReg) freeregs extra_clobbered - -- setFreeRegsR $! foldl' (flip $ frAllocateReg platform) freeregs clobbered + -- setFreeRegsR $! foldl' (flip frAllocateReg) freeregs clobbered assig <- getAssigR setAssigR $! clobber assig (nonDetUFMToList assig) @@ -896,7 +895,7 @@ allocRegsAndSpill_spill reading keep spills alloc r@(VirtualRegWithFormat vr vrF = do platform <- getPlatform freeRegs <- getFreeRegsR let regclass = classOfVirtualReg (platformArch platform) vr - freeRegs_thisClass = frGetFreeRegs platform regclass freeRegs :: [RealReg] + freeRegs_thisClass = frGetFreeRegs regclass freeRegs :: [RealReg] -- Can we put the variable into a register it already was? pref_reg <- findPrefRealReg vr @@ -915,7 +914,7 @@ allocRegsAndSpill_spill reading keep spills alloc r@(VirtualRegWithFormat vr vrF setAssigR $ toRegMap $ (addToUFM assig vr $! newLocation spill_loc $ RealRegUsage final_reg vrFmt) - setFreeRegsR $ frAllocateReg platform final_reg freeRegs + setFreeRegsR $ frAllocateReg final_reg freeRegs allocateRegsAndSpill reading keep spills' (final_reg : alloc) rs ===================================== compiler/GHC/CmmToAsm/Reg/Linear/FreeRegs.hs ===================================== @@ -43,49 +43,51 @@ import qualified GHC.CmmToAsm.RV64.Instr as RV64.Instr import qualified GHC.CmmToAsm.LA64.Instr as LA64.Instr class Show freeRegs => FR freeRegs where - frAllocateReg :: Platform -> RealReg -> freeRegs -> freeRegs - frGetFreeRegs :: Platform -> RegClass -> freeRegs -> [RealReg] + frAllocateReg :: RealReg -> freeRegs -> freeRegs + frGetFreeRegs :: RegClass -> freeRegs -> [RealReg] + -- | The initial allocatable set is platform-dependent. See Note + -- [Aarch64 Register x18 at Darwin and Windows] in GHC.Platform.Regs. frInitFreeRegs :: Platform -> freeRegs - frReleaseReg :: Platform -> RealReg -> freeRegs -> freeRegs + frReleaseReg :: RealReg -> freeRegs -> freeRegs instance FR X86.FreeRegs where - frAllocateReg = \_ -> X86.allocateReg + frAllocateReg = X86.allocateReg frGetFreeRegs = X86.getFreeRegs frInitFreeRegs = X86.initFreeRegs - frReleaseReg = \_ -> X86.releaseReg + frReleaseReg = X86.releaseReg instance FR X86_64.FreeRegs where - frAllocateReg = \_ -> X86_64.allocateReg + frAllocateReg = X86_64.allocateReg frGetFreeRegs = X86_64.getFreeRegs frInitFreeRegs = X86_64.initFreeRegs - frReleaseReg = \_ -> X86_64.releaseReg + frReleaseReg = X86_64.releaseReg instance FR PPC.FreeRegs where - frAllocateReg = \_ -> PPC.allocateReg - frGetFreeRegs = \_ -> PPC.getFreeRegs + frAllocateReg = PPC.allocateReg + frGetFreeRegs = PPC.getFreeRegs frInitFreeRegs = PPC.initFreeRegs - frReleaseReg = \_ -> PPC.releaseReg + frReleaseReg = PPC.releaseReg instance FR AArch64.FreeRegs where - frAllocateReg = \_ -> AArch64.allocateReg - frGetFreeRegs = \_ -> AArch64.getFreeRegs + frAllocateReg = AArch64.allocateReg + frGetFreeRegs = AArch64.getFreeRegs frInitFreeRegs = AArch64.initFreeRegs - frReleaseReg = \_ -> AArch64.releaseReg + frReleaseReg = AArch64.releaseReg instance FR RV64.FreeRegs where - frAllocateReg = const RV64.allocateReg - frGetFreeRegs = const RV64.getFreeRegs + frAllocateReg = RV64.allocateReg + frGetFreeRegs = RV64.getFreeRegs frInitFreeRegs = RV64.initFreeRegs - frReleaseReg = const RV64.releaseReg + frReleaseReg = RV64.releaseReg instance FR LA64.FreeRegs where - frAllocateReg = \_ -> LA64.allocateReg - frGetFreeRegs = \_ -> LA64.getFreeRegs + frAllocateReg = LA64.allocateReg + frGetFreeRegs = LA64.getFreeRegs frInitFreeRegs = LA64.initFreeRegs - frReleaseReg = \_ -> LA64.releaseReg + frReleaseReg = LA64.releaseReg allFreeRegs :: FR freeRegs => Platform -> freeRegs -> [RealReg] -allFreeRegs plat fr = foldMap (\rcls -> frGetFreeRegs plat rcls fr) allRegClasses +allFreeRegs plat fr = foldMap (\rcls -> frGetFreeRegs rcls fr) allRegClasses where allRegClasses = case registerArch (platformArch plat) of ===================================== compiler/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs ===================================== @@ -15,7 +15,6 @@ import GHC.CmmToAsm.Reg.Linear.Base import GHC.CmmToAsm.Reg.Linear.FreeRegs import GHC.CmmToAsm.Reg.Liveness import GHC.CmmToAsm.Instr -import GHC.CmmToAsm.Config import GHC.CmmToAsm.Types import GHC.Platform.Reg @@ -132,12 +131,9 @@ joinToTargets_first block_live new_blocks block_id instr dest dests block_assig src_assig to_free - = do config <- getConfig - let platform = ncgPlatform config - - -- free up the regs that are not live on entry to this block. + = do -- free up the regs that are not live on entry to this block. freeregs <- getFreeRegsR - let freeregs' = foldl' (flip $ frReleaseReg platform) freeregs to_free + let freeregs' = foldl' (flip frReleaseReg) freeregs to_free -- remember the current assignment on entry to this block. setBlockAssigR (updateBlockAssignment dest (freeregs', src_assig) block_assig) ===================================== compiler/GHC/CmmToAsm/Reg/Linear/X86.hs ===================================== @@ -25,17 +25,17 @@ initFreeRegs :: Platform -> FreeRegs initFreeRegs platform = foldl' (flip releaseReg) noFreeRegs (allocatableRegs platform) -getFreeRegs :: Platform -> RegClass -> FreeRegs -> [RealReg] -- lazily -getFreeRegs platform cls (FreeRegs f) = +getFreeRegs :: RegClass -> FreeRegs -> [RealReg] -- lazily +getFreeRegs cls (FreeRegs f) = case cls of RcInteger -> [ RealRegSingle i - | i <- intregnos platform + | i <- intregnos PW4 , testBit f i ] RcFloatOrVector -> [ RealRegSingle i - | i <- xmmregnos platform + | i <- xmmregnos PW4 , testBit f i ] ===================================== compiler/GHC/CmmToAsm/Reg/Linear/X86_64.hs ===================================== @@ -25,17 +25,17 @@ initFreeRegs :: Platform -> FreeRegs initFreeRegs platform = foldl' (flip releaseReg) noFreeRegs (allocatableRegs platform) -getFreeRegs :: Platform -> RegClass -> FreeRegs -> [RealReg] -- lazily -getFreeRegs platform cls (FreeRegs f) = +getFreeRegs :: RegClass -> FreeRegs -> [RealReg] -- lazily +getFreeRegs cls (FreeRegs f) = case cls of RcInteger -> [ RealRegSingle i - | i <- intregnos platform + | i <- intregnos PW8 , testBit f i ] RcFloatOrVector -> [ RealRegSingle i - | i <- xmmregnos platform + | i <- xmmregnos PW8 , testBit f i ] ===================================== compiler/GHC/CmmToAsm/X86/RegInfo.hs ===================================== @@ -41,9 +41,11 @@ regColors platform = listToUFM (normalRegColors platform) normalRegColors :: Platform -> [(RealReg,String)] normalRegColors platform = - zip (map realRegSingle [0..lastint platform]) colors - ++ zip (map realRegSingle [firstxmm..lastxmm platform]) greys + zip (map realRegSingle [0..lastint wordSize]) colors + ++ zip (map realRegSingle [firstxmm..lastxmm wordSize]) greys where + wordSize = platformWordSize platform + -- 16 colors - enough for amd64 gp regs colors = ["#800000","#ff0000","#808000","#ffff00","#008000" ,"#00ff00","#008080","#00ffff","#000080","#0000ff" ===================================== compiler/GHC/CmmToAsm/X86/Regs.hs ===================================== @@ -194,27 +194,23 @@ spRel platform n firstxmm :: RegNo firstxmm = 16 --- on 32bit platformOSs, only the first 8 XMM/YMM/ZMM registers are available -lastxmm :: Platform -> RegNo -lastxmm platform - | target32Bit platform = firstxmm + 7 -- xmm0 - xmmm7 - | otherwise = firstxmm + 15 -- xmm0 -xmm15 +-- on 32bit platforms, only the first 8 XMM/YMM/ZMM registers are available +lastxmm :: PlatformWordSize -> RegNo +lastxmm PW4 = firstxmm + 7 -- xmm0 - xmm7 +lastxmm PW8 = firstxmm + 15 -- xmm0 - xmm15 -lastint :: Platform -> RegNo -lastint platform - | target32Bit platform = 7 -- not %r8..%r15 - | otherwise = 15 +lastint :: PlatformWordSize -> RegNo +lastint PW4 = 7 -- not %r8..%r15 +lastint PW8 = 15 -intregnos :: Platform -> [RegNo] -intregnos platform = [0 .. lastint platform] +intregnos :: PlatformWordSize -> [RegNo] +intregnos wordSize = [0 .. lastint wordSize] - - -xmmregnos :: Platform -> [RegNo] -xmmregnos platform = [firstxmm .. lastxmm platform] +xmmregnos :: PlatformWordSize -> [RegNo] +xmmregnos wordSize = [firstxmm .. lastxmm wordSize] floatregnos :: Platform -> [RegNo] -floatregnos platform = xmmregnos platform +floatregnos platform = xmmregnos (platformWordSize platform) -- argRegs is the set of regs which are read for an n-argument call to C. -- For archs which pass all args on the stack (x86), is empty. @@ -224,7 +220,7 @@ argRegs _ = panic "MachRegs.argRegs(x86): should not be used!" -- | The complete set of machine registers. allMachRegNos :: Platform -> [RegNo] -allMachRegNos platform = intregnos platform ++ floatregnos platform +allMachRegNos platform = intregnos (platformWordSize platform) ++ floatregnos platform -- | Take the class of a register. {-# INLINE classOfRealReg #-} @@ -236,9 +232,11 @@ classOfRealReg :: Platform -> RealReg -> RegClass classOfRealReg platform reg = case reg of RealRegSingle i - | i <= lastint platform -> RcInteger - | i <= lastxmm platform -> RcFloatOrVector + | i <= lastint wordSize -> RcInteger + | i <= lastxmm wordSize -> RcFloatOrVector | otherwise -> panic "X86.Reg.classOfRealReg registerSingle too high" + where + wordSize = platformWordSize platform -- machine specific ------------------------------------------------------------ View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6911fbea532bac9a399113a93d26562e... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6911fbea532bac9a399113a93d26562e... You're receiving this email because of your account on gitlab.haskell.org.