-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]
-
-data TyConRepr = TyConRepr {
- repr_tyvars :: [TyVar]
- , repr_tys :: [[Type]]
- , arr_shape_tys :: [Type]
- , arr_repr_tys :: [[Type]]
-
- , repr_prod_tycons :: [Maybe TyCon]
- , repr_prod_data_cons :: [Maybe DataCon]
- , repr_prod_tys :: [Type]
- , repr_sum_tycon :: Maybe TyCon
- , repr_sum_data_cons :: [DataCon]
- , repr_type :: Type
- }
-
-mkTyConRepr :: TyCon -> VM TyConRepr
-mkTyConRepr vect_tc
- = do
- uarr <- builtin uarrTyCon
- prod_tycons <- mapM (mk_tycon prodTyCon) rep_tys
- let prod_tys = zipWith mk_tc_app_maybe prod_tycons rep_tys
- sum_tycon <- mk_tycon sumTyCon prod_tys
- arr_repr_tys <- mapM (mapM mkPArrayType . arr_repr_elem_tys) rep_tys
-
- return $ TyConRepr {
- repr_tyvars = tyvars
- , repr_tys = rep_tys
- , arr_shape_tys = mk_shape uarr
- , arr_repr_tys = arr_repr_tys
-
- , repr_prod_tycons = prod_tycons
- , repr_prod_data_cons = map (fmap mk_single_datacon) prod_tycons
- , repr_prod_tys = prod_tys
- , repr_sum_tycon = sum_tycon
- , repr_sum_data_cons = fmap tyConDataCons sum_tycon `orElse` []
- , repr_type = mk_tc_app_maybe sum_tycon prod_tys
- }
- where
- tyvars = tyConTyVars vect_tc
- data_cons = tyConDataCons vect_tc
- rep_tys = map dataConRepArgTys data_cons
-
- is_product | [_] <- data_cons = True
- | otherwise = False
-
- mk_shape uarr = intPrimTy : mk_sel uarr
-
- mk_sel uarr | is_product = []
- | otherwise = [uarr_int, uarr_int]
- where
- uarr_int = mkTyConApp uarr [intTy]
-
- mk_tycon get_tc tys
- | n > 1 = builtin (Just . get_tc n)
- | otherwise = return Nothing
- where n = length tys
-
- mk_single_datacon tc | [dc] <- tyConDataCons tc = dc
-
- mk_tc_app_maybe Nothing [] = unitTy
- mk_tc_app_maybe Nothing [ty] = ty
- mk_tc_app_maybe (Just tc) tys = mkTyConApp tc tys