Vectorise.hs 15.2 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' <- vectExpr 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
vectExpr e@(fvs, AnnLam bndr _)
267
268
  | isId bndr = onlyIfV (isEmptyVarSet fvs) (vectScalarLam bs $ deAnnotate body)
                `orElseV` vectLam fvs bs body
269
270
  where
    (bs,body) = collectAnnValBinders e
271

272
vectExpr e = cantVectorise "Can't vectorise expression" (ppr $ deAnnotate e)
273

274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
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
301
    is_scalar _ e@(Lit _)    = is_scalar_ty $ exprType e
302
303
304
    is_scalar vs (App e1 e2) = is_scalar vs e1 && is_scalar vs e2
    is_scalar _ _            = False

305
306
vectLam :: VarSet -> [Var] -> CoreExprWithFVs -> VM VExpr
vectLam fvs bs body
307
  = do
308
      tyvars <- localTyVars
309
310
311
      (vs, vvs) <- readLEnv $ \env ->
                   unzip [(var, vv) | var <- varSetElems fvs
                                    , Just vv <- [lookupVarEnv (local_vars env) var]]
312

313
314
315
      arg_tys <- mapM (vectType . idType) bs
      res_ty  <- vectType (exprType $ deAnnotate body)

316
      buildClosures tyvars vvs arg_tys res_ty
317
        . hoistPolyVExpr tyvars
318
        $ do
319
            lc <- builtin liftingContext
320
            (vbndrs, vbody) <- vectBndrsIn (vs ++ bs)
321
                                           (vectExpr body)
322
            return $ vLams lc vbndrs vbody
Ian Lynagh's avatar
Ian Lynagh committed
323

324
325
vectTyAppExpr :: CoreExprWithFVs -> [Type] -> VM VExpr
vectTyAppExpr (_, AnnVar v) tys = vectPolyVar v tys
326
327
vectTyAppExpr e tys = cantVectorise "Can't vectorise expression"
                        (ppr $ deAnnotate e `mkTyApps` tys)
328
329
330
331
332
333
334

