+allocUsingTheseRegs :: [Instr] -> [Reg] -> (Bool, [Instr])
+allocUsingTheseRegs instrs available_real_regs
+ = let (all_vregs_mapped, v_to_r_mapping)
+ = calc_vreg_to_rreg_mapping instrs available_real_regs
+ new_insns
+ = map (flip patchRegs sr) instrs
+ sr reg
+ | isRealReg reg
+ = reg
+ | otherwise
+ = case lookupFM v_to_r_mapping reg of
+ Just r -> r
+ Nothing -> pprPanic "allocateUsingTheseRegs: unmapped vreg: "
+ (ppr reg)
+ in
+ --trace ("allocUsingTheseRegs: " ++ show available_real_regs) (
+ (all_vregs_mapped, new_insns)
+ --)
+
+
+-- the heart of the matter.
+calc_vreg_to_rreg_mapping :: [Instr] -> [Reg] -> (Bool, FiniteMap Reg Reg)
+calc_vreg_to_rreg_mapping insns available_real_regs
+ = let
+ lr_sets :: FiniteMap Reg FeSet
+ lr_sets = calc_live_range_sets insns
+
+ -- lr_sets maps: vregs mentioned in insns to sets of live FEs
+ -- and also: rregs mentioned in insns to sets of live FEs
+ -- We need to extract the rreg mapping, and use it as the
+ -- initial real-register-commitment. Also, add to the initial
+ -- commitment, empty commitments for any real regs not
+ -- mentioned in it.
+
+ -- which real regs do we want to keep track of in the running
+ -- commitment mapping? Precisely the available_real_regs.
+ -- We don't care about real regs mentioned by insns which are
+ -- not in this list, since we're not allocating to them.
+ initial_rr_commitment :: FiniteMap Reg FeSet
+ initial_rr_commitment
+ = listToFM [(rreg,
+ case lookupFM lr_sets rreg of
+ Nothing -> emptyFeSet
+ Just fixed_use_fes -> fixed_use_fes
+ )
+ | rreg <- available_real_regs]
+
+ -- These are the vregs for which we actually have to (try to)
+ -- assign a real register. (ie, the whole reason we're here at all :)
+ vreg_liveness_list :: [(Reg, FeSet)]
+ vreg_liveness_list = filter (not.isRealReg.fst)
+ (fmToList lr_sets)
+
+ -- A loop, which attempts to assign each vreg to a rreg.
+ loop rr_commitment v_to_r_map []
+ = v_to_r_map
+ loop rr_commitment v_to_r_map ((vreg,vreg_live_fes):not_yet_done)
+ = let
+ -- find a real reg which is not live for any of vreg_live_fes
+ cand_reals
+ = [rreg
+ | (rreg,rreg_live_FEs) <- fmToList rr_commitment,
+ regClass vreg == regClass rreg,
+ isEmptyFeSet (intersectionFeSets rreg_live_FEs
+ vreg_live_fes)
+ ]
+ in
+ case cand_reals of
+ [] -> -- bummer. No register is available. Just go on to
+ -- the next vreg, mapping the vreg to itself.
+ loop rr_commitment (addToFM v_to_r_map vreg vreg)
+ not_yet_done
+ (r:_)
+ -> -- Hurrah! Found a free reg of the right class.
+ -- Now we need to update the RR commitment.
+ loop rr_commitment2 (addToFM v_to_r_map vreg r)
+ not_yet_done
+ where
+ rr_commitment2
+ = addToFM_C unionFeSets rr_commitment r
+ vreg_live_fes
+
+ -- the final vreg to rreg mapping
+ vreg_assignment
+ = loop initial_rr_commitment emptyFM vreg_liveness_list
+ -- did we succeed in mapping everyone to a real reg?
+ allocation_succeeded
+ = all isRealReg (eltsFM vreg_assignment)
+ in
+ (allocation_succeeded, vreg_assignment)
+
+
+
+-- calculate liveness, then produce the live range info
+-- as a mapping of VRegs to the set of FEs on which they are live.
+-- The difficult part is inverting the mapping of Reg -> FeSet
+-- to produce a mapping FE -> RegSet.
+
+calc_live_range_sets :: [Instr] -> FiniteMap Reg FeSet
+calc_live_range_sets insns
+ = let
+ -- this is the "original" (old) mapping
+ lis :: FiniteMap FE RegSet
+ lis = calc_liveness insns
+
+ -- establish the totality of reg names mentioned by the
+ -- insns, by scanning over the insns.
+ all_mentioned_regs :: RegSet
+ all_mentioned_regs
+ = foldl unionRegSets emptyRegSet
+ (map (\i -> case regUsage i of
+ RU rds wrs -> unionRegSets rds wrs)
+ insns)
+
+ -- Initial inverted mapping, from Reg to sets of FEs
+ initial_imap :: FiniteMap Reg FeSet
+ initial_imap
+ = listToFM [(reg, emptyFeSet)
+ | reg <- regSetToList all_mentioned_regs]
+
+ -- Update the new map with one element of the old map
+ upd_imap :: FiniteMap Reg FeSet -> (FE, RegSet)
+ -> FiniteMap Reg FeSet
+ upd_imap imap (fe, regset)
+ = foldl upd_1_imap imap (regSetToList regset)
+ where
+ upd_1_imap curr reg
+ = addToFM_C unionFeSets curr reg (unitFeSet fe)
+
+ -- the complete inverse mapping
+ final_imap :: FiniteMap Reg FeSet
+ final_imap
+ = foldl upd_imap initial_imap (fmToList lis)
+ in
+ final_imap
+
+
+
+-- Given the insns, calculate the FEs, and then doing fixpointing to
+-- figure out the set of live regs (virtual regs AND real regs) live
+-- on each FE.
+
+calc_liveness :: [Instr] -> FiniteMap FE RegSet
+calc_liveness insns
+ = let (pred_map, succ_map)
+ = find_flow_edges insns
+
+ -- We use the convention that if the current approximation
+ -- doesn't give a mapping for some FE, that FE maps to the
+ -- empty set.
+ initial_approx, fixpoint :: FiniteMap FE RegSet
+ initial_approx
+ = mk_initial_approx 0 insns succ_map emptyFM
+ fixpoint
+ = fix_set initial_approx 1
+ -- If you want to live dangerously, and promise that the code
+ -- doesn't contain any loops (ie, there are no back edges in
+ -- the flow graph), you should be able to get away with this:
+ -- = upd_liveness_info pred_map succ_map insn_array initial_approx
+ -- But since I'm paranoid, and since it hardly makes any difference
+ -- to the compiler run-time (about 0.1%), I prefer to do the
+ -- the full fixpointing game.
+
+ insn_array
+ = let n = length insns
+ in array (0, n-1) (zip [0..] insns)
+
+ sameSets [] [] = True
+ sameSets (c:cs) (n:ns) = eqRegSets c n && sameSets cs ns
+ sameSets _ _ = False
+
+ fix_set curr_approx iter_number
+ = let next_approx
+ = upd_liveness_info pred_map succ_map insn_array curr_approx
+ curr_sets
+ = eltsFM curr_approx
+ next_sets
+ = eltsFM next_approx
+ same
+ = sameSets curr_sets next_sets
+ final_approx
+ = if same then curr_approx
+ else fix_set next_approx (iter_number+1)
+ in
+ --trace (let qqq (fe, regset)
+ -- = show fe ++ " " ++ show (regSetToList regset)
+ -- in
+ -- "\n::iteration " ++ show iter_number ++ "\n"
+ -- ++ (unlines . map qqq . fmToList)
+ -- next_approx ++"\n"
+ -- )
+ final_approx
+ in
+ fixpoint
+
+
+-- Create a correct initial approximation. For each instruction that
+-- writes a register, we deem that the register is live on the
+-- flow edges leaving the instruction. Subsequent iterations of
+-- the liveness AbI augment this based purely on reads of regs, not
+-- writes. We need to start off with at least this minimal write-
+-- based information in order that writes to vregs which are never
+-- used have non-empty live ranges. If we don't do that, we eventually
+-- wind up assigning such vregs to any old real reg, since they don't
+-- apparently conflict -- you can't conflict with an empty live range.
+-- This kludge is unfortunate, but we need to do it to cover not only
+-- writes to vregs which are never used, but also to deal correctly
+-- with the fact that calls to C will trash the callee saves registers.
+
+mk_initial_approx :: Int -> [Instr] -> Array Int [Int]
+ -> FiniteMap FE RegSet
+ -> FiniteMap FE RegSet
+mk_initial_approx ino [] succ_map ia_so_far
+ = ia_so_far
+mk_initial_approx ino (i:is) succ_map ia_so_far
+ = let wrs
+ = case regUsage i of RU rrr www -> www
+ new_fes
+ = [case iUnbox ino of { inoh ->
+ case iUnbox ino_succ of { ino_succh ->
+ MkFE inoh ino_succh
+ }}
+ | ino_succ <- succ_map ! ino]
+
+ loop [] ia = ia
+ loop (fe:fes) ia
+ = loop fes (addToFM_C unionRegSets ia fe wrs)
+
+ next_ia
+ = loop new_fes ia_so_far
+ in
+ mk_initial_approx (ino+1) is succ_map next_ia
+
+
+-- Do one step in the liveness info calculation (AbI :). Given the
+-- prior approximation (which tells you a subset of live VRegs+RRegs
+-- for each flow edge), calculate new information for all FEs.
+-- Rather than do this by iterating over FEs, it's easier to iterate
+-- over insns, and update their incoming FEs.
+
+upd_liveness_info :: Array Int [Int] -- instruction pred map
+ -> Array Int [Int] -- instruction succ map
+ -> Array Int Instr -- array of instructions
+ -> FiniteMap FE RegSet -- previous approx
+ -> FiniteMap FE RegSet -- improved approx
+
+upd_liveness_info pred_map succ_map insn_array prev_approx
+ = do_insns hi prev_approx
+ where
+ (lo, hi) = bounds insn_array
+
+ enquireMapFE :: FiniteMap FE RegSet -> FE
+ -> RegSet
+ enquireMapFE fm fe
+ = case lookupFM fm fe of
+ Just set -> set
+ Nothing -> emptyRegSet
+
+ -- Work backwards, from the highest numbered insn to the lowest.
+ -- This is a heuristic which causes faster convergence to the
+ -- fixed point. In particular, for straight-line code with no
+ -- branches at all, arrives at the fixpoint in one iteration.
+ do_insns ino approx
+ | ino < lo
+ = approx
+ | otherwise
+ = let fes_to_futures
+ = [case iUnbox ino of { inoh ->
+ case iUnbox future_ino of { future_inoh ->
+ MkFE inoh future_inoh
+ }}
+ | future_ino <- succ_map ! ino]
+ future_lives
+ = map (enquireMapFE approx) fes_to_futures
+ future_live
+ = foldr unionRegSets emptyRegSet future_lives
+
+ fes_from_histories
+ = [case iUnbox history_ino of { history_inoh ->
+ case iUnbox ino of { inoh ->
+ MkFE history_inoh inoh
+ }}
+ | history_ino <- pred_map ! ino]
+ new_approx
+ = foldl update_one_history approx fes_from_histories
+
+ insn
+ = insn_array ! ino
+ history_independent_component
+ = case regUsage insn of
+ RU rds wrs
+ -> unionRegSets rds
+ (minusRegSets future_live wrs)
+
+ update_one_history :: FiniteMap FE RegSet
+ -> FE
+ -> FiniteMap FE RegSet
+ update_one_history approx0 fe
+ = addToFM_C unionRegSets approx0 fe
+ history_independent_component
+
+ rest_done
+ = do_insns (ino-1) new_approx
+ in
+ rest_done
+
+
+
+-- Extract the flow edges from a list of insns. Express the information
+-- as two mappings, from insn number to insn numbers of predecessors,
+-- and from insn number to insn numbers of successors. (Since that's
+-- what we need to know when computing live ranges later). Instructions
+-- are numbered starting at zero. This function is long and complex
+-- in order to be efficient; it could equally well be shorter and slower.
+
+find_flow_edges :: [Instr] -> (Array Int [Int],
+ Array Int [Int])
+find_flow_edges insns
+ = let
+ -- First phase: make a temp env which maps labels
+ -- to insn numbers, so the second pass can know the insn
+ -- numbers for jump targets.
+
+ label_env :: FiniteMap CLabel Int
+
+ mk_label_env n env [] = env
+ mk_label_env n env ((LABEL clbl):is)
+ = mk_label_env (n+1) (addToFM env clbl n) is
+ mk_label_env n env (i:is)
+ = mk_label_env (n+1) env is
+
+ label_env = mk_label_env 0 emptyFM insns
+
+ find_label :: CLabel -> Int
+ find_label jmptarget
+ = case lookupFM label_env jmptarget of
+ Just ino -> ino
+ Nothing -> pprPanic "find_flow_edges: unmapped label"
+ (pprCLabel jmptarget)
+
+ -- Second phase: traverse the insns, and make up the successor map.
+
+ least_ino, greatest_ino :: Int
+ least_ino = 0
+ greatest_ino = length insns - 1
+
+ mk_succ_map :: Int -> [(Int, [Int])] -> [Instr] -> [(Int, [Int])]
+
+ mk_succ_map i_num rsucc_map []
+ = reverse rsucc_map
+
+ mk_succ_map i_num rsucc_map (i:is)
+ = let i_num_1 = i_num + 1
+ in
+ case insnFuture i of
+
+ NoFuture
+ -> -- A non-local jump. We can regard this insn as a terminal
+ -- insn in the graph, so we don't add any edges.
+ mk_succ_map i_num_1 ((i_num,[]):rsucc_map) is
+
+ Next
+ | null is -- this is the last insn, and it doesn't go anywhere
+ -- (a meaningless scenario); handle it anyway
+ -> mk_succ_map i_num_1 ((i_num,[]):rsucc_map) is
+
+ | otherwise -- flows to next insn; add fe i_num -> i_num+1
+ -> mk_succ_map i_num_1 ((i_num, [i_num_1]): rsucc_map)
+ is
+
+ Branch lab -- jmps to lab; add fe i_num -> i_target
+ -> let i_target = find_label lab
+ in
+ mk_succ_map i_num_1 ((i_num, [i_target]): rsucc_map) is
+
+ NextOrBranch lab
+ | null is -- jmps to label, or falls through, and this is
+ -- the last insn (a meaningless scenario);
+ -- flag an error
+ -> error "find_flow_edges: NextOrBranch is last"
+
+ | otherwise -- add fes i_num -> i_num+1
+ -- and i_num -> i_target
+ -> let i_target = find_label lab
+ in
+ mk_succ_map i_num_1 ((i_num, [i_num_1, i_target]):rsucc_map)
+ is
+ MultiFuture labels
+ -> -- A jump, whose targets are listed explicitly.
+ -- (Generated from table-based switch translations).
+ -- Add fes i_num -> x for each x in labels
+ let is_target = nub (map find_label labels)
+ in
+ mk_succ_map i_num_1 ((i_num, is_target):rsucc_map) is
+
+ -- Third phase: invert the successor map to get the predecessor
+ -- map, using an algorithm which is quadratic in the worst case,
+ -- but runs in almost-linear time, because of the nature of our
+ -- inputs: most insns have a single successor, the next insn.
+
+ invert :: [(Int, [Int])] -> [(Int, [Int])]
+ invert fmap
+ = let inverted_pairs
+ = concatMap ( \ (a, bs) -> [(b,a) | b <- bs] ) fmap
+ sorted_inverted_pairs
+ = isort inverted_pairs
+
+ grp :: Int -> [Int] -> [(Int,Int)] -> [(Int,[Int])]
+ grp k vs [] = [(k, vs)]
+ grp k vs ((kk,vv):rest)
+ | k == kk = grp k (vv:vs) rest
+ | otherwise = (k,vs) : grp kk [vv] rest
+
+ grp_start [] = []
+ grp_start ((kk,vv):rest) = grp kk [vv] rest
+
+ grouped
+ = grp_start sorted_inverted_pairs
+
+ -- make sure that the reverse mapping maps all inos
+ add_empties ino []
+ | ino > greatest_ino = []
+ | otherwise = (ino,[]): add_empties (ino+1) []
+ add_empties ino ((k,vs):rest)
+ | ino < k = (ino,[]): add_empties (ino+1) ((k,vs):rest)
+ | ino == k = (k,vs) : add_empties (ino+1) rest
+
+ -- This is nearly linear provided that the fsts of the
+ -- list are nearly in order -- a critical assumption
+ -- for efficiency.
+ isort :: [(Int,Int)] -> [(Int,Int)]
+ isort [] = []
+ isort (x:xs) = insert x (isort xs)
+
+ insert :: (Int,Int) -> [(Int,Int)] -> [(Int,Int)]
+ insert y [] = [y]
+ insert y (z:zs)
+ -- specifically, this first test should almost always
+ -- be True in order for the near-linearity to happen
+ | fst y <= fst z = y:z:zs
+ | otherwise = z: insert y zs
+ in
+ add_empties least_ino grouped
+
+ -- Finally ...
+
+ succ_list
+ = mk_succ_map 0 [] insns
+ succ_map
+ = array (least_ino, greatest_ino) succ_list
+ pred_list
+ = invert succ_list
+ pred_map
+ = array (least_ino, greatest_ino) pred_list
+ in
+ (pred_map, succ_map)
+
+
+-- That's all, folks! From here on is just some dull supporting stuff.
+
+-- A data type for flow edges
+data FE
+ = MkFE FastInt FastInt deriving (Eq, Ord)
+
+-- deriving Show on types with unboxed fields doesn't work
+instance Show FE where
+ showsPrec _ (MkFE s d)
+ = showString "MkFE" . shows (iBox s) . shows ' ' . shows (iBox d)
+
+-- Blargh. Use ghc stuff soon! Or: perhaps that's not such a good
+-- idea. Most of these sets are either empty or very small, and it
+-- might be that the overheads of the FiniteMap based set implementation
+-- is a net loss. The same might be true of RegSets.
+
+newtype FeSet = MkFeSet [FE]
+
+feSetFromList xs
+ = MkFeSet (nukeDups (sort xs))
+ where nukeDups :: [FE] -> [FE]
+ nukeDups [] = []
+ nukeDups [x] = [x]
+ nukeDups (x:y:xys)
+ = if x == y then nukeDups (y:xys)
+ else x : nukeDups (y:xys)
+
+feSetToList (MkFeSet xs) = xs
+isEmptyFeSet (MkFeSet xs) = null xs
+emptyFeSet = MkFeSet []
+eqFeSet (MkFeSet xs1) (MkFeSet xs2) = xs1 == xs2
+unitFeSet x = MkFeSet [x]
+
+elemFeSet x (MkFeSet xs)
+ = f xs
+ where
+ f [] = False
+ f (y:ys) | x == y = True
+ | x < y = False
+ | otherwise = f ys
+
+unionFeSets (MkFeSet xs1) (MkFeSet xs2)
+ = MkFeSet (f xs1 xs2)
+ where
+ f [] bs = bs
+ f as [] = as
+ f (a:as) (b:bs)
+ | a < b = a : f as (b:bs)
+ | a > b = b : f (a:as) bs
+ | otherwise = a : f as bs
+
+minusFeSets (MkFeSet xs1) (MkFeSet xs2)
+ = MkFeSet (f xs1 xs2)
+ where
+ f [] bs = []
+ f as [] = as
+ f (a:as) (b:bs)
+ | a < b = a : f as (b:bs)
+ | a > b = f (a:as) bs
+ | otherwise = f as bs
+
+intersectionFeSets (MkFeSet xs1) (MkFeSet xs2)
+ = MkFeSet (f xs1 xs2)
+ where
+ f [] bs = []
+ f as [] = []
+ f (a:as) (b:bs)
+ | a < b = f as (b:bs)
+ | a > b = f (a:as) bs
+ | otherwise = a : f as bs