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 ->
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
"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)
"--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)
"--has-side-effects",
"--out-of-line",
"--commutable",
- "--needs-wrapper",
+ "--code-size",
"--can-fail",
"--strictness",
"--primop-primop-info",
"--primop-list",
"--make-haskell-wrappers",
"--make-haskell-source",
+ "--make-ext-core-source",
"--make-latex-doc"
]
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 ++ ","
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
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
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{"
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
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 ++ ")"
getAltRhs (OptionFalse _) = "False"
getAltRhs (OptionTrue _) = "True"
+ getAltRhs (OptionInteger _ i) = show i
getAltRhs (OptionString _ s) = s
mkAlt po
++ "(" ++ ppType resTy ++ ")"
sl_name :: Entry -> String
-sl_name i = "FSLIT(\"" ++ name i ++ "\") "
+sl_name i = "(fsLit \"" ++ name i ++ "\") "
ppTyVar :: String -> String
ppTyVar "a" = "alphaTyVar"
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"
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
++ " " ++ 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 ++ "))"
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
projects / ghc-hetmet.git / blobdiff