[project @ 2006-01-06 16:30:17 by simonmar]

[ghc-hetmet.git] / ghc / compiler / codeGen / CgUtils.hs

diff --git a/ghc/compiler/codeGen/CgUtils.hs b/ghc/compiler/codeGen/CgUtils.hs
index c8cae4b..2f69927 100644 (file)
--- a/ghc/compiler/codeGen/CgUtils.hs
+++ b/ghc/compiler/codeGen/CgUtils.hs
@@ -45,19 +45,21 @@ import CLabel
 import CmmUtils
 import MachOp          ( MachRep(..), wordRep, MachOp(..),  MachHint(..),
                          mo_wordOr, mo_wordAnd, mo_wordNe, mo_wordEq,
-                         mo_wordULt, mo_wordUGt, 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 CmdLineOpts     ( DynFlags(..), HscTarget(..) )
-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
+import DATA_WORD       ( Word8 )
 import Maybe           ( isNothing )
 
 -------------------------------------------------------------------------
@@ -76,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,6 +156,7 @@ 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]
+cmmUGeWord e1 e2 = CmmMachOp mo_wordUGe [e1, e2]
 cmmUGtWord e1 e2 = CmmMachOp mo_wordUGt [e1, e2]
 
 cmmNegate :: CmmExpr -> CmmExpr
@@ -209,11 +213,11 @@ addToMemE rep ptr n
 --
 -------------------------------------------------------------------------
 
-tagToClosure :: DynFlags -> TyCon -> CmmExpr -> CmmExpr
-tagToClosure dflags tycon tag
+tagToClosure :: HomeModules -> TyCon -> CmmExpr -> CmmExpr
+tagToClosure hmods tycon tag
   = CmmLoad (cmmOffsetExprW closure_tbl tag) wordRep
   where closure_tbl = CmmLit (CmmLabel lbl)
-       lbl = mkClosureTableLabel dflags (tyConName tycon)
+       lbl = mkClosureTableLabel hmods (tyConName tycon)
 
 -------------------------------------------------------------------------
 --
@@ -306,10 +310,13 @@ emitRODataLits lbl lits
 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) }
 
 -------------------------------------------------------------------------
@@ -411,7 +418,7 @@ mk_switch tag_expr [(tag,stmts)] (Just deflt) lo_tag hi_tag via_C
 -- 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
+  | use_switch         -- Use a switch
   = do { branch_ids <- mapM forkCgStmts (map snd branches)
        ; let 
                tagged_blk_ids = zip (map fst branches) (map Just branch_ids)
@@ -456,17 +463,28 @@ mk_switch tag_expr branches mb_deflt lo_tag hi_tag via_C
                                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
-       ; return (assign_tag `consCgStmt` (branch_stmt `consCgStmt` hi_stmts)) 
+       ; 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 ) 
-                  {- pprTrace "mk_switch" (ppr tag_expr <+> text "n_tags: "
-                                       <+> int n_tags <+> text "dense: "
-                                       <+> int n_branches) $ -}
-                  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)