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, mkAsmTempLabel )
+import CLabel ( CLabel, mkStringLitLabel )
import Digraph ( SCC(..), stronglyConnComp )
import ListSetOps ( assocDefault )
-import Util ( filterOut, sortLt )
-import Char ( ord )
-import FastString ( LitString, FastString, unpackFS )
+import Util ( filterOut, sortLe )
+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 )
-------------------------------------------------------------------------
--
-------------------------------------------------------------------------
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
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)
--
-------------------------------------------------------------------------
-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)
-------------------------------------------------------------------------
--
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 = mkAsmTempLabel uniq
- ; emitData ReadOnlyData [CmmDataLabel lbl, CmmString str]
+ ; let lbl = mkStringLitLabel uniq
+ ; emitData ReadOnlyData [CmmDataLabel lbl, CmmString bytes]
; return (CmmLabel lbl) }
-------------------------------------------------------------------------
Nothing -> return Nothing
Just stmts -> do id <- forkCgStmts stmts; return (Just id)
- ; stmts <- mk_switch tag_expr (sortLt lt branches)
- mb_deflt_id lo_tag hi_tag
+ ; 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 via_C
; emitCgStmts stmts
}
where
- (t1,_) `lt` (t2,_) = t1 < t2
+ (t1,_) `le` (t2,_) = t1 <= t2
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
-- 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))
-- 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 { 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 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
(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)
-- 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
= do { scrut' <- assignTemp scrut
; deflt_blk_id <- forkCgStmts deflt_blk
- ; blk <- mk_lit_switch scrut' deflt_blk_id (sortLt lt branches)
+ ; blk <- mk_lit_switch scrut' deflt_blk_id (sortLe le branches)
; emitCgStmts blk }
where
- lt (t1,_) (t2,_) = t1 < t2
+ le (t1,_) (t2,_) = t1 <= t2
mk_lit_switch :: CmmExpr -> BlockId
-> [(Literal,CgStmts)]
projects / ghc-hetmet.git / blobdiff