- -- 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]
-
-vectExpr :: CoreExpr -> CoreExprWithFVs -> VM (CoreExpr, CoreExpr)
-vectExpr lc (_, AnnType ty)
- = do
- vty <- vectType ty
- return (Type vty, Type vty)
-vectExpr lc (_, AnnVar v) = vectVar lc v
-vectExpr lc (_, AnnLit lit)
- = do
- let vexpr = Lit lit
- lexpr <- replicateP vexpr lc
- return (vexpr, lexpr)
-vectExpr lc (_, AnnNote note expr)
- = do
- (vexpr, lexpr) <- vectExpr lc expr
- return (Note note vexpr, Note note lexpr)
-vectExpr lc e@(_, AnnApp _ arg)
- | isAnnTypeArg arg
- = vectTyAppExpr lc fn tys
- where
- (fn, tys) = collectAnnTypeArgs e
-vectExpr lc (_, AnnApp fn arg)
- = do
- fn' <- vectExpr lc fn
- arg' <- vectExpr lc arg
- capply fn' arg'
-vectExpr lc (_, AnnCase expr bndr ty alts)
- = panic "vectExpr: case"
-vectExpr lc (_, AnnLet (AnnNonRec bndr rhs) body)
- = do
- (vrhs, lrhs) <- vectPolyExpr lc rhs
- (vbndr, lbndr, (vbody, lbody)) <- vectBndrIn bndr (vectExpr lc body)
- return (Let (NonRec vbndr vrhs) vbody,
- Let (NonRec lbndr lrhs) lbody)
-vectExpr lc (_, AnnLet (AnnRec prs) body)
- = do
- (vbndrs, lbndrs, (vrhss, vbody, lrhss, lbody)) <- vectBndrsIn bndrs vect
- return (Let (Rec (zip vbndrs vrhss)) vbody,
- Let (Rec (zip lbndrs lrhss)) lbody)
- where
- (bndrs, rhss) = unzip prs
-
- vect = do
- (vrhss, lrhss) <- mapAndUnzipM (vectExpr lc) rhss
- (vbody, lbody) <- vectPolyExpr lc body
- return (vrhss, vbody, lrhss, lbody)
-vectExpr lc e@(_, AnnLam bndr body)
- | isTyVar bndr = pprPanic "vectExpr" (ppr $ deAnnotate e)
-
-vectTyAppExpr :: CoreExpr -> CoreExprWithFVs -> [Type] -> VM (CoreExpr, CoreExpr)
-vectTyAppExpr lc (_, AnnVar v) tys = vectPolyVar lc v tys
-vectTyAppExpr lc e tys = pprPanic "vectTyAppExpr" (ppr $ deAnnotate e)
-
--- ----------------------------------------------------------------------------
--- Types
-
-vectTyCon :: TyCon -> VM TyCon
-vectTyCon tc
- | isFunTyCon tc = builtin closureTyCon
- | isBoxedTupleTyCon tc = return tc
- | isUnLiftedTyCon tc = return tc
- | otherwise = do
- r <- lookupTyCon tc
- case r of
- Just tc' -> return tc'
-
- -- FIXME: just for now
- Nothing -> pprTrace "ccTyCon:" (ppr tc) $ return tc
-
-vectType :: Type -> VM Type
-vectType ty | Just ty' <- coreView ty = vectType ty
-vectType (TyVarTy tv) = return $ TyVarTy tv
-vectType (AppTy ty1 ty2) = liftM2 AppTy (vectType ty1) (vectType ty2)
-vectType (TyConApp tc tys) = liftM2 TyConApp (vectTyCon tc) (mapM vectType tys)
-vectType (FunTy ty1 ty2) = liftM2 TyConApp (builtin closureTyCon)
- (mapM vectType [ty1,ty2])
-vectType (ForAllTy tv ty)
- = do
- r <- paDictArgType tv
- ty' <- vectType ty
- return $ ForAllTy tv (wrap r ty')