X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=utils%2Fgenprimopcode%2FMain.hs;h=5bc6ade8ebd67bbef61daa63faa19aaa68f4ed7d;hb=7f3ce06a1a2840c52d6f5bf1bcd09cffe1f80d28;hp=f08b7d5602b3d04131279665e8bb3c97cbf8e204;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1;p=ghc-hetmet.git diff --git a/utils/genprimopcode/Main.hs b/utils/genprimopcode/Main.hs index f08b7d5..5bc6ade 100644 --- a/utils/genprimopcode/Main.hs +++ b/utils/genprimopcode/Main.hs @@ -17,6 +17,7 @@ import List import System ( getArgs ) import Maybe ( catMaybes ) +main :: IO () main = getArgs >>= \args -> if length args /= 1 || head args `notElem` known_args then error ("usage: genprimopcode command < primops.txt > ...\n" @@ -89,7 +90,7 @@ main = getArgs >>= \args -> -> putStr (gen_latex_doc p_o_specs) ) - +known_args :: [String] known_args = [ "--data-decl", "--has-side-effects", @@ -111,56 +112,80 @@ known_args -- Code generators ----------------------------------------------- ------------------------------------------------------------------ -gen_hs_source (Info defaults entries) - = "module GHC.Prim (\n" - ++ unlines (map (("\t" ++) . hdr) entries) - ++ ") where\n\n{-\n" - ++ unlines (map opt defaults) ++ "-}\n" - ++ unlines (map ent entries) ++ "\n\n\n" - where opt (OptionFalse n) = n ++ " = False" - opt (OptionTrue n) = n ++ " = True" +gen_hs_source :: Info -> String +gen_hs_source (Info defaults entries) = + "-----------------------------------------------------------------------------\n" + ++ "-- |\n" + ++ "-- Module : GHC.Arr\n" + ++ "-- \n" + ++ "-- Maintainer : cvs-ghc@haskell.org\n" + ++ "-- Stability : internal\n" + ++ "-- Portability : non-portable (GHC extensions)\n" + ++ "--\n" + ++ "-- GHC\'s primitive types and operations.\n" + ++ "--\n" + ++ "-----------------------------------------------------------------------------\n" + ++ "module GHC.Prim (\n" + ++ unlines (map (("\t" ++) . hdr) entries) + ++ ") where\n\n{-\n" + ++ unlines (map opt defaults) ++ "-}\n" + ++ unlines (map ent entries) ++ "\n\n\n" + where opt (OptionFalse n) = n ++ " = False" + opt (OptionTrue n) = n ++ " = True" opt (OptionString n v) = n ++ " = { " ++ v ++ "}" - hdr s@(Section {}) = sec s - hdr o@(PrimOpSpec {}) = wrap (name o) ++ "," + hdr s@(Section {}) = sec s + hdr (PrimOpSpec { name = n }) = wrapOp n ++ "," + hdr (PseudoOpSpec { name = n }) = wrapOp n ++ "," + hdr (PrimTypeSpec { ty = TyApp n _ }) = wrapTy n ++ "," - ent s@(Section {}) = "" - ent o@(PrimOpSpec {}) = spec o + ent (Section {}) = "" + ent o@(PrimOpSpec {}) = spec o + ent o@(PrimTypeSpec {}) = spec o + ent o@(PseudoOpSpec {}) = spec o sec s = "\n-- * " ++ escape (title s) ++ "\n" ++ (unlines $ map ("-- " ++ ) $ lines $ unlatex $ escape $ "|" ++ desc s) ++ "\n" spec o = comm ++ decl - where decl = wrap (name o) ++ " :: " ++ pty (ty o) + where decl = case o of + PrimOpSpec { name = n, ty = t } -> wrapOp n ++ " :: " ++ pty t + PseudoOpSpec { name = n, ty = t } -> wrapOp n ++ " :: " ++ pty t + PrimTypeSpec { ty = t } -> "data " ++ pty t + comm = case (desc o) of [] -> "" d -> "\n" ++ (unlines $ map ("-- " ++ ) $ lines $ unlatex $ escape $ "|" ++ d) pty (TyF t1 t2) = pbty t1 ++ " -> " ++ pty t2 - pty t = pbty t + pty t = pbty t pbty (TyApp tc ts) = tc ++ (concat (map (' ':) (map paty ts))) - pbty (TyUTup ts) = "(# " ++ (concat (intersperse "," (map pty ts))) ++ " #)" - pbty t = paty t + pbty (TyUTup ts) = "(# " ++ (concat (intersperse "," (map pty ts))) ++ " #)" + pbty t = paty t - paty (TyVar tv) = tv - paty t = "(" ++ pty t ++ ")" + paty (TyVar tv) = tv + paty t = "(" ++ pty t ++ ")" - wrap nm | isLower (head nm) = nm - | otherwise = "(" ++ nm ++ ")" + wrapOp nm | isAlpha (head nm) = nm + | otherwise = "(" ++ nm ++ ")" + wrapTy nm | isAlpha (head nm) = nm + | otherwise = "(" ++ nm ++ ")" unlatex s = case s of '\\':'t':'e':'x':'t':'t':'t':'{':cs -> markup "@" "@" cs '{':'\\':'t':'t':cs -> markup "@" "@" cs + '{':'\\':'i':'t':cs -> markup "/" "/" cs c : cs -> c : unlatex cs [] -> [] markup s t cs = s ++ mk (dropWhile isSpace cs) - where mk "" = t + where mk "" = t mk ('\n':cs) = ' ' : mk cs - mk ('}':cs) = t ++ unlatex cs - mk (c:cs) = c : mk cs + mk ('}':cs) = t ++ unlatex cs + mk (c:cs) = c : mk cs escape = concatMap (\c -> if c `elem` special then '\\':c:[] else c:[]) where special = "/'`\"@<" +gen_latex_doc :: Info -> String gen_latex_doc (Info defaults entries) = "\\primopdefaults{" ++ mk_options defaults @@ -207,7 +232,7 @@ gen_latex_doc (Info defaults entries) tbinds ("o":tbs) = "(o::?) " ++ (tbinds tbs) tbinds (tv:tbs) = tv ++ " " ++ (tbinds tbs) tvars_of (TyF t1 t2) = tvars_of t1 `union` tvars_of t2 - tvars_of (TyApp tc ts) = foldl union [] (map tvars_of ts) + tvars_of (TyApp _ ts) = foldl union [] (map tvars_of ts) tvars_of (TyUTup ts) = foldr union [] (map tvars_of ts) tvars_of (TyVar tv) = [tv] @@ -251,13 +276,13 @@ gen_latex_doc (Info defaults entries) where maybe_tuple "(# #)" = Just("Z1H") maybe_tuple ('(' : '#' : cs) = case count_commas (0::Int) cs of - (n, '#' : ')' : cs) -> Just ('Z' : shows (n+1) "H") - other -> Nothing + (n, '#' : ')' : _) -> Just ('Z' : shows (n+1) "H") + _ -> Nothing maybe_tuple "()" = Just("Z0T") maybe_tuple ('(' : cs) = case count_commas (0::Int) cs of - (n, ')' : cs) -> Just ('Z' : shows (n+1) "T") - other -> Nothing - maybe_tuple other = Nothing + (n, ')' : _) -> Just ('Z' : shows (n+1) "T") + _ -> Nothing + maybe_tuple _ = Nothing count_commas :: Int -> String -> (Int, String) count_commas n (',' : cs) = count_commas (n+1) cs @@ -307,7 +332,8 @@ gen_latex_doc (Info defaults entries) latex_encode ('\\':cs) = "$\\backslash$" ++ (latex_encode cs) latex_encode (c:cs) = c:(latex_encode cs) -gen_wrappers (Info defaults entries) +gen_wrappers :: Info -> String +gen_wrappers (Info _ entries) = "{-# OPTIONS -fno-implicit-prelude #-}\n" -- Dependencies on Prelude must be explicit in libraries/base, but we -- don't need the Prelude here so we add -fno-implicit-prelude. @@ -333,8 +359,8 @@ gen_wrappers (Info defaults entries) "parAtAbs#", "parAtRel#", "parAtForNow#" ] - -gen_primop_list (Info defaults entries) +gen_primop_list :: Info -> String +gen_primop_list (Info _ entries) = unlines ( [ " [" ++ cons first ] ++ @@ -343,15 +369,17 @@ gen_primop_list (Info defaults entries) [ " ]" ] ) where (first:rest) = filter is_primop entries -gen_primop_tag (Info defaults entries) - = unlines (max_def : zipWith f primop_entries [1..]) +gen_primop_tag :: Info -> String +gen_primop_tag (Info _ entries) + = unlines (max_def : zipWith f primop_entries [1 :: Int ..]) where primop_entries = filter is_primop entries f i n = "tagOf_PrimOp " ++ cons i ++ " = _ILIT(" ++ show n ++ ") :: FastInt" max_def = "maxPrimOpTag = " ++ show (length primop_entries) ++ " :: Int" -gen_data_decl (Info defaults 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)) @@ -381,28 +409,31 @@ gen_switch_from_attribs attrib_name fn_name (Info defaults entries) -- Create PrimOpInfo text from PrimOpSpecs ----------------------- ------------------------------------------------------------------ - -gen_primop_info (Info defaults entries) +gen_primop_info :: Info -> String +gen_primop_info (Info _ entries) = unlines (map mkPOItext (filter is_primop entries)) +mkPOItext :: Entry -> String mkPOItext i = mkPOI_LHS_text i ++ mkPOI_RHS_text i +mkPOI_LHS_text :: Entry -> String mkPOI_LHS_text i = "primOpInfo " ++ cons i ++ " = " +mkPOI_RHS_text :: Entry -> String mkPOI_RHS_text i = case cat i of Compare -> case ty i of - TyF t1 (TyF t2 td) + TyF t1 (TyF _ _) -> "mkCompare " ++ sl_name i ++ ppType t1 Monadic -> case ty i of - TyF t1 td + TyF t1 _ -> "mkMonadic " ++ sl_name i ++ ppType t1 Dyadic -> case ty i of - TyF t1 (TyF t2 td) + TyF t1 (TyF _ _) -> "mkDyadic " ++ sl_name i ++ ppType t1 GenPrimOp -> let (argTys, resTy) = flatTys (ty i) @@ -413,15 +444,17 @@ mkPOI_RHS_text i ++ listify (map ppType argTys) ++ " " ++ "(" ++ ppType resTy ++ ")" +sl_name :: Entry -> String sl_name i = "FSLIT(\"" ++ name i ++ "\") " +ppTyVar :: String -> String ppTyVar "a" = "alphaTyVar" ppTyVar "b" = "betaTyVar" ppTyVar "c" = "gammaTyVar" ppTyVar "s" = "deltaTyVar" ppTyVar "o" = "openAlphaTyVar" - +ppType :: Ty -> String ppType (TyApp "Bool" []) = "boolTy" ppType (TyApp "Int#" []) = "intPrimTy" @@ -441,7 +474,6 @@ ppType (TyApp "ForeignObj#" []) = "foreignObjPrimTy" ppType (TyApp "BCO#" []) = "bcoPrimTy" ppType (TyApp "()" []) = "unitTy" -- unitTy is TysWiredIn's name for () - ppType (TyVar "a") = "alphaTy" ppType (TyVar "b") = "betaTy" ppType (TyVar "c") = "gammaTy" @@ -479,17 +511,19 @@ ppType other listify :: [String] -> String listify ss = "[" ++ concat (intersperse ", " ss) ++ "]" +flatTys :: Ty -> ([Ty],Ty) flatTys (TyF t1 t2) = case flatTys t2 of (ts,t) -> (t1:ts,t) flatTys other = ([],other) +tvsIn :: Ty -> [TyVar] tvsIn (TyF t1 t2) = tvsIn t1 ++ tvsIn t2 -tvsIn (TyApp tc tys) = concatMap tvsIn tys +tvsIn (TyApp _ tys) = concatMap tvsIn tys tvsIn (TyVar tv) = [tv] tvsIn (TyUTup tys) = concatMap tvsIn tys +arity :: Ty -> Int arity = length . fst . flatTys - ------------------------------------------------------------------ -- Abstract syntax ----------------------------------------------- ------------------------------------------------------------------ @@ -507,10 +541,18 @@ data Entry cat :: Category, -- category desc :: String, -- description opts :: [Option] } -- default overrides + | PseudoOpSpec { name :: String, -- name in prog text + ty :: Ty, -- type + desc :: String, -- description + opts :: [Option] } -- default overrides + | PrimTypeSpec { ty :: Ty, -- name in prog text + desc :: String, -- description + opts :: [Option] } -- default overrides | Section { title :: String, -- section title desc :: String } -- description deriving Show +is_primop :: Entry -> Bool is_primop (PrimOpSpec _ _ _ _ _ _) = True is_primop _ = False @@ -553,7 +595,10 @@ type TyCon = String T -> T -> Bool. Dies with "error" if there's a problem, else returns (). -} +myseq :: () -> a -> a myseq () x = x + +myseqAll :: [()] -> a -> a myseqAll (():ys) x = myseqAll ys x myseqAll [] x = x @@ -566,6 +611,7 @@ sanityTop (Info defs entries) then error ("non-unique default attribute names: " ++ show opt_names ++ "\n") else myseqAll (map (sanityPrimOp opt_names) primops) () +sanityPrimOp :: [String] -> Entry -> () sanityPrimOp def_names p = let p_names = map get_attrib_name (opts p) p_names_ok @@ -582,22 +628,25 @@ sanityPrimOp def_names p " category " ++ show (cat p) ++ "\n") else () +sane_ty :: Category -> Ty -> Bool sane_ty Compare (TyF t1 (TyF t2 td)) | t1 == t2 && td == TyApp "Bool" [] = True sane_ty Monadic (TyF t1 td) | t1 == td = True -sane_ty Dyadic (TyF t1 (TyF t2 td)) +sane_ty Dyadic (TyF t1 (TyF t2 _)) | t1 == t2 && t2 == t2 = True -sane_ty GenPrimOp any_old_thing +sane_ty GenPrimOp _ = True sane_ty _ _ = False +get_attrib_name :: Option -> String get_attrib_name (OptionFalse nm) = nm get_attrib_name (OptionTrue nm) = nm get_attrib_name (OptionString nm _) = nm -lookup_attrib nm [] = Nothing +lookup_attrib :: String -> [Option] -> Maybe Option +lookup_attrib _ [] = Nothing lookup_attrib nm (a:as) = if get_attrib_name a == nm then Just a else lookup_attrib nm as @@ -605,6 +654,9 @@ lookup_attrib nm (a:as) -- The parser ---------------------------------------------------- ------------------------------------------------------------------ +keywords :: [String] +keywords = [ "section", "primop", "pseudoop", "primtype", "with"] + -- Due to lack of proper lexing facilities, a hack to zap any -- leading comments pTop :: Parser Info @@ -614,7 +666,7 @@ pTop = then4 (\_ ds es _ -> Info ds es) pEntry :: Parser Entry pEntry - = alts [pPrimOpSpec, pSection] + = alts [pPrimOpSpec, pPrimTypeSpec, pPseudoOpSpec, pSection] pSection :: Parser Entry pSection = then3 (\_ n d -> Section {title = n, desc = d}) @@ -626,9 +678,9 @@ pDefaults = then2 sel22 (lit "defaults") (many pOption) pOption :: Parser Option pOption = alts [ - then3 (\nm eq ff -> OptionFalse nm) pName (lit "=") (lit "False"), - then3 (\nm eq tt -> OptionTrue nm) pName (lit "=") (lit "True"), - then3 (\nm eq zz -> OptionString nm zz) + then3 (\nm _ _ -> OptionFalse nm) pName (lit "=") (lit "False"), + then3 (\nm _ _ -> OptionTrue nm) pName (lit "=") (lit "True"), + then3 (\nm _ zz -> OptionString nm zz) pName (lit "=") pStuffBetweenBraces ] @@ -639,6 +691,17 @@ pPrimOpSpec (lit "primop") pConstructor stringLiteral pCategory pType pDesc pOptions +pPrimTypeSpec :: Parser Entry +pPrimTypeSpec + = then4 (\_ t d o -> PrimTypeSpec { ty = t, desc = d, opts = o } ) + (lit "primtype") pType pDesc pOptions + +pPseudoOpSpec :: Parser Entry +pPseudoOpSpec + = then5 (\_ n t d o -> PseudoOpSpec { name = n, ty = t, desc = d, + opts = o } ) + (lit "pseudoop") stringLiteral pType pDesc pOptions + pOptions :: Parser [Option] pOptions = optdef [] (then2 sel22 (lit "with") (many pOption)) @@ -672,8 +735,6 @@ pInsides (do c <- satisfy (/= '}') return [c]) - - ------------------- -- Parsing types -- ------------------- @@ -686,6 +747,7 @@ pType = then2 (\t maybe_tt -> case maybe_tt of (opt (then2 sel22 (lit "->") pType)) -- Atomic types +paT :: Parser Ty paT = alts [ then2 TyApp pTycon (many ppT), pUnboxedTupleTy, then3 sel23 (lit "(") pType (lit ")"), @@ -693,6 +755,7 @@ paT = alts [ then2 TyApp pTycon (many ppT), ] -- the magic bit in the middle is: T (,T)* so to speak +pUnboxedTupleTy :: Parser Ty pUnboxedTupleTy = then3 (\ _ ts _ -> TyUTup ts) (lit "(#") @@ -700,18 +763,30 @@ pUnboxedTupleTy (lit "#)") -- Primitive types +ppT :: Parser Ty ppT = alts [apply TyVar pTyvar, apply (\tc -> TyApp tc []) pTycon ] -pTyvar = sat (`notElem` ["section","primop","with"]) pName +pTyvar :: Parser String +pTyvar = sat (`notElem` keywords) pName + +pTycon :: Parser String pTycon = alts [pConstructor, lexeme (string "()")] + +pName :: Parser String pName = lexeme (then2 (:) lower (many isIdChar)) + +pConstructor :: Parser String pConstructor = lexeme (then2 (:) upper (many isIdChar)) +isIdChar :: Parser Char isIdChar = satisfy (`elem` idChars) + +idChars :: [Char] idChars = ['a' .. 'z'] ++ ['A' .. 'Z'] ++ ['0' .. '9'] ++ "#_" +sat :: (a -> Bool) -> Parser a -> Parser a sat pred p = do x <- try p if pred x @@ -722,32 +797,55 @@ sat pred p -- Helpful additions to Daan's parser stuff ---------------------- ------------------------------------------------------------------ +alts :: [Parser a] -> Parser a alts [p1] = try p1 alts (p1:p2:ps) = (try p1) <|> alts (p2:ps) +then2 :: (a -> b -> c) -> Parser a -> Parser b -> Parser c then2 f p1 p2 = do x1 <- p1 ; x2 <- p2 ; return (f x1 x2) + +then3 :: (a -> b -> c -> d) -> Parser a -> Parser b -> Parser c -> Parser d then3 f p1 p2 p3 = do x1 <- p1 ; x2 <- p2 ; x3 <- p3 ; return (f x1 x2 x3) + +then4 :: (a -> b -> c -> d -> e) -> Parser a -> Parser b -> Parser c -> Parser d -> Parser e then4 f p1 p2 p3 p4 = do x1 <- p1 ; x2 <- p2 ; x3 <- p3 ; x4 <- p4 ; return (f x1 x2 x3 x4) + +then5 :: (a -> b -> c -> d -> e -> f) -> Parser a -> Parser b -> Parser c -> Parser d -> Parser e -> Parser f then5 f p1 p2 p3 p4 p5 = do x1 <- p1 ; x2 <- p2 ; x3 <- p3 ; x4 <- p4 ; x5 <- p5 return (f x1 x2 x3 x4 x5) + +then6 :: (a -> b -> c -> d -> e -> f -> g) -> Parser a -> Parser b -> Parser c -> Parser d -> Parser e -> Parser f -> Parser g then6 f p1 p2 p3 p4 p5 p6 = do x1 <- p1 ; x2 <- p2 ; x3 <- p3 ; x4 <- p4 ; x5 <- p5 ; x6 <- p6 return (f x1 x2 x3 x4 x5 x6) + +then7 :: (a -> b -> c -> d -> e -> f -> g -> h) -> Parser a -> Parser b -> Parser c -> Parser d -> Parser e -> Parser f -> Parser g -> Parser h then7 f p1 p2 p3 p4 p5 p6 p7 = do x1 <- p1 ; x2 <- p2 ; x3 <- p3 ; x4 <- p4 ; x5 <- p5 ; x6 <- p6 ; x7 <- p7 return (f x1 x2 x3 x4 x5 x6 x7) + +opt :: Parser a -> Parser (Maybe a) opt p = (do x <- p; return (Just x)) <|> return Nothing + +optdef :: a -> Parser a -> Parser a optdef d p = (do x <- p; return x) <|> return d -sel12 a b = a -sel22 a b = b -sel23 a b c = b +sel12 :: a -> b -> a +sel12 a _ = a + +sel22 :: a -> b -> b +sel22 _ b = b + +sel23 :: a -> b -> c -> b +sel23 _ b _ = b + +apply :: (a -> b) -> Parser a -> Parser b apply f p = liftM f p -- Hacks for zapping whitespace and comments, unfortunately needed @@ -777,11 +875,6 @@ stringLiteral = lexeme ( } "literal string") - - ------------------------------------------------------------------ -- end -- ------------------------------------------------------------------ - - -