compiler/vectorise/VectMonad.hs

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