Commit 3f5e4368 authored by simonpj's avatar simonpj
Browse files

[project @ 2003-07-02 13:12:33 by simonpj]

------------------------
       Tidy up the code generator
	------------------------

The code generation for 'case' expressions had grown
huge and gnarly.  This commit removes about 120 lines of
code, and makes it a lot easier to read too. I think the code
generated is identical.

Part of this was to simplify the StgCase data type, so
that it is more like the Core case: there is a simple list
of alternatives, and the DEFAULT (if present) must be the
first.  This tidies and simplifies other Stg passes.
parent e82f4943
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
% $Id: AbsCSyn.lhs,v 1.52 2003/05/14 09:13:52 simonmar Exp $
% $Id: AbsCSyn.lhs,v 1.53 2003/07/02 13:12:33 simonpj Exp $
%
\section[AbstractC]{Abstract C: the last stop before machine code}
......@@ -14,27 +14,7 @@ From @AbstractC@, one may convert to real C (for portability) or to
raw assembler/machine code.
\begin{code}
module AbsCSyn {- (
-- export everything
AbstractC(..),
C_SRT(..)
CStmtMacro(..),
CExprMacro(..),
CAddrMode(..),
ReturnInfo(..),
mkAbstractCs, mkAbsCStmts, mkAlgAltsCSwitch,
mkIntCLit,
mkAbsCStmtList,
mkCCostCentre,
-- RegRelatives
RegRelative(..),
-- registers
MagicId(..), node, infoptr,
isVolatileReg,
CostRes(Cost)
)-} where
module AbsCSyn where -- export everything
#include "HsVersions.h"
......
......@@ -22,7 +22,7 @@ module AbsCUtils (
import AbsCSyn
import CLabel ( mkMAP_FROZEN_infoLabel )
import Digraph ( stronglyConnComp, SCC(..) )
import DataCon ( fIRST_TAG, ConTag )
import DataCon ( fIRST_TAG, dataConTag )
import Literal ( literalPrimRep, mkMachWord, mkMachInt )
import PrimRep ( getPrimRepSize, PrimRep(..) )
import PrimOp ( PrimOp(..) )
......@@ -34,14 +34,13 @@ import CmdLineOpts ( opt_EmitCExternDecls, opt_Unregisterised )
import ForeignCall ( ForeignCall(..), CCallSpec(..),
isDynamicTarget, isCasmTarget )
import StgSyn ( StgOp(..) )
import CoreSyn ( AltCon(..) )
import SMRep ( arrPtrsHdrSize, arrWordsHdrSize, fixedHdrSize )
import Outputable
import Panic ( panic )
import FastTypes
import Constants ( wORD_SIZE, wORD_SIZE_IN_BITS )
import Maybe ( isJust )
infixr 9 `thenFlt`
\end{code}
......@@ -108,18 +107,14 @@ mkAbsCStmtList' other r = other : r
\end{code}
\begin{code}
mkAlgAltsCSwitch :: CAddrMode -> [(ConTag, AbstractC)] -> AbstractC -> AbstractC
mkAlgAltsCSwitch :: CAddrMode -> [(AltCon, AbstractC)] -> AbstractC
mkAlgAltsCSwitch scrutinee tagged_alts deflt_absc
| isJust (nonemptyAbsC deflt_absc)
= CSwitch scrutinee (adjust tagged_alts) deflt_absc
| otherwise
= CSwitch scrutinee (adjust rest) first_alt
mkAlgAltsCSwitch scrutinee ((_,first_alt) : rest_alts)
= CSwitch scrutinee (adjust rest_alts) first_alt
where
-- it's ok to convert one of the alts into a default if we don't already have
-- one, because this is an algebraic case and we're guaranteed that the tag
-- will match one of the branches.
((_,first_alt):rest) = tagged_alts
-- We use the first alt as the default. Either it *is* the DEFAULT,
-- (which is always first if present), or the case is exhaustive,
-- in which case we can use the first as the default anyway
-- Adjust the tags in the switch to start at zero.
-- This is the convention used by primitive ops which return algebraic
......@@ -128,8 +123,8 @@ mkAlgAltsCSwitch scrutinee tagged_alts deflt_absc
-- We also need to convert to Literals to keep the CSwitch happy
adjust tagged_alts
= [ (mkMachWord (toInteger (tag - fIRST_TAG)), abs_c)
| (tag, abs_c) <- tagged_alts ]
= [ (mkMachWord (toInteger (dataConTag dc - fIRST_TAG)), abs_c)
| (DataAlt dc, abs_c) <- tagged_alts ]
\end{code}
%************************************************************************
......
......@@ -28,7 +28,7 @@ import AbsCUtils ( getAmodeRep, nonemptyAbsC,
import ForeignCall ( CCallSpec(..), CCallTarget(..), playSafe,
playThreadSafe, ccallConvAttribute,
ForeignCall(..), Safety(..), DNCallSpec(..),
ForeignCall(..), DNCallSpec(..),
DNType(..), DNKind(..) )
import CLabel ( externallyVisibleCLabel,
needsCDecl, pprCLabel, mkClosureLabel,
......@@ -1411,7 +1411,7 @@ pprMagicId SpLim = ptext SLIT("SpLim")
pprMagicId Hp = ptext SLIT("Hp")
pprMagicId HpLim = ptext SLIT("HpLim")
pprMagicId CurCostCentre = ptext SLIT("CCCS")
pprMagicId VoidReg = panic "pprMagicId:VoidReg!"
pprMagicId VoidReg = ptext SLIT("VoidReg")
pprVanillaReg :: Int# -> SDoc
pprVanillaReg n = char 'R' <> int (I# n)
......
......@@ -8,7 +8,7 @@ module CgBindery (
CgBindings, CgIdInfo,
StableLoc, VolatileLoc,
stableAmodeIdInfo, heapIdInfo, newTempAmodeAndIdInfo,
stableAmodeIdInfo, heapIdInfo,
letNoEscapeIdInfo, idInfoToAmode,
addBindC, addBindsC,
......@@ -18,7 +18,7 @@ module CgBindery (
bindNewToStack, rebindToStack,
bindNewToNode, bindNewToReg, bindArgsToRegs,
bindNewToTemp, bindNewPrimToAmode,
bindNewToTemp,
getArgAmode, getArgAmodes,
getCAddrModeAndInfo, getCAddrMode,
getCAddrModeIfVolatile, getVolatileRegs,
......@@ -44,9 +44,9 @@ import VarEnv
import VarSet ( varSetElems )
import Literal ( Literal )
import Maybes ( catMaybes, maybeToBool, seqMaybe )
import Name ( Name, isInternalName, NamedThing(..) )
import Name ( isInternalName, NamedThing(..) )
#ifdef DEBUG
import PprAbsC ( pprAmode )
import PprAbsC ( pprAmode, pprMagicId )
#endif
import PrimRep ( PrimRep(..) )
import StgSyn ( StgArg, StgLiveVars, GenStgArg(..), isStgTypeArg )
......@@ -109,6 +109,25 @@ maybeStkLoc (VirStkLoc offset) = Just offset
maybeStkLoc _ = Nothing
\end{code}
\begin{code}
instance Outputable CgIdInfo where
ppr (MkCgIdInfo id vol stb lf)
= ppr id <+> ptext SLIT("-->") <+> vcat [ppr vol, ppr stb]
instance Outputable VolatileLoc where
ppr NoVolatileLoc = empty
ppr (TempVarLoc u) = ptext SLIT("tmp") <+> ppr u
ppr (RegLoc r) = ptext SLIT("reg") <+> pprMagicId r
ppr (VirHpLoc v) = ptext SLIT("vh") <+> ppr v
ppr (VirNodeLoc v) = ptext SLIT("vn") <+> ppr v
instance Outputable StableLoc where
ppr NoStableLoc = empty
ppr (VirStkLoc v) = ptext SLIT("vs") <+> ppr v
ppr (LitLoc l) = ptext SLIT("lit") <+> ppr l
ppr (StableAmodeLoc a) = ptext SLIT("amode") <+> pprAmode a
\end{code}
%************************************************************************
%* *
\subsection[Bindery-idInfo]{Manipulating IdInfo}
......@@ -123,15 +142,6 @@ tempIdInfo i uniq lf_info = MkCgIdInfo i (TempVarLoc uniq) NoStableLoc l
letNoEscapeIdInfo i sp lf_info
= MkCgIdInfo i NoVolatileLoc (StableAmodeLoc (CJoinPoint sp)) lf_info
newTempAmodeAndIdInfo :: Id -> LambdaFormInfo -> (CAddrMode, CgIdInfo)
newTempAmodeAndIdInfo name lf_info
= (temp_amode, temp_idinfo)
where
uniq = getUnique name
temp_amode = CTemp uniq (idPrimRep name)
temp_idinfo = tempIdInfo name uniq lf_info
idInfoToAmode :: PrimRep -> CgIdInfo -> FCode CAddrMode
idInfoToAmode kind (MkCgIdInfo _ vol stab _) = idInfoPiecesToAmode kind vol stab
......@@ -373,14 +383,15 @@ bindNewToNode name offset lf_info
-- bind the id to it, and return the addressing mode for the
-- temporary.
bindNewToTemp :: Id -> FCode CAddrMode
bindNewToTemp name
= let (temp_amode, id_info) = newTempAmodeAndIdInfo name (mkLFArgument name)
-- This is used only for things we don't know
-- anything about; values returned by a case statement,
-- for example.
in do
addBindC name id_info
return temp_amode
bindNewToTemp id
= do addBindC id id_info
return temp_amode
where
uniq = getUnique id
temp_amode = CTemp uniq (idPrimRep id)
id_info = tempIdInfo id uniq lf_info
lf_info = mkLFArgument id -- Always used of things we
-- know nothing about
bindNewToReg :: Id -> MagicId -> LambdaFormInfo -> Code
bindNewToReg name magic_id lf_info
......@@ -395,24 +406,6 @@ bindArgsToRegs args regs
arg `bind` reg = bindNewToReg arg reg (mkLFArgument arg)
\end{code}
@bindNewPrimToAmode@ works only for certain addressing modes. Making
this work for stack offsets is non-trivial (virt vs. real stack offset
difficulties).
\begin{code}
bindNewPrimToAmode :: Id -> CAddrMode -> Code
bindNewPrimToAmode name (CReg reg)
= bindNewToReg name reg (panic "bindNewPrimToAmode")
bindNewPrimToAmode name (CTemp uniq kind)
= addBindC name (tempIdInfo name uniq (panic "bindNewPrimToAmode"))
#ifdef DEBUG
bindNewPrimToAmode name amode
= pprPanic "bindNew...:" (pprAmode amode)
#endif
\end{code}
\begin{code}
rebindToStack :: Id -> VirtualSpOffset -> Code
rebindToStack name offset
......@@ -458,15 +451,16 @@ buildLivenessMask size sp = do {
];
};
ASSERT(all (>=0) rel_slots)
return (intsToReverseBitmap size rel_slots)
WARN( not (all (>=0) rel_slots), ppr size $$ ppr sp $$ ppr rel_slots $$ ppr binds )
return (intsToReverseBitmap size rel_slots)
}
-- In a continuation, we want a liveness mask that starts from just after
-- the return address, which is on the stack at realSp.
buildContLivenessMask :: Name -> FCode Liveness
buildContLivenessMask name = do
buildContLivenessMask :: Id -> FCode Liveness
-- The Id is used just for its unique to make a label
buildContLivenessMask id = do
realSp <- getRealSp
frame_sp <- getStackFrame
......@@ -477,7 +471,7 @@ buildContLivenessMask name = do
mask <- buildLivenessMask frame_size (realSp-1)
let liveness = Liveness (mkBitmapLabel name) frame_size mask
let liveness = Liveness (mkBitmapLabel (getName id)) frame_size mask
absC (maybeLargeBitmap liveness)
return liveness
\end{code}
......
This diff is collapsed.
......@@ -45,7 +45,7 @@ import DataCon ( DataCon, dataConTag,
isUnboxedTupleCon, isNullaryDataCon, dataConWorkId,
dataConName, dataConRepArity
)
import Id ( Id, idName, idPrimRep )
import Id ( Id, idName, idPrimRep, isDeadBinder )
import Literal ( Literal(..) )
import PrelInfo ( maybeCharLikeCon, maybeIntLikeCon )
import PrimRep ( PrimRep(..), isFollowableRep )
......@@ -229,44 +229,51 @@ returned in registers and on the stack instead of the heap.
\begin{code}
bindUnboxedTupleComponents
:: [Id] -- args
-> FCode ([MagicId], -- regs assigned
Int, -- number of pointer stack slots
Int, -- number of non-pointer stack slots
Bool) -- any components on stack?
:: [Id] -- Aargs
-> FCode ([MagicId], -- Regs assigned
Int, -- Number of pointer stack slots
Int, -- Number of non-pointer stack slots
VirtualSpOffset) -- Offset of return address slot
-- (= realSP on entry)
bindUnboxedTupleComponents args
= -- Assign as many components as possible to registers
= -- Assign as many components as possible to registers
let (arg_regs, _leftovers) = assignRegs [] (map idPrimRep args)
(reg_args, stk_args) = splitAtList arg_regs args
-- separate the rest of the args into pointers and non-pointers
( ptr_args, nptr_args ) =
(ptr_args, nptr_args) =
partition (isFollowableRep . idPrimRep) stk_args
in
-- Allocate the rest on the stack
-- The real SP points to the return address, above which any
-- leftover unboxed-tuple components will be allocated
getVirtSp `thenFC` \ vsp ->
getRealSp `thenFC` \ rsp ->
let
(ptr_sp, ptr_offsets) = mkVirtStkOffsets rsp idPrimRep ptr_args
(nptr_sp, nptr_offsets) = mkVirtStkOffsets ptr_sp idPrimRep nptr_args
ptrs = ptr_sp - rsp
nptrs = nptr_sp - ptr_sp
in
-- The stack pointer points to the last stack-allocated component
setRealAndVirtualSp nptr_sp `thenC`
-- need to explicitly free any empty slots we just jumped over
(if vsp < rsp then freeStackSlots [vsp+1 .. rsp] else nopC) `thenC`
-- We have just allocated slots starting at real SP + 1, and set the new
-- virtual SP to the topmost allocated slot.
-- If the virtual SP started *below* the real SP, we've just jumped over
-- some slots that won't be in the free-list, so put them there
-- This commonly happens because we've freed the return-address slot
-- (trimming back the virtual SP), but the real SP still points to that slot
freeStackSlots [vsp+1,vsp+2 .. rsp] `thenC`
bindArgsToRegs reg_args arg_regs `thenC`
mapCs bindNewToStack ptr_offsets `thenC`
mapCs bindNewToStack nptr_offsets `thenC`
returnFC (arg_regs,
ptr_sp - rsp, nptr_sp - ptr_sp,
notNull ptr_offsets || notNull ptr_offsets
)
returnFC (arg_regs, ptrs, nptrs, rsp)
\end{code}
%************************************************************************
......@@ -287,7 +294,7 @@ cgReturnDataCon con amodes
case sequel of
CaseAlts _ (Just (alts, Just (maybe_deflt, (_,deflt_lbl)))) False
CaseAlts _ (Just (alts, Just (deflt_bndr, (_,deflt_lbl)))) False
| not (dataConTag con `is_elem` map fst alts)
->
-- Special case! We're returning a constructor to the default case
......@@ -301,9 +308,9 @@ cgReturnDataCon con amodes
-- if the default is a non-bind-default (ie does not use y),
-- then we should simply jump to the default join point;
case maybe_deflt of
Nothing -> performReturn AbsCNop {- No reg assts -} jump_to_join_point
Just _ -> build_it_then jump_to_join_point
if isDeadBinder deflt_bndr
then performReturn AbsCNop {- No reg assts -} jump_to_join_point
else build_it_then jump_to_join_point
where
is_elem = isIn "cgReturnDataCon"
jump_to_join_point sequel = absC (CJump (CLbl deflt_lbl CodePtrRep))
......
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
% $Id: CgExpr.lhs,v 1.53 2003/05/14 09:13:55 simonmar Exp $
% $Id: CgExpr.lhs,v 1.54 2003/07/02 13:12:36 simonpj Exp $
%
%********************************************************
%* *
......@@ -22,10 +22,10 @@ import AbsCUtils ( mkAbstractCs, getAmodeRep )
import CLabel ( mkClosureTblLabel )
import SMRep ( fixedHdrSize )
import CoreSyn ( AltCon(..) )
import CgBindery ( getArgAmodes, getArgAmode, CgIdInfo,
nukeDeadBindings, addBindC, addBindsC )
import CgCase ( cgCase, saveVolatileVarsAndRegs,
restoreCurrentCostCentre )
import CgCase ( cgCase, saveVolatileVarsAndRegs, restoreCurrentCostCentre )
import CgClosure ( cgRhsClosure, cgStdRhsClosure )
import CgCon ( buildDynCon, cgReturnDataCon )
import CgLetNoEscape ( cgLetNoEscapeClosure )
......@@ -138,6 +138,7 @@ cgExpr (StgOpApp (StgPrimOp TagToEnumOp) [arg] res_ty)
(\ sequel -> mkDynamicAlgReturnCode tycon dyn_tag sequel)
where
dyn_tag = CTemp (mkBuiltinUnique 0) IntRep
-- The '0' is just to get a random spare temp
--
-- if you're reading this code in the attempt to figure
-- out why the compiler panic'ed here, it is probably because
......@@ -199,8 +200,8 @@ Case-expression conversion is complicated enough to have its own
module, @CgCase@.
\begin{code}
cgExpr (StgCase expr live_vars save_vars bndr srt alts)
= cgCase expr live_vars save_vars bndr srt alts
cgExpr (StgCase expr live_vars save_vars bndr srt alt_type alts)
= cgCase expr live_vars save_vars bndr srt alt_type alts
\end{code}
......@@ -232,7 +233,10 @@ cgExpr (StgLetNoEscape live_in_whole_let live_in_rhss bindings body)
nukeDeadBindings live_in_whole_let `thenC`
saveVolatileVarsAndRegs live_in_rhss
`thenFC` \ (save_assts, rhs_eob_info, maybe_cc_slot) ->
-- ToDo: cost centre???
-- TEMP: put back in for line-by-line compatibility
-- Doesn't look right; surely should restore in the branch!
-- And the code isn't used....
restoreCurrentCostCentre maybe_cc_slot `thenFC` \ restore_cc ->
-- Save those variables right now!
......@@ -316,10 +320,9 @@ mkRhsClosure bndr cc bi srt
[] -- A thunk
body@(StgCase (StgApp scrutinee [{-no args-}])
_ _ _ _ -- ignore uniq, etc.
(StgAlgAlts (Just tycon)
[(con, params, use_mask,
(StgApp selectee [{-no args-}]))]
StgNoDefault))
(AlgAlt tycon)
[(DataAlt con, params, use_mask,
(StgApp selectee [{-no args-}]))])
| the_fv == scrutinee -- Scrutinee is the only free variable
&& maybeToBool maybe_offset -- Selectee is a component of the tuple
&& offset_into_int <= mAX_SPEC_SELECTEE_SIZE -- Offset is small enough
......@@ -397,7 +400,7 @@ mkRhsClosure bndr cc bi srt fvs upd_flag args body
cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot
(StgNonRec binder rhs)
= cgLetNoEscapeRhs live_in_rhss rhs_eob_info maybe_cc_slot
NonRecursive binder rhs
NonRecursive binder rhs
`thenFC` \ (binder, info) ->
addBindC binder info
......
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
% $Id: CgHeapery.lhs,v 1.36 2002/12/18 16:15:43 simonmar Exp $
% $Id: CgHeapery.lhs,v 1.37 2003/07/02 13:12:36 simonpj Exp $
%
\section[CgHeapery]{Heap management functions}
......@@ -17,23 +17,24 @@ module CgHeapery (
#include "HsVersions.h"
import AbsCSyn
import StgSyn ( AltType(..) )
import CLabel
import CgMonad
import CgStackery ( getFinalStackHW )
import AbsCUtils ( mkAbstractCs, getAmodeRep )
import CgUsages ( getVirtAndRealHp, getRealSp, setVirtHp, setRealHp,
initHeapUsage
)
import CgRetConv ( dataReturnConvPrim )
import ClosureInfo ( closureSize, closureGoodStuffSize,
slopSize, allocProfilingMsg, ClosureInfo
)
import TyCon ( tyConPrimRep )
import PrimRep ( PrimRep(..), isFollowableRep )
import CmdLineOpts ( opt_GranMacros )
import Outputable
#ifdef DEBUG
import PprAbsC ( pprMagicId ) -- tmp
import PprAbsC ( pprMagicId )
#endif
import GLAEXTS
......@@ -160,72 +161,57 @@ the heap check code.
\begin{code}
altHeapCheck
:: Bool -- do not enter node on return
-> [MagicId] -- live registers
-> Code -- continuation
-> Code
-- normal algebraic and primitive case alternatives:
altHeapCheck no_enter regs code
= initHeapUsage (\ hHw -> do_heap_chk hHw `thenC` code)
:: AltType -- PolyAlt, PrimAlt, AlgAlt, but *not* UbxTupAlt
-- (Unboxed tuples are dealt with by ubxTupleHeapCheck)
-> Code -- Continuation
-> Code
altHeapCheck alt_type code
= initHeapUsage (\ hHw ->
do_heap_chk hHw `thenC`
setRealHp hHw `thenC`
code)
where
do_heap_chk :: HeapOffset -> Code
do_heap_chk words_required
= getTickyCtrLabel `thenFC` \ ctr ->
absC ( if words_required == 0
then AbsCNop
else mkAbstractCs
[ checking_code,
= getTickyCtrLabel `thenFC` \ ctr ->
absC ( -- NB The conditional is inside the absC,
-- so the monadic stuff doesn't depend on
-- the value of words_required!
if words_required == 0
then AbsCNop
else mkAbstractCs
[ CCheck (checking_code alt_type)
[mkIntCLit words_required] AbsCNop,
profCtrAbsC FSLIT("TICK_ALLOC_HEAP")
[ mkIntCLit words_required, CLbl ctr DataPtrRep ]
]
) `thenC`
setRealHp words_required
where
non_void_regs = filter (/= VoidReg) regs
checking_code =
case non_void_regs of
-- No regs live: probably a Void return
[] ->
CCheck HP_CHK_NOREGS [mkIntCLit words_required] AbsCNop
[VanillaReg rep 1#]
-- R1 is boxed, but unlifted: DO NOT enter R1 when we return.
| isFollowableRep rep && no_enter ->
CCheck HP_CHK_UNPT_R1 [mkIntCLit words_required] AbsCNop
-- R1 is lifted (the common case)
| isFollowableRep rep ->
CCheck HP_CHK_NP
[mkIntCLit words_required]
AbsCNop
-- R1 is unboxed
| otherwise ->
CCheck HP_CHK_UNBX_R1 [mkIntCLit words_required] AbsCNop
-- FloatReg1
[FloatReg 1#] ->
CCheck HP_CHK_F1 [mkIntCLit words_required] AbsCNop
-- DblReg1
[DoubleReg 1#] ->
CCheck HP_CHK_D1 [mkIntCLit words_required] AbsCNop
-- LngReg1
[LongReg _ 1#] ->
CCheck HP_CHK_L1 [mkIntCLit words_required] AbsCNop
])
checking_code PolyAlt
= HP_CHK_UNPT_R1 -- Do *not* enter R1 after a heap check in
-- a polymorphic case. It might be a function
-- and the entry code for a function (currently)
-- applies it
--
-- However R1 is guaranteed to be a pointer
checking_code (AlgAlt tc)
= HP_CHK_NP -- Enter R1 after the heap check; it's a pointer
-- The "NP" is short for "Node (R1) Points to it"
checking_code (PrimAlt tc)
= case dataReturnConvPrim (tyConPrimRep tc) of
VoidReg -> HP_CHK_NOREGS
FloatReg 1# -> HP_CHK_F1
DoubleReg 1# -> HP_CHK_D1
LongReg _ 1# -> HP_CHK_L1
VanillaReg rep 1#
| isFollowableRep rep -> HP_CHK_UNPT_R1 -- R1 is boxed but unlifted:
| otherwise -> HP_CHK_UNBX_R1 -- R1 is unboxed
#ifdef DEBUG
_ -> panic ("CgHeapery.altHeapCheck: unimplemented heap-check, live regs = " ++ showSDoc (sep (map pprMagicId non_void_regs)))
other_reg -> pprPanic "CgHeapery.altHeapCheck" (ppr tc <+> pprMagicId other_reg)
#endif
-- unboxed tuple alternatives and let-no-escapes (the two most annoying
-- Unboxed tuple alternatives and let-no-escapes (the two most annoying
-- constructs to generate code for!):
unbxTupleHeapCheck
......@@ -247,21 +233,18 @@ unbxTupleHeapCheck regs ptrs nptrs fail_code code
absC ( if words_required == 0
then AbsCNop
else mkAbstractCs
[ checking_code,
[ checking_code words_required,
profCtrAbsC FSLIT("TICK_ALLOC_HEAP")
[ mkIntCLit words_required, CLbl ctr DataPtrRep ]
]
) `thenC`
setRealHp words_required
where
checking_code =
let liveness = mkRegLiveness regs ptrs nptrs
in
CCheck HP_CHK_UNBX_TUPLE
[mkIntCLit words_required,
mkIntCLit (I# (word2Int# liveness))]
fail_code
liveness = I# (word2Int# (mkRegLiveness regs ptrs nptrs))
checking_code words_required = CCheck HP_CHK_UNBX_TUPLE
[mkIntCLit words_required,
mkIntCLit liveness]
fail_code
-- build up a bitmap of the live pointer registers
......
%
% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
%
% $Id: CgLetNoEscape.lhs,v 1.20 2003/05/14 09:13:56 simonmar Exp $
% $Id: CgLetNoEscape.lhs,v 1.21 2003/07/02 13:12:37 simonpj Exp $
%
%********************************************************
%* *
......@@ -20,27 +20,19 @@ import StgSyn
import CgMonad
import AbsCSyn
import CgBindery ( letNoEscapeIdInfo, bindArgsToRegs,
bindNewToStack, buildContLivenessMask, CgIdInfo,
nukeDeadBindings
)
import CgBindery ( CgIdInfo, letNoEscapeIdInfo, nukeDeadBindings )
import CgCase ( mkRetDirectTarget, restoreCurrentCostCentre )
import CgCon ( bindUnboxedTupleComponents )
import CgHeapery ( unbxTupleHeapCheck )
import CgRetConv ( assignRegs )
import CgStackery ( mkVirtStkOffsets,
allocStackTop, deAllocStackTop, freeStackSlots )
import CgUsages ( setRealAndVirtualSp, getRealSp, getSpRelOffset )
import CgStackery ( allocStackTop, deAllocStackTop )
import CgUsages ( getSpRelOffset )
import CLabel ( mkReturnInfoLabel )
import ClosureInfo ( mkLFLetNoEscape )
import CostCentre ( CostCentreStack )
import Name ( getName )
import Id ( Id, idPrimRep, idName )
import Id ( Id )
import Var ( idUnique )
import PrimRep ( PrimRep(..), retPrimRepSize, isFollowableRep )