X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcodeGen%2FCgLetNoEscape.lhs;h=3ea05974f6700542daf87b00f554b2466d86e17e;hb=423d477bfecd490de1449c59325c8776f91d7aac;hp=abc1e115c926be469d8ced64eec103715f8fddb1;hpb=e7d21ee4f8ac907665a7e170c71d59e13a01da09;p=ghc-hetmet.git diff --git a/ghc/compiler/codeGen/CgLetNoEscape.lhs b/ghc/compiler/codeGen/CgLetNoEscape.lhs index abc1e11..3ea0597 100644 --- a/ghc/compiler/codeGen/CgLetNoEscape.lhs +++ b/ghc/compiler/codeGen/CgLetNoEscape.lhs @@ -1,5 +1,7 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1993-1994 +% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 +% +% $Id: CgLetNoEscape.lhs,v 1.25 2004/08/13 13:06:03 simonmar Exp $ % %******************************************************** %* * @@ -8,24 +10,31 @@ %******************************************************** \begin{code} +module CgLetNoEscape ( cgLetNoEscapeClosure ) where + #include "HsVersions.h" -module CgLetNoEscape ( cgLetNoEscapeClosure ) where +import {-# SOURCE #-} CgExpr ( cgExpr ) import StgSyn import CgMonad -import AbsCSyn - -import CgBindery -- various things -import CgExpr ( cgExpr ) -import CgHeapery ( heapCheck ) -import CgRetConv ( assignRegs ) -import CgStackery ( mkVirtStkOffsets ) -import CgUsages ( setRealAndVirtualSps, getVirtSps ) -import CLabelInfo ( mkFastEntryLabel ) + +import CgBindery ( CgIdInfo, letNoEscapeIdInfo, nukeDeadBindings ) +import CgCase ( restoreCurrentCostCentre ) +import CgCon ( bindUnboxedTupleComponents ) +import CgHeapery ( unbxTupleHeapCheck ) +import CgInfoTbls ( emitDirectReturnTarget ) +import CgStackery ( allocStackTop, deAllocStackTop, getSpRelOffset ) +import Cmm ( CmmStmt(..) ) +import CmmUtils ( mkLblExpr, oneStmt ) +import CLabel ( mkReturnInfoLabel ) import ClosureInfo ( mkLFLetNoEscape ) -import Id ( getIdKind ) -import Util +import CostCentre ( CostCentreStack ) +import Id ( Id, idName ) +import Var ( idUnique ) +import SMRep ( retAddrSizeW ) +import BasicTypes ( RecFlag(..) ) +import Outputable \end{code} %************************************************************************ @@ -39,12 +48,12 @@ import Util Consider: \begin{verbatim} let x = fvs \ args -> e - in - if ... then x else + in + if ... then x else if ... then x else ... \end{verbatim} @x@ is used twice (so we probably can't unfold it), but when it is -entered, the stack is deeper than it was then the definition of @x@ +entered, the stack is deeper than it was when the definition of @x@ happened. Specifically, if instead of allocating a closure for @x@, we saved all @x@'s fvs on the stack, and remembered the stack depth at that moment, then whenever we enter @x@ we can simply set the stack @@ -93,7 +102,7 @@ non-escaping. @x@ can even be recursive! Eg: \begin{verbatim} letrec x = [y] \ [v] -> if v then x True else ... - in + in ...(x b)... \end{verbatim} @@ -128,75 +137,76 @@ on the stack, if they aren't there already. \begin{code} cgLetNoEscapeClosure :: Id -- binder - -> CostCentre -- NB: *** NOT USED *** ToDo (WDP 94/06) + -> CostCentreStack -- NB: *** NOT USED *** ToDo (WDP 94/06) -> StgBinderInfo -- NB: ditto - -> PlainStgLiveVars -- variables live in RHS, including the binders + -> SRT + -> StgLiveVars -- variables live in RHS, including the binders -- themselves in the case of a recursive group - -> EndOfBlockInfo -- where are we going to? - -> Maybe VirtualSpBOffset -- Slot for current cost centre + -> EndOfBlockInfo -- where are we going to? + -> Maybe VirtualSpOffset -- Slot for current cost centre + -> RecFlag -- is the binding recursive? -> [Id] -- args (as in \ args -> body) - -> PlainStgExpr -- body (as in above) + -> StgExpr -- body (as in above) -> FCode (Id, CgIdInfo) -- ToDo: deal with the cost-centre issues -cgLetNoEscapeClosure binder cc bi full_live_in_rhss rhs_eob_info maybe_cc_slot args body +cgLetNoEscapeClosure + bndr cc binder_info srt full_live_in_rhss + rhs_eob_info cc_slot rec args body = let arity = length args - lf_info = mkLFLetNoEscape arity full_live_in_rhss{-used???-} - in - forkEvalHelp - rhs_eob_info - (nukeDeadBindings full_live_in_rhss) - (forkAbsC (cgLetNoEscapeBody args body)) - `thenFC` \ (vA, vB, code) -> - let - label = mkFastEntryLabel binder arity + lf_info = mkLFLetNoEscape arity in - absC (CCodeBlock label code) `thenC` - returnFC (binder, letNoEscapeIdInfo binder vA vB lf_info) + -- saveVolatileVarsAndRegs done earlier in cgExpr. + + do { (vSp, _) <- forkEvalHelp rhs_eob_info + + (do { allocStackTop retAddrSizeW + ; nukeDeadBindings full_live_in_rhss }) + + (do { deAllocStackTop retAddrSizeW + ; abs_c <- forkProc $ cgLetNoEscapeBody bndr cc + cc_slot args body + + -- Ignore the label that comes back from + -- mkRetDirectTarget. It must be conjured up elswhere + ; emitDirectReturnTarget (idName bndr) abs_c srt + ; return () }) + + ; returnFC (bndr, letNoEscapeIdInfo bndr vSp lf_info) } \end{code} \begin{code} -cgLetNoEscapeBody :: [Id] -- Args - -> PlainStgExpr -- Body +cgLetNoEscapeBody :: Id -- Name of the joint point + -> CostCentreStack + -> Maybe VirtualSpOffset + -> [Id] -- Args + -> StgExpr -- Body -> Code -cgLetNoEscapeBody all_args rhs - = getVirtSps `thenFC` \ (vA, vB) -> - let - arg_kinds = map getIdKind all_args - (arg_regs, _) = assignRegs [{-nothing live-}] arg_kinds - stk_args = drop (length arg_regs) all_args - - -- stk_args is the args which are passed on the stack at the fast-entry point - -- Using them, we define the stack layout - (spA_stk_args, spB_stk_args, stk_bxd_w_offsets, stk_ubxd_w_offsets) - = mkVirtStkOffsets - vA vB -- Initial virtual SpA, SpB - getIdKind - stk_args - in +cgLetNoEscapeBody bndr cc cc_slot all_args body = do + { (arg_regs, ptrs, nptrs, ret_slot) <- bindUnboxedTupleComponents all_args - -- Bind args to appropriate regs/stk locns - bindArgsToRegs all_args arg_regs `thenC` - mapCs bindNewToAStack stk_bxd_w_offsets `thenC` - mapCs bindNewToBStack stk_ubxd_w_offsets `thenC` - setRealAndVirtualSps spA_stk_args spB_stk_args `thenC` + -- restore the saved cost centre. BUT: we must not free the stack slot + -- containing the cost centre, because it might be needed for a + -- recursive call to this let-no-escape. + ; restoreCurrentCostCentre cc_slot False{-don't free-} -{- ToDo: NOT SURE ABOUT COST CENTRES! -- Enter the closures cc, if required - lexEnterCCcode closure_info maybe_cc `thenC` --} + ; -- enterCostCentreCode closure_info cc IsFunction + + -- The "return address" slot doesn't have a return address in it; + -- but the heap-check needs it filled in if the heap-check fails. + -- So we pass code to fill it in to the heap-check macro + ; sp_rel <- getSpRelOffset ret_slot - -- [No need for stack check; forkEvalHelp dealt with that] + ; let lbl = mkReturnInfoLabel (idUnique bndr) + frame_hdr_asst = oneStmt (CmmStore sp_rel (mkLblExpr lbl)) -- Do heap check [ToDo: omit for non-recursive case by recording in -- in envt and absorbing at call site] - heapCheck arg_regs False {- Node doesn't point to it -} ( - -- heapCheck *encloses* the rest - - -- Compile the body - cgExpr rhs - ) + ; unbxTupleHeapCheck arg_regs ptrs nptrs frame_hdr_asst + (cgExpr body) + } \end{code}