Commit b01edb03 authored by Simon Peyton Jones's avatar Simon Peyton Jones

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

parents b243d30b 0b3811c0
......@@ -183,6 +183,20 @@ cmmMachOpFoldM dflags mop1@(MO_Add{}) [CmmMachOp mop2@(MO_Sub{}) [arg1,arg2], ar
| not (isLit arg1) && not (isPicReg arg1)
= Just (cmmMachOpFold dflags mop1 [arg1, cmmMachOpFold dflags mop2 [arg3,arg2]])
-- special case: (PicBaseReg + lit) + N ==> PicBaseReg + (lit+N)
--
-- this is better because lit+N is a single link-time constant (e.g. a
-- CmmLabelOff), so the right-hand expression needs only one
-- instruction, whereas the left needs two. This happens when pointer
-- tagging gives us label+offset, and PIC turns the label into
-- PicBaseReg + label.
--
cmmMachOpFoldM _ MO_Add{} [ CmmMachOp op@MO_Add{} [pic, CmmLit lit]
, CmmLit (CmmInt n rep) ]
| isPicReg pic
= Just $ CmmMachOp op [pic, CmmLit $ cmmOffsetLit lit off ]
where off = fromIntegral (narrowS rep n)
-- Make a RegOff if we can
cmmMachOpFoldM _ (MO_Add _) [CmmReg reg, CmmLit (CmmInt n rep)]
= Just $ cmmRegOff reg (fromIntegral (narrowS rep n))
......
......@@ -25,6 +25,7 @@ import ErrUtils
import HscTypes
import Control.Monad
import Outputable
import Platform
-----------------------------------------------------------------------------
-- | Top level driver for C-- pipeline
......@@ -156,6 +157,7 @@ cpsTop hsc_env proc =
return (cafEnv, [g])
where dflags = hsc_dflags hsc_env
platform = targetPlatform dflags
dump = dumpGraph dflags
dump' = dumpWith dflags
......@@ -177,6 +179,40 @@ cpsTop hsc_env proc =
-- the entry point.
splitting_proc_points = hscTarget dflags /= HscAsm
|| not (tablesNextToCode dflags)
|| usingDarwinX86Pic -- Note [darwin-x86-pic]
usingDarwinX86Pic = platformArch platform == ArchX86
&& platformOS platform == OSDarwin
&& gopt Opt_PIC dflags
{- Note [darwin-x86-pic]
On x86/Darwin, PIC is implemented by inserting a sequence like
call 1f
1: popl %reg
at the proc entry point, and then referring to labels as offsets from
%reg. If we don't split proc points, then we could have many entry
points in a proc that would need this sequence, and each entry point
would then get a different value for %reg. If there are any join
points, then at the join point we don't have a consistent value for
%reg, so we don't know how to refer to labels.
Hence, on x86/Darwin, we have to split proc points, and then each proc
point will get its own PIC initialisation sequence.
This isn't an issue on x86/ELF, where the sequence is
call 1f
1: popl %reg
addl $_GLOBAL_OFFSET_TABLE_+(.-1b), %reg
so %reg always has a consistent value: the address of
_GLOBAL_OFFSET_TABLE_, regardless of which entry point we arrived via.
-}
runUniqSM :: UniqSM a -> IO a
runUniqSM m = do
......
......@@ -234,9 +234,10 @@ splitAtProcPoints dflags entry_label callPPs procPoints procMap
-- the proc point is a callPP)
-- Due to common blockification, we may overestimate the set of procpoints.
let add_label map pp = mapInsert pp lbls map
where lbls | pp == entry = (entry_label, Just (toInfoLbl entry_label))
| otherwise = (blockLbl pp, guard (setMember pp callPPs) >>
Just (infoTblLbl pp))
where lbls | pp == entry = (entry_label, fmap cit_lbl (mapLookup entry info_tbls))
| otherwise = (block_lbl, guard (setMember pp callPPs) >>
Just (toInfoLbl block_lbl))
where block_lbl = blockLbl pp
procLabels :: LabelMap (CLabel, Maybe CLabel)
procLabels = foldl add_label mapEmpty
......@@ -288,23 +289,25 @@ splitAtProcPoints dflags entry_label callPPs procPoints procMap
graphEnv <- foldM add_jumps emptyBlockMap $ mapToList graphEnv
let to_proc (bid, g) = case expectJust "pp label" $ mapLookup bid procLabels of
(lbl, Just info_lbl)
| bid == entry
-> CmmProc (TopInfo {info_tbls = info_tbls,
stack_info = stack_info})
top_l (replacePPIds g)
| otherwise
-> CmmProc (TopInfo {info_tbls = mapSingleton (g_entry g) (mkEmptyContInfoTable info_lbl), stack_info=stack_info})
lbl (replacePPIds g)
(lbl, Nothing)
-> CmmProc (TopInfo {info_tbls = mapEmpty, stack_info=stack_info})
lbl (replacePPIds g)
where
stack_info = StackInfo { arg_space = 0
, updfr_space = Nothing
, do_layout = True }
-- cannot use panic, this is printed by -ddump-cmmz
let to_proc (bid, g)
| bid == entry
= CmmProc (TopInfo {info_tbls = info_tbls,
stack_info = stack_info})
top_l (replacePPIds g)
| otherwise
= case expectJust "pp label" $ mapLookup bid procLabels of
(lbl, Just info_lbl)
-> CmmProc (TopInfo { info_tbls = mapSingleton (g_entry g) (mkEmptyContInfoTable info_lbl)
, stack_info=stack_info})
lbl (replacePPIds g)
(lbl, Nothing)
-> CmmProc (TopInfo {info_tbls = mapEmpty, stack_info=stack_info})
lbl (replacePPIds g)
where
stack_info = StackInfo { arg_space = 0
, updfr_space = Nothing
, do_layout = True }
-- cannot use panic, this is printed by -ddump-cmmz
-- References to procpoint IDs can now be replaced with the
-- infotable's label
......
......@@ -178,7 +178,7 @@ cmmSink dflags graph = ofBlockList (g_entry graph) $ sink mapEmpty $ blocks
drop_if a@(r,rhs,_) live_sets = (should_drop, live_sets')
where
should_drop = conflicts dflags a final_last
|| {- not (isSmall rhs) && -} live_in_multi live_sets r
|| not (isTrivial rhs) && live_in_multi live_sets r
|| r `Set.member` live_in_joins
live_sets' | should_drop = live_sets
......@@ -205,12 +205,12 @@ isSmall (CmmLit _) = True
isSmall (CmmMachOp (MO_Add _) [x,y]) = isTrivial x && isTrivial y
isSmall (CmmRegOff (CmmLocal _) _) = True
isSmall _ = False
-}
isTrivial :: CmmExpr -> Bool
isTrivial (CmmReg (CmmLocal _)) = True
isTrivial (CmmLit _) = True
-- isTrivial (CmmLit _) = True
isTrivial _ = False
-}
--
-- annotate each node with the set of registers live *after* the node
......@@ -365,9 +365,8 @@ tryToInline dflags live node assigs = go usages node [] assigs
go _usages node _skipped [] = (node, [])
go usages node skipped (a@(l,rhs,_) : rest)
| can_inline = inline_and_discard
| False {- isTiny rhs -} = inline_and_keep
-- ^^ seems to make things slightly worse
| can_inline = inline_and_discard
| isTrivial rhs = inline_and_keep
where
inline_and_discard = go usages' node' skipped rest
......@@ -464,8 +463,8 @@ conflicts dflags (r, rhs, addr) node
-- foreign call. See Note [foreign calls clobber GlobalRegs].
| CmmUnsafeForeignCall{} <- node, anyCallerSavesRegs dflags rhs = True
-- (5) foreign calls clobber memory, but not heap/stack memory
| CmmUnsafeForeignCall{} <- node, AnyMem <- addr = True
-- (5) foreign calls clobber heap: see Note [foreign calls clobber heap]
| CmmUnsafeForeignCall{} <- node, memConflicts addr AnyMem = True
-- (6) native calls clobber any memory
| CmmCall{} <- node, memConflicts addr AnyMem = True
......@@ -523,6 +522,21 @@ data AbsMem
-- that was written in the same basic block. To take advantage of
-- non-aliasing of heap memory we will have to be more clever.
-- Note [foreign calls clobber]
--
-- It is tempting to say that foreign calls clobber only
-- non-heap/stack memory, but unfortunately we break this invariant in
-- the RTS. For example, in stg_catch_retry_frame we call
-- stmCommitNestedTransaction() which modifies the contents of the
-- TRec it is passed (this actually caused incorrect code to be
-- generated).
--
-- Since the invariant is true for the majority of foreign calls,
-- perhaps we ought to have a special annotation for calls that can
-- modify heap/stack memory. For now we just use the conservative
-- definition here.
bothMems :: AbsMem -> AbsMem -> AbsMem
bothMems NoMem x = x
bothMems x NoMem = x
......
......@@ -222,6 +222,8 @@ cmmRegOff reg byte_off = CmmRegOff reg byte_off
cmmOffsetLit :: CmmLit -> Int -> CmmLit
cmmOffsetLit (CmmLabel l) byte_off = cmmLabelOff l byte_off
cmmOffsetLit (CmmLabelOff l m) byte_off = cmmLabelOff l (m+byte_off)
cmmOffsetLit (CmmLabelDiffOff l1 l2 m) byte_off
= CmmLabelDiffOff l1 l2 (m+byte_off)
cmmOffsetLit (CmmInt m rep) byte_off = CmmInt (m + fromIntegral byte_off) rep
cmmOffsetLit _ byte_off = pprPanic "cmmOffsetLit" (ppr byte_off)
......
%
% (c) The University of Glasgow 2005-2006
% (c) The University of Glasgow 2005-2012
%
\begin{code}
-- | The dynamic linker for GHCi.
......@@ -1239,7 +1239,7 @@ searchForLibUsingGcc dflags so dirs = do
else return (Just file)
-- ----------------------------------------------------------------------------
-- Loading a dyanmic library (dlopen()-ish on Unix, LoadLibrary-ish on Win32)
-- Loading a dynamic library (dlopen()-ish on Unix, LoadLibrary-ish on Win32)
-- Darwin / MacOS X only: load a framework
-- a framework is a dynamic library packaged inside a directory of the same
......
......@@ -1024,7 +1024,10 @@ wayGeneralFlags platform WayDyn =
-- different from the current one.
OSMinGW32 -> [Opt_PIC]
OSDarwin -> [Opt_PIC]
OSLinux -> [Opt_PIC]
OSLinux -> [Opt_PIC] -- This needs to be here for GHCi to work:
-- GHCi links objects into a .so before
-- loading the .so using the system linker.
-- Only PIC objects can be linked into a .so.
_ -> []
wayGeneralFlags _ WayProf = [Opt_SccProfilingOn]
wayGeneralFlags _ WayEventLog = []
......@@ -2550,12 +2553,7 @@ defaultFlags settings
++ [f | (ns,f) <- optLevelFlags, 0 `elem` ns]
-- The default -O0 options
++ (case platformOS platform of
OSDarwin ->
case platformArch platform of
ArchX86_64 -> [Opt_PIC]
_ -> []
_ -> [])
++ default_PIC platform
++ (if pc_dYNAMIC_BY_DEFAULT (sPlatformConstants settings)
then wayGeneralFlags platform WayDyn
......@@ -2563,6 +2561,12 @@ defaultFlags settings
where platform = sTargetPlatform settings
default_PIC :: Platform -> [GeneralFlag]
default_PIC platform =
case (platformOS platform, platformArch platform) of
(OSDarwin, ArchX86_64) -> [Opt_PIC]
_ -> []
impliedFlags :: [(ExtensionFlag, TurnOnFlag, ExtensionFlag)]
impliedFlags
= [ (Opt_RankNTypes, turnOn, Opt_ExplicitForAll)
......@@ -2831,7 +2835,14 @@ addWay w = do upd (\dfs -> dfs { ways = w : ways dfs })
mapM_ setGeneralFlag $ wayGeneralFlags platform w
removeWay :: Way -> DynP ()
removeWay w = upd (\dfs -> dfs { ways = filter (w /=) (ways dfs) })
removeWay w = do
upd (\dfs -> dfs { ways = filter (w /=) (ways dfs) })
dfs <- liftEwM getCmdLineState
let platform = targetPlatform dfs
-- XXX: wayExtras?
mapM_ unSetGeneralFlag $ wayGeneralFlags platform w
-- turn Opt_PIC back on if necessary for this platform:
mapM_ setGeneralFlag $ default_PIC platform
--------------------------
setGeneralFlag, unSetGeneralFlag :: GeneralFlag -> DynP ()
......
......@@ -72,7 +72,13 @@ import Control.Monad ( mplus )
{-
-----------------------------------------------------------------------------
24 Februar 2006
12 October 2012
Conflicts: 43 shift/reduce
1 reduce/reduce
-----------------------------------------------------------------------------
24 February 2006
Conflicts: 33 shift/reduce
1 reduce/reduce
......
......@@ -270,6 +270,10 @@ basicKnownKeyNames
andIntegerName, orIntegerName, xorIntegerName, complementIntegerName,
shiftLIntegerName, shiftRIntegerName,
-- Float/Double
rationalToFloatName,
rationalToDoubleName,
-- MonadFix
monadFixClassName, mfixName,
......@@ -932,6 +936,11 @@ floatingClassName, realFloatClassName :: Name
floatingClassName = clsQual gHC_FLOAT (fsLit "Floating") floatingClassKey
realFloatClassName = clsQual gHC_FLOAT (fsLit "RealFloat") realFloatClassKey
-- other GHC.Float functions
rationalToFloatName, rationalToDoubleName :: Name
rationalToFloatName = varQual gHC_FLOAT (fsLit "rationalToFloat") rationalToFloatIdKey
rationalToDoubleName = varQual gHC_FLOAT (fsLit "rationalToDouble") rationalToDoubleIdKey
-- Class Ix
ixClassName :: Name
ixClassName = clsQual gHC_ARR (fsLit "Ix") ixClassKey
......@@ -1614,6 +1623,10 @@ dollarIdKey = mkPreludeMiscIdUnique 123
coercionTokenIdKey :: Unique
coercionTokenIdKey = mkPreludeMiscIdUnique 124
rationalToFloatIdKey, rationalToDoubleIdKey :: Unique
rationalToFloatIdKey = mkPreludeMiscIdUnique 130
rationalToDoubleIdKey = mkPreludeMiscIdUnique 131
-- dotnet interop
unmarshalObjectIdKey, marshalObjectIdKey, marshalStringIdKey,
unmarshalStringIdKey, checkDotnetResNameIdKey :: Unique
......
......@@ -50,6 +50,7 @@ import Util
import Control.Monad
import Data.Bits as Bits
import Data.Int
import Data.Ratio
import Data.Word
\end{code}
......@@ -840,6 +841,8 @@ builtinIntegerRules =
rule_encodeFloat "encodeDoubleInteger" encodeDoubleIntegerName mkDoubleLitDouble,
rule_decodeDouble "decodeDoubleInteger" decodeDoubleIntegerName,
rule_convert "doubleFromInteger" doubleFromIntegerName (\_ -> mkDoubleLitDouble),
rule_rationalTo "rationalToFloat" rationalToFloatName mkFloatExpr,
rule_rationalTo "rationalToDouble" rationalToDoubleName mkDoubleExpr,
rule_binop "gcdInteger" gcdIntegerName gcd,
rule_binop "lcmInteger" lcmIntegerName lcm,
rule_binop "andInteger" andIntegerName (.&.),
......@@ -907,6 +910,9 @@ builtinIntegerRules =
rule_smallIntegerTo str name primOp
= BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
ru_try = match_smallIntegerTo primOp }
rule_rationalTo str name mkLit
= BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
ru_try = match_rationalTo mkLit }
---------------------------------------------------
-- The rule is this:
......@@ -1151,6 +1157,30 @@ match_Integer_Int_encodeFloat mkLit _ _ id_unf [xl,yl]
= Just (mkLit $ encodeFloat x (fromInteger y))
match_Integer_Int_encodeFloat _ _ _ _ _ = Nothing
---------------------------------------------------
-- constant folding for Float/Double
--
-- This turns
-- rationalToFloat n d
-- into a literal Float, and similarly for Doubles.
--
-- it's important to not match d == 0, because that may represent a
-- literal "0/0" or similar, and we can't produce a literal value for
-- NaN or +-Inf
match_rationalTo :: RealFloat a
=> (a -> Expr CoreBndr)
-> DynFlags
-> Id
-> IdUnfoldingFun
-> [Expr CoreBndr]
-> Maybe (Expr CoreBndr)
match_rationalTo mkLit _ _ id_unf [xl, yl]
| Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl
, Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
, y /= 0
= Just (mkLit (fromRational (x % y)))
match_rationalTo _ _ _ _ _ = Nothing
match_decodeDouble :: DynFlags
-> Id
-> IdUnfoldingFun
......
......@@ -381,6 +381,9 @@
TICK_ALLOC_PRIM(SIZEOF_StgHeader,bytes-SIZEOF_StgHeader,0); \
CCCS_ALLOC(bytes);
#define ALLOC_PRIM_(bytes,fun) \
ALLOC_PRIM_WITH_CUSTOM_FAILURE(bytes,GC_PRIM(fun));
#define ALLOC_PRIM_P(bytes,fun,arg) \
ALLOC_PRIM_WITH_CUSTOM_FAILURE(bytes,GC_PRIM_P(fun,arg));
......
......@@ -213,7 +213,7 @@ RTS_THUNK(stg_ap_5_upd);
RTS_THUNK(stg_ap_6_upd);
RTS_THUNK(stg_ap_7_upd);
/* standard application routines (see also rts/gen_apply.py,
/* standard application routines (see also utils/genapply,
* and compiler/codeGen/CgStackery.lhs).
*/
RTS_RET(stg_ap_v);
......@@ -470,10 +470,10 @@ extern StgWord RTS_VAR(stable_ptr_table);
// Profiling.c
extern unsigned int RTS_VAR(era);
extern unsigned int RTS_VAR(entering_PAP);
extern StgWord RTS_VAR(CC_LIST); /* registered CC list */
extern StgWord RTS_VAR(CC_LIST); /* registered CC list */
extern StgWord RTS_VAR(CCS_LIST); /* registered CCS list */
extern StgWord CCS_SYSTEM[];
extern unsigned int RTS_VAR(CC_ID); /* global ids */
extern unsigned int RTS_VAR(CC_ID); /* global ids */
extern unsigned int RTS_VAR(CCS_ID);
#endif
......
......@@ -252,7 +252,7 @@ stg_newMutVarzh ( gcptr init )
{
W_ mv;
ALLOC_PRIM (SIZEOF_StgMutVar);
ALLOC_PRIM_P (SIZEOF_StgMutVar, stg_newMutVarzh, init);
mv = Hp - SIZEOF_StgMutVar + WDS(1);
SET_HDR(mv,stg_MUT_VAR_DIRTY_info,CCCS);
......@@ -1154,7 +1154,7 @@ stg_newMVarzh ()
{
W_ mvar;
ALLOC_PRIM (SIZEOF_StgMVar);
ALLOC_PRIM_ (SIZEOF_StgMVar, stg_newMVarzh);
mvar = Hp - SIZEOF_StgMVar + WDS(1);
SET_HDR(mvar,stg_MVAR_DIRTY_info,CCCS);
......@@ -1365,7 +1365,7 @@ stg_putMVarzh ( P_ mvar, /* :: MVar a */
ALLOC_PRIM_WITH_CUSTOM_FAILURE
(SIZEOF_StgMVarTSOQueue,
unlockClosure(mvar, stg_MVAR_DIRTY_info);
GC_PRIM_P(stg_putMVarzh, mvar));
GC_PRIM_PP(stg_putMVarzh, mvar, val));
q = Hp - SIZEOF_StgMVarTSOQueue + WDS(1);
......
......@@ -1078,8 +1078,10 @@ fprintCCS_stderr (CostCentreStack *ccs, StgClosure *exception, StgTSO *tso)
case CONSTR_STATIC:
case CONSTR_NOCAF_STATIC:
desc = GET_CON_DESC(itbl_to_con_itbl(info));
default:
break;
default:
desc = closure_type_names[info->type];
break;
}
fprintf(stderr, "*** Exception (reporting due to +RTS -xc): (%s), stack trace: \n ", desc);
}
......
......@@ -459,11 +459,11 @@ run_thread:
// conserve power (see #1623). Re-enable it here.
nat prev;
prev = xchg((P_)&recent_activity, ACTIVITY_YES);
#ifndef PROFILING
if (prev == ACTIVITY_DONE_GC) {
#ifndef PROFILING
startTimer();
}
#endif
}
break;
}
case ACTIVITY_INACTIVE:
......@@ -2777,7 +2777,7 @@ findRetryFrameHelper (Capability *cap, StgTSO *tso)
case CATCH_RETRY_FRAME:
debugTrace(DEBUG_stm,
"found CATCH_RETRY_FRAME at %p during retrry", p);
"found CATCH_RETRY_FRAME at %p during retry", p);
tso->stackobj->sp = p;
return CATCH_RETRY_FRAME;
......
......@@ -60,6 +60,8 @@ else ifneq "$$($1_$2_INSTALL_INPLACE)" "YES"
$1_$2_WANT_INPLACE_WRAPPER = NO
else ifeq "$$($1_$2_SHELL_WRAPPER)" "YES"
$1_$2_WANT_INPLACE_WRAPPER = YES
else ifeq "$$(DYNAMIC_BY_DEFAULT)" "YES"
$1_$2_WANT_INPLACE_WRAPPER = YES
else
$1_$2_WANT_INPLACE_WRAPPER = NO
endif
......
# -----------------------------------------------------------------------------
#
# (c) 2009 The University of Glasgow
# (c) 2009-2012 The University of Glasgow
#
# This file is part of the GHC build system.
#
......@@ -46,9 +46,9 @@ $$(INPLACE_WRAPPER): $$($1_$2_INPLACE)
$$($1_$2_INPLACE_SHELL_WRAPPER_EXTRA)
ifeq "$$(DYNAMIC_BY_DEFAULT)" "YES"
ifeq "$$(TargetOS_CPP)" "linux"
echo 'export LD_LIBRARY_PATH="$$($1_$2_DEP_LIB_DIRS_SEARCHPATH)"' >> $$@
echo 'export LD_LIBRARY_PATH="$$($1_$2_DEP_LIB_DIRS_SEARCHPATH):$$$$LD_LIBRARY_PATH"' >> $$@
else ifeq "$$(TargetOS_CPP)" "darwin"
echo 'export DYLD_LIBRARY_PATH="$$($1_$2_DEP_LIB_DIRS_SEARCHPATH)"' >> $$@
echo 'export DYLD_LIBRARY_PATH="$$($1_$2_DEP_LIB_DIRS_SEARCHPATH):$$$$DYLD_LIBRARY_PATH"' >> $$@
endif
endif
ifeq "$$($1_$2_SHELL_WRAPPER)" "YES"
......
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