[project @ 2001-06-01 17:14:07 by apt]

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

diff --git a/ghc/utils/genprimopcode/Main.hs b/ghc/utils/genprimopcode/Main.hs
index aaff9c1..2d267fc 100644 (file)
--- a/ghc/utils/genprimopcode/Main.hs
+++ b/ghc/utils/genprimopcode/Main.hs
@@ -75,9 +75,11 @@ main = getArgs >>= \args ->
                       "--primop-list" 
                          -> putStr (gen_primop_list p_o_specs)
 
-                      "--c-bytecode-enum" 
-                         -> putStr (gen_enum_decl p_o_specs)
-
+                      "--make-haskell-wrappers" 
+                         -> putStr (gen_wrappers p_o_specs)
+                       
+                     "--make-latex-table"
+                        -> putStr (gen_latex_table p_o_specs)
                    )
 
 
@@ -93,14 +95,56 @@ known_args
        "--primop-primop-info",
        "--primop-tag",
        "--primop-list",
-
-       "--c-bytecode-enum"
+       "--make-haskell-wrappers",
+       "--make-latex-table"
      ]
 
 ------------------------------------------------------------------
 -- Code generators -----------------------------------------------
 ------------------------------------------------------------------
 
+gen_latex_table (Info defaults pos)
+   = "\\begin{tabular}{|l|l|}\n"
+     ++ "\\hline\nName &\t Type\\\\\n\\hline\n"
+     ++ (concat (map f pos))
+     ++ "\\end{tabular}"
+     where 
+       f spec = "@" ++ (encode (name spec)) ++ "@ &\t@" ++ (pty (ty spec)) ++ "@\\\\\n"
+       encode s = s
+       pty (TyF t1 t2) = pbty t1 ++ " -> " ++ pty t2
+       pty t = pbty t
+       pbty (TyApp tc ts) = (encode tc) ++ (concat (map (' ':) (map paty ts)))
+       pbty (TyUTup ts) = (mkUtupnm (length ts)) ++ (concat (map (' ':) (map paty ts)))
+       pbty t = paty t
+       paty (TyVar tv) = encode tv
+       paty t = "(" ++ pty t ++ ")"
+       mkUtupnm 1 = "ZL#z32U#ZR"
+       mkUtupnm n = "Z" ++ (show (n-1)) ++ "U"
+
+gen_wrappers (Info defaults pos)
+   = "module PrelPrimopWrappers where\n" 
+     ++ "import qualified PrelGHC\n" 
+     ++ unlines (map f (filter (not.dodgy) pos))
+     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
+        wrap nm | isLower (head nm) = nm
+                | otherwise = "(" ++ nm ++ ")"
+
+        dodgy spec
+           = name spec `elem` 
+             [-- C code generator can't handle these
+              "seq#", 
+              "tagToEnum#",
+              -- not interested in parallel support
+              "par#", "parGlobal#", "parLocal#", "parAt#", 
+              "parAtAbs#", "parAtRel#", "parAtForNow#" 
+             ]
+
+
 gen_primop_list (Info defaults pos)
    = unlines (
         [      "   [" ++ cons (head pos)       ]
@@ -116,11 +160,6 @@ gen_primop_tag (Info defaults pos)
         f i n = "tagOf_PrimOp " ++ cons i 
                 ++ " = _ILIT(" ++ show n ++ ") :: FastInt"
 
-gen_enum_decl (Info defaults pos)
-   = let conss = map cons pos
-     in  "enum PrimOp {\n     " ++ head conss ++ "\n"
-         ++ unlines (map ("     , "++) (tail conss)) ++ "};\n"
-
 gen_data_decl (Info defaults pos)
    = let conss = map cons pos
      in  "data PrimOp\n   = " ++ head conss ++ "\n"
@@ -256,6 +295,8 @@ tvsIn (TyApp tc tys) = concatMap tvsIn tys
 tvsIn (TyVar tv)     = [tv]
 tvsIn (TyUTup tys)   = concatMap tvsIn tys
 
+arity = length . fst . flatTys
+
 
 ------------------------------------------------------------------
 -- Abstract syntax -----------------------------------------------
@@ -475,7 +516,7 @@ optdef d p
 sel12 a b = a
 sel22 a b = b
 sel23 a b c = b
-apply = liftM
+apply f p = liftM f p
 
 -- Hacks for zapping whitespace and comments, unfortunately needed
 -- because Daan won't let us have a lexer before the parser :-(