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 -- | Set the local environment.
 369 setLEnv :: LocalEnv -> VM ()
 370 setLEnv lenv = VM $ \_ genv _ -> return (Yes genv lenv ())
 371
 372 -- | Update the enviroment using a provided function.
 373 updLEnv :: (LocalEnv -> LocalEnv) -> VM ()
 374 updLEnv f = VM $ \_ genv lenv -> return (Yes genv (f lenv) ())
 375
 376
 377 -- InstEnv --------------------------------------------------------------------
 378 getInstEnv :: VM (InstEnv, InstEnv)
 379 getInstEnv = readGEnv global_inst_env
 380
 381 getFamInstEnv :: VM FamInstEnvs
 382 getFamInstEnv = readGEnv global_fam_inst_env
 383
 384
 385 -- Names ----------------------------------------------------------------------
 386 -- | Get the name of the local binding currently being vectorised.
 387 getBindName :: VM FastString
 388 getBindName = readLEnv local_bind_name
 389
 390 inBind :: Id -> VM a -> VM a
 391 inBind id p
 392   = do updLEnv $ \env -> env { local_bind_name = occNameFS (getOccName id) }
 393        p
 394
 395 cloneName :: (OccName -> OccName) -> Name -> VM Name
 396 cloneName mk_occ name = liftM make (liftDs newUnique)
 397   where
 398     occ_name = mk_occ (nameOccName name)
 399
 400     make u | isExternalName name = mkExternalName u (nameModule name)
 401                                                     occ_name
 402                                                     (nameSrcSpan name)
 403            | otherwise           = mkSystemName u occ_name
 404
 405 cloneId :: (OccName -> OccName) -> Id -> Type -> VM Id
 406 cloneId mk_occ id ty
 407   = do
 408       name <- cloneName mk_occ (getName id)
 409       let id' | isExportedId id = Id.mkExportedLocalId name ty
 410               | otherwise       = Id.mkLocalId         name ty
 411       return id'
 412
 413 -- Make a fresh instance of this var, with a new unique.
 414 cloneVar :: Var -> VM Var
 415 cloneVar var = liftM (setIdUnique var) (liftDs newUnique)
 416
 417 newExportedVar :: OccName -> Type -> VM Var
 418 newExportedVar occ_name ty
 419   = do
 420       mod <- liftDs getModuleDs
 421       u   <- liftDs newUnique
 422
 423       let name = mkExternalName u mod occ_name noSrcSpan
 424
 425       return $ Id.mkExportedLocalId name ty
 426
 427 newLocalVar :: FastString -> Type -> VM Var
 428 newLocalVar fs ty
 429   = do
 430       u <- liftDs newUnique
 431       return $ mkSysLocal fs u ty
 432
 433 newLocalVars :: FastString -> [Type] -> VM [Var]
 434 newLocalVars fs = mapM (newLocalVar fs)
 435
 436 newDummyVar :: Type -> VM Var
 437 newDummyVar = newLocalVar (fsLit "vv")
 438
 439 newTyVar :: FastString -> Kind -> VM Var
 440 newTyVar fs k
 441   = do
 442       u <- liftDs newUnique
 443       return $ mkTyVar (mkSysTvName u fs) k
 444
 445
 446 -- | Add a mapping between a global var and its vectorised version to the state.
 447 defGlobalVar :: Var -> Var -> VM ()
 448 defGlobalVar v v' = updGEnv $ \env ->
 449   env { global_vars = extendVarEnv (global_vars env) v v'
 450       , global_exported_vars = upd (global_exported_vars env)
 451       }
 452   where
 453     upd env | isExportedId v = extendVarEnv env v (v, v')
 454             | otherwise      = env
 455
 456 -- Var ------------------------------------------------------------------------
 457 -- | Lookup the vectorised and\/or lifted versions of this variable.
 458 --      If it's in the global environment we get the vectorised version.
 459 --      If it's in the local environment we get both the vectorised and lifted version.
 460 --
 461 lookupVar :: Var -> VM (Scope Var (Var, Var))
 462 lookupVar v
 463  = do r <- readLEnv $ \env -> lookupVarEnv (local_vars env) v
 464       case r of
 465         Just e  -> return (Local e)
 466         Nothing -> liftM Global
 467                 . maybeCantVectoriseVarM v
 468                 . readGEnv $ \env -> lookupVarEnv (global_vars env) v
 469
 470 maybeCantVectoriseVarM :: Monad m => Var -> m (Maybe Var) -> m Var
 471 maybeCantVectoriseVarM v p
 472  = do r <- p
 473       case r of
 474         Just x  -> return x
 475         Nothing -> dumpVar v
 476
 477 dumpVar :: Var -> a
 478 dumpVar var
 479         | Just _                <- isClassOpId_maybe var
 480         = cantVectorise "ClassOpId not vectorised:" (ppr var)
 481
 482         | otherwise
 483         = cantVectorise "Variable not vectorised:" (ppr var)
 484
 485 -------------------------------------------------------------------------------
 486 globalScalars :: VM VarSet
 487 globalScalars = readGEnv global_scalars
 488
 489 lookupTyCon :: TyCon -> VM (Maybe TyCon)
 490 lookupTyCon tc
 491   | isUnLiftedTyCon tc || isTupleTyCon tc = return (Just tc)
 492
 493   | otherwise = readGEnv $ \env -> lookupNameEnv (global_tycons env) (tyConName tc)
 494
 495 defTyCon :: TyCon -> TyCon -> VM ()
 496 defTyCon tc tc' = updGEnv $ \env ->
 497   env { global_tycons = extendNameEnv (global_tycons env) (tyConName tc) tc' }
 498
 499 lookupDataCon :: DataCon -> VM (Maybe DataCon)
 500 lookupDataCon dc
 501   | isTupleTyCon (dataConTyCon dc) = return (Just dc)
 502   | otherwise = readGEnv $ \env -> lookupNameEnv (global_datacons env) (dataConName dc)
 503
 504 defDataCon :: DataCon -> DataCon -> VM ()
 505 defDataCon dc dc' = updGEnv $ \env ->
 506   env { global_datacons = extendNameEnv (global_datacons env) (dataConName dc) dc' }
 507
 508 lookupPrimPArray :: TyCon -> VM (Maybe TyCon)
 509 lookupPrimPArray = liftBuiltinDs . primPArray
 510
 511 lookupPrimMethod :: TyCon -> String -> VM (Maybe Var)
 512 lookupPrimMethod tycon = liftBuiltinDs . primMethod tycon
 513
 514 lookupTyConPA :: TyCon -> VM (Maybe Var)
 515 lookupTyConPA tc = readGEnv $ \env -> lookupNameEnv (global_pa_funs env) (tyConName tc)
 516
 517 defTyConPA :: TyCon -> Var -> VM ()
 518 defTyConPA tc pa = updGEnv $ \env ->
 519   env { global_pa_funs = extendNameEnv (global_pa_funs env) (tyConName tc) pa }
 520
 521 defTyConPAs :: [(TyCon, Var)] -> VM ()
 522 defTyConPAs ps = updGEnv $ \env ->
 523   env { global_pa_funs = extendNameEnvList (global_pa_funs env)
 524                                            [(tyConName tc, pa) | (tc, pa) <- ps] }
 525
 526 lookupTyVarPA :: Var -> VM (Maybe CoreExpr)
 527 lookupTyVarPA tv = readLEnv $ \env -> lookupVarEnv (local_tyvar_pa env) tv
 528
 529 lookupTyConPR :: TyCon -> VM (Maybe Var)
 530 lookupTyConPR tc = readGEnv $ \env -> lookupNameEnv (global_pr_funs env) (tyConName tc)
 531
 532 lookupBoxedTyCon :: TyCon -> VM (Maybe TyCon)
 533 lookupBoxedTyCon tc = readGEnv $ \env -> lookupNameEnv (global_boxed_tycons env)
 534                                                        (tyConName tc)
 535
 536 defLocalTyVar :: TyVar -> VM ()
 537 defLocalTyVar tv = updLEnv $ \env ->
 538   env { local_tyvars   = tv : local_tyvars env
 539       , local_tyvar_pa = local_tyvar_pa env `delVarEnv` tv
 540       }
 541
 542 defLocalTyVarWithPA :: TyVar -> CoreExpr -> VM ()
 543 defLocalTyVarWithPA tv pa = updLEnv $ \env ->
 544   env { local_tyvars   = tv : local_tyvars env
 545       , local_tyvar_pa = extendVarEnv (local_tyvar_pa env) tv pa
 546       }
 547
 548 localTyVars :: VM [TyVar]
 549 localTyVars = readLEnv (reverse . local_tyvars)
 550
 551 -- Look up the dfun of a class instance.
 552 --
 553 -- The match must be unique - ie, match exactly one instance - but the
 554 -- type arguments used for matching may be more specific than those of
 555 -- the class instance declaration.  The found class instances must not have
 556 -- any type variables in the instance context that do not appear in the
 557 -- instances head (i.e., no flexi vars); for details for what this means,
 558 -- see the docs at InstEnv.lookupInstEnv.
 559 --
 560 lookupInst :: Class -> [Type] -> VM (DFunId, [Type])
 561 lookupInst cls tys
 562   = do { instEnv <- getInstEnv
 563        ; case lookupInstEnv instEnv cls tys of
 564            ([(inst, inst_tys)], _)
 565              | noFlexiVar -> return (instanceDFunId inst, inst_tys')
 566              | otherwise  -> pprPanic "VectMonad.lookupInst: flexi var: "
 567                                       (ppr $ mkTyConApp (classTyCon cls) tys)
 568              where
 569                inst_tys'  = [ty | Right ty <- inst_tys]
 570                noFlexiVar = all isRight inst_tys
 571            _other         ->
 572              pprPanic "VectMonad.lookupInst: not found " (ppr cls <+> ppr tys)
 573        }
 574   where
 575     isRight (Left  _) = False
 576     isRight (Right _) = True
 577
 578 -- Look up the representation tycon of a family instance.
 579 --
 580 -- The match must be unique - ie, match exactly one instance - but the
 581 -- type arguments used for matching may be more specific than those of
 582 -- the family instance declaration.
 583 --
 584 -- Return the instance tycon and its type instance.  For example, if we have
 585 --
 586 --  lookupFamInst 'T' '[Int]' yields (':R42T', 'Int')
 587 --
 588 -- then we have a coercion (ie, type instance of family instance coercion)
 589 --
 590 --  :Co:R42T Int :: T [Int] ~ :R42T Int
 591 --
 592 -- which implies that :R42T was declared as 'data instance T [a]'.
 593 --
 594 lookupFamInst :: TyCon -> [Type] -> VM (TyCon, [Type])
 595 lookupFamInst tycon tys
 596   = ASSERT( isOpenTyCon tycon )
 597     do { instEnv <- getFamInstEnv
 598        ; case lookupFamInstEnv instEnv tycon tys of
 599            [(fam_inst, rep_tys)] -> return (famInstTyCon fam_inst, rep_tys)
 600            _other                ->
 601              pprPanic "VectMonad.lookupFamInst: not found: "
 602                       (ppr $ mkTyConApp tycon tys)
 603        }
 604
 605
 606 -- | Run a vectorisation computation.
 607 initV :: PackageId -> HscEnv -> ModGuts -> VectInfo -> VM a -> IO (Maybe (VectInfo, a))
 608 initV pkg hsc_env guts info p
 609   = do
 610          -- XXX: ignores error messages and warnings, check that this is
 611          -- indeed ok (the use of "Just r" suggests so)
 612       (_,Just r) <- initDs hsc_env (mg_module guts)
 613                                (mg_rdr_env guts)
 614                                (mg_types guts)
 615                                go
 616       return r
 617   where
 618
 619     go =
 620       do
 621         builtins       <- initBuiltins pkg
 622         builtin_vars   <- initBuiltinVars builtins
 623         builtin_tycons <- initBuiltinTyCons builtins
 624         let builtin_datacons = initBuiltinDataCons builtins
 625         builtin_boxed  <- initBuiltinBoxedTyCons builtins
 626         builtin_scalars <- initBuiltinScalars builtins
 627
 628         eps <- liftIO $ hscEPS hsc_env
 629         let famInstEnvs = (eps_fam_inst_env eps, mg_fam_inst_env guts)
 630             instEnvs    = (eps_inst_env     eps, mg_inst_env     guts)
 631
 632         builtin_prs    <- initBuiltinPRs builtins instEnvs
 633         builtin_pas    <- initBuiltinPAs builtins instEnvs
 634
 635         let genv = extendImportedVarsEnv builtin_vars
 636                  . extendScalars builtin_scalars
 637                  . extendTyConsEnv builtin_tycons
 638                  . extendDataConsEnv builtin_datacons
 639                  . extendPAFunsEnv builtin_pas
 640                  . setPRFunsEnv    builtin_prs
 641                  . setBoxedTyConsEnv builtin_boxed
 642                  $ initGlobalEnv info instEnvs famInstEnvs
 643
 644         r <- runVM p builtins genv emptyLocalEnv
 645         case r of
 646           Yes genv _ x -> return $ Just (new_info genv, x)
 647           No           -> return Nothing
 648
 649     new_info genv = updVectInfo genv (mg_types guts) info
 650