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 defGlobalVar :: Var -> Var -> VM ()
 443 defGlobalVar v v' = updGEnv $ \env ->
 444   env { global_vars = extendVarEnv (global_vars env) v v'
 445       , global_exported_vars = upd (global_exported_vars env)
 446       }
 447   where
 448     upd env | isExportedId v = extendVarEnv env v (v, v')
 449             | otherwise      = env
 450
 451 -- | Lookup the vectorised and\/or lifted versions of this variable.
 452 --      If it's in the global environment we get the vectorised version.
 453 --      If it's in the local environment we get both the vectorised and lifted version.
 454 --
 455 lookupVar :: Var -> VM (Scope Var (Var, Var))
 456 lookupVar v
 457   = do
 458       r <- readLEnv $ \env -> lookupVarEnv (local_vars env) v
 459       case r of
 460         Just e  -> return (Local e)
 461         Nothing -> liftM Global
 462                 . maybeCantVectoriseM "Variable not vectorised:" (ppr v)
 463                 . readGEnv $ \env -> lookupVarEnv (global_vars env) v
 464
 465 globalScalars :: VM VarSet
 466 globalScalars = readGEnv global_scalars
 467
 468 lookupTyCon :: TyCon -> VM (Maybe TyCon)
 469 lookupTyCon tc
 470   | isUnLiftedTyCon tc || isTupleTyCon tc = return (Just tc)
 471
 472   | otherwise = readGEnv $ \env -> lookupNameEnv (global_tycons env) (tyConName tc)
 473
 474 defTyCon :: TyCon -> TyCon -> VM ()
 475 defTyCon tc tc' = updGEnv $ \env ->
 476   env { global_tycons = extendNameEnv (global_tycons env) (tyConName tc) tc' }
 477
 478 lookupDataCon :: DataCon -> VM (Maybe DataCon)
 479 lookupDataCon dc
 480   | isTupleTyCon (dataConTyCon dc) = return (Just dc)
 481   | otherwise = readGEnv $ \env -> lookupNameEnv (global_datacons env) (dataConName dc)
 482
 483 defDataCon :: DataCon -> DataCon -> VM ()
 484 defDataCon dc dc' = updGEnv $ \env ->
 485   env { global_datacons = extendNameEnv (global_datacons env) (dataConName dc) dc' }
 486
 487 lookupPrimPArray :: TyCon -> VM (Maybe TyCon)
 488 lookupPrimPArray = liftBuiltinDs . primPArray
 489
 490 lookupPrimMethod :: TyCon -> String -> VM (Maybe Var)
 491 lookupPrimMethod tycon = liftBuiltinDs . primMethod tycon
 492
 493 lookupTyConPA :: TyCon -> VM (Maybe Var)
 494 lookupTyConPA tc = readGEnv $ \env -> lookupNameEnv (global_pa_funs env) (tyConName tc)
 495
 496 defTyConPA :: TyCon -> Var -> VM ()
 497 defTyConPA tc pa = updGEnv $ \env ->
 498   env { global_pa_funs = extendNameEnv (global_pa_funs env) (tyConName tc) pa }
 499
 500 defTyConPAs :: [(TyCon, Var)] -> VM ()
 501 defTyConPAs ps = updGEnv $ \env ->
 502   env { global_pa_funs = extendNameEnvList (global_pa_funs env)
 503                                            [(tyConName tc, pa) | (tc, pa) <- ps] }
 504
 505 lookupTyVarPA :: Var -> VM (Maybe CoreExpr)
 506 lookupTyVarPA tv = readLEnv $ \env -> lookupVarEnv (local_tyvar_pa env) tv
 507
 508 lookupTyConPR :: TyCon -> VM (Maybe Var)
 509 lookupTyConPR tc = readGEnv $ \env -> lookupNameEnv (global_pr_funs env) (tyConName tc)
 510
 511 lookupBoxedTyCon :: TyCon -> VM (Maybe TyCon)
 512 lookupBoxedTyCon tc = readGEnv $ \env -> lookupNameEnv (global_boxed_tycons env)
 513                                                        (tyConName tc)
 514
 515 defLocalTyVar :: TyVar -> VM ()
 516 defLocalTyVar tv = updLEnv $ \env ->
 517   env { local_tyvars   = tv : local_tyvars env
 518       , local_tyvar_pa = local_tyvar_pa env `delVarEnv` tv
 519       }
 520
 521 defLocalTyVarWithPA :: TyVar -> CoreExpr -> VM ()
 522 defLocalTyVarWithPA tv pa = updLEnv $ \env ->
 523   env { local_tyvars   = tv : local_tyvars env
 524       , local_tyvar_pa = extendVarEnv (local_tyvar_pa env) tv pa
 525       }
 526
 527 localTyVars :: VM [TyVar]
 528 localTyVars = readLEnv (reverse . local_tyvars)
 529
 530 -- Look up the dfun of a class instance.
 531 --
 532 -- The match must be unique - ie, match exactly one instance - but the
 533 -- type arguments used for matching may be more specific than those of
 534 -- the class instance declaration.  The found class instances must not have
 535 -- any type variables in the instance context that do not appear in the
 536 -- instances head (i.e., no flexi vars); for details for what this means,
 537 -- see the docs at InstEnv.lookupInstEnv.
 538 --
 539 lookupInst :: Class -> [Type] -> VM (DFunId, [Type])
 540 lookupInst cls tys
 541   = do { instEnv <- getInstEnv
 542        ; case lookupInstEnv instEnv cls tys of
 543            ([(inst, inst_tys)], _)
 544              | noFlexiVar -> return (instanceDFunId inst, inst_tys')
 545              | otherwise  -> pprPanic "VectMonad.lookupInst: flexi var: "
 546                                       (ppr $ mkTyConApp (classTyCon cls) tys)
 547              where
 548                inst_tys'  = [ty | Right ty <- inst_tys]
 549                noFlexiVar = all isRight inst_tys
 550            _other         ->
 551              pprPanic "VectMonad.lookupInst: not found " (ppr cls <+> ppr tys)
 552        }
 553   where
 554     isRight (Left  _) = False
 555     isRight (Right _) = True
 556
 557 -- Look up the representation tycon of a family instance.
 558 --
 559 -- The match must be unique - ie, match exactly one instance - but the
 560 -- type arguments used for matching may be more specific than those of
 561 -- the family instance declaration.
 562 --
 563 -- Return the instance tycon and its type instance.  For example, if we have
 564 --
 565 --  lookupFamInst 'T' '[Int]' yields (':R42T', 'Int')
 566 --
 567 -- then we have a coercion (ie, type instance of family instance coercion)
 568 --
 569 --  :Co:R42T Int :: T [Int] ~ :R42T Int
 570 --
 571 -- which implies that :R42T was declared as 'data instance T [a]'.
 572 --
 573 lookupFamInst :: TyCon -> [Type] -> VM (TyCon, [Type])
 574 lookupFamInst tycon tys
 575   = ASSERT( isOpenTyCon tycon )
 576     do { instEnv <- getFamInstEnv
 577        ; case lookupFamInstEnv instEnv tycon tys of
 578            [(fam_inst, rep_tys)] -> return (famInstTyCon fam_inst, rep_tys)
 579            _other                ->
 580              pprPanic "VectMonad.lookupFamInst: not found: "
 581                       (ppr $ mkTyConApp tycon tys)
 582        }
 583
 584 initV :: PackageId -> HscEnv -> ModGuts -> VectInfo -> VM a -> IO (Maybe (VectInfo, a))
 585 initV pkg hsc_env guts info p
 586   = do
 587          -- XXX: ignores error messages and warnings, check that this is
 588          -- indeed ok (the use of "Just r" suggests so)
 589       (_,Just r) <- initDs hsc_env (mg_module guts)
 590                                (mg_rdr_env guts)
 591                                (mg_types guts)
 592                                go
 593       return r
 594   where
 595
 596     go =
 597       do
 598         builtins       <- initBuiltins pkg
 599         builtin_vars   <- initBuiltinVars builtins
 600         builtin_tycons <- initBuiltinTyCons builtins
 601         let builtin_datacons = initBuiltinDataCons builtins
 602         builtin_boxed  <- initBuiltinBoxedTyCons builtins
 603         builtin_scalars <- initBuiltinScalars builtins
 604
 605         eps <- liftIO $ hscEPS hsc_env
 606         let famInstEnvs = (eps_fam_inst_env eps, mg_fam_inst_env guts)
 607             instEnvs    = (eps_inst_env     eps, mg_inst_env     guts)
 608
 609         builtin_prs    <- initBuiltinPRs builtins instEnvs
 610         builtin_pas    <- initBuiltinPAs builtins instEnvs
 611
 612         let genv = extendImportedVarsEnv builtin_vars
 613                  . extendScalars builtin_scalars
 614                  . extendTyConsEnv builtin_tycons
 615                  . extendDataConsEnv builtin_datacons
 616                  . extendPAFunsEnv builtin_pas
 617                  . setPRFunsEnv    builtin_prs
 618                  . setBoxedTyConsEnv builtin_boxed
 619                  $ initGlobalEnv info instEnvs famInstEnvs
 620
 621         r <- runVM p builtins genv emptyLocalEnv
 622         case r of
 623           Yes genv _ x -> return $ Just (new_info genv, x)
 624           No           -> return Nothing
 625
 626     new_info genv = updVectInfo genv (mg_types guts) info
 627