X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fvectorise%2FVectType.hs;h=878dfab14b42dd03e5c538d628a75ec458d02da5;hb=112780e06ecd41c7469317a08187ea8335ee3c54;hp=6e7557e9e20d9f2214e630a2af2491f137364355;hpb=222415a5b658e737a0a1f2c980c6f80635289f75;p=ghc-hetmet.git diff --git a/compiler/vectorise/VectType.hs b/compiler/vectorise/VectType.hs index 6e7557e..878dfab 100644 --- a/compiler/vectorise/VectType.hs +++ b/compiler/vectorise/VectType.hs @@ -23,8 +23,8 @@ import FamInstEnv ( FamInst, mkLocalFamInst ) import OccName import Id import MkId -import BasicTypes ( StrictnessMark(..), boolToRecFlag, - dfunInlinePragma ) +import BasicTypes ( HsBang(..), boolToRecFlag, + alwaysInlinePragma, dfunInlinePragma ) import Var ( Var, TyVar, varType ) import Name ( Name, getOccName ) import NameEnv @@ -45,13 +45,16 @@ import Data.List ( inits, tails, zipWith4, zipWith5 ) -- ---------------------------------------------------------------------------- -- Types +-- | Vectorise a type constructor. vectTyCon :: TyCon -> VM TyCon vectTyCon tc | isFunTyCon tc = builtin closureTyCon | isBoxedTupleTyCon tc = return tc | isUnLiftedTyCon tc = return tc - | otherwise = maybeCantVectoriseM "Tycon not vectorised:" (ppr tc) - $ lookupTyCon tc + | otherwise + = maybeCantVectoriseM "Tycon not vectorised: " (ppr tc) + $ lookupTyCon tc + vectAndLiftType :: Type -> VM (Type, Type) vectAndLiftType ty | Just ty' <- coreView ty = vectAndLiftType ty' @@ -67,6 +70,7 @@ vectAndLiftType ty (tyvars, mono_ty) = splitForAllTys ty +-- | Vectorise a type. vectType :: Type -> VM Type vectType ty | Just ty' <- coreView ty = vectType ty' vectType (TyVarTy tv) = return $ TyVarTy tv @@ -87,6 +91,7 @@ vectType ty = cantVectorise "Can't vectorise type" (ppr ty) vectAndBoxType :: Type -> VM Type vectAndBoxType ty = vectType ty >>= boxType +-- | Add quantified vars and dictionary parameters to the front of a type. abstractType :: [TyVar] -> [Type] -> Type -> Type abstractType tyvars dicts = mkForAllTys tyvars . mkFunTys dicts @@ -102,6 +107,7 @@ boxType ty case r of Just tycon' -> return $ mkTyConApp tycon' [] Nothing -> return ty + boxType ty = return ty -- ---------------------------------------------------------------------------- @@ -109,14 +115,21 @@ boxType ty = return ty type TyConGroup = ([TyCon], UniqSet TyCon) +-- | Vectorise a type environment. +-- The type environment contains all the type things defined in a module. vectTypeEnv :: TypeEnv -> VM (TypeEnv, [FamInst], [(Var, CoreExpr)]) vectTypeEnv env = do cs <- readGEnv $ mk_map . global_tycons + + -- Split the list of TyCons into the ones we have to vectorise vs the + -- ones we can pass through unchanged. We also pass through algebraic + -- types that use non Haskell98 features, as we don't handle those. let (conv_tcs, keep_tcs) = classifyTyCons cs groups keep_dcs = concatMap tyConDataCons keep_tcs zipWithM_ defTyCon keep_tcs keep_tcs zipWithM_ defDataCon keep_dcs keep_dcs + new_tcs <- vectTyConDecls conv_tcs let orig_tcs = keep_tcs ++ conv_tcs @@ -151,6 +164,7 @@ vectTypeEnv env mk_map env = listToUFM_Directly [(u, getUnique n /= u) | (u,n) <- nameEnvUniqueElts env] +-- | Vectorise some (possibly recursively defined) type constructors. vectTyConDecls :: [TyCon] -> VM [TyCon] vectTyConDecls tcs = fixV $ \tcs' -> do @@ -202,7 +216,7 @@ vectDataCon dc liftDs $ buildDataCon name' False -- not infix - (map (const NotMarkedStrict) arg_tys) + (map (const HsNoBang) arg_tys) [] -- no labelled fields univ_tvs [] -- no existential tvs for now @@ -693,7 +707,7 @@ buildPDataDataCon orig_name vect_tc repr_tc repr liftDs $ buildDataCon dc_name False -- not infix - (map (const NotMarkedStrict) comp_tys) + (map (const HsNoBang) comp_tys) [] -- no field labels tvs [] -- no existentials @@ -789,7 +803,7 @@ vectDataConWorkers orig_tc vect_tc arr_tc raw_worker <- cloneId mkVectOcc orig_worker (exprType body) let vect_worker = raw_worker `setIdUnfolding` - mkInlineRule InlSat body arity + mkInlineRule body (Just arity) defGlobalVar orig_worker vect_worker return (vect_worker, body) where @@ -802,16 +816,16 @@ buildPADict vect_tc prepr_tc arr_tc repr method_ids <- mapM (method args) paMethods pa_tc <- builtin paTyCon - pa_con <- builtin paDataCon + pa_dc <- builtin paDataCon let dict = mkLams (tvs ++ args) - $ mkConApp pa_con + $ mkConApp pa_dc $ Type inst_ty : map (method_call args) method_ids dfun_ty = mkForAllTys tvs $ mkFunTys (map varType args) (mkTyConApp pa_tc [inst_ty]) raw_dfun <- newExportedVar dfun_name dfun_ty - let dfun = raw_dfun `setIdUnfolding` mkDFunUnfolding pa_con method_ids + let dfun = raw_dfun `setIdUnfolding` mkDFunUnfolding dfun_ty (map Var method_ids) `setInlinePragma` dfunInlinePragma hoistBinding dfun dict @@ -830,7 +844,8 @@ buildPADict vect_tc prepr_tc arr_tc repr let body = mkLams (tvs ++ args) expr raw_var <- newExportedVar (method_name name) (exprType body) let var = raw_var - `setIdUnfolding` mkInlineRule InlSat body (length args) + `setIdUnfolding` mkInlineRule body (Just (length args)) + `setInlinePragma` alwaysInlinePragma hoistBinding var body return var @@ -847,8 +862,8 @@ paMethods = [("dictPRepr", buildPRDict), ("fromArrPRepr", buildFromArrPRepr)] -- | Split the given tycons into two sets depending on whether they have to be --- converted (first list) or not (second list). The first argument contains --- information about the conversion status of external tycons: +-- converted (first list) or not (second list). The first argument contains +-- information about the conversion status of external tycons: -- -- * tycons which have converted versions are mapped to True -- * tycons which are not changed by vectorisation are mapped to False