Vectorise.hs 15.7 KB
Newer Older
1

2 3 4
module Vectorise( vectorise )
where

5
import VectMonad
6
import VectUtils
7
import VectType
8
import VectCore
9

10
import HscTypes hiding      ( MonadThings(..) )
11

12
import Module               ( PackageId )
13
import CoreSyn
14 15
import CoreUtils
import CoreFVs
16
import CoreMonad            ( CoreM, getHscEnv, liftIO )
17
import DataCon
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
18
import TyCon
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
19
import Type
20
import FamInstEnv           ( extendFamInstEnvList )
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
21 22
import Var
import VarEnv
23
import VarSet
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
24
import Id
25
import OccName
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
26

Ian Lynagh's avatar
Ian Lynagh committed
27
import DsMonad
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
28

29
import Literal              ( Literal, mkMachInt )
30
import TysWiredIn
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
31

32
import Outputable
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
33
import FastString
Ian Lynagh's avatar
Ian Lynagh committed
34
import Control.Monad        ( liftM, liftM2, zipWithM )
35
import Data.List            ( sortBy, unzip4 )
36

37 38 39 40 41 42 43
vectorise :: PackageId -> ModGuts -> CoreM ModGuts
vectorise backend guts = do
    hsc_env <- getHscEnv
    liftIO $ vectoriseIO backend hsc_env guts

vectoriseIO :: PackageId -> HscEnv -> ModGuts -> IO ModGuts
vectoriseIO backend hsc_env guts
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
44 45 46
  = do
      eps <- hscEPS hsc_env
      let info = hptVectInfo hsc_env `plusVectInfo` eps_vect_info eps
47
      Just (info', guts') <- initV backend hsc_env guts info (vectModule guts)
48
      return (guts' { mg_vect_info = info' })
49

rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
50
vectModule :: ModGuts -> VM ModGuts
51 52
vectModule guts
  = do