-- We convert
--
--   case e :: t of v { ... }
--
-- to
--
335
336
--   V:    let v' = e in case v' of _ { ... }
--   L:    let v' = e in case v' `cast` ... of _ { ... }
337
338
--
-- When lifting, we have to do it this way because v must have the type
339
340
-- [: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
341
--
342
343

-- FIXME: this is too lazy
Ian Lynagh's avatar
Ian Lynagh committed
344
345
346
347
vectAlgCase :: TyCon -> [Type] -> CoreExprWithFVs -> Var -> Type
            -> [(AltCon, [Var], CoreExprWithFVs)]
            -> VM VExpr
vectAlgCase _tycon _ty_args scrut bndr ty [(DEFAULT, [], body)]
348
  = do
349
350
      vscrut         <- vectExpr scrut
      (vty, lty)     <- vectAndLiftType ty
351
352
353
      (vbndr, vbody) <- vectBndrIn bndr (vectExpr body)
      return $ vCaseDEFAULT vscrut vbndr vty lty vbody

Ian Lynagh's avatar
Ian Lynagh committed
354
vectAlgCase _tycon _ty_args scrut bndr ty [(DataAlt _, [], body)]
355
  = do
356
357
      vscrut         <- vectExpr scrut
      (vty, lty)     <- vectAndLiftType ty
358
359
360
      (vbndr, vbody) <- vectBndrIn bndr (vectExpr body)
      return $ vCaseDEFAULT vscrut vbndr vty lty vbody

Ian Lynagh's avatar
Ian Lynagh committed
361
vectAlgCase tycon _ty_args scrut bndr ty [(DataAlt dc, bndrs, body)]
362
  = do
363
364
365
      vect_tc    <- maybeV (lookupTyCon tycon)
      (vty, lty) <- vectAndLiftType ty
      vexpr      <- vectExpr scrut
366
      (vbndr, (vbndrs, vbody)) <- vect_scrut_bndr
367
368
369
                                . vectBndrsIn bndrs
                                $ vectExpr body

Ian Lynagh's avatar
Ian Lynagh committed
370
      (vscrut, arr_tc, _arg_tys) <- mkVScrut (vVar vbndr)
371
372
      vect_dc <- maybeV (lookupDataCon dc)
      let [arr_dc] = tyConDataCons arr_tc
373
374
      repr <- mkRepr vect_tc
      shape_bndrs <- arrShapeVars repr
375
376
      return . vLet (vNonRec vbndr vexpr)
             $ vCaseProd vscrut vty lty vect_dc arr_dc shape_bndrs vbndrs vbody
377
  where
Ian Lynagh's avatar
Ian Lynagh committed
378
    vect_scrut_bndr | isDeadBinder bndr = vectBndrNewIn bndr (fsLit "scrut")
379
380
                    | otherwise         = vectBndrIn bndr

Ian Lynagh's avatar
Ian Lynagh committed
381
vectAlgCase tycon _ty_args scrut bndr ty alts
382
  = do
383
384
      vect_tc     <- maybeV (lookupTyCon tycon)
      (vty, lty)  <- vectAndLiftType ty
385
386
387
388
      repr        <- mkRepr vect_tc
      shape_bndrs <- arrShapeVars repr
      (len, sel, indices) <- arrSelector repr (map Var shape_bndrs)

389
      (vbndr, valts) <- vect_scrut_bndr $ mapM (proc_alt sel vty lty) alts'
390
391
392
      let (vect_dcs, vect_bndrss, lift_bndrss, vbodies) = unzip4 valts

      vexpr <- vectExpr scrut
Ian Lynagh's avatar
Ian Lynagh committed
393
      (vscrut, arr_tc, _arg_tys) <- mkVScrut (vVar vbndr)
394
395
396
397
398
      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
399
400
401
      vdummy <- newDummyVar (exprType vect_scrut)
      ldummy <- newDummyVar (exprType lift_scrut)
      let vect_case = Case vect_scrut vdummy vty
402
403
404
                           (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
405
      let lift_case = Case lift_scrut ldummy lty
406
407
408
409
410
411
                           [(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
412
    vect_scrut_bndr | isDeadBinder bndr = vectBndrNewIn bndr (fsLit "scrut")
413
414
415
416
417
418
419
420
                    | 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
421
    cmp _             _             = panic "vectAlgCase/cmp"
422

423
    proc_alt sel vty lty (DataAlt dc, bndrs, body)
424
425
426
427
428
429
      = 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
430
             $ \len -> packLiftingContext len sel tag fvs vty lty
431
432
433
             $ vectExpr body

          return (vect_dc, vect_bndrs, lift_bndrs, vbody)
Ian Lynagh's avatar
Ian Lynagh committed
434
    proc_alt _ _ _ _ = panic "vectAlgCase/proc_alt"
435
436
437
438
439
440

    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
441
          bndr   <- newLocalVar (fsLit "voids") arr_ty
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
          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)

459
460
461
packLiftingContext :: CoreExpr -> CoreExpr -> CoreExpr -> VarSet
                   -> Type -> Type -> VM VExpr -> VM VExpr
packLiftingContext len shape tag fvs vty lty p
462
463
464
  = do
      select <- builtin selectPAIntPrimVar
      let sel_expr = mkApps (Var select) [shape, tag]
Ian Lynagh's avatar
Ian Lynagh committed
465
      sel_var <- newLocalVar (fsLit "sel#") (exprType sel_expr)
466
467
468
      lc_var <- builtin liftingContext
      localV $
        do
469
470
471
          bnds <- mapM (packFreeVar (Var lc_var) (Var sel_var))
                . filter isLocalId
                $ varSetElems fvs
472
          (vexpr, lexpr) <- p
473
          empty <- emptyPA vty
474
          return (vexpr, Let (NonRec sel_var sel_expr)
475
                         $ Case len lc_var lty
476
                             [(DEFAULT, [], mkLets (concat bnds) lexpr),
477
                              (LitAlt (mkMachInt 0), [], empty)])
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494

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') }