Merge branch 'master' of darcs.haskell.org:/srv/darcs//ghc

3 files changed, 83 insertions, 67 deletions

diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs
index d3fbe4cf47..34500bb109 100644
--- a/compiler/deSugar/Coverage.lhs
+++ b/compiler/deSugar/Coverage.lhs
@@ -89,6 +89,12 @@ addTicksToBinds dflags mod mod_loc exports tyCons binds =
                                           | tyCon <- tyCons ]
                       , density      = mkDensity dflags
                       , this_mod     = mod
+                      , tickishType  = case hscTarget dflags of
+                          HscInterpreted          -> Breakpoints
+                          _ | opt_Hpc             -> HpcTicks
+                            | dopt Opt_SccProfilingOn dflags
+                                                  -> ProfNotes
+                            | otherwise           -> error "addTicksToBinds: No way to annotate!"
                        })
                    (TT
                       { tickBoxCount = 0
@@ -910,10 +916,21 @@ data TickTransEnv = TTE { fileName     :: FastString
                         , inScope      :: VarSet
                         , blackList    :: Map SrcSpan ()
                         , this_mod     :: Module
+                        , tickishType  :: TickishType
                         }
 
 --      deriving Show
 
+data TickishType = ProfNotes | HpcTicks | Breakpoints
+
+
+-- | Tickishs that only make sense when their source code location
+-- refers to the current file. This might not always be true due to
+-- LINE pragmas in the code - which would confuse at least HPC.
+tickSameFileOnly :: TickishType -> Bool
+tickSameFileOnly HpcTicks = True
+tickSameFileOnly _other   = False
+
 type FreeVars = OccEnv Id
 noFVs :: FreeVars
 noFVs = emptyOccEnv
@@ -982,13 +999,22 @@ getPathEntry = declPath `liftM` getEnv
 getFileName :: TM FastString
 getFileName = fileName `liftM` getEnv
 
-sameFileName :: SrcSpan -> TM a -> TM a -> TM a
-sameFileName pos out_of_scope in_scope = do
+isGoodSrcSpan' :: SrcSpan -> Bool
+isGoodSrcSpan' pos@(RealSrcSpan _) = srcSpanStart pos /= srcSpanEnd pos
+isGoodSrcSpan' (UnhelpfulSpan _) = False
+
+isGoodTickSrcSpan :: SrcSpan -> TM Bool
+isGoodTickSrcSpan pos = do
   file_name <- getFileName
-  case srcSpanFileName_maybe pos of
-    Just file_name2
-      | file_name == file_name2 -> in_scope
-    _ -> out_of_scope
+  tickish <- tickishType `liftM` getEnv
+  let need_same_file = tickSameFileOnly tickish
+      same_file      = Just file_name == srcSpanFileName_maybe pos
+  return (isGoodSrcSpan' pos && (not need_same_file || same_file))
+
+ifGoodTickSrcSpan :: SrcSpan -> TM a -> TM a -> TM a
+ifGoodTickSrcSpan pos then_code else_code = do
+  good <- isGoodTickSrcSpan pos
+  if good then then_code else else_code
 
 bindLocals :: [Id] -> TM a -> TM a
 bindLocals new_ids (TM m)
@@ -1007,23 +1033,23 @@ isBlackListed pos = TM $ \ env st ->
 -- expression argument to support nested box allocations
 allocTickBox :: BoxLabel -> Bool -> Bool -> SrcSpan -> TM (HsExpr Id)
              -> TM (LHsExpr Id)
-allocTickBox boxLabel countEntries topOnly pos m | isGoodSrcSpan' pos =
-  sameFileName pos (do e <- m; return (L pos e)) $ do
+allocTickBox boxLabel countEntries topOnly pos m =
+  ifGoodTickSrcSpan pos (do
     (fvs, e) <- getFreeVars m
     env <- getEnv
     tickish <- mkTickish boxLabel countEntries topOnly pos fvs (declPath env)
     return (L pos (HsTick tickish (L pos e)))
-allocTickBox _boxLabel _countEntries _topOnly pos m = do
-  e <- m
-  return (L pos e)
-
+  ) (do
+    e <- m
+    return (L pos e)
+  )
 
 -- the tick application inherits the source position of its
 -- expression argument to support nested box allocations
 allocATickBox :: BoxLabel -> Bool -> Bool -> SrcSpan -> FreeVars
               -> TM (Maybe (Tickish Id))
-allocATickBox boxLabel countEntries topOnly  pos fvs | isGoodSrcSpan' pos =
-  sameFileName pos (return Nothing) $ do
+allocATickBox boxLabel countEntries topOnly  pos fvs =
+  ifGoodTickSrcSpan pos (do
     let
       mydecl_path = case boxLabel of
                       TopLevelBox x -> x
@@ -1031,8 +1057,7 @@ allocATickBox boxLabel countEntries topOnly  pos fvs | isGoodSrcSpan' pos =
                       _ -> panic "allocATickBox"
     tickish <- mkTickish boxLabel countEntries topOnly pos fvs mydecl_path
     return (Just tickish)
-allocATickBox _boxLabel _countEntries _topOnly _pos _fvs =
-  return Nothing
+  ) (return Nothing)
 
 
 mkTickish :: BoxLabel -> Bool -> Bool -> SrcSpan -> OccEnv Id -> [String]
@@ -1059,10 +1084,10 @@ mkTickish boxLabel countEntries topOnly pos fvs decl_path =
 
         count = countEntries && dopt Opt_ProfCountEntries dflags
 
-        tickish
-          | opt_Hpc                        = HpcTick (this_mod env) c
-          | dopt Opt_SccProfilingOn dflags = ProfNote cc count True{-scopes-}
-          | otherwise                      = Breakpoint c ids
+        tickish = case tickishType env of
+          HpcTicks    -> HpcTick (this_mod env) c
+          ProfNotes   -> ProfNote cc count True{-scopes-}
+          Breakpoints -> Breakpoint c ids
     in
     ( tickish
     , fvs
@@ -1072,11 +1097,18 @@ mkTickish boxLabel countEntries topOnly pos fvs decl_path =
 
 allocBinTickBox :: (Bool -> BoxLabel) -> SrcSpan -> TM (HsExpr Id)
                 -> TM (LHsExpr Id)
-allocBinTickBox boxLabel pos m
- | not opt_Hpc = allocTickBox (ExpBox False) False False pos m
- | isGoodSrcSpan' pos =
- do
- e <- m
+allocBinTickBox boxLabel pos m = do
+  env <- getEnv
+  case tickishType env of
+    HpcTicks -> do e <- liftM (L pos) m
+                   ifGoodTickSrcSpan pos
+                     (mkBinTickBoxHpc boxLabel pos e)
+                     (return e)
+    _other   -> allocTickBox (ExpBox False) False False pos m
+
+mkBinTickBoxHpc :: (Bool -> BoxLabel) -> SrcSpan -> LHsExpr Id
+                -> TM (LHsExpr Id)
+mkBinTickBoxHpc boxLabel pos e =
  TM $ \ env st ->
   let meT = (pos,declPath env, [],boxLabel True)
       meF = (pos,declPath env, [],boxLabel False)
@@ -1084,18 +1116,13 @@ allocBinTickBox boxLabel pos m
       c = tickBoxCount st
       mes = mixEntries st
   in
-             ( L pos $ HsTick (HpcTick (this_mod env) c) $ L pos $ HsBinTick (c+1) (c+2) (L pos e)
+             ( L pos $ HsTick (HpcTick (this_mod env) c) $ L pos $ HsBinTick (c+1) (c+2) e
            -- notice that F and T are reversed,
            -- because we are building the list in
            -- reverse...
              , noFVs
              , st {tickBoxCount=c+3 , mixEntries=meF:meT:meE:mes}
              )
-allocBinTickBox _boxLabel pos m = do e <- m; return (L pos e)
-
-isGoodSrcSpan' :: SrcSpan -> Bool
-isGoodSrcSpan' pos@(RealSrcSpan _) = srcSpanStart pos /= srcSpanEnd pos
-isGoodSrcSpan' (UnhelpfulSpan _) = False
 
 mkHpcPos :: SrcSpan -> HpcPos
 mkHpcPos pos@(RealSrcSpan s)
diff --git a/compiler/nativeGen/X86/Regs.hs b/compiler/nativeGen/X86/Regs.hs
index 44052582b6..9e36b087d7 100644
--- a/compiler/nativeGen/X86/Regs.hs
+++ b/compiler/nativeGen/X86/Regs.hs
@@ -51,6 +51,17 @@ where
 #include "nativeGen/NCG.h"
 #include "HsVersions.h"
 
+#if i386_TARGET_ARCH == 0 && x86_64_TARGET_ARCH == 0
+-- Compiling for some arch other than Intel so we choose x86-64 as default.
+#undef arm_TARGET_ARCH
+#undef powerpc_TARGET_ARCH
+#undef powerpc64_TARGET_ARCH
+#undef sparc_TARGET_ARCH
+
+#undef x86_64_TARGET_ARCH
+#define x86_64_TARGET_ARCH 1
+#endif
+
 #include "../includes/stg/HaskellMachRegs.h"
 
 import Reg
@@ -411,8 +422,6 @@ allIntArgRegs           :: [Reg]
 allFPArgRegs            :: [Reg]
 callClobberedRegs       :: [Reg]
 
-#if defined(i386_TARGET_ARCH) || defined(x86_64_TARGET_ARCH)
-
 #if i386_TARGET_ARCH
 #define eax 0
 #define ebx 1
@@ -588,25 +597,23 @@ globalRegMaybe _                        = Nothing
 
 --
 
-#if defined(mingw32_HOST_OS) && x86_64_TARGET_ARCH
+#if defined(mingw32_HOST_OS)
 
 allArgRegs = zip (map regSingle [rcx,rdx,r8,r9])
                  (map regSingle [firstxmm ..])
 allIntArgRegs = panic "X86.Regs.allIntArgRegs: not defined for this platform"
 allFPArgRegs = panic "X86.Regs.allFPArgRegs: not defined for this platform"
 
-#else
+#elif i386_TARGET_ARCH
 
 allArgRegs = panic "X86.Regs.allArgRegs: not defined for this arch"
-
-# if   i386_TARGET_ARCH
 allIntArgRegs = panic "X86.Regs.allIntArgRegs: should not be used!"
-# elif x86_64_TARGET_ARCH
-allIntArgRegs = map regSingle [rdi,rsi,rdx,rcx,r8,r9]
-# else
-allIntArgRegs = panic "X86.Regs.allIntArgRegs: not defined for this arch"
-# endif
+allFPArgRegs    = map regSingle [firstxmm .. firstxmm+7]
+
+#else
 
+allArgRegs = panic "X86.Regs.allArgRegs: not defined for this arch"
+allIntArgRegs = map regSingle [rdi,rsi,rdx,rcx,r8,r9]
 allFPArgRegs    = map regSingle [firstxmm .. firstxmm+7]
 
 #endif
@@ -621,7 +628,7 @@ allHaskellArgRegs = [ RegReal r | Just r <- map globalRegMaybe globalArgRegs ]
 instrClobberedRegs :: [RealReg]
 #if   i386_TARGET_ARCH
 instrClobberedRegs = map RealRegSingle [ eax, ecx, edx ]
-#elif x86_64_TARGET_ARCH
+#else
 instrClobberedRegs = map RealRegSingle [ rax, rcx, rdx ]
 #endif
 
@@ -632,35 +639,12 @@ instrClobberedRegs = map RealRegSingle [ rax, rcx, rdx ]
 callClobberedRegs
   = map regSingle ([eax,ecx,edx]  ++ floatregnos)
 
-#elif x86_64_TARGET_ARCH
+#else
 -- all xmm regs are caller-saves
 -- caller-saves registers
 callClobberedRegs
   = map regSingle ([rax,rcx,rdx,rsi,rdi,r8,r9,r10,r11] ++ floatregnos)
 
-#else
-callClobberedRegs
-  = panic "X86.Regs.callClobberedRegs: not defined for this architecture"
-#endif
-
-#else /* i386_TARGET_ARCH || x86_64_TARGET_ARCH */
-
-
-
-freeReg _               = 0#
-globalRegMaybe _        = panic "X86.Regs.globalRegMaybe: not defined"
-
-allArgRegs              = panic "X86.Regs.allArgRegs: not defined"
-allIntArgRegs           = panic "X86.Regs.allIntArgRegs: not defined"
-allFPArgRegs            = panic "X86.Regs.allFPArgRegs: not defined"
-callClobberedRegs       = panic "X86.Regs.callClobberedRegs: not defined"
-
-instrClobberedRegs :: [RealReg]
-instrClobberedRegs = panic "X86.Regs.instrClobberedRegs: not defined for this arch"
-
-allHaskellArgRegs :: [Reg]
-allHaskellArgRegs = panic "X86.Regs.allHaskellArgRegs: not defined for this arch"
-
 #endif
 
 -- allocatableRegs is allMachRegNos with the fixed-use regs removed.
diff --git a/rts/Linker.c b/rts/Linker.c
index 6d86e2b1a7..bf0045616e 100644
--- a/rts/Linker.c
+++ b/rts/Linker.c
@@ -6177,8 +6177,13 @@ ocGetNames_MachO(ObjectCode* oc)
 
         if((sections[i].flags & SECTION_TYPE) == S_ZEROFILL)
         {
+#ifdef USE_MMAP
+            char * zeroFillArea = mmapForLinker(sections[i].size, MAP_ANONYMOUS, -1);
+            memset(zeroFillArea, 0, sections[i].size);
+#else
             char * zeroFillArea = stgCallocBytes(1,sections[i].size,
                                       "ocGetNames_MachO(common symbols)");
+#endif
             sections[i].offset = zeroFillArea - image;
         }