From ef7cf7b03cbb7174bcd8cc52c4a780999ad9c935 Mon Sep 17 00:00:00 2001 From: sewardj Date: Mon, 7 Aug 2000 14:15:43 +0000 Subject: [PATCH] [project @ 2000-08-07 14:15:43 by sewardj] This is the program which generates bits of primop-related Haskell (and, soon, C) code from ghc/compiler/prelude/primops.txt. --- ghc/utils/Makefile | 3 +- ghc/utils/genprimopcode/Main.hs | 514 ++++++++++++++++++++++++++++++++++++++ ghc/utils/genprimopcode/Makefile | 19 ++ 3 files changed, 535 insertions(+), 1 deletion(-) create mode 100644 ghc/utils/genprimopcode/Main.hs create mode 100644 ghc/utils/genprimopcode/Makefile diff --git a/ghc/utils/Makefile b/ghc/utils/Makefile index 124976b..7d2f25c 100644 --- a/ghc/utils/Makefile +++ b/ghc/utils/Makefile @@ -9,7 +9,8 @@ SUBDIRS = hp2ps \ parallel \ stat2resid \ prof \ - unlit + unlit \ + genprimopcode endif # hstags died when the new parser was introduced. diff --git a/ghc/utils/genprimopcode/Main.hs b/ghc/utils/genprimopcode/Main.hs new file mode 100644 index 0000000..fce372e --- /dev/null +++ b/ghc/utils/genprimopcode/Main.hs @@ -0,0 +1,514 @@ + +------------------------------------------------------------------ +-- A primop-table mangling program -- +------------------------------------------------------------------ + +module Main where + +import Parsec +import Monad +import Char +import List +import System ( getArgs ) +import Maybe ( catMaybes ) + +main = getArgs >>= \args -> + if length args /= 1 || head args `notElem` known_args + then error ("usage: genprimopcode command < primops.txt > ...\n" + ++ " where command is one of\n" + ++ unlines (map (" "++) known_args) + ) + else + do s <- getContents + let pres = parse pTop "" s + case pres of + Left err -> do putStr "parse error at " + print err + Right p_o_specs + -> myseq (sanityTop p_o_specs) ( + case head args of + + "--data-decl" + -> putStr (gen_data_decl p_o_specs) + + "--has-side-effects" + -> putStr (gen_switch_from_attribs + "has_side_effects" + "primOpHasSideEffects" p_o_specs) + + "--out-of-line" + -> putStr (gen_switch_from_attribs + "out_of_line" + "primOpOutOfLine" p_o_specs) + + "--commutable" + -> putStr (gen_switch_from_attribs + "commutable" + "commutableOp" p_o_specs) + + "--needs-wrapper" + -> putStr (gen_switch_from_attribs + "needs_wrapper" + "primOpNeedsWrapper" p_o_specs) + + "--can-fail" + -> putStr (gen_switch_from_attribs + "can_fail" + "primOpCanFail" p_o_specs) + + "--strictness" + -> putStr (gen_switch_from_attribs + "strictness" + "primOpStrictness" p_o_specs) + + "--usage" + -> putStr (gen_switch_from_attribs + "usage" + "primOpUsg" p_o_specs) + + "--primop-primop-info" + -> putStr (gen_primop_info p_o_specs) + + "--primop-tag" + -> putStr (gen_primop_tag p_o_specs) + + "--primop-list" + -> putStr (gen_primop_list p_o_specs) + + "--c-bytecode-enum" + -> putStr (gen_enum_decl p_o_specs) + + ) + + +known_args + = [ "--data-decl", + "--has-side-effects", + "--out-of-line", + "--commutable", + "--needs-wrapper", + "--can-fail", + "--strictness", + "--usage", + "--primop-primop-info", + "--primop-tag", + "--primop-list", + + "--c-bytecode-enum" + ] + +------------------------------------------------------------------ +-- Code generators ----------------------------------------------- +------------------------------------------------------------------ + +gen_primop_list (Info defaults pos) + = unlines ( + [ " [" ++ cons (head pos) ] + ++ + map (\pi -> " , " ++ cons pi) (tail pos) + ++ + [ " ]" ] + ) + +gen_primop_tag (Info defaults pos) + = unlines (zipWith f pos [1..]) + where + f i n = "tagOf_PrimOp " ++ cons i + ++ " = ILIT(" ++ show n ++ ") :: FAST_INT" + +gen_enum_decl (Info defaults pos) + = let conss = map cons pos + in "enum PrimOp {\n " ++ head conss ++ "\n" + ++ unlines (map (" , "++) (tail conss)) ++ "};\n" + +gen_data_decl (Info defaults pos) + = let conss = map cons pos + in "data PrimOp\n = " ++ head conss ++ "\n" + ++ unlines (map (" | "++) (tail conss)) + +gen_switch_from_attribs :: String -> String -> Info -> String +gen_switch_from_attribs attrib_name fn_name (Info defaults pos) + = let defv = lookup_attrib attrib_name defaults + alts = catMaybes (map mkAlt pos) + + getAltRhs (OptionFalse _) = "False" + getAltRhs (OptionTrue _) = "True" + getAltRhs (OptionString _ s) = s + + mkAlt po + = case lookup_attrib attrib_name (opts po) of + Nothing -> Nothing + Just xx -> Just (fn_name ++ " " ++ cons po ++ " = " ++ getAltRhs xx) + + lookup_attrib nm [] = Nothing + lookup_attrib nm (a:as) + = if get_attrib_name a == nm then Just a else lookup_attrib nm as + in + case defv of + Nothing -> error ("gen_switch_from: " ++ attrib_name) + Just xx + -> unlines alts + ++ fn_name ++ " other = " ++ getAltRhs xx ++ "\n" + +------------------------------------------------------------------ +-- Create PrimOpInfo text from PrimOpSpecs ----------------------- +------------------------------------------------------------------ + + +gen_primop_info (Info defaults pos) + = unlines (map mkPOItext pos) + +mkPOItext i = mkPOI_LHS_text i ++ mkPOI_RHS_text i + +mkPOI_LHS_text i + = "primOpInfo " ++ cons i ++ " = " + +mkPOI_RHS_text i + = case cat i of + Compare + -> case ty i of + TyF t1 (TyF t2 td) + -> "mkCompare " ++ sl_name i ++ ppType t1 + Monadic + -> case ty i of + TyF t1 td + -> "mkMonadic " ++ sl_name i ++ ppType t1 + Dyadic + -> case ty i of + TyF t1 (TyF t2 td) + -> "mkDyadic " ++ sl_name i ++ ppType t1 + GenPrimOp + -> let (argTys, resTy) = flatTys (ty i) + tvs = nub (tvsIn (ty i)) + in + "mkGenPrimOp " ++ sl_name i ++ " " + ++ listify (map ppTyVar tvs) ++ " " + ++ listify (map ppType argTys) ++ " " + ++ "(" ++ ppType resTy ++ ")" + +sl_name i = "SLIT(\"" ++ name i ++ "\") " + +ppTyVar "a" = "alphaTyVar" +ppTyVar "b" = "betaTyVar" +ppTyVar "c" = "gammaTyVar" +ppTyVar "s" = "deltaTyVar" +ppTyVar "o" = "openAlphaTyVar" + + +ppType (TyApp "Bool" []) = "boolTy" + +ppType (TyApp "Int#" []) = "intPrimTy" +ppType (TyApp "Int64#" []) = "int64PrimTy" +ppType (TyApp "Char#" []) = "charPrimTy" +ppType (TyApp "Word#" []) = "wordPrimTy" +ppType (TyApp "Word64#" []) = "word64PrimTy" +ppType (TyApp "Addr#" []) = "addrPrimTy" +ppType (TyApp "Float#" []) = "floatPrimTy" +ppType (TyApp "Double#" []) = "doublePrimTy" +ppType (TyApp "ByteArr#" []) = "byteArrayPrimTy" +ppType (TyApp "RealWorld" []) = "realWorldTy" +ppType (TyApp "ThreadId#" []) = "threadIdPrimTy" +ppType (TyApp "ForeignObj#" []) = "foreignObjPrimTy" +ppType (TyApp "BCO#" []) = "bcoPrimTy" +ppType (TyApp "Unit" []) = "unitTy" -- dodgy + + +ppType (TyVar "a") = "alphaTy" +ppType (TyVar "b") = "betaTy" +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 "MutArr#" [x,y]) = "mkMutableArrayPrimTy " ++ ppType x + ++ " " ++ ppType y + +ppType (TyApp "MutByteArr#" [x]) = "mkMutableByteArrayPrimTy " + ++ ppType x + +ppType (TyApp "Array#" [x]) = "mkArrayPrimTy " ++ ppType x + + +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 (TyUTup ts) = "(mkTupleTy Unboxed " ++ show (length ts) + ++ " " + ++ listify (map ppType ts) ++ ")" + +ppType (TyF s d) = "(mkFunTy (" ++ ppType s ++ ") (" ++ ppType d ++ "))" + +ppType other + = error ("ppType: can't handle: " ++ show other ++ "\n") + +listify :: [String] -> String +listify ss = "[" ++ concat (intersperse ", " ss) ++ "]" + +flatTys (TyF t1 t2) = case flatTys t2 of (ts,t) -> (t1:ts,t) +flatTys other = ([],other) + +tvsIn (TyF t1 t2) = tvsIn t1 ++ tvsIn t2 +tvsIn (TyApp tc tys) = concatMap tvsIn tys +tvsIn (TyVar tv) = [tv] +tvsIn (TyUTup tys) = concatMap tvsIn tys + + +------------------------------------------------------------------ +-- Abstract syntax ----------------------------------------------- +------------------------------------------------------------------ + +-- info for all primops; the totality of the info in primops.txt +data Info + = Info [Option] [PrimOpSpec] -- defaults, primops + deriving Show + +-- info for one primop +data PrimOpSpec + = PrimOpSpec { cons :: String, -- PrimOp name + name :: String, -- name in prog text + ty :: Ty, -- type + cat :: Category, -- category + opts :: [Option] } -- default overrides + deriving Show + +-- a binding of property to value +data Option + = OptionFalse String -- name = False + | OptionTrue String -- name = True + | OptionString String String -- name = { ... unparsed stuff ... } + deriving Show + +-- categorises primops +data Category + = Dyadic | Monadic | Compare | GenPrimOp + deriving Show + +-- types +data Ty + = TyF Ty Ty + | TyApp TyCon [Ty] + | TyVar TyVar + | TyUTup [Ty] -- unboxed tuples; just a TyCon really, + -- but convenient like this + deriving (Eq,Show) + +type TyVar = String +type TyCon = String + + +------------------------------------------------------------------ +-- Sanity checking ----------------------------------------------- +------------------------------------------------------------------ + +{- Do some simple sanity checks: + * all the default field names are unique + * for each PrimOpSpec, all override field names are unique + * for each PrimOpSpec, all overriden field names + have a corresponding default value + * that primop types correspond in certain ways to the + Category: eg if Comparison, the type must be of the form + T -> T -> Bool. + Dies with "error" if there's a problem, else returns (). +-} +myseq () x = x +myseqAll (():ys) x = myseqAll ys x +myseqAll [] x = x + +sanityTop :: Info -> () +sanityTop (Info defs primops) + = let opt_names = map get_attrib_name defs + in + if length opt_names /= length (nub opt_names) + then error ("non-unique default attribute names: " ++ show opt_names ++ "\n") + else myseqAll (map (sanityPrimOp opt_names) primops) () + +sanityPrimOp def_names p + = let p_names = map get_attrib_name (opts p) + p_names_ok + = length p_names == length (nub p_names) + && all (`elem` def_names) p_names + ty_ok = sane_ty (cat p) (ty p) + in + if not p_names_ok + then error ("attribute names are non-unique or have no default in\n" ++ + "info for primop " ++ cons p ++ "\n") + else + if not ty_ok + then error ("type of primop " ++ cons p ++ " doesn't make sense w.r.t" ++ + " category " ++ show (cat p) ++ "\n") + else () + +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)) + | t1 == t2 && t2 == t2 = True +sane_ty GenPrimOp any_old_thing + = True +sane_ty _ _ + = False + +get_attrib_name (OptionFalse nm) = nm +get_attrib_name (OptionTrue nm) = nm +get_attrib_name (OptionString nm _) = nm + +------------------------------------------------------------------ +-- The parser ---------------------------------------------------- +------------------------------------------------------------------ + +-- Due to lack of proper lexing facilities, a hack to zap any +-- leading comments +pTop :: Parser Info +pTop = then4 (\_ ds ss _ -> Info ds ss) + pCommentAndWhitespace pDefaults (many pPrimOpSpec) + (lit "thats_all_folks") + +pDefaults :: Parser [Option] +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) + pName (lit "=") pStuffBetweenBraces + ] + +pPrimOpSpec :: Parser PrimOpSpec +pPrimOpSpec + = then6 (\_ c n k t o -> PrimOpSpec { cons = c, name = n, ty = t, + cat = k, opts = o } ) + (lit "primop") pConstructor stringLiteral + pCategory pType pOptions + +pOptions :: Parser [Option] +pOptions = optdef [] (then2 sel22 (lit "with") (many pOption)) + +pCategory :: Parser Category +pCategory + = alts [ + apply (const Dyadic) (lit "Dyadic"), + apply (const Monadic) (lit "Monadic"), + apply (const Compare) (lit "Compare"), + apply (const GenPrimOp) (lit "GenPrimOp") + ] + +pStuffBetweenBraces + = lexeme (then3 sel23 + (char '{') (many (satisfy (not . (== '}')))) + (char '}')) + +------------------- +-- Parsing types -- +------------------- + +pType :: Parser Ty +pType = then2 (\t maybe_tt -> case maybe_tt of + Just tt -> TyF t tt + Nothing -> t) + paT + (opt (then2 sel22 (lit "->") pType)) + +-- Atomic types +paT = alts [ then2 TyApp pTycon (many ppT), + pUnboxedTupleTy, + then3 sel23 (lit "(") pType (lit ")"), + ppT + ] + +-- the magic bit in the middle is: T (,T)* so to speak +pUnboxedTupleTy + = then3 (\ _ ts _ -> TyUTup ts) + (lit "(#") + (then2 (:) pType (many (then2 sel22 (lit ",") pType))) + (lit "#)") + +-- Primitive types +ppT = alts [apply TyVar pTyvar, + apply (\tc -> TyApp tc []) pTycon + ] + +pTyvar = sat (`notElem` ["primop","with"]) pName +pTycon = pConstructor +pName = lexeme (then2 (:) lower (many isIdChar)) +pConstructor = lexeme (then2 (:) upper (many isIdChar)) + +isIdChar = satisfy (`elem` idChars) +idChars = ['a' .. 'z'] ++ ['A' .. 'Z'] ++ ['0' .. '9'] ++ "#_" + +sat pred p + = do x <- try p + if pred x + then return x + else pzero + +------------------------------------------------------------------ +-- Helpful additions to Daan's parser stuff ---------------------- +------------------------------------------------------------------ + +alts [p1] = try p1 +alts (p1:p2:ps) = (try p1) <|> alts (p2:ps) + +then2 f p1 p2 + = do x1 <- p1 ; x2 <- p2 ; return (f x1 x2) +then3 f p1 p2 p3 + = do x1 <- p1 ; x2 <- p2 ; x3 <- p3 ; return (f x1 x2 x3) +then4 f p1 p2 p3 p4 + = do x1 <- p1 ; x2 <- p2 ; x3 <- p3 ; x4 <- p4 ; return (f x1 x2 x3 x4) +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 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) +opt p + = (do x <- p; return (Just x)) <|> return Nothing +optdef d p + = (do x <- p; return x) <|> return d + +sel12 a b = a +sel22 a b = b +sel23 a b c = b +apply = liftM + +-- Hacks for zapping whitespace and comments, unfortunately needed +-- because Daan won't let us have a lexer before the parser :-( +lexeme :: Parser p -> Parser p +lexeme p = then2 sel12 p pCommentAndWhitespace + +lit :: String -> Parser () +lit s = apply (const ()) (lexeme (string s)) + +pCommentAndWhitespace :: Parser () +pCommentAndWhitespace + = apply (const ()) (many (alts [pLineComment, + apply (const ()) (satisfy isSpace)])) + <|> + return () + +pLineComment :: Parser () +pLineComment + = try (then3 (\_ _ _ -> ()) (string "--") (many (satisfy (/= '\n'))) (char '\n')) + +stringLiteral :: Parser String +stringLiteral = lexeme ( + do { between (char '"') + (char '"' "end of string") + (many (noneOf "\"")) + } + "literal string") + + + +------------------------------------------------------------------ +-- end -- +------------------------------------------------------------------ + + + diff --git a/ghc/utils/genprimopcode/Makefile b/ghc/utils/genprimopcode/Makefile new file mode 100644 index 0000000..50c363b --- /dev/null +++ b/ghc/utils/genprimopcode/Makefile @@ -0,0 +1,19 @@ +TOP=../.. +include $(TOP)/mk/boilerplate.mk + +INSTALL_PROGS += genprimopcode + +SRC_HC_OPTS += -syslib text +OBJS = Main.o + +CLEAN_FILES += genprimopcode + +all :: genprimopcode + +genprimopcode: Main.o + $(HC) -o $@ $(HC_OPTS) $(LD_OPTS) $(OBJS) + +CLEAN_FILES += genprimopcode +CLEAN_FILES += $(OBJS) + +include $(TOP)/mk/target.mk -- 1.7.10.4