+ ty_args = mkTyVarTys (tyConTyVars vect_tc)
+ res_ty = mkTyConApp vect_tc ty_args
+
+ from_sum _ [] = pprPanic "buildFromPRepr" (ppr vect_tc)
+ from_sum expr [con] = from_prod expr con
+ from_sum expr cons
+ = do
+ (sum_tc, _, _, sum_ty_args) <- reprSumTyCons vect_tc
+ let sum_cons = tyConDataCons sum_tc
+ vars <- newLocalVars (fsLit "x") sum_ty_args
+ prods <- zipWithM from_prod (map Var vars) cons
+ return . mkWildCase expr (exprType expr) res_ty
+ $ zipWith3 mk_alt sum_cons vars prods
+ where
+ mk_alt con var expr = (DataAlt con, [var], expr)
+
+ from_prod expr con
+ = case dataConRepArgTys con of
+ [] -> return $ apply_con []
+ [_] -> return $ apply_con [expr]
+ tys -> do
+ prod_con <- builtin (prodDataCon (length tys))
+ vars <- newLocalVars (fsLit "y") tys
+ return $ mkWildCase expr (exprType expr) res_ty
+ [(DataAlt prod_con, vars, apply_con (map Var vars))]
+ where
+ apply_con exprs = mkConApp con (map Type ty_args) `mkApps` exprs
+
+buildToArrPRepr :: TyCon -> TyCon -> TyCon -> VM CoreExpr
+buildToArrPRepr vect_tc prepr_tc pdata_tc
+ = do
+ arg_ty <- mkPDataType el_ty
+ res_ty <- mkPDataType =<< mkPReprType el_ty
+ arg <- newLocalVar (fsLit "xs") arg_ty
+
+ pdata_co <- mkBuiltinCo pdataTyCon
+ let Just repr_co = tyConFamilyCoercion_maybe prepr_tc
+ co = mkAppCoercion pdata_co
+ . mkSymCoercion
+ $ mkTyConApp repr_co ty_args
+
+ scrut = unwrapFamInstScrut pdata_tc ty_args (Var arg)
+
+ (vars, result) <- to_sum (tyConDataCons vect_tc)
+
+ return . Lam arg
+ $ mkWildCase scrut (mkTyConApp pdata_tc ty_args) res_ty
+ [(DataAlt pdata_dc, vars, mkCoerce co result)]
+ where
+ ty_args = mkTyVarTys $ tyConTyVars vect_tc
+ el_ty = mkTyConApp vect_tc ty_args
+
+ [pdata_dc] = tyConDataCons pdata_tc
+
+ to_sum [] = do
+ pvoid <- builtin pvoidVar
+ return ([], Var pvoid)
+ to_sum [con] = to_prod con
+ to_sum cons = do
+ (vars, exprs) <- mapAndUnzipM to_prod cons
+ (_, pdata_tc, sel_ty, arg_tys) <- reprSumTyCons vect_tc
+ sel <- newLocalVar (fsLit "sel") sel_ty
+ let [pdata_con] = tyConDataCons pdata_tc
+ result = wrapFamInstBody pdata_tc arg_tys
+ . mkConApp pdata_con
+ $ map Type arg_tys ++ (Var sel : exprs)
+ return (sel : concat vars, result)
+
+ to_prod con
+ | [] <- tys = do
+ pvoid <- builtin pvoidVar
+ return ([], Var pvoid)
+ | [ty] <- tys = do
+ var <- newLocalVar (fsLit "x") ty
+ return ([var], Var var)
+ | otherwise
+ = do
+ vars <- newLocalVars (fsLit "x") tys
+ prod_tc <- builtin (prodTyCon (length tys))
+ (pdata_prod_tc, _) <- pdataReprTyCon (mkTyConApp prod_tc tys)
+ let [pdata_prod_con] = tyConDataCons pdata_prod_tc
+ result = wrapFamInstBody pdata_prod_tc tys
+ . mkConApp pdata_prod_con
+ $ map Type tys ++ map Var vars
+ return (vars, result)
+ where
+ tys = dataConRepArgTys con
+
+buildFromArrPRepr :: TyCon -> TyCon -> TyCon -> VM CoreExpr
+buildFromArrPRepr vect_tc prepr_tc pdata_tc
+ = do
+ arg_ty <- mkPDataType =<< mkPReprType el_ty
+ res_ty <- mkPDataType el_ty
+ arg <- newLocalVar (fsLit "xs") arg_ty
+
+ pdata_co <- mkBuiltinCo pdataTyCon
+ let Just repr_co = tyConFamilyCoercion_maybe prepr_tc
+ co = mkAppCoercion pdata_co
+ $ mkTyConApp repr_co var_tys
+
+ scrut = mkCoerce co (Var arg)
+
+ (args, mk) <- from_sum res_ty scrut (tyConDataCons vect_tc)
+
+ let result = wrapFamInstBody pdata_tc var_tys
+ . mkConApp pdata_dc
+ $ map Type var_tys ++ args
+
+ return $ Lam arg (mk result)
+ where
+ var_tys = mkTyVarTys $ tyConTyVars vect_tc
+ el_ty = mkTyConApp vect_tc var_tys
+
+ [pdata_dc] = tyConDataCons pdata_tc
+
+ from_sum res_ty expr [] = return ([], mk)
+ where
+ mk body = mkWildCase expr (exprType expr) res_ty [(DEFAULT, [], body)]
+ from_sum res_ty expr [con] = from_prod res_ty expr con
+ from_sum res_ty expr cons
+ = do
+ (_, pdata_tc, sel_ty, arg_tys) <- reprSumTyCons vect_tc
+ sel <- newLocalVar (fsLit "sel") sel_ty
+ vars <- newLocalVars (fsLit "xs") arg_tys
+ rs <- zipWithM (from_prod res_ty) (map Var vars) cons
+ let (prods, mks) = unzip rs
+ [pdata_con] = tyConDataCons pdata_tc
+ scrut = unwrapFamInstScrut pdata_tc arg_tys expr
+
+ mk body = mkWildCase scrut (exprType scrut) res_ty
+ [(DataAlt pdata_con, sel : vars, foldr ($) body mks)]
+ return (Var sel : concat prods, mk)
+
+
+ from_prod res_ty expr con
+ | [] <- tys = return ([], id)
+ | [_] <- tys = return ([expr], id)
+ | otherwise
+ = do
+ prod_tc <- builtin (prodTyCon (length tys))
+ (pdata_tc, _) <- pdataReprTyCon (mkTyConApp prod_tc tys)
+ pdata_tys <- mapM mkPDataType tys
+ vars <- newLocalVars (fsLit "ys") pdata_tys
+ let [pdata_con] = tyConDataCons pdata_tc
+ scrut = unwrapFamInstScrut pdata_tc tys expr
+
+ mk body = mkWildCase scrut (exprType scrut) res_ty
+ [(DataAlt pdata_con, vars, body)]
+
+ return (map Var vars, mk)
+ where
+ tys = dataConRepArgTys con
+
+buildPRDict :: TyCon -> TyCon -> TyCon -> VM CoreExpr
+buildPRDict vect_tc prepr_tc _
+ = do
+ dict <- sum_dict (tyConDataCons vect_tc)
+ pr_co <- mkBuiltinCo prTyCon
+ let co = mkAppCoercion pr_co
+ . mkSymCoercion
+ $ mkTyConApp arg_co ty_args
+ return (mkCoerce co dict)
+ where
+ ty_args = mkTyVarTys (tyConTyVars vect_tc)
+ Just arg_co = tyConFamilyCoercion_maybe prepr_tc
+
+ sum_dict [] = prDFunOfTyCon =<< builtin voidTyCon
+ sum_dict [con] = prod_dict con
+ sum_dict cons = do
+ dicts <- mapM prod_dict cons
+ (sum_tc, _, _, sum_ty_args) <- reprSumTyCons vect_tc
+ dfun <- prDFunOfTyCon sum_tc
+ return $ dfun `mkTyApps` sum_ty_args `mkApps` dicts
+
+ prod_dict con
+ | [] <- tys = prDFunOfTyCon =<< builtin voidTyCon
+ | [ty] <- tys = mkPR ty
+ | otherwise = do
+ dicts <- mapM mkPR tys
+ prod_tc <- builtin (prodTyCon (length tys))
+ dfun <- prDFunOfTyCon prod_tc
+ return $ dfun `mkTyApps` tys `mkApps` dicts
+ where
+ tys = dataConRepArgTys con
+
+buildPDataTyCon :: TyCon -> TyCon -> VM TyCon
+buildPDataTyCon orig_tc vect_tc = fixV $ \repr_tc ->
+ do
+ name' <- cloneName mkPDataTyConOcc orig_name
+ rhs <- buildPDataTyConRhs orig_name vect_tc repr_tc
+ pdata <- builtin pdataTyCon
+
+ liftDs $ buildAlgTyCon name'
+ tyvars
+ [] -- no stupid theta
+ rhs
+ rec_flag -- FIXME: is this ok?
+ False -- FIXME: no generics
+ False -- not GADT syntax
+ (Just $ mk_fam_inst pdata vect_tc)
+ where
+ orig_name = tyConName orig_tc