X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=utils%2Fgenprimopcode%2FMain.hs;h=14f08346be833127dd764184cc5aa39047e9c15a;hp=f36aa3132e90e6835ca067811190aa9fcd967474;hb=b2524b3960999fffdb3767900f58825903f6560f;hpb=a1a38a088957ec6bae652ae49c814cfbcf6f0251

diff --git a/utils/genprimopcode/Main.hs b/utils/genprimopcode/Main.hs
index f36aa31..14f0834 100644
--- a/utils/genprimopcode/Main.hs
+++ b/utils/genprimopcode/Main.hs
@@ -8,11 +8,10 @@ module Main where
 import Parser
 import Syntax
 
-import Monad
-import Char
-import List
-import System ( getArgs )
-import Maybe ( catMaybes )
+import Data.Char
+import Data.List
+import Data.Maybe ( catMaybes )
+import System.Environment ( getArgs )
 
 main :: IO ()
 main = getArgs >>= \args ->
@@ -47,13 +46,13 @@ main = getArgs >>= \args ->
                                        "commutable" 
                                        "commutableOp" p_o_specs)
 
-                      "--needs-wrapper" 
+                      "--code-size"
                          -> putStr (gen_switch_from_attribs 
-                                       "needs_wrapper" 
-                                       "primOpNeedsWrapper" p_o_specs)
+                                       "code_size"
+                                       "primOpCodeSize" p_o_specs)
 
-                      "--can-fail" 
-                         -> putStr (gen_switch_from_attribs 
+                      "--can-fail"
+                         -> putStr (gen_switch_from_attribs
                                        "can_fail" 
                                        "primOpCanFail" p_o_specs)
 
@@ -92,7 +91,7 @@ known_args
        "--has-side-effects",
        "--out-of-line",
        "--commutable",
-       "--needs-wrapper",
+       "--code-size",
        "--can-fail",
        "--strictness",
        "--primop-primop-info",
@@ -110,7 +109,13 @@ known_args
 
 gen_hs_source :: Info -> String
 gen_hs_source (Info defaults entries) =
-	   "-----------------------------------------------------------------------------\n"
+       "{-\n"
+    ++ "This is a generated file (generated by genprimopcode).\n"
+    ++ "It is not code to actually be used. Its only purpose is to be\n"
+    ++ "consumed by haddock.\n"
+    ++ "-}\n"
+    ++ "\n"
+	++ "-----------------------------------------------------------------------------\n"
 	++ "-- |\n"
 	++ "-- Module      :  GHC.Prim\n"
 	++ "-- \n"
@@ -119,16 +124,24 @@ gen_hs_source (Info defaults entries) =
 	++ "-- Portability :  non-portable (GHC extensions)\n"
 	++ "--\n"
 	++ "-- GHC\'s primitive types and operations.\n"
+	++ "-- Use GHC.Exts from the base package instead of importing this\n"
+	++ "-- module directly.\n"
 	++ "--\n" 
 	++ "-----------------------------------------------------------------------------\n"
 	++ "module GHC.Prim (\n"
 	++ unlines (map (("\t" ++) . hdr) entries)
-	++ ") where\n\n{-\n"
-	++ unlines (map opt defaults) ++ "-}\n"
-	++ unlines (map ent entries) ++ "\n\n\n"
+	++ ") where\n"
+    ++ "\n"
+    ++ "import GHC.Types\n"
+    ++ "\n"
+    ++ "{-\n"
+	++ unlines (map opt defaults)
+    ++ "-}\n"
+	++ unlines (concatMap ent entries) ++ "\n\n\n"
      where opt (OptionFalse n)	  = n ++ " = False"
            opt (OptionTrue n)	  = n ++ " = True"
 	   opt (OptionString n v) = n ++ " = { " ++ v ++ "}"
+           opt (OptionInteger n v) = n ++ " = " ++ show v
 
 	   hdr s@(Section {})			 = sec s
 	   hdr (PrimOpSpec { name = n })	 = wrapOp n ++ ","
@@ -136,7 +149,7 @@ gen_hs_source (Info defaults entries) =
 	   hdr (PrimTypeSpec { ty = TyApp n _ }) = wrapTy n ++ ","
 	   hdr (PrimTypeSpec {})                 = error "Illegal type spec"
 
-	   ent   (Section {})	   = ""
+	   ent   (Section {})	   = []
 	   ent o@(PrimOpSpec {})   = spec o
 	   ent o@(PrimTypeSpec {}) = spec o
 	   ent o@(PseudoOpSpec {}) = spec o
@@ -144,12 +157,17 @@ gen_hs_source (Info defaults entries) =
 	   sec s = "\n-- * " ++ escape (title s) ++ "\n"
 			++ (unlines $ map ("-- " ++ ) $ lines $ unlatex $ escape $ "|" ++ desc s) ++ "\n"
 
-	   spec o = comm ++ decl
-	     where decl = case o of
-			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 { } -> ""
+	   spec o = comm : decls
+	     where decls = case o of
+			PrimOpSpec { name = n, ty = t }	  ->
+                            [ wrapOp n ++ " :: " ++ pprTy t,
+                              wrapOp n ++ " = let x = x in x" ]
+			PseudoOpSpec { name = n, ty = t } ->
+                            [ wrapOp n ++ " :: " ++ pprTy t,
+                              wrapOp n ++ " = let x = x in x" ]
+			PrimTypeSpec { ty = t }	  ->
+                            [ "data " ++ pprTy t ]
+			Section { } -> []
 
 		   comm = case (desc o) of
 		   	[] -> ""
@@ -173,6 +191,7 @@ gen_hs_source (Info defaults entries) =
 	   escape = concatMap (\c -> if c `elem` special then '\\':c:[] else c:[])
 	   	where special = "/'`\"@<"
 
+pprTy :: Ty -> String
 pprTy = pty
     where
           pty (TyF t1 t2) = pbty t1 ++ " -> " ++ pty t2
@@ -237,14 +256,14 @@ gen_ext_core_source entries =
         -- ext-core's Prims module again.
         tcKind "Any" _                = "Klifted"
         tcKind tc [] | last tc == '#' = "Kunlifted"
-        tcKind tc [] | otherwise      = "Klifted"
+        tcKind _  [] | otherwise      = "Klifted"
         -- assumes that all type arguments are lifted (are they?)
-        tcKind tc (v:as)              = "(Karrow Klifted " ++ tcKind tc as 
-                                        ++ ")"
+        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))
+        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)
@@ -259,7 +278,7 @@ gen_ext_core_source entries =
                   mkForallTy [] t = t
                   mkForallTy vs t = foldr 
                      (\ v s -> "Tforall " ++ 
-                               (paren (quot v ++ ", " ++ vKind v)) ++ " "
+                               (paren (quote v ++ ", " ++ vKind v)) ++ " "
                                ++ paren s) t vs
 
                   -- hack alert!
