() is now in ghc-prim:GHC.Unit

[ghc-hetmet.git] / utils / genprimopcode / Main.hs

diff --git a/utils/genprimopcode/Main.hs b/utils/genprimopcode/Main.hs
index 54bdc8d..71b1e76 100644 (file)
--- a/utils/genprimopcode/Main.hs
+++ b/utils/genprimopcode/Main.hs
@@ -146,25 +146,15 @@ gen_hs_source (Info defaults entries) =
 
           spec o = comm ++ decl
             where decl = case o of
-                       PrimOpSpec { name = n, ty = t }   -> wrapOp n ++ " :: " ++ pty t
-                       PseudoOpSpec { name = n, ty = t } -> wrapOp n ++ " :: " ++ pty t
-                       PrimTypeSpec { ty = t }   -> "data " ++ pty t
+                       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 { } -> ""
 
                   comm = case (desc o) of
                        [] -> ""
                        d -> "\n" ++ (unlines $ map ("-- " ++ ) $ lines $ unlatex $ escape $ "|" ++ d)
 
-                  pty (TyF t1 t2) = pbty t1 ++ " -> " ++ pty t2
-                  pty t           = pbty t
-
-                  pbty (TyApp tc ts) = tc ++ (concat (map (' ':) (map paty ts)))
-                  pbty (TyUTup ts)   = "(# " ++ (concat (intersperse "," (map pty ts))) ++ " #)"
-                  pbty t             = paty t
-
-                  paty (TyVar tv)      = tv
-                  paty t               = "(" ++ pty t ++ ")"
-
           wrapOp nm | isAlpha (head nm) = nm
                     | otherwise         = "(" ++ nm ++ ")"
           wrapTy nm | isAlpha (head nm) = nm
@@ -183,6 +173,19 @@ gen_hs_source (Info defaults entries) =
           escape = concatMap (\c -> if c `elem` special then '\\':c:[] else c:[])
                where special = "/'`\"@<"
 
+pprTy = pty
+    where
+          pty (TyF t1 t2) = pbty t1 ++ " -> " ++ pty t2
+          pty t      = pbty t
+          pbty (TyApp tc ts) = tc ++ concat (map (' ' :) (map paty ts))
+          pbty (TyUTup ts)   = "(# "
+                            ++ concat (intersperse "," (map pty ts))
+                            ++ " #)"
+          pbty t             = paty t
+
+          paty (TyVar tv)    = tv
+          paty t             = "(" ++ pty t ++ ")"
+--
 -- Generates the type environment that the stand-alone External Core tools use.
 gen_ext_core_source :: [Entry] -> String
 gen_ext_core_source entries =
@@ -190,8 +193,9 @@ gen_ext_core_source entries =
    ++ "-- This module is automatically generated by the GHC utility\n"
    ++ "-- \"genprimopcode\". Do not edit!\n"
    ++ "-----------------------------------------------------------------------\n"
-   ++ "module PrimEnv(primTcs, primVals, intLitTypes, ratLitTypes,\n"
-   ++ "    charLitTypes, stringLitTypes) where\nimport Core\nimport Encoding\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 
@@ -278,10 +282,6 @@ gen_ext_core_source entries =
 
         -- 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" ++ ", "
@@ -464,18 +464,27 @@ gen_latex_doc (Info defaults entries)
 
 gen_wrappers :: Info -> String
 gen_wrappers (Info _ entries)
-   = "{-# OPTIONS -fno-implicit-prelude #-}\n" 
+   = "{-# LANGUAGE NoImplicitPrelude, UnboxedTuples #-}\n"
        -- Dependencies on Prelude must be explicit in libraries/base, but we
-       -- don't need the Prelude here so we add -fno-implicit-prelude.
+       -- don't need the Prelude here so we add NoImplicitPrelude.
      ++ "module GHC.PrimopWrappers where\n" 
      ++ "import qualified GHC.Prim\n" 
-     ++ unlines (map f (filter (not.dodgy) (filter is_primop entries)))
+     ++ "import GHC.Bool (Bool)\n"
+     ++ "import GHC.Unit ()\n"
+     ++ "import GHC.Prim (" ++ types ++ ")\n"
+     ++ unlines (concatMap f specs)
      where
+        specs = filter (not.dodgy) (filter is_primop entries)
+        tycons = foldr union [] $ map (tyconsIn . ty) specs
+        tycons' = filter (`notElem` ["()", "Bool"]) tycons
+        types = concat $ intersperse ", " tycons'
         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 
-                     ++ " = (GHC.Prim." ++ name spec ++ ") " ++ unwords args
+                     lhs = src_name ++ " " ++ unwords args
+                     rhs = "(GHC.Prim." ++ name spec ++ ") " ++ unwords args
+                 in ["{-# NOINLINE " ++ src_name ++ " #-}",
+                     src_name ++ " :: " ++ pprTy (ty spec),
+                     lhs ++ " = " ++ rhs]
         wrap nm | isLower (head nm) = nm
                 | otherwise = "(" ++ nm ++ ")"
 
@@ -603,7 +612,7 @@ ppType (TyApp "Word64#"     []) = "word64PrimTy"
 ppType (TyApp "Addr#"       []) = "addrPrimTy"
 ppType (TyApp "Float#"      []) = "floatPrimTy"
 ppType (TyApp "Double#"     []) = "doublePrimTy"
-ppType (TyApp "ByteArr#"    []) = "byteArrayPrimTy"
+ppType (TyApp "ByteArray#"  []) = "byteArrayPrimTy"
 ppType (TyApp "RealWorld"   []) = "realWorldTy"
 ppType (TyApp "ThreadId#"   []) = "threadIdPrimTy"
 ppType (TyApp "ForeignObj#" []) = "foreignObjPrimTy"
@@ -618,10 +627,10 @@ ppType (TyVar "o")               = "openAlphaTy"
 ppType (TyApp "State#" [x])      = "mkStatePrimTy " ++ ppType x
 ppType (TyApp "MutVar#" [x,y])   = "mkMutVarPrimTy " ++ ppType x 
                                    ++ " " ++ ppType y
-ppType (TyApp "MutArr#" [x,y])   = "mkMutableArrayPrimTy " ++ ppType x 
-                                   ++ " " ++ ppType y
+ppType (TyApp "MutableArray#" [x,y]) = "mkMutableArrayPrimTy " ++ ppType x
+                                    ++ " " ++ ppType y
 
-ppType (TyApp "MutByteArr#" [x]) = "mkMutableByteArrayPrimTy " 
+ppType (TyApp "MutableByteArray#" [x]) = "mkMutableByteArrayPrimTy " 
                                    ++ ppType x
 
 ppType (TyApp "Array#" [x])      = "mkArrayPrimTy " ++ ppType x
@@ -657,6 +666,12 @@ tvsIn (TyApp _ tys)  = concatMap tvsIn tys
 tvsIn (TyVar tv)     = [tv]
 tvsIn (TyUTup tys)   = concatMap tvsIn tys
 
+tyconsIn :: Ty -> [TyCon]
+tyconsIn (TyF t1 t2)    = tyconsIn t1 `union` tyconsIn t2
+tyconsIn (TyApp tc tys) = foldr union [tc] $ map tyconsIn tys
+tyconsIn (TyVar _)      = []
+tyconsIn (TyUTup tys)   = foldr union [] $ map tyconsIn tys
+
 arity :: Ty -> Int
 arity = length . fst . flatTys