summaryrefslogtreecommitdiff
path: root/compiler/codeGen/StgCmmUtils.hs
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/codeGen/StgCmmUtils.hs')
-rw-r--r--compiler/codeGen/StgCmmUtils.hs394
1 files changed, 194 insertions, 200 deletions
diff --git a/compiler/codeGen/StgCmmUtils.hs b/compiler/codeGen/StgCmmUtils.hs
index d6bc23c0d4..9f20047368 100644
--- a/compiler/codeGen/StgCmmUtils.hs
+++ b/compiler/codeGen/StgCmmUtils.hs
@@ -6,44 +6,37 @@
--
-----------------------------------------------------------------------------
-{-# OPTIONS -fno-warn-tabs #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and
--- detab the module (please do the detabbing in a separate patch). See
--- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
--- for details
-
module StgCmmUtils (
- cgLit, mkSimpleLit,
- emitDataLits, mkDataLits,
+ cgLit, mkSimpleLit,
+ emitDataLits, mkDataLits,
emitRODataLits, mkRODataLits,
emitRtsCall, emitRtsCallWithResult, emitRtsCallGen,
assignTemp, newTemp,
- newUnboxedTupleRegs,
+ newUnboxedTupleRegs,
emitMultiAssign, emitCmmLitSwitch, emitSwitch,
- tagToClosure, mkTaggedObjectLoad,
+ tagToClosure, mkTaggedObjectLoad,
callerSaves, callerSaveVolatileRegs, get_GlobalReg_addr,
- cmmAndWord, cmmOrWord, cmmNegate, cmmEqWord, cmmNeWord,
+ cmmAndWord, cmmOrWord, cmmNegate, cmmEqWord, cmmNeWord,
cmmUGtWord, cmmSubWord, cmmMulWord, cmmAddWord, cmmUShrWord,
- cmmOffsetExprW, cmmOffsetExprB,
- cmmRegOffW, cmmRegOffB,
- cmmLabelOffW, cmmLabelOffB,
- cmmOffsetW, cmmOffsetB,
- cmmOffsetLitW, cmmOffsetLitB,
- cmmLoadIndexW,
+ cmmOffsetExprW, cmmOffsetExprB,
+ cmmRegOffW, cmmRegOffB,
+ cmmLabelOffW, cmmLabelOffB,
+ cmmOffsetW, cmmOffsetB,
+ cmmOffsetLitW, cmmOffsetLitB,
+ cmmLoadIndexW,
cmmConstrTag, cmmConstrTag1,
cmmUntag, cmmIsTagged, cmmGetTag,
- addToMem, addToMemE, addToMemLbl,
- mkWordCLit,
- newStringCLit, newByteStringCLit,
- packHalfWordsCLit,
+ addToMem, addToMemE, addToMemLbl,
+ mkWordCLit,
+ newStringCLit, newByteStringCLit,
+ packHalfWordsCLit,
blankWord,
srt_escape
@@ -86,7 +79,7 @@ import Data.Maybe
-------------------------------------------------------------------------
--
--- Literals
+-- Literals
--
-------------------------------------------------------------------------
@@ -100,11 +93,11 @@ mkLtOp :: Literal -> MachOp
mkLtOp (MachInt _) = MO_S_Lt wordWidth
mkLtOp (MachFloat _) = MO_F_Lt W32
mkLtOp (MachDouble _) = MO_F_Lt W64
-mkLtOp lit = MO_U_Lt (typeWidth (cmmLitType (mkSimpleLit lit)))
- -- ToDo: seems terribly indirect!
+mkLtOp lit = MO_U_Lt (typeWidth (cmmLitType (mkSimpleLit lit)))
+ -- ToDo: seems terribly indirect!
mkSimpleLit :: Literal -> CmmLit
-mkSimpleLit (MachChar c) = CmmInt (fromIntegral (ord c)) wordWidth
+mkSimpleLit (MachChar c) = CmmInt (fromIntegral (ord c)) wordWidth
mkSimpleLit MachNullAddr = zeroCLit
mkSimpleLit (MachInt i) = CmmInt i wordWidth
mkSimpleLit (MachInt64 i) = CmmInt i W64
@@ -112,12 +105,12 @@ mkSimpleLit (MachWord i) = CmmInt i wordWidth
mkSimpleLit (MachWord64 i) = CmmInt i W64
mkSimpleLit (MachFloat r) = CmmFloat r W32
mkSimpleLit (MachDouble r) = CmmFloat r W64
-mkSimpleLit (MachLabel fs ms fod)
- = CmmLabel (mkForeignLabel fs ms labelSrc fod)
- where
- -- TODO: Literal labels might not actually be in the current package...
- labelSrc = ForeignLabelInThisPackage
-mkSimpleLit other = pprPanic "mkSimpleLit" (ppr other)
+mkSimpleLit (MachLabel fs ms fod)
+ = CmmLabel (mkForeignLabel fs ms labelSrc fod)
+ where
+ -- TODO: Literal labels might not actually be in the current package...
+ labelSrc = ForeignLabelInThisPackage
+mkSimpleLit other = pprPanic "mkSimpleLit" (ppr other)
--------------------------------------------------------------------------
--
@@ -128,40 +121,40 @@ mkSimpleLit other = pprPanic "mkSimpleLit" (ppr other)
addToMemLbl :: CmmType -> CLabel -> Int -> CmmAGraph
addToMemLbl rep lbl n = addToMem rep (CmmLit (CmmLabel lbl)) n
-addToMem :: CmmType -- rep of the counter
- -> CmmExpr -- Address
- -> Int -- What to add (a word)
- -> CmmAGraph
+addToMem :: CmmType -- rep of the counter
+ -> CmmExpr -- Address
+ -> Int -- What to add (a word)
+ -> CmmAGraph
addToMem rep ptr n = addToMemE rep ptr (CmmLit (CmmInt (toInteger n) (typeWidth rep)))
-addToMemE :: CmmType -- rep of the counter
- -> CmmExpr -- Address
- -> CmmExpr -- What to add (a word-typed expression)
- -> CmmAGraph
+addToMemE :: CmmType -- rep of the counter
+ -> CmmExpr -- Address
+ -> CmmExpr -- What to add (a word-typed expression)
+ -> CmmAGraph
addToMemE rep ptr n
= mkStore ptr (CmmMachOp (MO_Add (typeWidth rep)) [CmmLoad ptr rep, n])
-------------------------------------------------------------------------
--
--- Loading a field from an object,
--- where the object pointer is itself tagged
+-- Loading a field from an object,
+-- where the object pointer is itself tagged
--
-------------------------------------------------------------------------
mkTaggedObjectLoad :: LocalReg -> LocalReg -> WordOff -> DynTag -> CmmAGraph
-- (loadTaggedObjectField reg base off tag) generates assignment
--- reg = bitsK[ base + off - tag ]
+-- reg = bitsK[ base + off - tag ]
-- where K is fixed by 'reg'
mkTaggedObjectLoad reg base offset tag
- = mkAssign (CmmLocal reg)
- (CmmLoad (cmmOffsetB (CmmReg (CmmLocal base))
- (wORD_SIZE*offset - tag))
+ = mkAssign (CmmLocal reg)
+ (CmmLoad (cmmOffsetB (CmmReg (CmmLocal base))
+ (wORD_SIZE*offset - tag))
(localRegType reg))
-------------------------------------------------------------------------
--
--- Converting a closure tag to a closure for enumeration types
+-- Converting a closure tag to a closure for enumeration types
-- (this is the implementation of tagToEnum#).
--
-------------------------------------------------------------------------
@@ -170,11 +163,11 @@ tagToClosure :: TyCon -> CmmExpr -> CmmExpr
tagToClosure tycon tag
= CmmLoad (cmmOffsetExprW closure_tbl tag) bWord
where closure_tbl = CmmLit (CmmLabel lbl)
- lbl = mkClosureTableLabel (tyConName tycon) NoCafRefs
+ lbl = mkClosureTableLabel (tyConName tycon) NoCafRefs
-------------------------------------------------------------------------
--
--- Conditionals and rts calls
+-- Conditionals and rts calls
--
-------------------------------------------------------------------------
@@ -182,7 +175,7 @@ emitRtsCall :: PackageId -> FastString -> [(CmmExpr,ForeignHint)] -> Bool -> FCo
emitRtsCall pkg fun args safe = emitRtsCallGen [] pkg fun args safe
emitRtsCallWithResult :: LocalReg -> ForeignHint -> PackageId -> FastString
- -> [(CmmExpr,ForeignHint)] -> Bool -> FCode ()
+ -> [(CmmExpr,ForeignHint)] -> Bool -> FCode ()
emitRtsCallWithResult res hint pkg fun args safe
= emitRtsCallGen [(res,hint)] pkg fun args safe
@@ -215,7 +208,7 @@ emitRtsCallGen res pkg fun args safe
-----------------------------------------------------------------------------
--
--- Caller-Save Registers
+-- Caller-Save Registers
--
-----------------------------------------------------------------------------
@@ -252,36 +245,36 @@ callerSaveVolatileRegs dflags = (caller_save, caller_load)
caller_load = catAGraphs (map callerRestoreGlobalReg regs_to_save)
system_regs = [ Sp,SpLim,Hp,HpLim,CCCS,CurrentTSO,CurrentNursery
- {- ,SparkHd,SparkTl,SparkBase,SparkLim -}
- , BaseReg ]
+ {- ,SparkHd,SparkTl,SparkBase,SparkLim -}
+ , BaseReg ]
regs_to_save = filter (callerSaves platform) system_regs
callerSaveGlobalReg reg
- = mkStore (get_GlobalReg_addr reg) (CmmReg (CmmGlobal reg))
+ = mkStore (get_GlobalReg_addr reg) (CmmReg (CmmGlobal reg))
callerRestoreGlobalReg reg
- = mkAssign (CmmGlobal reg)
- (CmmLoad (get_GlobalReg_addr reg) (globalRegType reg))
+ = mkAssign (CmmGlobal reg)
+ (CmmLoad (get_GlobalReg_addr reg) (globalRegType reg))
-- -----------------------------------------------------------------------------
-- Global registers
-- We map STG registers onto appropriate CmmExprs. Either they map
-- to real machine registers or stored as offsets from BaseReg. Given
--- a GlobalReg, get_GlobalReg_addr always produces the
+-- a GlobalReg, get_GlobalReg_addr always produces the
-- register table address for it.
-- (See also get_GlobalReg_reg_or_addr in MachRegs)
get_GlobalReg_addr :: GlobalReg -> CmmExpr
get_GlobalReg_addr BaseReg = regTableOffset 0
-get_GlobalReg_addr mid = get_Regtable_addr_from_offset
- (globalRegType mid) (baseRegOffset mid)
+get_GlobalReg_addr mid = get_Regtable_addr_from_offset
+ (globalRegType mid) (baseRegOffset mid)
-- Calculate a literal representing an offset into the register table.
-- Used when we don't have an actual BaseReg to offset from.
regTableOffset :: Int -> CmmExpr
-regTableOffset n =
+regTableOffset n =
CmmLit (CmmLabelOff mkMainCapabilityLabel (oFFSET_Capability_r + n))
get_Regtable_addr_from_offset :: CmmType -> Int -> CmmExpr
@@ -298,22 +291,22 @@ get_Regtable_addr_from_offset _rep offset =
baseRegOffset :: GlobalReg -> Int
-baseRegOffset Sp = oFFSET_StgRegTable_rSp
-baseRegOffset SpLim = oFFSET_StgRegTable_rSpLim
+baseRegOffset Sp = oFFSET_StgRegTable_rSp
+baseRegOffset SpLim = oFFSET_StgRegTable_rSpLim
baseRegOffset (LongReg 1) = oFFSET_StgRegTable_rL1
-baseRegOffset Hp = oFFSET_StgRegTable_rHp
-baseRegOffset HpLim = oFFSET_StgRegTable_rHpLim
+baseRegOffset Hp = oFFSET_StgRegTable_rHp
+baseRegOffset HpLim = oFFSET_StgRegTable_rHpLim
baseRegOffset CCCS = oFFSET_StgRegTable_rCCCS
baseRegOffset CurrentTSO = oFFSET_StgRegTable_rCurrentTSO
-baseRegOffset CurrentNursery = oFFSET_StgRegTable_rCurrentNursery
-baseRegOffset HpAlloc = oFFSET_StgRegTable_rHpAlloc
-baseRegOffset GCEnter1 = oFFSET_stgGCEnter1
-baseRegOffset GCFun = oFFSET_stgGCFun
-baseRegOffset reg = pprPanic "baseRegOffset:" (ppr reg)
+baseRegOffset CurrentNursery = oFFSET_StgRegTable_rCurrentNursery
+baseRegOffset HpAlloc = oFFSET_StgRegTable_rHpAlloc
+baseRegOffset GCEnter1 = oFFSET_stgGCEnter1
+baseRegOffset GCFun = oFFSET_stgGCFun
+baseRegOffset reg = pprPanic "baseRegOffset:" (ppr reg)
-------------------------------------------------------------------------
--
--- Strings generate a top-level data block
+-- Strings generate a top-level data block
--
-------------------------------------------------------------------------
@@ -332,14 +325,14 @@ newStringCLit str = newByteStringCLit (map (fromIntegral . ord) str)
newByteStringCLit :: [Word8] -> FCode CmmLit
newByteStringCLit bytes
- = do { uniq <- newUnique
- ; let (lit, decl) = mkByteStringCLit uniq bytes
- ; emitDecl decl
- ; return lit }
+ = do { uniq <- newUnique
+ ; let (lit, decl) = mkByteStringCLit uniq bytes
+ ; emitDecl decl
+ ; return lit }
-------------------------------------------------------------------------
--
--- Assigning expressions to temporaries
+-- Assigning expressions to temporaries
--
-------------------------------------------------------------------------
@@ -353,31 +346,31 @@ assignTemp :: CmmExpr -> FCode LocalReg
-- the optimization pass doesn't have to do as much work)
assignTemp (CmmReg (CmmLocal reg)) = return reg
assignTemp e = do { uniq <- newUnique
- ; let reg = LocalReg uniq (cmmExprType e)
+ ; let reg = LocalReg uniq (cmmExprType e)
; emitAssign (CmmLocal reg) e
- ; return reg }
+ ; return reg }
newTemp :: CmmType -> FCode LocalReg
newTemp rep = do { uniq <- newUnique
- ; return (LocalReg uniq rep) }
+ ; return (LocalReg uniq rep) }
newUnboxedTupleRegs :: Type -> FCode ([LocalReg], [ForeignHint])
-- Choose suitable local regs to use for the components
--- of an unboxed tuple that we are about to return to
+-- of an unboxed tuple that we are about to return to
-- the Sequel. If the Sequel is a join point, using the
-- regs it wants will save later assignments.
-newUnboxedTupleRegs res_ty
+newUnboxedTupleRegs res_ty
= ASSERT( isUnboxedTupleType res_ty )
- do { sequel <- getSequel
- ; regs <- choose_regs sequel
- ; ASSERT( regs `equalLength` reps )
- return (regs, map primRepForeignHint reps) }
+ do { sequel <- getSequel
+ ; regs <- choose_regs sequel
+ ; ASSERT( regs `equalLength` reps )
+ return (regs, map primRepForeignHint reps) }
where
UbxTupleRep ty_args = repType res_ty
reps = [ rep
- | ty <- ty_args
- , let rep = typePrimRep ty
- , not (isVoidRep rep) ]
+ | ty <- ty_args
+ , let rep = typePrimRep ty
+ , not (isVoidRep rep) ]
choose_regs (AssignTo regs _) = return regs
choose_regs _other = mapM (newTemp . primRepCmmType) reps
@@ -392,15 +385,15 @@ emitMultiAssign :: [LocalReg] -> [CmmExpr] -> FCode ()
-- input simultaneously, using temporary variables when necessary.
type Key = Int
-type Vrtx = (Key, Stmt) -- Give each vertex a unique number,
- -- for fast comparison
-type Stmt = (LocalReg, CmmExpr) -- r := e
+type Vrtx = (Key, Stmt) -- Give each vertex a unique number,
+ -- for fast comparison
+type Stmt = (LocalReg, CmmExpr) -- r := e
-- We use the strongly-connected component algorithm, in which
--- * the vertices are the statements
--- * an edge goes from s1 to s2 iff
--- s1 assigns to something s2 uses
--- that is, if s1 should *follow* s2 in the final order
+-- * the vertices are the statements
+-- * an edge goes from s1 to s2 iff
+-- s1 assigns to something s2 uses
+-- that is, if s1 should *follow* s2 in the final order
emitMultiAssign [] [] = return ()
emitMultiAssign [reg] [rhs] = emitAssign (CmmLocal reg) rhs
@@ -410,39 +403,39 @@ emitMultiAssign regs rhss = ASSERT( equalLength regs rhss )
unscramble :: [Vrtx] -> FCode ()
unscramble vertices = mapM_ do_component components
where
- edges :: [ (Vrtx, Key, [Key]) ]
- edges = [ (vertex, key1, edges_from stmt1)
- | vertex@(key1, stmt1) <- vertices ]
+ edges :: [ (Vrtx, Key, [Key]) ]
+ edges = [ (vertex, key1, edges_from stmt1)
+ | vertex@(key1, stmt1) <- vertices ]
- edges_from :: Stmt -> [Key]
- edges_from stmt1 = [ key2 | (key2, stmt2) <- vertices,
- stmt1 `mustFollow` stmt2 ]
+ edges_from :: Stmt -> [Key]
+ edges_from stmt1 = [ key2 | (key2, stmt2) <- vertices,
+ stmt1 `mustFollow` stmt2 ]
- components :: [SCC Vrtx]
- components = stronglyConnCompFromEdgedVertices edges
+ components :: [SCC Vrtx]
+ components = stronglyConnCompFromEdgedVertices edges
- -- do_components deal with one strongly-connected component
- -- Not cyclic, or singleton? Just do it
+ -- do_components deal with one strongly-connected component
+ -- Not cyclic, or singleton? Just do it
do_component :: SCC Vrtx -> FCode ()
do_component (AcyclicSCC (_,stmt)) = mk_graph stmt
- do_component (CyclicSCC []) = panic "do_component"
- do_component (CyclicSCC [(_,stmt)]) = mk_graph stmt
+ do_component (CyclicSCC []) = panic "do_component"
+ do_component (CyclicSCC [(_,stmt)]) = mk_graph stmt
- -- Cyclic? Then go via temporaries. Pick one to
- -- break the loop and try again with the rest.
+ -- Cyclic? Then go via temporaries. Pick one to
+ -- break the loop and try again with the rest.
do_component (CyclicSCC ((_,first_stmt) : rest)) = do
u <- newUnique
- let (to_tmp, from_tmp) = split u first_stmt
+ let (to_tmp, from_tmp) = split u first_stmt
mk_graph to_tmp
unscramble rest
mk_graph from_tmp
- split :: Unique -> Stmt -> (Stmt, Stmt)
- split uniq (reg, rhs)
- = ((tmp, rhs), (reg, CmmReg (CmmLocal tmp)))
- where
- rep = cmmExprType rhs
- tmp = LocalReg uniq rep
+ split :: Unique -> Stmt -> (Stmt, Stmt)
+ split uniq (reg, rhs)
+ = ((tmp, rhs), (reg, CmmReg (CmmLocal tmp)))
+ where
+ rep = cmmExprType rhs
+ tmp = LocalReg uniq rep
mk_graph :: Stmt -> FCode ()
mk_graph (reg, rhs) = emitAssign (CmmLocal reg) rhs
@@ -451,30 +444,31 @@ mustFollow :: Stmt -> Stmt -> Bool
(reg, _) `mustFollow` (_, rhs) = CmmLocal reg `regUsedIn` rhs
-------------------------------------------------------------------------
--- mkSwitch
+-- mkSwitch
-------------------------------------------------------------------------
-emitSwitch :: CmmExpr -- Tag to switch on
- -> [(ConTagZ, CmmAGraph)] -- Tagged branches
- -> Maybe CmmAGraph -- Default branch (if any)
- -> ConTagZ -> ConTagZ -- Min and Max possible values; behaviour
- -- outside this range is undefined
- -> FCode ()
+emitSwitch :: CmmExpr -- Tag to switch on
+ -> [(ConTagZ, CmmAGraph)] -- Tagged branches
+ -> Maybe CmmAGraph -- Default branch (if any)
+ -> ConTagZ -> ConTagZ -- Min and Max possible values; behaviour
+ -- outside this range is undefined
+ -> FCode ()
emitSwitch tag_expr branches mb_deflt lo_tag hi_tag
- = do { dflags <- getDynFlags
+ = do { dflags <- getDynFlags
; mkCmmSwitch (via_C dflags) tag_expr branches mb_deflt lo_tag hi_tag }
where
via_C dflags | HscC <- hscTarget dflags = True
- | otherwise = False
+ | otherwise = False
-mkCmmSwitch :: Bool -- True <=> never generate a conditional tree
- -> CmmExpr -- Tag to switch on
- -> [(ConTagZ, CmmAGraph)] -- Tagged branches
- -> Maybe CmmAGraph -- Default branch (if any)
- -> ConTagZ -> ConTagZ -- Min and Max possible values; behaviour
- -- outside this range is undefined
+mkCmmSwitch :: Bool -- True <=> never generate a
+ -- conditional tree
+ -> CmmExpr -- Tag to switch on
+ -> [(ConTagZ, CmmAGraph)] -- Tagged branches
+ -> Maybe CmmAGraph -- Default branch (if any)
+ -> ConTagZ -> ConTagZ -- Min and Max possible values; behaviour
+ -- outside this range is undefined
-> FCode ()
-- First, two rather common cases in which there is no work to do
@@ -487,7 +481,7 @@ mkCmmSwitch via_C tag_expr branches mb_deflt lo_tag hi_tag = do
mb_deflt_lbl <- label_default join_lbl mb_deflt
branches_lbls <- label_branches join_lbl branches
tag_expr' <- assignTemp' tag_expr
-
+
emit =<< mk_switch tag_expr' (sortBy (comparing fst) branches_lbls)
mb_deflt_lbl lo_tag hi_tag via_C
@@ -496,8 +490,8 @@ mkCmmSwitch via_C tag_expr branches mb_deflt lo_tag hi_tag = do
emitLabel join_lbl
mk_switch :: CmmExpr -> [(ConTagZ, BlockId)]
- -> Maybe BlockId
- -> ConTagZ -> ConTagZ -> Bool
+ -> Maybe BlockId
+ -> ConTagZ -> ConTagZ -> Bool
-> FCode CmmAGraph
-- SINGLETON TAG RANGE: no case analysis to do
@@ -509,19 +503,19 @@ mk_switch _tag_expr [(tag, lbl)] _ lo_tag hi_tag _via_C
-- SINGLETON BRANCH, NO DEFAULT: no case analysis to do
mk_switch _tag_expr [(_tag,lbl)] Nothing _ _ _
= return (mkBranch lbl)
- -- The simplifier might have eliminated a case
- -- so we may have e.g. case xs of
- -- [] -> e
- -- In that situation we can be sure the (:) case
- -- can't happen, so no need to test
+ -- The simplifier might have eliminated a case
+ -- so we may have e.g. case xs of
+ -- [] -> e
+ -- In that situation we can be sure the (:) case
+ -- can't happen, so no need to test
-- SINGLETON BRANCH: one equality check to do
mk_switch tag_expr [(tag,lbl)] (Just deflt) _ _ _
= return (mkCbranch cond deflt lbl)
where
cond = cmmNeWord tag_expr (CmmLit (mkIntCLit tag))
- -- We have lo_tag < hi_tag, but there's only one branch,
- -- so there must be a default
+ -- We have lo_tag < hi_tag, but there's only one branch,
+ -- so there must be a default
-- ToDo: we might want to check for the two branch case, where one of
-- the branches is the tag 0, because comparing '== 0' is likely to be
@@ -537,18 +531,18 @@ mk_switch tag_expr [(tag,lbl)] (Just deflt) _ _ _
-- time works around that problem.
--
mk_switch tag_expr branches mb_deflt lo_tag hi_tag via_C
- | use_switch -- Use a switch
- = let
- find_branch :: ConTagZ -> Maybe BlockId
- find_branch i = case (assocMaybe branches i) of
- Just lbl -> Just lbl
- Nothing -> mb_deflt
-
- -- NB. we have eliminated impossible branches at
- -- either end of the range (see below), so the first
- -- tag of a real branch is real_lo_tag (not lo_tag).
- arms :: [Maybe BlockId]
- arms = [ find_branch i | i <- [real_lo_tag..real_hi_tag]]
+ | use_switch -- Use a switch
+ = let
+ find_branch :: ConTagZ -> Maybe BlockId
+ find_branch i = case (assocMaybe branches i) of
+ Just lbl -> Just lbl
+ Nothing -> mb_deflt
+
+ -- NB. we have eliminated impossible branches at
+ -- either end of the range (see below), so the first
+ -- tag of a real branch is real_lo_tag (not lo_tag).
+ arms :: [Maybe BlockId]
+ arms = [ find_branch i | i <- [real_lo_tag..real_hi_tag]]
in
return (mkSwitch (cmmOffset tag_expr (- real_lo_tag)) arms)
@@ -557,86 +551,86 @@ mk_switch tag_expr branches mb_deflt lo_tag hi_tag via_C
= do stmts <- mk_switch tag_expr branches mb_deflt
lowest_branch hi_tag via_C
mkCmmIfThenElse
- (cmmULtWord tag_expr (CmmLit (mkIntCLit lowest_branch)))
- (mkBranch deflt)
+ (cmmULtWord tag_expr (CmmLit (mkIntCLit lowest_branch)))
+ (mkBranch deflt)
stmts
| Just deflt <- mb_deflt, (hi_tag - highest_branch) >= n_branches
= do stmts <- mk_switch tag_expr branches mb_deflt
lo_tag highest_branch via_C
mkCmmIfThenElse
- (cmmUGtWord tag_expr (CmmLit (mkIntCLit highest_branch)))
- (mkBranch deflt)
+ (cmmUGtWord tag_expr (CmmLit (mkIntCLit highest_branch)))
+ (mkBranch deflt)
stmts
- | otherwise -- Use an if-tree
+ | otherwise -- Use an if-tree
= do lo_stmts <- mk_switch tag_expr lo_branches mb_deflt
lo_tag (mid_tag-1) via_C
hi_stmts <- mk_switch tag_expr hi_branches mb_deflt
mid_tag hi_tag via_C
mkCmmIfThenElse
- (cmmUGeWord tag_expr (CmmLit (mkIntCLit mid_tag)))
+ (cmmUGeWord tag_expr (CmmLit (mkIntCLit mid_tag)))
hi_stmts
lo_stmts
- -- we test (e >= mid_tag) rather than (e < mid_tag), because
- -- the former works better when e is a comparison, and there
- -- are two tags 0 & 1 (mid_tag == 1). In this case, the code
- -- generator can reduce the condition to e itself without
- -- having to reverse the sense of the comparison: comparisons
- -- can't always be easily reversed (eg. floating
- -- pt. comparisons).
+ -- we test (e >= mid_tag) rather than (e < mid_tag), because
+ -- the former works better when e is a comparison, and there
+ -- are two tags 0 & 1 (mid_tag == 1). In this case, the code
+ -- generator can reduce the condition to e itself without
+ -- having to reverse the sense of the comparison: comparisons
+ -- can't always be easily reversed (eg. floating
+ -- pt. comparisons).
where
- use_switch = {- pprTrace "mk_switch" (
- ppr tag_expr <+> text "n_tags:" <+> int n_tags <+>
+ use_switch = {- pprTrace "mk_switch" (
+ ppr tag_expr <+> text "n_tags:" <+> int n_tags <+>
text "branches:" <+> ppr (map fst branches) <+>
- text "n_branches:" <+> int n_branches <+>
- text "lo_tag:" <+> int lo_tag <+>
- text "hi_tag:" <+> int hi_tag <+>
- text "real_lo_tag:" <+> int real_lo_tag <+>
- text "real_hi_tag:" <+> int real_hi_tag) $ -}
- ASSERT( n_branches > 1 && n_tags > 1 )
- n_tags > 2 && (via_C || (dense && big_enough))
- -- up to 4 branches we use a decision tree, otherwise
+ text "n_branches:" <+> int n_branches <+>
+ text "lo_tag:" <+> int lo_tag <+>
+ text "hi_tag:" <+> int hi_tag <+>
+ text "real_lo_tag:" <+> int real_lo_tag <+>
+ text "real_hi_tag:" <+> int real_hi_tag) $ -}
+ ASSERT( n_branches > 1 && n_tags > 1 )
+ n_tags > 2 && (via_C || (dense && big_enough))
+ -- up to 4 branches we use a decision tree, otherwise
-- a switch (== jump table in the NCG). This seems to be
-- optimal, and corresponds with what gcc does.
- big_enough = n_branches > 4
- dense = n_branches > (n_tags `div` 2)
+ big_enough = n_branches > 4
+ dense = n_branches > (n_tags `div` 2)
n_branches = length branches
-
- -- ignore default slots at each end of the range if there's
+
+ -- ignore default slots at each end of the range if there's
-- no default branch defined.
lowest_branch = fst (head branches)
highest_branch = fst (last branches)
real_lo_tag
- | isNothing mb_deflt = lowest_branch
- | otherwise = lo_tag
+ | isNothing mb_deflt = lowest_branch
+ | otherwise = lo_tag
real_hi_tag
- | isNothing mb_deflt = highest_branch
- | otherwise = hi_tag
+ | isNothing mb_deflt = highest_branch
+ | otherwise = hi_tag
n_tags = real_hi_tag - real_lo_tag + 1
- -- INVARIANT: Provided hi_tag > lo_tag (which is true)
- -- lo_tag <= mid_tag < hi_tag
- -- lo_branches have tags < mid_tag
- -- hi_branches have tags >= mid_tag
+ -- INVARIANT: Provided hi_tag > lo_tag (which is true)
+ -- lo_tag <= mid_tag < hi_tag
+ -- lo_branches have tags < mid_tag
+ -- hi_branches have tags >= mid_tag
(mid_tag,_) = branches !! (n_branches `div` 2)
- -- 2 branches => n_branches `div` 2 = 1
- -- => branches !! 1 give the *second* tag
- -- There are always at least 2 branches here
+ -- 2 branches => n_branches `div` 2 = 1
+ -- => branches !! 1 give the *second* tag
+ -- There are always at least 2 branches here
(lo_branches, hi_branches) = span is_lo branches
is_lo (t,_) = t < mid_tag
--------------
emitCmmLitSwitch :: CmmExpr -- Tag to switch on
- -> [(Literal, CmmAGraph)] -- Tagged branches
- -> CmmAGraph -- Default branch (always)
+ -> [(Literal, CmmAGraph)] -- Tagged branches
+ -> CmmAGraph -- Default branch (always)
-> FCode () -- Emit the code
--- Used for general literals, whose size might not be a word,
+-- Used for general literals, whose size might not be a word,
-- where there is always a default case, and where we don't know
-- the range of values for certain. For simplicity we always generate a tree.
--
@@ -652,10 +646,10 @@ emitCmmLitSwitch scrut branches deflt = do
(sortBy (comparing fst) branches_lbls)
emitLabel join_lbl
-mk_lit_switch :: CmmExpr -> BlockId
- -> [(Literal,BlockId)]
+mk_lit_switch :: CmmExpr -> BlockId
+ -> [(Literal,BlockId)]
-> FCode CmmAGraph
-mk_lit_switch scrut deflt [(lit,blk)]
+mk_lit_switch scrut deflt [(lit,blk)]
= return (mkCbranch (CmmMachOp ne [scrut, CmmLit cmm_lit]) deflt blk)
where
cmm_lit = mkSimpleLit lit
@@ -670,13 +664,13 @@ mk_lit_switch scrut deflt_blk_id branches
where
n_branches = length branches
(mid_lit,_) = branches !! (n_branches `div` 2)
- -- See notes above re mid_tag
+ -- See notes above re mid_tag
(lo_branches, hi_branches) = span is_lo branches
is_lo (t,_) = t < mid_lit
- cond = CmmMachOp (mkLtOp mid_lit)
- [scrut, CmmLit (mkSimpleLit mid_lit)]
+ cond = CmmMachOp (mkLtOp mid_lit)
+ [scrut, CmmLit (mkSimpleLit mid_lit)]
--------------
@@ -699,7 +693,7 @@ label_branches join_lbl ((tag,code):branches)
--------------
label_code :: BlockId -> CmmAGraph -> FCode BlockId
-- label_code J code
--- generates
+-- generates
-- [L: code; goto J]
-- and returns L
label_code join_lbl code = do