+mkBuiltinTyConApps1 :: (Builtins -> TyCon) -> Type -> [Type] -> VM Type
+mkBuiltinTyConApps1 get_tc dft [] = return dft
+mkBuiltinTyConApps1 get_tc dft tys
+ = do
+ tc <- builtin get_tc
+ case tys of
+ [] -> pprPanic "mkBuiltinTyConApps1" (ppr tc)
+ _ -> return $ foldr1 (mk tc) tys
+ where
+ mk tc ty1 ty2 = mkTyConApp tc [ty1,ty2]
+
+mkBuiltinDataConApp :: (Builtins -> DataCon) -> [CoreExpr] -> VM CoreExpr
+mkBuiltinDataConApp get_dc args
+ = do
+ dc <- builtin get_dc
+ return $ mkConApp dc args
+
+mkPlusType :: Type -> Type -> VM Type
+mkPlusType ty1 ty2 = mkBuiltinTyConApp plusTyCon [ty1, ty2]
+
+mkPlusTypes :: Type -> [Type] -> VM Type
+mkPlusTypes = mkBuiltinTyConApps1 plusTyCon
+
+mkPlusAlts :: [CoreExpr] -> VM [CoreExpr]
+mkPlusAlts [] = return []
+mkPlusAlts exprs
+ = do
+ plus_tc <- builtin plusTyCon
+ left_dc <- builtin leftDataCon
+ right_dc <- builtin rightDataCon
+
+ let go [expr] = ([expr], exprType expr)
+ go (expr : exprs)
+ | (alts, right_ty) <- go exprs
+ = (mkConApp left_dc [Type left_ty, Type right_ty, expr]
+ : [mkConApp right_dc [Type left_ty, Type right_ty, alt]
+ | alt <- alts],
+ mkTyConApp plus_tc [left_ty, right_ty])
+ where
+ left_ty = exprType expr
+
+ return . fst $ go exprs
+
+mkCrossType :: Type -> Type -> VM Type
+mkCrossType ty1 ty2 = mkBuiltinTyConApp crossTyCon [ty1, ty2]
+
+mkCrossTypes :: Type -> [Type] -> VM Type
+mkCrossTypes = mkBuiltinTyConApps1 crossTyCon
+
+mkCrosses :: [CoreExpr] -> VM CoreExpr
+mkCrosses [] = return (Var unitDataConId)
+mkCrosses exprs