X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fvectorise%2FVectorise.hs;h=06fc5422127ba890967692f2898b6996064a0eef;hb=8e71d5082f618e97db1c82dede313367c386891b;hp=7a29a7bf079698591ab89e3c0fc787c2d1ad794e;hpb=6ed5e6a3e9fbbd08f67a6136544aac1219680f5b;p=ghc-hetmet.git diff --git a/compiler/vectorise/Vectorise.hs b/compiler/vectorise/Vectorise.hs index 7a29a7b..06fc542 100644 --- a/compiler/vectorise/Vectorise.hs +++ b/compiler/vectorise/Vectorise.hs @@ -25,11 +25,13 @@ import InstEnv ( extendInstEnvList ) import Var import VarEnv import VarSet -import Name ( mkSysTvName, getName ) +import Name ( Name, mkSysTvName, getName ) import NameEnv import Id import MkId ( unwrapFamInstScrut ) import OccName +import RdrName ( RdrName, mkRdrQual ) +import Module ( mkModuleNameFS ) import DsMonad hiding (mapAndUnzipM) import DsUtils ( mkCoreTup, mkCoreTupTy ) @@ -44,6 +46,24 @@ import Outputable import FastString import Control.Monad ( liftM, liftM2, zipWithM, mapAndUnzipM ) +mkNDPVar :: String -> RdrName +mkNDPVar s = mkRdrQual nDP_BUILTIN (mkVarOcc s) + +mkNDPVarFS :: FastString -> RdrName +mkNDPVarFS fs = mkRdrQual nDP_BUILTIN (mkVarOccFS fs) + +builtin_PAs :: [(Name, RdrName)] +builtin_PAs = [ + mk closureTyConName FSLIT("dPA_Clo") + , mk intTyConName FSLIT("dPA_Int") + ] + ++ tups + where + mk name fs = (name, mkNDPVarFS fs) + + tups = mk_tup 0 : map mk_tup [2..3] + mk_tup n = (getName $ tupleTyCon Boxed n, mkNDPVar $ "dPA_" ++ show n) + vectorise :: HscEnv -> UniqSupply -> RuleBase -> ModGuts -> IO (SimplCount, ModGuts) vectorise hsc_env _ _ guts @@ -60,20 +80,18 @@ vectorise hsc_env _ _ guts vectModule :: ModGuts -> VM ModGuts vectModule guts = do - (types', fam_insts, pa_insts) <- vectTypeEnv (mg_types guts) + defTyConRdrPAs builtin_PAs + (types', fam_insts, tc_binds) <- vectTypeEnv (mg_types guts) - let insts = map painstInstance pa_insts - fam_inst_env' = extendFamInstEnvList (mg_fam_inst_env guts) fam_insts - inst_env' = extendInstEnvList (mg_inst_env guts) insts - updGEnv (setInstEnvs inst_env' fam_inst_env') + let fam_inst_env' = extendFamInstEnvList (mg_fam_inst_env guts) fam_insts + updGEnv (setFamInstEnv fam_inst_env') - dicts <- mapM buildPADict pa_insts - binds' <- mapM vectTopBind (mg_binds guts) + -- dicts <- mapM buildPADict pa_insts + -- workers <- mapM vectDataConWorkers pa_insts + binds' <- mapM vectTopBind (mg_binds guts) return $ guts { mg_types = types' - , mg_binds = Rec (concat dicts) : binds' - , mg_inst_env = inst_env' + , mg_binds = Rec tc_binds : binds' , mg_fam_inst_env = fam_inst_env' - , mg_insts = mg_insts guts ++ insts , mg_fam_insts = mg_fam_insts guts ++ fam_insts } @@ -101,20 +119,17 @@ vectTopBind b@(Rec bs) vectTopBinder :: Var -> VM Var vectTopBinder var = do - vty <- vectType (idType var) - name <- cloneName mkVectOcc (getName var) - let var' | isExportedId var = Id.mkExportedLocalId name vty - | otherwise = Id.mkLocalId name vty + vty <- vectType (idType var) + var' <- cloneId mkVectOcc var vty defGlobalVar var var' return var' vectTopRhs :: Var -> CoreExpr -> VM CoreExpr vectTopRhs var expr = do - lc <- newLocalVar FSLIT("lc") intPrimTy closedV . liftM vectorised . inBind var - $ vectPolyExpr lc (freeVars expr) + $ vectPolyExpr (freeVars expr) -- ---------------------------------------------------------------------------- -- Bindings @@ -150,19 +165,19 @@ vectBndrsIn vs p -- ---------------------------------------------------------------------------- -- Expressions -vectVar :: Var -> Var -> VM VExpr -vectVar lc v +vectVar :: Var -> VM VExpr +vectVar v = do r <- lookupVar v case r of Local (vv,lv) -> return (Var vv, Var lv) Global vv -> do let vexpr = Var vv - lexpr <- replicatePA (Var lc) vexpr + lexpr <- liftPA vexpr return (vexpr, lexpr) -vectPolyVar :: Var -> Var -> [Type] -> VM VExpr -vectPolyVar lc v tys +vectPolyVar :: Var -> [Type] -> VM VExpr +vectPolyVar v tys = do vtys <- mapM vectType tys r <- lookupVar v @@ -171,79 +186,78 @@ vectPolyVar lc v tys (polyApply (Var lv) vtys) Global poly -> do vexpr <- polyApply (Var poly) vtys - lexpr <- replicatePA (Var lc) vexpr + lexpr <- liftPA vexpr return (vexpr, lexpr) -vectLiteral :: Var -> Literal -> VM VExpr -vectLiteral lc lit +vectLiteral :: Literal -> VM VExpr +vectLiteral lit = do - lexpr <- replicatePA (Var lc) (Lit lit) + lexpr <- liftPA (Lit lit) return (Lit lit, lexpr) -vectPolyExpr :: Var -> CoreExprWithFVs -> VM VExpr -vectPolyExpr lc expr +vectPolyExpr :: CoreExprWithFVs -> VM VExpr +vectPolyExpr expr = polyAbstract tvs $ \abstract -> - -- FIXME: shadowing (tvs in lc) do - mono' <- vectExpr lc mono + mono' <- vectExpr mono return $ mapVect abstract mono' where (tvs, mono) = collectAnnTypeBinders expr -vectExpr :: Var -> CoreExprWithFVs -> VM VExpr -vectExpr lc (_, AnnType ty) +vectExpr :: CoreExprWithFVs -> VM VExpr +vectExpr (_, AnnType ty) = liftM vType (vectType ty) -vectExpr lc (_, AnnVar v) = vectVar lc v +vectExpr (_, AnnVar v) = vectVar v -vectExpr lc (_, AnnLit lit) = vectLiteral lc lit +vectExpr (_, AnnLit lit) = vectLiteral lit -vectExpr lc (_, AnnNote note expr) - = liftM (vNote note) (vectExpr lc expr) +vectExpr (_, AnnNote note expr) + = liftM (vNote note) (vectExpr expr) -vectExpr lc e@(_, AnnApp _ arg) +vectExpr e@(_, AnnApp _ arg) | isAnnTypeArg arg - = vectTyAppExpr lc fn tys + = vectTyAppExpr fn tys where (fn, tys) = collectAnnTypeArgs e -vectExpr lc (_, AnnApp fn arg) +vectExpr (_, AnnApp fn arg) = do - fn' <- vectExpr lc fn - arg' <- vectExpr lc arg + fn' <- vectExpr fn + arg' <- vectExpr arg mkClosureApp fn' arg' -vectExpr lc (_, AnnCase expr bndr ty alts) +vectExpr (_, AnnCase expr bndr ty alts) = panic "vectExpr: case" -vectExpr lc (_, AnnLet (AnnNonRec bndr rhs) body) +vectExpr (_, AnnLet (AnnNonRec bndr rhs) body) = do - vrhs <- localV . inBind bndr $ vectPolyExpr lc rhs - (vbndr, vbody) <- vectBndrIn bndr (vectExpr lc body) + vrhs <- localV . inBind bndr $ vectPolyExpr rhs + (vbndr, vbody) <- vectBndrIn bndr (vectExpr body) return $ vLet (vNonRec vbndr vrhs) vbody -vectExpr lc (_, AnnLet (AnnRec bs) body) +vectExpr (_, AnnLet (AnnRec bs) body) = do (vbndrs, (vrhss, vbody)) <- vectBndrsIn bndrs $ liftM2 (,) (zipWithM vect_rhs bndrs rhss) - (vectPolyExpr lc body) + (vectPolyExpr body) return $ vLet (vRec vbndrs vrhss) vbody where (bndrs, rhss) = unzip bs vect_rhs bndr rhs = localV . inBind bndr - $ vectExpr lc rhs + $ vectExpr rhs -vectExpr lc e@(fvs, AnnLam bndr _) +vectExpr e@(fvs, AnnLam bndr _) | not (isId bndr) = pprPanic "vectExpr" (ppr $ deAnnotate e) - | otherwise = vectLam lc fvs bs body + | otherwise = vectLam fvs bs body where (bs,body) = collectAnnValBinders e -vectLam :: Var -> VarSet -> [Var] -> CoreExprWithFVs -> VM VExpr -vectLam lc fvs bs body +vectLam :: VarSet -> [Var] -> CoreExprWithFVs -> VM VExpr +vectLam fvs bs body = do tyvars <- localTyVars (vs, vvs) <- readLEnv $ \env -> @@ -253,14 +267,15 @@ vectLam lc fvs bs body arg_tys <- mapM (vectType . idType) bs res_ty <- vectType (exprType $ deAnnotate body) - buildClosures tyvars lc vvs arg_tys res_ty + buildClosures tyvars vvs arg_tys res_ty . hoistPolyVExpr tyvars $ do + lc <- builtin liftingContext (vbndrs, vbody) <- vectBndrsIn (vs ++ bs) - (vectExpr lc body) + (vectExpr body) return $ vLams lc vbndrs vbody -vectTyAppExpr :: Var -> CoreExprWithFVs -> [Type] -> VM VExpr -vectTyAppExpr lc (_, AnnVar v) tys = vectPolyVar lc v tys -vectTyAppExpr lc e tys = pprPanic "vectTyAppExpr" (ppr $ deAnnotate e) +vectTyAppExpr :: CoreExprWithFVs -> [Type] -> VM VExpr +vectTyAppExpr (_, AnnVar v) tys = vectPolyVar v tys +vectTyAppExpr e tys = pprPanic "vectTyAppExpr" (ppr $ deAnnotate e)