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