+ 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]
+
+mkPRepr :: [[Type]] -> VM Type
+mkPRepr tys
+ = do
+ embed_tc <- builtin embedTyCon
+ sum_tcs <- builtins sumTyCon
+ prod_tcs <- builtins prodTyCon
+
+ let mk_sum [] = unitTy
+ mk_sum [ty] = ty
+ mk_sum tys = mkTyConApp (sum_tcs $ length tys) tys
+
+ mk_prod [] = unitTy
+ mk_prod [ty] = ty
+ mk_prod tys = mkTyConApp (prod_tcs $ length tys) tys
+
+ mk_embed ty = mkTyConApp embed_tc [ty]
+
+ return . mk_sum
+ . map (mk_prod . map mk_embed)
+ $ tys
+
+mkToPRepr :: [[CoreExpr]] -> VM ([CoreExpr], Type)
+mkToPRepr ess
+ = do
+ embed_tc <- builtin embedTyCon
+ embed_dc <- builtin embedDataCon
+ sum_tcs <- builtins sumTyCon
+ prod_tcs <- builtins prodTyCon
+
+ let mk_sum [] = ([Var unitDataConId], unitTy)
+ mk_sum [(expr, ty)] = ([expr], ty)
+ mk_sum es = (zipWith mk_alt (tyConDataCons sum_tc) exprs,
+ mkTyConApp sum_tc tys)
+ where
+ (exprs, tys) = unzip es
+ sum_tc = sum_tcs (length es)
+ mk_alt dc expr = mkConApp dc (map Type tys ++ [expr])
+
+ mk_prod [] = (Var unitDataConId, unitTy)
+ mk_prod [(expr, ty)] = (expr, ty)
+ mk_prod es = (mkConApp prod_dc (map Type tys ++ exprs),
+ mkTyConApp prod_tc tys)
+ where
+ (exprs, tys) = unzip es
+ prod_tc = prod_tcs (length es)
+ [prod_dc] = tyConDataCons prod_tc
+
+ mk_embed expr = (mkConApp embed_dc [Type ty, expr],
+ mkTyConApp embed_tc [ty])
+ where ty = exprType expr
+
+ return . mk_sum $ map (mk_prod . map mk_embed) ess
+
+mkFromPRepr :: CoreExpr -> Type -> [([Var], CoreExpr)] -> VM CoreExpr
+mkFromPRepr scrut res_ty alts
+ = do
+ embed_dc <- builtin embedDataCon
+ sum_tcs <- builtins sumTyCon
+ prod_tcs <- builtins prodTyCon
+
+ let un_sum expr ty [(vars, res)] = un_prod expr ty vars res
+ un_sum expr ty bs
+ = do
+ ps <- mapM (newLocalVar FSLIT("p")) tys
+ bodies <- sequence
+ $ zipWith4 un_prod (map Var ps) tys vars rs
+ return . Case expr (mkWildId ty) res_ty
+ $ zipWith3 mk_alt sum_dcs ps bodies
+ where
+ (vars, rs) = unzip bs
+ tys = splitFixedTyConApp sum_tc ty
+ sum_tc = sum_tcs $ length bs
+ sum_dcs = tyConDataCons sum_tc
+
+ mk_alt dc p body = (DataAlt dc, [p], body)
+
+ un_prod expr ty [] r = return r
+ un_prod expr ty [var] r = return $ un_embed expr ty var r
+ un_prod expr ty vars r
+ = do
+ xs <- mapM (newLocalVar FSLIT("x")) tys
+ let body = foldr (\(e,t,v) r -> un_embed e t v r) r
+ $ zip3 (map Var xs) tys vars
+ return $ Case expr (mkWildId ty) res_ty
+ [(DataAlt prod_dc, xs, body)]
+ where
+ tys = splitFixedTyConApp prod_tc ty
+ prod_tc = prod_tcs $ length vars
+ [prod_dc] = tyConDataCons prod_tc
+
+ un_embed expr ty var r
+ = Case expr (mkWildId ty) res_ty
+ [(DataAlt embed_dc, [var], r)]
+
+ un_sum scrut (exprType scrut) alts
+
+mkClosureType :: Type -> Type -> VM Type
+mkClosureType arg_ty res_ty = mkBuiltinTyConApp closureTyCon [arg_ty, res_ty]
+
+mkClosureTypes :: [Type] -> Type -> VM Type
+mkClosureTypes = mkBuiltinTyConApps closureTyCon
+
+mkPReprType :: Type -> VM Type
+mkPReprType ty = mkBuiltinTyConApp preprTyCon [ty]
+
+mkPADictType :: Type -> VM Type
+mkPADictType ty = mkBuiltinTyConApp paTyCon [ty]