X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=utils%2Fgenprimopcode%2FMain.hs;h=14f08346be833127dd764184cc5aa39047e9c15a;hp=0e7c815f44d16b9e0b6b47a7f321bdea5827dc32;hb=b2524b3960999fffdb3767900f58825903f6560f;hpb=84bd33df44c6f52c5517405dd1bb968a7ccdd154 diff --git a/utils/genprimopcode/Main.hs b/utils/genprimopcode/Main.hs index 0e7c815..14f0834 100644 --- a/utils/genprimopcode/Main.hs +++ b/utils/genprimopcode/Main.hs @@ -8,11 +8,10 @@ module Main where import Parser import Syntax -import Monad -import Char -import List -import System ( getArgs ) -import Maybe ( catMaybes ) +import Data.Char +import Data.List +import Data.Maybe ( catMaybes ) +import System.Environment ( getArgs ) main :: IO () main = getArgs >>= \args -> @@ -25,7 +24,7 @@ main = getArgs >>= \args -> do s <- getContents case parse s of Left err -> error ("parse error at " ++ (show err)) - Right p_o_specs + Right p_o_specs@(Info _ entries) -> seq (sanityTop p_o_specs) ( case head args of @@ -47,13 +46,13 @@ main = getArgs >>= \args -> "commutable" "commutableOp" p_o_specs) - "--needs-wrapper" + "--code-size" -> putStr (gen_switch_from_attribs - "needs_wrapper" - "primOpNeedsWrapper" p_o_specs) + "code_size" + "primOpCodeSize" p_o_specs) - "--can-fail" - -> putStr (gen_switch_from_attribs + "--can-fail" + -> putStr (gen_switch_from_attribs "can_fail" "primOpCanFail" p_o_specs) @@ -77,6 +76,9 @@ main = getArgs >>= \args -> "--make-haskell-source" -> putStr (gen_hs_source p_o_specs) + "--make-ext-core-source" + -> putStr (gen_ext_core_source entries) + "--make-latex-doc" -> putStr (gen_latex_doc p_o_specs) @@ -89,7 +91,7 @@ known_args "--has-side-effects", "--out-of-line", "--commutable", - "--needs-wrapper", + "--code-size", "--can-fail", "--strictness", "--primop-primop-info", @@ -97,6 +99,7 @@ known_args "--primop-list", "--make-haskell-wrappers", "--make-haskell-source", + "--make-ext-core-source", "--make-latex-doc" ] @@ -106,25 +109,39 @@ known_args gen_hs_source :: Info -> String gen_hs_source (Info defaults entries) = - "-----------------------------------------------------------------------------\n" + "{-\n" + ++ "This is a generated file (generated by genprimopcode).\n" + ++ "It is not code to actually be used. Its only purpose is to be\n" + ++ "consumed by haddock.\n" + ++ "-}\n" + ++ "\n" + ++ "-----------------------------------------------------------------------------\n" ++ "-- |\n" - ++ "-- Module : GHC.Arr\n" + ++ "-- Module : GHC.Prim\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" + ++ "-- Use GHC.Exts from the base package instead of importing this\n" + ++ "-- module directly.\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\n" + ++ "\n" + ++ "import GHC.Types\n" + ++ "\n" + ++ "{-\n" + ++ unlines (map opt defaults) + ++ "-}\n" + ++ unlines (concatMap ent entries) ++ "\n\n\n" where opt (OptionFalse n) = n ++ " = False" opt (OptionTrue n) = n ++ " = True" opt (OptionString n v) = n ++ " = { " ++ v ++ "}" + opt (OptionInteger n v) = n ++ " = " ++ show v hdr s@(Section {}) = sec s hdr (PrimOpSpec { name = n }) = wrapOp n ++ "," @@ -132,7 +149,7 @@ gen_hs_source (Info defaults entries) = hdr (PrimTypeSpec { ty = TyApp n _ }) = wrapTy n ++ "," hdr (PrimTypeSpec {}) = error "Illegal type spec" - ent (Section {}) = "" + ent (Section {}) = [] ent o@(PrimOpSpec {}) = spec o ent o@(PrimTypeSpec {}) = spec o ent o@(PseudoOpSpec {}) = spec o @@ -140,27 +157,22 @@ gen_hs_source (Info defaults entries) = sec s = "\n-- * " ++ escape (title s) ++ "\n" ++ (unlines $ map ("-- " ++ ) $ lines $ unlatex $ escape $ "|" ++ desc s) ++ "\n" - spec o = comm ++ decl - 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 - Section { } -> "" + spec o = comm : decls + where decls = case o of + PrimOpSpec { name = n, ty = t } -> + [ 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" ] + PrimTypeSpec { ty = t } -> + [ "data " ++ pprTy t ] + Section { } -> [] 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 - - pbty (TyApp tc ts) = tc ++ (concat (map (' ':) (map paty ts))) - pbty (TyUTup ts) = "(# " ++ (concat (intersperse "," (map pty ts))) ++ " #)" - pbty t = paty t - - paty (TyVar tv) = tv - paty t = "(" ++ pty t ++ ")" - wrapOp nm | isAlpha (head nm) = nm | otherwise = "(" ++ nm ++ ")" wrapTy nm | isAlpha (head nm) = nm @@ -179,6 +191,138 @@ gen_hs_source (Info defaults entries) = escape = concatMap (\c -> if c `elem` special then '\\':c:[] else c:[]) where special = "/'`\"@<" +pprTy :: Ty -> String +pprTy = pty + where + pty (TyF t1 t2) = pbty t1 ++ " -> " ++ pty t2 + 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 + + paty (TyVar tv) = tv + paty t = "(" ++ pty t ++ ")" +-- +-- Generates the type environment that the stand-alone External Core tools use. +gen_ext_core_source :: [Entry] -> String +gen_ext_core_source entries = + "-----------------------------------------------------------------------\n" + ++ "-- This module is automatically generated by the GHC utility\n" + ++ "-- \"genprimopcode\". Do not edit!\n" + ++ "-----------------------------------------------------------------------\n" + ++ "module Language.Core.PrimEnv(primTcs, primVals, intLitTypes, ratLitTypes," + ++ "\n charLitTypes, stringLitTypes) where\nimport Language.Core.Core" + ++ "\nimport Language.Core.Encoding\n\n" + ++ "primTcs :: [(Tcon, Kind)]\n" + ++ "primTcs = [\n" + ++ printList tcEnt entries + ++ " ]\n" + ++ "primVals :: [(Var, Ty)]\n" + ++ "primVals = [\n" + ++ printList valEnt entries + ++ "]\n" + ++ "intLitTypes :: [Ty]\n" + ++ "intLitTypes = [\n" + ++ printList tyEnt (intLitTys entries) + ++ "]\n" + ++ "ratLitTypes :: [Ty]\n" + ++ "ratLitTypes = [\n" + ++ printList tyEnt (ratLitTys entries) + ++ "]\n" + ++ "charLitTypes :: [Ty]\n" + ++ "charLitTypes = [\n" + ++ printList tyEnt (charLitTys entries) + ++ "]\n" + ++ "stringLitTypes :: [Ty]\n" + ++ "stringLitTypes = [\n" + ++ printList tyEnt (stringLitTys entries) + ++ "]\n\n" + + 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) + _ -> error ("tcEnt: type in PrimTypeSpec is not a type" + ++ " constructor: " ++ show t) + tcEnt _ = "" + -- hack alert! + -- The primops.txt.pp format doesn't have enough information in it to + -- print out some of the information that ext-core needs (like kinds, + -- and later on in this code, module names) so we special-case. An + -- 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" + -- assumes that all type arguments are lifted (are they?) + 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 _ = "" + valEntry name' ty' = parens name' (mkForallTy (freeTvars ty') (pty ty')) + where pty (TyF t1 t2) = mkFunTy (pty t1) (pty t2) + pty (TyApp tc ts) = mkTconApp (mkTcon tc) (map pty ts) + pty (TyUTup ts) = mkUtupleTy (map pty ts) + pty (TyVar tv) = paren $ "Tvar \"" ++ tv ++ "\"" + + mkFunTy s1 s2 = "Tapp " ++ (paren ("Tapp (Tcon tcArrow)" + ++ " " ++ paren s1)) + ++ " " ++ paren s2 + mkTconApp tc args = foldl tapp tc args + mkTcon tc = paren $ "Tcon " ++ paren (qualify True tc) + mkUtupleTy args = foldl tapp (tcUTuple (length args)) args + mkForallTy [] t = t + mkForallTy vs t = foldr + (\ v s -> "Tforall " ++ + (paren (quote v ++ ", " ++ vKind v)) ++ " " + ++ paren s) t vs + + -- hack alert! + vKind "o" = "Kopen" + vKind _ = "Klifted" + + freeTvars (TyF t1 t2) = freeTvars t1 `union` freeTvars t2 + freeTvars (TyApp _ tys) = freeTvarss tys + freeTvars (TyVar v) = [v] + freeTvars (TyUTup tys) = freeTvarss tys + freeTvarss = nub . concatMap freeTvars + + tapp s nextArg = paren $ "Tapp " ++ s ++ " " ++ paren nextArg + tcUTuple n = paren $ "Tcon " ++ paren (qualify False $ "Z" + ++ show n ++ "H") + + tyEnt (PrimTypeSpec {ty=(TyApp tc _args)}) = " " ++ paren ("Tcon " ++ + (paren (qualify True tc))) + tyEnt _ = "" + + -- more hacks. might be better to do this on the ext-core side, + -- as per earlier comment + qualify _ tc | tc == "Bool" = "Just boolMname" ++ ", " + ++ ze True tc + qualify _ tc | tc == "()" = "Just baseMname" ++ ", " + ++ ze True tc + qualify enc tc = "Just primMname" ++ ", " ++ (ze enc tc) + ze enc tc = (if enc then "zEncodeString " else "") + ++ "\"" ++ tc ++ "\"" + + intLitTys = prefixes ["Int", "Word", "Addr", "Char"] + ratLitTys = prefixes ["Float", "Double"] + charLitTys = prefixes ["Char"] + stringLitTys = prefixes ["Addr"] + prefixes ps = filter (\ t -> + case t of + (PrimTypeSpec {ty=(TyApp tc _args)}) -> + any (\ p -> p `isPrefixOf` tc) ps + _ -> False) + + parens n ty' = " (zEncodeString \"" ++ n ++ "\", " ++ ty' ++ ")" + paren s = "(" ++ s ++ ")" + quote s = "\"" ++ s ++ "\"" + gen_latex_doc :: Info -> String gen_latex_doc (Info defaults entries) = "\\primopdefaults{" @@ -266,7 +410,8 @@ gen_latex_doc (Info defaults entries) Just (OptionTrue _) -> if_true Just (OptionFalse _) -> if_false Just (OptionString _ _) -> error "String value for boolean option" - Nothing -> "" + Just (OptionInteger _ _) -> error "Integer value for boolean option" + Nothing -> "" mk_strictness o = case lookup_attrib "strictness" o of @@ -339,18 +484,27 @@ gen_latex_doc (Info defaults entries) gen_wrappers :: Info -> String gen_wrappers (Info _ entries) - = "{-# OPTIONS -fno-implicit-prelude #-}\n" + = "{-# LANGUAGE NoImplicitPrelude, UnboxedTuples #-}\n" -- Dependencies on Prelude must be explicit in libraries/base, but we - -- don't need the Prelude here so we add -fno-implicit-prelude. + -- don't need the Prelude here so we add NoImplicitPrelude. ++ "module GHC.PrimopWrappers where\n" ++ "import qualified GHC.Prim\n" - ++ unlines (map f (filter (not.dodgy) (filter is_primop entries))) + ++ "import GHC.Types (Bool)\n" + ++ "import GHC.Unit ()\n" + ++ "import GHC.Prim (" ++ types ++ ")\n" + ++ unlines (concatMap f specs) where + specs = filter (not.dodgy) (filter is_primop entries) + tycons = foldr union [] $ map (tyconsIn . ty) specs + tycons' = filter (`notElem` ["()", "Bool"]) tycons + types = concat $ intersperse ", " tycons' f spec = let args = map (\n -> "a" ++ show n) [1 .. arity (ty spec)] src_name = wrap (name spec) - in "{-# NOINLINE " ++ src_name ++ " #-}\n" ++ - src_name ++ " " ++ unwords args - ++ " = (GHC.Prim." ++ name spec ++ ") " ++ unwords args + lhs = src_name ++ " " ++ unwords args + rhs = "(GHC.Prim." ++ name spec ++ ") " ++ unwords args + in ["{-# NOINLINE " ++ src_name ++ " #-}", + src_name ++ " :: " ++ pprTy (ty spec), + lhs ++ " = " ++ rhs] wrap nm | isLower (head nm) = nm | otherwise = "(" ++ nm ++ ")" @@ -376,12 +530,14 @@ gen_primop_list (Info _ entries) gen_primop_tag :: Info -> String gen_primop_tag (Info _ entries) - = unlines (max_def : zipWith f primop_entries [1 :: Int ..]) + = unlines (max_def_type : max_def : + tagOf_type : 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" + primop_entries = 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) @@ -396,6 +552,7 @@ gen_switch_from_attribs attrib_name fn_name (Info defaults entries) getAltRhs (OptionFalse _) = "False" getAltRhs (OptionTrue _) = "True" + getAltRhs (OptionInteger _ i) = show i getAltRhs (OptionString _ s) = s mkAlt po @@ -408,7 +565,7 @@ gen_switch_from_attribs attrib_name fn_name (Info defaults entries) Nothing -> error ("gen_switch_from: " ++ attrib_name) Just xx -> unlines alternatives - ++ fn_name ++ " other = " ++ getAltRhs xx ++ "\n" + ++ fn_name ++ " _ = " ++ getAltRhs xx ++ "\n" ------------------------------------------------------------------ -- Create PrimOpInfo text from PrimOpSpecs ----------------------- @@ -453,7 +610,7 @@ mkPOI_RHS_text i ++ "(" ++ ppType resTy ++ ")" sl_name :: Entry -> String -sl_name i = "FSLIT(\"" ++ name i ++ "\") " +sl_name i = "(fsLit \"" ++ name i ++ "\") " ppTyVar :: String -> String ppTyVar "a" = "alphaTyVar" @@ -476,7 +633,7 @@ ppType (TyApp "Word64#" []) = "word64PrimTy" ppType (TyApp "Addr#" []) = "addrPrimTy" ppType (TyApp "Float#" []) = "floatPrimTy" ppType (TyApp "Double#" []) = "doublePrimTy" -ppType (TyApp "ByteArr#" []) = "byteArrayPrimTy" +ppType (TyApp "ByteArray#" []) = "byteArrayPrimTy" ppType (TyApp "RealWorld" []) = "realWorldTy" ppType (TyApp "ThreadId#" []) = "threadIdPrimTy" ppType (TyApp "ForeignObj#" []) = "foreignObjPrimTy" @@ -491,10 +648,10 @@ 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 "MutableArray#" [x,y]) = "mkMutableArrayPrimTy " ++ ppType x + ++ " " ++ ppType y -ppType (TyApp "MutByteArr#" [x]) = "mkMutableByteArrayPrimTy " +ppType (TyApp "MutableByteArray#" [x]) = "mkMutableByteArrayPrimTy " ++ ppType x ppType (TyApp "Array#" [x]) = "mkArrayPrimTy " ++ ppType x @@ -508,8 +665,7 @@ ppType (TyApp "MVar#" [x,y]) = "mkMVarPrimTy " ++ ppType x ++ " " ++ ppType y ppType (TyApp "TVar#" [x,y]) = "mkTVarPrimTy " ++ ppType x ++ " " ++ ppType y -ppType (TyUTup ts) = "(mkTupleTy Unboxed " ++ show (length ts) - ++ " " +ppType (TyUTup ts) = "(mkTupleTy Unboxed " ++ listify (map ppType ts) ++ ")" ppType (TyF s d) = "(mkFunTy (" ++ ppType s ++ ") (" ++ ppType d ++ "))" @@ -530,6 +686,12 @@ tvsIn (TyApp _ tys) = concatMap tvsIn tys tvsIn (TyVar tv) = [tv] tvsIn (TyUTup tys) = concatMap tvsIn tys +tyconsIn :: Ty -> [TyCon] +tyconsIn (TyF t1 t2) = tyconsIn t1 `union` tyconsIn t2 +tyconsIn (TyApp tc tys) = foldr union [tc] $ map tyconsIn tys +tyconsIn (TyVar _) = [] +tyconsIn (TyUTup tys) = foldr union [] $ map tyconsIn tys + arity :: Ty -> Int arity = length . fst . flatTys