+ repr_ty <- mkPArrayType intTy -- FIXME: we want to unbox this
+ return $ Shape {
+ shapeReprTys = [repr_ty]
+ , shapeStrictness = [MarkedStrict]
+ , shapeLength = \[sel] -> lengthPA sel
+ , shapeReplicate = \len n -> do
+ e <- replicatePA len n
+ return [e]
+ }
+
+buildTyConBindings :: TyCon -> TyCon -> TyCon -> Var -> VM [(Var, CoreExpr)]
+buildTyConBindings orig_tc vect_tc arr_tc dfun
+ = do
+ shape <- tyConShape vect_tc
+ sequence_ (zipWith4 (vectDataConWorker shape vect_tc arr_tc arr_dc)
+ orig_dcs
+ vect_dcs
+ (inits repr_tys)
+ (tails repr_tys))
+ dict <- buildPADict shape vect_tc arr_tc dfun
+ binds <- takeHoisted
+ return $ (dfun, dict) : binds
+ where
+ orig_dcs = tyConDataCons orig_tc
+ vect_dcs = tyConDataCons vect_tc
+ [arr_dc] = tyConDataCons arr_tc
+
+ repr_tys = map dataConRepArgTys vect_dcs
+
+vectDataConWorker :: Shape -> TyCon -> TyCon -> DataCon
+ -> DataCon -> DataCon -> [[Type]] -> [[Type]]
+ -> VM ()
+vectDataConWorker shape vect_tc arr_tc arr_dc orig_dc vect_dc pre (dc_tys : post)
+ = do
+ clo <- closedV
+ . inBind orig_worker
+ . polyAbstract tvs $ \abstract ->
+ liftM (abstract . vectorised)
+ $ buildClosures tvs [] dc_tys res_ty (liftM2 (,) mk_vect mk_lift)
+
+ worker <- cloneId mkVectOcc orig_worker (exprType clo)
+ hoistBinding worker clo
+ defGlobalVar orig_worker worker
+ return ()
+ where
+ tvs = tyConTyVars vect_tc
+ arg_tys = mkTyVarTys tvs
+ res_ty = mkTyConApp vect_tc arg_tys
+
+ orig_worker = dataConWorkId orig_dc
+
+ mk_vect = return . mkConApp vect_dc $ map Type arg_tys
+ mk_lift = do
+ len <- newLocalVar FSLIT("n") intPrimTy
+ arr_tys <- mapM mkPArrayType dc_tys
+ args <- mapM (newLocalVar FSLIT("xs")) arr_tys
+ shapes <- shapeReplicate shape
+ (Var len)
+ (mkDataConTag vect_dc)
+
+ empty_pre <- mapM emptyPA (concat pre)
+ empty_post <- mapM emptyPA (concat post)
+
+ return . mkLams (len : args)
+ . wrapFamInstBody arr_tc arg_tys
+ . mkConApp arr_dc
+ $ map Type arg_tys ++ shapes
+ ++ empty_pre
+ ++ map Var args
+ ++ empty_post
+
+buildPADict :: Shape -> TyCon -> TyCon -> Var -> VM CoreExpr
+buildPADict shape vect_tc arr_tc dfun
+ = polyAbstract tvs $ \abstract ->
+ do
+ meth_binds <- mapM (mk_method shape) paMethods
+ let meth_exprs = map (Var . fst) meth_binds
+
+ pa_dc <- builtin paDataCon
+ let dict = mkConApp pa_dc (Type (mkTyConApp vect_tc arg_tys) : meth_exprs)
+ body = Let (Rec meth_binds) dict
+ return . mkInlineMe $ abstract body