53
      (types', fam_insts, tc_binds) <- vectTypeEnv (mg_types guts)
Ian Lynagh's avatar
Ian Lynagh committed
54

55 56
      let fam_inst_env' = extendFamInstEnvList (mg_fam_inst_env guts) fam_insts
      updGEnv (setFamInstEnv fam_inst_env')
Ian Lynagh's avatar
Ian Lynagh committed
57

58 59
      -- dicts   <- mapM buildPADict pa_insts
      -- workers <- mapM vectDataConWorkers pa_insts
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
60
      binds'  <- mapM vectTopBind (mg_binds guts)
61
      return $ guts { mg_types        = types'
62
                    , mg_binds        = Rec tc_binds : binds'
63 64 65
                    , mg_fam_inst_env = fam_inst_env'
                    , mg_fam_insts    = mg_fam_insts guts ++ fam_insts
                    }
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
66

67
vectTopBind :: CoreBind -> VM CoreBind
68 69 70
vectTopBind b@(NonRec var expr)
  = do
      var'  <- vectTopBinder var
71
      expr' <- vectTopRhs var expr
72
      hs    <- takeHoisted
73 74
      cexpr <- tryConvert var var' expr
      return . Rec $ (var, cexpr) : (var', expr') : hs
75 76 77 78 79 80
  `orElseV`
    return b

vectTopBind b@(Rec bs)
  = do
      vars'  <- mapM vectTopBinder vars
81
      exprs' <- zipWithM vectTopRhs vars exprs
82
      hs     <- takeHoisted
83 84
      cexprs <- sequence $ zipWith3 tryConvert vars vars' exprs
      return . Rec $ zip vars cexprs ++ zip vars' exprs' ++ hs
85 86 87 88 89 90 91 92
  `orElseV`
    return b
  where
    (vars, exprs) = unzip bs

vectTopBinder :: Var -> VM Var
vectTopBinder var
  = do
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
93 94
      vty  <- vectType (idType var)
      var' <- cloneId mkVectOcc var vty
95 96
      defGlobalVar var var'
      return var'
Ian Lynagh's avatar
Ian Lynagh committed
97

98 99
vectTopRhs :: Var -> CoreExpr -> VM CoreExpr
vectTopRhs var expr
100 101
  = do
      closedV . liftM vectorised
102
              . inBind var
103
              $ vectPolyExpr (freeVars expr)
104

105 106 107 108
tryConvert :: Var -> Var -> CoreExpr -> VM CoreExpr
tryConvert var vect_var rhs
  = fromVect (idType var) (Var vect_var) `orElseV` return rhs

109 110
-- ----------------------------------------------------------------------------
-- Bindings
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
111

112
vectBndr :: Var -> VM VVar
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
113 114
vectBndr v
  = do
115
      (vty, lty) <- vectAndLiftType (idType v)
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
116 117 118 119 120
      let vv = v `Id.setIdType` vty
          lv = v `Id.setIdType` lty
      updLEnv (mapTo vv lv)
      return (vv, lv)
  where
121
    mapTo vv lv env = env { local_vars = extendVarEnv (local_vars env) v (vv, lv) }
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
122

123 124 125 126 127 128 129 130 131 132
vectBndrNew :: Var -> FastString -> VM VVar
vectBndrNew v fs
  = do
      vty <- vectType (idType v)
      vv  <- newLocalVVar fs vty
      updLEnv (upd vv)
      return vv
  where
    upd vv env = env { local_vars = extendVarEnv (local_vars env) v vv }

133
vectBndrIn :: Var -> VM a -> VM (VVar, a)
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
134 135 136
vectBndrIn v p
  = localV
  $ do
137
      vv <- vectBndr v
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
138
      x <- p
139
      return (vv, x)
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
140

141 142 143 144 145 146 147 148
vectBndrNewIn :: Var -> FastString -> VM a -> VM (VVar, a)
vectBndrNewIn v fs p
  = localV
  $ do
      vv <- vectBndrNew v fs
      x  <- p
      return (vv, x)

149
vectBndrsIn :: [Var] -> VM a -> VM ([VVar], a)
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
150 151 152
vectBndrsIn vs p
  = localV
  $ do
153
      vvs <- mapM vectBndr vs
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
154
      x <- p
155
      return (vvs, x)
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
156

rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
157
-- ----------------------------------------------------------------------------
158 159
-- Expressions

160 161
vectVar :: Var -> VM VExpr
vectVar v
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
162 163 164
  = do
      r <- lookupVar v
      case r of
165 166 167
        Local (vv,lv) -> return (Var vv, Var lv)
        Global vv     -> do
                           let vexpr = Var vv
168
                           lexpr <- liftPA vexpr
169
                           return (vexpr, lexpr)
170

171 172
vectPolyVar :: Var -> [Type] -> VM VExpr
vectPolyVar v tys
173
  = do
174
      vtys <- mapM vectType tys
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
175
      r <- lookupVar v
176
      case r of
177 178 179 180
        Local (vv, lv) -> liftM2 (,) (polyApply (Var vv) vtys)
                                     (polyApply (Var lv) vtys)
        Global poly    -> do
                            vexpr <- polyApply (Var poly) vtys
181
                            lexpr <- liftPA vexpr
182
                            return (vexpr, lexpr)
183

184 185
vectLiteral :: Literal -> VM VExpr
vectLiteral lit
186
  = do
187
      lexpr <- liftPA (Lit lit)
188 189
      return (Lit lit, lexpr)

190
vectPolyExpr :: CoreExprWithFVs -> VM VExpr
191 192
vectPolyExpr (_, AnnNote note expr)
  = liftM (vNote note) $ vectPolyExpr expr
193
vectPolyExpr expr
194
  = polyAbstract tvs $ \abstract ->
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
195
    do
196
      mono' <- vectFnExpr False mono
197
      return $ mapVect abstract mono'
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
198
  where
Ian Lynagh's avatar
Ian Lynagh committed
199 200
    (tvs, mono) = collectAnnTypeBinders expr

201 202
vectExpr :: CoreExprWithFVs -> VM VExpr
vectExpr (_, AnnType ty)
203
  = liftM vType (vectType ty)
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
204

205
vectExpr (_, AnnVar v) = vectVar v
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
206

207
vectExpr (_, AnnLit lit) = vectLiteral lit
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
208

209 210
vectExpr (_, AnnNote note expr)
  = liftM (vNote note) (vectExpr expr)
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
211

212
vectExpr e@(_, AnnApp _ arg)
213
  | isAnnTypeArg arg
214
  = vectTyAppExpr fn tys
215 216
  where
    (fn, tys) = collectAnnTypeArgs e
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
217

218 219 220 221 222 223 224 225 226
vectExpr (_, AnnApp (_, AnnVar v) (_, AnnLit lit))
  | Just con <- isDataConId_maybe v
  , is_special_con con
  = do
      let vexpr = App (Var v) (Lit lit)
      lexpr <- liftPA vexpr
      return (vexpr, lexpr)
  where
    is_special_con con = con `elem` [intDataCon, floatDataCon, doubleDataCon]
Ian Lynagh's avatar
Ian Lynagh committed
227

228

229
vectExpr (_, AnnApp fn arg)
230
  = do
231 232 233 234 235 236 237
      arg_ty' <- vectType arg_ty
      res_ty' <- vectType res_ty
      fn'     <- vectExpr fn
      arg'    <- vectExpr arg
      mkClosureApp arg_ty' res_ty' fn' arg'
  where
    (arg_ty, res_ty) = splitFunTy . exprType $ deAnnotate fn
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
238

239
vectExpr (_, AnnCase scrut bndr ty alts)
240 241 242
  | Just (tycon, ty_args) <- splitTyConApp_maybe scrut_ty
  , isAlgTyCon tycon
  = vectAlgCase tycon ty_args scrut bndr ty alts
243 244 245
  where
    scrut_ty = exprType (deAnnotate scrut)

246
vectExpr (_, AnnLet (AnnNonRec bndr rhs) body)
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
247
  = do
248 249
      vrhs <- localV . inBind bndr $ vectPolyExpr rhs
      (vbndr, vbody) <- vectBndrIn bndr (vectExpr body)
250
      return $ vLet (vNonRec vbndr vrhs) vbody
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
251

252
vectExpr (_, AnnLet (AnnRec bs) body)
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
253
  = do
254 255
      (vbndrs, (vrhss, vbody)) <- vectBndrsIn bndrs
                                $ liftM2 (,)
256
                                  (zipWithM vect_rhs bndrs rhss)
257
                                  (vectPolyExpr body)
258
      return $ vLet (vRec vbndrs vrhss) vbody
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
259
  where
260
    (bndrs, rhss) = unzip bs
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
261

262 263
    vect_rhs bndr rhs = localV
                      . inBind bndr
264
                      $ vectExpr rhs
265

266 267 268 269 270
vectExpr e@(_, AnnLam bndr _)
  | isId bndr = vectFnExpr True e
{-
onlyIfV (isEmptyVarSet fvs) (vectScalarLam bs $ deAnnotate body)
                `orElseV` vectLam True fvs bs body
271 272
  where
    (bs,body) = collectAnnValBinders e
273
-}
274

275
vectExpr e = cantVectorise "Can't vectorise expression" (ppr $ deAnnotate e)
276

277 278 279 280 281 282 283 284 285
vectFnExpr :: Bool -> CoreExprWithFVs -> VM VExpr
vectFnExpr inline e@(fvs, AnnLam bndr _)
  | isId bndr = onlyIfV (isEmptyVarSet fvs) (vectScalarLam bs $ deAnnotate body)
                `orElseV` vectLam inline fvs bs body
  where
    (bs,body) = collectAnnValBinders e
vectFnExpr _ e = vectExpr e


286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312
vectScalarLam :: [Var] -> CoreExpr -> VM VExpr
vectScalarLam args body
  = do
      scalars <- globalScalars
      onlyIfV (all is_scalar_ty arg_tys
               && is_scalar_ty res_ty
               && is_scalar (extendVarSetList scalars args) body)
        $ do
            fn_var <- hoistExpr (fsLit "fn") (mkLams args body)
            zipf <- zipScalars arg_tys res_ty
            clo <- scalarClosure arg_tys res_ty (Var fn_var)
                                                (zipf `App` Var fn_var)
            clo_var <- hoistExpr (fsLit "clo") clo
            lclo <- liftPA (Var clo_var)
            return (Var clo_var, lclo)
  where
    arg_tys = map idType args
    res_ty  = exprType body

    is_scalar_ty ty | Just (tycon, []) <- splitTyConApp_maybe ty
                    = tycon == intTyCon
                      || tycon == floatTyCon
                      || tycon == doubleTyCon

                    | otherwise = False

    is_scalar vs (Var v)     = v `elemVarSet` vs
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
313
    is_scalar _ e@(Lit _)    = is_scalar_ty $ exprType e
314 315 316
    is_scalar vs (App e1 e2) = is_scalar vs e1 && is_scalar vs e2
    is_scalar _ _            = False

317 318
vectLam :: Bool -> VarSet -> [Var] -> CoreExprWithFVs -> VM VExpr
vectLam inline fvs bs body
319
  = do
320
      tyvars <- localTyVars
321 322 323
      (vs, vvs) <- readLEnv $ \env ->
                   unzip [(var, vv) | var <- varSetElems fvs
                                    , Just vv <- [lookupVarEnv (local_vars env) var]]
324

325 326 327
      arg_tys <- mapM (vectType . idType) bs
      res_ty  <- vectType (exprType $ deAnnotate body)

328
      buildClosures tyvars vvs arg_tys res_ty
329
        . hoistPolyVExpr tyvars
330
        $ do
331
            lc <- builtin liftingContext
332
            (vbndrs, vbody) <- vectBndrsIn (vs ++ bs)
333
                                           (vectExpr body)
334 335 336
            return . maybe_inline $ vLams lc vbndrs vbody
  where
    maybe_inline = if inline then vInlineMe else id
Ian Lynagh's avatar
Ian Lynagh committed
337

338 339
vectTyAppExpr :: CoreExprWithFVs -> [Type] -> VM VExpr
vectTyAppExpr (_, AnnVar v) tys = vectPolyVar v tys
340 341
vectTyAppExpr e tys = cantVectorise "Can't vectorise expression"
                        (ppr $ deAnnotate e `mkTyApps` tys)
342 343 344 345 346 347 348

-- We convert
--
--   case e :: t of v { ... }
--
-- to
--
349 350
--   V:    let v' = e in case v' of _ { ... }
--   L:    let v' = e in case v' `cast` ... of _ { ... }
351 352
--
-- When lifting, we have to do it this way because v must have the type
353 354
-- [:V(T):] but the scrutinee must be cast to the representation type. We also
-- have to handle the case where v is a wild var correctly.
Ian Lynagh's avatar
Ian Lynagh committed
355
--
356 357

-- FIXME: this is too lazy
Ian Lynagh's avatar
Ian Lynagh committed
358 359 360 361
vectAlgCase :: TyCon -> [Type] -> CoreExprWithFVs -> Var -> Type
            -> [(AltCon, [Var], CoreExprWithFVs)]
            -> VM VExpr
vectAlgCase _tycon _ty_args scrut bndr ty [(DEFAULT, [], body)]
362
  = do
363 364
      vscrut         <- vectExpr scrut
      (vty, lty)     <- vectAndLiftType ty
365 366 367
      (vbndr, vbody) <- vectBndrIn bndr (vectExpr body)
      return $ vCaseDEFAULT vscrut vbndr vty lty vbody

Ian Lynagh's avatar
Ian Lynagh committed
368
vectAlgCase _tycon _ty_args scrut bndr ty [(DataAlt _, [], body)]
369
  = do
370 371
      vscrut         <- vectExpr scrut
      (vty, lty)     <- vectAndLiftType ty
372 373 374
      (vbndr, vbody) <- vectBndrIn bndr (vectExpr body)
      return $ vCaseDEFAULT vscrut vbndr vty lty vbody

Ian Lynagh's avatar
Ian Lynagh committed
375
vectAlgCase tycon _ty_args scrut bndr ty [(DataAlt dc, bndrs, body)]
376
  = do
377 378 379
      vect_tc    <- maybeV (lookupTyCon tycon)
      (vty, lty) <- vectAndLiftType ty
      vexpr      <- vectExpr scrut
380
      (vbndr, (vbndrs, vbody)) <- vect_scrut_bndr
381 382 383
                                . vectBndrsIn bndrs
                                $ vectExpr body

Ian Lynagh's avatar
Ian Lynagh committed
384
      (vscrut, arr_tc, _arg_tys) <- mkVScrut (vVar vbndr)
385 386
      vect_dc <- maybeV (lookupDataCon dc)
      let [arr_dc] = tyConDataCons arr_tc
387 388
      repr <- mkRepr vect_tc
      shape_bndrs <- arrShapeVars repr
389 390
      return . vLet (vNonRec vbndr vexpr)
             $ vCaseProd vscrut vty lty vect_dc arr_dc shape_bndrs vbndrs vbody
391
  where
Ian Lynagh's avatar
Ian Lynagh committed
392
    vect_scrut_bndr | isDeadBinder bndr = vectBndrNewIn bndr (fsLit "scrut")
393 394
                    | otherwise         = vectBndrIn bndr

Ian Lynagh's avatar
Ian Lynagh committed
395
vectAlgCase tycon _ty_args scrut bndr ty alts
396
  = do
397 398
      vect_tc     <- maybeV (lookupTyCon tycon)
      (vty, lty)  <- vectAndLiftType ty
399 400 401 402
      repr        <- mkRepr vect_tc
      shape_bndrs <- arrShapeVars repr
      (len, sel, indices) <- arrSelector repr (map Var shape_bndrs)

403
      (vbndr, valts) <- vect_scrut_bndr $ mapM (proc_alt sel vty lty) alts'
404 405 406
      let (vect_dcs, vect_bndrss, lift_bndrss, vbodies) = unzip4 valts

      vexpr <- vectExpr scrut
Ian Lynagh's avatar
Ian Lynagh committed
407
      (vscrut, arr_tc, _arg_tys) <- mkVScrut (vVar vbndr)
408 409 410 411 412
      let [arr_dc] = tyConDataCons arr_tc

      let (vect_scrut,  lift_scrut)  = vscrut
          (vect_bodies, lift_bodies) = unzip vbodies

rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
413 414 415
      vdummy <- newDummyVar (exprType vect_scrut)
      ldummy <- newDummyVar (exprType lift_scrut)
      let vect_case = Case vect_scrut vdummy vty
416 417 418
                           (zipWith3 mk_vect_alt vect_dcs vect_bndrss vect_bodies)

      lbody <- combinePA vty len sel indices lift_bodies
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
419
      let lift_case = Case lift_scrut ldummy lty
420 421 422 423 424 425
                           [(DataAlt arr_dc, shape_bndrs ++ concat lift_bndrss,
                             lbody)]

      return . vLet (vNonRec vbndr vexpr)
             $ (vect_case, lift_case)
  where
Ian Lynagh's avatar
Ian Lynagh committed
426
    vect_scrut_bndr | isDeadBinder bndr = vectBndrNewIn bndr (fsLit "scrut")
427 428 429 430 431 432 433 434
                    | otherwise         = vectBndrIn bndr

    alts' = sortBy (\(alt1, _, _) (alt2, _, _) -> cmp alt1 alt2) alts

    cmp (DataAlt dc1) (DataAlt dc2) = dataConTag dc1 `compare` dataConTag dc2
    cmp DEFAULT       DEFAULT       = EQ
    cmp DEFAULT       _             = LT
    cmp _             DEFAULT       = GT
Ian Lynagh's avatar
Ian Lynagh committed
435
    cmp _             _             = panic "vectAlgCase/cmp"
436

437
    proc_alt sel vty lty (DataAlt dc, bndrs, body)
438 439 440 441 442 443
      = do
          vect_dc <- maybeV (lookupDataCon dc)
          let tag = mkDataConTag vect_dc
              fvs = freeVarsOf body `delVarSetList` bndrs
          (vect_bndrs, lift_bndrs, vbody)
            <- vect_alt_bndrs bndrs
444
             $ \len -> packLiftingContext len sel tag fvs vty lty
445 446 447
             $ vectExpr body

          return (vect_dc, vect_bndrs, lift_bndrs, vbody)
Ian Lynagh's avatar
Ian Lynagh committed
448
    proc_alt _ _ _ _ = panic "vectAlgCase/proc_alt"
449 450 451 452 453 454

    vect_alt_bndrs [] p
      = do
          void_tc <- builtin voidTyCon
          let void_ty = mkTyConApp void_tc []
          arr_ty <- mkPArrayType void_ty
Ian Lynagh's avatar
Ian Lynagh committed
455
          bndr   <- newLocalVar (fsLit "voids") arr_ty
456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472
          len    <- lengthPA void_ty (Var bndr)
          e      <- p len
          return ([], [bndr], e)

    vect_alt_bndrs bndrs p
       = localV
       $ do
           vbndrs <- mapM vectBndr bndrs
           let (vect_bndrs, lift_bndrs) = unzip vbndrs
               vv : _ = vect_bndrs
               lv : _ = lift_bndrs
           len <- lengthPA (idType vv) (Var lv)
           e   <- p len
           return (vect_bndrs, lift_bndrs, e)

    mk_vect_alt vect_dc bndrs body = (DataAlt vect_dc, bndrs, body)

473 474 475
packLiftingContext :: CoreExpr -> CoreExpr -> CoreExpr -> VarSet
                   -> Type -> Type -> VM VExpr -> VM VExpr
packLiftingContext len shape tag fvs vty lty p
476 477 478
  = do
      select <- builtin selectPAIntPrimVar
      let sel_expr = mkApps (Var select) [shape, tag]
Ian Lynagh's avatar
Ian Lynagh committed
479
      sel_var <- newLocalVar (fsLit "sel#") (exprType sel_expr)
480 481 482
      lc_var <- builtin liftingContext
      localV $
        do
483 484 485
          bnds <- mapM (packFreeVar (Var lc_var) (Var sel_var))
                . filter isLocalId
                $ varSetElems fvs
486
          (vexpr, lexpr) <- p
487
          empty <- emptyPA vty
488
          return (vexpr, Let (NonRec sel_var sel_expr)
489
                         $ Case len lc_var lty
490
                             [(DEFAULT, [], mkLets (concat bnds) lexpr),
491
                              (LitAlt (mkMachInt 0), [], empty)])
492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508

packFreeVar :: CoreExpr -> CoreExpr -> Var -> VM [CoreBind]
packFreeVar len sel v
  = do
      r <- lookupVar v
      case r of
        Local (vv,lv) ->
          do
            lv' <- cloneVar lv
            expr <- packPA (idType vv) (Var lv) len sel
            updLEnv (upd vv lv')
            return [(NonRec lv' expr)]

        _  -> return []
  where
    upd vv lv' env = env { local_vars = extendVarEnv (local_vars env) v (vv, lv') }