merged master into late-dmdlate-dmd

9 files changed, 33 insertions, 37 deletions

diff --git a/compiler/vectorise/Vectorise/Env.hs b/compiler/vectorise/Vectorise/Env.hs
index 2d415aab36..3358ceafab 100644
--- a/compiler/vectorise/Vectorise/Env.hs
+++ b/compiler/vectorise/Vectorise/Env.hs
@@ -174,7 +174,7 @@ extendImportedVarsEnv ps genv
 
 -- |Extend the list of type family instances.
 --
-extendFamEnv :: [FamInst Unbranched] -> GlobalEnv -> GlobalEnv
+extendFamEnv :: [FamInst] -> GlobalEnv -> GlobalEnv
 extendFamEnv new genv
   = genv { global_fam_inst_env = (g_fam_inst, extendFamInstEnvList l_fam_inst new) }
   where (g_fam_inst, l_fam_inst) = global_fam_inst_env genv
diff --git a/compiler/vectorise/Vectorise/Generic/PADict.hs b/compiler/vectorise/Vectorise/Generic/PADict.hs
index f70e796daa..7e70f2dd11 100644
--- a/compiler/vectorise/Vectorise/Generic/PADict.hs
+++ b/compiler/vectorise/Vectorise/Generic/PADict.hs
@@ -68,37 +68,35 @@ buildPADict vect_tc prepr_ax pdata_tc pdatas_tc repr
                              ; pr_cls <- builtin prClass
                              ; return $ mkClassPred pr_cls [r]
                              }
-      ; super_tys <- sequence [mk_super_ty | not (null tvs)]
+      ; super_tys  <- sequence [mk_super_ty | not (null tvs)]
       ; super_args <- mapM (newLocalVar (fsLit "pr")) super_tys
-      ; let all_args = super_args ++ args
+      ; let val_args = super_args ++ args
+            all_args = tvs ++ val_args
      
           -- ...it is constant otherwise
       ; super_consts <- sequence [prDictOfPReprInstTyCon inst_ty prepr_ax [] | null tvs]
 
           -- Get ids for each of the methods in the dictionary, including superclass
       ; paMethodBuilders <- buildPAScAndMethods
-      ; method_ids       <- mapM (method all_args dfun_name) paMethodBuilders
+      ; method_ids       <- mapM (method val_args dfun_name) paMethodBuilders
 
           -- Expression to build the dictionary.
       ; pa_dc  <- builtin paDataCon
-      ; let dict = mkLams (tvs ++ all_args)
-                 $ mkConApp pa_dc
-                 $ Type inst_ty
-                 : map Var super_args ++ super_consts -- the superclass dictionary is either lambda-bound or constant
-                   ++ map (method_call all_args) method_ids
+      ; let dict = mkLams all_args (mkConApp pa_dc con_args)
+            con_args = Type inst_ty
+                     : map Var super_args  -- the superclass dictionary is either 
+                    ++ super_consts        -- lambda-bound or constant
+                    ++ map (method_call val_args) method_ids
 
           -- Build the type of the dictionary function.
       ; pa_cls <- builtin paClass
       ; let dfun_ty = mkForAllTys tvs
-                    $ mkFunTys (map varType all_args)
+                    $ mkFunTys (map varType val_args)
                                (mkClassPred pa_cls [inst_ty])
 
           -- Set the unfolding for the inliner.
       ; raw_dfun <- newExportedVar dfun_name dfun_ty
-      ; let dfun_unf = mkDFunUnfolding dfun_ty $
-                       map (const $ DFunLamArg 0) super_args
-                       ++ map DFunPolyArg super_consts
-                       ++ map (DFunPolyArg . Var) method_ids
+      ; let dfun_unf = mkDFunUnfolding all_args pa_dc con_args
             dfun = raw_dfun `setIdUnfolding`  dfun_unf
                             `setInlinePragma` dfunInlinePragma
 
diff --git a/compiler/vectorise/Vectorise/Generic/PAMethods.hs b/compiler/vectorise/Vectorise/Generic/PAMethods.hs
index af815c9294..269119c6dd 100644
--- a/compiler/vectorise/Vectorise/Generic/PAMethods.hs
+++ b/compiler/vectorise/Vectorise/Generic/PAMethods.hs
@@ -32,13 +32,13 @@ import Control.Monad
 import Outputable
 
 
