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
"--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)
"--primop-list",
"--make-haskell-wrappers",
"--make-haskell-source",
+ "--make-ext-core-source",
"--make-latex-doc"
]
gen_hs_source (Info defaults entries) =
"-----------------------------------------------------------------------------\n"
++ "-- |\n"
- ++ "-- Module : GHC.Arr\n"
+ ++ "-- Module : GHC.Prim\n"
++ "-- \n"
++ "-- Maintainer : cvs-ghc@haskell.org\n"
++ "-- Stability : internal\n"
escape = concatMap (\c -> if c `elem` special then '\\':c:[] else c:[])
where special = "/'`\"@<"
+-- 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 tc [] | 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 (quot 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 == "ByteArr#" = qualify True "ByteArray#"
+ qualify _ tc | tc == "MutArr#" = qualify True "MutableArray#"
+ qualify _ tc | tc == "MutByteArr#" =
+ qualify True "MutableByteArray#"
+ 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 ++ ")"
+ quot s = "\"" ++ s ++ "\""
+
gen_latex_doc :: Info -> String
gen_latex_doc (Info defaults entries)
= "\\primopdefaults{"
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)
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 -----------------------
++ "(" ++ ppType resTy ++ ")"
sl_name :: Entry -> String
-sl_name i = "FSLIT(\"" ++ name i ++ "\") "
+sl_name i = "(fsLit \"" ++ name i ++ "\") "
ppTyVar :: String -> String
ppTyVar "a" = "alphaTyVar"
projects / ghc-hetmet.git / blobdiff