+
+vectPolyVar :: CoreExpr -> Var -> [Type] -> VM (CoreExpr, CoreExpr)
+vectPolyVar lc v tys
+ = do
+ r <- readLEnv $ \env -> lookupVarEnv (local_vars env) v
+ case r of
+ Just (vexpr, lexpr) -> liftM2 (,) (mk_app vexpr) (mk_app lexpr)
+ Nothing ->
+ do
+ poly <- maybeV (readGEnv $ \env -> lookupVarEnv (global_vars env) v)
+ vexpr <- mk_app poly
+ lexpr <- replicateP vexpr lc
+ return (vexpr, lexpr)
+ where
+ mk_app e = do
+ vtys <- mapM vectType tys
+ dicts <- mapM paDictOfType vtys
+ return $ mkApps e [arg | (vty, dict) <- zip vtys dicts
+ , arg <- [Type vty, dict]]
+
+vectPolyExpr :: CoreExpr -> CoreExprWithFVs -> VM (CoreExpr, CoreExpr)
+vectPolyExpr lc expr
+ = do
+ mdicts <- mapM mk_dict_var tvs
+
+ -- FIXME: shadowing (tvs in lc)
+ (vmono, lmono) <- localV
+ $ do
+ zipWithM_ (\tv -> maybe (deleteTyVarPA tv) (extendTyVarPA tv . Var))
+ tvs mdicts
+ vectExpr lc mono
+ return (mk_lams tvs mdicts vmono, mk_lams tvs mdicts lmono)
+ where
+ (tvs, mono) = collectAnnTypeBinders expr
+
+ mk_dict_var tv = do
+ r <- paDictArgType tv
+ case r of
+ Just ty -> liftM Just (newLocalVar FSLIT("dPA") ty)
+ Nothing -> return Nothing
+
+ mk_lams tvs mdicts = mkLams [arg | (tv, mdict) <- zip tvs mdicts
+ , arg <- tv : maybeToList mdict]