X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcodeGen%2FStgCmmExpr.hs;h=8952f92bd26fd09fbc77b457de2caec9c0a1d385;hp=3b6aac97906c589c86bc6f659f998060df7ca929;hb=984a288119983912d40a80845c674ee4b83a19ce;hpb=6bc92166180824bf046d31e378359e3c386150f9 diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs index 3b6aac9..8952f92 100644 --- a/compiler/codeGen/StgCmmExpr.hs +++ b/compiler/codeGen/StgCmmExpr.hs @@ -42,6 +42,7 @@ import Maybes import Util import FastString import Outputable +import UniqSupply ------------------------------------------------------------------------ -- cgExpr: the main function @@ -57,8 +58,13 @@ cgExpr (StgTick m n expr) = do { emit (mkTickBox m n); cgExpr expr } cgExpr (StgLit lit) = do cmm_lit <- cgLit lit emitReturn [CmmLit cmm_lit] -cgExpr (StgLet binds expr) = do { cgBind binds; cgExpr expr } -cgExpr (StgLetNoEscape _ _ binds expr) = do { cgLneBinds binds; cgExpr expr } +cgExpr (StgLet binds expr) = do { cgBind binds; cgExpr expr } +cgExpr (StgLetNoEscape _ _ binds expr) = + do { us <- newUniqSupply + ; let join_id = mkBlockId (uniqFromSupply us) + ; cgLneBinds join_id binds + ; cgExpr expr + ; emit $ mkLabel join_id} cgExpr (StgCase expr _live_vars _save_vars bndr srt alt_type alts) = cgCase expr bndr srt alt_type alts @@ -84,37 +90,42 @@ bound only to stable things like stack locations.. The 'e' part will execute *next*, just like the scrutinee of a case. -} ------------------------- -cgLneBinds :: StgBinding -> FCode () -cgLneBinds (StgNonRec bndr rhs) - = do { local_cc <- saveCurrentCostCentre - -- See Note [Saving the current cost centre] - ; info <- cgLetNoEscapeRhs local_cc bndr rhs - ; addBindC (cg_id info) info } - -cgLneBinds (StgRec pairs) - = do { local_cc <- saveCurrentCostCentre - ; new_bindings <- fixC (\ new_bindings -> do - { addBindsC new_bindings - ; listFCs [ cgLetNoEscapeRhs local_cc b e - | (b,e) <- pairs ] }) - - ; addBindsC new_bindings } +cgLneBinds :: BlockId -> StgBinding -> FCode () +cgLneBinds join_id (StgNonRec bndr rhs) + = do { local_cc <- saveCurrentCostCentre + -- See Note [Saving the current cost centre] + ; info <- cgLetNoEscapeRhs join_id local_cc bndr rhs + ; addBindC (cg_id info) info } + +cgLneBinds join_id (StgRec pairs) + = do { local_cc <- saveCurrentCostCentre + ; new_bindings <- fixC (\ new_bindings -> do + { addBindsC new_bindings + ; listFCs [ cgLetNoEscapeRhs join_id local_cc b e + | (b,e) <- pairs ] }) + ; addBindsC new_bindings } ------------------------- -cgLetNoEscapeRhs, cgLetNoEscapeRhsBody - :: Maybe LocalReg -- Saved cost centre +cgLetNoEscapeRhs + :: BlockId -- join point for successor of let-no-escape + -> Maybe LocalReg -- Saved cost centre -> Id -> StgRhs -> FCode CgIdInfo -cgLetNoEscapeRhs local_cc bndr rhs = +cgLetNoEscapeRhs join_id local_cc bndr rhs = do { (info, rhs_body) <- getCodeR $ cgLetNoEscapeRhsBody local_cc bndr rhs ; let (bid, _) = expectJust "cgLetNoEscapeRhs" $ maybeLetNoEscape info - ; emit (outOfLine $ mkLabel bid emptyStackInfo <*> rhs_body) + ; emit (outOfLine $ mkLabel bid <*> rhs_body <*> mkBranch join_id) ; return info } +cgLetNoEscapeRhsBody + :: Maybe LocalReg -- Saved cost centre + -> Id + -> StgRhs + -> FCode CgIdInfo cgLetNoEscapeRhsBody local_cc bndr (StgRhsClosure cc _bi _ _upd _ args body) = cgLetNoEscapeClosure bndr local_cc cc (nonVoidIds args) body cgLetNoEscapeRhsBody local_cc bndr (StgRhsCon cc con args) @@ -285,7 +296,7 @@ cgCase scrut bndr srt alt_type alts ; restoreCurrentCostCentre mb_cc -- JD: We need Note: [Better Alt Heap Checks] - ; bindArgsToRegs ret_bndrs + ; _ <- bindArgsToRegs ret_bndrs ; cgAlts gc_plan (NonVoid bndr) alt_type alts } ----------------- @@ -309,8 +320,8 @@ isSimpleScrut _ _ = False isSimpleOp :: StgOp -> Bool -- True iff the op cannot block or allocate isSimpleOp (StgFCallOp (CCall (CCallSpec _ _ safe)) _) = not (playSafe safe) -isSimpleOp (StgFCallOp (DNCall _) _) = False -- Safe! isSimpleOp (StgPrimOp op) = not (primOpOutOfLine op) +isSimpleOp (StgPrimCallOp _) = False ----------------- chooseReturnBndrs :: Id -> AltType -> [StgAlt] -> [NonVoid Id] @@ -396,7 +407,7 @@ cgAltRhss gc_plan bndr alts cg_alt (con, bndrs, _uses, rhs) = getCodeR $ maybeAltHeapCheck gc_plan $ - do { pprTrace "binding args for" (ppr bndr <+> ppr con) $ bindConArgs con base_reg bndrs + do { _ <- bindConArgs con base_reg bndrs ; cgExpr rhs ; return con } @@ -442,8 +453,9 @@ cgLneJump blk_id lne_regs args -- Join point; discard sequel <*> mkBranch blk_id) } cgTailCall :: Id -> CgIdInfo -> [StgArg] -> FCode () -cgTailCall fun_id fun_info args - = case (getCallMethod fun_name (idCafInfo fun_id) lf_info (length args)) of +cgTailCall fun_id fun_info args = do + dflags <- getDynFlags + case (getCallMethod dflags fun_name (idCafInfo fun_id) lf_info (length args)) of -- A value in WHNF, so we can just return it. ReturnIt -> emitReturn [fun] -- ToDo: does ReturnIt guarantee tagged? @@ -452,8 +464,9 @@ cgTailCall fun_id fun_info args do { let fun' = CmmLoad fun (cmmExprType fun) ; [ret,call] <- forkAlts [ getCode $ emitReturn [fun], -- Is tagged; no need to untag - getCode $ do emit (mkAssign nodeReg fun) - emitCall Native (entryCode fun') []] -- Not tagged + getCode $ do -- emit (mkAssign nodeReg fun) + emitCall (NativeNodeCall, NativeReturn) + (entryCode fun') [fun]] -- Not tagged ; emit (mkCmmIfThenElse (cmmIsTagged fun) ret call) } SlowCall -> do -- A slow function call via the RTS apply routines @@ -468,8 +481,6 @@ cgTailCall fun_id fun_info args do emit $ mkComment $ mkFastString "directEntry" emit (mkAssign nodeReg fun) directCall lbl arity args - -- directCall lbl (arity+1) (StgVarArg fun_id : args)) - -- >>= (emit . (mkComment (mkFastString "DirectEntry") <*>)) else do emit $ mkComment $ mkFastString "directEntry else" directCall lbl arity args }