Commit 7e2e23b8 authored by Simon Peyton Jones's avatar Simon Peyton Jones

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

parents 525aca2c 73523d2f
This diff is collapsed.
......@@ -461,6 +461,12 @@ convFloating l = l
trueVal, falseVal :: Expr CoreBndr
trueVal = Var trueDataConId
falseVal = Var falseDataConId
ltVal, eqVal, gtVal :: Expr CoreBndr
ltVal = Var ltDataConId
eqVal = Var eqDataConId
gtVal = Var gtDataConId
mkIntVal :: Integer -> Expr CoreBndr
mkIntVal i = Lit (mkMachInt i)
mkWordVal :: Integer -> Expr CoreBndr
......@@ -604,8 +610,56 @@ builtinRules
BuiltinRule { ru_name = fsLit "EqString", ru_fn = eqStringName,
ru_nargs = 2, ru_try = match_eq_string },
BuiltinRule { ru_name = fsLit "Inline", ru_fn = inlineIdName,
ru_nargs = 2, ru_try = match_inline }
ru_nargs = 2, ru_try = match_inline },
-- TODO: All the below rules need to handle target platform
-- having a different wordsize than the host platform
rule_Integer_convert "integerToWord" integerToWordName mkWordLitWord,
rule_Integer_convert "integerToInt" integerToIntName mkIntLitInt,
rule_Integer_binop "plusInteger" plusIntegerName (+),
rule_Integer_binop "timesInteger" timesIntegerName (*),
rule_Integer_binop "minusInteger" minusIntegerName (-),
rule_Integer_unop "negateInteger" negateIntegerName negate,
rule_Integer_binop_Bool "eqInteger" eqIntegerName (==),
rule_Integer_binop_Bool "neqInteger" neqIntegerName (/=),
rule_Integer_unop "absInteger" absIntegerName abs,
rule_Integer_unop "signumInteger" signumIntegerName signum,
rule_Integer_binop_Bool "leInteger" leIntegerName (<=),
rule_Integer_binop_Bool "gtInteger" gtIntegerName (>),
rule_Integer_binop_Bool "ltInteger" ltIntegerName (<),
rule_Integer_binop_Bool "geInteger" geIntegerName (>=),
rule_Integer_binop_Ordering "compareInteger" compareIntegerName compare,
-- TODO: divMod/quoteRem/quot/rem rules. Due to the 0 check we
-- need rules for the generic functions, rather than the
-- Integer-specific functions
rule_Integer_binop "gcdInteger" gcdIntegerName gcd,
rule_Integer_binop "lcmInteger" lcmIntegerName lcm,
rule_Integer_binop "andInteger" andIntegerName (.&.),
rule_Integer_binop "orInteger" orIntegerName (.|.),
rule_Integer_binop "xorInteger" xorIntegerName xor,
rule_Integer_unop "complementInteger" complementIntegerName complement,
-- TODO: Likewise, these rules currently don't do anything, due to
-- the sign test in shift's definition
rule_Integer_Int_binop "shiftLInteger" shiftLIntegerName shiftL,
rule_Integer_Int_binop "shiftRInteger" shiftRIntegerName shiftR
]
where rule_Integer_convert str name convert
= BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
ru_try = match_Integer_convert convert }
rule_Integer_unop str name op
= BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
ru_try = match_Integer_unop op }
rule_Integer_binop str name op
= BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
ru_try = match_Integer_binop op }
rule_Integer_Int_binop str name op
= BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
ru_try = match_Integer_Int_binop op }
rule_Integer_binop_Bool str name op
= BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
ru_try = match_Integer_binop_Bool op }
rule_Integer_binop_Ordering str name op
= BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
ru_try = match_Integer_binop_Ordering op }
---------------------------------------------------
......@@ -667,4 +721,85 @@ match_inline _ (Type _ : e : _)
= Just (mkApps unf args1)
match_inline _ _ = Nothing
-- Integer rules
match_Integer_convert :: Num a
=> (a -> Expr CoreBndr)
-> IdUnfoldingFun
-> [Expr CoreBndr]
-> Maybe (Expr CoreBndr)
match_Integer_convert convert _ [x]
| (Var fx, [Lit (MachInt ix)]) <- collectArgs x,
idName fx == smallIntegerName
= Just (convert (fromIntegral ix))
match_Integer_convert _ _ _ = Nothing
match_Integer_unop :: (Integer -> Integer)
-> IdUnfoldingFun
-> [Expr CoreBndr]
-> Maybe (Expr CoreBndr)
match_Integer_unop unop _ [x]
| (Var fx, [Lit (MachInt ix)]) <- collectArgs x,
idName fx == smallIntegerName,
let iz = unop ix,
iz >= fromIntegral (minBound :: Int),
iz <= fromIntegral (maxBound :: Int)
= Just (Var fx `App` Lit (MachInt iz))
match_Integer_unop _ _ _ = Nothing
match_Integer_binop :: (Integer -> Integer -> Integer)
-> IdUnfoldingFun
-> [Expr CoreBndr]
-> Maybe (Expr CoreBndr)
match_Integer_binop binop _ [x, y]
| (Var fx, [Lit (MachInt ix)]) <- collectArgs x,
(Var fy, [Lit (MachInt iy)]) <- collectArgs y,
idName fx == smallIntegerName,
idName fy == smallIntegerName,
let iz = ix `binop` iy,
iz >= fromIntegral (minBound :: Int),
iz <= fromIntegral (maxBound :: Int)
= Just (Var fx `App` Lit (MachInt iz))
match_Integer_binop _ _ _ = Nothing
match_Integer_Int_binop :: (Integer -> Int -> Integer)
-> IdUnfoldingFun
-> [Expr CoreBndr]
-> Maybe (Expr CoreBndr)
match_Integer_Int_binop binop _ [x, Lit (MachInt iy)]
| (Var fx, [Lit (MachInt ix)]) <- collectArgs x,
idName fx == smallIntegerName,
let iz = ix `binop` fromIntegral iy,
iz >= fromIntegral (minBound :: Int),
iz <= fromIntegral (maxBound :: Int)
= Just (Var fx `App` Lit (MachInt iz))
match_Integer_Int_binop _ _ _ = Nothing
match_Integer_binop_Bool :: (Integer -> Integer -> Bool)
-> IdUnfoldingFun
-> [Expr CoreBndr]
-> Maybe (Expr CoreBndr)
match_Integer_binop_Bool binop _ [x, y]
| (Var fx, [Lit (MachInt ix)]) <- collectArgs x,
(Var fy, [Lit (MachInt iy)]) <- collectArgs y,
idName fx == smallIntegerName,
idName fy == smallIntegerName
= Just (if ix `binop` iy then trueVal else falseVal)
match_Integer_binop_Bool _ _ _ = Nothing
match_Integer_binop_Ordering :: (Integer -> Integer -> Ordering)
-> IdUnfoldingFun
-> [Expr CoreBndr]
-> Maybe (Expr CoreBndr)
match_Integer_binop_Ordering binop _ [x, y]
| (Var fx, [Lit (MachInt ix)]) <- collectArgs x,
(Var fy, [Lit (MachInt iy)]) <- collectArgs y,
idName fx == smallIntegerName,
idName fy == smallIntegerName
= Just $ case ix `binop` iy of
LT -> ltVal
EQ -> eqVal
GT -> gtVal
match_Integer_binop_Ordering _ _ _ = Nothing
\end{code}
......@@ -15,6 +15,11 @@ module TysWiredIn (
trueDataCon, trueDataConId, true_RDR,
falseDataCon, falseDataConId, false_RDR,
-- * Ordering
ltDataCon, ltDataConId,
eqDataCon, eqDataConId,
gtDataCon, gtDataConId,
-- * Char
charTyCon, charDataCon, charTyCon_RDR,
charTy, stringTy, charTyConName,
......@@ -424,6 +429,20 @@ trueDataCon = pcDataCon trueDataConName [] [] boolTyCon
falseDataConId, trueDataConId :: Id
falseDataConId = dataConWorkId falseDataCon
trueDataConId = dataConWorkId trueDataCon
orderingTyCon :: TyCon
orderingTyCon = pcTyCon True NonRecursive orderingTyConName
[] [ltDataCon, eqDataCon, gtDataCon]
ltDataCon, eqDataCon, gtDataCon :: DataCon
ltDataCon = pcDataCon ltDataConName [] [] orderingTyCon
eqDataCon = pcDataCon eqDataConName [] [] orderingTyCon
gtDataCon = pcDataCon gtDataConName [] [] orderingTyCon
ltDataConId, eqDataConId, gtDataConId :: Id
ltDataConId = dataConWorkId ltDataCon
eqDataConId = dataConWorkId eqDataCon
gtDataConId = dataConWorkId gtDataCon
\end{code}
%************************************************************************
......
......@@ -1071,14 +1071,14 @@ heapCensusChain( Census *census, bdescr *bd )
}
void
heapCensus( void )
heapCensus( Ticks t )
{
nat g, n;
Census *census;
gen_workspace *ws;
census = &censuses[era];
census->time = mut_user_time();
census->time = mut_user_time_until(t);
// calculate retainer sets if necessary
#ifdef PROFILING
......
......@@ -9,9 +9,11 @@
#ifndef PROFHEAP_H
#define PROFHEAP_H
#include "GetTime.h" // for Ticks
#include "BeginPrivate.h"
void heapCensus (void);
void heapCensus (Ticks t);
nat initHeapProfiling (void);
void endHeapProfiling (void);
rtsBool strMatchesSelector (char* str, char* sel);
......
......@@ -57,7 +57,7 @@ static Ticks HCe_start_time, HCe_tot_time = 0; // heap census prof elap time
#endif
static lnat max_residency = 0; // in words; for stats only
static lnat avg_residency = 0;
static lnat cumulative_residency = 0;
static lnat residency_samples = 0; // for stats only
static lnat max_slop = 0;
......@@ -83,12 +83,18 @@ Ticks stat_getElapsedTime(void)
Measure the current MUT time, for profiling
------------------------------------------------------------------------ */
double
mut_user_time_until( Ticks t )
{
return TICK_TO_DBL(t - GC_tot_cpu - PROF_VAL(RP_tot_time));
}
double
mut_user_time( void )
{
Ticks cpu;
cpu = getProcessCPUTime();
return TICK_TO_DBL(cpu - GC_tot_cpu - PROF_VAL(RP_tot_time + HC_tot_time));
return mut_user_time_until(cpu);
}
#ifdef PROFILING
......@@ -99,13 +105,13 @@ mut_user_time( void )
double
mut_user_time_during_RP( void )
{
return TICK_TO_DBL(RP_start_time - GC_tot_cpu - RP_tot_time - HC_tot_time);
return TICK_TO_DBL(RP_start_time - GC_tot_cpu - RP_tot_time);
}
double
mut_user_time_during_heap_census( void )
{
return TICK_TO_DBL(HC_start_time - GC_tot_cpu - RP_tot_time - HC_tot_time);
return TICK_TO_DBL(HC_start_time - GC_tot_cpu - RP_tot_time);
}
#endif /* PROFILING */
......@@ -145,7 +151,7 @@ initStats0(void)
#endif
max_residency = 0;
avg_residency = 0;
cumulative_residency = 0;
residency_samples = 0;
max_slop = 0;
......@@ -362,7 +368,7 @@ stat_endGC (gc_thread *gct,
max_residency = live;
}
residency_samples++;
avg_residency += live;
cumulative_residency += live;
}
if (slop > max_slop) max_slop = slop;
......@@ -739,7 +745,7 @@ stat_exit(int alloc)
statsPrintf(fmt2,
total_collections,
residency_samples == 0 ? 0 :
avg_residency*sizeof(W_)/residency_samples,
cumulative_residency*sizeof(W_)/residency_samples,
max_residency*sizeof(W_),
residency_samples,
(unsigned long)(peak_mblocks_allocated * MBLOCK_SIZE / (1024L * 1024L)),
......
......@@ -49,7 +49,7 @@ void stat_workerStop(void);
void initStats0(void);
void initStats1(void);
double mut_user_time_during_GC(void);
double mut_user_time_until(Ticks t);
double mut_user_time(void);
#ifdef PROFILING
......
......@@ -669,7 +669,7 @@ GarbageCollect (rtsBool force_major_gc,
if (do_heap_census) {
debugTrace(DEBUG_sched, "performing heap census");
RELEASE_SM_LOCK;
heapCensus();
heapCensus(gct->gc_start_cpu);
ACQUIRE_SM_LOCK;
}
......
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