-packLiftingContext :: CoreExpr -> CoreExpr -> CoreExpr -> VarSet
- -> Type -> Type -> VM VExpr -> VM VExpr
-packLiftingContext len shape tag fvs vty lty p
- = do
- select <- builtin selectPAIntPrimVar
- let sel_expr = mkApps (Var select) [shape, tag]
- sel_var <- newLocalVar (fsLit "sel#") (exprType sel_expr)
- lc_var <- builtin liftingContext
- localV $
- do
- bnds <- mapM (packFreeVar (Var lc_var) (Var sel_var))
- . filter isLocalId
- $ varSetElems fvs
- (vexpr, lexpr) <- p
- empty <- emptyPA vty
- return (vexpr, Let (NonRec sel_var sel_expr)
- $ Case len lc_var lty
- [(DEFAULT, [], mkLets (concat bnds) lexpr),
- (LitAlt (mkMachInt 0), [], empty)])
-
-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') }
+ pack_var len flags v
+ = do
+ r <- lookupVar v
+ case r of
+ Local (vv, lv) ->
+ do
+ lv' <- cloneVar lv
+ expr <- packPD (idType vv) (Var lv) len flags
+ updLEnv (\env -> env { local_vars = extendVarEnv
+ (local_vars env) v (vv, lv') })
+ return [(NonRec lv' expr)]
+
+ _ -> return []