X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Futils%2Fgenprimopcode%2FMain.hs;h=f08b7d5602b3d04131279665e8bb3c97cbf8e204;hb=89408a89fa2ea7d5977498e27983f7d00dc1d857;hp=2e79230387791dc69fbab340ebd3086554b5a30d;hpb=1dfaee318171836b32f6b33a14231c69adfdef2f;p=ghc-hetmet.git

diff --git a/ghc/utils/genprimopcode/Main.hs b/ghc/utils/genprimopcode/Main.hs
index 2e79230..f08b7d5 100644
--- a/ghc/utils/genprimopcode/Main.hs
+++ b/ghc/utils/genprimopcode/Main.hs
@@ -1,11 +1,16 @@
-
+{-# OPTIONS -cpp #-}
 ------------------------------------------------------------------
 -- A primop-table mangling program                              --
 ------------------------------------------------------------------
 
 module Main where
 
+#if __GLASGOW_HASKELL__ >= 504
+import Text.ParserCombinators.Parsec
+#else
 import Parsec
+#endif
+
 import Monad
 import Char
 import List
@@ -77,6 +82,9 @@ main = getArgs >>= \args ->
                       "--make-haskell-wrappers" 
                          -> putStr (gen_wrappers p_o_specs)
 			
+                      "--make-haskell-source" 
+                         -> putStr (gen_hs_source p_o_specs)
+
 		      "--make-latex-doc"
 			 -> putStr (gen_latex_doc p_o_specs)
                    )
@@ -95,6 +103,7 @@ known_args
        "--primop-tag",
        "--primop-list",
        "--make-haskell-wrappers",
+       "--make-haskell-source",
        "--make-latex-doc"
      ]
 
@@ -102,6 +111,56 @@ known_args
 -- Code generators -----------------------------------------------
 ------------------------------------------------------------------
 
+gen_hs_source (Info defaults entries)
+   = "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 opt (OptionFalse n) = n ++ " = False"
+           opt (OptionTrue n) = n ++ " = True"
+	   opt (OptionString n v) = n ++ " = { " ++ v ++ "}"
+
+	   hdr s@(Section {}) = sec s
+	   hdr o@(PrimOpSpec {}) = wrap (name o) ++ ","
+
+	   ent s@(Section {}) = ""
+	   ent o@(PrimOpSpec {}) = spec o
+
+	   sec s = "\n-- * " ++ escape (title s) ++ "\n"
+			++ (unlines $ map ("-- " ++ ) $ lines $ unlatex $ escape $ "|" ++ desc s) ++ "\n"
+
+	   spec o = comm ++ decl
+	     where decl = wrap (name o) ++ " :: " ++ pty (ty o)
+		   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 ++ ")"
+
+	   wrap nm | isLower (head nm) = nm
+		   | otherwise = "(" ++ nm ++ ")"
+	   unlatex s = case s of
+	   	'\\':'t':'e':'x':'t':'t':'t':'{':cs -> markup "@" "@" cs
+		'{':'\\':'t':'t':cs -> markup "@" "@" cs
+		c : cs -> c : unlatex cs
+		[] -> []
+	   markup s t cs = s ++ mk (dropWhile isSpace cs)
+	   	where mk "" = t
+	              mk ('\n':cs) = ' ' : mk cs
+	              mk ('}':cs) = t ++ unlatex cs
+	              mk (c:cs) = c : mk cs
+	   escape = concatMap (\c -> if c `elem` special then '\\':c:[] else c:[])
+	   	where special = "/'`\"@<"
+
 gen_latex_doc (Info defaults entries)
    = "\\primopdefaults{" 
 	 ++ mk_options defaults
@@ -249,15 +308,18 @@ gen_latex_doc (Info defaults entries)
 	   latex_encode (c:cs) = c:(latex_encode cs)
 
 gen_wrappers (Info defaults entries)
-   = "module PrelPrimopWrappers where\n" 
-     ++ "import qualified PrelGHC\n" 
+   = "{-# OPTIONS -fno-implicit-prelude #-}\n" 
+	-- Dependencies on Prelude must be explicit in libraries/base, but we
+	-- don't need the Prelude here so we add -fno-implicit-prelude.
+     ++ "module GHC.PrimopWrappers where\n" 
+     ++ "import qualified GHC.Prim\n" 
      ++ unlines (map f (filter (not.dodgy) (filter is_primop entries)))
      where
         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 
-                     ++ " = (PrelGHC." ++ name spec ++ ") " ++ unwords args
+                     ++ " = (GHC.Prim." ++ name spec ++ ") " ++ unwords args
         wrap nm | isLower (head nm) = nm
                 | otherwise = "(" ++ nm ++ ")"
 
@@ -282,10 +344,12 @@ gen_primop_list (Info defaults entries)
      ) where (first:rest) = filter is_primop entries
 
 gen_primop_tag (Info defaults entries)
-   = unlines (zipWith f (filter is_primop entries) [1..])
+   = unlines (max_def : zipWith f primop_entries [1..])
      where
+	primop_entries = filter is_primop entries
         f i n = "tagOf_PrimOp " ++ cons i 
                 ++ " = _ILIT(" ++ show n ++ ") :: FastInt"
+	max_def = "maxPrimOpTag = " ++ show (length primop_entries) ++ " :: Int"
 
 gen_data_decl (Info defaults entries)
    = let conss = map cons (filter is_primop entries)
@@ -349,7 +413,7 @@ mkPOI_RHS_text i
                       ++ listify (map ppType argTys) ++ " "
                       ++ "(" ++ ppType resTy ++ ")"
             
-sl_name i = "SLIT(\"" ++ name i ++ "\") "
+sl_name i = "FSLIT(\"" ++ name i ++ "\") "
 
 ppTyVar "a" = "alphaTyVar"
 ppTyVar "b" = "betaTyVar"
@@ -375,7 +439,7 @@ ppType (TyApp "RealWorld"   []) = "realWorldTy"
 ppType (TyApp "ThreadId#"   []) = "threadIdPrimTy"
 ppType (TyApp "ForeignObj#" []) = "foreignObjPrimTy"
 ppType (TyApp "BCO#"        []) = "bcoPrimTy"
-ppType (TyApp "Unit"        []) = "unitTy"   -- dodgy
+ppType (TyApp "()"          []) = "unitTy" 	-- unitTy is TysWiredIn's name for ()
 
 
 ppType (TyVar "a")               = "alphaTy"
@@ -401,6 +465,8 @@ ppType (TyApp "StableName#"  [x])      = "mkStableNamePrimTy " ++ ppType x
 
 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)
                                    ++ " "
                                    ++ listify (map ppType ts) ++ ")"
@@ -639,7 +705,7 @@ ppT = alts [apply TyVar pTyvar,
            ]
 
 pTyvar       = sat (`notElem` ["section","primop","with"]) pName
-pTycon       = pConstructor
+pTycon       = alts [pConstructor, lexeme (string "()")]
 pName        = lexeme (then2 (:) lower (many isIdChar))
 pConstructor = lexeme (then2 (:) upper (many isIdChar))