-
+{-# OPTIONS -cpp #-}
------------------------------------------------------------------
-- A primop-table mangling program --
------------------------------------------------------------------
module Main where
+#if __GLASGOW_HASKELL__ >= 504
+import Text.ParserCombinators.Parsec
+#else
import Parsec
+#endif
+
import Monad
import Char
import List
latex_encode (c:cs) = c:(latex_encode cs)
gen_wrappers (Info defaults entries)
- = "module PrelPrimopWrappers where\n"
- ++ "import qualified PrelGHC\n"
+ = "{-# 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.
+ ++ "module GHC.PrimopWrappers where\n"
+ ++ "import qualified GHC.Prim\n"
++ unlines (map f (filter (not.dodgy) (filter is_primop entries)))
where
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
- ++ " = (PrelGHC." ++ name spec ++ ") " ++ unwords args
+ ++ " = (GHC.Prim." ++ name spec ++ ") " ++ unwords args
wrap nm | isLower (head nm) = nm
| otherwise = "(" ++ nm ++ ")"
++ listify (map ppType argTys) ++ " "
++ "(" ++ ppType resTy ++ ")"
-sl_name i = "SLIT(\"" ++ name i ++ "\") "
+sl_name i = "FSLIT(\"" ++ name i ++ "\") "
ppTyVar "a" = "alphaTyVar"
ppTyVar "b" = "betaTyVar"
ppType (TyApp "ThreadId#" []) = "threadIdPrimTy"
ppType (TyApp "ForeignObj#" []) = "foreignObjPrimTy"
ppType (TyApp "BCO#" []) = "bcoPrimTy"
-ppType (TyApp "Unit" []) = "unitTy" -- dodgy
+ppType (TyApp "()" []) = "unitTy" -- unitTy is TysWiredIn's name for ()
ppType (TyVar "a") = "alphaTy"
]
pTyvar = sat (`notElem` ["section","primop","with"]) pName
-pTycon = pConstructor
+pTycon = alts [pConstructor, lexeme (string "()")]
pName = lexeme (then2 (:) lower (many isIdChar))
pConstructor = lexeme (then2 (:) upper (many isIdChar))