vectoriser: build instance tycons for the PDatas family
authorBen Lippmeier <benl@ouroborus.net>
Mon, 14 Nov 2011 06:12:14 +0000 (17:12 +1100)
committerBen Lippmeier <benl@ouroborus.net>
Mon, 14 Nov 2011 06:12:14 +0000 (17:12 +1100)
compiler/basicTypes/OccName.lhs
compiler/vectorise/Vectorise/Type/PData.hs

index fa86350..9f8f32d 100644 (file)
@@ -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)
index cbc74f5..6b84a1d 100644 (file)
@@ -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])