X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcodeGen%2FCgUtils.hs;h=2f69927db00e7c891057d35854ce0a579ea69751;hb=9d7da331989abcd1844e9d03b8d1e4163796fa85;hp=5dbef8b438b28d1a1b75512d2eefeb6c55dcca67;hpb=557d889d9db42c76b8b4cd07f07eb3616ff3236b;p=ghc-hetmet.git diff --git a/ghc/compiler/codeGen/CgUtils.hs b/ghc/compiler/codeGen/CgUtils.hs index 5dbef8b..2f69927 100644 --- a/ghc/compiler/codeGen/CgUtils.hs +++ b/ghc/compiler/codeGen/CgUtils.hs @@ -45,21 +45,22 @@ 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, mo_wordUGe, machRepByteWidth ) import ForeignCall ( CCallConv(..) ) import Literal ( Literal(..) ) import CLabel ( CLabel, mkStringLitLabel ) import Digraph ( SCC(..), stronglyConnComp ) import ListSetOps ( assocDefault ) import Util ( filterOut, sortLe ) -import Char ( ord ) -import FastString ( LitString, FastString, unpackFS ) +import DynFlags ( DynFlags(..), HscTarget(..) ) +import Packages ( HomeModules ) +import FastString ( LitString, FastString, bytesFS ) import Outputable +import Char ( ord ) import DATA_BITS - -#include "../includes/ghcconfig.h" - -- For WORDS_BIGENDIAN +import DATA_WORD ( Word8 ) +import Maybe ( isNothing ) ------------------------------------------------------------------------- -- @@ -77,7 +78,8 @@ addIdReps ids = [(idCgRep id, id) | id <- ids] ------------------------------------------------------------------------- cgLit :: Literal -> FCode CmmLit -cgLit (MachStr s) = mkStringCLit (unpackFS s) +cgLit (MachStr s) = mkByteStringCLit (bytesFS s) + -- not unpackFS; we want the UTF-8 byte stream. cgLit other_lit = return (mkSimpleLit other_lit) mkSimpleLit :: Literal -> CmmLit @@ -153,7 +155,9 @@ 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] +cmmUGeWord e1 e2 = CmmMachOp mo_wordUGe [e1, e2] +cmmUGtWord e1 e2 = CmmMachOp mo_wordUGt [e1, e2] cmmNegate :: CmmExpr -> CmmExpr cmmNegate (CmmLit (CmmInt n rep)) = CmmLit (CmmInt (-n) rep) @@ -209,10 +213,11 @@ addToMemE rep ptr n -- ------------------------------------------------------------------------- -tagToClosure :: TyCon -> CmmExpr -> CmmExpr -tagToClosure tycon tag +tagToClosure :: HomeModules -> TyCon -> CmmExpr -> CmmExpr +tagToClosure hmods tycon tag = CmmLoad (cmmOffsetExprW closure_tbl tag) wordRep - where closure_tbl = CmmLit (CmmLabel (mkClosureTblLabel (tyConName tycon))) + where closure_tbl = CmmLit (CmmLabel lbl) + lbl = mkClosureTableLabel hmods (tyConName tycon) ------------------------------------------------------------------------- -- @@ -295,15 +300,23 @@ 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 +mkStringCLit str = mkByteStringCLit (map (fromIntegral.ord) str) + +mkByteStringCLit :: [Word8] -> FCode CmmLit +mkByteStringCLit bytes = do { uniq <- newUnique ; let lbl = mkStringLitLabel uniq - ; emitData ReadOnlyData [CmmDataLabel lbl, CmmString str] + ; emitData ReadOnlyData [CmmDataLabel lbl, CmmString bytes] ; return (CmmLabel lbl) } ------------------------------------------------------------------------- @@ -352,8 +365,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 @@ -361,17 +378,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 @@ -380,7 +397,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)) @@ -391,8 +408,16 @@ 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 +-- 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 -- Use a switch = do { branch_ids <- mapM forkCgStmts (map snd branches) ; let @@ -401,33 +426,86 @@ 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)) + 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)) + 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_id <- forkCgStmts lo_stmts - ; let cond = cmmULtWord tag_expr' (CmmLit (mkIntCLit mid_tag)) - branch_stmt = CmmCondBranch cond lo_id - ; return (assign_tag `consCgStmt` (branch_stmt `consCgStmt` hi_stmts)) + ; 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 + ; hi_id <- forkCgStmts hi_stmts + ; let cond = cmmUGeWord tag_expr' (CmmLit (mkIntCLit mid_tag)) + branch_stmt = CmmCondBranch cond hi_id + ; return (assign_tag `consCgStmt` (branch_stmt `consCgStmt` 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). where - use_switch = ASSERT( n_branches > 1 && n_tags > 1 ) - n_tags > 2 && (small || dense) + use_switch = {- pprTrace "mk_switch" ( + ppr tag_expr <+> text "n_tags:" <+> int n_tags <+> + 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 && (small || dense || via_C) -- 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 @@ -455,6 +533,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