2 ------------------------------------------------------------------
3 -- A primop-table mangling program --
4 ------------------------------------------------------------------
14 import System ( getArgs )
15 import Maybe ( catMaybes )
18 main = getArgs >>= \args ->
19 if length args /= 1 || head args `notElem` known_args
20 then error ("usage: genprimopcode command < primops.txt > ...\n"
21 ++ " where command is one of\n"
22 ++ unlines (map (" "++) known_args)
27 Left err -> error ("parse error at " ++ (show err))
29 -> seq (sanityTop p_o_specs) (
33 -> putStr (gen_data_decl p_o_specs)
36 -> putStr (gen_switch_from_attribs
38 "primOpHasSideEffects" p_o_specs)
41 -> putStr (gen_switch_from_attribs
43 "primOpOutOfLine" p_o_specs)
46 -> putStr (gen_switch_from_attribs
48 "commutableOp" p_o_specs)
51 -> putStr (gen_switch_from_attribs
53 "primOpNeedsWrapper" p_o_specs)
56 -> putStr (gen_switch_from_attribs
58 "primOpCanFail" p_o_specs)
61 -> putStr (gen_switch_from_attribs
63 "primOpStrictness" p_o_specs)
65 "--primop-primop-info"
66 -> putStr (gen_primop_info p_o_specs)
69 -> putStr (gen_primop_tag p_o_specs)
72 -> putStr (gen_primop_list p_o_specs)
74 "--make-haskell-wrappers"
75 -> putStr (gen_wrappers p_o_specs)
77 "--make-haskell-source"
78 -> putStr (gen_hs_source p_o_specs)
81 -> putStr (gen_latex_doc p_o_specs)
83 _ -> error "Should not happen, known_args out of sync?"
86 known_args :: [String]
95 "--primop-primop-info",
98 "--make-haskell-wrappers",
99 "--make-haskell-source",
103 ------------------------------------------------------------------
104 -- Code generators -----------------------------------------------
105 ------------------------------------------------------------------
107 gen_hs_source :: Info -> String
108 gen_hs_source (Info defaults entries) =
109 "-----------------------------------------------------------------------------\n"
111 ++ "-- Module : GHC.Arr\n"
113 ++ "-- Maintainer : cvs-ghc@haskell.org\n"
114 ++ "-- Stability : internal\n"
115 ++ "-- Portability : non-portable (GHC extensions)\n"
117 ++ "-- GHC\'s primitive types and operations.\n"
119 ++ "-----------------------------------------------------------------------------\n"
120 ++ "module GHC.Prim (\n"
121 ++ unlines (map (("\t" ++) . hdr) entries)
123 ++ unlines (map opt defaults) ++ "-}\n"
124 ++ unlines (map ent entries) ++ "\n\n\n"
125 where opt (OptionFalse n) = n ++ " = False"
126 opt (OptionTrue n) = n ++ " = True"
127 opt (OptionString n v) = n ++ " = { " ++ v ++ "}"
129 hdr s@(Section {}) = sec s
130 hdr (PrimOpSpec { name = n }) = wrapOp n ++ ","
131 hdr (PseudoOpSpec { name = n }) = wrapOp n ++ ","
132 hdr (PrimTypeSpec { ty = TyApp n _ }) = wrapTy n ++ ","
133 hdr (PrimTypeSpec {}) = error "Illegal type spec"
135 ent (Section {}) = ""
136 ent o@(PrimOpSpec {}) = spec o
137 ent o@(PrimTypeSpec {}) = spec o
138 ent o@(PseudoOpSpec {}) = spec o
140 sec s = "\n-- * " ++ escape (title s) ++ "\n"
141 ++ (unlines $ map ("-- " ++ ) $ lines $ unlatex $ escape $ "|" ++ desc s) ++ "\n"
143 spec o = comm ++ decl
144 where decl = case o of
145 PrimOpSpec { name = n, ty = t } -> wrapOp n ++ " :: " ++ pty t
146 PseudoOpSpec { name = n, ty = t } -> wrapOp n ++ " :: " ++ pty t
147 PrimTypeSpec { ty = t } -> "data " ++ pty t
150 comm = case (desc o) of
152 d -> "\n" ++ (unlines $ map ("-- " ++ ) $ lines $ unlatex $ escape $ "|" ++ d)
154 pty (TyF t1 t2) = pbty t1 ++ " -> " ++ pty t2
157 pbty (TyApp tc ts) = tc ++ (concat (map (' ':) (map paty ts)))
158 pbty (TyUTup ts) = "(# " ++ (concat (intersperse "," (map pty ts))) ++ " #)"
162 paty t = "(" ++ pty t ++ ")"
164 wrapOp nm | isAlpha (head nm) = nm
165 | otherwise = "(" ++ nm ++ ")"
166 wrapTy nm | isAlpha (head nm) = nm
167 | otherwise = "(" ++ nm ++ ")"
168 unlatex s = case s of
169 '\\':'t':'e':'x':'t':'t':'t':'{':cs -> markup "@" "@" cs
170 '{':'\\':'t':'t':cs -> markup "@" "@" cs
171 '{':'\\':'i':'t':cs -> markup "/" "/" cs
172 c : cs -> c : unlatex cs
174 markup s t xs = s ++ mk (dropWhile isSpace xs)
176 mk ('\n':cs) = ' ' : mk cs
177 mk ('}':cs) = t ++ unlatex cs
178 mk (c:cs) = c : mk cs
179 escape = concatMap (\c -> if c `elem` special then '\\':c:[] else c:[])
180 where special = "/'`\"@<"
182 gen_latex_doc :: Info -> String
183 gen_latex_doc (Info defaults entries)
184 = "\\primopdefaults{"
185 ++ mk_options defaults
187 ++ (concat (map mk_entry entries))
188 where mk_entry (PrimOpSpec {cons=constr,name=n,ty=t,cat=c,desc=d,opts=o}) =
190 ++ latex_encode constr ++ "}{"
191 ++ latex_encode n ++ "}{"
192 ++ latex_encode (zencode n) ++ "}{"
193 ++ latex_encode (show c) ++ "}{"
194 ++ latex_encode (mk_source_ty t) ++ "}{"
195 ++ latex_encode (mk_core_ty t) ++ "}{"
199 mk_entry (Section {title=ti,desc=d}) =
201 ++ latex_encode ti ++ "}{"
203 mk_entry (PrimTypeSpec {ty=t,desc=d,opts=o}) =
205 ++ latex_encode (mk_source_ty t) ++ "}{"
206 ++ latex_encode (mk_core_ty t) ++ "}{"
210 mk_entry (PseudoOpSpec {name=n,ty=t,desc=d,opts=o}) =
212 ++ latex_encode (zencode n) ++ "}{"
213 ++ latex_encode (mk_source_ty t) ++ "}{"
214 ++ latex_encode (mk_core_ty t) ++ "}{"
218 mk_source_ty typ = pty typ
219 where pty (TyF t1 t2) = pbty t1 ++ " -> " ++ pty t2
221 pbty (TyApp tc ts) = tc ++ (concat (map (' ':) (map paty ts)))
222 pbty (TyUTup ts) = "(# " ++ (concat (intersperse "," (map pty ts))) ++ " #)"
225 paty t = "(" ++ pty t ++ ")"
227 mk_core_ty typ = foralls ++ (pty typ)
228 where pty (TyF t1 t2) = pbty t1 ++ " -> " ++ pty t2
230 pbty (TyApp tc ts) = (zencode tc) ++ (concat (map (' ':) (map paty ts)))
231 pbty (TyUTup ts) = (zencode (utuplenm (length ts))) ++ (concat ((map (' ':) (map paty ts))))
233 paty (TyVar tv) = zencode tv
234 paty (TyApp tc []) = zencode tc
235 paty t = "(" ++ pty t ++ ")"
237 utuplenm n = "(#" ++ (replicate (n-1) ',') ++ "#)"
238 foralls = if tvars == [] then "" else "%forall " ++ (tbinds tvars)
241 tbinds ("o":tbs) = "(o::?) " ++ (tbinds tbs)
242 tbinds (tv:tbs) = tv ++ " " ++ (tbinds tbs)
243 tvars_of (TyF t1 t2) = tvars_of t1 `union` tvars_of t2
244 tvars_of (TyApp _ ts) = foldl union [] (map tvars_of ts)
245 tvars_of (TyUTup ts) = foldr union [] (map tvars_of ts)
246 tvars_of (TyVar tv) = [tv]
250 ++ mk_has_side_effects o ++ "}{"
251 ++ mk_out_of_line o ++ "}{"
252 ++ mk_commutable o ++ "}{"
253 ++ mk_needs_wrapper o ++ "}{"
254 ++ mk_can_fail o ++ "}{"
255 ++ latex_encode (mk_strictness o) ++ "}{"
258 mk_has_side_effects o = mk_bool_opt o "has_side_effects" "Has side effects." "Has no side effects."
259 mk_out_of_line o = mk_bool_opt o "out_of_line" "Implemented out of line." "Implemented in line."
260 mk_commutable o = mk_bool_opt o "commutable" "Commutable." "Not commutable."
261 mk_needs_wrapper o = mk_bool_opt o "needs_wrapper" "Needs wrapper." "Needs no wrapper."
262 mk_can_fail o = mk_bool_opt o "can_fail" "Can fail." "Cannot fail."
264 mk_bool_opt o opt_name if_true if_false =
265 case lookup_attrib opt_name o of
266 Just (OptionTrue _) -> if_true
267 Just (OptionFalse _) -> if_false
268 Just (OptionString _ _) -> error "String value for boolean option"
272 case lookup_attrib "strictness" o of
273 Just (OptionString _ s) -> s -- for now
274 Just _ -> error "Boolean value for strictness"
278 case maybe_tuple xs of
279 Just n -> n -- Tuples go to Z2T etc
280 Nothing -> concat (map encode_ch xs)
282 maybe_tuple "(# #)" = Just("Z1H")
283 maybe_tuple ('(' : '#' : cs) = case count_commas (0::Int) cs of
284 (n, '#' : ')' : _) -> Just ('Z' : shows (n+1) "H")
286 maybe_tuple "()" = Just("Z0T")
287 maybe_tuple ('(' : cs) = case count_commas (0::Int) cs of
288 (n, ')' : _) -> Just ('Z' : shows (n+1) "T")
290 maybe_tuple _ = Nothing
292 count_commas :: Int -> String -> (Int, String)
293 count_commas n (',' : cs) = count_commas (n+1) cs
294 count_commas n cs = (n,cs)
296 unencodedChar :: Char -> Bool -- True for chars that don't need encoding
297 unencodedChar 'Z' = False
298 unencodedChar 'z' = False
299 unencodedChar c = isAlphaNum c
301 encode_ch :: Char -> String
302 encode_ch c | unencodedChar c = [c] -- Common case first
305 encode_ch '(' = "ZL" -- Needed for things like (,), and (->)
306 encode_ch ')' = "ZR" -- For symmetry with (
326 encode_ch '\'' = "zq"
327 encode_ch '\\' = "zr"
332 encode_ch c = 'z' : shows (ord c) "U"
335 latex_encode (c:cs) | c `elem` "#$%&_^{}" = "\\" ++ c:(latex_encode cs)
336 latex_encode ('~':cs) = "\\verb!~!" ++ (latex_encode cs)
337 latex_encode ('\\':cs) = "$\\backslash$" ++ (latex_encode cs)
338 latex_encode (c:cs) = c:(latex_encode cs)
340 gen_wrappers :: Info -> String
341 gen_wrappers (Info _ entries)
342 = "{-# OPTIONS -fno-implicit-prelude #-}\n"
343 -- Dependencies on Prelude must be explicit in libraries/base, but we
344 -- don't need the Prelude here so we add -fno-implicit-prelude.
345 ++ "module GHC.PrimopWrappers where\n"
346 ++ "import qualified GHC.Prim\n"
347 ++ unlines (map f (filter (not.dodgy) (filter is_primop entries)))
349 f spec = let args = map (\n -> "a" ++ show n) [1 .. arity (ty spec)]
350 src_name = wrap (name spec)
351 in "{-# NOINLINE " ++ src_name ++ " #-}\n" ++
352 src_name ++ " " ++ unwords args
353 ++ " = (GHC.Prim." ++ name spec ++ ") " ++ unwords args
354 wrap nm | isLower (head nm) = nm
355 | otherwise = "(" ++ nm ++ ")"
359 [-- C code generator can't handle these
362 -- not interested in parallel support
363 "par#", "parGlobal#", "parLocal#", "parAt#",
364 "parAtAbs#", "parAtRel#", "parAtForNow#"
367 gen_primop_list :: Info -> String
368 gen_primop_list (Info _ entries)
370 [ " [" ++ cons first ]
372 map (\p -> " , " ++ cons p) rest
375 ) where (first:rest) = filter is_primop entries
377 gen_primop_tag :: Info -> String
378 gen_primop_tag (Info _ entries)
379 = unlines (max_def : zipWith f primop_entries [1 :: Int ..])
381 primop_entries = filter is_primop entries
382 f i n = "tagOf_PrimOp " ++ cons i
383 ++ " = _ILIT(" ++ show n ++ ") :: FastInt"
384 max_def = "maxPrimOpTag = " ++ show (length primop_entries) ++ " :: Int"
386 gen_data_decl :: Info -> String
387 gen_data_decl (Info _ entries)
388 = let conss = map cons (filter is_primop entries)
389 in "data PrimOp\n = " ++ head conss ++ "\n"
390 ++ unlines (map (" | "++) (tail conss))
392 gen_switch_from_attribs :: String -> String -> Info -> String
393 gen_switch_from_attribs attrib_name fn_name (Info defaults entries)
394 = let defv = lookup_attrib attrib_name defaults
395 alternatives = catMaybes (map mkAlt (filter is_primop entries))
397 getAltRhs (OptionFalse _) = "False"
398 getAltRhs (OptionTrue _) = "True"
399 getAltRhs (OptionString _ s) = s
402 = case lookup_attrib attrib_name (opts po) of
404 Just xx -> Just (fn_name ++ " " ++ cons po ++ " = " ++ getAltRhs xx)
408 Nothing -> error ("gen_switch_from: " ++ attrib_name)
410 -> unlines alternatives
411 ++ fn_name ++ " other = " ++ getAltRhs xx ++ "\n"
413 ------------------------------------------------------------------
414 -- Create PrimOpInfo text from PrimOpSpecs -----------------------
415 ------------------------------------------------------------------
417 gen_primop_info :: Info -> String
418 gen_primop_info (Info _ entries)
419 = unlines (map mkPOItext (filter is_primop entries))
421 mkPOItext :: Entry -> String
422 mkPOItext i = mkPOI_LHS_text i ++ mkPOI_RHS_text i
424 mkPOI_LHS_text :: Entry -> String
426 = "primOpInfo " ++ cons i ++ " = "
428 mkPOI_RHS_text :: Entry -> String
434 -> "mkCompare " ++ sl_name i ++ ppType t1
435 _ -> error "Type error in comparison op"
439 -> "mkMonadic " ++ sl_name i ++ ppType t1
440 _ -> error "Type error in monadic op"
444 -> "mkDyadic " ++ sl_name i ++ ppType t1
445 _ -> error "Type error in dyadic op"
447 -> let (argTys, resTy) = flatTys (ty i)
448 tvs = nub (tvsIn (ty i))
450 "mkGenPrimOp " ++ sl_name i ++ " "
451 ++ listify (map ppTyVar tvs) ++ " "
452 ++ listify (map ppType argTys) ++ " "
453 ++ "(" ++ ppType resTy ++ ")"
455 sl_name :: Entry -> String
456 sl_name i = "FSLIT(\"" ++ name i ++ "\") "
458 ppTyVar :: String -> String
459 ppTyVar "a" = "alphaTyVar"
460 ppTyVar "b" = "betaTyVar"
461 ppTyVar "c" = "gammaTyVar"
462 ppTyVar "s" = "deltaTyVar"
463 ppTyVar "o" = "openAlphaTyVar"
464 ppTyVar _ = error "Unknown type var"
466 ppType :: Ty -> String
467 ppType (TyApp "Bool" []) = "boolTy"
469 ppType (TyApp "Int#" []) = "intPrimTy"
470 ppType (TyApp "Int32#" []) = "int32PrimTy"
471 ppType (TyApp "Int64#" []) = "int64PrimTy"
472 ppType (TyApp "Char#" []) = "charPrimTy"
473 ppType (TyApp "Word#" []) = "wordPrimTy"
474 ppType (TyApp "Word32#" []) = "word32PrimTy"
475 ppType (TyApp "Word64#" []) = "word64PrimTy"
476 ppType (TyApp "Addr#" []) = "addrPrimTy"
477 ppType (TyApp "Float#" []) = "floatPrimTy"
478 ppType (TyApp "Double#" []) = "doublePrimTy"
479 ppType (TyApp "ByteArr#" []) = "byteArrayPrimTy"
480 ppType (TyApp "RealWorld" []) = "realWorldTy"
481 ppType (TyApp "ThreadId#" []) = "threadIdPrimTy"
482 ppType (TyApp "ForeignObj#" []) = "foreignObjPrimTy"
483 ppType (TyApp "BCO#" []) = "bcoPrimTy"
484 ppType (TyApp "()" []) = "unitTy" -- unitTy is TysWiredIn's name for ()
486 ppType (TyVar "a") = "alphaTy"
487 ppType (TyVar "b") = "betaTy"
488 ppType (TyVar "c") = "gammaTy"
489 ppType (TyVar "s") = "deltaTy"
490 ppType (TyVar "o") = "openAlphaTy"
491 ppType (TyApp "State#" [x]) = "mkStatePrimTy " ++ ppType x
492 ppType (TyApp "MutVar#" [x,y]) = "mkMutVarPrimTy " ++ ppType x
494 ppType (TyApp "MutArr#" [x,y]) = "mkMutableArrayPrimTy " ++ ppType x
497 ppType (TyApp "MutByteArr#" [x]) = "mkMutableByteArrayPrimTy "
500 ppType (TyApp "Array#" [x]) = "mkArrayPrimTy " ++ ppType x
503 ppType (TyApp "Weak#" [x]) = "mkWeakPrimTy " ++ ppType x
504 ppType (TyApp "StablePtr#" [x]) = "mkStablePtrPrimTy " ++ ppType x
505 ppType (TyApp "StableName#" [x]) = "mkStableNamePrimTy " ++ ppType x
507 ppType (TyApp "MVar#" [x,y]) = "mkMVarPrimTy " ++ ppType x
509 ppType (TyApp "TVar#" [x,y]) = "mkTVarPrimTy " ++ ppType x
511 ppType (TyUTup ts) = "(mkTupleTy Unboxed " ++ show (length ts)
513 ++ listify (map ppType ts) ++ ")"
515 ppType (TyF s d) = "(mkFunTy (" ++ ppType s ++ ") (" ++ ppType d ++ "))"
518 = error ("ppType: can't handle: " ++ show other ++ "\n")
520 listify :: [String] -> String
521 listify ss = "[" ++ concat (intersperse ", " ss) ++ "]"
523 flatTys :: Ty -> ([Ty],Ty)
524 flatTys (TyF t1 t2) = case flatTys t2 of (ts,t) -> (t1:ts,t)
525 flatTys other = ([],other)
527 tvsIn :: Ty -> [TyVar]
528 tvsIn (TyF t1 t2) = tvsIn t1 ++ tvsIn t2
529 tvsIn (TyApp _ tys) = concatMap tvsIn tys
530 tvsIn (TyVar tv) = [tv]
531 tvsIn (TyUTup tys) = concatMap tvsIn tys
534 arity = length . fst . flatTys