SIMD primops are now generated using schemas that are polymorphic in

width and element type.

SIMD primops are now polymorphic in vector size and element type, but
only internally to the compiler. More specifically, utils/genprimopcode
has been extended so that it "knows" about SIMD vectors. This allows us
to, for example, write a single definition for the "add two vectors"
primop in primops.txt.pp and have it instantiated at many vector types.
This generates a primop in GHC.Prim for each vector type at which "add
two vectors" is instantiated, but only one data constructor for the
PrimOp data type, so the code generator is much, much simpler.

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 ++ "))"