"--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)
)
"--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) ]
= unlines (zipWith f pos [1..])
where
f i n = "tagOf_PrimOp " ++ cons i
- ++ " = ILIT(" ++ show n ++ ") :: FAST_INT"
-
-gen_enum_decl (Info defaults pos)
- = let conss = map cons pos
- in "enum PrimOp {\n " ++ head conss ++ "\n"
- ++ unlines (map (" , "++) (tail conss)) ++ "};\n"
+ ++ " = _ILIT(" ++ show n ++ ") :: FastInt"
gen_data_decl (Info defaults pos)
= let conss = map cons pos
tvsIn (TyVar tv) = [tv]
tvsIn (TyUTup tys) = concatMap tvsIn tys
+arity = length . fst . flatTys
+
------------------------------------------------------------------
-- Abstract syntax -----------------------------------------------
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 :-(