%
% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
%
-% $Id: CgLetNoEscape.lhs,v 1.11 1998/12/02 13:17:50 simonm Exp $
+% $Id: CgLetNoEscape.lhs,v 1.24 2003/07/21 11:01:07 simonmar Exp $
%
%********************************************************
%* *
import StgSyn
import CgMonad
import AbsCSyn
-import CLabel ( CLabel )
-
-import CgBindery ( letNoEscapeIdInfo, bindArgsToRegs,
- bindNewToStack, buildContLivenessMask, CgIdInfo,
- nukeDeadBindings
- )
-import CgHeapery ( altHeapCheck )
-import CgRetConv ( assignRegs )
-import CgStackery ( mkTaggedVirtStkOffsets,
- allocStackTop, deAllocStackTop, freeStackSlots )
-import CgUsages ( setRealAndVirtualSp, getRealSp, getSpRelOffset )
-import CLabel ( mkReturnPtLabel )
+
+import CgBindery ( CgIdInfo, letNoEscapeIdInfo, nukeDeadBindings )
+import CgCase ( mkRetDirectTarget, restoreCurrentCostCentre )
+import CgCon ( bindUnboxedTupleComponents )
+import CgHeapery ( unbxTupleHeapCheck )
+import CgStackery ( allocStackTop, deAllocStackTop )
+import CgUsages ( getSpRelOffset )
+import CLabel ( mkReturnInfoLabel )
import ClosureInfo ( mkLFLetNoEscape )
import CostCentre ( CostCentreStack )
-import Id ( idPrimRep, Id )
+import Id ( Id )
import Var ( idUnique )
import PrimRep ( PrimRep(..), retPrimRepSize )
import BasicTypes ( RecFlag(..) )
-- ToDo: deal with the cost-centre issues
cgLetNoEscapeClosure
- binder cc binder_info srt full_live_in_rhss
+ 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
- uniq = idUnique binder
- lbl = mkReturnPtLabel uniq
in
-- saveVolatileVarsAndRegs done earlier in cgExpr.
(allocStackTop retPrimRepSize `thenFC` \_ ->
nukeDeadBindings full_live_in_rhss)
- (deAllocStackTop retPrimRepSize `thenFC` \_ ->
- buildContLivenessMask uniq `thenFC` \ liveness ->
- forkAbsC (cgLetNoEscapeBody binder cc args body lbl)
- `thenFC` \ code ->
- getSRTLabel `thenFC` \ srt_label ->
- absC (CRetDirect uniq code (srt_label,srt) liveness)
- `thenC` returnFC ())
- `thenFC` \ (vSp, _) ->
+ (deAllocStackTop retPrimRepSize `thenFC` \_ ->
+ forkAbsC (
+ cgLetNoEscapeBody bndr cc cc_slot args body
+ ) `thenFC` \ abs_c ->
+ mkRetDirectTarget bndr abs_c srt
+ -- Ignore the label that comes back from
+ -- mkRetDirectTarget. It must be conjured up elswhere
+ ) `thenFC` \ (vSp, _) ->
- returnFC (binder, letNoEscapeIdInfo binder vSp lf_info)
+ returnFC (bndr, letNoEscapeIdInfo bndr vSp lf_info)
\end{code}
\begin{code}
-cgLetNoEscapeBody :: Id
+cgLetNoEscapeBody :: Id -- Name of the joint point
-> CostCentreStack
+ -> Maybe VirtualSpOffset
-> [Id] -- Args
-> StgExpr -- Body
- -> CLabel -- Entry label
-> Code
-cgLetNoEscapeBody binder cc all_args body lbl
- =
- -- this is where the stack frame lives:
- getRealSp `thenFC` \sp ->
-
- let
- arg_kinds = map idPrimRep all_args
- (arg_regs, _) = assignRegs [{-nothing live-}] arg_kinds
- (reg_args, stk_args) = splitAt (length arg_regs) all_args
-
- (sp_stk_args, stk_offsets, stk_tags)
- = mkTaggedVirtStkOffsets sp idPrimRep stk_args
- in
-
- -- Bind args to appropriate regs/stk locns
- bindArgsToRegs reg_args arg_regs `thenC`
- mapCs bindNewToStack stk_offsets `thenC`
- setRealAndVirtualSp sp_stk_args `thenC`
+cgLetNoEscapeBody bndr cc cc_slot all_args body
+ = bindUnboxedTupleComponents all_args `thenFC` \ (arg_regs, ptrs, nptrs, ret_slot) ->
- -- free up the stack slots containing tags, and the slot
- -- containing the return address (really frame header).
- -- c.f. CgCase.cgUnboxedTupleAlt.
- freeStackSlots (sp : map fst stk_tags) `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-} `thenC`
-- Enter the closures cc, if required
--enterCostCentreCode closure_info cc IsFunction `thenC`
- -- fill in the frame header only if we fail a heap check:
- -- otherwise it isn't needed.
- getSpRelOffset sp `thenFC` \sp_rel ->
- let frame_hdr_asst = CAssign (CVal sp_rel RetRep) (CLbl lbl RetRep)
+ -- 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
+ getSpRelOffset ret_slot `thenFC` \ sp_rel ->
+ let lbl = mkReturnInfoLabel (idUnique bndr)
+ frame_hdr_asst = CAssign (CVal sp_rel RetRep) (CLbl lbl RetRep)
in
-- Do heap check [ToDo: omit for non-recursive case by recording in
-- in envt and absorbing at call site]
- altHeapCheck False arg_regs stk_tags frame_hdr_asst (Just lbl) (
+ unbxTupleHeapCheck arg_regs ptrs nptrs frame_hdr_asst (
cgExpr body
)
-
\end{code}
projects / ghc-hetmet.git / blobdiff