module Vectorise( vectorise )
where
-#include "HsVersions.h"
-
import VectMonad
import VectUtils
import VectType
vectModule guts
= do
(types', fam_insts, tc_binds) <- vectTypeEnv (mg_types guts)
-
+
let fam_inst_env' = extendFamInstEnvList (mg_fam_inst_env guts) fam_insts
updGEnv (setFamInstEnv fam_inst_env')
-
+
-- dicts <- mapM buildPADict pa_insts
-- workers <- mapM vectDataConWorkers pa_insts
binds' <- mapM vectTopBind (mg_binds guts)
var' <- cloneId mkVectOcc var vty
defGlobalVar var var'
return var'
-
+
vectTopRhs :: Var -> CoreExpr -> VM CoreExpr
vectTopRhs var expr
= do
mono' <- vectExpr mono
return $ mapVect abstract mono'
where
- (tvs, mono) = collectAnnTypeBinders expr
-
+ (tvs, mono) = collectAnnTypeBinders expr
+
vectExpr :: CoreExprWithFVs -> VM VExpr
vectExpr (_, AnnType ty)
= liftM vType (vectType ty)
return (vexpr, lexpr)
where
is_special_con con = con `elem` [intDataCon, floatDataCon, doubleDataCon]
-
+
vectExpr (_, AnnApp fn arg)
= do
(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)
-- When lifting, we have to do it this way because v must have the type
-- [:V(T):] but the scrutinee must be cast to the representation type. We also
-- have to handle the case where v is a wild var correctly.
---
+--
-- FIXME: this is too lazy
vectAlgCase tycon ty_args scrut bndr ty [(DEFAULT, [], body)]
return . vLet (vNonRec vbndr vexpr)
$ vCaseProd vscrut vty lty vect_dc arr_dc shape_bndrs vbndrs vbody
where
- vect_scrut_bndr | isDeadBinder bndr = vectBndrNewIn bndr FSLIT("scrut")
+ vect_scrut_bndr | isDeadBinder bndr = vectBndrNewIn bndr (fsLit "scrut")
| otherwise = vectBndrIn bndr
vectAlgCase tycon ty_args scrut bndr ty alts
return . vLet (vNonRec vbndr vexpr)
$ (vect_case, lift_case)
where
- vect_scrut_bndr | isDeadBinder bndr = vectBndrNewIn bndr FSLIT("scrut")
+ vect_scrut_bndr | isDeadBinder bndr = vectBndrNewIn bndr (fsLit "scrut")
| otherwise = vectBndrIn bndr
alts' = sortBy (\(alt1, _, _) (alt2, _, _) -> cmp alt1 alt2) alts
void_tc <- builtin voidTyCon
let void_ty = mkTyConApp void_tc []
arr_ty <- mkPArrayType void_ty
- bndr <- newLocalVar FSLIT("voids") arr_ty
+ bndr <- newLocalVar (fsLit "voids") arr_ty
len <- lengthPA void_ty (Var bndr)
e <- p len
return ([], [bndr], e)
= do
select <- builtin selectPAIntPrimVar
let sel_expr = mkApps (Var select) [shape, tag]
- sel_var <- newLocalVar FSLIT("sel#") (exprType sel_expr)
+ sel_var <- newLocalVar (fsLit "sel#") (exprType sel_expr)
lc_var <- builtin liftingContext
localV $
do
(vexpr, lexpr) <- p
empty <- emptyPA vty
return (vexpr, Let (NonRec sel_var sel_expr)
- . mkLets (concat bnds)
$ Case len lc_var lty
- [(DEFAULT, [], lexpr),
+ [(DEFAULT, [], mkLets (concat bnds) lexpr),
(LitAlt (mkMachInt 0), [], empty)])
packFreeVar :: CoreExpr -> CoreExpr -> Var -> VM [CoreBind]