intPrimTy, realWorldStatePrimTy
)
import TysWiredIn ( boolTy, charTy, mkListTy )
-import PrelMods ( pREL_ERR, pREL_GHC )
+import PrelNames ( pREL_ERR, pREL_GHC )
import PrelRules ( primOpRule )
import Rules ( addRule )
import Type ( Type, ClassContext, mkDictTy, mkDictTys, mkTyConApp, mkTyVarTys,
splitFunTys, splitForAllTys, unUsgTy,
mkUsgTy, UsageAnn(..)
)
-import PprType ( pprParendType )
import Module ( Module )
-import CoreUtils ( mkInlineMe )
+import CoreUtils ( exprType, mkInlineMe )
import CoreUnfold ( mkTopUnfolding, mkCompulsoryUnfolding, mkOtherCon )
+import Literal ( Literal(..) )
import Subst ( mkTopTyVarSubst, substClasses )
import TyCon ( TyCon, isNewTyCon, tyConTyVars, tyConDataCons, isDataTyCon,
tyConTheta, isProductTyCon, isUnboxedTupleTyCon )
primOpSig, mkPrimOpIdName,
CCall, pprCCallOp
)
-import Demand ( wwStrict, wwPrim )
+import Demand ( wwStrict, wwPrim, mkStrictnessInfo )
import DataCon ( DataCon, StrictnessMark(..),
dataConFieldLabels, dataConRepArity, dataConTyCon,
dataConArgTys, dataConRepType, dataConRepStrictness,
)
import CoreSyn
import Maybes
-import BasicTypes ( Arity )
import Unique
import Maybe ( isJust )
import Outputable
import Util ( assoc )
-import List ( nub )
+import UnicodeUtil ( stringToUtf8 )
+import Char ( ord )
\end{code}
arity = dataConRepArity data_con
- strict_info = StrictnessInfo (dataConRepStrictness data_con) False
+ strict_info = mkStrictnessInfo (dataConRepStrictness data_con, False)
cpr_info | isProductTyCon tycon &&
not (isUnboxedTupleTyCon tycon) &&
wrap_rhs | isNewTyCon tycon
= ASSERT( null ex_tyvars && null ex_dict_args && length orig_arg_tys == 1 )
- -- No existentials on a newtype, but it can have a contex
+ -- No existentials on a newtype, but it can have a context
-- e.g. newtype Eq a => T a = MkT (...)
mkLams tyvars $ mkLams dict_args $ Lam id_arg1 $
MarkedUnboxed con tys ->
Case (Var arg) arg [(DataAlt con, con_args,
body i' (reverse con_args++rep_args))]
- where n_tys = length tys
- (con_args,i') = mkLocals i tys
+ where
+ (con_args,i') = mkLocals i tys
\end{code}
T2 ... x ... -> x
other -> error "..."
+Similarly for newtypes
+
+ newtype N a = MkN { unN :: a->a }
+
+ unN :: N a -> a -> a
+ unN n = coerce (a->a) n
+
+We need to take a little care if the field has a polymorphic type:
+
+ data R = R { f :: forall a. a->a }
+
+Then we want
+
+ f :: forall a. R -> a -> a
+ f = /\ a \ r = case r of
+ R f -> f a
+
+(not f :: R -> forall a. a->a, which gives the type inference mechanism
+problems at call sites)
+
+Similarly for newtypes
+
+ newtype N = MkN { unN :: forall a. a->a }
+
+ unN :: forall a. N -> a -> a
+ unN = /\a -> \n:N -> coerce (a->a) n
+
\begin{code}
-mkRecordSelId tycon field_label
- -- Assumes that all fields with the same field label
- -- have the same type
+mkRecordSelId tycon field_label unpack_id unpackUtf8_id
+ -- Assumes that all fields with the same field label have the same type
+ --
+ -- Annoyingly, we have to pass in the unpackCString# Id, because
+ -- we can't conjure it up out of thin air
= sel_id
where
sel_id = mkId (fieldLabelName field_label) selector_ty info
field_ty = fieldLabelType field_label
- field_name = fieldLabelName field_label
data_cons = tyConDataCons tycon
tyvars = tyConTyVars tycon -- These scope over the types in
-- the FieldLabels of constructors of this type
tycon_theta = tyConTheta tycon -- The context on the data decl
-- eg data (Eq a, Ord b) => T a b = ...
+ (field_tyvars,field_tau) = splitForAllTys field_ty
- data_ty = mkTyConApp tycon (mkTyVarTys tyvars)
+ data_ty = mkTyConApp tycon tyvar_tys
tyvar_tys = mkTyVarTys tyvars
-- Very tiresomely, the selectors are (unnecessarily!) overloaded over
| (DataAlt dc, _, _) <- the_alts]
selector_ty :: Type
- selector_ty = mkForAllTys tyvars $ mkFunTys dict_tys $
- mkFunTy data_ty field_ty
+ selector_ty = mkForAllTys tyvars $ mkForAllTys field_tyvars $
+ mkFunTys dict_tys $ mkFunTy data_ty field_tau
info = mkIdInfo (RecordSelId field_label)
- `setArityInfo` exactArity 1
+ `setArityInfo` exactArity (1 + length dict_tys)
`setUnfoldingInfo` unfolding
`setCafInfo` NoCafRefs
-- ToDo: consider adding further IdInfo
sel_rhs | isNewTyCon tycon = new_sel_rhs
| otherwise = data_sel_rhs
- data_sel_rhs = mkLams tyvars $ mkLams dict_ids $ Lam data_id $
+ data_sel_rhs = mkLams tyvars $ mkLams field_tyvars $
+ mkLams dict_ids $ Lam data_id $
Case (Var data_id) data_id (the_alts ++ default_alt)
- new_sel_rhs = mkLams tyvars $ Lam data_id $
- Note (Coerce (unUsgTy field_ty) (unUsgTy data_ty)) (Var data_id)
+ new_sel_rhs = mkLams tyvars $ mkLams field_tyvars $ Lam data_id $
+ Note (Coerce (unUsgTy field_tau) (unUsgTy data_ty)) (Var data_id)
mk_maybe_alt data_con
= case maybe_the_arg_id of
Nothing -> Nothing
- Just the_arg_id -> Just (DataAlt data_con, arg_ids, Var the_arg_id)
+ Just the_arg_id -> Just (DataAlt data_con, arg_ids,
+ mkVarApps (Var the_arg_id) field_tyvars)
where
arg_ids = mkTemplateLocals (dataConArgTys data_con tyvar_tys)
-- The first one will shadow data_id, but who cares
field_lbls = dataConFieldLabels data_con
maybe_the_arg_id = assocMaybe (field_lbls `zip` arg_ids) field_label
- error_expr = mkApps (Var rEC_SEL_ERROR_ID) [Type (unUsgTy field_ty), mkStringLit full_msg]
+ error_expr = mkApps (Var rEC_SEL_ERROR_ID) [Type (unUsgTy field_tau), err_string]
-- preserves invariant that type args are *not* usage-annotated on top. KSW 1999-04.
+ err_string
+ | all safeChar full_msg
+ = App (Var unpack_id) (Lit (MachStr (_PK_ full_msg)))
+ | otherwise
+ = App (Var unpackUtf8_id) (Lit (MachStr (_PK_ (stringToUtf8 (map ord full_msg)))))
+ where
+ safeChar c = c >= '\1' && c <= '\xFF'
+ -- TODO: Putting this Unicode stuff here is ugly. Find a better
+ -- generic place to make string literals. This logic is repeated
+ -- in DsUtils.
full_msg = showSDoc (sep [text "No match in record selector", ppr sel_id])
\end{code}
ToDo: unify with mkRecordSelId.
\begin{code}
-mkDictSelId name clas ty
+mkDictSelId :: Name -> Class -> Id
+mkDictSelId name clas
= sel_id
where
+ ty = exprType rhs
sel_id = mkId name ty info
- field_lbl = mkFieldLabel name ty tag
+ field_lbl = mkFieldLabel name tycon ty tag
tag = assoc "MkId.mkDictSelId" (classSelIds clas `zip` allFieldLabelTags) sel_id
info = mkIdInfo (RecordSelId field_lbl)
mkDictFunId dfun_name clas inst_tyvars inst_tys inst_decl_theta
= mkVanillaId dfun_name dfun_ty
where
- (class_tyvars, sc_theta, _, _) = classBigSig clas
- sc_theta' = substClasses (mkTopTyVarSubst class_tyvars inst_tys) sc_theta
-
dfun_theta = classesToPreds inst_decl_theta
{- 1 dec 99: disable the Mark Jones optimisation for the sake
of compatibility with Hugs.
See `types/InstEnv' for a discussion related to this.
+ (class_tyvars, sc_theta, _, _) = classBigSig clas
+ not_const (clas, tys) = not (isEmptyVarSet (tyVarsOfTypes tys))
+ sc_theta' = substClasses (mkTopTyVarSubst class_tyvars inst_tys) sc_theta
dfun_theta = case inst_decl_theta of
[] -> [] -- If inst_decl_theta is empty, then we don't
-- want to have any dict arguments, so that we can
-- Now sc_theta' has Foo T
-}
dfun_ty = mkSigmaTy inst_tyvars dfun_theta (mkDictTy clas inst_tys)
-
- not_const (clas, tys) = not (isEmptyVarSet (tyVarsOfTypes tys))
\end{code}
\begin{code}
eRROR_ID
= pc_bottoming_Id errorIdKey pREL_ERR SLIT("error") errorTy
-rEC_SEL_ERROR_ID
- = generic_ERROR_ID recSelErrIdKey SLIT("patError")
pAT_ERROR_ID
= generic_ERROR_ID patErrorIdKey SLIT("patError")
+rEC_SEL_ERROR_ID
+ = generic_ERROR_ID recSelErrIdKey SLIT("recSelError")
rEC_CON_ERROR_ID
= generic_ERROR_ID recConErrorIdKey SLIT("recConError")
rEC_UPD_ERROR_ID
projects / ghc-hetmet.git / blobdiff