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.

5 files changed, 372 insertions, 88 deletions

diff --git a/utils/genprimopcode/Lexer.x b/utils/genprimopcode/Lexer.x
index ff18e17373..d29d8a17f0 100644
--- a/utils/genprimopcode/Lexer.x
+++ b/utils/genprimopcode/Lexer.x
@@ -40,6 +40,10 @@ words :-
     <0>         ")"                 { mkT TCloseParen }
     <0>         "(#"                { mkT TOpenParenHash }
     <0>         "#)"                { mkT THashCloseParen }
+    <0>         "["                 { mkT TOpenBracket }
+    <0>         "]"                 { mkT TCloseBracket }
+    <0>         "<"                 { mkT TOpenAngle }
+    <0>         ">"                 { mkT TCloseAngle }
     <0>         "section"           { mkT TSection }
     <0>         "primop"            { mkT TPrimop }
     <0>         "pseudoop"          { mkT TPseudoop }
@@ -58,7 +62,11 @@ words :-
     <0>         "infixl"            { mkT TInfixL }
     <0>         "infixr"            { mkT TInfixR }
     <0>         "Nothing"           { mkT TNothing }
+    <0>         "vector"            { mkT TVector }
     <0>         "thats_all_folks"   { mkT TThatsAllFolks }
+    <0>         "SCALAR"            { mkT TSCALAR }
+    <0>         "VECTOR"            { mkT TVECTOR }
+    <0>         "VECTUPLE"          { mkT TVECTUPLE }
     <0>         [a-z][a-zA-Z0-9\#_]* { mkTv TLowerName }
     <0>         [A-Z][a-zA-Z0-9\#_]* { mkTv TUpperName }
     <0>         [0-9][0-9]*         { mkTv (TInteger . read) }
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 ++ "))"
diff --git a/utils/genprimopcode/Parser.y b/utils/genprimopcode/Parser.y
index eb76cb0407..07ef03b986 100644
--- a/utils/genprimopcode/Parser.y
+++ b/utils/genprimopcode/Parser.y
@@ -32,6 +32,10 @@ import Syntax
     '#)'            { THashCloseParen }
     '{'             { TOpenBrace }
     '}'             { TCloseBrace }
+    '['             { TOpenBracket }
+    ']'             { TCloseBracket }
+    '<'             { TOpenAngle }
+    '>'             { TCloseAngle }
     section         { TSection }
     primop          { TPrimop }
     pseudoop        { TPseudoop }
@@ -50,6 +54,10 @@ import Syntax
     infixl          { TInfixL }
     infixr          { TInfixR }
     nothing         { TNothing }
+    vector          { TVector }
+    SCALAR          { TSCALAR }
+    VECTOR          { TVECTOR }
+    VECTUPLE        { TVECTUPLE }
     thats_all_folks { TThatsAllFolks }
     lowerName       { TLowerName $$ }
     upperName       { TUpperName $$ }
@@ -74,6 +82,7 @@ pOption : lowerName '=' false               { OptionFalse  $1 }
         | lowerName '=' true                { OptionTrue   $1 }
         | lowerName '=' pStuffBetweenBraces { OptionString $1 $3 }
         | lowerName '=' integer             { OptionInteger $1 $3 }
+        | vector    '=' pVectorTemplate     { OptionVector $3 }
         | fixity    '=' pInfix              { OptionFixity $3 }
 
 pInfix :: { Maybe Fixity }
@@ -147,6 +156,17 @@ pInside :: { String }
 pInside : '{' pInsides '}' { "{" ++ $2 ++ "}" }
         | noBraces         { $1 }
 
+pVectorTemplate :: { [(String, String, Int)] }
+pVectorTemplate : '[' pVectors ']' { $2 }
+
+pVectors :: { [(String, String, Int)] }
+pVectors : pVector ',' pVectors { [$1] ++ $3 }
+         | pVector              { [$1] }
+         | {- empty -}          { [] }
+
+pVector :: { (String, String, Int) }
+pVector : '<' upperName ',' upperName ',' integer '>' { ($2, $4, $6) }
+ 
 pType :: { Ty }
 pType : paT '->' pType { TyF $1 $3 }
       | paT '=>' pType { TyC $1 $3 }
@@ -175,9 +195,12 @@ ppT :: { Ty }
 ppT : lowerName { TyVar $1 }
     | pTycon    { TyApp $1 [] }
 
-pTycon :: { String }
-pTycon : upperName { $1 }
-       | '(' ')'   { "()" }
+pTycon :: { TyCon }
+pTycon : upperName { TyCon $1 }
+       | '(' ')'   { TyCon "()" }
+       | SCALAR    { SCALAR }
+       | VECTOR    { VECTOR }
+       | VECTUPLE  { VECTUPLE }
 
 {
 parse :: String -> Either String Info
diff --git a/utils/genprimopcode/ParserM.hs b/utils/genprimopcode/ParserM.hs
index 8093675651..aaaf6ac66f 100644
--- a/utils/genprimopcode/ParserM.hs
+++ b/utils/genprimopcode/ParserM.hs
@@ -67,6 +67,10 @@ data Token = TEOF
            | THashCloseParen
            | TOpenBrace
            | TCloseBrace
+           | TOpenBracket
+           | TCloseBracket
+           | TOpenAngle
+           | TCloseAngle
            | TSection
            | TPrimop
            | TPseudoop
@@ -91,6 +95,10 @@ data Token = TEOF
            | TInfixL
            | TInfixR
            | TNothing
+           | TVector
+           | TSCALAR
+           | TVECTOR
+           | TVECTUPLE
     deriving Show
 
 -- Actions
diff --git a/utils/genprimopcode/Syntax.hs b/utils/genprimopcode/Syntax.hs
index 333ea2c4c7..d0c380cf59 100644
--- a/utils/genprimopcode/Syntax.hs
+++ b/utils/genprimopcode/Syntax.hs
@@ -19,6 +19,15 @@ data Entry
                    cat   :: Category,    -- category
                    desc  :: String,      -- description
                    opts  :: [Option] }   -- default overrides
+    | PrimVecOpSpec { cons    :: String,    -- PrimOp name
+                      name    :: String,    -- name in prog text
+                      prefix  :: String,    -- prefix for generated names
+                      veclen  :: Int,       -- vector length
+                      elemrep :: String,    -- vector ElemRep
+                      ty      :: Ty,        -- type
+                      cat     :: Category,  -- category
+                      desc    :: String,    -- description
+                      opts    :: [Option] } -- default overrides
     | PseudoOpSpec { name  :: String,      -- name in prog text
                      ty    :: Ty,          -- type
                      desc  :: String,      -- description
@@ -29,6 +38,12 @@ data Entry
     | PrimClassSpec { cls   :: Ty,      -- name in prog text
                       desc  :: String,      -- description
                       opts  :: [Option] }   -- default overrides
+    | PrimVecTypeSpec { ty    :: Ty,      -- name in prog text
+                        prefix  :: String,    -- prefix for generated names
+                        veclen  :: Int,       -- vector length
+                        elemrep :: String,    -- vector ElemRep
+                        desc  :: String,      -- description
+                        opts  :: [Option] }   -- default overrides
     | Section { title :: String,         -- section title
                 desc  :: String }        -- description
     deriving Show
@@ -37,12 +52,17 @@ is_primop :: Entry -> Bool
 is_primop (PrimOpSpec _ _ _ _ _ _) = True
 is_primop _ = False
 
+is_primtype :: Entry -> Bool
+is_primtype (PrimTypeSpec {}) = True
+is_primtype _ = False
+
 -- a binding of property to value
 data Option
    = OptionFalse  String          -- name = False
    | OptionTrue   String          -- name = True
    | OptionString String String   -- name = { ... unparsed stuff ... }
    | OptionInteger String Int     -- name = <int>
+   | OptionVector [(String,String,Int)]  -- name = [(,...),...]
    | OptionFixity (Maybe Fixity)  -- fixity = infix{,l,r} <int> | Nothing
      deriving Show
 
@@ -62,7 +82,20 @@ data Ty
    deriving (Eq,Show)
 
 type TyVar = String
-type TyCon = String
+
+data TyCon = TyCon String
+           | SCALAR
+           | VECTOR
+           | VECTUPLE
+           | VecTyCon String String
+  deriving (Eq, Ord)
+
+instance Show TyCon where
+    show (TyCon tc)      = tc
+    show SCALAR          = "SCALAR"
+    show VECTOR          = "VECTOR"
+    show VECTUPLE        = "VECTUPLE"
+    show (VecTyCon tc _) = tc
 
 -- Follow definitions of Fixity and FixityDirection in GHC
 
@@ -118,7 +151,7 @@ sanityPrimOp def_names p
 
 sane_ty :: Category -> Ty -> Bool
 sane_ty Compare (TyF t1 (TyF t2 td)) 
-   | t1 == t2 && td == TyApp "Int#" []  = True
+   | t1 == t2 && td == TyApp (TyCon "Int#") []  = True
 sane_ty Monadic (TyF t1 td) 
    | t1 == td  = True
 sane_ty Dyadic (TyF t1 (TyF t2 td))
@@ -133,6 +166,7 @@ get_attrib_name (OptionFalse nm) = nm
 get_attrib_name (OptionTrue nm)  = nm
 get_attrib_name (OptionString nm _) = nm
 get_attrib_name (OptionInteger nm _) = nm
+get_attrib_name (OptionVector _) = "vector"
 get_attrib_name (OptionFixity _) = "fixity"
 
 lookup_attrib :: String -> [Option] -> Maybe Option
@@ -140,3 +174,7 @@ lookup_attrib _ [] = Nothing
 lookup_attrib nm (a:as) 
     = if get_attrib_name a == nm then Just a else lookup_attrib nm as
 
+is_vector :: Entry -> Bool
+is_vector i = case lookup_attrib "vector" (opts i) of
+                Nothing -> False
+                _       -> True