X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FbasicTypes%2FMkId.lhs;h=78211445a515158118b9333292af2ba725d59552;hb=c58414c7fc6c259945c457c24f5992af1230a824;hp=33482feff91a8d6c94346ae95e6fa9365471c6a3;hpb=d5bba9ee196f64a077e922680b16fe6f28fb79db;p=ghc-hetmet.git diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs index 33482fe..7821144 100644 --- a/compiler/basicTypes/MkId.lhs +++ b/compiler/basicTypes/MkId.lhs @@ -21,11 +21,12 @@ module MkId ( mkPrimOpId, mkFCallId, mkReboxingAlt, wrapNewTypeBody, unwrapNewTypeBody, + mkUnpackCase, mkProductBox, -- And some particular Ids; see below for why they are wired in wiredInIds, ghcPrimIds, unsafeCoerceId, realWorldPrimId, voidArgId, nullAddrId, seqId, - lazyId, lazyIdUnfolding, lazyIdKey, + lazyId, lazyIdUnfolding, lazyIdKey, mkRuntimeErrorApp, rEC_CON_ERROR_ID, iRREFUT_PAT_ERROR_ID, rUNTIME_ERROR_ID, @@ -45,8 +46,10 @@ import TysPrim ( openAlphaTyVars, alphaTyVar, alphaTy, ) import TysWiredIn ( charTy, mkListTy ) import PrelRules ( primOpRules ) -import Type ( TyThing(..), mkForAllTy, tyVarsOfTypes ) -import Coercion ( mkSymCoercion, mkUnsafeCoercion ) +import Type ( TyThing(..), mkForAllTy, tyVarsOfTypes, newTyConInstRhs, coreEqType, + mkTopTvSubst, substTyVar ) +import Coercion ( mkSymCoercion, mkUnsafeCoercion, + splitNewTypeRepCo_maybe ) import TcType ( Type, ThetaType, mkDictTy, mkPredTys, mkPredTy, mkTyConApp, mkTyVarTys, mkClassPred, mkFunTys, mkFunTy, mkSigmaTy, tcSplitSigmaTy, @@ -60,7 +63,7 @@ import TyCon ( TyCon, isNewTyCon, tyConDataCons, FieldLabel, tyConStupidTheta, isProductTyCon, isDataTyCon, isRecursiveTyCon, newTyConCo, tyConArity ) import Class ( Class, classTyCon, classSelIds ) -import Var ( Id, TyVar, Var ) +import Var ( Id, TyVar, Var, setIdType ) import VarSet ( isEmptyVarSet, subVarSet, varSetElems ) import Name ( mkFCallName, mkWiredInName, Name, BuiltInSyntax(..) ) import OccName ( mkOccNameFS, varName ) @@ -68,14 +71,14 @@ import PrimOp ( PrimOp, primOpSig, primOpOcc, primOpTag ) import ForeignCall ( ForeignCall ) import DataCon ( DataCon, DataConIds(..), dataConTyCon, dataConUnivTyVars, dataConFieldLabels, dataConRepArity, dataConResTys, - dataConRepArgTys, dataConRepType, + dataConRepArgTys, dataConRepType, dataConFullSig, dataConSig, dataConStrictMarks, dataConExStricts, splitProductType, isVanillaDataCon, dataConFieldType, - dataConInstOrigArgTys + dataConInstOrigArgTys, deepSplitProductType ) import Id ( idType, mkGlobalId, mkVanillaGlobal, mkSysLocal, mkTemplateLocals, mkTemplateLocalsNum, mkExportedLocalId, - mkTemplateLocal, idName + mkTemplateLocal, idName, mkWildId ) import IdInfo ( IdInfo, noCafIdInfo, setUnfoldingInfo, setArityInfo, setSpecInfo, setCafInfo, @@ -93,7 +96,7 @@ import PrelNames import Util ( dropList, isSingleton ) import Outputable import FastString -import ListSetOps ( assoc ) +import ListSetOps ( assoc, minusList ) \end{code} %************************************************************************ @@ -191,24 +194,28 @@ mkDataConIds wrap_name wkr_name data_con = NewDC nt_wrap_id | any isMarkedStrict all_strict_marks -- Algebraic, needs wrapper + || not (null eq_spec) = AlgDC (Just alg_wrap_id) wrk_id | otherwise -- Algebraic, no wrapper = AlgDC Nothing wrk_id where - (tvs, theta, orig_arg_tys) = dataConSig data_con - tycon = dataConTyCon data_con + (univ_tvs, ex_tvs, eq_spec, theta, orig_arg_tys) = dataConFullSig data_con + tycon = dataConTyCon data_con - dict_tys = mkPredTys theta - all_arg_tys = dict_tys ++ orig_arg_tys - tycon_args = dataConUnivTyVars data_con - result_ty_args = (mkTyVarTys tycon_args) - result_ty = mkTyConApp tycon result_ty_args - - wrap_ty = mkForAllTys tvs (mkFunTys all_arg_tys result_ty) + ----------- Wrapper -------------- -- We used to include the stupid theta in the wrapper's args -- but now we don't. Instead the type checker just injects these -- extra constraints where necessary. + wrap_tvs = (univ_tvs `minusList` map fst eq_spec) ++ ex_tvs + subst = mkTopTvSubst eq_spec + dict_tys = mkPredTys theta + result_ty_args = map (substTyVar subst) univ_tvs + result_ty = mkTyConApp tycon result_ty_args + wrap_ty = mkForAllTys wrap_tvs $ mkFunTys dict_tys $ + mkFunTys orig_arg_tys $ result_ty + -- NB: watch out here if you allow user-written equality + -- constraints in data constructor signatures ----------- Worker (algebraic data types only) -------------- -- The *worker* for the data constructor is the function that @@ -258,7 +265,7 @@ mkDataConIds wrap_name wkr_name data_con -- No existentials on a newtype, but it can have a context -- e.g. newtype Eq a => T a = MkT (...) mkCompulsoryUnfolding $ - mkLams tvs $ Lam id_arg1 $ + mkLams wrap_tvs $ Lam id_arg1 $ wrapNewTypeBody tycon result_ty_args (Var id_arg1) @@ -288,14 +295,16 @@ mkDataConIds wrap_name wkr_name data_con -- we want to see that w is strict in its two arguments alg_unf = mkTopUnfolding $ Note InlineMe $ - mkLams tvs $ + mkLams wrap_tvs $ mkLams dict_args $ mkLams id_args $ foldr mk_case con_app (zip (dict_args ++ id_args) all_strict_marks) i3 [] - con_app i rep_ids = mkApps (Var wrk_id) - (map varToCoreExpr (tvs ++ reverse rep_ids)) + con_app i rep_ids = Var wrk_id `mkTyApps` result_ty_args + `mkVarApps` ex_tvs + `mkTyApps` map snd eq_spec + `mkVarApps` reverse rep_ids (dict_args,i2) = mkLocals 1 dict_tys (id_args,i3) = mkLocals i2 orig_arg_tys @@ -316,14 +325,9 @@ mkDataConIds wrap_name wkr_name data_con Case (Var arg) arg result_ty [(DEFAULT,[], body i (arg:rep_args))] MarkedUnboxed - -> case splitProductType "do_unbox" (idType arg) of - (tycon, tycon_args, con, tys) -> - Case (Var arg) arg result_ty - [(DataAlt con, - con_args, - body i' (reverse con_args ++ rep_args))] - where - (con_args, i') = mkLocals i tys + -> unboxProduct i (Var arg) (idType arg) the_body result_ty + where + the_body i con_args = body i (reverse con_args ++ rep_args) mAX_CPR_SIZE :: Arity mAX_CPR_SIZE = 10 @@ -530,7 +534,7 @@ mkRecordSelId tycon field_label -- NB: A newtype always has a vanilla DataCon; no existentials etc -- res_tys will simply be the dataConUnivTyVars sel_body | isNewTyCon tycon = unwrapNewTypeBody tycon res_tys (Var data_id) - | otherwise = Case (Var data_id) data_id field_tau (default_alt ++ the_alts) + | otherwise = Case (Var data_id) data_id field_ty (default_alt ++ the_alts) mk_result poly_result = mkVarApps (mkVarApps poly_result field_tyvars) field_dict_ids -- We pull the field lambdas to the top, so we need to @@ -563,7 +567,81 @@ mkRecordSelId tycon field_label field_lbls = dataConFieldLabels data_con error_expr = mkRuntimeErrorApp rEC_SEL_ERROR_ID field_tau full_msg - full_msg = showSDoc (sep [text "No match in record selector", ppr sel_id]) + full_msg = showSDoc (sep [text "No match in record selector", ppr sel_id]) + +-- unbox a product type... +-- we will recurse into newtypes, casting along the way, and unbox at the +-- first product data constructor we find. e.g. +-- +-- data PairInt = PairInt Int Int +-- newtype S = MkS PairInt +-- newtype T = MkT S +-- +-- If we have e = MkT (MkS (PairInt 0 1)) and some body expecting a list of +-- ids, we get (modulo int passing) +-- +-- case (e `cast` (sym CoT)) `cast` (sym CoS) of +-- PairInt a b -> body [a,b] +-- +-- The Ints passed around are just for creating fresh locals +unboxProduct :: Int -> CoreExpr -> Type -> (Int -> [Id] -> CoreExpr) -> Type -> CoreExpr +unboxProduct i arg arg_ty body res_ty + = result + where + result = mkUnpackCase the_id arg arg_ty con_args boxing_con rhs + (tycon, tycon_args, boxing_con, tys) = deepSplitProductType "unboxProduct" arg_ty + ([the_id], i') = mkLocals i [arg_ty] + (con_args, i'') = mkLocals i' tys + rhs = body i'' con_args + +mkUnpackCase :: Id -> CoreExpr -> Type -> [Id] -> DataCon -> CoreExpr -> CoreExpr +-- (mkUnpackCase x e args Con body) +-- returns +-- case (e `cast` ...) of bndr { Con args -> body } +-- +-- the type of the bndr passed in is irrelevent +mkUnpackCase bndr arg arg_ty unpk_args boxing_con body + = Case cast_arg (setIdType bndr bndr_ty) (exprType body) [(DataAlt boxing_con, unpk_args, body)] + where + (cast_arg, bndr_ty) = go (idType bndr) arg + go ty arg + | res@(tycon, tycon_args, _, _) <- splitProductType "mkUnpackCase" ty + , isNewTyCon tycon && not (isRecursiveTyCon tycon) + = go (newTyConInstRhs tycon tycon_args) + (unwrapNewTypeBody tycon tycon_args arg) + | otherwise = (arg, ty) + +-- ...and the dual +reboxProduct :: [Unique] -- uniques to create new local binders + -> Type -- type of product to box + -> ([Unique], -- remaining uniques + CoreExpr, -- boxed product + [Id]) -- Ids being boxed into product +reboxProduct us ty + = let + (tycon, tycon_args, pack_con, con_arg_tys) = deepSplitProductType "reboxProduct" ty + + us' = dropList con_arg_tys us + + arg_ids = zipWith (mkSysLocal FSLIT("rb")) us con_arg_tys + + bind_rhs = mkProductBox arg_ids ty + + in + (us', bind_rhs, arg_ids) + +mkProductBox :: [Id] -> Type -> CoreExpr +mkProductBox arg_ids ty + = result_expr + where + (tycon, tycon_args, pack_con, con_arg_tys) = splitProductType "mkProductBox" ty + + result_expr + | isNewTyCon tycon && not (isRecursiveTyCon tycon) + = wrap (mkProductBox arg_ids (newTyConInstRhs tycon tycon_args)) + | otherwise = mkConApp pack_con (map Type tycon_args ++ map Var arg_ids) + + wrap expr = wrapNewTypeBody tycon tycon_args expr -- (mkReboxingAlt us con xs rhs) basically constructs the case @@ -610,21 +688,11 @@ mkReboxingAlt us con args rhs -- Term variable case go (arg:args) (str:stricts) us | isMarkedUnboxed str - = let - ty = idType arg - - (tycon, tycon_args, pack_con, con_arg_tys) - = splitProductType "mkReboxingAlt" ty - - unpacked_args = zipWith (mkSysLocal FSLIT("rb")) us con_arg_tys - (binds, args') = go args stricts (dropList con_arg_tys us) - con_app | isNewTyCon tycon = ASSERT( isSingleton unpacked_args ) - wrapNewTypeBody tycon tycon_args (Var (head unpacked_args)) - -- ToDo: is this right? Jun06 - | otherwise = mkConApp pack_con (map Type tycon_args ++ map Var unpacked_args) - in - (NonRec arg con_app : binds, unpacked_args ++ args') - + = + let (binds, unpacked_args') = go args stricts us' + (us', bind_rhs, unpacked_args) = reboxProduct us (idType arg) + in + (NonRec arg bind_rhs : binds, unpacked_args ++ unpacked_args') | otherwise = let (binds, args') = go args stricts us in (binds, arg:args') @@ -709,35 +777,23 @@ wrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr -- body of the wrapper, namely -- e `cast` CoT [a] -- --- For non-recursive newtypes, GHC currently treats them like type --- synonyms, so no cast is necessary. This function is the only --- place in the compiler that generates +-- If a coercion constructor is prodivided in the newtype, then we use +-- it, otherwise the wrap/unwrap are both no-ops -- wrapNewTypeBody tycon args result_expr --- | isRecursiveTyCon tycon -- Recursive case; use a coerce - = Cast result_expr co --- | otherwise --- = result_expr - where - co = mkTyConApp (newTyConCo tycon) args + | Just co_con <- newTyConCo tycon + = Cast result_expr (mkTyConApp co_con args) + | otherwise + = result_expr unwrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr unwrapNewTypeBody tycon args result_expr --- | isRecursiveTyCon tycon -- Recursive case; use a coerce - = Cast result_expr sym_co --- | otherwise --- = result_expr - where - sym_co = mkSymCoercion co - co = mkTyConApp (newTyConCo tycon) args - --- Old Definition of mkNewTypeBody --- Used for both wrapping and unwrapping ---mkNewTypeBody tycon result_ty result_expr --- | isRecursiveTyCon tycon -- Recursive case; use a coerce --- = Note (Coerce result_ty (exprType result_expr)) result_expr --- | otherwise -- Normal case --- = result_expr + | Just co_con <- newTyConCo tycon + = Cast result_expr (mkSymCoercion (mkTyConApp co_con args)) + | otherwise + = result_expr + + \end{code}