X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcodeGen%2FCgUtils.hs;h=2f69927db00e7c891057d35854ce0a579ea69751;hb=9d7da331989abcd1844e9d03b8d1e4163796fa85;hp=c8cae4b6cf056cb866d37355444ebe1b040a53dc;hpb=90334ab3c0c841d466671a416763989d169d4877;p=ghc-hetmet.git

diff --git a/ghc/compiler/codeGen/CgUtils.hs b/ghc/compiler/codeGen/CgUtils.hs
index c8cae4b..2f69927 100644
--- 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)