diff options
Diffstat (limited to 'utils/genprimopcode')
| -rw-r--r-- | utils/genprimopcode/Lexer.x | 8 | ||||
| -rw-r--r-- | utils/genprimopcode/Main.hs | 373 | ||||
| -rw-r--r-- | utils/genprimopcode/Parser.y | 29 | ||||
| -rw-r--r-- | utils/genprimopcode/ParserM.hs | 8 | ||||
| -rw-r--r-- | utils/genprimopcode/Syntax.hs | 42 |
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 |