X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcodeGen%2FCgUtils.hs;h=c8cae4b6cf056cb866d37355444ebe1b040a53dc;hb=75d52d81c0256e7bd2ae5108fc611224ea08edda;hp=06011f16eb6c5de24a5a5ae4d2f7efb1cdb8edc2;hpb=f220cc512fdc7f885e60d656ba7ba0d9f2e67611;p=ghc-hetmet.git diff --git a/ghc/compiler/codeGen/CgUtils.hs b/ghc/compiler/codeGen/CgUtils.hs index 06011f1..c8cae4b 100644 --- a/ghc/compiler/codeGen/CgUtils.hs +++ b/ghc/compiler/codeGen/CgUtils.hs @@ -52,16 +52,14 @@ import CLabel ( CLabel, mkStringLitLabel ) import Digraph ( SCC(..), stronglyConnComp ) import ListSetOps ( assocDefault ) import Util ( filterOut, sortLe ) -import Char ( ord ) +import CmdLineOpts ( DynFlags(..), HscTarget(..) ) import FastString ( LitString, FastString, unpackFS ) import Outputable +import Char ( ord ) import DATA_BITS import Maybe ( isNothing ) -#include "../includes/ghcconfig.h" - -- For WORDS_BIGENDIAN - ------------------------------------------------------------------------- -- -- Random small functions @@ -211,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) ------------------------------------------------------------------------- -- @@ -297,7 +296,12 @@ 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, @@ -354,8 +358,12 @@ emitSwitch tag_expr branches mb_deflt lo_tag hi_tag Nothing -> return Nothing Just stmts -> do id <- forkCgStmts stmts; return (Just id) + ; dflags <- getDynFlags + ; let via_C | HscC <- hscTarget dflags = True + | otherwise = False + ; stmts <- mk_switch tag_expr (sortLe le branches) - mb_deflt_id lo_tag hi_tag + mb_deflt_id lo_tag hi_tag via_C ; emitCgStmts stmts } where @@ -363,17 +371,17 @@ emitSwitch tag_expr branches mb_deflt lo_tag hi_tag mk_switch :: CmmExpr -> [(ConTagZ, CgStmts)] - -> Maybe BlockId -> ConTagZ -> ConTagZ + -> Maybe BlockId -> ConTagZ -> ConTagZ -> Bool -> FCode CgStmts -- SINGLETON TAG RANGE: no case analysis to do -mk_switch tag_expr [(tag,stmts)] _ lo_tag hi_tag +mk_switch tag_expr [(tag,stmts)] _ lo_tag hi_tag via_C | lo_tag == hi_tag = ASSERT( tag == lo_tag ) return stmts -- SINGLETON BRANCH, NO DEFUALT: no case analysis to do -mk_switch tag_expr [(tag,stmts)] Nothing lo_tag hi_tag +mk_switch tag_expr [(tag,stmts)] Nothing lo_tag hi_tag via_C = return stmts -- The simplifier might have eliminated a case -- so we may have e.g. case xs of @@ -382,7 +390,7 @@ mk_switch tag_expr [(tag,stmts)] Nothing lo_tag hi_tag -- can't happen, so no need to test -- SINGLETON BRANCH: one equality check to do -mk_switch tag_expr [(tag,stmts)] (Just deflt) lo_tag hi_tag +mk_switch tag_expr [(tag,stmts)] (Just deflt) lo_tag hi_tag via_C = return (CmmCondBranch cond deflt `consCgStmt` stmts) where cond = cmmNeWord tag_expr (CmmLit (mkIntCLit tag)) @@ -393,9 +401,17 @@ mk_switch tag_expr [(tag,stmts)] (Just deflt) lo_tag hi_tag -- the branches is the tag 0, because comparing '== 0' is likely to be -- more efficient than other kinds of comparison. --- DENSE TAG RANGE: use a switch statment -mk_switch tag_expr branches mb_deflt lo_tag hi_tag - | use_switch -- Use a switch +-- DENSE TAG RANGE: use a switch statment. +-- +-- We also use a switch uncoditionally when compiling via C, because +-- this will get emitted as a C switch statement and the C compiler +-- should do a good job of optimising it. Also, older GCC versions +-- (2.95 in particular) have problems compiling the complicated +-- if-trees generated by this code, so compiling to a switch every +-- time works around that problem. +-- +mk_switch tag_expr branches mb_deflt lo_tag hi_tag via_C + | use_switch || via_C -- Use a switch = do { branch_ids <- mapM forkCgStmts (map snd branches) ; let tagged_blk_ids = zip (map fst branches) (map Just branch_ids) @@ -403,33 +419,43 @@ mk_switch tag_expr branches mb_deflt lo_tag hi_tag find_branch :: ConTagZ -> Maybe BlockId find_branch i = assocDefault mb_deflt tagged_blk_ids i - arms = [ find_branch (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)) - ; stmtC (CmmCondBranch cond deflt) - ; mk_switch tag_expr' branches mb_deflt lowest_branch hi_tag + branch = CmmCondBranch cond deflt + ; stmts <- mk_switch tag_expr' branches mb_deflt + lowest_branch hi_tag via_C + ; 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)) - ; stmtC (CmmCondBranch cond deflt) - ; mk_switch tag_expr' branches mb_deflt lo_tag highest_branch + branch = CmmCondBranch cond deflt + ; stmts <- mk_switch tag_expr' branches mb_deflt + lo_tag highest_branch via_C + ; return (assign_tag `consCgStmt` (branch `consCgStmt` stmts)) } | otherwise -- Use an if-tree = do { (assign_tag, tag_expr') <- assignTemp' tag_expr -- To avoid duplication - ; lo_stmts <- mk_switch tag_expr' lo_branches mb_deflt lo_tag (mid_tag-1) - ; hi_stmts <- mk_switch tag_expr' hi_branches mb_deflt mid_tag hi_tag + ; 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 ; lo_id <- forkCgStmts lo_stmts ; let cond = cmmULtWord tag_expr' (CmmLit (mkIntCLit mid_tag)) branch_stmt = CmmCondBranch cond lo_id