diff options
Diffstat (limited to 'utils/genprimopcode/Main.hs')
| -rw-r--r-- | utils/genprimopcode/Main.hs | 373 |
1 files changed, 290 insertions, 83 deletions
diff --git a/utils/genprimopcode/Main.hs b/utils/genprimopcode/Main.hs index a9f6a2a5fd..8b97ca169c 100644 --- a/utils/genprimopcode/Main.hs +++ b/utils/genprimopcode/Main.hs @@ -13,6 +13,100 @@ import Data.List import Data.Maybe ( catMaybes ) import System.Environment ( getArgs ) +vecOptions :: Entry -> [(String,String,Int)] +vecOptions i = + concat [vecs | OptionVector vecs <- opts i] + +desugarVectorSpec :: Entry -> [Entry] +desugarVectorSpec i@(Section {}) = [i] +desugarVectorSpec i = case vecOptions i of + [] -> [i] + vos -> map genVecEntry vos + where + genVecEntry :: (String,String,Int) -> Entry + genVecEntry (con,repCon,n) = + case i of + PrimOpSpec {} -> + PrimVecOpSpec { cons = "(" ++ concat (intersperse " " [cons i, vecCat, show n, vecWidth]) ++ ")" + , name = name' + , prefix = pfx + , veclen = n + , elemrep = con ++ "ElemRep" + , ty = desugarTy (ty i) + , cat = cat i + , desc = desc i + , opts = opts i + } + PrimTypeSpec {} -> + PrimVecTypeSpec { ty = desugarTy (ty i) + , prefix = pfx + , veclen = n + , elemrep = con ++ "ElemRep" + , desc = desc i + , opts = opts i + } + _ -> + error "vector options can only be given for primops and primtypes" + where + vecCons = con++"X"++show n++"#" + vecCat = conCat con + vecWidth = conWidth con + pfx = lowerHead con++"X"++show n + vecTyName = pfx++"PrimTy" + + name' | Just pre <- splitSuffix (name i) "Array#" = pre++vec++"Array#" + | Just pre <- splitSuffix (name i) "OffAddr#" = pre++vec++"OffAddr#" + | Just pre <- splitSuffix (name i) "ArrayAs#" = pre++con++"ArrayAs"++vec++"#" + | Just pre <- splitSuffix (name i) "OffAddrAs#" = pre++con++"OffAddrAs"++vec++"#" + | otherwise = init (name i)++vec ++"#" + where + vec = con++"X"++show n + + splitSuffix :: Eq a => [a] -> [a] -> Maybe [a] + splitSuffix s suf + | drop len s == suf = Just (take len s) + | otherwise = Nothing + where + len = length s - length suf + + lowerHead s = toLower (head s) : tail s + + desugarTy :: Ty -> Ty + desugarTy (TyF s d) = TyF (desugarTy s) (desugarTy d) + desugarTy (TyC s d) = TyC (desugarTy s) (desugarTy d) + desugarTy (TyApp SCALAR []) = TyApp (TyCon repCon) [] + desugarTy (TyApp VECTOR []) = TyApp (VecTyCon vecCons vecTyName) [] + desugarTy (TyApp VECTUPLE []) = TyUTup (replicate n (TyApp (TyCon repCon) [])) + desugarTy (TyApp tycon ts) = TyApp tycon (map desugarTy ts) + desugarTy t@(TyVar {}) = t + desugarTy (TyUTup ts) = TyUTup (map desugarTy ts) + + conCat :: String -> String + conCat "Int8" = "IntVec" + conCat "Int16" = "IntVec" + conCat "Int32" = "IntVec" + conCat "Int64" = "IntVec" + conCat "Word8" = "WordVec" + conCat "Word16" = "WordVec" + conCat "Word32" = "WordVec" + conCat "Word64" = "WordVec" + conCat "Float" = "FloatVec" + conCat "Double" = "FloatVec" + conCat con = error $ "conCat: unknown type constructor " ++ con ++ "\n" + + conWidth :: String -> String + conWidth "Int8" = "W8" + conWidth "Int16" = "W16" + conWidth "Int32" = "W32" + conWidth "Int64" = "W64" + conWidth "Word8" = "W8" + conWidth "Word16" = "W16" + conWidth "Word32" = "W32" + conWidth "Word64" = "W64" + conWidth "Float" = "W32" + conWidth "Double" = "W64" + conWidth con = error $ "conWidth: unknown type constructor " ++ con ++ "\n" + main :: IO () main = getArgs >>= \args -> if length args /= 1 || head args `notElem` known_args @@ -75,6 +169,18 @@ main = getArgs >>= \args -> "--primop-list" -> putStr (gen_primop_list p_o_specs) + "--primop-vector-uniques" + -> putStr (gen_primop_vector_uniques p_o_specs) + + "--primop-vector-tys" + -> putStr (gen_primop_vector_tys p_o_specs) + + "--primop-vector-tys-exports" + -> putStr (gen_primop_vector_tys_exports p_o_specs) + + "--primop-vector-tycons" + -> putStr (gen_primop_vector_tycons p_o_specs) + "--make-haskell-wrappers" -> putStr (gen_wrappers p_o_specs) @@ -103,6 +209,10 @@ known_args "--primop-primop-info", "--primop-tag", "--primop-list", + "--primop-vector-uniques", + "--primop-vector-tys", + "--primop-vector-tys-exports", + "--primop-vector-tycons", "--make-haskell-wrappers", "--make-haskell-source", "--make-ext-core-source", @@ -136,32 +246,40 @@ gen_hs_source (Info defaults entries) = ++ "-----------------------------------------------------------------------------\n" ++ "{-# LANGUAGE MultiParamTypeClasses #-}\n" ++ "module GHC.Prim (\n" - ++ unlines (map (("\t" ++) . hdr) entries) + ++ unlines (map (("\t" ++) . hdr) entries') ++ ") where\n" ++ "\n" ++ "{-\n" ++ unlines (map opt defaults) ++ "-}\n" - ++ unlines (concatMap ent entries) ++ "\n\n\n" - where opt (OptionFalse n) = n ++ " = False" + ++ unlines (concatMap ent entries') ++ "\n\n\n" + where entries' = concatMap desugarVectorSpec entries + + opt (OptionFalse n) = n ++ " = False" opt (OptionTrue n) = n ++ " = True" opt (OptionString n v) = n ++ " = { " ++ v ++ "}" opt (OptionInteger n v) = n ++ " = " ++ show v + opt (OptionVector _) = "" opt (OptionFixity mf) = "fixity" ++ " = " ++ show mf - hdr s@(Section {}) = sec s - hdr (PrimOpSpec { name = n }) = wrapOp n ++ "," - hdr (PseudoOpSpec { name = n }) = wrapOp n ++ "," - hdr (PrimTypeSpec { ty = TyApp n _ }) = wrapTy n ++ "," - hdr (PrimTypeSpec {}) = error "Illegal type spec" - hdr (PrimClassSpec { cls = TyApp n _ }) = wrapTy n ++ "," - hdr (PrimClassSpec {}) = error "Illegal class spec" - - ent (Section {}) = [] - ent o@(PrimOpSpec {}) = spec o - ent o@(PrimTypeSpec {}) = spec o - ent o@(PrimClassSpec {}) = spec o - ent o@(PseudoOpSpec {}) = spec o + hdr s@(Section {}) = sec s + hdr (PrimOpSpec { name = n }) = wrapOp n ++ "," + hdr (PrimVecOpSpec { name = n }) = wrapOp n ++ "," + hdr (PseudoOpSpec { name = n }) = wrapOp n ++ "," + hdr (PrimTypeSpec { ty = TyApp (TyCon n) _ }) = wrapTy n ++ "," + hdr (PrimTypeSpec {}) = error $ "Illegal type spec" + hdr (PrimClassSpec { cls = TyApp (TyCon n) _ }) = wrapTy n ++ "," + hdr (PrimClassSpec {}) = error "Illegal class spec" + hdr (PrimVecTypeSpec { ty = TyApp (VecTyCon n _) _ }) = wrapTy n ++ "," + hdr (PrimVecTypeSpec {}) = error $ "Illegal type spec" + + ent (Section {}) = [] + ent o@(PrimOpSpec {}) = spec o + ent o@(PrimVecOpSpec {}) = spec o + ent o@(PrimTypeSpec {}) = spec o + ent o@(PrimClassSpec {}) = spec o + ent o@(PrimVecTypeSpec {}) = spec o + ent o@(PseudoOpSpec {}) = spec o sec s = "\n-- * " ++ escape (title s) ++ "\n" ++ (unlines $ map ("-- " ++ ) $ lines $ unlatex $ escape $ "|" ++ desc s) ++ "\n" @@ -173,6 +291,11 @@ gen_hs_source (Info defaults entries) = ++ [ wrapOp n ++ " :: " ++ pprTy t, wrapOp n ++ " = let x = x in x" ] + PrimVecOpSpec { name = n, ty = t, opts = options } -> + [ pprFixity fixity n | OptionFixity (Just fixity) <- options ] + ++ + [ wrapOp n ++ " :: " ++ pprTy t, + wrapOp n ++ " = let x = x in x" ] PseudoOpSpec { name = n, ty = t } -> [ wrapOp n ++ " :: " ++ pprTy t, wrapOp n ++ " = let x = x in x" ] @@ -180,6 +303,8 @@ gen_hs_source (Info defaults entries) = [ "data " ++ pprTy t ] PrimClassSpec { cls = t } -> [ "class " ++ pprTy t ] + PrimVecTypeSpec { ty = t } -> + [ "data " ++ pprTy t ] Section { } -> [] comm = case (desc o) of @@ -212,7 +337,7 @@ pprTy = pty pty (TyF t1 t2) = pbty t1 ++ " -> " ++ pty t2 pty (TyC t1 t2) = pbty t1 ++ " => " ++ pty t2 pty t = pbty t - pbty (TyApp tc ts) = tc ++ concat (map (' ' :) (map paty ts)) + pbty (TyApp tc ts) = show tc ++ concat (map (' ' :) (map paty ts)) pbty (TyUTup ts) = "(# " ++ concat (intersperse "," (map pty ts)) ++ " #)" @@ -259,7 +384,7 @@ gen_ext_core_source entries = where printList f = concat . intersperse ",\n" . filter (not . null) . map f tcEnt (PrimTypeSpec {ty=t}) = case t of - TyApp tc args -> parens tc (tcKind tc args) + TyApp tc args -> parens (show tc) (tcKind tc args) _ -> error ("tcEnt: type in PrimTypeSpec is not a type" ++ " constructor: " ++ show t) tcEnt _ = "" @@ -270,12 +395,12 @@ gen_ext_core_source entries = -- alternative would be to refer to things indirectly and hard-wire -- certain things (e.g., the kind of the Any constructor, here) into -- ext-core's Prims module again. - tcKind "Any" _ = "Klifted" - tcKind tc [] | last tc == '#' = "Kunlifted" - tcKind _ [] | otherwise = "Klifted" + tcKind (TyCon "Any") _ = "Klifted" + tcKind tc [] | last (show tc) == '#' = "Kunlifted" + tcKind _ [] | otherwise = "Klifted" -- assumes that all type arguments are lifted (are they?) - tcKind tc (_v:as) = "(Karrow Klifted " ++ tcKind tc as - ++ ")" + tcKind tc (_v:as) = "(Karrow Klifted " ++ tcKind tc as + ++ ")" valEnt (PseudoOpSpec {name=n, ty=t}) = valEntry n t valEnt (PrimOpSpec {name=n, ty=t}) = valEntry n t valEnt _ = "" @@ -290,7 +415,7 @@ gen_ext_core_source entries = ++ " " ++ paren s1)) ++ " " ++ paren s2 mkTconApp tc args = foldl tapp tc args - mkTcon tc = paren $ "Tcon " ++ paren (qualify True tc) + mkTcon tc = paren $ "Tcon " ++ paren (qualify True (show tc)) mkUtupleTy args = foldl tapp (tcUTuple (length args)) args mkForallTy [] t = t mkForallTy vs t = foldr @@ -314,7 +439,7 @@ gen_ext_core_source entries = ++ show n ++ "H") tyEnt (PrimTypeSpec {ty=(TyApp tc _args)}) = " " ++ paren ("Tcon " ++ - (paren (qualify True tc))) + (paren (qualify True (show tc)))) tyEnt _ = "" -- more hacks. might be better to do this on the ext-core side, @@ -334,7 +459,7 @@ gen_ext_core_source entries = prefixes ps = filter (\ t -> case t of (PrimTypeSpec {ty=(TyApp tc _args)}) -> - any (\ p -> p `isPrefixOf` tc) ps + any (\ p -> p `isPrefixOf` show tc) ps _ -> False) parens n ty' = " (zEncodeString \"" ++ n ++ "\", " ++ ty' ++ ")" @@ -358,6 +483,8 @@ gen_latex_doc (Info defaults entries) ++ d ++ "}{" ++ mk_options o ++ "}\n" + mk_entry (PrimVecOpSpec {}) = + "" mk_entry (Section {title=ti,desc=d}) = "\\primopsection{" ++ latex_encode ti ++ "}{" @@ -376,6 +503,8 @@ gen_latex_doc (Info defaults entries) ++ d ++ "}{" ++ mk_options o ++ "}\n" + mk_entry (PrimVecTypeSpec {}) = + "" mk_entry (PseudoOpSpec {name=n,ty=t,desc=d,opts=o}) = "\\pseudoopspec{" ++ latex_encode (zencode n) ++ "}{" @@ -388,7 +517,7 @@ gen_latex_doc (Info defaults entries) where pty (TyF t1 t2) = pbty t1 ++ " -> " ++ pty t2 pty (TyC t1 t2) = pbty t1 ++ " => " ++ pty t2 pty t = pbty t - pbty (TyApp tc ts) = tc ++ (concat (map (' ':) (map paty ts))) + pbty (TyApp tc ts) = show tc ++ (concat (map (' ':) (map paty ts))) pbty (TyUTup ts) = "(# " ++ (concat (intersperse "," (map pty ts))) ++ " #)" pbty t = paty t paty (TyVar tv) = tv @@ -398,11 +527,11 @@ gen_latex_doc (Info defaults entries) where pty (TyF t1 t2) = pbty t1 ++ " -> " ++ pty t2 pty (TyC t1 t2) = pbty t1 ++ " => " ++ pty t2 pty t = pbty t - pbty (TyApp tc ts) = (zencode tc) ++ (concat (map (' ':) (map paty ts))) + pbty (TyApp tc ts) = (zencode (show tc)) ++ (concat (map (' ':) (map paty ts))) pbty (TyUTup ts) = (zencode (utuplenm (length ts))) ++ (concat ((map (' ':) (map paty ts)))) pbty t = paty t paty (TyVar tv) = zencode tv - paty (TyApp tc []) = zencode tc + paty (TyApp tc []) = zencode (show tc) paty t = "(" ++ pty t ++ ")" utuplenm 1 = "(# #)" utuplenm n = "(#" ++ (replicate (n-1) ',') ++ "#)" @@ -441,6 +570,7 @@ gen_latex_doc (Info defaults entries) Just (OptionString _ _) -> error "String value for boolean option" Just (OptionInteger _ _) -> error "Integer value for boolean option" Just (OptionFixity _) -> error "Fixity value for boolean option" + Just (OptionVector _) -> error "vector template for boolean option" Nothing -> "" mk_strictness o = @@ -532,8 +662,8 @@ gen_wrappers (Info _ entries) filter (not.is_llvm_only) $ filter is_primop entries tycons = foldr union [] $ map (tyconsIn . ty) specs - tycons' = filter (`notElem` ["()", "Bool"]) tycons - types = concat $ intersperse ", " tycons' + tycons' = filter (`notElem` [TyCon "()", TyCon "Bool"]) tycons + types = concat $ intersperse ", " $ map show tycons' f spec = let args = map (\n -> "a" ++ show n) [1 .. arity (ty spec)] src_name = wrap (name spec) lhs = src_name ++ " " ++ unwords args @@ -568,24 +698,99 @@ gen_primop_list (Info _ entries) map (\p -> " , " ++ cons p) rest ++ [ " ]" ] - ) where (first:rest) = filter is_primop entries + ) where (first:rest) = concatMap desugarVectorSpec (filter is_primop entries) + +mIN_VECTOR_UNIQUE :: Int +mIN_VECTOR_UNIQUE = 300 + +gen_primop_vector_uniques :: Info -> String +gen_primop_vector_uniques (Info _ entries) + = unlines $ + concatMap mkVecUnique (specs `zip` [mIN_VECTOR_UNIQUE..]) + where + specs = concatMap desugarVectorSpec (filter is_vector (filter is_primtype entries)) + + mkVecUnique :: (Entry, Int) -> [String] + mkVecUnique (i, unique) = + [ key_id ++ " :: Unique" + , key_id ++ " = mkPreludeTyConUnique " ++ show unique + ] + where + key_id = prefix i ++ "PrimTyConKey" + +gen_primop_vector_tys :: Info -> String +gen_primop_vector_tys (Info _ entries) + = unlines $ + concatMap mkVecTypes specs + where + specs = concatMap desugarVectorSpec (filter is_vector (filter is_primtype entries)) + + mkVecTypes :: Entry -> [String] + mkVecTypes i = + [ name_id ++ " :: Name" + , name_id ++ " = mkPrimTc (fsLit \"" ++ pprTy (ty i) ++ "\") " ++ key_id ++ " " ++ tycon_id + , ty_id ++ " :: Type" + , ty_id ++ " = mkTyConTy " ++ tycon_id + , tycon_id ++ " :: TyCon" + , tycon_id ++ " = pcPrimTyCon0 " ++ name_id ++ + " (VecRep " ++ show (veclen i) ++ " " ++ elemrep i ++ ")" + ] + where + key_id = prefix i ++ "PrimTyConKey" + name_id = prefix i ++ "PrimTyConName" + ty_id = prefix i ++ "PrimTy" + tycon_id = prefix i ++ "PrimTyCon" + +gen_primop_vector_tys_exports :: Info -> String +gen_primop_vector_tys_exports (Info _ entries) + = unlines $ + map mkVecTypes specs + where + specs = concatMap desugarVectorSpec (filter is_vector (filter is_primtype entries)) + + mkVecTypes :: Entry -> String + mkVecTypes i = + "\t" ++ ty_id ++ ", " ++ tycon_id ++ "," + where + ty_id = prefix i ++ "PrimTy" + tycon_id = prefix i ++ "PrimTyCon" + +gen_primop_vector_tycons :: Info -> String +gen_primop_vector_tycons (Info _ entries) + = unlines $ + map mkVecTypes specs + where + specs = concatMap desugarVectorSpec (filter is_vector (filter is_primtype entries)) + + mkVecTypes :: Entry -> String + mkVecTypes i = + " , " ++ tycon_id + where + tycon_id = prefix i ++ "PrimTyCon" gen_primop_tag :: Info -> String gen_primop_tag (Info _ entries) = unlines (max_def_type : max_def : tagOf_type : zipWith f primop_entries [1 :: Int ..]) where - primop_entries = filter is_primop entries + primop_entries = concatMap desugarVectorSpec $ filter is_primop entries tagOf_type = "tagOf_PrimOp :: PrimOp -> FastInt" f i n = "tagOf_PrimOp " ++ cons i ++ " = _ILIT(" ++ show n ++ ")" max_def_type = "maxPrimOpTag :: Int" max_def = "maxPrimOpTag = " ++ show (length primop_entries) gen_data_decl :: Info -> String -gen_data_decl (Info _ entries) - = let conss = map cons (filter is_primop entries) - in "data PrimOp\n = " ++ head conss ++ "\n" - ++ unlines (map (" | "++) (tail conss)) +gen_data_decl (Info _ entries) = + "data PrimOp\n = " ++ head conss ++ "\n" + ++ unlines (map (" | "++) (tail conss)) + where + conss = map genCons (filter is_primop entries) + + genCons :: Entry -> String + genCons entry = + case vecOptions entry of + [] -> cons entry + _ -> cons entry ++ " PrimOpVecCat Length Width" gen_switch_from_attribs :: String -> String -> Info -> String gen_switch_from_attribs attrib_name fn_name (Info defaults entries) @@ -596,12 +801,15 @@ gen_switch_from_attribs attrib_name fn_name (Info defaults entries) getAltRhs (OptionTrue _) = "True" getAltRhs (OptionInteger _ i) = show i getAltRhs (OptionString _ s) = s + getAltRhs (OptionVector _) = "True" getAltRhs (OptionFixity mf) = show mf mkAlt po = case lookup_attrib attrib_name (opts po) of Nothing -> Nothing - Just xx -> Just (fn_name ++ " " ++ cons po ++ " = " ++ getAltRhs xx) + Just xx -> case vecOptions po of + [] -> Just (fn_name ++ " " ++ cons po ++ " = " ++ getAltRhs xx) + _ -> Just (fn_name ++ " (" ++ cons po ++ " _ _ _) = " ++ getAltRhs xx) in case defv of @@ -616,7 +824,7 @@ gen_switch_from_attribs attrib_name fn_name (Info defaults entries) gen_primop_info :: Info -> String gen_primop_info (Info _ entries) - = unlines (map mkPOItext (filter is_primop entries)) + = unlines (map mkPOItext (concatMap desugarVectorSpec (filter is_primop entries))) mkPOItext :: Entry -> String mkPOItext i = mkPOI_LHS_text i ++ mkPOI_RHS_text i @@ -664,29 +872,25 @@ ppTyVar "o" = "openAlphaTyVar" ppTyVar _ = error "Unknown type var" ppType :: Ty -> String -ppType (TyApp "Any" []) = "anyTy" -ppType (TyApp "Bool" []) = "boolTy" - -ppType (TyApp "Int#" []) = "intPrimTy" -ppType (TyApp "Int32#" []) = "int32PrimTy" -ppType (TyApp "Int64#" []) = "int64PrimTy" -ppType (TyApp "Char#" []) = "charPrimTy" -ppType (TyApp "Word#" []) = "wordPrimTy" -ppType (TyApp "Word32#" []) = "word32PrimTy" -ppType (TyApp "Word64#" []) = "word64PrimTy" -ppType (TyApp "Addr#" []) = "addrPrimTy" -ppType (TyApp "Float#" []) = "floatPrimTy" -ppType (TyApp "Double#" []) = "doublePrimTy" -ppType (TyApp "FloatX4#" []) = "floatX4PrimTy" -ppType (TyApp "DoubleX2#" []) = "doubleX2PrimTy" -ppType (TyApp "Int32X4#" []) = "int32X4PrimTy" -ppType (TyApp "Int64X2#" []) = "int64X2PrimTy" -ppType (TyApp "ByteArray#" []) = "byteArrayPrimTy" -ppType (TyApp "RealWorld" []) = "realWorldTy" -ppType (TyApp "ThreadId#" []) = "threadIdPrimTy" -ppType (TyApp "ForeignObj#" []) = "foreignObjPrimTy" -ppType (TyApp "BCO#" []) = "bcoPrimTy" -ppType (TyApp "()" []) = "unitTy" -- unitTy is TysWiredIn's name for () +ppType (TyApp (TyCon "Any") []) = "anyTy" +ppType (TyApp (TyCon "Bool") []) = "boolTy" + +ppType (TyApp (TyCon "Int#") []) = "intPrimTy" +ppType (TyApp (TyCon "Int32#") []) = "int32PrimTy" +ppType (TyApp (TyCon "Int64#") []) = "int64PrimTy" +ppType (TyApp (TyCon "Char#") []) = "charPrimTy" +ppType (TyApp (TyCon "Word#") []) = "wordPrimTy" +ppType (TyApp (TyCon "Word32#") []) = "word32PrimTy" +ppType (TyApp (TyCon "Word64#") []) = "word64PrimTy" +ppType (TyApp (TyCon "Addr#") []) = "addrPrimTy" +ppType (TyApp (TyCon "Float#") []) = "floatPrimTy" +ppType (TyApp (TyCon "Double#") []) = "doublePrimTy" +ppType (TyApp (TyCon "ByteArray#") []) = "byteArrayPrimTy" +ppType (TyApp (TyCon "RealWorld") []) = "realWorldTy" +ppType (TyApp (TyCon "ThreadId#") []) = "threadIdPrimTy" +ppType (TyApp (TyCon "ForeignObj#") []) = "foreignObjPrimTy" +ppType (TyApp (TyCon "BCO#") []) = "bcoPrimTy" +ppType (TyApp (TyCon "()") []) = "unitTy" -- unitTy is TysWiredIn's name for () ppType (TyVar "a") = "alphaTy" ppType (TyVar "b") = "betaTy" @@ -694,28 +898,31 @@ ppType (TyVar "c") = "gammaTy" ppType (TyVar "s") = "deltaTy" ppType (TyVar "o") = "openAlphaTy" -ppType (TyApp "State#" [x]) = "mkStatePrimTy " ++ ppType x -ppType (TyApp "MutVar#" [x,y]) = "mkMutVarPrimTy " ++ ppType x - ++ " " ++ ppType y -ppType (TyApp "MutableArray#" [x,y]) = "mkMutableArrayPrimTy " ++ ppType x +ppType (TyApp (TyCon "State#") [x]) = "mkStatePrimTy " ++ ppType x +ppType (TyApp (TyCon "MutVar#") [x,y]) = "mkMutVarPrimTy " ++ ppType x + ++ " " ++ ppType y +ppType (TyApp (TyCon "MutableArray#") [x,y]) = "mkMutableArrayPrimTy " ++ ppType x + ++ " " ++ ppType y +ppType (TyApp (TyCon "MutableArrayArray#") [x]) = "mkMutableArrayArrayPrimTy " ++ ppType x +ppType (TyApp (TyCon "MutableByteArray#") [x]) = "mkMutableByteArrayPrimTy " + ++ ppType x +ppType (TyApp (TyCon "Array#") [x]) = "mkArrayPrimTy " ++ ppType x +ppType (TyApp (TyCon "ArrayArray#") []) = "mkArrayArrayPrimTy" + + +ppType (TyApp (TyCon "Weak#") [x]) = "mkWeakPrimTy " ++ ppType x +ppType (TyApp (TyCon "StablePtr#") [x]) = "mkStablePtrPrimTy " ++ ppType x +ppType (TyApp (TyCon "StableName#") [x]) = "mkStableNamePrimTy " ++ ppType x + +ppType (TyApp (TyCon "MVar#") [x,y]) = "mkMVarPrimTy " ++ ppType x + ++ " " ++ ppType y +ppType (TyApp (TyCon "TVar#") [x,y]) = "mkTVarPrimTy " ++ ppType x ++ " " ++ ppType y -ppType (TyApp "MutableArrayArray#" [x]) = "mkMutableArrayArrayPrimTy " ++ ppType x -ppType (TyApp "MutableByteArray#" [x]) = "mkMutableByteArrayPrimTy " - ++ ppType x -ppType (TyApp "Array#" [x]) = "mkArrayPrimTy " ++ ppType x -ppType (TyApp "ArrayArray#" []) = "mkArrayArrayPrimTy" - - -ppType (TyApp "Weak#" [x]) = "mkWeakPrimTy " ++ ppType x -ppType (TyApp "StablePtr#" [x]) = "mkStablePtrPrimTy " ++ ppType x -ppType (TyApp "StableName#" [x]) = "mkStableNamePrimTy " ++ ppType x - -ppType (TyApp "MVar#" [x,y]) = "mkMVarPrimTy " ++ ppType x - ++ " " ++ ppType y -ppType (TyApp "TVar#" [x,y]) = "mkTVarPrimTy " ++ ppType x - ++ " " ++ ppType y -ppType (TyUTup ts) = "(mkTupleTy UnboxedTuple " - ++ listify (map ppType ts) ++ ")" + +ppType (TyApp (VecTyCon _ pptc) []) = pptc + +ppType (TyUTup ts) = "(mkTupleTy UnboxedTuple " + ++ listify (map ppType ts) ++ ")" ppType (TyF s d) = "(mkFunTy (" ++ ppType s ++ ") (" ++ ppType d ++ "))" ppType (TyC s d) = "(mkFunTy (" ++ ppType s ++ ") (" ++ ppType d ++ "))" |