Commit 4a1e12a1 authored by simonpj's avatar simonpj
Browse files

[project @ 2001-10-03 13:58:13 by simonpj]

----------------------------------------------
	Output curried functions for data constructors
	----------------------------------------------
			(incomplete)

The idea here is to output code for the *curried* version of
the worker of a data constructor, so that the worker can be
treated as a first-class citizen elsewhere in the compiler.
In particular, it doesn't need to be a "hasNoBinding" thing,
which are the subject of a number of nasty hacks.

These changes only do the business for the code gen route
via AbstractC.  Remaining to do: the byte code generator.

Idea: move the byte-code gen to STG code, and inject the
curried data-constructor workers at the STG stage.


	I hope the changes here won't make
	anything stop working.  For now, constructor
	workers remain "hasNoBinding" things.

CgConTbls, CodeGen, CoreTidy, CoreToStg
parent b4623557
......@@ -9,16 +9,23 @@ module CgConTbls ( genStaticConBits ) where
#include "HsVersions.h"
import AbsCSyn
import StgSyn
import CgMonad
import AbsCUtils ( mkAbstractCs, mkAbsCStmts )
import CostCentre ( noCCS )
import CgCon ( cgTopRhsCon )
import CgClosure ( cgTopRhsClosure )
import CgTailCall ( performReturn, mkStaticAlgReturnCode )
import ClosureInfo ( layOutStaticConstr, layOutDynConstr, ClosureInfo )
import DataCon ( DataCon, dataConName, dataConRepArgTys, isNullaryDataCon )
import ClosureInfo ( layOutStaticConstr, layOutDynConstr, mkClosureLFInfo, ClosureInfo )
import DataCon ( DataCon, dataConName, dataConRepArgTys, dataConId, isNullaryDataCon )
import Id ( mkTemplateLocals )
import Name ( getOccName )
import OccName ( occNameUserString )
import TyCon ( tyConDataCons, isEnumerationTyCon, TyCon )
import Type ( typePrimRep )
import BasicTypes ( TopLevelFlag(..) )
import Outputable
\end{code}
For every constructor we generate the following info tables:
......@@ -75,19 +82,22 @@ genStaticConBits comp_info gen_tycons
-- C labels are local to this module i.e. static
-- since they may be duplicated in other modules
mkAbstractCs [ gen_for_tycon tc | tc <- gen_tycons ]
mkAbstractCs [ gen_for_tycon tc `mkAbsCStmts` enum_closure_table tc
| tc <- gen_tycons ]
where
gen_for_tycon :: TyCon -> AbstractC
gen_for_tycon tycon
= mkAbstractCs (map (genConInfo comp_info tycon) (tyConDataCons tycon))
`mkAbsCStmts` (
-- after the con decls, so we don't need to declare the constructor labels
if (isEnumerationTyCon tycon)
then CClosureTbl tycon
else AbsCNop
)
gen_for_tycon tycon = mkAbstractCs [ genConInfo comp_info data_con
| data_con <- tyConDataCons tycon ]
enum_closure_table tycon
| isEnumerationTyCon tycon = CClosureTbl tycon
| otherwise = AbsCNop
-- Put the table after the data constructor decls, because the
-- datatype closure table (for enumeration types)
-- to (say) PrelBase_$wTrue_closure, which is defined in code_stuff
\end{code}
%************************************************************************
%* *
\subsection[CgConTbls-info-tables]{Generating info tables for constructors}
......@@ -98,14 +108,14 @@ Generate the entry code, info tables, and (for niladic constructor) the
static closure, for a constructor.
\begin{code}
genConInfo :: CompilationInfo -> TyCon -> DataCon -> AbstractC
genConInfo :: CompilationInfo -> DataCon -> AbstractC
genConInfo comp_info tycon data_con
= mkAbstractCs [
CSplitMarker,
genConInfo comp_info data_con
= -- Order of things is to reduce forward references
mkAbstractCs [CSplitMarker,
closure_code,
static_code]
-- Order of things is to reduce forward references
static_code,
wrkr_code]
where
(closure_info, body_code) = mkConCodeAndInfo data_con
......@@ -114,10 +124,11 @@ genConInfo comp_info tycon data_con
-- info-table contains the information we need.
(static_ci,_) = layOutStaticConstr con_name data_con typePrimRep arg_tys
body = (initC comp_info (
body = initC comp_info (
profCtrC SLIT("TICK_ENT_CON") [CReg node] `thenC`
body_code))
body_code)
wrkr_code = initC comp_info (cgWorker data_con `thenFC` \ _ -> returnFC ())
con_descr = occNameUserString (getOccName data_con)
-- Don't need any dynamic closure code for zero-arity constructors
......@@ -158,3 +169,27 @@ mkConCodeAndInfo con
in
(closure_info, body_code)
\end{code}
For a constructor C, make a binding
$wC = \x y -> $wC x y
i.e. a curried constructor that allocates. This means that we can treat
the worker for a constructor like any other function in the rest of the compiler.
\begin{code}
cgWorker data_con
| isNullaryDataCon data_con
= cgTopRhsCon work_id data_con []
| otherwise
= cgTopRhsClosure work_id
noCCS noBinderInfo NoSRT
arg_ids rhs
lf_info
where
work_id = dataConId data_con
arg_ids = mkTemplateLocals (dataConRepArgTys data_con)
rhs = StgConApp data_con [StgVarArg id | id <- arg_ids]
lf_info = mkClosureLFInfo work_id TopLevel [{-no fvs-}] ReEntrant arg_ids
\end{code}
......@@ -92,7 +92,6 @@ codeGen dflags mod_name imported_modules cost_centre_info fe_binders
}
where
data_tycons = filter isDataTyCon tycons
cinfo = MkCompInfo mod_name
\end{code}
......@@ -229,7 +228,7 @@ mkSRT lbl ids these
`thenFC` \ (id, _, _) -> returnFC id
(id':_) -> returnFC id'
-- if we're splitting the object, we need to globalise all the top-level names
-- If we're splitting the object, we need to globalise all the top-level names
-- (and then make sure we only use the globalised one in any C label we use
-- which refers to this name).
maybeGlobaliseId :: Id -> FCode Id
......
......@@ -23,7 +23,7 @@ import Var ( Id, Var )
import Id ( idType, idInfo, idName, isExportedId,
idSpecialisation, idUnique, isDataConWrapId,
mkVanillaGlobal, mkGlobalId, isLocalId,
hasNoBinding, mkUserLocal, isGlobalId, globalIdDetails,
isDataConId, mkUserLocal, isGlobalId, globalIdDetails,
idNewDemandInfo, setIdNewDemandInfo,
idNewStrictness_maybe, setIdNewStrictness
)
......@@ -224,9 +224,9 @@ mkFinalTypeEnv type_env final_ids
-- in interface files, because they are needed by importing modules when
-- using the compilation manager
-- We keep "hasNoBinding" Ids, notably constructor workers,
-- We keep constructor workers,
-- because they won't appear in the bindings from which final_ids are derived!
keep_it (AnId id) = hasNoBinding id -- Remove all Ids except constructor workers
keep_it (AnId id) = isDataConId id -- Remove all Ids except constructor workers
keep_it other = True -- Keep all TyCons and Classes
\end{code}
......
......@@ -501,11 +501,14 @@ coreToStgApp maybe_thunk_body f args
-- NB: f_arity is only consulted for LetBound things
f_arity = case how_bound of
LetBound _ arity -> arity
ImportBound -> idArity f
saturated = f_arity <= n_val_args
fun_occ
| not_letrec_bound = noBinderInfo -- Uninteresting variable
| f_arity > 0 && f_arity <= n_val_args = stgSatOcc -- Saturated or over-saturated function call
| otherwise = stgUnsatOcc -- Unsaturated function or thunk
| not_letrec_bound = noBinderInfo -- Uninteresting variable
| f_arity > 0 && saturated = stgSatOcc -- Saturated or over-saturated function call
| otherwise = stgUnsatOcc -- Unsaturated function or thunk
fun_escs
| not_letrec_bound = emptyVarSet -- Only letrec-bound escapees are interesting
......@@ -528,10 +531,12 @@ coreToStgApp maybe_thunk_body f args
res_ty = exprType (mkApps (Var f) args)
app = case globalIdDetails f of
DataConId dc -> StgConApp dc args'
PrimOpId op -> StgOpApp (StgPrimOp op) args' res_ty
FCallId call -> StgOpApp (StgFCallOp call (idUnique f)) args' res_ty
_other -> StgApp f args'
DataConId dc | saturated -> StgConApp dc args'
PrimOpId op -> ASSERT( saturated )
StgOpApp (StgPrimOp op) args' res_ty
FCallId call -> ASSERT( saturated )
StgOpApp (StgFCallOp call (idUnique f)) args' res_ty
_other -> StgApp f args'
in
returnLne (
......@@ -813,15 +818,9 @@ unitLiveCaf caf = (emptyVarSet, unitVarSet caf)
addLiveVar :: LiveInfo -> Id -> LiveInfo
addLiveVar (lvs, cafs) id = (lvs `extendVarSet` id, cafs)
deleteLiveVar :: LiveInfo -> Id -> LiveInfo
deleteLiveVar (lvs, cafs) id = (lvs `delVarSet` id, cafs)
unionLiveInfo :: LiveInfo -> LiveInfo -> LiveInfo
unionLiveInfo (lv1,caf1) (lv2,caf2) = (lv1 `unionVarSet` lv2, caf1 `unionVarSet` caf2)
unionLiveInfos :: [LiveInfo] -> LiveInfo
unionLiveInfos lvs = foldr unionLiveInfo emptyLiveInfo lvs
mkSRT :: LiveInfo -> SRT
mkSRT (_, cafs) = SRTEntries cafs
......@@ -940,10 +939,13 @@ type FreeVarsInfo = VarEnv (Var, HowBound, StgBinderInfo)
-- we look up just once when we encounter the occurrence.
-- INVARIANT: Any ImportBound Ids are HaveCafRef Ids
-- Imported Ids without CAF refs are simply
-- not put in the FreeVarsInfo for an expression;
-- see singletonFVInfo
-- not put in the FreeVarsInfo for an expression.
-- See singletonFVInfo and freeVarsToLiveVars
--
-- StgBinderInfo
-- StgBinderInfo records how it occurs; notably, we
-- are interested in whether it only occurs in saturated
-- applications, because then we don't need to build a
-- curried version.
-- If f is mapped to noBinderInfo, that means
-- that f *is* mentioned (else it wouldn't be in the
-- IdEnv at all), but perhaps in an unsaturated applications.
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment