From 4a1e12a1edfd959c133d922b1adc733c137610d7 Mon Sep 17 00:00:00 2001 From: simonpj Date: Wed, 3 Oct 2001 13:58:13 +0000 Subject: [PATCH] [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 --- ghc/compiler/codeGen/CgConTbls.lhs | 73 ++++++++++++++++++++++++++---------- ghc/compiler/codeGen/CodeGen.lhs | 3 +- ghc/compiler/coreSyn/CoreTidy.lhs | 6 +-- ghc/compiler/stgSyn/CoreToStg.lhs | 34 +++++++++-------- 4 files changed, 76 insertions(+), 40 deletions(-) diff --git a/ghc/compiler/codeGen/CgConTbls.lhs b/ghc/compiler/codeGen/CgConTbls.lhs index 5a2b6be..5b862fd 100644 --- a/ghc/compiler/codeGen/CgConTbls.lhs +++ b/ghc/compiler/codeGen/CgConTbls.lhs @@ -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} diff --git a/ghc/compiler/codeGen/CodeGen.lhs b/ghc/compiler/codeGen/CodeGen.lhs index d6b5d0f..62d10f3 100644 --- a/ghc/compiler/codeGen/CodeGen.lhs +++ b/ghc/compiler/codeGen/CodeGen.lhs @@ -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 diff --git a/ghc/compiler/coreSyn/CoreTidy.lhs b/ghc/compiler/coreSyn/CoreTidy.lhs index 5ba745a..357ba9b 100644 --- a/ghc/compiler/coreSyn/CoreTidy.lhs +++ b/ghc/compiler/coreSyn/CoreTidy.lhs @@ -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} diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs index 3df5a82..659e15d 100644 --- a/ghc/compiler/stgSyn/CoreToStg.lhs +++ b/ghc/compiler/stgSyn/CoreToStg.lhs @@ -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. -- 1.7.10.4