summaryrefslogtreecommitdiff
path: root/ghc/compiler/codeGen
diff options
context:
space:
mode:
Diffstat (limited to 'ghc/compiler/codeGen')
-rw-r--r--ghc/compiler/codeGen/CgExpr.lhs40
-rw-r--r--ghc/compiler/codeGen/ClosureInfo.lhs19
-rw-r--r--ghc/compiler/codeGen/CodeGen.lhs16
3 files changed, 36 insertions, 39 deletions
diff --git a/ghc/compiler/codeGen/CgExpr.lhs b/ghc/compiler/codeGen/CgExpr.lhs
index 7f01cd99f4..a47eb92b50 100644
--- a/ghc/compiler/codeGen/CgExpr.lhs
+++ b/ghc/compiler/codeGen/CgExpr.lhs
@@ -1,7 +1,7 @@
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgExpr.lhs,v 1.41 2001/02/20 09:38:59 simonpj Exp $
+% $Id: CgExpr.lhs,v 1.42 2001/03/13 12:50:30 simonmar Exp $
%
%********************************************************
%* *
@@ -208,14 +208,14 @@ cgExpr (StgCase expr live_vars save_vars bndr srt alts)
\subsection[let-and-letrec-codegen]{Converting @StgLet@ and @StgLetrec@}
\begin{code}
-cgExpr (StgLet (StgNonRec name rhs) expr)
- = cgRhs name rhs `thenFC` \ (name, info) ->
+cgExpr (StgLet (StgNonRec srt name rhs) expr)
+ = cgRhs srt name rhs `thenFC` \ (name, info) ->
addBindC name info `thenC`
cgExpr expr
-cgExpr (StgLet (StgRec pairs) expr)
+cgExpr (StgLet (StgRec srt pairs) expr)
= fixC (\ new_bindings -> addBindsC new_bindings `thenC`
- listFCs [ cgRhs b e | (b,e) <- pairs ]
+ listFCs [ cgRhs srt b e | (b,e) <- pairs ]
) `thenFC` \ new_bindings ->
addBindsC new_bindings `thenC`
@@ -274,17 +274,15 @@ We rely on the support code in @CgCon@ (to do constructors) and
in @CgClosure@ (to do closures).
\begin{code}
-cgRhs :: Id -> StgRhs -> FCode (Id, CgIdInfo)
+cgRhs :: SRT -> Id -> StgRhs -> FCode (Id, CgIdInfo)
-- the Id is passed along so a binding can be set up
-cgRhs name (StgRhsCon maybe_cc con args)
+cgRhs srt name (StgRhsCon maybe_cc con args)
= getArgAmodes args `thenFC` \ amodes ->
buildDynCon name maybe_cc con amodes `thenFC` \ idinfo ->
returnFC (name, idinfo)
-cgRhs name (StgRhsClosure cc bi srt@(NoSRT) fvs upd_flag args body)
- = mkRhsClosure name cc bi srt fvs upd_flag args body
-cgRhs name (StgRhsClosure cc bi srt@(SRT _ _) fvs upd_flag args body)
+cgRhs srt name (StgRhsClosure cc bi fvs upd_flag args body)
= mkRhsClosure name cc bi srt fvs upd_flag args body
\end{code}
@@ -391,17 +389,19 @@ mkRhsClosure bndr cc bi srt fvs upd_flag args body
%* *
%********************************************************
\begin{code}
-cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot (StgNonRec binder rhs)
+cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot
+ (StgNonRec srt binder rhs)
= cgLetNoEscapeRhs live_in_rhss rhs_eob_info maybe_cc_slot
- NonRecursive binder rhs
+ NonRecursive srt binder rhs
`thenFC` \ (binder, info) ->
addBindC binder info
-cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot (StgRec pairs)
+cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot
+ (StgRec srt pairs)
= fixC (\ new_bindings ->
addBindsC new_bindings `thenC`
listFCs [ cgLetNoEscapeRhs full_live_in_rhss
- rhs_eob_info maybe_cc_slot Recursive b e
+ rhs_eob_info maybe_cc_slot Recursive srt b e
| (b,e) <- pairs ]
) `thenFC` \ new_bindings ->
@@ -416,25 +416,27 @@ cgLetNoEscapeRhs
-> EndOfBlockInfo
-> Maybe VirtualSpOffset
-> RecFlag
+ -> SRT
-> Id
-> StgRhs
-> FCode (Id, CgIdInfo)
-cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec binder
- (StgRhsClosure cc bi srt _ upd_flag args body)
+cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec srt binder
+ (StgRhsClosure cc bi _ upd_flag args body)
= -- We could check the update flag, but currently we don't switch it off
-- for let-no-escaped things, so we omit the check too!
-- case upd_flag of
-- Updatable -> panic "cgLetNoEscapeRhs" -- Nothing to update!
-- other -> cgLetNoEscapeClosure binder cc bi live_in_whole_let live_in_rhss args body
- cgLetNoEscapeClosure binder cc bi srt full_live_in_rhss rhs_eob_info maybe_cc_slot rec args body
+ cgLetNoEscapeClosure binder cc bi srt full_live_in_rhss rhs_eob_info
+ maybe_cc_slot rec args body
-- For a constructor RHS we want to generate a single chunk of code which
-- can be jumped to from many places, which will return the constructor.
-- It's easy; just behave as if it was an StgRhsClosure with a ConApp inside!
-cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec binder
+cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec srt binder
(StgRhsCon cc con args)
- = cgLetNoEscapeClosure binder cc noBinderInfo{-safe-} NoSRT
+ = cgLetNoEscapeClosure binder cc noBinderInfo{-safe-} srt
full_live_in_rhss rhs_eob_info maybe_cc_slot rec
[] --No args; the binder is data structure, not a function
(StgConApp con args)
diff --git a/ghc/compiler/codeGen/ClosureInfo.lhs b/ghc/compiler/codeGen/ClosureInfo.lhs
index d1a40acb24..467f44b036 100644
--- a/ghc/compiler/codeGen/ClosureInfo.lhs
+++ b/ghc/compiler/codeGen/ClosureInfo.lhs
@@ -1,7 +1,7 @@
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: ClosureInfo.lhs,v 1.45 2001/02/20 09:38:59 simonpj Exp $
+% $Id: ClosureInfo.lhs,v 1.46 2001/03/13 12:50:30 simonmar Exp $
%
\section[ClosureInfo]{Data structures which describe closures}
@@ -79,7 +79,7 @@ import CLabel ( CLabel, mkStdEntryLabel, mkFastEntryLabel,
import CmdLineOpts ( opt_SccProfilingOn, opt_OmitBlackHoling,
opt_Parallel, opt_DoTickyProfiling,
opt_SMP )
-import Id ( Id, idType, idArityInfo )
+import Id ( Id, idType, idCgArity )
import DataCon ( DataCon, dataConTag, fIRST_TAG, dataConTyCon,
isNullaryDataCon, dataConName
)
@@ -261,16 +261,11 @@ mkLFLetNoEscape = LFLetNoEscape
mkLFImported :: Id -> LambdaFormInfo
mkLFImported id
- = case idArityInfo id of
- ArityExactly 0 -> LFThunk (idType id)
- TopLevel True{-no fvs-}
- True{-updatable-} NonStandardThunk
- (error "mkLFImported: no srt label")
- (error "mkLFImported: no srt")
- ArityExactly n -> LFReEntrant (idType id) TopLevel n True -- n > 0
- (error "mkLFImported: no srt label")
- (error "mkLFImported: no srt")
- other -> LFImported -- Not sure of exact arity
+ = case idCgArity id of
+ n | n > 0 -> LFReEntrant (idType id) TopLevel n True -- n > 0
+ (error "mkLFImported: no srt label")
+ (error "mkLFImported: no srt")
+ other -> LFImported -- Not sure of exact arity
\end{code}
%************************************************************************
diff --git a/ghc/compiler/codeGen/CodeGen.lhs b/ghc/compiler/codeGen/CodeGen.lhs
index bf6177df7f..5db06d0bb4 100644
--- a/ghc/compiler/codeGen/CodeGen.lhs
+++ b/ghc/compiler/codeGen/CodeGen.lhs
@@ -188,7 +188,7 @@ variable.
\begin{code}
cgTopBinding :: (StgBinding,[Id]) -> Code
-cgTopBinding (StgNonRec id rhs, srt)
+cgTopBinding (StgNonRec srt_info id rhs, srt)
= absC maybeSplitCode `thenC`
maybeGlobaliseId id `thenFC` \ id' ->
let
@@ -196,11 +196,11 @@ cgTopBinding (StgNonRec id rhs, srt)
in
mkSRT srt_label srt [] `thenC`
setSRTLabel srt_label (
- cgTopRhs id' rhs `thenFC` \ (id, info) ->
+ cgTopRhs id' rhs srt_info `thenFC` \ (id, info) ->
addBindC id info
)
-cgTopBinding (StgRec pairs, srt)
+cgTopBinding (StgRec srt_info pairs, srt)
= absC maybeSplitCode `thenC`
let
(bndrs, rhss) = unzip pairs
@@ -214,7 +214,7 @@ cgTopBinding (StgRec pairs, srt)
setSRTLabel srt_label (
fixC (\ new_binds ->
addBindsC new_binds `thenC`
- mapFCs ( \ (b,e) -> cgTopRhs b e ) pairs'
+ mapFCs ( \ (b,e) -> cgTopRhs b e srt_info ) pairs'
) `thenFC` \ new_binds -> nopC
)
@@ -256,18 +256,18 @@ maybeSplitCode
-- to enclose the listFCs in cgTopBinding, but that tickled the
-- statics "error" call in initC. I DON'T UNDERSTAND WHY!
-cgTopRhs :: Id -> StgRhs -> FCode (Id, CgIdInfo)
+cgTopRhs :: Id -> StgRhs -> SRT -> FCode (Id, CgIdInfo)
-- the Id is passed along for setting up a binding...
-cgTopRhs bndr (StgRhsCon cc con args)
+cgTopRhs bndr (StgRhsCon cc con args) srt
= maybeGlobaliseId bndr `thenFC` \ bndr' ->
forkStatics (cgTopRhsCon bndr con args)
-cgTopRhs bndr (StgRhsClosure cc bi srt fvs upd_flag args body)
+cgTopRhs bndr (StgRhsClosure cc bi fvs upd_flag args body) srt
= -- There should be no free variables
ASSERT(null fvs)
-- If the closure is a thunk, then the binder must be recorded as such.
- ASSERT2(not (isUpdatable upd_flag) || mayHaveCafRefs (idCafInfo bndr), ppr bndr)
+-- ASSERT2(not (isUpdatable upd_flag) || mayHaveCafRefs (idCafInfo bndr), ppr bndr)
getSRTLabel `thenFC` \srt_label ->
let lf_info =
View Lorry Controller Status