Use _ rather than "other" in generated code
[ghc.git] / utils / genprimopcode / Main.hs
1 {-# OPTIONS -cpp #-}
2 ------------------------------------------------------------------
3 -- A primop-table mangling program --
4 ------------------------------------------------------------------
5
6 module Main where
7
8 import Parser
9 import Syntax
10
11 import Monad
12 import Char
13 import List
14 import System ( getArgs )
15 import Maybe ( catMaybes )
16
17 main :: IO ()
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)
23 )
24 else
25 do s <- getContents
26 case parse s of
27 Left err -> error ("parse error at " ++ (show err))
28 Right p_o_specs
29 -> seq (sanityTop p_o_specs) (
30 case head args of
31
32 "--data-decl"
33 -> putStr (gen_data_decl p_o_specs)
34
35 "--has-side-effects"
36 -> putStr (gen_switch_from_attribs
37 "has_side_effects"
38 "primOpHasSideEffects" p_o_specs)
39
40 "--out-of-line"
41 -> putStr (gen_switch_from_attribs
42 "out_of_line"
43 "primOpOutOfLine" p_o_specs)
44
45 "--commutable"
46 -> putStr (gen_switch_from_attribs
47 "commutable"
48 "commutableOp" p_o_specs)
49
50 "--needs-wrapper"
51 -> putStr (gen_switch_from_attribs
52 "needs_wrapper"
53 "primOpNeedsWrapper" p_o_specs)
54
55 "--can-fail"
56 -> putStr (gen_switch_from_attribs
57 "can_fail"
58 "primOpCanFail" p_o_specs)
59
60 "--strictness"
61 -> putStr (gen_switch_from_attribs
62 "strictness"
63 "primOpStrictness" p_o_specs)
64
65 "--primop-primop-info"
66 -> putStr (gen_primop_info p_o_specs)
67
68 "--primop-tag"
69 -> putStr (gen_primop_tag p_o_specs)
70
71 "--primop-list"
72 -> putStr (gen_primop_list p_o_specs)
73
74 "--make-haskell-wrappers"
75 -> putStr (gen_wrappers p_o_specs)
76
77 "--make-haskell-source"
78 -> putStr (gen_hs_source p_o_specs)
79
80 "--make-latex-doc"
81 -> putStr (gen_latex_doc p_o_specs)
82
83 _ -> error "Should not happen, known_args out of sync?"
84 )
85
86 known_args :: [String]
87 known_args
88 = [ "--data-decl",
89 "--has-side-effects",
90 "--out-of-line",
91 "--commutable",
92 "--needs-wrapper",
93 "--can-fail",
94 "--strictness",
95 "--primop-primop-info",
96 "--primop-tag",
97 "--primop-list",
98 "--make-haskell-wrappers",
99 "--make-haskell-source",
100 "--make-latex-doc"
101 ]
102
103 ------------------------------------------------------------------
104 -- Code generators -----------------------------------------------
105 ------------------------------------------------------------------
106
107 gen_hs_source :: Info -> String
108 gen_hs_source (Info defaults entries) =
109 "-----------------------------------------------------------------------------\n"
110 ++ "-- |\n"
111 ++ "-- Module : GHC.Arr\n"
112 ++ "-- \n"
113 ++ "-- Maintainer : cvs-ghc@haskell.org\n"
114 ++ "-- Stability : internal\n"
115 ++ "-- Portability : non-portable (GHC extensions)\n"
116 ++ "--\n"
117 ++ "-- GHC\'s primitive types and operations.\n"
118 ++ "--\n"
119 ++ "-----------------------------------------------------------------------------\n"
120 ++ "module GHC.Prim (\n"
121 ++ unlines (map (("\t" ++) . hdr) entries)
122 ++ ") where\n\n{-\n"
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 ++ "}"
128
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"
134
135 ent (Section {}) = ""
136 ent o@(PrimOpSpec {}) = spec o
137 ent o@(PrimTypeSpec {}) = spec o
138 ent o@(PseudoOpSpec {}) = spec o
139
140 sec s = "\n-- * " ++ escape (title s) ++ "\n"
141 ++ (unlines $ map ("-- " ++ ) $ lines $ unlatex $ escape $ "|" ++ desc s) ++ "\n"
142
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
148 Section { } -> ""
149
150 comm = case (desc o) of
151 [] -> ""
152 d -> "\n" ++ (unlines $ map ("-- " ++ ) $ lines $ unlatex $ escape $ "|" ++ d)
153
154 pty (TyF t1 t2) = pbty t1 ++ " -> " ++ pty t2
155 pty t = pbty t
156
157 pbty (TyApp tc ts) = tc ++ (concat (map (' ':) (map paty ts)))
158 pbty (TyUTup ts) = "(# " ++ (concat (intersperse "," (map pty ts))) ++ " #)"
159 pbty t = paty t
160
161 paty (TyVar tv) = tv
162 paty t = "(" ++ pty t ++ ")"
163
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
173 [] -> []
174 markup s t xs = s ++ mk (dropWhile isSpace xs)
175 where mk "" = t
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 = "/'`\"@<"
181
182 gen_latex_doc :: Info -> String
183 gen_latex_doc (Info defaults entries)
184 = "\\primopdefaults{"
185 ++ mk_options defaults
186 ++ "}\n"
187 ++ (concat (map mk_entry entries))
188 where mk_entry (PrimOpSpec {cons=constr,name=n,ty=t,cat=c,desc=d,opts=o}) =
189 "\\primopdesc{"
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) ++ "}{"
196 ++ d ++ "}{"
197 ++ mk_options o
198 ++ "}\n"
199 mk_entry (Section {title=ti,desc=d}) =
200 "\\primopsection{"
201 ++ latex_encode ti ++ "}{"
202 ++ d ++ "}\n"
203 mk_entry (PrimTypeSpec {ty=t,desc=d,opts=o}) =
204 "\\primtypespec{"
205 ++ latex_encode (mk_source_ty t) ++ "}{"
206 ++ latex_encode (mk_core_ty t) ++ "}{"
207 ++ d ++ "}{"
208 ++ mk_options o
209 ++ "}\n"
210 mk_entry (PseudoOpSpec {name=n,ty=t,desc=d,opts=o}) =
211 "\\pseudoopspec{"
212 ++ latex_encode (zencode n) ++ "}{"
213 ++ latex_encode (mk_source_ty t) ++ "}{"
214 ++ latex_encode (mk_core_ty t) ++ "}{"
215 ++ d ++ "}{"
216 ++ mk_options o
217 ++ "}\n"
218 mk_source_ty typ = pty typ
219 where pty (TyF t1 t2) = pbty t1 ++ " -> " ++ pty t2
220 pty t = pbty t
221 pbty (TyApp tc ts) = tc ++ (concat (map (' ':) (map paty ts)))
222 pbty (TyUTup ts) = "(# " ++ (concat (intersperse "," (map pty ts))) ++ " #)"
223 pbty t = paty t
224 paty (TyVar tv) = tv
225 paty t = "(" ++ pty t ++ ")"
226
227 mk_core_ty typ = foralls ++ (pty typ)
228 where pty (TyF t1 t2) = pbty t1 ++ " -> " ++ pty t2
229 pty t = pbty t
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))))
232 pbty t = paty t
233 paty (TyVar tv) = zencode tv
234 paty (TyApp tc []) = zencode tc
235 paty t = "(" ++ pty t ++ ")"
236 utuplenm 1 = "(# #)"
237 utuplenm n = "(#" ++ (replicate (n-1) ',') ++ "#)"
238 foralls = if tvars == [] then "" else "%forall " ++ (tbinds tvars)
239 tvars = tvars_of typ
240 tbinds [] = ". "
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]
247
248 mk_options o =
249 "\\primoptions{"
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) ++ "}{"
256 ++ "}"
257
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."
263
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"
269 Nothing -> ""
270
271 mk_strictness o =
272 case lookup_attrib "strictness" o of
273 Just (OptionString _ s) -> s -- for now
274 Just _ -> error "Boolean value for strictness"
275 Nothing -> ""
276
277 zencode xs =
278 case maybe_tuple xs of
279 Just n -> n -- Tuples go to Z2T etc
280 Nothing -> concat (map encode_ch xs)
281 where
282 maybe_tuple "(# #)" = Just("Z1H")
283 maybe_tuple ('(' : '#' : cs) = case count_commas (0::Int) cs of
284 (n, '#' : ')' : _) -> Just ('Z' : shows (n+1) "H")
285 _ -> Nothing
286 maybe_tuple "()" = Just("Z0T")
287 maybe_tuple ('(' : cs) = case count_commas (0::Int) cs of
288 (n, ')' : _) -> Just ('Z' : shows (n+1) "T")
289 _ -> Nothing
290 maybe_tuple _ = Nothing
291
292 count_commas :: Int -> String -> (Int, String)
293 count_commas n (',' : cs) = count_commas (n+1) cs
294 count_commas n cs = (n,cs)
295
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
300
301 encode_ch :: Char -> String
302 encode_ch c | unencodedChar c = [c] -- Common case first
303
304 -- Constructors
305 encode_ch '(' = "ZL" -- Needed for things like (,), and (->)
306 encode_ch ')' = "ZR" -- For symmetry with (
307 encode_ch '[' = "ZM"
308 encode_ch ']' = "ZN"
309 encode_ch ':' = "ZC"
310 encode_ch 'Z' = "ZZ"
311
312 -- Variables
313 encode_ch 'z' = "zz"
314 encode_ch '&' = "za"
315 encode_ch '|' = "zb"
316 encode_ch '^' = "zc"
317 encode_ch '$' = "zd"
318 encode_ch '=' = "ze"
319 encode_ch '>' = "zg"
320 encode_ch '#' = "zh"
321 encode_ch '.' = "zi"
322 encode_ch '<' = "zl"
323 encode_ch '-' = "zm"
324 encode_ch '!' = "zn"
325 encode_ch '+' = "zp"
326 encode_ch '\'' = "zq"
327 encode_ch '\\' = "zr"
328 encode_ch '/' = "zs"
329 encode_ch '*' = "zt"
330 encode_ch '_' = "zu"
331 encode_ch '%' = "zv"
332 encode_ch c = 'z' : shows (ord c) "U"
333
334 latex_encode [] = []
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)
339
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)))
348 where
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 ++ ")"
356
357 dodgy spec
358 = name spec `elem`
359 [-- C code generator can't handle these
360 "seq#",
361 "tagToEnum#",
362 -- not interested in parallel support
363 "par#", "parGlobal#", "parLocal#", "parAt#",
364 "parAtAbs#", "parAtRel#", "parAtForNow#"
365 ]
366
367 gen_primop_list :: Info -> String
368 gen_primop_list (Info _ entries)
369 = unlines (
370 [ " [" ++ cons first ]
371 ++
372 map (\p -> " , " ++ cons p) rest
373 ++
374 [ " ]" ]
375 ) where (first:rest) = filter is_primop entries
376
377 gen_primop_tag :: Info -> String
378 gen_primop_tag (Info _ entries)
379 = unlines (max_def : zipWith f primop_entries [1 :: Int ..])
380 where
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"
385
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))
391
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))
396
397 getAltRhs (OptionFalse _) = "False"
398 getAltRhs (OptionTrue _) = "True"
399 getAltRhs (OptionString _ s) = s
400
401 mkAlt po
402 = case lookup_attrib attrib_name (opts po) of
403 Nothing -> Nothing
404 Just xx -> Just (fn_name ++ " " ++ cons po ++ " = " ++ getAltRhs xx)
405
406 in
407 case defv of
408 Nothing -> error ("gen_switch_from: " ++ attrib_name)
409 Just xx
410 -> unlines alternatives
411 ++ fn_name ++ " _ = " ++ getAltRhs xx ++ "\n"
412
413 ------------------------------------------------------------------
414 -- Create PrimOpInfo text from PrimOpSpecs -----------------------
415 ------------------------------------------------------------------
416
417 gen_primop_info :: Info -> String
418 gen_primop_info (Info _ entries)
419 = unlines (map mkPOItext (filter is_primop entries))
420
421 mkPOItext :: Entry -> String
422 mkPOItext i = mkPOI_LHS_text i ++ mkPOI_RHS_text i
423
424 mkPOI_LHS_text :: Entry -> String
425 mkPOI_LHS_text i
426 = "primOpInfo " ++ cons i ++ " = "
427
428 mkPOI_RHS_text :: Entry -> String
429 mkPOI_RHS_text i
430 = case cat i of
431 Compare
432 -> case ty i of
433 TyF t1 (TyF _ _)
434 -> "mkCompare " ++ sl_name i ++ ppType t1
435 _ -> error "Type error in comparison op"
436 Monadic
437 -> case ty i of
438 TyF t1 _
439 -> "mkMonadic " ++ sl_name i ++ ppType t1
440 _ -> error "Type error in monadic op"
441 Dyadic
442 -> case ty i of
443 TyF t1 (TyF _ _)
444 -> "mkDyadic " ++ sl_name i ++ ppType t1
445 _ -> error "Type error in dyadic op"
446 GenPrimOp
447 -> let (argTys, resTy) = flatTys (ty i)
448 tvs = nub (tvsIn (ty i))
449 in
450 "mkGenPrimOp " ++ sl_name i ++ " "
451 ++ listify (map ppTyVar tvs) ++ " "
452 ++ listify (map ppType argTys) ++ " "
453 ++ "(" ++ ppType resTy ++ ")"
454
455 sl_name :: Entry -> String
456 sl_name i = "FSLIT(\"" ++ name i ++ "\") "
457
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"
465
466 ppType :: Ty -> String
467 ppType (TyApp "Bool" []) = "boolTy"
468
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 ()
485
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
493 ++ " " ++ ppType y
494 ppType (TyApp "MutArr#" [x,y]) = "mkMutableArrayPrimTy " ++ ppType x
495 ++ " " ++ ppType y
496
497 ppType (TyApp "MutByteArr#" [x]) = "mkMutableByteArrayPrimTy "
498 ++ ppType x
499
500 ppType (TyApp "Array#" [x]) = "mkArrayPrimTy " ++ ppType x
501
502
503 ppType (TyApp "Weak#" [x]) = "mkWeakPrimTy " ++ ppType x
504 ppType (TyApp "StablePtr#" [x]) = "mkStablePtrPrimTy " ++ ppType x
505 ppType (TyApp "StableName#" [x]) = "mkStableNamePrimTy " ++ ppType x
506
507 ppType (TyApp "MVar#" [x,y]) = "mkMVarPrimTy " ++ ppType x
508 ++ " " ++ ppType y
509 ppType (TyApp "TVar#" [x,y]) = "mkTVarPrimTy " ++ ppType x
510 ++ " " ++ ppType y
511 ppType (TyUTup ts) = "(mkTupleTy Unboxed " ++ show (length ts)
512 ++ " "
513 ++ listify (map ppType ts) ++ ")"
514
515 ppType (TyF s d) = "(mkFunTy (" ++ ppType s ++ ") (" ++ ppType d ++ "))"
516
517 ppType other
518 = error ("ppType: can't handle: " ++ show other ++ "\n")
519
520 listify :: [String] -> String
521 listify ss = "[" ++ concat (intersperse ", " ss) ++ "]"
522
523 flatTys :: Ty -> ([Ty],Ty)
524 flatTys (TyF t1 t2) = case flatTys t2 of (ts,t) -> (t1:ts,t)
525 flatTys other = ([],other)
526
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
532
533 arity :: Ty -> Int
534 arity = length . fst . flatTys
535