From ccd5bdcdd84a4cd4615a6fe57b6870135adf3add Mon Sep 17 00:00:00 2001
From: sof <unknown>
Date: Sun, 18 May 1997 23:12:10 +0000
Subject: [PATCH] [project @ 1997-05-18 23:12:10 by sof] Removed the
attribution of variable arities
---
ghc/compiler/stgSyn/CoreToStg.lhs | 38 ++++++++++---------------------
1 file changed, 12 insertions(+), 26 deletions(-)
diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs
index 7aaefe6c2276..1042d3c1c756 100644
--- a/ghc/compiler/stgSyn/CoreToStg.lhs
+++ b/ghc/compiler/stgSyn/CoreToStg.lhs
@@ -23,12 +23,11 @@ import StgSyn -- output
import Bag ( emptyBag, unitBag, unionBags, unionManyBags, bagToList )
import CoreUtils ( coreExprType )
import CostCentre ( noCostCentre )
-import Id ( mkSysLocal, idType, isBottomingId, addIdArity,
+import Id ( mkSysLocal, idType, isBottomingId,
externallyVisibleId,
nullIdEnv, addOneToIdEnv, lookupIdEnv, growIdEnvList,
- SYN_IE(IdEnv), GenId{-instance NamedThing-}
+ SYN_IE(IdEnv), GenId{-instance NamedThing-}, SYN_IE(Id)
)
-import IdInfo ( ArityInfo, exactArity )
import Literal ( mkMachInt, Literal(..) )
import PrelVals ( unpackCStringId, unpackCString2Id,
integerZeroId, integerPlusOneId,
@@ -38,7 +37,7 @@ import PrimOp ( PrimOp(..) )
import SpecUtils ( mkSpecialisedCon )
import SrcLoc ( noSrcLoc )
import TyCon ( TyCon{-instance Uniquable-} )
-import Type ( maybeAppDataTyCon, getAppDataTyConExpandingDicts )
+import Type ( maybeAppDataTyCon, getAppDataTyConExpandingDicts, SYN_IE(Type) )
import TysWiredIn ( stringTy )
import Unique ( integerTyConKey, ratioTyConKey, Unique{-instance Eq-} )
import UniqSupply -- all of it, really
@@ -63,12 +62,10 @@ The business of this pass is to convert Core to Stg. On the way:
x = y t1 t2
where t1, t2 are types
-* We pin correct arities on each let(rec)-bound binder, and propagate them
- to their uses. This is used
- a) when emitting arity info into interface files
- b) in the code generator, when deciding if a right-hand side
- is a saturated application so we can generate a VAP closure.
- (b) is rather untidy, but the easiest compromise was to propagate arities here.
+* We don't pin on correct arities any more, because they can be mucked up
+ by the lambda lifter. In particular, the lambda lifter can take a local
+ letrec-bound variable and make it a lambda argument, which shouldn't have
+ an arity. So SetStgVarInfo sets arities now.
* We do *not* pin on the correct free/live var info; that's done later.
Instead we use bOGUS_LVS and _FVS as a placeholder.
@@ -137,9 +134,8 @@ coreBindToStg env (NonRec binder rhs)
= coreRhsToStg env rhs `thenUs` \ stg_rhs ->
let
-- Binds to return if RHS is trivial
- binder_w_arity = binder `addIdArity` (rhsArity stg_rhs)
- triv_binds | externallyVisibleId binder = [StgNonRec binder_w_arity stg_rhs] -- Retain it
- | otherwise = [] -- Discard it
+ triv_binds | externallyVisibleId binder = [StgNonRec binder stg_rhs] -- Retain it
+ | otherwise = [] -- Discard it
in
case stg_rhs of
StgRhsClosure cc bi fvs upd [] (StgApp atom [] lvs) ->
@@ -155,10 +151,7 @@ coreBindToStg env (NonRec binder rhs)
new_env = addOneToIdEnv env binder (StgConArg con_id)
other -> -- Non-trivial RHS, so don't augment envt
- returnUs ([StgNonRec binder_w_arity stg_rhs], new_env)
- where
- new_env = addOneToIdEnv env binder (StgVarArg binder_w_arity)
- -- new_env propagates the arity
+ returnUs ([StgNonRec binder stg_rhs], env)
coreBindToStg env (Rec pairs)
= -- NB: *** WE DO NOT CHECK FOR TRIV_BINDS in REC BIND ****
@@ -167,14 +160,7 @@ coreBindToStg env (Rec pairs)
(binders, rhss) = unzip pairs
in
mapUs (coreRhsToStg env) rhss `thenUs` \ stg_rhss ->
- let
- binders_w_arities = [ b `addIdArity` rhsArity rhs
- | (b,rhs) <- binders `zip` stg_rhss]
- in
- returnUs ([StgRec (binders_w_arities `zip` stg_rhss)], env)
-
-rhsArity (StgRhsClosure _ _ _ _ args _) = exactArity (length args)
-rhsArity (StgRhsCon _ _ _) = exactArity 0
+ returnUs ([StgRec (binders `zip` stg_rhss)], env)
\end{code}
@@ -279,7 +265,7 @@ coreExprToStg env expr@(Lam _ _)
else
newStgVar (coreExprType expr) `thenUs` \ var ->
returnUs
- (StgLet (StgNonRec (var `addIdArity` exactArity (length binders))
+ (StgLet (StgNonRec var
(StgRhsClosure noCostCentre
stgArgOcc
bOGUS_FVs
--
GitLab