%
-% (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 $
%
%********************************************************
%* *
%********************************************************
\begin{code}
-#include "HsVersions.h"
-
module CgLetNoEscape ( cgLetNoEscapeClosure ) where
-IMP_Ubiq(){-uitious-}
-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
-IMPORT_DELOOPER(CgLoop2) ( cgExpr )
-#else
+#include "HsVersions.h"
+
import {-# SOURCE #-} CgExpr ( cgExpr )
-#endif
import StgSyn
import CgMonad
-import AbsCSyn
-
-import CgBindery ( letNoEscapeIdInfo, bindArgsToRegs,
- bindNewToAStack, bindNewToBStack,
- CgIdInfo
- )
-import CgHeapery ( heapCheck )
-import CgRetConv ( assignRegs )
-import CgStackery ( mkVirtStkOffsets )
-import CgUsages ( setRealAndVirtualSps, getVirtSps )
-import CLabel ( mkStdEntryLabel )
+
+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 CostCentre ( CostCentre )
-import HeapOffs ( SYN_IE(VirtualSpBOffset) )
-import Id ( idPrimRep, SYN_IE(Id) )
+import CostCentre ( CostCentreStack )
+import Id ( Id, idName )
+import Var ( idUnique )
+import SMRep ( retAddrSizeW )
+import BasicTypes ( RecFlag(..) )
+import Outputable
\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
- 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)
+ -- 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
+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 idPrimRep all_args
- (arg_regs, _) = assignRegs [{-nothing live-}] arg_kinds
- (reg_args, stk_args) = splitAt (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
- idPrimRep
- 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 reg_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}
projects / ghc-hetmet.git / blobdiff