Track specified/invisible more carefully.
[ghc.git] / compiler / vectorise / Vectorise / Generic / PData.hs
index 1026e95..54f5ace 100644 (file)
@@ -5,20 +5,23 @@
 --   We should be able to factor out the common parts.
 module Vectorise.Generic.PData
   ( buildPDataTyCon
-  , buildPDatasTyCon ) 
+  , buildPDatasTyCon )
 where
 
 import Vectorise.Monad
 import Vectorise.Builtins
 import Vectorise.Generic.Description
 import Vectorise.Utils
+import Vectorise.Env( GlobalEnv( global_fam_inst_env ) )
 
 import BasicTypes
 import BuildTyCl
 import DataCon
 import TyCon
 import Type
+import FamInst
 import FamInstEnv
+import TcMType
 import Name
 import Util
 import MonadUtils
@@ -28,7 +31,7 @@ import Control.Monad
 -- buildPDataTyCon ------------------------------------------------------------
 -- | Build the PData instance tycon for a given type constructor.
 buildPDataTyCon :: TyCon -> TyCon -> SumRepr -> VM FamInst
-buildPDataTyCon orig_tc vect_tc repr 
+buildPDataTyCon orig_tc vect_tc repr
  = fixV $ \fam_inst ->
    do let repr_tc = dataFamInstRepTyCon fam_inst
       name' <- mkLocalisedName mkPDataTyConOcc orig_name
@@ -42,17 +45,23 @@ buildDataFamInst :: Name -> TyCon -> TyCon -> AlgTyConRhs -> VM FamInst
 buildDataFamInst name' fam_tc vect_tc rhs
  = do { axiom_name <- mkDerivedName mkInstTyCoOcc name'
 
-      ; let fam_inst = mkDataFamInst axiom_name tyvars fam_tc pat_tys rep_tc
-            ax       = famInstAxiom fam_inst
-            pat_tys  = [mkTyConApp vect_tc (mkTyVarTys tyvars)]
-            rep_tc   = buildAlgTyCon name'
-                           tyvars
+      ; (_, tyvars') <- liftDs $ tcInstSigTyVarsLoc (getSrcSpan name') tyvars
+      ; let ax       = mkSingleCoAxiom Representational axiom_name tyvars' [] fam_tc pat_tys rep_ty
+            tys'     = mkTyVarTys tyvars'
+            rep_ty   = mkTyConApp rep_tc tys'
+            pat_tys  = [mkTyConApp vect_tc tys']
+            rep_tc   = mkAlgTyCon name'
+                           (mkTyBindersPreferAnon tyvars' liftedTypeKind)
+                           liftedTypeKind
+                           tyvars'
+                           (map (const Nominal) tyvars')
+                           Nothing
                            []          -- no stupid theta
                            rhs
+                           (DataFamInstTyCon ax fam_tc pat_tys)
                            rec_flag    -- FIXME: is this ok?
                            False       -- not GADT syntax
-                           (FamInstTyCon ax fam_tc pat_tys)
-      ; return fam_inst }
+      ; liftDs $ newFamInst (DataFamilyInst rep_tc) ax }
  where
     tyvars    = tyConTyVars vect_tc
     rec_flag  = boolToRecFlag (isRecursiveTyCon vect_tc)
@@ -68,24 +77,29 @@ buildPDataDataCon orig_name vect_tc repr_tc repr
  = do let tvs   = tyConTyVars vect_tc
       dc_name   <- mkLocalisedName mkPDataDataConOcc orig_name
       comp_tys  <- mkSumTys repr_sel_ty mkPDataType repr
-
-      liftDs $ buildDataCon dc_name
+      fam_envs  <- readGEnv global_fam_inst_env
+      rep_nm    <- liftDs $ newTyConRepName dc_name
+      liftDs $ buildDataCon fam_envs dc_name
                             False                  -- not infix
-                            (map (const HsNoBang) comp_tys)
+                            rep_nm
+                            (map (const no_bang) comp_tys)
+                            (Just $ map (const HsLazy) comp_tys)
                             []                     -- no field labels
-                            tvs
-                            []                     -- no existentials
+                            tvs (mkNamedBinders Specified tvs)
+                            [] []                  -- no existentials
                             []                     -- no eq spec
                             []                     -- no context
                             comp_tys
                             (mkFamilyTyConApp repr_tc (mkTyVarTys tvs))
                             repr_tc
+  where
+    no_bang = HsSrcBang Nothing NoSrcUnpack NoSrcStrict
 
 
 -- buildPDatasTyCon -----------------------------------------------------------
 -- | Build the PDatas instance tycon for a given type constructor.
 buildPDatasTyCon :: TyCon -> TyCon -> SumRepr -> VM FamInst
-buildPDatasTyCon orig_tc vect_tc repr 
+buildPDatasTyCon orig_tc vect_tc repr
  = fixV $ \fam_inst ->
    do let repr_tc = dataFamInstRepTyCon fam_inst
       name'       <- mkLocalisedName mkPDatasTyConOcc orig_name
@@ -107,23 +121,28 @@ buildPDatasDataCon orig_name vect_tc repr_tc repr
       dc_name        <- mkLocalisedName mkPDatasDataConOcc orig_name
 
       comp_tys  <- mkSumTys repr_sels_ty mkPDatasType repr
-
-      liftDs $ buildDataCon dc_name
+      fam_envs <- readGEnv global_fam_inst_env
+      rep_nm   <- liftDs $ newTyConRepName dc_name
+      liftDs $ buildDataCon fam_envs dc_name
                             False                  -- not infix
-                            (map (const HsNoBang) comp_tys)
+                            rep_nm
+                            (map (const no_bang) comp_tys)
+                            (Just $ map (const HsLazy) comp_tys)
                             []                     -- no field labels
-                            tvs
-                            []                     -- no existentials
+                            tvs (mkNamedBinders Specified tvs)
+                            [] []                  -- no existentials
                             []                     -- no eq spec
                             []                     -- no context
                             comp_tys
                             (mkFamilyTyConApp repr_tc (mkTyVarTys tvs))
                             repr_tc
+  where
+     no_bang = HsSrcBang Nothing NoSrcUnpack NoSrcStrict
 
 
 -- Utils ----------------------------------------------------------------------
 -- | Flatten a SumRepr into a list of data constructor types.
-mkSumTys 
+mkSumTys
         :: (SumRepr -> Type)
         -> (Type -> VM Type)
         -> SumRepr
@@ -149,4 +168,4 @@ mkSumTys repr_selX_ty mkTc repr
 mk_fam_inst :: TyCon -> TyCon -> (TyCon, [Type])
 mk_fam_inst fam_tc arg_tc
   = (fam_tc, [mkTyConApp arg_tc . mkTyVarTys $ tyConTyVars arg_tc])
--}
\ No newline at end of file
+-}