Commit 07295e96 authored by ian@well-typed.com's avatar ian@well-typed.com
Browse files

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

parents 6d3fb1b1 e590ad77
......@@ -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)
......
......@@ -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.
......
......@@ -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;
}
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment