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 ->
"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)
"--has-side-effects",
"--out-of-line",
"--commutable",
- "--needs-wrapper",
+ "--code-size",
"--can-fail",
"--strictness",
"--primop-primop-info",
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.Prim\n"
++ "-- \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 ++ " :: " ++ pprTy t
- PseudoOpSpec { name = n, ty = t } -> wrapOp n ++ " :: " ++ pprTy t
- PrimTypeSpec { ty = t } -> "data " ++ pprTy 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
[] -> ""
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
-- ext-core's Prims module again.
tcKind "Any" _ = "Klifted"
tcKind tc [] | last tc == '#' = "Kunlifted"
- tcKind tc [] | otherwise = "Klifted"
+ 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 _ = ""
- valEntry name ty = parens name (mkForallTy (freeTvars ty) (pty ty))
+ 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)
mkForallTy [] t = t
mkForallTy vs t = foldr
(\ v s -> "Tforall " ++
- (paren (quot v ++ ", " ++ vKind v)) ++ " "
+ (paren (quote v ++ ", " ++ vKind v)) ++ " "
++ paren s) t vs
-- hack alert!
tcUTuple n = paren $ "Tcon " ++ paren (qualify False $ "Z"
++ show n ++ "H")
- tyEnt (PrimTypeSpec {ty=(TyApp tc args)}) = " " ++ paren ("Tcon " ++
+ tyEnt (PrimTypeSpec {ty=(TyApp tc _args)}) = " " ++ paren ("Tcon " ++
(paren (qualify True tc)))
tyEnt _ = ""
stringLitTys = prefixes ["Addr"]
prefixes ps = filter (\ t ->
case t of
- (PrimTypeSpec {ty=(TyApp tc args)}) ->
+ (PrimTypeSpec {ty=(TyApp tc _args)}) ->
any (\ p -> p `isPrefixOf` tc) ps
_ -> False)
- parens n ty = " (zEncodeString \"" ++ n ++ "\", " ++ ty ++ ")"
+ parens n ty' = " (zEncodeString \"" ++ n ++ "\", " ++ ty' ++ ")"
paren s = "(" ++ s ++ ")"
- quot s = "\"" ++ s ++ "\""
+ quote s = "\"" ++ s ++ "\""
gen_latex_doc :: Info -> String
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
-- don't need the Prelude here so we add NoImplicitPrelude.
++ "module GHC.PrimopWrappers where\n"
++ "import qualified GHC.Prim\n"
- ++ "import GHC.Bool (Bool)\n"
+ ++ "import GHC.Types (Bool)\n"
+ ++ "import GHC.Unit ()\n"
++ "import GHC.Prim (" ++ types ++ ")\n"
++ unlines (concatMap f specs)
where
getAltRhs (OptionFalse _) = "False"
getAltRhs (OptionTrue _) = "True"
+ getAltRhs (OptionInteger _ i) = show i
getAltRhs (OptionString _ s) = s
mkAlt po
++ " " ++ 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 ++ "))"
projects / ghc-hetmet.git / blobdiff