module VectUtils (
collectAnnTypeBinders, collectAnnTypeArgs, isAnnTypeArg,
collectAnnValBinders,
- mkDataConTag, mkDataConTagLit,
+ dataConTagZ, mkDataConTag, mkDataConTagLit,
+
+ newLocalVVar,
mkBuiltinCo,
mkPADictType, mkPArrayType, mkPReprType,
parrayReprTyCon, parrayReprDataCon, mkVScrut,
prDFunOfTyCon,
paDictArgType, paDictOfType, paDFunType,
- paMethod, mkPR, lengthPA, replicatePA, emptyPA, packPA, liftPA,
+ paMethod, mkPR, lengthPA, replicatePA, emptyPA, packPA, combinePA, liftPA,
polyAbstract, polyApply, polyVApply,
hoistBinding, hoistExpr, hoistPolyVExpr, takeHoisted,
buildClosure, buildClosures,
isAnnTypeArg (_, AnnType t) = True
isAnnTypeArg _ = False
+dataConTagZ :: DataCon -> Int
+dataConTagZ con = dataConTag con - fIRST_TAG
+
mkDataConTagLit :: DataCon -> Literal
-mkDataConTagLit con
- = mkMachInt . toInteger $ dataConTag con - fIRST_TAG
+mkDataConTagLit = mkMachInt . toInteger . dataConTagZ
mkDataConTag :: DataCon -> CoreExpr
-mkDataConTag con = mkIntLitInt (dataConTag con - fIRST_TAG)
+mkDataConTag = mkIntLitInt . dataConTagZ
splitPrimTyCon :: Type -> Maybe TyCon
splitPrimTyCon ty
emptyPA = paMethod pa_empty
packPA :: Type -> CoreExpr -> CoreExpr -> CoreExpr -> VM CoreExpr
-packPA ty xs len sel = liftM (`mkApps` [len, sel])
+packPA ty xs len sel = liftM (`mkApps` [xs, len, sel])
(paMethod pa_pack ty)
+combinePA :: Type -> CoreExpr -> CoreExpr -> CoreExpr -> [CoreExpr]
+ -> VM CoreExpr
+combinePA ty len sel is xs
+ = liftM (`mkApps` (len : sel : is : xs))
+ (paMethod (combinePAVar n, "combine" ++ show n ++ "PA") ty)
+ where
+ n = length xs
+
liftPA :: CoreExpr -> VM CoreExpr
liftPA x
= do
setGEnv $ env { global_bindings = [] }
return $ global_bindings env
+boxExpr :: Type -> VExpr -> VM VExpr
+boxExpr ty (vexpr, lexpr)
+ | Just (tycon, []) <- splitTyConApp_maybe ty
+ , isUnLiftedTyCon tycon
+ = do
+ r <- lookupBoxedTyCon tycon
+ case r of
+ Just tycon' -> let [dc] = tyConDataCons tycon'
+ in
+ return (mkConApp dc [vexpr], lexpr)
+ Nothing -> return (vexpr, lexpr)
+
+
mkClosure :: Type -> Type -> Type -> VExpr -> VExpr -> VM VExpr
mkClosure arg_ty res_ty env_ty (vfn,lfn) (venv,lenv)
= do
mkLiftEnv lc tys vs
= do
(env_tc, env_tyargs) <- parrayReprTyCon vty
+
+ bndrs <- if null vs then do
+ v <- newDummyVar unitTy
+ return [v]
+ else return vs
let [env_con] = tyConDataCons env_tc
env = Var (dataConWrapId env_con)
`mkTyApps` env_tyargs
- `mkVarApps` (lc : vs)
+ `mkApps` (Var lc : args)
bind env body = let scrut = unwrapFamInstScrut env_tc env_tyargs env
in
where
vty = mkCoreTupTy tys
- bndrs | null vs = [mkWildId unitTy]
- | otherwise = vs
+ args | null vs = [Var unitDataConId]
+ | otherwise = map Var vs