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

diff --git a/utils/genprimopcode/Main.hs b/utils/genprimopcode/Main.hs
index 10e577e..14f0834 100644
--- a/utils/genprimopcode/Main.hs
+++ b/utils/genprimopcode/Main.hs
@@ -8,10 +8,10 @@ module Main where
 import Parser
 import Syntax
 
-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 ->
@@ -46,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)
 
@@ -91,7 +91,7 @@ known_args
        "--has-side-effects",
        "--out-of-line",
        "--commutable",
-       "--needs-wrapper",
+       "--code-size",
        "--can-fail",
        "--strictness",
        "--primop-primop-info",
@@ -124,13 +124,15 @@ 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"
-    ++ "import GHC.Bool\n"
+    ++ "import GHC.Types\n"
     ++ "\n"
     ++ "{-\n"
 	++ unlines (map opt defaults)
@@ -139,6 +141,7 @@ gen_hs_source (Info defaults entries) =
      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 ++ ","
@@ -407,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
@@ -485,7 +489,7 @@ 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)
@@ -548,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
@@ -660,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 ++ "))"