compiler/vectorise/VectUtils.hs

   1 module VectUtils (
   2   collectAnnTypeBinders, collectAnnTypeArgs, isAnnTypeArg,
   3   collectAnnValBinders,
   4   mkDataConTag,
   5   splitClosureTy,
   6
   7   TyConRepr(..), mkTyConRepr,
   8   mkToArrPRepr, mkFromPRepr, mkFromArrPRepr,
   9   mkPADictType, mkPArrayType, mkPReprType,
  10
  11   parrayCoerce, parrayReprTyCon, parrayReprDataCon, mkVScrut,
  12   prDictOfType, prCoerce,
  13   paDictArgType, paDictOfType, paDFunType,
  14   paMethod, lengthPA, replicatePA, emptyPA, liftPA,
  15   polyAbstract, polyApply, polyVApply,
  16   hoistBinding, hoistExpr, hoistPolyVExpr, takeHoisted,
  17   buildClosure, buildClosures,
  18   mkClosureApp
  19 ) where
  20
  21 #include "HsVersions.h"
  22
  23 import VectCore
  24 import VectMonad
  25
  26 import DsUtils
  27 import CoreSyn
  28 import CoreUtils
  29 import Coercion
  30 import Type
  31 import TypeRep
  32 import TyCon
  33 import DataCon
  34 import Var
  35 import Id                 ( mkWildId )
  36 import MkId               ( unwrapFamInstScrut )
  37 import Name               ( Name )
  38 import PrelNames
  39 import TysWiredIn
  40 import BasicTypes         ( Boxity(..) )
  41
  42 import Outputable
  43 import FastString
  44
  45 import Data.List             ( zipWith4 )
  46 import Control.Monad         ( liftM, liftM2, zipWithM_ )
  47
  48 collectAnnTypeArgs :: AnnExpr b ann -> (AnnExpr b ann, [Type])
  49 collectAnnTypeArgs expr = go expr []
  50   where
  51     go (_, AnnApp f (_, AnnType ty)) tys = go f (ty : tys)
  52     go e                             tys = (e, tys)
  53
  54 collectAnnTypeBinders :: AnnExpr Var ann -> ([Var], AnnExpr Var ann)
  55 collectAnnTypeBinders expr = go [] expr
  56   where
  57     go bs (_, AnnLam b e) | isTyVar b = go (b:bs) e
  58     go bs e                           = (reverse bs, e)
  59
  60 collectAnnValBinders :: AnnExpr Var ann -> ([Var], AnnExpr Var ann)
  61 collectAnnValBinders expr = go [] expr
  62   where
  63     go bs (_, AnnLam b e) | isId b = go (b:bs) e
  64     go bs e                        = (reverse bs, e)
  65
  66 isAnnTypeArg :: AnnExpr b ann -> Bool
  67 isAnnTypeArg (_, AnnType t) = True
  68 isAnnTypeArg _              = False
  69
  70 mkDataConTag :: DataCon -> CoreExpr
  71 mkDataConTag dc = mkConApp intDataCon [mkIntLitInt $ dataConTag dc]
  72
  73 splitUnTy :: String -> Name -> Type -> Type
  74 splitUnTy s name ty
  75   | Just (tc, [ty']) <- splitTyConApp_maybe ty
  76   , tyConName tc == name
  77   = ty'
  78
  79   | otherwise = pprPanic s (ppr ty)
  80
  81 splitBinTy :: String -> Name -> Type -> (Type, Type)
  82 splitBinTy s name ty
  83   | Just (tc, [ty1, ty2]) <- splitTyConApp_maybe ty
  84   , tyConName tc == name
  85   = (ty1, ty2)
  86
  87   | otherwise = pprPanic s (ppr ty)
  88
  89 splitFixedTyConApp :: TyCon -> Type -> [Type]
  90 splitFixedTyConApp tc ty
  91   | Just (tc', tys) <- splitTyConApp_maybe ty
  92   , tc == tc'
  93   = tys
  94
  95   | otherwise = pprPanic "splitFixedTyConApp" (ppr tc <+> ppr ty)
  96
  97 splitClosureTy :: Type -> (Type, Type)
  98 splitClosureTy = splitBinTy "splitClosureTy" closureTyConName
  99
 100 splitPArrayTy :: Type -> Type
 101 splitPArrayTy = splitUnTy "splitPArrayTy" parrayTyConName
 102
 103 mkBuiltinTyConApp :: (Builtins -> TyCon) -> [Type] -> VM Type
 104 mkBuiltinTyConApp get_tc tys
 105   = do
 106       tc <- builtin get_tc
 107       return $ mkTyConApp tc tys
 108
 109 mkBuiltinTyConApps :: (Builtins -> TyCon) -> [Type] -> Type -> VM Type
 110 mkBuiltinTyConApps get_tc tys ty
 111   = do
 112       tc <- builtin get_tc
 113       return $ foldr (mk tc) ty tys
 114   where
 115     mk tc ty1 ty2 = mkTyConApp tc [ty1,ty2]
 116
 117 mkBuiltinTyConApps1 :: (Builtins -> TyCon) -> Type -> [Type] -> VM Type
 118 mkBuiltinTyConApps1 get_tc dft [] = return dft
 119 mkBuiltinTyConApps1 get_tc dft tys
 120   = do
 121       tc <- builtin get_tc
 122       case tys of
 123         [] -> pprPanic "mkBuiltinTyConApps1" (ppr tc)
 124         _  -> return $ foldr1 (mk tc) tys
 125   where
 126     mk tc ty1 ty2 = mkTyConApp tc [ty1,ty2]
 127
 128 data TyConRepr = TyConRepr {
 129                    repr_tyvars      :: [TyVar]
 130                  , repr_tys         :: [[Type]]
 131
 132                  , repr_prod_tycons :: [Maybe TyCon]
 133                  , repr_prod_tys    :: [Type]
 134                  , repr_sum_tycon   :: Maybe TyCon
 135                  , repr_type        :: Type
 136                  }
 137
 138 mkTyConRepr :: TyCon -> VM TyConRepr
 139 mkTyConRepr vect_tc
 140   = do
 141       prod_tycons <- mapM (mk_tycon prodTyCon) rep_tys
 142       let prod_tys = zipWith mk_tc_app_maybe prod_tycons rep_tys
 143       sum_tycon   <- mk_tycon sumTyCon prod_tys
 144
 145       return $ TyConRepr {
 146                  repr_tyvars      = tyvars
 147                , repr_tys         = rep_tys
 148
 149                , repr_prod_tycons = prod_tycons
 150                , repr_prod_tys    = prod_tys
 151                , repr_sum_tycon   = sum_tycon
 152                , repr_type        = mk_tc_app_maybe sum_tycon prod_tys
 153                }
 154   where
 155     tyvars = tyConTyVars vect_tc
 156     data_cons = tyConDataCons vect_tc
 157     rep_tys   = map dataConRepArgTys data_cons
 158
 159     mk_tycon get_tc tys
 160       | n > 1     = builtin (Just . get_tc n)
 161       | otherwise = return Nothing
 162       where n = length tys
 163
 164     mk_tc_app_maybe Nothing   []   = unitTy
 165     mk_tc_app_maybe Nothing   [ty] = ty
 166     mk_tc_app_maybe (Just tc) tys  = mkTyConApp tc tys
 167
 168 mkToArrPRepr :: CoreExpr -> CoreExpr -> [[CoreExpr]] -> VM CoreExpr
 169 mkToArrPRepr len sel ess
 170   = do
 171       let mk_sum [(expr, ty)] = return (expr, ty)
 172           mk_sum es
 173             = do
 174                 sum_tc <- builtin . sumTyCon $ length es
 175                 (sum_rtc, _) <- parrayReprTyCon (mkTyConApp sum_tc tys)
 176                 let [sum_rdc] = tyConDataCons sum_rtc
 177
 178                 return (mkConApp sum_rdc (map Type tys ++ (len : sel : exprs)),
 179                         mkTyConApp sum_tc tys)
 180             where
 181               (exprs, tys) = unzip es
 182
 183           mk_prod [expr] = return (expr, splitPArrayTy (exprType expr))
 184           mk_prod exprs
 185             = do
 186                 prod_tc <- builtin . prodTyCon $ length exprs
 187                 (prod_rtc, _) <- parrayReprTyCon (mkTyConApp prod_tc tys)
 188                 let [prod_rdc] = tyConDataCons prod_rtc
 189
 190                 return (mkConApp prod_rdc (map Type tys ++ (len : exprs)),
 191                         mkTyConApp prod_tc tys)
 192             where
 193               tys = map (splitPArrayTy . exprType) exprs
 194
 195       liftM fst (mk_sum =<< mapM mk_prod ess)
 196
 197 mkFromPRepr :: CoreExpr -> Type -> [([Var], CoreExpr)] -> VM CoreExpr
 198 mkFromPRepr scrut res_ty alts
 199   = do
 200       sum_tcs  <- builtins sumTyCon
 201       prod_tcs <- builtins prodTyCon
 202
 203       let un_sum expr ty [(vars, res)] = un_prod expr ty vars res
 204           un_sum expr ty bs
 205             = do
 206                 ps     <- mapM (newLocalVar FSLIT("p")) tys
 207                 bodies <- sequence
 208                         $ zipWith4 un_prod (map Var ps) tys vars rs
 209                 return . Case expr (mkWildId ty) res_ty
 210                        $ zipWith3 mk_alt sum_dcs ps bodies
 211             where
 212               (vars, rs) = unzip bs
 213               tys        = splitFixedTyConApp sum_tc ty
 214               sum_tc     = sum_tcs $ length bs
 215               sum_dcs    = tyConDataCons sum_tc
 216
 217               mk_alt dc p body = (DataAlt dc, [p], body)
 218
 219           un_prod expr ty []    r = return r
 220           un_prod expr ty [var] r = return $ Let (NonRec var expr) r
 221           un_prod expr ty vars  r
 222             = return $ Case expr (mkWildId ty) res_ty
 223                        [(DataAlt prod_dc, vars, r)]
 224             where
 225               prod_tc   = prod_tcs $ length vars
 226               [prod_dc] = tyConDataCons prod_tc
 227
 228       un_sum scrut (exprType scrut) alts
 229
 230 mkFromArrPRepr :: CoreExpr -> Type -> Var -> Var -> [[Var]] -> CoreExpr
 231                -> VM CoreExpr
 232 mkFromArrPRepr scrut res_ty len sel vars res
 233   = return (Var unitDataConId)
 234
 235 mkClosureType :: Type -> Type -> VM Type
 236 mkClosureType arg_ty res_ty = mkBuiltinTyConApp closureTyCon [arg_ty, res_ty]
 237
 238 mkClosureTypes :: [Type] -> Type -> VM Type
 239 mkClosureTypes = mkBuiltinTyConApps closureTyCon
 240
 241 mkPReprType :: Type -> VM Type
 242 mkPReprType ty = mkBuiltinTyConApp preprTyCon [ty]
 243
 244 mkPADictType :: Type -> VM Type
 245 mkPADictType ty = mkBuiltinTyConApp paTyCon [ty]
 246
 247 mkPArrayType :: Type -> VM Type
 248 mkPArrayType ty = mkBuiltinTyConApp parrayTyCon [ty]
 249
 250 parrayCoerce :: TyCon -> [Type] -> CoreExpr -> VM CoreExpr
 251 parrayCoerce repr_tc args expr
 252   | Just arg_co <- tyConFamilyCoercion_maybe repr_tc
 253   = do
 254       parray <- builtin parrayTyCon
 255
 256       let co = mkAppCoercion (mkTyConApp parray [])
 257                              (mkSymCoercion (mkTyConApp arg_co args))
 258
 259       return $ mkCoerce co expr
 260
 261 parrayReprTyCon :: Type -> VM (TyCon, [Type])
 262 parrayReprTyCon ty = builtin parrayTyCon >>= (`lookupFamInst` [ty])
 263
 264 parrayReprDataCon :: Type -> VM (DataCon, [Type])
 265 parrayReprDataCon ty
 266   = do
 267       (tc, arg_tys) <- parrayReprTyCon ty
 268       let [dc] = tyConDataCons tc
 269       return (dc, arg_tys)
 270
 271 mkVScrut :: VExpr -> VM (VExpr, TyCon, [Type])
 272 mkVScrut (ve, le)
 273   = do
 274       (tc, arg_tys) <- parrayReprTyCon (exprType ve)
 275       return ((ve, unwrapFamInstScrut tc arg_tys le), tc, arg_tys)
 276
 277 prDictOfType :: Type -> VM CoreExpr
 278 prDictOfType orig_ty
 279   | Just (tycon, ty_args) <- splitTyConApp_maybe orig_ty
 280   = do
 281       dfun <- traceMaybeV "prDictOfType" (ppr tycon) (lookupTyConPR tycon)
 282       prDFunApply (Var dfun) ty_args
 283
 284 prDFunApply :: CoreExpr -> [Type] -> VM CoreExpr
 285 prDFunApply dfun tys
 286   = do
 287       args <- mapM mkDFunArg arg_tys
 288       return $ mkApps mono_dfun args
 289   where
 290     mono_dfun    = mkTyApps dfun tys
 291     (arg_tys, _) = splitFunTys (exprType mono_dfun)
 292
 293 mkDFunArg :: Type -> VM CoreExpr
 294 mkDFunArg ty
 295   | Just (tycon, [arg]) <- splitTyConApp_maybe ty
 296
 297   = let name = tyConName tycon
 298
 299         get_dict | name == paTyConName = paDictOfType
 300                  | name == prTyConName = prDictOfType
 301                  | otherwise           = pprPanic "mkDFunArg" (ppr ty)
 302
 303     in get_dict arg
 304
 305 mkDFunArg ty = pprPanic "mkDFunArg" (ppr ty)
 306
 307 prCoerce :: TyCon -> [Type] -> CoreExpr -> VM CoreExpr
 308 prCoerce repr_tc args expr
 309   | Just arg_co <- tyConFamilyCoercion_maybe repr_tc
 310   = do
 311       pr_tc <- builtin prTyCon
 312
 313       let co = mkAppCoercion (mkTyConApp pr_tc [])
 314                              (mkSymCoercion (mkTyConApp arg_co args))
 315
 316       return $ mkCoerce co expr
 317
 318 paDictArgType :: TyVar -> VM (Maybe Type)
 319 paDictArgType tv = go (TyVarTy tv) (tyVarKind tv)
 320   where
 321     go ty k | Just k' <- kindView k = go ty k'
 322     go ty (FunTy k1 k2)
 323       = do
 324           tv   <- newTyVar FSLIT("a") k1
 325           mty1 <- go (TyVarTy tv) k1
 326           case mty1 of
 327             Just ty1 -> do
 328                           mty2 <- go (AppTy ty (TyVarTy tv)) k2
 329                           return $ fmap (ForAllTy tv . FunTy ty1) mty2
 330             Nothing  -> go ty k2
 331
 332     go ty k
 333       | isLiftedTypeKind k
 334       = liftM Just (mkPADictType ty)
 335
 336     go ty k = return Nothing
 337
 338 paDictOfType :: Type -> VM CoreExpr
 339 paDictOfType ty = paDictOfTyApp ty_fn ty_args
 340   where
 341     (ty_fn, ty_args) = splitAppTys ty
 342
 343 paDictOfTyApp :: Type -> [Type] -> VM CoreExpr
 344 paDictOfTyApp ty_fn ty_args
 345   | Just ty_fn' <- coreView ty_fn = paDictOfTyApp ty_fn' ty_args
 346 paDictOfTyApp (TyVarTy tv) ty_args
 347   = do
 348       dfun <- maybeV (lookupTyVarPA tv)
 349       paDFunApply dfun ty_args
 350 paDictOfTyApp (TyConApp tc _) ty_args
 351   = do
 352       dfun <- traceMaybeV "paDictOfTyApp" (ppr tc) (lookupTyConPA tc)
 353       paDFunApply (Var dfun) ty_args
 354 paDictOfTyApp ty ty_args = pprPanic "paDictOfTyApp" (ppr ty)
 355
 356 paDFunType :: TyCon -> VM Type
 357 paDFunType tc
 358   = do
 359       margs <- mapM paDictArgType tvs
 360       res   <- mkPADictType (mkTyConApp tc arg_tys)
 361       return . mkForAllTys tvs
 362              $ mkFunTys [arg | Just arg <- margs] res
 363   where
 364     tvs = tyConTyVars tc
 365     arg_tys = mkTyVarTys tvs
 366
 367 paDFunApply :: CoreExpr -> [Type] -> VM CoreExpr
 368 paDFunApply dfun tys
 369   = do
 370       dicts <- mapM paDictOfType tys
 371       return $ mkApps (mkTyApps dfun tys) dicts
 372
 373 paMethod :: (Builtins -> Var) -> Type -> VM CoreExpr
 374 paMethod method ty
 375   = do
 376       fn   <- builtin method
 377       dict <- paDictOfType ty
 378       return $ mkApps (Var fn) [Type ty, dict]
 379
 380 mkPR :: Type -> VM CoreExpr
 381 mkPR = paMethod mkPRVar
 382
 383 lengthPA :: CoreExpr -> VM CoreExpr
 384 lengthPA x = liftM (`App` x) (paMethod lengthPAVar ty)
 385   where
 386     ty = splitPArrayTy (exprType x)
 387
 388 replicatePA :: CoreExpr -> CoreExpr -> VM CoreExpr
 389 replicatePA len x = liftM (`mkApps` [len,x])
 390                           (paMethod replicatePAVar (exprType x))
 391
 392 emptyPA :: Type -> VM CoreExpr
 393 emptyPA = paMethod emptyPAVar
 394
 395 liftPA :: CoreExpr -> VM CoreExpr
 396 liftPA x
 397   = do
 398       lc <- builtin liftingContext
 399       replicatePA (Var lc) x
 400
 401 newLocalVVar :: FastString -> Type -> VM VVar
 402 newLocalVVar fs vty
 403   = do
 404       lty <- mkPArrayType vty
 405       vv  <- newLocalVar fs vty
 406       lv  <- newLocalVar fs lty
 407       return (vv,lv)
 408
 409 polyAbstract :: [TyVar] -> ((CoreExpr -> CoreExpr) -> VM a) -> VM a
 410 polyAbstract tvs p
 411   = localV
 412   $ do
 413       mdicts <- mapM mk_dict_var tvs
 414       zipWithM_ (\tv -> maybe (defLocalTyVar tv) (defLocalTyVarWithPA tv . Var)) tvs mdicts
 415       p (mk_lams mdicts)
 416   where
 417     mk_dict_var tv = do
 418                        r <- paDictArgType tv
 419                        case r of
 420                          Just ty -> liftM Just (newLocalVar FSLIT("dPA") ty)
 421                          Nothing -> return Nothing
 422
 423     mk_lams mdicts = mkLams (tvs ++ [dict | Just dict <- mdicts])
 424
 425 polyApply :: CoreExpr -> [Type] -> VM CoreExpr
 426 polyApply expr tys
 427   = do
 428       dicts <- mapM paDictOfType tys
 429       return $ expr `mkTyApps` tys `mkApps` dicts
 430
 431 polyVApply :: VExpr -> [Type] -> VM VExpr
 432 polyVApply expr tys
 433   = do
 434       dicts <- mapM paDictOfType tys
 435       return $ mapVect (\e -> e `mkTyApps` tys `mkApps` dicts) expr
 436
 437 hoistBinding :: Var -> CoreExpr -> VM ()
 438 hoistBinding v e = updGEnv $ \env ->
 439   env { global_bindings = (v,e) : global_bindings env }
 440
 441 hoistExpr :: FastString -> CoreExpr -> VM Var
 442 hoistExpr fs expr
 443   = do
 444       var <- newLocalVar fs (exprType expr)
 445       hoistBinding var expr
 446       return var
 447
 448 hoistVExpr :: VExpr -> VM VVar
 449 hoistVExpr (ve, le)
 450   = do
 451       fs <- getBindName
 452       vv <- hoistExpr ('v' `consFS` fs) ve
 453       lv <- hoistExpr ('l' `consFS` fs) le
 454       return (vv, lv)
 455
 456 hoistPolyVExpr :: [TyVar] -> VM VExpr -> VM VExpr
 457 hoistPolyVExpr tvs p
 458   = do
 459       expr <- closedV . polyAbstract tvs $ \abstract ->
 460               liftM (mapVect abstract) p
 461       fn   <- hoistVExpr expr
 462       polyVApply (vVar fn) (mkTyVarTys tvs)
 463
 464 takeHoisted :: VM [(Var, CoreExpr)]
 465 takeHoisted
 466   = do
 467       env <- readGEnv id
 468       setGEnv $ env { global_bindings = [] }
 469       return $ global_bindings env
 470
 471 mkClosure :: Type -> Type -> Type -> VExpr -> VExpr -> VM VExpr
 472 mkClosure arg_ty res_ty env_ty (vfn,lfn) (venv,lenv)
 473   = do
 474       dict <- paDictOfType env_ty
 475       mkv  <- builtin mkClosureVar
 476       mkl  <- builtin mkClosurePVar
 477       return (Var mkv `mkTyApps` [arg_ty, res_ty, env_ty] `mkApps` [dict, vfn, lfn, venv],
 478               Var mkl `mkTyApps` [arg_ty, res_ty, env_ty] `mkApps` [dict, vfn, lfn, lenv])
 479
 480 mkClosureApp :: VExpr -> VExpr -> VM VExpr
 481 mkClosureApp (vclo, lclo) (varg, larg)
 482   = do
 483       vapply <- builtin applyClosureVar
 484       lapply <- builtin applyClosurePVar
 485       return (Var vapply `mkTyApps` [arg_ty, res_ty] `mkApps` [vclo, varg],
 486               Var lapply `mkTyApps` [arg_ty, res_ty] `mkApps` [lclo, larg])
 487   where
 488     (arg_ty, res_ty) = splitClosureTy (exprType vclo)
 489
 490 buildClosures :: [TyVar] -> [VVar] -> [Type] -> Type -> VM VExpr -> VM VExpr
 491 buildClosures tvs vars [] res_ty mk_body
 492   = mk_body
 493 buildClosures tvs vars [arg_ty] res_ty mk_body
 494   = buildClosure tvs vars arg_ty res_ty mk_body
 495 buildClosures tvs vars (arg_ty : arg_tys) res_ty mk_body
 496   = do
 497       res_ty' <- mkClosureTypes arg_tys res_ty
 498       arg <- newLocalVVar FSLIT("x") arg_ty
 499       buildClosure tvs vars arg_ty res_ty'
 500         . hoistPolyVExpr tvs
 501         $ do
 502             lc <- builtin liftingContext
 503             clo <- buildClosures tvs (vars ++ [arg]) arg_tys res_ty mk_body
 504             return $ vLams lc (vars ++ [arg]) clo
 505
 506 -- (clo <x1,...,xn> <f,f^>, aclo (Arr lc xs1 ... xsn) <f,f^>)
 507 --   where
 508 --     f  = \env v -> case env of <x1,...,xn> -> e x1 ... xn v
 509 --     f^ = \env v -> case env of Arr l xs1 ... xsn -> e^ l x1 ... xn v
 510 --
 511 buildClosure :: [TyVar] -> [VVar] -> Type -> Type -> VM VExpr -> VM VExpr
 512 buildClosure tvs vars arg_ty res_ty mk_body
 513   = do
 514       (env_ty, env, bind) <- buildEnv vars
 515       env_bndr <- newLocalVVar FSLIT("env") env_ty
 516       arg_bndr <- newLocalVVar FSLIT("arg") arg_ty
 517
 518       fn <- hoistPolyVExpr tvs
 519           $ do
 520               lc    <- builtin liftingContext
 521               body  <- mk_body
 522               body' <- bind (vVar env_bndr)
 523                             (vVarApps lc body (vars ++ [arg_bndr]))
 524               return (vLamsWithoutLC [env_bndr, arg_bndr] body')
 525
 526       mkClosure arg_ty res_ty env_ty fn env
 527
 528 buildEnv :: [VVar] -> VM (Type, VExpr, VExpr -> VExpr -> VM VExpr)
 529 buildEnv vvs
 530   = do
 531       lc <- builtin liftingContext
 532       let (ty, venv, vbind) = mkVectEnv tys vs
 533       (lenv, lbind) <- mkLiftEnv lc tys ls
 534       return (ty, (venv, lenv),
 535               \(venv,lenv) (vbody,lbody) ->
 536               do
 537                 let vbody' = vbind venv vbody
 538                 lbody' <- lbind lenv lbody
 539                 return (vbody', lbody'))
 540   where
 541     (vs,ls) = unzip vvs
 542     tys     = map idType vs
 543
 544 mkVectEnv :: [Type] -> [Var] -> (Type, CoreExpr, CoreExpr -> CoreExpr -> CoreExpr)
 545 mkVectEnv []   []  = (unitTy, Var unitDataConId, \env body -> body)
 546 mkVectEnv [ty] [v] = (ty, Var v, \env body -> Let (NonRec v env) body)
 547 mkVectEnv tys  vs  = (ty, mkCoreTup (map Var vs),
 548                         \env body -> Case env (mkWildId ty) (exprType body)
 549                                        [(DataAlt (tupleCon Boxed (length vs)), vs, body)])
 550   where
 551     ty = mkCoreTupTy tys
 552
 553 mkLiftEnv :: Var -> [Type] -> [Var] -> VM (CoreExpr, CoreExpr -> CoreExpr -> VM CoreExpr)
 554 mkLiftEnv lc [ty] [v]
 555   = return (Var v, \env body ->
 556                    do
 557                      len <- lengthPA (Var v)
 558                      return . Let (NonRec v env)
 559                             $ Case len lc (exprType body) [(DEFAULT, [], body)])
 560
 561 -- NOTE: this transparently deals with empty environments
 562 mkLiftEnv lc tys vs
 563   = do
 564       (env_tc, env_tyargs) <- parrayReprTyCon vty
 565       let [env_con] = tyConDataCons env_tc
 566
 567           env = Var (dataConWrapId env_con)
 568                 `mkTyApps`  env_tyargs
 569                 `mkVarApps` (lc : vs)
 570
 571           bind env body = let scrut = unwrapFamInstScrut env_tc env_tyargs env
 572                           in
 573                           return $ Case scrut (mkWildId (exprType scrut))
 574                                         (exprType body)
 575                                         [(DataAlt env_con, lc : bndrs, body)]
 576       return (env, bind)
 577   where
 578     vty = mkCoreTupTy tys
 579
 580     bndrs | null vs   = [mkWildId unitTy]
 581           | otherwise = vs
 582