Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : master
http://hackage.haskell.org/trac/ghc/changeset/21e8413e65397f49852ea54fe543753174c135dd >--------------------------------------------------------------- commit 21e8413e65397f49852ea54fe543753174c135dd Author: Ben Lippmeier <[email protected]> Date: Mon Nov 14 17:12:14 2011 +1100 vectoriser: build instance tycons for the PDatas family >--------------------------------------------------------------- compiler/basicTypes/OccName.lhs | 28 ++++++---- compiler/vectorise/Vectorise/Type/PData.hs | 86 ++++++++++++++++++++++++--- 2 files changed, 93 insertions(+), 21 deletions(-) diff --git a/compiler/basicTypes/OccName.lhs b/compiler/basicTypes/OccName.lhs index fa86350..9f8f32d 100644 --- a/compiler/basicTypes/OccName.lhs +++ b/compiler/basicTypes/OccName.lhs @@ -67,7 +67,8 @@ module OccName ( mkSuperDictSelOcc, mkLocalOcc, mkMethodOcc, mkInstTyTcOcc, mkInstTyCoOcc, mkEqPredCoOcc, mkVectOcc, mkVectTyConOcc, mkVectDataConOcc, mkVectIsoOcc, - mkPDataTyConOcc, mkPDataDataConOcc, + mkPDataTyConOcc, mkPDataDataConOcc, + mkPDatasTyConOcc, mkPDatasDataConOcc, mkPReprTyConOcc, mkPADFunOcc, @@ -638,16 +639,21 @@ mkDataTOcc = mk_simple_deriv varName "$t" mkDataCOcc = mk_simple_deriv varName "$c" -- Vectorisation -mkVectOcc, mkVectTyConOcc, mkVectDataConOcc, mkVectIsoOcc, mkPADFunOcc, mkPReprTyConOcc, - mkPDataTyConOcc, mkPDataDataConOcc :: Maybe String -> OccName -> OccName -mkVectOcc = mk_simple_deriv_with varName "$v" -mkVectTyConOcc = mk_simple_deriv_with tcName "V:" -mkVectDataConOcc = mk_simple_deriv_with dataName "VD:" -mkVectIsoOcc = mk_simple_deriv_with varName "$vi" -mkPADFunOcc = mk_simple_deriv_with varName "$pa" -mkPReprTyConOcc = mk_simple_deriv_with tcName "VR:" -mkPDataTyConOcc = mk_simple_deriv_with tcName "VP:" -mkPDataDataConOcc = mk_simple_deriv_with dataName "VPD:" +mkVectOcc, mkVectTyConOcc, mkVectDataConOcc, mkVectIsoOcc, + mkPADFunOcc, mkPReprTyConOcc, + mkPDataTyConOcc, mkPDataDataConOcc, + mkPDatasTyConOcc, mkPDatasDataConOcc + :: Maybe String -> OccName -> OccName +mkVectOcc = mk_simple_deriv_with varName "$v" +mkVectTyConOcc = mk_simple_deriv_with tcName "V:" +mkVectDataConOcc = mk_simple_deriv_with dataName "VD:" +mkVectIsoOcc = mk_simple_deriv_with varName "$vi" +mkPADFunOcc = mk_simple_deriv_with varName "$pa" +mkPReprTyConOcc = mk_simple_deriv_with tcName "VR:" +mkPDataTyConOcc = mk_simple_deriv_with tcName "VP:" +mkPDatasTyConOcc = mk_simple_deriv_with tcName "VPs:" +mkPDataDataConOcc = mk_simple_deriv_with dataName "VPD:" +mkPDatasDataConOcc = mk_simple_deriv_with dataName "VPDs:" mk_simple_deriv :: NameSpace -> String -> OccName -> OccName mk_simple_deriv sp px occ = mk_deriv sp px (occNameString occ) diff --git a/compiler/vectorise/Vectorise/Type/PData.hs b/compiler/vectorise/Vectorise/Type/PData.hs index cbc74f5..6b84a1d 100644 --- a/compiler/vectorise/Vectorise/Type/PData.hs +++ b/compiler/vectorise/Vectorise/Type/PData.hs @@ -1,4 +1,8 @@ +-- | Build instance tycons for the PData and PDatas type families. +-- +-- TODO: the PData and PDatas cases are very similar. +-- We should be able to factor out the common parts. module Vectorise.Type.PData ( buildPDataTyCon , buildPDatasTyCon ) @@ -20,9 +24,8 @@ import MonadUtils import Control.Monad -buildPDatasTyCon :: TyCon -> TyCon -> SumRepr -> VM TyCon -buildPDatasTyCon = buildPDataTyCon -- error "buildPDatasTyCon: not finished" - +-- buildPDataTyCon ------------------------------------------------------------ +-- | Build the PData instance tycon for a given type constructor. buildPDataTyCon :: TyCon -> TyCon -> SumRepr -> VM TyCon buildPDataTyCon orig_tc vect_tc repr = fixV $ \repr_tc -> @@ -49,10 +52,12 @@ buildPDataTyConRhs orig_name vect_tc repr_tc repr = do data_con <- buildPDataDataCon orig_name vect_tc repr_tc repr return $ DataTyCon { data_cons = [data_con], is_enum = False } + buildPDataDataCon :: Name -> TyCon -> TyCon -> SumRepr -> VM DataCon buildPDataDataCon orig_name vect_tc repr_tc repr - = do dc_name <- mkLocalisedName mkPDataDataConOcc orig_name - comp_tys <- sum_tys repr + = do let tvs = tyConTyVars vect_tc + dc_name <- mkLocalisedName mkPDataDataConOcc orig_name + comp_tys <- mkSumTys mkPDataType repr liftDs $ buildDataCon dc_name False -- not infix @@ -65,22 +70,83 @@ buildPDataDataCon orig_name vect_tc repr_tc repr comp_tys (mkFamilyTyConApp repr_tc (mkTyVarTys tvs)) repr_tc + + +-- buildPDatasTyCon ----------------------------------------------------------- +-- | Build the PDatas instance tycon for a given type constructor. +buildPDatasTyCon :: TyCon -> TyCon -> SumRepr -> VM TyCon +buildPDatasTyCon orig_tc vect_tc repr + = fixV $ \repr_tc -> + do name' <- mkLocalisedName mkPDatasTyConOcc orig_name + rhs <- buildPDatasTyConRhs orig_name vect_tc repr_tc repr + Just pdatas <- builtin pdatasTyCon + + liftDs $ buildAlgTyCon name' + tyvars + [] -- no stupid theta + rhs + rec_flag -- FIXME: is this ok? + False -- not GADT syntax + NoParentTyCon + (Just $ mk_fam_inst pdatas vect_tc) where - tvs = tyConTyVars vect_tc + orig_name = tyConName orig_tc + tyvars = tyConTyVars vect_tc + rec_flag = boolToRecFlag (isRecursiveTyCon vect_tc) + + +buildPDatasTyConRhs :: Name -> TyCon -> TyCon -> SumRepr -> VM AlgTyConRhs +buildPDatasTyConRhs orig_name vect_tc repr_tc repr + = do data_con <- buildPDatasDataCon orig_name vect_tc repr_tc repr + return $ DataTyCon { data_cons = [data_con], is_enum = False } - sum_tys EmptySum = return [] - sum_tys (UnarySum r) = con_tys r + +buildPDatasDataCon :: Name -> TyCon -> TyCon -> SumRepr -> VM DataCon +buildPDatasDataCon orig_name vect_tc repr_tc repr + = do let tvs = tyConTyVars vect_tc + dc_name <- mkLocalisedName mkPDatasDataConOcc orig_name + + let mkPDatasType' t + = mkPDatasType t >>= (\(Just t') -> return t') + + comp_tys <- mkSumTys mkPDatasType' repr + + liftDs $ buildDataCon dc_name + False -- not infix + (map (const HsNoBang) comp_tys) + [] -- no field labels + tvs + [] -- no existentials + [] -- no eq spec + [] -- no context + comp_tys + (mkFamilyTyConApp repr_tc (mkTyVarTys tvs)) + repr_tc + + +-- Utils ---------------------------------------------------------------------- +-- | Flatten a SumRepr into a list of data constructor types. +mkSumTys + :: (Type -> VM Type) + -> SumRepr + -> VM [Type] + +mkSumTys mkTc repr + = sum_tys repr + where + sum_tys EmptySum = return [] + sum_tys (UnarySum r) = con_tys r sum_tys (Sum { repr_sel_ty = sel_ty , repr_cons = cons }) = liftM (sel_ty :) (concatMapM con_tys cons) - con_tys (ConRepr _ r) = prod_tys r + con_tys (ConRepr _ r) = prod_tys r prod_tys EmptyProd = return [] prod_tys (UnaryProd r) = liftM singleton (comp_ty r) prod_tys (Prod { repr_comps = comps }) = mapM comp_ty comps - comp_ty r = mkPDataType (compOrigType r) + comp_ty r = mkTc (compOrigType r) mk_fam_inst :: TyCon -> TyCon -> (TyCon, [Type]) _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
