X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FnativeGen%2FAsmCodeGen.lhs;h=57faa6ff0efc14d72b3a83a1a936d3c61bf48e36;hp=06e6d6d4a0830dcb0201a1b1db4d68ec2dc37181;hb=2d4d636af091b8da27466b5cf90011395a9c2f66;hpb=50f5c8491bfcb6b891f772e2915443dbb5078e97

diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs
index 06e6d6d..57faa6f 100644
--- a/compiler/nativeGen/AsmCodeGen.lhs
+++ b/compiler/nativeGen/AsmCodeGen.lhs
@@ -50,6 +50,7 @@ import qualified RegAlloc.Graph.TrivColorable	as Color
 
 import TargetReg
 import Platform
+import Config
 import Instruction
 import PIC
 import Reg
@@ -68,7 +69,6 @@ import UniqSupply
 import DynFlags
 import StaticFlags
 import Util
-import Config
 
 import Digraph
 import qualified Pretty
@@ -86,7 +86,6 @@ import Data.List
 import Data.Maybe
 import Control.Monad
 import System.IO
-import Distribution.System
 
 {-
 The native-code generator has machine-independent and
@@ -372,10 +371,25 @@ cmmNativeGen dflags us cmm count
 			, Nothing
 			, mPprStats)
 
-	---- generate jump tables
+        ---- x86fp_kludge.  This pass inserts ffree instructions to clear
+        ---- the FPU stack on x86.  The x86 ABI requires that the FPU stack
+        ---- is clear, and library functions can return odd results if it
+        ---- isn't.
+        ----
+        ---- NB. must happen before shortcutBranches, because that
+        ---- generates JXX_GBLs which we can't fix up in x86fp_kludge.
+        let kludged =
+#if i386_TARGET_ARCH
+	 	{-# SCC "x86fp_kludge" #-}
+                map x86fp_kludge alloced
+#else
+                alloced
+#endif
+
+        ---- generate jump tables
 	let tabled	=
 		{-# SCC "generateJumpTables" #-}
-		alloced ++ generateJumpTables alloced
+                generateJumpTables kludged
 
 	---- shortcut branches
 	let shorted	=
@@ -387,27 +401,18 @@ cmmNativeGen dflags us cmm count
 	 	{-# SCC "sequenceBlocks" #-}
 	 	map sequenceTop shorted
 
-	---- x86fp_kludge
-	let kludged =
-#if i386_TARGET_ARCH
-	 	{-# SCC "x86fp_kludge" #-}
-	 	map x86fp_kludge sequenced
-#else
-		sequenced
-#endif
-
-	---- expansion of SPARC synthetic instrs
+        ---- expansion of SPARC synthetic instrs
 #if sparc_TARGET_ARCH
 	let expanded = 
 		{-# SCC "sparc_expand" #-}
-		map expandTop kludged
+                map expandTop sequenced
 
 	dumpIfSet_dyn dflags
 		Opt_D_dump_asm_expanded "Synthetic instructions expanded"
 		(vcat $ map (docToSDoc . pprNatCmmTop) expanded)
 #else
 	let expanded = 
-		kludged
+                sequenced
 #endif
 
 	return 	( usAlloc
@@ -446,14 +451,12 @@ makeImportsDoc dflags imports
                 -- stack so add the note in:
             Pretty.$$ Pretty.text ".section .note.GNU-stack,\"\",@progbits"
 #endif
-#if !defined(darwin_TARGET_OS)
                 -- And just because every other compiler does, lets stick in
 		-- an identifier directive: .ident "GHC x.y.z"
-	    Pretty.$$ let compilerIdent = Pretty.text "GHC" Pretty.<+>
+            Pretty.$$ let compilerIdent = Pretty.text "GHC" Pretty.<+>
 	                                  Pretty.text cProjectVersion
                        in Pretty.text ".ident" Pretty.<+>
                           Pretty.doubleQuotes compilerIdent
-#endif
 
  where
 	-- Generate "symbol stubs" for all external symbols that might
@@ -479,7 +482,7 @@ makeImportsDoc dflags imports
 		| otherwise
 		= Pretty.empty
 
-	doPpr lbl = (lbl, Pretty.render $ pprCLabel lbl astyle)
+	doPpr lbl = (lbl, renderWithStyle (pprCLabel lbl) astyle)
 	astyle = mkCodeStyle AsmStyle
 
 
@@ -615,8 +618,8 @@ makeFarBranches = id
 generateJumpTables
 	:: [NatCmmTop Instr] -> [NatCmmTop Instr]
 generateJumpTables xs = concatMap f xs
-    where f (CmmProc _ _ (ListGraph xs)) = concatMap g xs
-          f _ = []
+    where f p@(CmmProc _ _ (ListGraph xs)) = p : concatMap g xs
+          f p = [p]
           g (BasicBlock _ xs) = catMaybes (map generateJumpTableForInstr xs)
 
 -- -----------------------------------------------------------------------------
@@ -817,8 +820,10 @@ cmmStmtConFold stmt
 
 
 cmmExprConFold :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
-cmmExprConFold referenceKind expr
-   = case expr of
+cmmExprConFold referenceKind expr = do
+     dflags <- getDynFlagsCmmOpt
+     let arch = platformArch (targetPlatform dflags)
+     case expr of
         CmmLoad addr rep
            -> do addr' <- cmmExprConFold DataReference addr
                  return $ CmmLoad addr' rep
@@ -831,11 +836,9 @@ cmmExprConFold referenceKind expr
 
         CmmLit (CmmLabel lbl)
            -> do
-		dflags <- getDynFlagsCmmOpt
 		cmmMakeDynamicReference dflags addImportCmmOpt referenceKind lbl
         CmmLit (CmmLabelOff lbl off)
            -> do
-		 dflags <- getDynFlagsCmmOpt
 		 dynRef <- cmmMakeDynamicReference dflags addImportCmmOpt referenceKind lbl
                  return $ cmmMachOpFold (MO_Add wordWidth) [
                      dynRef,
@@ -846,15 +849,15 @@ cmmExprConFold referenceKind expr
         -- to use the register table, so we replace these registers
         -- with the corresponding labels:
         CmmReg (CmmGlobal EagerBlackholeInfo)
-          | cTargetArch == PPC && not opt_PIC
+          | arch == ArchPPC && not opt_PIC
           -> cmmExprConFold referenceKind $
              CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_EAGER_BLACKHOLE_info")))
         CmmReg (CmmGlobal GCEnter1)
-          | cTargetArch == PPC && not opt_PIC
+          | arch == ArchPPC && not opt_PIC
           -> cmmExprConFold referenceKind $
              CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_gc_enter_1"))) 
         CmmReg (CmmGlobal GCFun)
-          | cTargetArch == PPC && not opt_PIC
+          | arch == ArchPPC && not opt_PIC
           -> cmmExprConFold referenceKind $
              CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_gc_fun")))