The Backpack patch.
[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
248 ++ "{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}\n"
249 -- We generate a binding for coerce, like
250 -- coerce :: Coercible a b => a -> b
251 -- coerce = let x = x in x
252 -- and we don't want a complaint that the constraint is redundant
253 -- Remember, this silly file is only for Haddock's consumption
254
255 ++ "module GHC.Prim (\n"
256 ++ unlines (map ((" " ++) . hdr) entries')
257 ++ ") where\n"
258 ++ "\n"
259 ++ "{-\n"
260 ++ unlines (map opt defaults)
261 ++ "-}\n"
262 ++ "import GHC.Types (Coercible)\n"
263
264 ++ "default ()" -- If we don't say this then the default type include Integer
265 -- so that runs off and loads modules that are not part of
266 -- pacakge ghc-prim at all. And that in turn somehow ends up
267 -- with Declaration for $fEqMaybe:
268 -- attempting to use module ‘GHC.Classes’
269 -- (libraries/ghc-prim/./GHC/Classes.hs) which is not loaded
270 -- coming from LoadIface.homeModError
271 -- I'm not sure precisely why; but I *am* sure that we don't need
272 -- any type-class defaulting; and it's clearly wrong to need
273 -- the base package when haddocking ghc-prim
274
275 -- Now the main payload
276 ++ unlines (concatMap ent entries') ++ "\n\n\n"
277
278 where entries' = concatMap desugarVectorSpec entries
279
280 opt (OptionFalse n) = n ++ " = False"
281 opt (OptionTrue n) = n ++ " = True"
282 opt (OptionString n v) = n ++ " = { " ++ v ++ "}"
283 opt (OptionInteger n v) = n ++ " = " ++ show v
284 opt (OptionVector _) = ""
285 opt (OptionFixity mf) = "fixity" ++ " = " ++ show mf
286
287 hdr s@(Section {}) = sec s
288 hdr (PrimOpSpec { name = n }) = wrapOp n ++ ","
289 hdr (PrimVecOpSpec { name = n }) = wrapOp n ++ ","
290 hdr (PseudoOpSpec { name = n }) = wrapOp n ++ ","
291 hdr (PrimTypeSpec { ty = TyApp (TyCon n) _ }) = wrapTy n ++ ","
292 hdr (PrimTypeSpec {}) = error $ "Illegal type spec"
293 hdr (PrimVecTypeSpec { ty = TyApp (VecTyCon n _) _ }) = wrapTy n ++ ","
294 hdr (PrimVecTypeSpec {}) = error $ "Illegal type spec"
295
296 ent (Section {}) = []
297 ent o@(PrimOpSpec {}) = spec o
298 ent o@(PrimVecOpSpec {}) = spec o
299 ent o@(PrimTypeSpec {}) = spec o
300 ent o@(PrimVecTypeSpec {}) = spec o
301 ent o@(PseudoOpSpec {}) = spec o
302
303 sec s = "\n-- * " ++ escape (title s) ++ "\n"
304 ++ (unlines $ map ("-- " ++ ) $ lines $ unlatex $ escape $ "|" ++ desc s) ++ "\n"
305
306 spec o = comm : decls
307 where decls = case o of -- See Note [Placeholder declarations]
308 PrimOpSpec { name = n, ty = t, opts = options } ->
309 prim_fixity n options ++ prim_decl n t
310 PrimVecOpSpec { name = n, ty = t, opts = options } ->
311 prim_fixity n options ++ prim_decl n t
312 PseudoOpSpec { name = n, ty = t } ->
313 prim_decl n t
314 PrimTypeSpec { ty = t } ->
315 [ "data " ++ pprTy t ]
316 PrimVecTypeSpec { ty = t } ->
317 [ "data " ++ pprTy t ]
318 Section { } -> []
319
320 comm = case (desc o) of
321 [] -> ""
322 d -> "\n" ++ (unlines $ map ("-- " ++ ) $ lines $ unlatex $ escape $ "|" ++ d)
323
324 prim_fixity n options = [ pprFixity fixity n | OptionFixity (Just fixity) <- options ]
325
326 prim_decl n t = [ wrapOp n ++ " :: " ++ pprTy t,
327 wrapOp n ++ " = " ++ wrapOpRhs n ]
328
329 wrapOp nm | isAlpha (head nm) = nm
330 | otherwise = "(" ++ nm ++ ")"
331
332 wrapTy nm | isAlpha (head nm) = nm
333 | otherwise = "(" ++ nm ++ ")"
334
335 wrapOpRhs "tagToEnum#" = "let x = x in x"
336 wrapOpRhs nm = wrapOp nm
337 -- Special case for tagToEnum#: see Note [Placeholder declarations]
338
339 unlatex s = case s of
340 '\\':'t':'e':'x':'t':'t':'t':'{':cs -> markup "@" "@" cs
341 '{':'\\':'t':'t':cs -> markup "@" "@" cs
342 '{':'\\':'i':'t':cs -> markup "/" "/" cs
343 c : cs -> c : unlatex cs
344 [] -> []
345 markup s t xs = s ++ mk (dropWhile isSpace xs)
346 where mk "" = t
347 mk ('\n':cs) = ' ' : mk cs
348 mk ('}':cs) = t ++ unlatex cs
349 mk (c:cs) = c : mk cs
350 escape = concatMap (\c -> if c `elem` special then '\\':c:[] else c:[])
351 where special = "/'`\"@<"
352
353 pprFixity (Fixity _ i d) n
354 = 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" = "runtimeRep1TyVar, 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 "Compact#") []) = "compactPrimTy"
808 ppType (TyApp (TyCon "()") []) = "unitTy" -- unitTy is TysWiredIn's name for ()
809
810 ppType (TyVar "a") = "alphaTy"
811 ppType (TyVar "b") = "betaTy"
812 ppType (TyVar "c") = "gammaTy"
813 ppType (TyVar "s") = "deltaTy"
814 ppType (TyVar "o") = "openAlphaTy"
815
816 ppType (TyApp (TyCon "State#") [x]) = "mkStatePrimTy " ++ ppType x
817 ppType (TyApp (TyCon "MutVar#") [x,y]) = "mkMutVarPrimTy " ++ ppType x
818 ++ " " ++ ppType y
819 ppType (TyApp (TyCon "MutableArray#") [x,y]) = "mkMutableArrayPrimTy " ++ ppType x
820 ++ " " ++ ppType y
821 ppType (TyApp (TyCon "MutableArrayArray#") [x]) = "mkMutableArrayArrayPrimTy " ++ ppType x
822 ppType (TyApp (TyCon "SmallMutableArray#") [x,y]) = "mkSmallMutableArrayPrimTy " ++ ppType x
823 ++ " " ++ ppType y
824 ppType (TyApp (TyCon "MutableByteArray#") [x]) = "mkMutableByteArrayPrimTy "
825 ++ ppType x
826 ppType (TyApp (TyCon "Array#") [x]) = "mkArrayPrimTy " ++ ppType x
827 ppType (TyApp (TyCon "ArrayArray#") []) = "mkArrayArrayPrimTy"
828 ppType (TyApp (TyCon "SmallArray#") [x]) = "mkSmallArrayPrimTy " ++ ppType x
829
830
831 ppType (TyApp (TyCon "Weak#") [x]) = "mkWeakPrimTy " ++ ppType x
832 ppType (TyApp (TyCon "StablePtr#") [x]) = "mkStablePtrPrimTy " ++ ppType x
833 ppType (TyApp (TyCon "StableName#") [x]) = "mkStableNamePrimTy " ++ ppType x
834
835 ppType (TyApp (TyCon "MVar#") [x,y]) = "mkMVarPrimTy " ++ ppType x
836 ++ " " ++ ppType y
837 ppType (TyApp (TyCon "TVar#") [x,y]) = "mkTVarPrimTy " ++ ppType x
838 ++ " " ++ ppType y
839
840 ppType (TyApp (VecTyCon _ pptc) []) = pptc
841
842 ppType (TyUTup ts) = "(mkTupleTy Unboxed "
843 ++ listify (map ppType ts) ++ ")"
844
845 ppType (TyF s d) = "(mkFunTy (" ++ ppType s ++ ") (" ++ ppType d ++ "))"
846 ppType (TyC s d) = "(mkFunTy (" ++ ppType s ++ ") (" ++ ppType d ++ "))"
847
848 ppType other
849 = error ("ppType: can't handle: " ++ show other ++ "\n")
850
851 pprFixityDir :: FixityDirection -> String
852 pprFixityDir InfixN = "infix"
853 pprFixityDir InfixL = "infixl"
854 pprFixityDir InfixR = "infixr"
855
856 listify :: [String] -> String
857 listify ss = "[" ++ concat (intersperse ", " ss) ++ "]"
858
859 flatTys :: Ty -> ([Ty],Ty)
860 flatTys (TyF t1 t2) = case flatTys t2 of (ts,t) -> (t1:ts,t)
861 flatTys (TyC t1 t2) = case flatTys t2 of (ts,t) -> (t1:ts,t)
862 flatTys other = ([],other)
863
864 tvsIn :: Ty -> [TyVar]
865 tvsIn (TyF t1 t2) = tvsIn t1 ++ tvsIn t2
866 tvsIn (TyC t1 t2) = tvsIn t1 ++ tvsIn t2
867 tvsIn (TyApp _ tys) = concatMap tvsIn tys
868 tvsIn (TyVar tv) = [tv]
869 tvsIn (TyUTup tys) = concatMap tvsIn tys
870
871 tyconsIn :: Ty -> [TyCon]
872 tyconsIn (TyF t1 t2) = tyconsIn t1 `union` tyconsIn t2
873 tyconsIn (TyC t1 t2) = tyconsIn t1 `union` tyconsIn t2
874 tyconsIn (TyApp tc tys) = foldr union [tc] $ map tyconsIn tys
875 tyconsIn (TyVar _) = []
876 tyconsIn (TyUTup tys) = foldr union [] $ map tyconsIn tys
877
878 arity :: Ty -> Int
879 arity = length . fst . flatTys