From 43c2b68138397eb08aa386e2818b6cc17e94fd1e Mon Sep 17 00:00:00 2001 From: simonpj Date: Tue, 5 Apr 2005 08:25:07 +0000 Subject: [PATCH] [project @ 2005-04-05 08:25:06 by simonpj] Final wibbles, I hope --- ghc/compiler/basicTypes/DataCon.lhs | 4 ++-- ghc/compiler/basicTypes/Id.lhs | 15 +++++++++++++-- ghc/compiler/basicTypes/OccName.lhs | 2 +- ghc/compiler/deSugar/DsExpr.lhs | 6 +++--- ghc/compiler/hsSyn/HsExpr.lhs | 5 +---- ghc/compiler/typecheck/TcExpr.lhs | 5 ++--- 6 files changed, 22 insertions(+), 15 deletions(-) diff --git a/ghc/compiler/basicTypes/DataCon.lhs b/ghc/compiler/basicTypes/DataCon.lhs index 0f7d74b..cce7cbd 100644 --- a/ghc/compiler/basicTypes/DataCon.lhs +++ b/ghc/compiler/basicTypes/DataCon.lhs @@ -100,10 +100,10 @@ The data con has one or two Ids associated with it: - strict args may be flattened The worker is very like a primop, in that it has no binding. - Newtypes currently do get a worker-Id, but it is never used. + Newtypes have no worker Id - The "wrapper Id", $wC, whose type is exactly what it looks like + The "wrapper Id", $WC, whose type is exactly what it looks like in the source program. It is an ordinary function, and it gets a top-level binding like any other function. diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs index f2c70c3..547ed7a 100644 --- a/ghc/compiler/basicTypes/Id.lhs +++ b/ghc/compiler/basicTypes/Id.lhs @@ -29,7 +29,7 @@ module Id ( isRecordSelector, isPrimOpId, isPrimOpId_maybe, isFCallId, isFCallId_maybe, - isDataConWorkId, isDataConWorkId_maybe, + isDataConWorkId, isDataConWorkId_maybe, idDataCon, isBottomingId, idIsFrom, hasNoBinding, @@ -100,7 +100,7 @@ import IdInfo #ifdef OLD_STRICTNESS import qualified Demand ( Demand ) #endif -import DataCon ( isUnboxedTupleCon ) +import DataCon ( DataCon, isUnboxedTupleCon ) import NewDemand ( Demand, StrictSig, topDmd, topSig, isBottomingSig ) import Name ( Name, OccName, nameIsLocalOrFrom, mkSystemVarName, mkSystemVarNameEncoded, mkInternalName, @@ -273,6 +273,17 @@ isDataConWorkId_maybe id = case globalIdDetails id of DataConWorkId con -> Just con other -> Nothing +idDataCon :: Id -> DataCon +-- Get from either the worker or the wrapper to the DataCon +-- Currently used only in the desugarer +-- INVARIANT: idDataCon (dataConWrapId d) = d +-- (Remember, dataConWrapId can return either the wrapper or the worker.) +idDataCon id = case globalIdDetails id of + DataConWorkId con -> con + DataConWrapId con -> con + other -> pprPanic "idDataCon" (ppr id) + + -- hasNoBinding returns True of an Id which may not have a -- binding, even though it is defined in this module. -- Data constructor workers used to be things of this kind, but diff --git a/ghc/compiler/basicTypes/OccName.lhs b/ghc/compiler/basicTypes/OccName.lhs index fb66916..780bda2 100644 --- a/ghc/compiler/basicTypes/OccName.lhs +++ b/ghc/compiler/basicTypes/OccName.lhs @@ -501,7 +501,7 @@ mk_simple_deriv sp px occ = mk_deriv sp px (occNameString occ) -- Data constructor workers are made by setting the name space -- of the data constructor OccName (which should be a DataName) --- to DataName +-- to VarName mkDataConWorkerOcc datacon_occ = setOccNameSpace varName datacon_occ \end{code} diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs index 9c1bcdf..fe7d1e3 100644 --- a/ghc/compiler/deSugar/DsExpr.lhs +++ b/ghc/compiler/deSugar/DsExpr.lhs @@ -40,7 +40,7 @@ import CoreSyn import CoreUtils ( exprType, mkIfThenElse, bindNonRec ) import CostCentre ( mkUserCC ) -import Id ( Id, idType, idName, isDataConWorkId_maybe ) +import Id ( Id, idType, idName, idDataCon ) import PrelInfo ( rEC_CON_ERROR_ID, iRREFUT_PAT_ERROR_ID ) import DataCon ( DataCon, dataConWrapId, dataConFieldLabels, dataConInstOrigArgTys ) import DataCon ( isVanillaDataCon ) @@ -421,8 +421,8 @@ dsExpr (RecordCon (L _ data_con_id) con_expr rbinds) [] -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (showSDoc (ppr lbl)) unlabelled_bottom arg_ty = mkErrorAppDs rEC_CON_ERROR_ID arg_ty "" - labels = dataConFieldLabels (fromJust (isDataConWorkId_maybe data_con_id)) - -- The data_con_id is guaranteed to be the work id of the constructor + labels = dataConFieldLabels (idDataCon data_con_id) + -- The data_con_id is guaranteed to be the wrapper id of the constructor in (if null labels diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs index 7327436..de3ae9e 100644 --- a/ghc/compiler/hsSyn/HsExpr.lhs +++ b/ghc/compiler/hsSyn/HsExpr.lhs @@ -104,9 +104,6 @@ data HsExpr id Fixity -- Renamer adds fixity; bottom until then (LHsExpr id) -- right operand - -- We preserve prefix negation and parenthesis for the precedence parser. - -- They are eventually removed by the type checker. - | NegApp (LHsExpr id) -- negated expr (SyntaxExpr id) -- Name of 'negate' @@ -153,7 +150,7 @@ data HsExpr id -- Record construction | RecordCon (Located id) -- The constructor. After type checking - -- it's the *worker* Id of the constructor + -- it's the dataConWrapId of the constructor PostTcExpr -- Data con Id applied to type args (HsRecordBinds id) diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index c509c67..6d441b2 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -49,7 +49,7 @@ import Kind ( openTypeKind, liftedTypeKind, argTypeKind ) import Id ( idType, recordSelectorFieldLabel, isRecordSelector ) import DataCon ( DataCon, dataConFieldLabels, dataConStrictMarks, - dataConWrapId, dataConWorkId ) + dataConWrapId ) import Name ( Name ) import TyCon ( TyCon, FieldLabel, tyConTyVars, tyConStupidTheta, tyConDataCons, tyConFields ) @@ -381,7 +381,7 @@ tcExpr expr@(RecordCon con@(L loc con_name) _ rbinds) res_ty -- Check for missing fields checkMissingFields data_con rbinds `thenM_` - returnM (RecordCon (L loc (dataConWorkId data_con)) con_expr rbinds') + returnM (RecordCon (L loc (dataConWrapId data_con)) con_expr rbinds') -- The main complication with RecordUpd is that we need to explicitly -- handle the *non-updated* fields. Consider: @@ -791,7 +791,6 @@ tcId orig id_name -- Look up the Id and instantiate its type -> do { checkProcLevel id proc_level ; tc_local_id id th_level } - -- THis ; other -> failWithTc (ppr other <+> ptext SLIT("used where a value identifer was expected")) } where -- 1.7.10.4