%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1994
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
+%
+% $Id: CgLetNoEscape.lhs,v 1.24 2003/07/21 11:01:07 simonmar Exp $
%
%********************************************************
%* *
%********************************************************
\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 CLabel ( mkStdEntryLabel )
+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 Id ( getIdPrimRep )
-import Util
+import CostCentre ( CostCentreStack )
+import Id ( Id )
+import Var ( idUnique )
+import PrimRep ( PrimRep(..), retPrimRepSize )
+import BasicTypes ( RecFlag(..) )
\end{code}
%************************************************************************
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
\begin{code}
cgLetNoEscapeClosure
:: Id -- binder
- -> CostCentre -- NB: *** NOT USED *** ToDo (WDP 94/06)
+ -> CostCentreStack -- NB: *** NOT USED *** ToDo (WDP 94/06)
-> StgBinderInfo -- NB: ditto
- -> StgLiveVars -- 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
+ -> Maybe VirtualSpOffset -- Slot for current cost centre
+ -> RecFlag -- is the binding recursive?
-> [Id] -- args (as in \ args -> body)
-> 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???-}
+ lf_info = mkLFLetNoEscape arity
in
+
+ -- saveVolatileVarsAndRegs done earlier in cgExpr.
+
forkEvalHelp
rhs_eob_info
- (nukeDeadBindings full_live_in_rhss)
- (forkAbsC (cgLetNoEscapeBody args body))
- `thenFC` \ (vA, vB, code) ->
- let
- label = mkStdEntryLabel binder -- arity
- in
- absC (CCodeBlock label code) `thenC`
- returnFC (binder, letNoEscapeIdInfo binder vA vB lf_info)
+
+ (allocStackTop retPrimRepSize `thenFC` \_ ->
+ nukeDeadBindings full_live_in_rhss)
+
+ (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 (bndr, letNoEscapeIdInfo bndr vSp lf_info)
\end{code}
\begin{code}
-cgLetNoEscapeBody :: [Id] -- Args
+cgLetNoEscapeBody :: Id -- Name of the joint point
+ -> CostCentreStack
+ -> Maybe VirtualSpOffset
+ -> [Id] -- Args
-> StgExpr -- Body
-> Code
-cgLetNoEscapeBody all_args rhs
- = getVirtSps `thenFC` \ (vA, vB) ->
- getIntSwitchChkrC `thenFC` \ isw_chkr ->
- let
- arg_kinds = map getIdPrimRep all_args
- (arg_regs, _) = assignRegs isw_chkr [{-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
- getIdPrimRep
- stk_args
- in
+cgLetNoEscapeBody bndr cc cc_slot all_args body
+ = bindUnboxedTupleComponents all_args `thenFC` \ (arg_regs, ptrs, nptrs, ret_slot) ->
- -- 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-} `thenC`
-{- ToDo: NOT SURE ABOUT COST CENTRES!
-- Enter the closures cc, if required
- lexEnterCCcode closure_info maybe_cc `thenC`
--}
+ --enterCostCentreCode closure_info cc IsFunction `thenC`
- -- [No need for stack check; forkEvalHelp dealt with that]
+ -- 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]
- 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}