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 )
import Outputable
import FastString
-import Control.Monad ( liftM, liftM2, mapAndUnzipM )
+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)
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
}
vectTopBind b@(NonRec var expr)
= do
var' <- vectTopBinder var
- expr' <- vectTopRhs expr
+ expr' <- vectTopRhs var expr
hs <- takeHoisted
return . Rec $ (var, expr) : (var', expr') : hs
`orElseV`
vectTopBind b@(Rec bs)
= do
vars' <- mapM vectTopBinder vars
- exprs' <- mapM vectTopRhs exprs
+ exprs' <- zipWithM vectTopRhs vars exprs
hs <- takeHoisted
return . Rec $ bs ++ zip vars' exprs' ++ hs
`orElseV`
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 :: CoreExpr -> VM CoreExpr
-vectTopRhs expr
+vectTopRhs :: Var -> CoreExpr -> VM CoreExpr
+vectTopRhs var expr
= do
- lc <- newLocalVar FSLIT("lc") intPrimTy
closedV . liftM vectorised
- $ vectPolyExpr lc (freeVars expr)
+ . inBind var
+ $ vectPolyExpr (freeVars expr)
-- ----------------------------------------------------------------------------
-- Bindings
-- ----------------------------------------------------------------------------
-- Expressions
-capply :: VExpr -> VExpr -> VM VExpr
-capply (vfn, lfn) (varg, larg)
- = do
- apply <- builtin applyClosureVar
- applyP <- builtin applyClosurePVar
- return (mkApps (Var apply) [Type arg_ty, Type res_ty, vfn, varg],
- mkApps (Var applyP) [Type arg_ty, Type res_ty, lfn, larg])
- where
- fn_ty = exprType vfn
- (arg_ty, res_ty) = splitClosureTy fn_ty
-
-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 vexpr (Var lc)
+ 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
(polyApply (Var lv) vtys)
Global poly -> do
vexpr <- polyApply (Var poly) vtys
- lexpr <- replicatePA vexpr (Var lc)
+ lexpr <- liftPA vexpr
return (vexpr, lexpr)
-vectLiteral :: Var -> Literal -> VM VExpr
-vectLiteral lc lit
+vectLiteral :: Literal -> VM VExpr
+vectLiteral lit
= do
- lexpr <- replicatePA (Lit lit) (Var lc)
+ 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
- capply fn' 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 <- 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 (,)
- (mapM (vectExpr lc) rhss)
- (vectPolyExpr lc body)
+ (zipWithM vect_rhs bndrs rhss)
+ (vectPolyExpr body)
return $ vLet (vRec vbndrs vrhss) vbody
where
(bndrs, rhss) = unzip bs
-vectExpr lc e@(_, AnnLam bndr body)
- | isTyVar bndr = pprPanic "vectExpr" (ppr $ deAnnotate e)
+ vect_rhs bndr rhs = localV
+ . inBind bndr
+ $ vectExpr rhs
-vectExpr lc (fvs, AnnLam bndr body)
+vectExpr e@(fvs, AnnLam bndr _)
+ | not (isId bndr) = pprPanic "vectExpr" (ppr $ deAnnotate e)
+ | otherwise = vectLam fvs bs body
+ where
+ (bs,body) = collectAnnValBinders e
+
+vectLam :: VarSet -> [Var] -> CoreExprWithFVs -> VM VExpr
+vectLam fvs bs body
= do
tyvars <- localTyVars
(vs, vvs) <- readLEnv $ \env ->
unzip [(var, vv) | var <- varSetElems fvs
, Just vv <- [lookupVarEnv (local_vars env) var]]
- arg_ty <- vectType (idType bndr)
- res_ty <- vectType (exprType $ deAnnotate body)
- buildClosure tyvars lc vvs arg_ty res_ty
- . hoistPolyVExpr FSLIT("fn") tyvars
+ arg_tys <- mapM (vectType . idType) bs
+ res_ty <- vectType (exprType $ deAnnotate body)
+
+ buildClosures tyvars vvs arg_tys res_ty
+ . hoistPolyVExpr tyvars
$ do
- new_lc <- newLocalVar FSLIT("lc") intPrimTy
- (vbndrs, vbody) <- vectBndrsIn (vs ++ [bndr])
- (vectExpr new_lc body)
- return $ vLams new_lc vbndrs vbody
-
-vectTyAppExpr :: Var -> CoreExprWithFVs -> [Type] -> VM (CoreExpr, CoreExpr)
-vectTyAppExpr lc (_, AnnVar v) tys = vectPolyVar lc v tys
-vectTyAppExpr lc e tys = pprPanic "vectTyAppExpr" (ppr $ deAnnotate e)
+ lc <- builtin liftingContext
+ (vbndrs, vbody) <- vectBndrsIn (vs ++ bs)
+ (vectExpr body)
+ return $ vLams lc vbndrs vbody
+
+vectTyAppExpr :: CoreExprWithFVs -> [Type] -> VM VExpr
+vectTyAppExpr (_, AnnVar v) tys = vectPolyVar v tys
+vectTyAppExpr e tys = pprPanic "vectTyAppExpr" (ppr $ deAnnotate e)
projects / ghc-hetmet.git / blobdiff