From: Tim Chevalier Date: Thu, 10 Apr 2008 18:58:10 +0000 (+0000) Subject: Extend genprimopcode to print primop types for ext-core X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=07d1b116efe38566ef51286121da1fc60ef33b16 Extend genprimopcode to print primop types for ext-core I added a new flag, --make-ext-core-source, to genprimopcode. It prints out the type information for primops that the External Core typechecker needs. This replaces the old mechanism where the ext-core tools had a hard-wired Prims module that could get out of sync with the old primops.txt. Now, that won't happen. --- diff --git a/utils/genprimopcode/Main.hs b/utils/genprimopcode/Main.hs index b96e9b4..8cfbed3 100644 --- a/utils/genprimopcode/Main.hs +++ b/utils/genprimopcode/Main.hs @@ -25,7 +25,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 @@ -77,6 +77,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) @@ -97,6 +100,7 @@ known_args "--primop-list", "--make-haskell-wrappers", "--make-haskell-source", + "--make-ext-core-source", "--make-latex-doc" ] @@ -108,7 +112,7 @@ gen_hs_source :: Info -> String 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" @@ -179,6 +183,94 @@ gen_hs_source (Info defaults entries) = 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 PrimEnv(primTcs, primVals) where\nimport Core\nimport Encoding\n\n" + ++ "primTcs :: [(Tcon, Kind)]\n" + ++ "primTcs = [\n" + ++ printList tcEnt entries + ++ " ]\n" + ++ "primVals :: [(Var, Ty)]\n" + ++ "primVals = [\n" + ++ printList valEnt 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") + -- 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 ++ "\"" + + parens n ty = " (zEncodeString \"" ++ n ++ "\", " ++ ty ++ ")" + paren s = "(" ++ s ++ ")" + quot s = "\"" ++ s ++ "\"" + gen_latex_doc :: Info -> String gen_latex_doc (Info defaults entries) = "\\primopdefaults{"