d7ae9ffe01cd51ddb5d127206fc2b64a2fb8490a
[ghc.git] / utils / genprimopcode / Main.hs
1 ------------------------------------------------------------------
2 -- A primop-table mangling program --
3 ------------------------------------------------------------------
4
5 module Main where
6
7 import Parser
8 import Syntax
9
10 import Data.Char
11 import Data.List
12 import Data.Maybe ( catMaybes )
13 import System.Environment ( getArgs )
14
15 vecOptions :: Entry -> [(String,String,Int)]
16 vecOptions i =
17 concat [vecs | OptionVector vecs <- opts i]
18
19 desugarVectorSpec :: Entry -> [Entry]
20 desugarVectorSpec i@(Section {}) = [i]
21 desugarVectorSpec i = case vecOptions i of
22 [] -> [i]
23 vos -> map genVecEntry vos
24 where
25 genVecEntry :: (String,String,Int) -> Entry
26 genVecEntry (con,repCon,n) =
27 case i of
28 PrimOpSpec {} ->
29 PrimVecOpSpec { cons = "(" ++ concat (intersperse " " [cons i, vecCat, show n, vecWidth]) ++ ")"
30 , name = name'
31 , prefix = pfx
32 , veclen = n
33 , elemrep = con ++ "ElemRep"
34 , ty = desugarTy (ty i)
35 , cat = cat i
36 , desc = desc i
37 , opts = opts i
38 }
39 PrimTypeSpec {} ->
40 PrimVecTypeSpec { ty = desugarTy (ty i)
41 , prefix = pfx
42 , veclen = n
43 , elemrep = con ++ "ElemRep"
44 , desc = desc i
45 , opts = opts i
46 }
47 _ ->
48 error "vector options can only be given for primops and primtypes"
49 where
50 vecCons = con++"X"++show n++"#"
51 vecCat = conCat con
52 vecWidth = conWidth con
53 pfx = lowerHead con++"X"++show n
54 vecTyName = pfx++"PrimTy"
55
56 name' | Just pre <- splitSuffix (name i) "Array#" = pre++vec++"Array#"
57 | Just pre <- splitSuffix (name i) "OffAddr#" = pre++vec++"OffAddr#"
58 | Just pre <- splitSuffix (name i) "ArrayAs#" = pre++con++"ArrayAs"++vec++"#"
59 | Just pre <- splitSuffix (name i) "OffAddrAs#" = pre++con++"OffAddrAs"++vec++"#"
60 | otherwise = init (name i)++vec ++"#"
61 where
62 vec = con++"X"++show n
63
64 splitSuffix :: Eq a => [a] -> [a] -> Maybe [a]
65 splitSuffix s suf
66 | drop len s == suf = Just (take len s)
67 | otherwise = Nothing
68 where
69 len = length s - length suf
70
71 lowerHead s = toLower (head s) : tail s
72
73 desugarTy :: Ty -> Ty
74 desugarTy (TyF s d) = TyF (desugarTy s) (desugarTy d)
75 desugarTy (TyC s d) = TyC (desugarTy s) (desugarTy d)
76 desugarTy (TyApp SCALAR []) = TyApp (TyCon repCon) []
77 desugarTy (TyApp VECTOR []) = TyApp (VecTyCon vecCons vecTyName) []
78 desugarTy (TyApp VECTUPLE []) = TyUTup (replicate n (TyApp (TyCon repCon) []))
79 desugarTy (TyApp tycon ts) = TyApp tycon (map desugarTy ts)
80 desugarTy t@(TyVar {}) = t
81 desugarTy (TyUTup ts) = TyUTup (map desugarTy ts)
82
83 conCat :: String -> String
84 conCat "Int8" = "IntVec"
85 conCat "Int16" = "IntVec"
86 conCat "Int32" = "IntVec"
87 conCat "Int64" = "IntVec"
88 conCat "Word8" = "WordVec"
89 conCat "Word16" = "WordVec"
90 conCat "Word32" = "WordVec"
91 conCat "Word64" = "WordVec"
92 conCat "Float" = "FloatVec"
93 conCat "Double" = "FloatVec"
94 conCat con = error $ "conCat: unknown type constructor " ++ con ++ "\n"
95
96 conWidth :: String -> String
97 conWidth "Int8" = "W8"
98 conWidth "Int16" = "W16"
99 conWidth "Int32" = "W32"
100 conWidth "Int64" = "W64"
101 conWidth "Word8" = "W8"
102 conWidth "Word16" = "W16"
103 conWidth "Word32" = "W32"
104 conWidth "Word64" = "W64"
105 conWidth "Float" = "W32"
106 conWidth "Double" = "W64"
107 conWidth con = error $ "conWidth: unknown type constructor " ++ con ++ "\n"
108
109 main :: IO ()
110 main = getArgs >>= \args ->
111 if length args /= 1 || head args `notElem` known_args
112 then error ("usage: genprimopcode command < primops.txt > ...\n"
113 ++ " where command is one of\n"
114 ++ unlines (map (" "++) known_args)
115 )
116 else
117 do s <- getContents
118 case parse s of
119 Left err -> error ("parse error at " ++ (show err))
120 Right p_o_specs@(Info _ _)
121 -> seq (sanityTop p_o_specs) (
122 case head args of
123
124 "--data-decl"
125 -> putStr (gen_data_decl p_o_specs)
126
127 "--has-side-effects"
128 -> putStr (gen_switch_from_attribs
129 "has_side_effects"
130 "primOpHasSideEffects" p_o_specs)
131
132 "--out-of-line"
133 -> putStr (gen_switch_from_attribs
134 "out_of_line"
135 "primOpOutOfLine" p_o_specs)
136
137 "--commutable"
138 -> putStr (gen_switch_from_attribs
139 "commutable"
140 "commutableOp" p_o_specs)
141
142 "--code-size"
143 -> putStr (gen_switch_from_attribs
144 "code_size"
145 "primOpCodeSize" p_o_specs)
146
147 "--can-fail"
148 -> putStr (gen_switch_from_attribs
149 "can_fail"
150 "primOpCanFail" p_o_specs)
151
152 "--strictness"
153 -> putStr (gen_switch_from_attribs
154 "strictness"
155 "primOpStrictness" p_o_specs)
156
157 "--fixity"
158 -> putStr (gen_switch_from_attribs
159 "fixity"
160 "primOpFixity" p_o_specs)
161
162 "--primop-primop-info"
163 -> putStr (gen_primop_info p_o_specs)
164
165 "--primop-tag"
166 -> putStr (gen_primop_tag p_o_specs)
167
168 "--primop-list"
169 -> putStr (gen_primop_list p_o_specs)
170
171 "--primop-vector-uniques"
172 -> putStr (gen_primop_vector_uniques p_o_specs)
173
174 "--primop-vector-tys"
175 -> putStr (gen_primop_vector_tys p_o_specs)
176
177 "--primop-vector-tys-exports"
178 -> putStr (gen_primop_vector_tys_exports p_o_specs)
179
180 "--primop-vector-tycons"
181 -> putStr (gen_primop_vector_tycons p_o_specs)
182
183 "--make-haskell-wrappers"
184 -> putStr (gen_wrappers p_o_specs)
185
186 "--make-haskell-source"
187 -> putStr (gen_hs_source p_o_specs)
188
189 "--make-latex-doc"
190 -> putStr (gen_latex_doc p_o_specs)
191
192 _ -> error "Should not happen, known_args out of sync?"
193 )
194
195 known_args :: [String]
196 known_args
197 = [ "--data-decl",
198 "--has-side-effects",
199 "--out-of-line",
200 "--commutable",
201 "--code-size",
202 "--can-fail",
203 "--strictness",
204 "--fixity",
205 "--primop-primop-info",
206 "--primop-tag",
207 "--primop-list",
208 "--primop-vector-uniques",
209 "--primop-vector-tys",
210 "--primop-vector-tys-exports",
211 "--primop-vector-tycons",
212 "--make-haskell-wrappers",
213 "--make-haskell-source",
214 "--make-latex-doc"
215 ]
216
217 ------------------------------------------------------------------
218 -- Code generators -----------------------------------------------
219 ------------------------------------------------------------------
220
221 gen_hs_source :: Info -> String
222 gen_hs_source (Info defaults entries) =
223 "{-\n"
224 ++ "This is a generated file (generated by genprimopcode).\n"
225 ++ "It is not code to actually be used. Its only purpose is to be\n"
226 ++ "consumed by haddock.\n"
227 ++ "-}\n"
228 ++ "\n"
229 ++ (replicate 77 '-' ++ "\n") -- For 80-col cleanliness
230 ++ "-- |\n"
231 ++ "-- Module : GHC.Prim\n"
232 ++ "-- \n"
233 ++ "-- Maintainer : ghc-devs@haskell.org\n"
234 ++ "-- Stability : internal\n"
235 ++ "-- Portability : non-portable (GHC extensions)\n"
236 ++ "--\n"
237 ++ "-- GHC\'s primitive types and operations.\n"
238 ++ "-- Use GHC.Exts from the base package instead of importing this\n"
239 ++ "-- module directly.\n"
240 ++ "--\n"
241 ++ (replicate 77 '-' ++ "\n") -- For 80-col cleanliness
242 ++ "{-# LANGUAGE Unsafe #-}\n"
243 ++ "{-# LANGUAGE MagicHash #-}\n"
244 ++ "{-# LANGUAGE MultiParamTypeClasses #-}\n"
245 ++ "{-# LANGUAGE NoImplicitPrelude #-}\n"
246 ++ "{-# LANGUAGE UnboxedTuples #-}\n"
247 ++ "{-# LANGUAGE NegativeLiterals #-}\n"
248
249 ++ "{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}\n"
250 -- We generate a binding for coerce, like
251 -- coerce :: Coercible a b => a -> b
252 -- coerce = let x = x in x
253 -- and we don't want a complaint that the constraint is redundant
254 -- Remember, this silly file is only for Haddock's consumption
255
256 ++ "module GHC.Prim (\n"
257 ++ unlines (map ((" " ++) . hdr) entries')
258 ++ ") where\n"
259 ++ "\n"
260 ++ "{-\n"
261 ++ unlines (map opt defaults)
262 ++ "-}\n"
263 ++ "import GHC.Types (Coercible)\n"
264
265 ++ "default ()" -- If we don't say this then the default type include Integer
266 -- so that runs off and loads modules that are not part of
267 -- package ghc-prim at all. And that in turn somehow ends up
268 -- with Declaration for $fEqMaybe:
269 -- attempting to use module ‘GHC.Classes’
270 -- (libraries/ghc-prim/./GHC/Classes.hs) which is not loaded
271 -- coming from LoadIface.homeModError
272 -- I'm not sure precisely why; but I *am* sure that we don't need
273 -- any type-class defaulting; and it's clearly wrong to need
274 -- the base package when haddocking ghc-prim
275
276 -- Now the main payload
277 ++ "\n" ++ unlines (concatMap ent entries') ++ "\n\n\n"
278
279 where entries' = concatMap desugarVectorSpec entries
280
281 opt (OptionFalse n) = n ++ " = False"
282 opt (OptionTrue n) = n ++ " = True"
283 opt (OptionString n v) = n ++ " = { " ++ v ++ "}"
284 opt (OptionInteger n v) = n ++ " = " ++ show v
285 opt (OptionVector _) = ""
286 opt (OptionFixity mf) = "fixity" ++ " = " ++ show mf
287
288 hdr s@(Section {}) = sec s
289 hdr (PrimOpSpec { name = n }) = wrapOp n ++ ","
290 hdr (PrimVecOpSpec { name = n }) = wrapOp n ++ ","
291 hdr (PseudoOpSpec { name = n }) = wrapOp n ++ ","
292 hdr (PrimTypeSpec { ty = TyApp (TyCon "->") _ }) = ""
293 -- GHC lacks the syntax to explicitly export "->"
294 hdr (PrimTypeSpec { ty = TyApp (TyCon n) _ }) = wrapOp n ++ ","
295 hdr (PrimTypeSpec {}) = error $ "Illegal type spec"
296 hdr (PrimVecTypeSpec { ty = TyApp (VecTyCon n _) _ }) = wrapOp n ++ ","
297 hdr (PrimVecTypeSpec {}) = error $ "Illegal type spec"
298
299 sec s = "\n-- * " ++ escape (title s) ++ "\n"
300 ++ (unlines $ map ("-- " ++ ) $ lines $ unlatex $ escape $ "|" ++ desc s)
301
302
303 ent (Section {}) = []
304 ent o@(PrimOpSpec {}) = spec o
305 ent o@(PrimVecOpSpec {}) = spec o
306 ent o@(PrimTypeSpec {}) = spec o
307 ent o@(PrimVecTypeSpec {}) = spec o
308 ent o@(PseudoOpSpec {}) = spec o
309
310 spec o = ([ "" ] ++) . concat $
311 -- Doc comments
312 [ case unlatex (escape (desc o)) ++ extra (opts o) of
313 "" -> []
314 cmmt -> map ("-- " ++) $ lines $ "|" ++ cmmt
315
316 -- Deprecations
317 , [ d | Just n <- [getName o], d <- prim_deprecated (opts o) n ]
318
319 -- Fixity
320 , [ f | Just n <- [getName o], f <- prim_fixity (opts o) n ]
321
322 -- Declarations (see Note [Placeholder declarations])
323 , case o of
324 PrimOpSpec { name = n, ty = t } -> prim_func n t
325 PrimVecOpSpec { name = n, ty = t } -> prim_func n t
326 PseudoOpSpec { name = n, ty = t } -> prim_func n t
327 PrimTypeSpec { ty = t } -> prim_data t
328 PrimVecTypeSpec { ty = t } -> prim_data t
329 Section { } -> error "Section is not an entity"
330 ]
331
332 extra options = case on_llvm_only options ++ can_fail options of
333 [m1,m2] -> "\n\n__/Warning:/__ this " ++ m1 ++ " and " ++ m2 ++ "."
334 [m] -> "\n\n__/Warning:/__ this " ++ m ++ "."
335 _ -> ""
336
337 on_llvm_only options
338 = [ "is only available on LLVM"
339 | Just (OptionTrue _) <- [lookup_attrib "llvm_only" options] ]
340
341 can_fail options
342 = [ "can fail with an unchecked exception"
343 | Just (OptionTrue _) <- [lookup_attrib "can_fail" options] ]
344
345 prim_deprecated options n
346 = [ "{-# DEPRECATED " ++ wrapOp n ++ " \"" ++ msg ++ "\" #-}"
347 | Just (OptionString _ msg)
348 <- [lookup_attrib "deprecated_msg" options] ]
349
350 prim_fixity options n
351 = [ pprFixityDir d ++ " " ++ show i ++ " " ++ asInfix n
352 | OptionFixity (Just (Fixity _ i d)) <- options ]
353
354 prim_func n t = [ wrapOp n ++ " :: " ++ pprTy t,
355 wrapOp n ++ " = " ++ funcRhs n ]
356
357 funcRhs "tagToEnum#" = "let x = x in x"
358 funcRhs nm = wrapOp nm
359 -- Special case for tagToEnum#: see Note [Placeholder declarations]
360
361 prim_data t = [ "data " ++ pprTy t ]
362
363 unlatex s = case s of
364 '\\':'t':'e':'x':'t':'t':'t':'{':cs -> markup "@" "@" cs
365 '{':'\\':'t':'e':'x':'t':'t':'t':' ':cs -> markup "@" "@" cs
366 '{':'\\':'t':'t':cs -> markup "@" "@" cs
367 '{':'\\':'i':'t':cs -> markup "/" "/" cs
368 '{':'\\':'e':'m':cs -> markup "/" "/" cs
369 c : cs -> c : unlatex cs
370 "" -> ""
371 markup s t xs = s ++ mk (dropWhile isSpace xs)
372 where mk "" = t
373 mk ('\n':cs) = ' ' : mk cs
374 mk ('}':cs) = t ++ unlatex cs
375 mk (c:cs) = c : mk cs
376 escape = concatMap (\c -> if c `elem` special then '\\':c:[] else c:[])
377 where special = "/'`\"@<"
378
379 -- | Extract a string representation of the name
380 getName :: Entry -> Maybe String
381 getName PrimOpSpec{ name = n } = Just n
382 getName PrimVecOpSpec{ name = n } = Just n
383 getName PseudoOpSpec{ name = n } = Just n
384 getName PrimTypeSpec{ ty = TyApp tc _ } = Just (show tc)
385 getName _ = Nothing
386
387 {- Note [Placeholder declarations]
388 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
389 We are generating fake declarations for things in GHC.Prim, just to
390 keep GHC's renamer and typechecker happy enough for what Haddock
391 needs. Our main plan is to say
392 foo :: <type>
393 foo = foo
394 We have to silence GHC's complaints about unboxed-top-level declarations
395 with an ad-hoc fix in TcBinds: see Note [Compiling GHC.Prim] in TcBinds.
396
397 That works for all the primitive functions except tagToEnum#.
398 If we generate the binding
399 tagToEnum# = tagToEnum#
400 GHC will complain about "tagToEnum# must appear applied to one argument".
401 We could hack GHC to silence this complaint when compiling GHC.Prim,
402 but it seems easier to generate
403 tagToEnum# = let x = x in x
404 We don't do this for *all* bindings because for ones with an unboxed
405 RHS we would get other complaints (e.g.can't unify "*" with "#").
406 -}
407
408 -- | "Pretty"-print a type
409 pprTy :: Ty -> String
410 pprTy = pty
411 where
412 pty (TyF t1 t2) = pbty t1 ++ " -> " ++ pty t2
413 pty (TyC t1 t2) = pbty t1 ++ " => " ++ pty t2
414 pty t = pbty t
415
416 pbty (TyApp tc ts) = unwords (wrapOp (show tc) : map paty ts)
417 pbty (TyUTup ts) = "(# "
418 ++ concat (intersperse "," (map pty ts))
419 ++ " #)"
420 pbty t = paty t
421
422 paty (TyVar tv) = tv
423 paty t = "(" ++ pty t ++ ")"
424
425 -- | Turn an identifier or operator into its prefix form
426 wrapOp :: String -> String
427 wrapOp nm | isAlpha (head nm) = nm
428 | otherwise = "(" ++ nm ++ ")"
429
430 -- | Turn an identifer or operator into its infix form
431 asInfix :: String -> String
432 asInfix nm | isAlpha (head nm) = "`" ++ nm ++ "`"
433 | otherwise = nm
434
435 gen_latex_doc :: Info -> String
436 gen_latex_doc (Info defaults entries)
437 = "\\primopdefaults{"
438 ++ mk_options defaults
439 ++ "}\n"
440 ++ (concat (map mk_entry entries))
441 where mk_entry (PrimOpSpec {cons=constr,name=n,ty=t,cat=c,desc=d,opts=o}) =
442 "\\primopdesc{"
443 ++ latex_encode constr ++ "}{"
444 ++ latex_encode n ++ "}{"
445 ++ latex_encode (zencode n) ++ "}{"
446 ++ latex_encode (show c) ++ "}{"
447 ++ latex_encode (mk_source_ty t) ++ "}{"
448 ++ latex_encode (mk_core_ty t) ++ "}{"
449 ++ d ++ "}{"
450 ++ mk_options o
451 ++ "}\n"
452 mk_entry (PrimVecOpSpec {}) =
453 ""
454 mk_entry (Section {title=ti,desc=d}) =
455 "\\primopsection{"
456 ++ latex_encode ti ++ "}{"
457 ++ d ++ "}\n"
458 mk_entry (PrimTypeSpec {ty=t,desc=d,opts=o}) =
459 "\\primtypespec{"
460 ++ latex_encode (mk_source_ty t) ++ "}{"
461 ++ latex_encode (mk_core_ty t) ++ "}{"
462 ++ d ++ "}{"
463 ++ mk_options o
464 ++ "}\n"
465 mk_entry (PrimVecTypeSpec {}) =
466 ""
467 mk_entry (PseudoOpSpec {name=n,ty=t,desc=d,opts=o}) =
468 "\\pseudoopspec{"
469 ++ latex_encode (zencode n) ++ "}{"
470 ++ latex_encode (mk_source_ty t) ++ "}{"
471 ++ latex_encode (mk_core_ty t) ++ "}{"
472 ++ d ++ "}{"
473 ++ mk_options o
474 ++ "}\n"
475 mk_source_ty typ = pty typ
476 where pty (TyF t1 t2) = pbty t1 ++ " -> " ++ pty t2
477 pty (TyC t1 t2) = pbty t1 ++ " => " ++ pty t2
478 pty t = pbty t
479 pbty (TyApp tc ts) = show tc ++ (concat (map (' ':) (map paty ts)))
480 pbty (TyUTup ts) = "(# " ++ (concat (intersperse "," (map pty ts))) ++ " #)"
481 pbty t = paty t
482 paty (TyVar tv) = tv
483 paty t = "(" ++ pty t ++ ")"
484
485 mk_core_ty typ = foralls ++ (pty typ)
486 where pty (TyF t1 t2) = pbty t1 ++ " -> " ++ pty t2
487 pty (TyC t1 t2) = pbty t1 ++ " => " ++ pty t2
488 pty t = pbty t
489 pbty (TyApp tc ts) = (zencode (show tc)) ++ (concat (map (' ':) (map paty ts)))
490 pbty (TyUTup ts) = (zencode (utuplenm (length ts))) ++ (concat ((map (' ':) (map paty ts))))
491 pbty t = paty t
492 paty (TyVar tv) = zencode tv
493 paty (TyApp tc []) = zencode (show tc)
494 paty t = "(" ++ pty t ++ ")"
495 utuplenm 1 = "(# #)"
496 utuplenm n = "(#" ++ (replicate (n-1) ',') ++ "#)"
497 foralls = if tvars == [] then "" else "%forall " ++ (tbinds tvars)
498 tvars = tvars_of typ
499 tbinds [] = ". "
500 tbinds ("o":tbs) = "(o::?) " ++ (tbinds tbs)
501 tbinds (tv:tbs) = tv ++ " " ++ (tbinds tbs)
502 tvars_of (TyF t1 t2) = tvars_of t1 `union` tvars_of t2
503 tvars_of (TyC t1 t2) = tvars_of t1 `union` tvars_of t2
504 tvars_of (TyApp _ ts) = foldl union [] (map tvars_of ts)
505 tvars_of (TyUTup ts) = foldr union [] (map tvars_of ts)
506 tvars_of (TyVar tv) = [tv]
507
508 mk_options o =
509 "\\primoptions{"
510 ++ mk_has_side_effects o ++ "}{"
511 ++ mk_out_of_line o ++ "}{"
512 ++ mk_commutable o ++ "}{"
513 ++ mk_needs_wrapper o ++ "}{"
514 ++ mk_can_fail o ++ "}{"
515 ++ mk_fixity o ++ "}{"
516 ++ latex_encode (mk_strictness o) ++ "}{"
517 ++ "}"
518
519 mk_has_side_effects o = mk_bool_opt o "has_side_effects" "Has side effects." "Has no side effects."
520 mk_out_of_line o = mk_bool_opt o "out_of_line" "Implemented out of line." "Implemented in line."
521 mk_commutable o = mk_bool_opt o "commutable" "Commutable." "Not commutable."
522 mk_needs_wrapper o = mk_bool_opt o "needs_wrapper" "Needs wrapper." "Needs no wrapper."
523 mk_can_fail o = mk_bool_opt o "can_fail" "Can fail." "Cannot fail."
524
525 mk_bool_opt o opt_name if_true if_false =
526 case lookup_attrib opt_name o of
527 Just (OptionTrue _) -> if_true
528 Just (OptionFalse _) -> if_false
529 Just (OptionString _ _) -> error "String value for boolean option"
530 Just (OptionInteger _ _) -> error "Integer value for boolean option"
531 Just (OptionFixity _) -> error "Fixity value for boolean option"
532 Just (OptionVector _) -> error "vector template for boolean option"
533 Nothing -> ""
534
535 mk_strictness o =
536 case lookup_attrib "strictness" o of
537 Just (OptionString _ s) -> s -- for now
538 Just _ -> error "Wrong value for strictness"
539 Nothing -> ""
540
541 mk_fixity o = case lookup_attrib "fixity" o of
542 Just (OptionFixity (Just (Fixity _ i d)))
543 -> pprFixityDir d ++ " " ++ show i
544 _ -> ""
545
546 zencode xs =
547 case maybe_tuple xs of
548 Just n -> n -- Tuples go to Z2T etc
549 Nothing -> concat (map encode_ch xs)
550 where
551 maybe_tuple "(# #)" = Just("Z1H")
552 maybe_tuple ('(' : '#' : cs) = case count_commas (0::Int) cs of
553 (n, '#' : ')' : _) -> Just ('Z' : shows (n+1) "H")
554 _ -> Nothing
555 maybe_tuple "()" = Just("Z0T")
556 maybe_tuple ('(' : cs) = case count_commas (0::Int) cs of
557 (n, ')' : _) -> Just ('Z' : shows (n+1) "T")
558 _ -> Nothing
559 maybe_tuple _ = Nothing
560
561 count_commas :: Int -> String -> (Int, String)
562 count_commas n (',' : cs) = count_commas (n+1) cs
563 count_commas n cs = (n,cs)
564
565 unencodedChar :: Char -> Bool -- True for chars that don't need encoding
566 unencodedChar 'Z' = False
567 unencodedChar 'z' = False
568 unencodedChar c = isAlphaNum c
569
570 encode_ch :: Char -> String
571 encode_ch c | unencodedChar c = [c] -- Common case first
572
573 -- Constructors
574 encode_ch '(' = "ZL" -- Needed for things like (,), and (->)
575 encode_ch ')' = "ZR" -- For symmetry with (
576 encode_ch '[' = "ZM"
577 encode_ch ']' = "ZN"
578 encode_ch ':' = "ZC"
579 encode_ch 'Z' = "ZZ"
580
581 -- Variables
582 encode_ch 'z' = "zz"
583 encode_ch '&' = "za"
584 encode_ch '|' = "zb"
585 encode_ch '^' = "zc"
586 encode_ch '$' = "zd"
587 encode_ch '=' = "ze"
588 encode_ch '>' = "zg"
589 encode_ch '#' = "zh"
590 encode_ch '.' = "zi"
591 encode_ch '<' = "zl"
592 encode_ch '-' = "zm"
593 encode_ch '!' = "zn"
594 encode_ch '+' = "zp"
595 encode_ch '\'' = "zq"
596 encode_ch '\\' = "zr"
597 encode_ch '/' = "zs"
598 encode_ch '*' = "zt"
599 encode_ch '_' = "zu"
600 encode_ch '%' = "zv"
601 encode_ch c = 'z' : shows (ord c) "U"
602
603 latex_encode [] = []
604 latex_encode (c:cs) | c `elem` "#$%&_^{}" = "\\" ++ c:(latex_encode cs)
605 latex_encode ('~':cs) = "\\verb!~!" ++ (latex_encode cs)
606 latex_encode ('\\':cs) = "$\\backslash$" ++ (latex_encode cs)
607 latex_encode (c:cs) = c:(latex_encode cs)
608
609 gen_wrappers :: Info -> String
610 gen_wrappers (Info _ entries)
611 = "{-# LANGUAGE MagicHash, NoImplicitPrelude, UnboxedTuples #-}\n"
612 -- Dependencies on Prelude must be explicit in libraries/base, but we
613 -- don't need the Prelude here so we add NoImplicitPrelude.
614 ++ "{-# OPTIONS_GHC -Wno-deprecations #-}\n"
615 ++ "module GHC.PrimopWrappers where\n"
616 ++ "import qualified GHC.Prim\n"
617 ++ "import GHC.Tuple ()\n"
618 ++ "import GHC.Prim (" ++ types ++ ")\n"
619 ++ unlines (concatMap f specs)
620 where
621 specs = filter (not.dodgy) $
622 filter (not.is_llvm_only) $
623 filter is_primop entries
624 tycons = foldr union [] $ map (tyconsIn . ty) specs
625 tycons' = filter (`notElem` [TyCon "()", TyCon "Bool"]) tycons
626 types = concat $ intersperse ", " $ map show tycons'
627 f spec = let args = map (\n -> "a" ++ show n) [1 .. arity (ty spec)]
628 src_name = wrap (name spec)
629 lhs = src_name ++ " " ++ unwords args
630 rhs = "(GHC.Prim." ++ name spec ++ ") " ++ unwords args
631 in ["{-# NOINLINE " ++ src_name ++ " #-}",
632 src_name ++ " :: " ++ pprTy (ty spec),
633 lhs ++ " = " ++ rhs]
634 wrap nm | isLower (head nm) = nm
635 | otherwise = "(" ++ nm ++ ")"
636
637 dodgy spec
638 = name spec `elem`
639 [-- tagToEnum# is really magical, and can't have
640 -- a wrapper since its implementation depends on
641 -- the type of its result
642 "tagToEnum#"
643 ]
644
645 is_llvm_only :: Entry -> Bool
646 is_llvm_only entry =
647 case lookup_attrib "llvm_only" (opts entry) of
648 Just (OptionTrue _) -> True
649 _ -> False
650
651 gen_primop_list :: Info -> String
652 gen_primop_list (Info _ entries)
653 = unlines (
654 [ " [" ++ cons first ]
655 ++
656 map (\p -> " , " ++ cons p) rest
657 ++
658 [ " ]" ]
659 ) where (first:rest) = concatMap desugarVectorSpec (filter is_primop entries)
660
661 mIN_VECTOR_UNIQUE :: Int
662 mIN_VECTOR_UNIQUE = 300
663
664 gen_primop_vector_uniques :: Info -> String
665 gen_primop_vector_uniques (Info _ entries)
666 = unlines $
667 concatMap mkVecUnique (specs `zip` [mIN_VECTOR_UNIQUE..])
668 where
669 specs = concatMap desugarVectorSpec (filter is_vector (filter is_primtype entries))
670
671 mkVecUnique :: (Entry, Int) -> [String]
672 mkVecUnique (i, unique) =
673 [ key_id ++ " :: Unique"
674 , key_id ++ " = mkPreludeTyConUnique " ++ show unique
675 ]
676 where
677 key_id = prefix i ++ "PrimTyConKey"
678
679 gen_primop_vector_tys :: Info -> String
680 gen_primop_vector_tys (Info _ entries)
681 = unlines $
682 concatMap mkVecTypes specs
683 where
684 specs = concatMap desugarVectorSpec (filter is_vector (filter is_primtype entries))
685
686 mkVecTypes :: Entry -> [String]
687 mkVecTypes i =
688 [ name_id ++ " :: Name"
689 , name_id ++ " = mkPrimTc (fsLit \"" ++ pprTy (ty i) ++ "\") " ++ key_id ++ " " ++ tycon_id
690 , ty_id ++ " :: Type"
691 , ty_id ++ " = mkTyConTy " ++ tycon_id
692 , tycon_id ++ " :: TyCon"
693 , tycon_id ++ " = pcPrimTyCon0 " ++ name_id ++
694 " (VecRep " ++ show (veclen i) ++ " " ++ elemrep i ++ ")"
695 ]
696 where
697 key_id = prefix i ++ "PrimTyConKey"
698 name_id = prefix i ++ "PrimTyConName"
699 ty_id = prefix i ++ "PrimTy"
700 tycon_id = prefix i ++ "PrimTyCon"
701
702 gen_primop_vector_tys_exports :: Info -> String
703 gen_primop_vector_tys_exports (Info _ entries)
704 = unlines $
705 map mkVecTypes specs
706 where
707 specs = concatMap desugarVectorSpec (filter is_vector (filter is_primtype entries))
708
709 mkVecTypes :: Entry -> String
710 mkVecTypes i =
711 " " ++ ty_id ++ ", " ++ tycon_id ++ ","
712 where
713 ty_id = prefix i ++ "PrimTy"
714 tycon_id = prefix i ++ "PrimTyCon"
715
716 gen_primop_vector_tycons :: Info -> String
717 gen_primop_vector_tycons (Info _ entries)
718 = unlines $
719 map mkVecTypes specs
720 where
721 specs = concatMap desugarVectorSpec (filter is_vector (filter is_primtype entries))
722
723 mkVecTypes :: Entry -> String
724 mkVecTypes i =
725 " , " ++ tycon_id
726 where
727 tycon_id = prefix i ++ "PrimTyCon"
728
729 gen_primop_tag :: Info -> String
730 gen_primop_tag (Info _ entries)
731 = unlines (max_def_type : max_def :
732 tagOf_type : zipWith f primop_entries [1 :: Int ..])
733 where
734 primop_entries = concatMap desugarVectorSpec $ filter is_primop entries
735 tagOf_type = "primOpTag :: PrimOp -> Int"
736 f i n = "primOpTag " ++ cons i ++ " = " ++ show n
737 max_def_type = "maxPrimOpTag :: Int"
738 max_def = "maxPrimOpTag = " ++ show (length primop_entries)
739
740 gen_data_decl :: Info -> String
741 gen_data_decl (Info _ entries) =
742 "data PrimOp\n = " ++ head conss ++ "\n"
743 ++ unlines (map (" | "++) (tail conss))
744 where
745 conss = map genCons (filter is_primop entries)
746
747 genCons :: Entry -> String
748 genCons entry =
749 case vecOptions entry of
750 [] -> cons entry
751 _ -> cons entry ++ " PrimOpVecCat Length Width"
752
753 gen_switch_from_attribs :: String -> String -> Info -> String
754 gen_switch_from_attribs attrib_name fn_name (Info defaults entries)
755 = let defv = lookup_attrib attrib_name defaults
756 alternatives = catMaybes (map mkAlt (filter is_primop entries))
757
758 getAltRhs (OptionFalse _) = "False"
759 getAltRhs (OptionTrue _) = "True"
760 getAltRhs (OptionInteger _ i) = show i
761 getAltRhs (OptionString _ s) = s
762 getAltRhs (OptionVector _) = "True"
763 getAltRhs (OptionFixity mf) = show mf
764
765 mkAlt po
766 = case lookup_attrib attrib_name (opts po) of
767 Nothing -> Nothing
768 Just xx -> case vecOptions po of
769 [] -> Just (fn_name ++ " " ++ cons po ++ " = " ++ getAltRhs xx)
770 _ -> Just (fn_name ++ " (" ++ cons po ++ " _ _ _) = " ++ getAltRhs xx)
771
772 in
773 case defv of
774 Nothing -> error ("gen_switch_from: " ++ attrib_name)
775 Just xx
776 -> unlines alternatives
777 ++ fn_name ++ " _ = " ++ getAltRhs xx ++ "\n"
778
779 ------------------------------------------------------------------
780 -- Create PrimOpInfo text from PrimOpSpecs -----------------------
781 ------------------------------------------------------------------
782
783 gen_primop_info :: Info -> String
784 gen_primop_info (Info _ entries)
785 = unlines (map mkPOItext (concatMap desugarVectorSpec (filter is_primop entries)))
786
787 mkPOItext :: Entry -> String
788 mkPOItext i = mkPOI_LHS_text i ++ mkPOI_RHS_text i
789
790 mkPOI_LHS_text :: Entry -> String
791 mkPOI_LHS_text i
792 = "primOpInfo " ++ cons i ++ " = "
793
794 mkPOI_RHS_text :: Entry -> String
795 mkPOI_RHS_text i
796 = case cat i of
797 Compare
798 -> case ty i of
799 TyF t1 (TyF _ _)
800 -> "mkCompare " ++ sl_name i ++ ppType t1
801 _ -> error "Type error in comparison op"
802 Monadic
803 -> case ty i of
804 TyF t1 _
805 -> "mkMonadic " ++ sl_name i ++ ppType t1
806 _ -> error "Type error in monadic op"
807 Dyadic
808 -> case ty i of
809 TyF t1 (TyF _ _)
810 -> "mkDyadic " ++ sl_name i ++ ppType t1
811 _ -> error "Type error in dyadic op"
812 GenPrimOp
813 -> let (argTys, resTy) = flatTys (ty i)
814 tvs = nub (tvsIn (ty i))
815 in
816 "mkGenPrimOp " ++ sl_name i ++ " "
817 ++ listify (map ppTyVar tvs) ++ " "
818 ++ listify (map ppType argTys) ++ " "
819 ++ "(" ++ ppType resTy ++ ")"
820
821 sl_name :: Entry -> String
822 sl_name i = "(fsLit \"" ++ name i ++ "\") "
823
824 ppTyVar :: String -> String
825 ppTyVar "a" = "alphaTyVar"
826 ppTyVar "b" = "betaTyVar"
827 ppTyVar "c" = "gammaTyVar"
828 ppTyVar "s" = "deltaTyVar"
829 ppTyVar "o" = "runtimeRep1TyVar, openAlphaTyVar"
830 ppTyVar _ = error "Unknown type var"
831
832 ppType :: Ty -> String
833 ppType (TyApp (TyCon "Any") []) = "anyTy"
834 ppType (TyApp (TyCon "Bool") []) = "boolTy"
835
836 ppType (TyApp (TyCon "Int#") []) = "intPrimTy"
837 ppType (TyApp (TyCon "Int8#") []) = "int8PrimTy"
838 ppType (TyApp (TyCon "Int16#") []) = "int16PrimTy"
839 ppType (TyApp (TyCon "Int32#") []) = "int32PrimTy"
840 ppType (TyApp (TyCon "Int64#") []) = "int64PrimTy"
841 ppType (TyApp (TyCon "Char#") []) = "charPrimTy"
842 ppType (TyApp (TyCon "Word#") []) = "wordPrimTy"
843 ppType (TyApp (TyCon "Word8#") []) = "word8PrimTy"
844 ppType (TyApp (TyCon "Word16#") []) = "word16PrimTy"
845 ppType (TyApp (TyCon "Word32#") []) = "word32PrimTy"
846 ppType (TyApp (TyCon "Word64#") []) = "word64PrimTy"
847 ppType (TyApp (TyCon "Addr#") []) = "addrPrimTy"
848 ppType (TyApp (TyCon "Float#") []) = "floatPrimTy"
849 ppType (TyApp (TyCon "Double#") []) = "doublePrimTy"
850 ppType (TyApp (TyCon "ByteArray#") []) = "byteArrayPrimTy"
851 ppType (TyApp (TyCon "RealWorld") []) = "realWorldTy"
852 ppType (TyApp (TyCon "ThreadId#") []) = "threadIdPrimTy"
853 ppType (TyApp (TyCon "ForeignObj#") []) = "foreignObjPrimTy"
854 ppType (TyApp (TyCon "BCO#") []) = "bcoPrimTy"
855 ppType (TyApp (TyCon "Compact#") []) = "compactPrimTy"
856 ppType (TyApp (TyCon "()") []) = "unitTy" -- unitTy is TysWiredIn's name for ()
857
858 ppType (TyVar "a") = "alphaTy"
859 ppType (TyVar "b") = "betaTy"
860 ppType (TyVar "c") = "gammaTy"
861 ppType (TyVar "s") = "deltaTy"
862 ppType (TyVar "o") = "openAlphaTy"
863
864 ppType (TyApp (TyCon "State#") [x]) = "mkStatePrimTy " ++ ppType x
865 ppType (TyApp (TyCon "MutVar#") [x,y]) = "mkMutVarPrimTy " ++ ppType x
866 ++ " " ++ ppType y
867 ppType (TyApp (TyCon "MutableArray#") [x,y]) = "mkMutableArrayPrimTy " ++ ppType x
868 ++ " " ++ ppType y
869 ppType (TyApp (TyCon "MutableArrayArray#") [x]) = "mkMutableArrayArrayPrimTy " ++ ppType x
870 ppType (TyApp (TyCon "SmallMutableArray#") [x,y]) = "mkSmallMutableArrayPrimTy " ++ ppType x
871 ++ " " ++ ppType y
872 ppType (TyApp (TyCon "MutableByteArray#") [x]) = "mkMutableByteArrayPrimTy "
873 ++ ppType x
874 ppType (TyApp (TyCon "Array#") [x]) = "mkArrayPrimTy " ++ ppType x
875 ppType (TyApp (TyCon "ArrayArray#") []) = "mkArrayArrayPrimTy"
876 ppType (TyApp (TyCon "SmallArray#") [x]) = "mkSmallArrayPrimTy " ++ ppType x
877
878
879 ppType (TyApp (TyCon "Weak#") [x]) = "mkWeakPrimTy " ++ ppType x
880 ppType (TyApp (TyCon "StablePtr#") [x]) = "mkStablePtrPrimTy " ++ ppType x
881 ppType (TyApp (TyCon "StableName#") [x]) = "mkStableNamePrimTy " ++ ppType x
882
883 ppType (TyApp (TyCon "MVar#") [x,y]) = "mkMVarPrimTy " ++ ppType x
884 ++ " " ++ ppType y
885 ppType (TyApp (TyCon "TVar#") [x,y]) = "mkTVarPrimTy " ++ ppType x
886 ++ " " ++ ppType y
887
888 ppType (TyApp (VecTyCon _ pptc) []) = pptc
889
890 ppType (TyUTup ts) = "(mkTupleTy Unboxed "
891 ++ listify (map ppType ts) ++ ")"
892
893 ppType (TyF s d) = "(mkVisFunTy (" ++ ppType s ++ ") (" ++ ppType d ++ "))"
894 ppType (TyC s d) = "(mkInvisFunTy (" ++ ppType s ++ ") (" ++ ppType d ++ "))"
895
896 ppType other
897 = error ("ppType: can't handle: " ++ show other ++ "\n")
898
899 pprFixityDir :: FixityDirection -> String
900 pprFixityDir InfixN = "infix"
901 pprFixityDir InfixL = "infixl"
902 pprFixityDir InfixR = "infixr"
903
904 listify :: [String] -> String
905 listify ss = "[" ++ concat (intersperse ", " ss) ++ "]"
906
907 flatTys :: Ty -> ([Ty],Ty)
908 flatTys (TyF t1 t2) = case flatTys t2 of (ts,t) -> (t1:ts,t)
909 flatTys (TyC t1 t2) = case flatTys t2 of (ts,t) -> (t1:ts,t)
910 flatTys other = ([],other)
911
912 tvsIn :: Ty -> [TyVar]
913 tvsIn (TyF t1 t2) = tvsIn t1 ++ tvsIn t2
914 tvsIn (TyC t1 t2) = tvsIn t1 ++ tvsIn t2
915 tvsIn (TyApp _ tys) = concatMap tvsIn tys
916 tvsIn (TyVar tv) = [tv]
917 tvsIn (TyUTup tys) = concatMap tvsIn tys
918
919 tyconsIn :: Ty -> [TyCon]
920 tyconsIn (TyF t1 t2) = tyconsIn t1 `union` tyconsIn t2
921 tyconsIn (TyC t1 t2) = tyconsIn t1 `union` tyconsIn t2
922 tyconsIn (TyApp tc tys) = foldr union [tc] $ map tyconsIn tys
923 tyconsIn (TyVar _) = []
924 tyconsIn (TyUTup tys) = foldr union [] $ map tyconsIn tys
925
926 arity :: Ty -> Int
927 arity = length . fst . flatTys