- let (ty, venv, vbind) = mkVectEnv tys vs
- (lenv, lbind) <- mkLiftEnv lv tys ls
- return (ty, (venv, lenv),
- \(venv,lenv) (vbody,lbody) ->
- do
- let vbody' = vbind venv vbody
- lbody' <- lbind lenv lbody
- return (vbody', lbody'))
- where
- (vs,ls) = unzip vvs
- tys = map idType vs
-
-mkVectEnv :: [Type] -> [Var] -> (Type, CoreExpr, CoreExpr -> CoreExpr -> CoreExpr)
-mkVectEnv [] [] = (unitTy, Var unitDataConId, \env body -> body)
-mkVectEnv [ty] [v] = (ty, Var v, \env body -> Let (NonRec v env) body)
-mkVectEnv tys vs = (ty, mkCoreTup (map Var vs),
- \env body -> Case env (mkWildId ty) (exprType body)
- [(DataAlt (tupleCon Boxed (length vs)), vs, body)])
- where
- ty = mkCoreTupTy tys
-
-mkLiftEnv :: Var -> [Type] -> [Var] -> VM (CoreExpr, CoreExpr -> CoreExpr -> VM CoreExpr)
-mkLiftEnv lv [ty] [v]
- = return (Var v, \env body ->
- do
- len <- lengthPA (Var v)
- return . Let (NonRec v env)
- $ Case len lv (exprType body) [(DEFAULT, [], body)])
-
--- NOTE: this transparently deals with empty environments
-mkLiftEnv lv tys vs
- = do
- (env_tc, env_tyargs) <- lookupPArrayFamInst vty
- let [env_con] = tyConDataCons env_tc
-
- env = Var (dataConWrapId env_con)
- `mkTyApps` env_tyargs
- `mkVarApps` (lv : vs)
-
- bind env body = let scrut = unwrapFamInstScrut env_tc env_tyargs env
- in
- return $ Case scrut (mkWildId (exprType scrut))
- (exprType body)
- [(DataAlt env_con, lv : bndrs, body)]
- return (env, bind)
- where
- vty = mkCoreTupTy tys