@@ -276,7 +295,7 @@ gen_ext_core_source entries =
                   tcUTuple n = paren $ "Tcon " ++ paren (qualify False $ "Z" 
                                                           ++ show n ++ "H")
 
-        tyEnt (PrimTypeSpec {ty=(TyApp tc args)}) = "   " ++ paren ("Tcon " ++
+        tyEnt (PrimTypeSpec {ty=(TyApp tc _args)}) = "   " ++ paren ("Tcon " ++
                                                        (paren (qualify True tc)))
         tyEnt _ = ""
 
@@ -296,13 +315,13 @@ gen_ext_core_source entries =
         stringLitTys = prefixes ["Addr"]
         prefixes ps = filter (\ t ->
                         case t of
-                          (PrimTypeSpec {ty=(TyApp tc args)}) ->
+                          (PrimTypeSpec {ty=(TyApp tc _args)}) ->
                             any (\ p -> p `isPrefixOf` tc) ps
                           _ -> False)
 
-        parens n ty = "      (zEncodeString \"" ++ n ++ "\", " ++ ty ++ ")"
+        parens n ty' = "      (zEncodeString \"" ++ n ++ "\", " ++ ty' ++ ")"
         paren s = "(" ++ s ++ ")"
-        quot s = "\"" ++ s ++ "\""
+        quote s = "\"" ++ s ++ "\""
 
 gen_latex_doc :: Info -> String
 gen_latex_doc (Info defaults entries)
@@ -391,7 +410,8 @@ gen_latex_doc (Info defaults entries)
 	       Just (OptionTrue _) -> if_true
 	       Just (OptionFalse _) -> if_false
 	       Just (OptionString _ _) -> error "String value for boolean option"
-	       Nothing -> ""
+               Just (OptionInteger _ _) -> error "Integer value for boolean option"
+               Nothing -> ""
 	   
 	   mk_strictness o = 
 	     case lookup_attrib "strictness" o of
@@ -469,7 +489,8 @@ gen_wrappers (Info _ entries)
 	-- don't need the Prelude here so we add NoImplicitPrelude.
      ++ "module GHC.PrimopWrappers where\n" 
      ++ "import qualified GHC.Prim\n" 
-     ++ "import GHC.Bool (Bool)\n"
+     ++ "import GHC.Types (Bool)\n"
+     ++ "import GHC.Unit ()\n"
      ++ "import GHC.Prim (" ++ types ++ ")\n"
      ++ unlines (concatMap f specs)
      where
@@ -531,6 +552,7 @@ gen_switch_from_attribs attrib_name fn_name (Info defaults entries)
 
          getAltRhs (OptionFalse _)    = "False"
          getAltRhs (OptionTrue _)     = "True"
+         getAltRhs (OptionInteger _ i) = show i
          getAltRhs (OptionString _ s) = s
 
          mkAlt po
@@ -643,8 +665,7 @@ ppType (TyApp "MVar#" [x,y])     = "mkMVarPrimTy " ++ ppType x
                                    ++ " " ++ ppType y
 ppType (TyApp "TVar#" [x,y])     = "mkTVarPrimTy " ++ ppType x 
                                    ++ " " ++ ppType y
-ppType (TyUTup ts)               = "(mkTupleTy Unboxed " ++ show (length ts)
-                                   ++ " "
+ppType (TyUTup ts)               = "(mkTupleTy Unboxed " 
                                    ++ listify (map ppType ts) ++ ")"
 
 ppType (TyF s d) = "(mkFunTy (" ++ ppType s ++ ") (" ++ ppType d ++ "))"