diff options
Diffstat (limited to 'compiler/codeGen/StgCmmUtils.hs')
| -rw-r--r-- | compiler/codeGen/StgCmmUtils.hs | 394 |
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 |