-buildPReprTyCon :: TyCon -> TyCon -> SumRepr -> VM (FamInst Unbranched)
+buildPReprTyCon :: TyCon -> TyCon -> SumRepr -> VM FamInst
 buildPReprTyCon orig_tc vect_tc repr
  = do name      <- mkLocalisedName mkPReprTyConOcc (tyConName orig_tc)
       rhs_ty    <- sumReprType repr
       prepr_tc  <- builtin preprTyCon
       let axiom = mkSingleCoAxiom name tyvars prepr_tc instTys rhs_ty
-      liftDs $ newFamInst SynFamilyInst False axiom
+      liftDs $ newFamInst SynFamilyInst axiom
   where
     tyvars = tyConTyVars vect_tc
     instTys = [mkTyConApp vect_tc . mkTyVarTys $ tyConTyVars vect_tc]
@@ -218,7 +218,7 @@ buildToArrPRepr vect_tc repr_co pdata_tc _ r
       pdata_co <- mkBuiltinCo pdataTyCon
       let co           = mkAppCo pdata_co
                        . mkSymCo
-                       $ mkUnbranchedAxInstCo repr_co ty_args
+                       $ mkUnbranchedAxInstCo Nominal repr_co ty_args
 
           scrut   = unwrapFamInstScrut pdata_tc ty_args (Var arg)
 
@@ -282,7 +282,7 @@ buildFromArrPRepr vect_tc repr_co pdata_tc _ r
 
       pdata_co <- mkBuiltinCo pdataTyCon
       let co           = mkAppCo pdata_co
-                       $ mkUnbranchedAxInstCo repr_co var_tys
+                       $ mkUnbranchedAxInstCo Nominal repr_co var_tys
 
       let scrut        = mkCast (Var arg) co
 
@@ -368,7 +368,7 @@ buildToArrPReprs vect_tc repr_co _ pdatas_tc r
     pdatas_co <- mkBuiltinCo pdatasTyCon
     let co           = mkAppCo pdatas_co
                      . mkSymCo
-                     $ mkUnbranchedAxInstCo repr_co ty_args
+                     $ mkUnbranchedAxInstCo Nominal repr_co ty_args
 
     let scrut        = unwrapFamInstScrut pdatas_tc ty_args (Var varg)
     (vars, result)  <- to_sum r
@@ -458,7 +458,7 @@ buildFromArrPReprs vect_tc repr_co _ pdatas_tc r
     -- Build the coercion between PRepr and the instance type
     pdatas_co <- mkBuiltinCo pdatasTyCon
     let co           = mkAppCo pdatas_co
-                     $ mkUnbranchedAxInstCo repr_co var_tys
+                     $ mkUnbranchedAxInstCo Nominal repr_co var_tys
 
     let scrut        = mkCast (Var varg) co
 
diff --git a/compiler/vectorise/Vectorise/Generic/PData.hs b/compiler/vectorise/Vectorise/Generic/PData.hs
index 893f1559be..37358c9bdf 100644
--- a/compiler/vectorise/Vectorise/Generic/PData.hs
+++ b/compiler/vectorise/Vectorise/Generic/PData.hs
@@ -14,7 +14,6 @@ import Vectorise.Generic.Description
 import Vectorise.Utils
 import Vectorise.Env( GlobalEnv( global_fam_inst_env ) )
 
-import Coercion( mkSingleCoAxiom )
 import BasicTypes
 import BuildTyCl
 import DataCon
@@ -31,7 +30,7 @@ import Control.Monad
 
 -- buildPDataTyCon ------------------------------------------------------------
 -- | Build the PData instance tycon for a given type constructor.
-buildPDataTyCon :: TyCon -> TyCon -> SumRepr -> VM (FamInst Unbranched)
+buildPDataTyCon :: TyCon -> TyCon -> SumRepr -> VM FamInst
 buildPDataTyCon orig_tc vect_tc repr 
  = fixV $ \fam_inst ->
    do let repr_tc = dataFamInstRepTyCon fam_inst
@@ -42,7 +41,7 @@ buildPDataTyCon orig_tc vect_tc repr
  where
     orig_name = tyConName orig_tc
 
