compiler/vectorise/VectMonad.hs

   1 {-# LANGUAGE NamedFieldPuns #-}
   2
   3 -- | The Vectorisation monad.
   4 module VectMonad (
   5   Scope(..),
   6   VM,
   7
   8   noV, traceNoV, ensureV, traceEnsureV, tryV, maybeV, traceMaybeV, orElseV,
   9   onlyIfV, fixV, localV, closedV,
  10   initV, cantVectorise, maybeCantVectorise, maybeCantVectoriseM,
  11   liftDs,
  12   cloneName, cloneId, cloneVar,
  13   newExportedVar, newLocalVar, newLocalVars, newDummyVar, newTyVar,
  14
  15   Builtins(..), sumTyCon, prodTyCon, prodDataCon,
  16   selTy, selReplicate, selPick, selTags, selElements,
  17   combinePDVar, scalarZip, closureCtrFun,
  18   builtin, builtins,
  19
  20   GlobalEnv(..),
  21   setFamInstEnv,
  22   readGEnv, setGEnv, updGEnv,
  23
  24   LocalEnv(..),
  25   readLEnv, setLEnv, updLEnv,
  26
  27   getBindName, inBind,
  28
  29   lookupVar, defGlobalVar, globalScalars,
  30   lookupTyCon, defTyCon,
  31   lookupDataCon, defDataCon,
  32   lookupTyConPA, defTyConPA, defTyConPAs,
  33   lookupTyConPR,
  34   lookupBoxedTyCon,
  35   lookupPrimMethod, lookupPrimPArray,
  36   lookupTyVarPA, defLocalTyVar, defLocalTyVarWithPA, localTyVars,
  37
  38   lookupInst, lookupFamInst
  39 ) where
  40
  41 #include "HsVersions.h"
  42
  43 import VectBuiltIn
  44
  45 import HscTypes hiding  ( MonadThings(..) )
  46 import Module           ( PackageId )
  47 import CoreSyn
  48 import Class
  49 import TyCon
  50 import DataCon
  51 import Type
  52 import Var
  53 import VarSet
  54 import VarEnv
  55 import Id
  56 import Name
  57 import NameEnv
  58
  59 import DsMonad
  60
  61 import InstEnv
  62 import FamInstEnv
  63
  64 import Outputable
  65 import FastString
  66 import SrcLoc        ( noSrcSpan )
  67
  68 import Control.Monad
  69
  70 -- | Indicates what scope something (a variable) is in.
  71 data Scope a b = Global a | Local b
  72
  73
  74 -- | The global environment.
  75 data GlobalEnv = GlobalEnv {
  76                   -- | Mapping from global variables to their vectorised versions.
  77                   --
  78                   global_vars :: VarEnv Var
  79
  80                   -- | Purely scalar variables. Code which mentions only these
  81                   --   variables doesn't have to be lifted.
  82                 , global_scalars :: VarSet
  83
  84                   -- | Exported variables which have a vectorised version
  85                   --
  86                 , global_exported_vars :: VarEnv (Var, Var)
  87
  88                   -- | Mapping from TyCons to their vectorised versions.
  89                   --   TyCons which do not have to be vectorised are mapped to
  90                   --   themselves.
  91                   --
  92                 , global_tycons :: NameEnv TyCon
  93
  94                   -- | Mapping from DataCons to their vectorised versions
  95                   --
  96                 , global_datacons :: NameEnv DataCon
  97
  98                   -- | Mapping from TyCons to their PA dfuns
  99                   --
 100                 , global_pa_funs :: NameEnv Var
 101
 102                   -- | Mapping from TyCons to their PR dfuns
 103                 , global_pr_funs :: NameEnv Var
 104
 105                   -- | Mapping from unboxed TyCons to their boxed versions
 106                 , global_boxed_tycons :: NameEnv TyCon
 107
 108                 -- | External package inst-env & home-package inst-env for class
 109                 --   instances
 110                 --
 111                 , global_inst_env :: (InstEnv, InstEnv)
 112
 113                 -- | External package inst-env & home-package inst-env for family
 114                 --   instances
 115                 --
 116                 , global_fam_inst_env :: FamInstEnvs
 117
 118                 -- | Hoisted bindings
 119                 , global_bindings :: [(Var, CoreExpr)]
 120                 }
 121
 122 -- | The local environment.
 123 data LocalEnv = LocalEnv {
 124                  -- Mapping from local variables to their vectorised and
 125                  -- lifted versions
 126                  --
 127                  local_vars :: VarEnv (Var, Var)
 128
 129                  -- In-scope type variables
 130                  --
 131                , local_tyvars :: [TyVar]
 132
 133                  -- Mapping from tyvars to their PA dictionaries
 134                , local_tyvar_pa :: VarEnv CoreExpr
 135
 136                  -- Local binding name
 137                , local_bind_name :: FastString
 138                }
 139
 140
 141 -- | Create an initial global environment
 142 initGlobalEnv :: VectInfo -> (InstEnv, InstEnv) -> FamInstEnvs -> GlobalEnv
 143 initGlobalEnv info instEnvs famInstEnvs
 144   = GlobalEnv {
 145       global_vars          = mapVarEnv snd $ vectInfoVar info
 146     , global_scalars   = emptyVarSet
 147     , global_exported_vars = emptyVarEnv
 148     , global_tycons        = mapNameEnv snd $ vectInfoTyCon info
 149     , global_datacons      = mapNameEnv snd $ vectInfoDataCon info
 150     , global_pa_funs       = mapNameEnv snd $ vectInfoPADFun info
 151     , global_pr_funs       = emptyNameEnv
 152     , global_boxed_tycons  = emptyNameEnv
 153     , global_inst_env      = instEnvs
 154     , global_fam_inst_env  = famInstEnvs
 155     , global_bindings      = []
 156     }
 157
 158
 159 -- Operators on Global Environments -------------------------------------------
 160 extendImportedVarsEnv :: [(Var, Var)] -> GlobalEnv -> GlobalEnv
 161 extendImportedVarsEnv ps genv
 162   = genv { global_vars = extendVarEnvList (global_vars genv) ps }
 163
 164 extendScalars :: [Var] -> GlobalEnv -> GlobalEnv
 165 extendScalars vs genv
 166   = genv { global_scalars = extendVarSetList (global_scalars genv) vs }
 167
 168 setFamInstEnv :: FamInstEnv -> GlobalEnv -> GlobalEnv
 169 setFamInstEnv l_fam_inst genv
 170   = genv { global_fam_inst_env = (g_fam_inst, l_fam_inst) }
 171   where
 172     (g_fam_inst, _) = global_fam_inst_env genv
 173
 174 extendTyConsEnv :: [(Name, TyCon)] -> GlobalEnv -> GlobalEnv
 175 extendTyConsEnv ps genv
 176   = genv { global_tycons = extendNameEnvList (global_tycons genv) ps }
 177
 178 extendDataConsEnv :: [(Name, DataCon)] -> GlobalEnv -> GlobalEnv
 179 extendDataConsEnv ps genv
 180   = genv { global_datacons = extendNameEnvList (global_datacons genv) ps }
 181
 182 extendPAFunsEnv :: [(Name, Var)] -> GlobalEnv -> GlobalEnv
 183 extendPAFunsEnv ps genv
 184   = genv { global_pa_funs = extendNameEnvList (global_pa_funs genv) ps }
 185
 186 setPRFunsEnv :: [(Name, Var)] -> GlobalEnv -> GlobalEnv
 187 setPRFunsEnv ps genv
 188   = genv { global_pr_funs = mkNameEnv ps }
 189
 190 setBoxedTyConsEnv :: [(Name, TyCon)] -> GlobalEnv -> GlobalEnv
 191 setBoxedTyConsEnv ps genv
 192   = genv { global_boxed_tycons = mkNameEnv ps }
 193
 194
 195 -- | Create an empty local environment.
 196 emptyLocalEnv :: LocalEnv
 197 emptyLocalEnv = LocalEnv {
 198                    local_vars     = emptyVarEnv
 199                  , local_tyvars   = []
 200                  , local_tyvar_pa = emptyVarEnv
 201                  , local_bind_name  = fsLit "fn"
 202                  }
 203
 204 -- FIXME
 205 updVectInfo :: GlobalEnv -> TypeEnv -> VectInfo -> VectInfo
 206 updVectInfo env tyenv info
 207   = info {
 208       vectInfoVar     = global_exported_vars env
 209     , vectInfoTyCon   = mk_env typeEnvTyCons global_tycons
 210     , vectInfoDataCon = mk_env typeEnvDataCons global_datacons
 211     , vectInfoPADFun  = mk_env typeEnvTyCons global_pa_funs
 212     }
 213   where
 214     mk_env from_tyenv from_env = mkNameEnv [(name, (from,to))
 215                                    | from <- from_tyenv tyenv
 216                                    , let name = getName from
 217                                    , Just to <- [lookupNameEnv (from_env env) name]]
 218
 219
 220 -- The Vectorisation Monad ----------------------------------------------------
 221
 222 -- Vectorisation can either succeed with new envionment and a value,
 223 -- or return with failure.
 224 --
 225 data VResult a = Yes GlobalEnv LocalEnv a | No
 226
 227 newtype VM a = VM { runVM :: Builtins -> GlobalEnv -> LocalEnv -> DsM (VResult a) }
 228
 229 instance Monad VM where
 230   return x   = VM $ \_  genv lenv -> return (Yes genv lenv x)
 231   VM p >>= f = VM $ \bi genv lenv -> do
 232                                       r <- p bi genv lenv
 233                                       case r of
 234                                         Yes genv' lenv' x -> runVM (f x) bi genv' lenv'
 235                                         No                -> return No
 236
 237
 238 -- | Throw an error saying we can't vectorise something
 239 cantVectorise :: String -> SDoc -> a
 240 cantVectorise s d = pgmError
 241                   . showSDocDump
 242                   $ vcat [text "*** Vectorisation error ***",
 243                           nest 4 $ sep [text s, nest 4 d]]
 244
 245 maybeCantVectorise :: String -> SDoc -> Maybe a -> a
 246 maybeCantVectorise s d Nothing  = cantVectorise s d
 247 maybeCantVectorise _ _ (Just x) = x
 248
 249 maybeCantVectoriseM :: Monad m => String -> SDoc -> m (Maybe a) -> m a
 250 maybeCantVectoriseM s d p
 251   = do
 252       r <- p
 253       case r of
 254         Just x  -> return x
 255         Nothing -> cantVectorise s d
 256
 257
 258 -- Control --------------------------------------------------------------------
 259 -- | Return some result saying we've failed.
 260 noV :: VM a
 261 noV = VM $ \_ _ _ -> return No
 262
 263 traceNoV :: String -> SDoc -> VM a
 264 traceNoV s d = pprTrace s d noV
 265
 266
 267 -- | If True then carry on, otherwise fail.
 268 ensureV :: Bool -> VM ()
 269 ensureV False = noV
 270 ensureV True  = return ()
 271
 272
 273 -- | If True then return the first argument, otherwise fail.
 274 onlyIfV :: Bool -> VM a -> VM a
 275 onlyIfV b p = ensureV b >> p
 276
 277 traceEnsureV :: String -> SDoc -> Bool -> VM ()
 278 traceEnsureV s d False = traceNoV s d
 279 traceEnsureV _ _ True  = return ()
 280
 281
 282 -- | Try some vectorisation computaton.
 283 --      If it succeeds then return Just the result,
 284 --      otherwise return Nothing.
 285 tryV :: VM a -> VM (Maybe a)
 286 tryV (VM p) = VM $ \bi genv lenv ->
 287   do
 288     r <- p bi genv lenv
 289     case r of
 290       Yes genv' lenv' x -> return (Yes genv' lenv' (Just x))
 291       No                -> return (Yes genv  lenv  Nothing)
 292
 293
 294 maybeV :: VM (Maybe a) -> VM a
 295 maybeV p = maybe noV return =<< p
 296
 297 traceMaybeV :: String -> SDoc -> VM (Maybe a) -> VM a
 298 traceMaybeV s d p = maybe (traceNoV s d) return =<< p
 299
 300 orElseV :: VM a -> VM a -> VM a
 301 orElseV p q = maybe q return =<< tryV p
 302
 303 fixV :: (a -> VM a) -> VM a
 304 fixV f = VM (\bi genv lenv -> fixDs $ \r -> runVM (f (unYes r)) bi genv lenv )
 305   where
 306     -- NOTE: It is essential that we are lazy in r above so do not replace
 307     --       calls to this function by an explicit case.
 308     unYes (Yes _ _ x) = x
 309     unYes No          = panic "VectMonad.fixV: no result"
 310
 311
 312 -- Local Environments ---------------------------------------------------------
 313 -- | Perform a computation in its own local environment.
 314 --      This does not alter the environment of the current state.
 315 localV :: VM a -> VM a
 316 localV p = do
 317              env <- readLEnv id
 318              x <- p
 319              setLEnv env
 320              return x
 321
 322 -- | Perform a computation in an empty local environment.
 323 closedV :: VM a -> VM a
 324 closedV p = do
 325               env <- readLEnv id
 326               setLEnv (emptyLocalEnv { local_bind_name = local_bind_name env })
 327               x <- p
 328               setLEnv env
 329               return x
 330
 331 -- Lifting --------------------------------------------------------------------
 332 -- | Lift a desugaring computation into the vectorisation monad.
 333 liftDs :: DsM a -> VM a
 334 liftDs p = VM $ \_ genv lenv -> do { x <- p; return (Yes genv lenv x) }
 335
 336
 337
 338 -- Builtins -------------------------------------------------------------------
 339 -- Operations on Builtins
 340 liftBuiltinDs :: (Builtins -> DsM a) -> VM a
 341 liftBuiltinDs p = VM $ \bi genv lenv -> do { x <- p bi; return (Yes genv lenv x)}
 342
 343
 344 -- | Project something from the set of builtins.
 345 builtin :: (Builtins -> a) -> VM a
 346 builtin f = VM $ \bi genv lenv -> return (Yes genv lenv (f bi))
 347
 348 builtins :: (a -> Builtins -> b) -> VM (a -> b)
 349 builtins f = VM $ \bi genv lenv -> return (Yes genv lenv (`f` bi))
 350
 351
 352 -- Environments ---------------------------------------------------------------
 353 -- | Project something from the global environment.
 354 readGEnv :: (GlobalEnv -> a) -> VM a
 355 readGEnv f = VM $ \_ genv lenv -> return (Yes genv lenv (f genv))
 356
 357 setGEnv :: GlobalEnv -> VM ()
 358 setGEnv genv = VM $ \_ _ lenv -> return (Yes genv lenv ())
 359
 360 updGEnv :: (GlobalEnv -> GlobalEnv) -> VM ()
 361 updGEnv f = VM $ \_ genv lenv -> return (Yes (f genv) lenv ())
 362
 363
 364 -- | Project something from the local environment.
 365 readLEnv :: (LocalEnv -> a) -> VM a
 366 readLEnv f = VM $ \_ genv lenv -> return (Yes genv lenv (f lenv))
 367
 368 setLEnv :: LocalEnv -> VM ()
 369 setLEnv lenv = VM $ \_ genv _ -> return (Yes genv lenv ())
 370
 371 updLEnv :: (LocalEnv -> LocalEnv) -> VM ()
 372 updLEnv f = VM $ \_ genv lenv -> return (Yes genv (f lenv) ())
 373
 374
 375 -- InstEnv --------------------------------------------------------------------
 376 getInstEnv :: VM (InstEnv, InstEnv)
 377 getInstEnv = readGEnv global_inst_env
 378
 379 getFamInstEnv :: VM FamInstEnvs
 380 getFamInstEnv = readGEnv global_fam_inst_env
 381
 382
 383 -- Names ----------------------------------------------------------------------
 384 -- | Get the name of the local binding currently being vectorised.
 385 getBindName :: VM FastString
 386 getBindName = readLEnv local_bind_name
 387
 388 inBind :: Id -> VM a -> VM a
 389 inBind id p
 390   = do updLEnv $ \env -> env { local_bind_name = occNameFS (getOccName id) }
 391        p
 392
 393 cloneName :: (OccName -> OccName) -> Name -> VM Name
 394 cloneName mk_occ name = liftM make (liftDs newUnique)
 395   where
 396     occ_name = mk_occ (nameOccName name)
 397
 398     make u | isExternalName name = mkExternalName u (nameModule name)
 399                                                     occ_name
 400                                                     (nameSrcSpan name)
 401            | otherwise           = mkSystemName u occ_name
 402
 403 cloneId :: (OccName -> OccName) -> Id -> Type -> VM Id
 404 cloneId mk_occ id ty
 405   = do
 406       name <- cloneName mk_occ (getName id)
 407       let id' | isExportedId id = Id.mkExportedLocalId name ty
 408               | otherwise       = Id.mkLocalId         name ty
 409       return id'
 410
 411 -- Make a fresh instance of this var, with a new unique.
 412 cloneVar :: Var -> VM Var
 413 cloneVar var = liftM (setIdUnique var) (liftDs newUnique)
 414
 415 newExportedVar :: OccName -> Type -> VM Var
 416 newExportedVar occ_name ty
 417   = do
 418       mod <- liftDs getModuleDs
 419       u   <- liftDs newUnique
 420
 421       let name = mkExternalName u mod occ_name noSrcSpan
 422
 423       return $ Id.mkExportedLocalId name ty
 424
 425 newLocalVar :: FastString -> Type -> VM Var
 426 newLocalVar fs ty
 427   = do
 428       u <- liftDs newUnique
 429       return $ mkSysLocal fs u ty
 430
 431 newLocalVars :: FastString -> [Type] -> VM [Var]
 432 newLocalVars fs = mapM (newLocalVar fs)
 433
 434 newDummyVar :: Type -> VM Var
 435 newDummyVar = newLocalVar (fsLit "vv")
 436
 437 newTyVar :: FastString -> Kind -> VM Var
 438 newTyVar fs k
 439   = do
 440       u <- liftDs newUnique
 441       return $ mkTyVar (mkSysTvName u fs) k
 442
 443
 444 -- | Add a mapping between a global var and its vectorised version to the state.
 445 defGlobalVar :: Var -> Var -> VM ()
 446 defGlobalVar v v' = updGEnv $ \env ->
 447   env { global_vars = extendVarEnv (global_vars env) v v'
 448       , global_exported_vars = upd (global_exported_vars env)
 449       }
 450   where
 451     upd env | isExportedId v = extendVarEnv env v (v, v')
 452             | otherwise      = env
 453
 454 -- Var ------------------------------------------------------------------------
 455 -- | Lookup the vectorised and\/or lifted versions of this variable.
 456 --      If it's in the global environment we get the vectorised version.
 457 --      If it's in the local environment we get both the vectorised and lifted version.
 458 --
 459 lookupVar :: Var -> VM (Scope Var (Var, Var))
 460 lookupVar v
 461  = do r <- readLEnv $ \env -> lookupVarEnv (local_vars env) v
 462       case r of
 463         Just e  -> return (Local e)
 464         Nothing -> liftM Global
 465                 . maybeCantVectoriseVarM v
 466                 . readGEnv $ \env -> lookupVarEnv (global_vars env) v
 467
 468 maybeCantVectoriseVarM :: Monad m => Var -> m (Maybe Var) -> m Var
 469 maybeCantVectoriseVarM v p
 470  = do r <- p
 471       case r of
 472         Just x  -> return x
 473         Nothing -> dumpVar v
 474
 475 dumpVar :: Var -> a
 476 dumpVar var
 477         | Just cls              <- isClassOpId_maybe var
 478         = cantVectorise "ClassOpId not vectorised:" (ppr var)
 479
 480         | otherwise
 481         = cantVectorise "Variable not vectorised:" (ppr var)
 482
 483 -------------------------------------------------------------------------------
 484 globalScalars :: VM VarSet
 485 globalScalars = readGEnv global_scalars
 486
 487 lookupTyCon :: TyCon -> VM (Maybe TyCon)
 488 lookupTyCon tc
 489   | isUnLiftedTyCon tc || isTupleTyCon tc = return (Just tc)
 490
 491   | otherwise = readGEnv $ \env -> lookupNameEnv (global_tycons env) (tyConName tc)
 492
 493 defTyCon :: TyCon -> TyCon -> VM ()
 494 defTyCon tc tc' = updGEnv $ \env ->
 495   env { global_tycons = extendNameEnv (global_tycons env) (tyConName tc) tc' }
 496
 497 lookupDataCon :: DataCon -> VM (Maybe DataCon)
 498 lookupDataCon dc
 499   | isTupleTyCon (dataConTyCon dc) = return (Just dc)
 500   | otherwise = readGEnv $ \env -> lookupNameEnv (global_datacons env) (dataConName dc)
 501
 502 defDataCon :: DataCon -> DataCon -> VM ()
 503 defDataCon dc dc' = updGEnv $ \env ->
 504   env { global_datacons = extendNameEnv (global_datacons env) (dataConName dc) dc' }
 505
 506 lookupPrimPArray :: TyCon -> VM (Maybe TyCon)
 507 lookupPrimPArray = liftBuiltinDs . primPArray
 508
 509 lookupPrimMethod :: TyCon -> String -> VM (Maybe Var)
 510 lookupPrimMethod tycon = liftBuiltinDs . primMethod tycon
 511
 512 lookupTyConPA :: TyCon -> VM (Maybe Var)
 513 lookupTyConPA tc = readGEnv $ \env -> lookupNameEnv (global_pa_funs env) (tyConName tc)
 514
 515 defTyConPA :: TyCon -> Var -> VM ()
 516 defTyConPA tc pa = updGEnv $ \env ->
 517   env { global_pa_funs = extendNameEnv (global_pa_funs env) (tyConName tc) pa }
 518
 519 defTyConPAs :: [(TyCon, Var)] -> VM ()
 520 defTyConPAs ps = updGEnv $ \env ->
 521   env { global_pa_funs = extendNameEnvList (global_pa_funs env)
 522                                            [(tyConName tc, pa) | (tc, pa) <- ps] }
 523
 524 lookupTyVarPA :: Var -> VM (Maybe CoreExpr)
 525 lookupTyVarPA tv = readLEnv $ \env -> lookupVarEnv (local_tyvar_pa env) tv
 526
 527 lookupTyConPR :: TyCon -> VM (Maybe Var)
 528 lookupTyConPR tc = readGEnv $ \env -> lookupNameEnv (global_pr_funs env) (tyConName tc)
 529
 530 lookupBoxedTyCon :: TyCon -> VM (Maybe TyCon)
 531 lookupBoxedTyCon tc = readGEnv $ \env -> lookupNameEnv (global_boxed_tycons env)
 532                                                        (tyConName tc)
 533
 534 defLocalTyVar :: TyVar -> VM ()
 535 defLocalTyVar tv = updLEnv $ \env ->
 536   env { local_tyvars   = tv : local_tyvars env
 537       , local_tyvar_pa = local_tyvar_pa env `delVarEnv` tv
 538       }
 539
 540 defLocalTyVarWithPA :: TyVar -> CoreExpr -> VM ()
 541 defLocalTyVarWithPA tv pa = updLEnv $ \env ->
 542   env { local_tyvars   = tv : local_tyvars env
 543       , local_tyvar_pa = extendVarEnv (local_tyvar_pa env) tv pa
 544       }
 545
 546 localTyVars :: VM [TyVar]
 547 localTyVars = readLEnv (reverse . local_tyvars)
 548
 549 -- Look up the dfun of a class instance.
 550 --
 551 -- The match must be unique - ie, match exactly one instance - but the
 552 -- type arguments used for matching may be more specific than those of
 553 -- the class instance declaration.  The found class instances must not have
 554 -- any type variables in the instance context that do not appear in the
 555 -- instances head (i.e., no flexi vars); for details for what this means,
 556 -- see the docs at InstEnv.lookupInstEnv.
 557 --
 558 lookupInst :: Class -> [Type] -> VM (DFunId, [Type])
 559 lookupInst cls tys
 560   = do { instEnv <- getInstEnv
 561        ; case lookupInstEnv instEnv cls tys of
 562            ([(inst, inst_tys)], _)
 563              | noFlexiVar -> return (instanceDFunId inst, inst_tys')
 564              | otherwise  -> pprPanic "VectMonad.lookupInst: flexi var: "
 565                                       (ppr $ mkTyConApp (classTyCon cls) tys)
 566              where
 567                inst_tys'  = [ty | Right ty <- inst_tys]
 568                noFlexiVar = all isRight inst_tys
 569            _other         ->
 570              pprPanic "VectMonad.lookupInst: not found " (ppr cls <+> ppr tys)
 571        }
 572   where
 573     isRight (Left  _) = False
 574     isRight (Right _) = True
 575
 576 -- Look up the representation tycon of a family instance.
 577 --
 578 -- The match must be unique - ie, match exactly one instance - but the
 579 -- type arguments used for matching may be more specific than those of
 580 -- the family instance declaration.
 581 --
 582 -- Return the instance tycon and its type instance.  For example, if we have
 583 --
 584 --  lookupFamInst 'T' '[Int]' yields (':R42T', 'Int')
 585 --
 586 -- then we have a coercion (ie, type instance of family instance coercion)
 587 --
 588 --  :Co:R42T Int :: T [Int] ~ :R42T Int
 589 --
 590 -- which implies that :R42T was declared as 'data instance T [a]'.
 591 --
 592 lookupFamInst :: TyCon -> [Type] -> VM (TyCon, [Type])
 593 lookupFamInst tycon tys
 594   = ASSERT( isOpenTyCon tycon )
 595     do { instEnv <- getFamInstEnv
 596        ; case lookupFamInstEnv instEnv tycon tys of
 597            [(fam_inst, rep_tys)] -> return (famInstTyCon fam_inst, rep_tys)
 598            _other                ->
 599              pprPanic "VectMonad.lookupFamInst: not found: "
 600                       (ppr $ mkTyConApp tycon tys)
 601        }
 602
 603
 604 -- | Run a vectorisation computation.
 605 initV :: PackageId -> HscEnv -> ModGuts -> VectInfo -> VM a -> IO (Maybe (VectInfo, a))
 606 initV pkg hsc_env guts info p
 607   = do
 608          -- XXX: ignores error messages and warnings, check that this is
 609          -- indeed ok (the use of "Just r" suggests so)
 610       (_,Just r) <- initDs hsc_env (mg_module guts)
 611                                (mg_rdr_env guts)
 612                                (mg_types guts)
 613                                go
 614       return r
 615   where
 616
 617     go =
 618       do
 619         builtins       <- initBuiltins pkg
 620         builtin_vars   <- initBuiltinVars builtins
 621         builtin_tycons <- initBuiltinTyCons builtins
 622         let builtin_datacons = initBuiltinDataCons builtins
 623         builtin_boxed  <- initBuiltinBoxedTyCons builtins
 624         builtin_scalars <- initBuiltinScalars builtins
 625
 626         eps <- liftIO $ hscEPS hsc_env
 627         let famInstEnvs = (eps_fam_inst_env eps, mg_fam_inst_env guts)
 628             instEnvs    = (eps_inst_env     eps, mg_inst_env     guts)
 629
 630         builtin_prs    <- initBuiltinPRs builtins instEnvs
 631         builtin_pas    <- initBuiltinPAs builtins instEnvs
 632
 633         let genv = extendImportedVarsEnv builtin_vars
 634                  . extendScalars builtin_scalars
 635                  . extendTyConsEnv builtin_tycons
 636                  . extendDataConsEnv builtin_datacons
 637                  . extendPAFunsEnv builtin_pas
 638                  . setPRFunsEnv    builtin_prs
 639                  . setBoxedTyConsEnv builtin_boxed
 640                  $ initGlobalEnv info instEnvs famInstEnvs
 641
 642         r <- runVM p builtins genv emptyLocalEnv
 643         case r of
 644           Yes genv _ x -> return $ Just (new_info genv, x)
 645           No           -> return Nothing
 646
 647     new_info genv = updVectInfo genv (mg_types guts) info
 648