X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcodeGen%2FCgUtils.hs;h=9a99bfd1269ba234f8e6771c33b2cf16f5d685d9;hb=153b9cb9b11e05c4edb1b6bc0a7b972660e41f70;hp=9d789be942e79a7adc377953402ea7895d5f3322;hpb=59c796f8e77325d35f29ddd3e724bfa780466d40;p=ghc-hetmet.git diff --git a/ghc/compiler/codeGen/CgUtils.hs b/ghc/compiler/codeGen/CgUtils.hs index 9d789be..9a99bfd 100644 --- a/ghc/compiler/codeGen/CgUtils.hs +++ b/ghc/compiler/codeGen/CgUtils.hs @@ -45,21 +45,20 @@ import CLabel import CmmUtils import MachOp ( MachRep(..), wordRep, MachOp(..), MachHint(..), mo_wordOr, mo_wordAnd, mo_wordNe, mo_wordEq, - mo_wordULt, machRepByteWidth ) + mo_wordULt, mo_wordUGt, machRepByteWidth ) import ForeignCall ( CCallConv(..) ) import Literal ( Literal(..) ) -import CLabel ( CLabel, mkAsmTempLabel ) +import CLabel ( CLabel, mkStringLitLabel ) import Digraph ( SCC(..), stronglyConnComp ) import ListSetOps ( assocDefault ) import Util ( filterOut, sortLe ) -import Char ( ord ) +import CmdLineOpts ( DynFlags ) import FastString ( LitString, FastString, unpackFS ) import Outputable +import Char ( ord ) import DATA_BITS - -#include "../includes/ghcconfig.h" - -- For WORDS_BIGENDIAN +import Maybe ( isNothing ) ------------------------------------------------------------------------- -- @@ -153,7 +152,8 @@ cmmOrWord e1 e2 = CmmMachOp mo_wordOr [e1, e2] cmmAndWord e1 e2 = CmmMachOp mo_wordAnd [e1, e2] cmmNeWord e1 e2 = CmmMachOp mo_wordNe [e1, e2] cmmEqWord e1 e2 = CmmMachOp mo_wordEq [e1, e2] -cmmULtWord e1 e2 = CmmMachOp mo_wordULt [e1, e2] +cmmULtWord e1 e2 = CmmMachOp mo_wordULt [e1, e2] +cmmUGtWord e1 e2 = CmmMachOp mo_wordUGt [e1, e2] cmmNegate :: CmmExpr -> CmmExpr cmmNegate (CmmLit (CmmInt n rep)) = CmmLit (CmmInt (-n) rep) @@ -209,10 +209,11 @@ addToMemE rep ptr n -- ------------------------------------------------------------------------- -tagToClosure :: TyCon -> CmmExpr -> CmmExpr -tagToClosure tycon tag +tagToClosure :: DynFlags -> TyCon -> CmmExpr -> CmmExpr +tagToClosure dflags tycon tag = CmmLoad (cmmOffsetExprW closure_tbl tag) wordRep - where closure_tbl = CmmLit (CmmLabel (mkClosureTblLabel (tyConName tycon))) + where closure_tbl = CmmLit (CmmLabel lbl) + lbl = mkClosureTableLabel dflags (tyConName tycon) ------------------------------------------------------------------------- -- @@ -295,14 +296,19 @@ emitDataLits lbl lits emitRODataLits :: CLabel -> [CmmLit] -> Code -- Emit a read-only data block emitRODataLits lbl lits - = emitData ReadOnlyData (CmmDataLabel lbl : map CmmStaticLit lits) + = emitData section (CmmDataLabel lbl : map CmmStaticLit lits) + where section | any needsRelocation lits = RelocatableReadOnlyData + | otherwise = ReadOnlyData + needsRelocation (CmmLabel _) = True + needsRelocation (CmmLabelOff _ _) = True + needsRelocation _ = False mkStringCLit :: String -> FCode CmmLit -- Make a global definition for the string, -- and return its label mkStringCLit str = do { uniq <- newUnique - ; let lbl = mkAsmTempLabel uniq + ; let lbl = mkStringLitLabel uniq ; emitData ReadOnlyData [CmmDataLabel lbl, CmmString str] ; return (CmmLabel lbl) } @@ -394,22 +400,41 @@ mk_switch tag_expr [(tag,stmts)] (Just deflt) lo_tag hi_tag -- DENSE TAG RANGE: use a switch statment mk_switch tag_expr branches mb_deflt lo_tag hi_tag | use_switch -- Use a switch - = do { deflt_id <- get_deflt_id mb_deflt - ; branch_ids <- mapM forkCgStmts (map snd branches) + = do { branch_ids <- mapM forkCgStmts (map snd branches) ; let - tagged_blk_ids = zip (map fst branches) branch_ids + tagged_blk_ids = zip (map fst branches) (map Just branch_ids) - find_branch :: BlockId -> ConTagZ -> BlockId - find_branch deflt_id i = assocDefault deflt_id tagged_blk_ids i + find_branch :: ConTagZ -> Maybe BlockId + find_branch i = assocDefault mb_deflt tagged_blk_ids i - arms = [ Just (find_branch deflt_id (i+lo_tag)) - | i <- [0..n_tags-1]] + -- 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 = [ find_branch i | i <- [real_lo_tag..real_hi_tag]] - switch_stmt = CmmSwitch (cmmOffset tag_expr (- lo_tag)) arms + switch_stmt = CmmSwitch (cmmOffset tag_expr (- real_lo_tag)) arms - ; return (oneCgStmt switch_stmt) + ; ASSERT(not (all isNothing arms)) + return (oneCgStmt switch_stmt) } + -- if we can knock off a bunch of default cases with one if, then do so + | Just deflt <- mb_deflt, (lowest_branch - lo_tag) >= n_branches + = do { (assign_tag, tag_expr') <- assignTemp' tag_expr + ; let cond = cmmULtWord tag_expr' (CmmLit (mkIntCLit lowest_branch)) + branch = CmmCondBranch cond deflt + ; stmts <- mk_switch tag_expr' branches mb_deflt lowest_branch hi_tag + ; return (assign_tag `consCgStmt` (branch `consCgStmt` stmts)) + } + + | Just deflt <- mb_deflt, (hi_tag - highest_branch) >= n_branches + = do { (assign_tag, tag_expr') <- assignTemp' tag_expr + ; let cond = cmmUGtWord tag_expr' (CmmLit (mkIntCLit highest_branch)) + branch = CmmCondBranch cond deflt + ; stmts <- mk_switch tag_expr' branches mb_deflt lo_tag highest_branch + ; return (assign_tag `consCgStmt` (branch `consCgStmt` stmts)) + } + | otherwise -- Use an if-tree = do { (assign_tag, tag_expr') <- assignTemp' tag_expr -- To avoid duplication @@ -422,14 +447,31 @@ mk_switch tag_expr branches mb_deflt lo_tag hi_tag } where use_switch = ASSERT( n_branches > 1 && n_tags > 1 ) + {- pprTrace "mk_switch" (ppr tag_expr <+> text "n_tags: " + <+> int n_tags <+> text "dense: " + <+> int n_branches) $ -} n_tags > 2 && (small || dense) -- a 2-branch switch always turns into an if. small = n_tags <= 4 dense = n_branches > (n_tags `div` 2) exhaustive = n_tags == n_branches - n_tags = hi_tag - lo_tag + 1 n_branches = length branches + -- 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 + + real_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 @@ -443,19 +485,6 @@ mk_switch tag_expr branches mb_deflt lo_tag hi_tag (lo_branches, hi_branches) = span is_lo branches is_lo (t,_) = t < mid_tag - -- Add a default block if the case is not exhaustive - get_deflt_id (Just deflt_id) = return deflt_id - get_deflt_id Nothing - | exhaustive - = return (pprPanic "mk_deflt_blks" (ppr tag_expr)) - | otherwise - = do { stmts <- getCgStmts (stmtC jump_to_impossible) - ; id <- forkCgStmts stmts - ; return id } - - jump_to_impossible - = CmmJump (mkLblExpr mkErrorStdEntryLabel) [] - assignTemp' e | isTrivialCmmExpr e = return (CmmNop, e) @@ -470,6 +499,9 @@ emitLitSwitch :: CmmExpr -- Tag to switch on -- 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. +-- +-- ToDo: for integers we could do better here, perhaps by generalising +-- mk_switch and using that. --SDM 15/09/2004 emitLitSwitch scrut [] deflt = emitCgStmts deflt emitLitSwitch scrut branches deflt_blk