-buildDataFamInst :: Name -> TyCon -> TyCon -> AlgTyConRhs -> VM (FamInst Unbranched)
+buildDataFamInst :: Name -> TyCon -> TyCon -> AlgTyConRhs -> VM FamInst
 buildDataFamInst name' fam_tc vect_tc rhs
  = do { axiom_name <- mkDerivedName mkInstTyCoOcc name'
 
@@ -53,6 +52,7 @@ buildDataFamInst name' fam_tc vect_tc rhs
             pat_tys  = [mkTyConApp vect_tc tys']
             rep_tc   = buildAlgTyCon name'
                            tyvars'
+                           (map (const Nominal) tyvars')
                            Nothing
                            []          -- no stupid theta
                            rhs
@@ -60,7 +60,7 @@ buildDataFamInst name' fam_tc vect_tc rhs
                            False       -- Not promotable
                            False       -- not GADT syntax
                            (FamInstTyCon ax fam_tc pat_tys)
-      ; liftDs $ newFamInst (DataFamilyInst rep_tc) False ax }
+      ; liftDs $ newFamInst (DataFamilyInst rep_tc) ax }
  where
     tyvars    = tyConTyVars vect_tc
     rec_flag  = boolToRecFlag (isRecursiveTyCon vect_tc)
@@ -92,7 +92,7 @@ buildPDataDataCon orig_name vect_tc repr_tc repr
 
 -- buildPDatasTyCon -----------------------------------------------------------
 -- | Build the PDatas instance tycon for a given type constructor.
-buildPDatasTyCon :: TyCon -> TyCon -> SumRepr -> VM (FamInst Unbranched)
+buildPDatasTyCon :: TyCon -> TyCon -> SumRepr -> VM FamInst
 buildPDatasTyCon orig_tc vect_tc repr 
  = fixV $ \fam_inst ->
    do let repr_tc = dataFamInstRepTyCon fam_inst
diff --git a/compiler/vectorise/Vectorise/Monad/InstEnv.hs b/compiler/vectorise/Vectorise/Monad/InstEnv.hs
index ceb62eef80..84b29ceb61 100644
--- a/compiler/vectorise/Vectorise/Monad/InstEnv.hs
+++ b/compiler/vectorise/Vectorise/Monad/InstEnv.hs
@@ -67,7 +67,7 @@ lookupInst cls tys
 --
 lookupFamInst :: TyCon -> [Type] -> VM FamInstMatch
 lookupFamInst tycon tys
-  = ASSERT( isFamilyTyCon tycon )
+  = ASSERT( isOpenFamilyTyCon tycon )
     do { instEnv <- readGEnv global_fam_inst_env
        ; case lookupFamInstEnv instEnv tycon tys of
            [match] -> return match
diff --git a/compiler/vectorise/Vectorise/Type/Env.hs b/compiler/vectorise/Vectorise/Type/Env.hs
index 0ae0f936b3..34008efbbd 100644
--- a/compiler/vectorise/Vectorise/Type/Env.hs
+++ b/compiler/vectorise/Vectorise/Type/Env.hs
@@ -162,7 +162,7 @@ vectTypeEnv :: [TyCon]                   -- Type constructors defined in this mo
             -> [CoreVect]                -- All 'VECTORISE [SCALAR] type' declarations in this module
             -> [CoreVect]                -- All 'VECTORISE class' declarations in this module
             -> VM ( [TyCon]              -- old TyCons ++ new TyCons
-                  , [FamInst Unbranched] -- New type family instances.
+                  , [FamInst]            -- New type family instances.
                   , [(Var, CoreExpr)])   -- New top level bindings.
 vectTypeEnv tycons vectTypeDecls vectClassDecls
   = do { traceVt "** vectTypeEnv" $ ppr tycons
@@ -354,7 +354,7 @@ vectTypeEnv tycons vectTypeDecls vectClassDecls
         origName  = tyConName origTyCon
         vectName  = tyConName vectTyCon
 
-        mkSyn canonName ty = mkSynTyCon canonName (typeKind ty) [] (SynonymTyCon ty) NoParentTyCon
+        mkSyn canonName ty = mkSynTyCon canonName (typeKind ty) [] [] (SynonymTyCon ty) NoParentTyCon
         
         defDataCons
           | isAbstract = return ()
diff --git a/compiler/vectorise/Vectorise/Type/TyConDecl.hs b/compiler/vectorise/Vectorise/Type/TyConDecl.hs
index 588cd39ec0..935ea32c69 100644
--- a/compiler/vectorise/Vectorise/Type/TyConDecl.hs
+++ b/compiler/vectorise/Vectorise/Type/TyConDecl.hs
@@ -62,6 +62,7 @@ vectTyConDecl tycon name'
                      False                      -- include unfoldings on dictionary selectors
                      name'                      -- new name: "V:Class"
                      (tyConTyVars tycon)        -- keep original type vars
+                     (map (const Nominal) (tyConRoles tycon)) -- all role are N for safety
                      theta'                     -- superclasses
                      (snd . classTvsFds $ cls)  -- keep the original functional dependencies
                      []                         -- no associated types (for the moment)
@@ -100,6 +101,7 @@ vectTyConDecl tycon name'
        ; return $ buildAlgTyCon 
                     name'                   -- new name
                     (tyConTyVars tycon)     -- keep original type vars
+                    (map (const Nominal) (tyConRoles tycon)) -- all roles are N for safety
                     Nothing
                     []                      -- no stupid theta
                     rhs'                    -- new constructor defs
diff --git a/compiler/vectorise/Vectorise/Utils/Base.hs b/compiler/vectorise/Vectorise/Utils/Base.hs
index d088f45355..cb7b34e36a 100644
--- a/compiler/vectorise/Vectorise/Utils/Base.hs
+++ b/compiler/vectorise/Vectorise/Utils/Base.hs
@@ -39,8 +39,6 @@ import DataCon
 import MkId
 import DynFlags
 import FastString
-import Util
-import Panic
 
 #include "HsVersions.h"
 
@@ -130,12 +128,12 @@ splitPrimTyCon ty
 
 -- Coercion Construction -----------------------------------------------------
 
--- |Make a coersion to some builtin type.
+-- |Make a representational coersion to some builtin type.
 --
 mkBuiltinCo :: (Builtins -> TyCon) -> VM Coercion
 mkBuiltinCo get_tc
   = do { tc <- builtin get_tc
-       ; return $ mkTyConAppCo tc []
+       ; return $ mkTyConAppCo Representational tc []
        }
 
 
@@ -211,10 +209,8 @@ pdataReprTyCon :: Type -> VM (TyCon, [Type])
 pdataReprTyCon ty 
   = do 
     { FamInstMatch { fim_instance = famInst
-                   , fim_index    = index
                    , fim_tys      = tys } <- builtin pdataTyCon >>= (`lookupFamInst` [ty])
-    ; ASSERT( index == 0 )
-      return (dataFamInstRepTyCon famInst, tys)
+    ; return (dataFamInstRepTyCon famInst, tys)
     }
 
 -- |Get the representation tycon of the 'PData' data family for a given type constructor.
diff --git a/compiler/vectorise/Vectorise/Utils/PADict.hs b/compiler/vectorise/Vectorise/Utils/PADict.hs
index 8029dfb466..01fbede4bd 100644
--- a/compiler/vectorise/Vectorise/Utils/PADict.hs
+++ b/compiler/vectorise/Vectorise/Utils/PADict.hs
@@ -119,7 +119,7 @@ prDictOfPReprInst :: Type -> VM CoreExpr
 prDictOfPReprInst ty
   = do
     { (FamInstMatch { fim_instance = prepr_fam, fim_tys = prepr_args }) <- preprSynTyCon ty
-    ; prDictOfPReprInstTyCon ty (famInstAxiom (toUnbranchedFamInst prepr_fam)) prepr_args
+    ; prDictOfPReprInstTyCon ty (famInstAxiom prepr_fam) prepr_args
     }
 
 -- |Given a type @ty@, its PRepr synonym tycon and its type arguments,
@@ -145,7 +145,7 @@ prDictOfPReprInstTyCon _ty prepr_ax prepr_args
       pr_co <- mkBuiltinCo prTyCon
       let co = mkAppCo pr_co
              $ mkSymCo
-             $ mkUnbranchedAxInstCo prepr_ax prepr_args
+             $ mkUnbranchedAxInstCo Nominal prepr_ax prepr_args
       return $ mkCast dict co
 
 -- |Get the PR dictionary for a type. The argument must be a representation