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.

1 files changed, 94 insertions, 2 deletions

diff --git a/utils/genprimopcode/Main.hs b/utils/genprimopcode/Main.hs
index b96e9b4f41..8cfbed3d49 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{"