From: Simon Peyton Jones Date: Wed, 11 May 2011 16:28:26 +0000 (+0100) Subject: Merge remote branch 'origin/master' X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=cd54b707b0d77a3c62ee9f57b82dae98727f1c34;hp=cbebca1c9164a5e5ae9b117d0dcf5ad217defc6d Merge remote branch 'origin/master' --- diff --git a/compiler/cmm/CmmNode.hs b/compiler/cmm/CmmNode.hs index e67321c..ee948fe 100644 --- a/compiler/cmm/CmmNode.hs +++ b/compiler/cmm/CmmNode.hs @@ -30,31 +30,51 @@ import Prelude hiding (succ) data CmmNode e x where CmmEntry :: Label -> CmmNode C O + CmmComment :: FastString -> CmmNode O O + CmmAssign :: CmmReg -> CmmExpr -> CmmNode O O -- Assign to register + CmmStore :: CmmExpr -> CmmExpr -> CmmNode O O -- Assign to memory location. Size is -- given by cmmExprType of the rhs. + CmmUnsafeForeignCall :: -- An unsafe foreign call; see Note [Foreign calls] + -- Like a "fat machine instruction"; can occur + -- in the middle of a block ForeignTarget -> -- call target CmmFormals -> -- zero or more results CmmActuals -> -- zero or more arguments CmmNode O O + -- Semantics: kills only result regs; all other regs (both GlobalReg + -- and LocalReg) are preserved + CmmBranch :: Label -> CmmNode O C -- Goto another block in the same procedure + CmmCondBranch :: { -- conditional branch cml_pred :: CmmExpr, cml_true, cml_false :: Label } -> CmmNode O C + CmmSwitch :: CmmExpr -> [Maybe Label] -> CmmNode O C -- Table branch -- The scrutinee is zero-based; -- zero -> first block -- one -> second block etc -- Undefined outside range, and when there's a Nothing - CmmCall :: { -- A call (native or safe foreign) + + CmmCall :: { -- A native call or tail call cml_target :: CmmExpr, -- never a CmmPrim to a CallishMachOp! cml_cont :: Maybe Label, -- Label of continuation (Nothing for return or tail call) +-- ToDO: add this: +-- cml_args_regs :: [GlobalReg], +-- It says which GlobalRegs are live for the parameters at the +-- moment of the call. Later stages can use this to give liveness +-- everywhere, which in turn guides register allocation. +-- It is the companion of cml_args; cml_args says which stack words +-- hold parameters, while cml_arg_regs says which global regs hold parameters + cml_args :: ByteOff, -- Byte offset, from the *old* end of the Area associated with -- the Label (if cml_cont = Nothing, then Old area), of @@ -78,7 +98,9 @@ data CmmNode e x where -- cml_ret_off are treated as live, even if the sequel of -- the call goes into a loop. } -> CmmNode O C + CmmForeignCall :: { -- A safe foreign call; see Note [Foreign calls] + -- Always the last node of a block tgt :: ForeignTarget, -- call target and convention res :: CmmFormals, -- zero or more results args :: CmmActuals, -- zero or more arguments @@ -89,8 +111,8 @@ data CmmNode e x where {- Note [Foreign calls] ~~~~~~~~~~~~~~~~~~~~~~~ -A MidForeign call is used for *unsafe* foreign calls; -a LastForeign call is used for *safe* foreign calls. +A CmmUnsafeForeignCall is used for *unsafe* foreign calls; +a CmmForeignCall call is used for *safe* foreign calls. Unsafe ones are easy: think of them as a "fat machine instruction". In particular, they do *not* kill all live registers (there was a bit of code in GHC that conservatively assumed otherwise.) diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y index 4dc7e32..0ee429d 100644 --- a/compiler/cmm/CmmParse.y +++ b/compiler/cmm/CmmParse.y @@ -689,15 +689,7 @@ machOps = listToUFM $ ( "gtu", MO_U_Gt ), ( "ltu", MO_U_Lt ), - ( "flt", MO_S_Lt ), - ( "fle", MO_S_Le ), - ( "feq", MO_Eq ), - ( "fne", MO_Ne ), - ( "fgt", MO_S_Gt ), - ( "fge", MO_S_Ge ), - ( "fneg", MO_S_Neg ), - - ( "and", MO_And ), + ( "and", MO_And ), ( "or", MO_Or ), ( "xor", MO_Xor ), ( "com", MO_Not ), @@ -705,7 +697,20 @@ machOps = listToUFM $ ( "shrl", MO_U_Shr ), ( "shra", MO_S_Shr ), - ( "lobits8", flip MO_UU_Conv W8 ), + ( "fadd", MO_F_Add ), + ( "fsub", MO_F_Sub ), + ( "fneg", MO_F_Neg ), + ( "fmul", MO_F_Mul ), + ( "fquot", MO_F_Quot ), + + ( "feq", MO_F_Eq ), + ( "fne", MO_F_Ne ), + ( "fge", MO_F_Ge ), + ( "fle", MO_F_Le ), + ( "fgt", MO_F_Gt ), + ( "flt", MO_F_Lt ), + + ( "lobits8", flip MO_UU_Conv W8 ), ( "lobits16", flip MO_UU_Conv W16 ), ( "lobits32", flip MO_UU_Conv W32 ), ( "lobits64", flip MO_UU_Conv W64 ), diff --git a/compiler/cmm/cmm-notes b/compiler/cmm/cmm-notes index e787f18..c0ccadf 100644 --- a/compiler/cmm/cmm-notes +++ b/compiler/cmm/cmm-notes @@ -1,3 +1,7 @@ +More notes (May 11) +~~~~~~~~~~~~~~~~~~~ +In CmmNode, consider spliting CmmCall into two: call and jump + Notes on new codegen (Aug 10) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs index 8071da7..37cbc2d 100644 --- a/compiler/deSugar/Coverage.lhs +++ b/compiler/deSugar/Coverage.lhs @@ -608,9 +608,12 @@ addTickCmdGRHSs (GRHSs guarded local_binds) = do binders = collectLocalBinders local_binds addTickCmdGRHS :: GRHS Id -> TM (GRHS Id) -addTickCmdGRHS (GRHS stmts cmd) = do - (stmts',expr') <- addTickLCmdStmts' stmts (addTickLHsCmd cmd) - return $ GRHS stmts' expr' +-- The *guards* are *not* Cmds, although the body is +-- C.f. addTickGRHS for the BinBox stuff +addTickCmdGRHS (GRHS stmts cmd) + = do { (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox) + stmts (addTickLHsCmd cmd) + ; return $ GRHS stmts' expr' } addTickLCmdStmts :: [LStmt Id] -> TM [LStmt Id] addTickLCmdStmts stmts = do diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs index 9c88783..dd33cae 100644 --- a/compiler/hsSyn/HsExpr.lhs +++ b/compiler/hsSyn/HsExpr.lhs @@ -1274,10 +1274,12 @@ data HsStmtContext id \begin{code} isListCompExpr :: HsStmtContext id -> Bool -- Uses syntax [ e | quals ] -isListCompExpr ListComp = True -isListCompExpr PArrComp = True -isListCompExpr MonadComp = True -isListCompExpr _ = False +isListCompExpr ListComp = True +isListCompExpr PArrComp = True +isListCompExpr MonadComp = True +isListCompExpr (ParStmtCtxt c) = isListCompExpr c +isListCompExpr (TransStmtCtxt c) = isListCompExpr c +isListCompExpr _ = False isMonadCompExpr :: HsStmtContext id -> Bool isMonadCompExpr MonadComp = True diff --git a/compiler/nativeGen/X86/Ppr.hs b/compiler/nativeGen/X86/Ppr.hs index a9ed036..38b6344 100644 --- a/compiler/nativeGen/X86/Ppr.hs +++ b/compiler/nativeGen/X86/Ppr.hs @@ -642,8 +642,8 @@ pprInstr (FDIV size op1 op2) = pprSizeOpOp (sLit "div") size op1 op2 pprInstr (CVTSS2SD from to) = pprRegReg (sLit "cvtss2sd") from to pprInstr (CVTSD2SS from to) = pprRegReg (sLit "cvtsd2ss") from to -pprInstr (CVTTSS2SIQ sz from to) = pprSizeOpReg (sLit "cvttss2si") sz from to -pprInstr (CVTTSD2SIQ sz from to) = pprSizeOpReg (sLit "cvttsd2si") sz from to +pprInstr (CVTTSS2SIQ sz from to) = pprSizeSizeOpReg (sLit "cvttss2si") FF32 sz from to +pprInstr (CVTTSD2SIQ sz from to) = pprSizeSizeOpReg (sLit "cvttsd2si") FF64 sz from to pprInstr (CVTSI2SS sz from to) = pprSizeOpReg (sLit "cvtsi2ss") sz from to pprInstr (CVTSI2SD sz from to) = pprSizeOpReg (sLit "cvtsi2sd") sz from to @@ -1094,7 +1094,6 @@ pprSizeOpReg name size op1 reg2 pprReg archWordSize reg2 ] - pprCondRegReg :: LitString -> Size -> Cond -> Reg -> Reg -> Doc pprCondRegReg name size cond reg1 reg2 = hcat [ @@ -1116,11 +1115,18 @@ pprSizeSizeRegReg name size1 size2 reg1 reg2 pprSize size2, space, pprReg size1 reg1, - comma, pprReg size2 reg2 ] +pprSizeSizeOpReg :: LitString -> Size -> Size -> Operand -> Reg -> Doc +pprSizeSizeOpReg name size1 size2 op1 reg2 + = hcat [ + pprMnemonic name size2, + pprOperand size1 op1, + comma, + pprReg size2 reg2 + ] pprSizeRegRegReg :: LitString -> Size -> Reg -> Reg -> Reg -> Doc pprSizeRegRegReg name size reg1 reg2 reg3 diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs index 46eef67..88e0462 100644 --- a/compiler/rename/RnExpr.lhs +++ b/compiler/rename/RnExpr.lhs @@ -694,6 +694,8 @@ rnStmt ctxt (L loc (ExprStmt expr _ _ _)) thing_inside then lookupStmtName ctxt guardMName else return (noSyntaxExpr, emptyFVs) -- Only list/parr/monad comprehensions use 'guard' + -- Also for sub-stmts of same eg [ e | x<-xs, gd | blah ] + -- Here "gd" is a guard ; (thing, fvs3) <- thing_inside [] ; return (([L loc (ExprStmt expr' then_op guard_op placeHolderType)], thing), fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) } diff --git a/rts/ProfHeap.c b/rts/ProfHeap.c index 9bd707f..7d2a450 100644 --- a/rts/ProfHeap.c +++ b/rts/ProfHeap.c @@ -18,6 +18,7 @@ #include "LdvProfile.h" #include "Arena.h" #include "Printer.h" +#include "sm/GCThread.h" #include @@ -1057,8 +1058,9 @@ heapCensusChain( Census *census, bdescr *bd ) void heapCensus( void ) { - nat g; + nat g, n; Census *census; + gen_workspace *ws; census = &censuses[era]; census->time = mut_user_time(); @@ -1080,6 +1082,13 @@ heapCensus( void ) // Are we interested in large objects? might be // confusing to include the stack in a heap profile. heapCensusChain( census, generations[g].large_objects ); + + for (n = 0; n < n_capabilities; n++) { + ws = &gc_threads[n]->gens[g]; + heapCensusChain(census, ws->todo_bd); + heapCensusChain(census, ws->part_list); + heapCensusChain(census, ws->scavd_list); + } } // dump out the census info diff --git a/rts/Schedule.c b/rts/Schedule.c index f5cb568..9636223 100644 --- a/rts/Schedule.c +++ b/rts/Schedule.c @@ -1447,6 +1447,12 @@ delete_threads_and_gc: recent_activity = ACTIVITY_YES; } + if (heap_census) { + debugTrace(DEBUG_sched, "performing heap census"); + heapCensus(); + performHeapProfile = rtsFalse; + } + #if defined(THREADED_RTS) if (gc_type == PENDING_GC_PAR) { @@ -1454,12 +1460,6 @@ delete_threads_and_gc: } #endif - if (heap_census) { - debugTrace(DEBUG_sched, "performing heap census"); - heapCensus(); - performHeapProfile = rtsFalse; - } - if (heap_overflow && sched_state < SCHED_INTERRUPTING) { // GC set the heap_overflow flag, so we should proceed with // an orderly shutdown now. Ultimately we want the main diff --git a/rts/Stats.c b/rts/Stats.c index fa38472..3036ed7 100644 --- a/rts/Stats.c +++ b/rts/Stats.c @@ -547,6 +547,18 @@ stat_exit(int alloc) gc_elapsed += GC_coll_elapsed[i]; } + init_cpu = end_init_cpu - start_init_cpu; + init_elapsed = end_init_elapsed - start_init_elapsed; + + exit_cpu = end_exit_cpu - start_exit_cpu; + exit_elapsed = end_exit_elapsed - start_exit_elapsed; + + mut_elapsed = start_exit_elapsed - end_init_elapsed - gc_elapsed; + + mut_cpu = start_exit_cpu - end_init_cpu - gc_cpu + - PROF_VAL(RP_tot_time + HC_tot_time); + if (mut_cpu < 0) { mut_cpu = 0; } + if (RtsFlags.GcFlags.giveStats >= SUMMARY_GC_STATS) { showStgWord64(GC_tot_alloc*sizeof(W_), temp, rtsTrue/*commas*/); @@ -635,21 +647,9 @@ stat_exit(int alloc) } #endif - init_cpu = end_init_cpu - start_init_cpu; - init_elapsed = end_init_elapsed - start_init_elapsed; - - exit_cpu = end_exit_cpu - start_exit_cpu; - exit_elapsed = end_exit_elapsed - start_exit_elapsed; - statsPrintf(" INIT time %6.2fs (%6.2fs elapsed)\n", TICK_TO_DBL(init_cpu), TICK_TO_DBL(init_elapsed)); - mut_elapsed = start_exit_elapsed - end_init_elapsed - gc_elapsed; - - mut_cpu = start_exit_cpu - end_init_cpu - gc_cpu - - PROF_VAL(RP_tot_time + HC_tot_time); - if (mut_cpu < 0) { mut_cpu = 0; } - statsPrintf(" MUT time %6.2fs (%6.2fs elapsed)\n", TICK_TO_DBL(mut_cpu), TICK_TO_DBL(mut_elapsed)); statsPrintf(" GC time %6.2fs (%6.2fs elapsed)\n",