Main.hs 26.3 KB
Newer Older
1
{-# OPTIONS -cpp #-}
2
3
4
5
6
7
------------------------------------------------------------------
-- A primop-table mangling program                              --
------------------------------------------------------------------

module Main where

8
9
import Parser
import Syntax
10

11
12
13
14
15
16
import Monad
import Char
import List
import System ( getArgs )
import Maybe ( catMaybes )

17
main :: IO ()
18
19
main = getArgs >>= \args ->
       if length args /= 1 || head args `notElem` known_args
ken's avatar
ken committed
20
       then error ("usage: genprimopcode command < primops.txt > ...\n"
21
22
23
24
25
                   ++ "   where command is one of\n"
                   ++ unlines (map ("            "++) known_args)
                  )
       else
       do s <- getContents
26
          case parse s of
apt's avatar
apt committed
27
             Left err -> error ("parse error at " ++ (show err))
28
             Right p_o_specs@(Info _ entries)
29
                -> seq (sanityTop p_o_specs) (
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
                   case head args of

                      "--data-decl" 
                         -> putStr (gen_data_decl p_o_specs)

                      "--has-side-effects" 
                         -> putStr (gen_switch_from_attribs 
                                       "has_side_effects" 
                                       "primOpHasSideEffects" p_o_specs)

                      "--out-of-line" 
                         -> putStr (gen_switch_from_attribs 
                                       "out_of_line" 
                                       "primOpOutOfLine" p_o_specs)

                      "--commutable" 
                         -> putStr (gen_switch_from_attribs 
                                       "commutable" 
                                       "commutableOp" p_o_specs)

                      "--needs-wrapper" 
                         -> putStr (gen_switch_from_attribs 
                                       "needs_wrapper" 
                                       "primOpNeedsWrapper" p_o_specs)

                      "--can-fail" 
                         -> putStr (gen_switch_from_attribs 
                                       "can_fail" 
                                       "primOpCanFail" p_o_specs)

                      "--strictness" 
                         -> putStr (gen_switch_from_attribs 
                                       "strictness" 
                                       "primOpStrictness" p_o_specs)

                      "--primop-primop-info" 
                         -> putStr (gen_primop_info p_o_specs)

                      "--primop-tag" 
                         -> putStr (gen_primop_tag p_o_specs)

                      "--primop-list" 
                         -> putStr (gen_primop_list p_o_specs)

74
75
                      "--make-haskell-wrappers" 
                         -> putStr (gen_wrappers p_o_specs)
apt's avatar
apt committed
76
			
Dinko Tenev's avatar
Dinko Tenev committed
77
78
79
                      "--make-haskell-source" 
                         -> putStr (gen_hs_source p_o_specs)

80
81
82
                      "--make-ext-core-source"
                         -> putStr (gen_ext_core_source entries)

apt's avatar
apt committed
83
84
		      "--make-latex-doc"
			 -> putStr (gen_latex_doc p_o_specs)
85
86

                      _ -> error "Should not happen, known_args out of sync?"
87
88
                   )

89
known_args :: [String]
90
91
92
93
94
95
96
97
98
99
100
known_args 
   = [ "--data-decl",
       "--has-side-effects",
       "--out-of-line",
       "--commutable",
       "--needs-wrapper",
       "--can-fail",
       "--strictness",
       "--primop-primop-info",
       "--primop-tag",
       "--primop-list",
apt's avatar
apt committed
101
       "--make-haskell-wrappers",
Dinko Tenev's avatar
Dinko Tenev committed
102
       "--make-haskell-source",
103
       "--make-ext-core-source",
apt's avatar
apt committed
104
       "--make-latex-doc"
105
106
107
108
109
110
     ]

------------------------------------------------------------------
-- Code generators -----------------------------------------------
------------------------------------------------------------------

111
gen_hs_source :: Info -> String
112
gen_hs_source (Info defaults entries) =
113
114
115
116
117
118
119
       "{-\n"
    ++ "This is a generated file (generated by genprimopcode).\n"
    ++ "It is not code to actually be used. Its only purpose is to be\n"
    ++ "consumed by haddock.\n"
    ++ "-}\n"
    ++ "\n"
	++ "-----------------------------------------------------------------------------\n"
120
	++ "-- |\n"
121
	++ "-- Module      :  GHC.Prim\n"
122
123
124
125
126
127
128
129
130
131
	++ "-- \n"
	++ "-- Maintainer  :  cvs-ghc@haskell.org\n"
	++ "-- Stability   :  internal\n"
	++ "-- Portability :  non-portable (GHC extensions)\n"
	++ "--\n"
	++ "-- GHC\'s primitive types and operations.\n"
	++ "--\n" 
	++ "-----------------------------------------------------------------------------\n"
	++ "module GHC.Prim (\n"
	++ unlines (map (("\t" ++) . hdr) entries)
132
133
134
135
136
137
138
139
	++ ") where\n"
    ++ "\n"
    ++ "import GHC.Bool\n"
    ++ "\n"
    ++ "{-\n"
	++ unlines (map opt defaults)
    ++ "-}\n"
	++ unlines (concatMap ent entries) ++ "\n\n\n"
140
141
     where opt (OptionFalse n)	  = n ++ " = False"
           opt (OptionTrue n)	  = n ++ " = True"
Dinko Tenev's avatar
Dinko Tenev committed
142
143
	   opt (OptionString n v) = n ++ " = { " ++ v ++ "}"

144
145
146
147
	   hdr s@(Section {})			 = sec s
	   hdr (PrimOpSpec { name = n })	 = wrapOp n ++ ","
	   hdr (PseudoOpSpec { name = n })	 = wrapOp n ++ ","
	   hdr (PrimTypeSpec { ty = TyApp n _ }) = wrapTy n ++ ","
148
	   hdr (PrimTypeSpec {})                 = error "Illegal type spec"
Dinko Tenev's avatar
Dinko Tenev committed
149

150
	   ent   (Section {})	   = []
151
152
153
	   ent o@(PrimOpSpec {})   = spec o
	   ent o@(PrimTypeSpec {}) = spec o
	   ent o@(PseudoOpSpec {}) = spec o
Dinko Tenev's avatar
Dinko Tenev committed
154
155
156
157

	   sec s = "\n-- * " ++ escape (title s) ++ "\n"
			++ (unlines $ map ("-- " ++ ) $ lines $ unlatex $ escape $ "|" ++ desc s) ++ "\n"

158
159
160
161
162
163
164
165
166
167
168
	   spec o = comm : decls
	     where decls = case o of
			PrimOpSpec { name = n, ty = t }	  ->
                            [ wrapOp n ++ " :: " ++ pprTy t,
                              wrapOp n ++ " = let x = x in x" ]
			PseudoOpSpec { name = n, ty = t } ->
                            [ wrapOp n ++ " :: " ++ pprTy t,
                              wrapOp n ++ " = let x = x in x" ]
			PrimTypeSpec { ty = t }	  ->
                            [ "data " ++ pprTy t ]
			Section { } -> []
169

Dinko Tenev's avatar
Dinko Tenev committed
170
171
172
173
		   comm = case (desc o) of
		   	[] -> ""
			d -> "\n" ++ (unlines $ map ("-- " ++ ) $ lines $ unlatex $ escape $ "|" ++ d)

174
175
176
177
	   wrapOp nm | isAlpha (head nm) = nm
		     | otherwise	 = "(" ++ nm ++ ")"
	   wrapTy nm | isAlpha (head nm) = nm
		     | otherwise	 = "(" ++ nm ++ ")"
Dinko Tenev's avatar
Dinko Tenev committed
178
179
180
	   unlatex s = case s of
	   	'\\':'t':'e':'x':'t':'t':'t':'{':cs -> markup "@" "@" cs
		'{':'\\':'t':'t':cs -> markup "@" "@" cs
181
		'{':'\\':'i':'t':cs -> markup "/" "/" cs
Dinko Tenev's avatar
Dinko Tenev committed
182
183
		c : cs -> c : unlatex cs
		[] -> []
184
	   markup s t xs = s ++ mk (dropWhile isSpace xs)
185
	   	where mk ""	   = t
Dinko Tenev's avatar
Dinko Tenev committed
186
	              mk ('\n':cs) = ' ' : mk cs
187
188
	              mk ('}':cs)  = t ++ unlatex cs
	              mk (c:cs)	   = c : mk cs
Dinko Tenev's avatar
Dinko Tenev committed
189
190
191
	   escape = concatMap (\c -> if c `elem` special then '\\':c:[] else c:[])
	   	where special = "/'`\"@<"

Ian Lynagh's avatar
Ian Lynagh committed
192
pprTy :: Ty -> String
193
194
195
196
197
198
199
200
201
202
203
204
205
pprTy = pty
    where
          pty (TyF t1 t2) = pbty t1 ++ " -> " ++ pty t2
          pty t      = pbty t
          pbty (TyApp tc ts) = tc ++ concat (map (' ' :) (map paty ts))
          pbty (TyUTup ts)   = "(# "
                            ++ concat (intersperse "," (map pty ts))
                            ++ " #)"
          pbty t             = paty t

          paty (TyVar tv)    = tv
          paty t             = "(" ++ pty t ++ ")"
--
206
207
208
209
210
211
212
-- Generates the type environment that the stand-alone External Core tools use.
gen_ext_core_source :: [Entry] -> String
gen_ext_core_source entries =
      "-----------------------------------------------------------------------\n"
   ++ "-- This module is automatically generated by the GHC utility\n"
   ++ "-- \"genprimopcode\". Do not edit!\n"
   ++ "-----------------------------------------------------------------------\n"
213
214
215
   ++ "module Language.Core.PrimEnv(primTcs, primVals, intLitTypes, ratLitTypes,"
   ++ "\n charLitTypes, stringLitTypes) where\nimport Language.Core.Core"
   ++ "\nimport Language.Core.Encoding\n\n"
216
217
218
219
220
221
222
   ++ "primTcs :: [(Tcon, Kind)]\n"
   ++ "primTcs = [\n"
   ++ printList tcEnt entries 
   ++ "   ]\n"
   ++ "primVals :: [(Var, Ty)]\n"
   ++ "primVals = [\n"
   ++ printList valEnt entries
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
   ++ "]\n"
   ++ "intLitTypes :: [Ty]\n"
   ++ "intLitTypes = [\n"
   ++ printList tyEnt (intLitTys entries)
   ++ "]\n"
   ++ "ratLitTypes :: [Ty]\n"
   ++ "ratLitTypes = [\n"
   ++ printList tyEnt (ratLitTys entries)
   ++ "]\n"
   ++ "charLitTypes :: [Ty]\n"
   ++ "charLitTypes = [\n"
   ++ printList tyEnt (charLitTys entries)
   ++ "]\n"
   ++ "stringLitTypes :: [Ty]\n"
   ++ "stringLitTypes = [\n"
   ++ printList tyEnt (stringLitTys entries)
239
   ++ "]\n\n"
240

241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
  where printList f = concat . intersperse ",\n" . filter (not . null) . map f   
        tcEnt  (PrimTypeSpec {ty=t}) = 
           case t of
            TyApp tc args -> parens tc (tcKind tc args)
            _             -> error ("tcEnt: type in PrimTypeSpec is not a type"
                              ++ " constructor: " ++ show t)  
        tcEnt  _                = ""
        -- hack alert!
        -- The primops.txt.pp format doesn't have enough information in it to 
        -- print out some of the information that ext-core needs (like kinds,
        -- and later on in this code, module names) so we special-case. An
        -- alternative would be to refer to things indirectly and hard-wire
        -- certain things (e.g., the kind of the Any constructor, here) into
        -- ext-core's Prims module again.
        tcKind "Any" _                = "Klifted"
        tcKind tc [] | last tc == '#' = "Kunlifted"
Ian Lynagh's avatar
Ian Lynagh committed
257
        tcKind _  [] | otherwise      = "Klifted"
258
        -- assumes that all type arguments are lifted (are they?)
Ian Lynagh's avatar
Ian Lynagh committed
259
260
        tcKind tc (_v:as)              = "(Karrow Klifted " ++ tcKind tc as
                                         ++ ")"
261
262
263
        valEnt (PseudoOpSpec {name=n, ty=t}) = valEntry n t
        valEnt (PrimOpSpec {name=n, ty=t})   = valEntry n t
        valEnt _                             = ""
Ian Lynagh's avatar
Ian Lynagh committed
264
        valEntry name' ty' = parens name' (mkForallTy (freeTvars ty') (pty ty'))
265
266
267
268
269
270
271
272
273
274
275
276
277
278
            where pty (TyF t1 t2) = mkFunTy (pty t1) (pty t2)
                  pty (TyApp tc ts) = mkTconApp (mkTcon tc) (map pty ts)  
                  pty (TyUTup ts)   = mkUtupleTy (map pty ts)
                  pty (TyVar tv)    = paren $ "Tvar \"" ++ tv ++ "\""

                  mkFunTy s1 s2 = "Tapp " ++ (paren ("Tapp (Tcon tcArrow)" 
                                               ++ " " ++ paren s1))
                                          ++ " " ++ paren s2
                  mkTconApp tc args = foldl tapp tc args
                  mkTcon tc = paren $ "Tcon " ++ paren (qualify True tc)
                  mkUtupleTy args = foldl tapp (tcUTuple (length args)) args   
                  mkForallTy [] t = t
                  mkForallTy vs t = foldr 
                     (\ v s -> "Tforall " ++ 
Ian Lynagh's avatar
Ian Lynagh committed
279
                               (paren (quote v ++ ", " ++ vKind v)) ++ " "
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
                               ++ paren s) t vs

                  -- hack alert!
                  vKind "o" = "Kopen"
                  vKind _   = "Klifted"

                  freeTvars (TyF t1 t2)   = freeTvars t1 `union` freeTvars t2
                  freeTvars (TyApp _ tys) = freeTvarss tys
                  freeTvars (TyVar v)     = [v]
                  freeTvars (TyUTup tys)  = freeTvarss tys
                  freeTvarss = nub . concatMap freeTvars

                  tapp s nextArg = paren $ "Tapp " ++ s ++ " " ++ paren nextArg
                  tcUTuple n = paren $ "Tcon " ++ paren (qualify False $ "Z" 
                                                          ++ show n ++ "H")
295

Ian Lynagh's avatar
Ian Lynagh committed
296
        tyEnt (PrimTypeSpec {ty=(TyApp tc _args)}) = "   " ++ paren ("Tcon " ++
297
298
299
300
301
302
                                                       (paren (qualify True tc)))
        tyEnt _ = ""

        -- more hacks. might be better to do this on the ext-core side,
        -- as per earlier comment
        qualify _ tc | tc == "Bool" = "Just boolMname" ++ ", " 
303
                                                ++ ze True tc
304
        qualify _ tc | tc == "()"  = "Just baseMname" ++ ", "
305
                                                ++ ze True tc
306
307
        qualify enc tc = "Just primMname" ++ ", " ++ (ze enc tc)
        ze enc tc      = (if enc then "zEncodeString " else "")
308
309
                                      ++ "\"" ++ tc ++ "\""

310
311
312
313
314
315
        intLitTys = prefixes ["Int", "Word", "Addr", "Char"]
        ratLitTys = prefixes ["Float", "Double"]
        charLitTys = prefixes ["Char"]
        stringLitTys = prefixes ["Addr"]
        prefixes ps = filter (\ t ->
                        case t of
Ian Lynagh's avatar
Ian Lynagh committed
316
                          (PrimTypeSpec {ty=(TyApp tc _args)}) ->
317
318
319
                            any (\ p -> p `isPrefixOf` tc) ps
                          _ -> False)

Ian Lynagh's avatar
Ian Lynagh committed
320
        parens n ty' = "      (zEncodeString \"" ++ n ++ "\", " ++ ty' ++ ")"
321
        paren s = "(" ++ s ++ ")"
Ian Lynagh's avatar
Ian Lynagh committed
322
        quote s = "\"" ++ s ++ "\""
323

324
gen_latex_doc :: Info -> String
apt's avatar
apt committed
325
326
327
328
329
gen_latex_doc (Info defaults entries)
   = "\\primopdefaults{" 
	 ++ mk_options defaults
	 ++ "}\n"
     ++ (concat (map mk_entry entries))
330
     where mk_entry (PrimOpSpec {cons=constr,name=n,ty=t,cat=c,desc=d,opts=o}) =
apt's avatar
apt committed
331
   		 "\\primopdesc{" 
332
333
334
335
336
337
338
339
		 ++ latex_encode constr ++ "}{"
		 ++ latex_encode n ++ "}{"
		 ++ latex_encode (zencode n) ++ "}{"
		 ++ latex_encode (show c) ++ "}{"
		 ++ latex_encode (mk_source_ty t) ++ "}{"
		 ++ latex_encode (mk_core_ty t) ++ "}{"
		 ++ d ++ "}{"
		 ++ mk_options o
apt's avatar
apt committed
340
		 ++ "}\n"
341
           mk_entry (Section {title=ti,desc=d}) =
apt's avatar
apt committed
342
		 "\\primopsection{" 
343
344
345
		 ++ latex_encode ti ++ "}{"
		 ++ d ++ "}\n"
           mk_entry (PrimTypeSpec {ty=t,desc=d,opts=o}) =
346
   		 "\\primtypespec{"
347
348
349
350
		 ++ latex_encode (mk_source_ty t) ++ "}{"
		 ++ latex_encode (mk_core_ty t) ++ "}{"
		 ++ d ++ "}{"
		 ++ mk_options o
351
		 ++ "}\n"
352
           mk_entry (PseudoOpSpec {name=n,ty=t,desc=d,opts=o}) =
353
		 "\\pseudoopspec{"
354
355
356
357
358
		 ++ latex_encode (zencode n) ++ "}{"
		 ++ latex_encode (mk_source_ty t) ++ "}{"
		 ++ latex_encode (mk_core_ty t) ++ "}{"
		 ++ d ++ "}{"
		 ++ mk_options o
359
		 ++ "}\n"
360
	   mk_source_ty typ = pty typ
apt's avatar
apt committed
361
362
363
364
365
366
367
368
	     where pty (TyF t1 t2) = pbty t1 ++ " -> " ++ pty t2
		   pty t = pbty t
		   pbty (TyApp tc ts) = tc ++ (concat (map (' ':) (map paty ts)))
		   pbty (TyUTup ts) = "(# " ++ (concat (intersperse "," (map pty ts))) ++ " #)"
		   pbty t = paty t
		   paty (TyVar tv) = tv
		   paty t = "(" ++ pty t ++ ")"
	   
369
	   mk_core_ty typ = foralls ++ (pty typ)
apt's avatar
apt committed
370
371
372
373
374
375
376
377
378
379
380
	     where pty (TyF t1 t2) = pbty t1 ++ " -> " ++ pty t2
		   pty t = pbty t
		   pbty (TyApp tc ts) = (zencode tc) ++ (concat (map (' ':) (map paty ts)))
		   pbty (TyUTup ts) = (zencode (utuplenm (length ts))) ++ (concat ((map (' ':) (map paty ts))))
		   pbty t = paty t
		   paty (TyVar tv) = zencode tv
		   paty (TyApp tc []) = zencode tc
		   paty t = "(" ++ pty t ++ ")"
		   utuplenm 1 = "(# #)"
		   utuplenm n = "(#" ++ (replicate (n-1) ',') ++ "#)"
		   foralls = if tvars == [] then "" else "%forall " ++ (tbinds tvars)
381
		   tvars = tvars_of typ
apt's avatar
apt committed
382
383
384
385
		   tbinds [] = ". " 
		   tbinds ("o":tbs) = "(o::?) " ++ (tbinds tbs)
		   tbinds (tv:tbs) = tv ++ " " ++ (tbinds tbs)
	   tvars_of (TyF t1 t2) = tvars_of t1 `union` tvars_of t2
386
	   tvars_of (TyApp _ ts) = foldl union [] (map tvars_of ts)
apt's avatar
apt committed
387
388
389
	   tvars_of (TyUTup ts) = foldr union [] (map tvars_of ts)
	   tvars_of (TyVar tv) = [tv]
	   
390
           mk_options o =
apt's avatar
apt committed
391
	     "\\primoptions{"
392
393
394
395
396
397
	      ++ mk_has_side_effects o ++ "}{"
	      ++ mk_out_of_line o ++ "}{"
	      ++ mk_commutable o ++ "}{"
 	      ++ mk_needs_wrapper o ++ "}{"
	      ++ mk_can_fail o ++ "}{"
	      ++ latex_encode (mk_strictness o) ++ "}{"
apt's avatar
apt committed
398
399
	      ++ "}"

400
401
402
403
404
  	   mk_has_side_effects o = mk_bool_opt o "has_side_effects" "Has side effects." "Has no side effects."
	   mk_out_of_line o = mk_bool_opt o "out_of_line" "Implemented out of line." "Implemented in line."
  	   mk_commutable o = mk_bool_opt o "commutable" "Commutable." "Not commutable."
  	   mk_needs_wrapper o = mk_bool_opt o "needs_wrapper" "Needs wrapper." "Needs no wrapper."
	   mk_can_fail o = mk_bool_opt o "can_fail" "Can fail." "Cannot fail."
apt's avatar
apt committed
405

406
407
	   mk_bool_opt o opt_name if_true if_false =
	     case lookup_attrib opt_name o of
apt's avatar
apt committed
408
409
	       Just (OptionTrue _) -> if_true
	       Just (OptionFalse _) -> if_false
410
	       Just (OptionString _ _) -> error "String value for boolean option"
apt's avatar
apt committed
411
412
	       Nothing -> ""
	   
413
414
	   mk_strictness o = 
	     case lookup_attrib "strictness" o of
apt's avatar
apt committed
415
	       Just (OptionString _ s) -> s  -- for now
416
	       Just _ -> error "Boolean value for strictness"
apt's avatar
apt committed
417
418
	       Nothing -> "" 

419
420
	   zencode xs =
	     case maybe_tuple xs of
apt's avatar
apt committed
421
		Just n  -> n		-- Tuples go to Z2T etc
422
		Nothing -> concat (map encode_ch xs)
apt's avatar
apt committed
423
424
425
	     where
	       maybe_tuple "(# #)" = Just("Z1H")
	       maybe_tuple ('(' : '#' : cs) = case count_commas (0::Int) cs of
426
427
						(n, '#' : ')' : _) -> Just ('Z' : shows (n+1) "H")
						_		   -> Nothing
apt's avatar
apt committed
428
429
	       maybe_tuple "()" = Just("Z0T")
	       maybe_tuple ('(' : cs)       = case count_commas (0::Int) cs of
430
431
432
						(n, ')' : _) -> Just ('Z' : shows (n+1) "T")
						_	     -> Nothing
	       maybe_tuple _    	     = Nothing
apt's avatar
apt committed
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
	       
	       count_commas :: Int -> String -> (Int, String)
	       count_commas n (',' : cs) = count_commas (n+1) cs
	       count_commas n cs	  = (n,cs)
	       
	       unencodedChar :: Char -> Bool	-- True for chars that don't need encoding
	       unencodedChar 'Z' = False
	       unencodedChar 'z' = False
	       unencodedChar c   = isAlphaNum c
	       
	       encode_ch :: Char -> String
	       encode_ch c | unencodedChar c = [c]	-- Common case first
	       
	       -- Constructors
	       encode_ch '('  = "ZL"	-- Needed for things like (,), and (->)
	       encode_ch ')'  = "ZR"	-- For symmetry with (
	       encode_ch '['  = "ZM"
	       encode_ch ']'  = "ZN"
	       encode_ch ':'  = "ZC"
	       encode_ch 'Z'  = "ZZ"
	       
	       -- Variables
	       encode_ch 'z'  = "zz"
	       encode_ch '&'  = "za"
	       encode_ch '|'  = "zb"
	       encode_ch '^'  = "zc"
	       encode_ch '$'  = "zd"
	       encode_ch '='  = "ze"
	       encode_ch '>'  = "zg"
	       encode_ch '#'  = "zh"
	       encode_ch '.'  = "zi"
	       encode_ch '<'  = "zl"
	       encode_ch '-'  = "zm"
	       encode_ch '!'  = "zn"
	       encode_ch '+'  = "zp"
	       encode_ch '\'' = "zq"
	       encode_ch '\\' = "zr"
	       encode_ch '/'  = "zs"
	       encode_ch '*'  = "zt"
	       encode_ch '_'  = "zu"
	       encode_ch '%'  = "zv"
	       encode_ch c    = 'z' : shows (ord c) "U"
		       
	   latex_encode [] = []
	   latex_encode (c:cs) | c `elem` "#$%&_^{}" = "\\" ++ c:(latex_encode cs)
	   latex_encode ('~':cs) = "\\verb!~!" ++ (latex_encode cs)
	   latex_encode ('\\':cs) = "$\\backslash$" ++ (latex_encode cs)
	   latex_encode (c:cs) = c:(latex_encode cs)

482
gen_wrappers :: Info -> String
483
gen_wrappers (Info _ entries)
484
   = "{-# LANGUAGE NoImplicitPrelude, UnboxedTuples #-}\n"
485
	-- Dependencies on Prelude must be explicit in libraries/base, but we
486
	-- don't need the Prelude here so we add NoImplicitPrelude.
487
     ++ "module GHC.PrimopWrappers where\n" 
488
     ++ "import qualified GHC.Prim\n" 
489
     ++ "import GHC.Bool (Bool)\n"
Ian Lynagh's avatar
Ian Lynagh committed
490
     ++ "import GHC.Unit ()\n"
491
492
     ++ "import GHC.Prim (" ++ types ++ ")\n"
     ++ unlines (concatMap f specs)
493
     where
494
495
496
497
        specs = filter (not.dodgy) (filter is_primop entries)
        tycons = foldr union [] $ map (tyconsIn . ty) specs
        tycons' = filter (`notElem` ["()", "Bool"]) tycons
        types = concat $ intersperse ", " tycons'
498
499
        f spec = let args = map (\n -> "a" ++ show n) [1 .. arity (ty spec)]
                     src_name = wrap (name spec)
500
501
502
503
504
                     lhs = src_name ++ " " ++ unwords args
                     rhs = "(GHC.Prim." ++ name spec ++ ") " ++ unwords args
                 in ["{-# NOINLINE " ++ src_name ++ " #-}",
                     src_name ++ " :: " ++ pprTy (ty spec),
                     lhs ++ " = " ++ rhs]
505
506
507
508
509
510
511
512
513
514
515
516
517
        wrap nm | isLower (head nm) = nm
                | otherwise = "(" ++ nm ++ ")"

        dodgy spec
           = name spec `elem` 
             [-- C code generator can't handle these
              "seq#", 
              "tagToEnum#",
              -- not interested in parallel support
              "par#", "parGlobal#", "parLocal#", "parAt#", 
              "parAtAbs#", "parAtRel#", "parAtForNow#" 
             ]

518
gen_primop_list :: Info -> String
519
gen_primop_list (Info _ entries)
520
   = unlines (
apt's avatar
apt committed
521
        [      "   [" ++ cons first       ]
522
        ++
523
        map (\p -> "   , " ++ cons p) rest
524
525
        ++ 
        [     "   ]"     ]
apt's avatar
apt committed
526
     ) where (first:rest) = filter is_primop entries
527

528
gen_primop_tag :: Info -> String
529
gen_primop_tag (Info _ entries)
530
531
   = unlines (max_def_type : max_def :
              tagOf_type : zipWith f primop_entries [1 :: Int ..])
532
     where
533
534
535
536
537
        primop_entries = filter is_primop entries
        tagOf_type = "tagOf_PrimOp :: PrimOp -> FastInt"
        f i n = "tagOf_PrimOp " ++ cons i ++ " = _ILIT(" ++ show n ++ ")"
        max_def_type = "maxPrimOpTag :: Int"
        max_def      = "maxPrimOpTag = " ++ show (length primop_entries)
538

539
gen_data_decl :: Info -> String
540
gen_data_decl (Info _ entries)
apt's avatar
apt committed
541
   = let conss = map cons (filter is_primop entries)
542
543
544
545
     in  "data PrimOp\n   = " ++ head conss ++ "\n"
         ++ unlines (map ("   | "++) (tail conss))

gen_switch_from_attribs :: String -> String -> Info -> String
apt's avatar
apt committed
546
gen_switch_from_attribs attrib_name fn_name (Info defaults entries)
547
   = let defv = lookup_attrib attrib_name defaults
548
         alternatives = catMaybes (map mkAlt (filter is_primop entries))
549
550
551
552
553
554
555
556
557
558
559
560
561
562

         getAltRhs (OptionFalse _)    = "False"
         getAltRhs (OptionTrue _)     = "True"
         getAltRhs (OptionString _ s) = s

         mkAlt po
            = case lookup_attrib attrib_name (opts po) of
                 Nothing -> Nothing
                 Just xx -> Just (fn_name ++ " " ++ cons po ++ " = " ++ getAltRhs xx)

     in
         case defv of
            Nothing -> error ("gen_switch_from: " ++ attrib_name)
            Just xx 
563
               -> unlines alternatives
564
                  ++ fn_name ++ " _ = " ++ getAltRhs xx ++ "\n"
565
566
567
568
569

------------------------------------------------------------------
-- Create PrimOpInfo text from PrimOpSpecs -----------------------
------------------------------------------------------------------

570
gen_primop_info :: Info -> String
571
gen_primop_info (Info _ entries)
apt's avatar
apt committed
572
   = unlines (map mkPOItext (filter is_primop entries))
573

574
mkPOItext :: Entry -> String
575
576
mkPOItext i = mkPOI_LHS_text i ++ mkPOI_RHS_text i

577
mkPOI_LHS_text :: Entry -> String
578
579
580
mkPOI_LHS_text i
   = "primOpInfo " ++ cons i ++ " = "

581
mkPOI_RHS_text :: Entry -> String
582
583
584
585
mkPOI_RHS_text i
   = case cat i of
        Compare 
           -> case ty i of
586
                 TyF t1 (TyF _ _) 
587
                    -> "mkCompare " ++ sl_name i ++ ppType t1
588
                 _ -> error "Type error in comparison op"
589
590
        Monadic
           -> case ty i of
591
                 TyF t1 _
592
                    -> "mkMonadic " ++ sl_name i ++ ppType t1
593
                 _ -> error "Type error in monadic op"
594
595
        Dyadic
           -> case ty i of
596
                 TyF t1 (TyF _ _)
597
                    -> "mkDyadic " ++ sl_name i ++ ppType t1
598
                 _ -> error "Type error in dyadic op"
599
600
601
602
603
604
605
606
        GenPrimOp
           -> let (argTys, resTy) = flatTys (ty i)
                  tvs = nub (tvsIn (ty i))
              in
                  "mkGenPrimOp " ++ sl_name i ++ " " 
                      ++ listify (map ppTyVar tvs) ++ " "
                      ++ listify (map ppType argTys) ++ " "
                      ++ "(" ++ ppType resTy ++ ")"
607

608
sl_name :: Entry -> String
609
sl_name i = "(fsLit \"" ++ name i ++ "\") "
610

611
ppTyVar :: String -> String
612
613
614
615
616
ppTyVar "a" = "alphaTyVar"
ppTyVar "b" = "betaTyVar"
ppTyVar "c" = "gammaTyVar"
ppTyVar "s" = "deltaTyVar"
ppTyVar "o" = "openAlphaTyVar"
617
ppTyVar _   = error "Unknown type var"
618

619
ppType :: Ty -> String
620
621
622
ppType (TyApp "Bool"        []) = "boolTy"

ppType (TyApp "Int#"        []) = "intPrimTy"
apt's avatar
apt committed
623
ppType (TyApp "Int32#"      []) = "int32PrimTy"
624
625
626
ppType (TyApp "Int64#"      []) = "int64PrimTy"
ppType (TyApp "Char#"       []) = "charPrimTy"
ppType (TyApp "Word#"       []) = "wordPrimTy"
apt's avatar
apt committed
627
ppType (TyApp "Word32#"     []) = "word32PrimTy"
628
629
630
631
ppType (TyApp "Word64#"     []) = "word64PrimTy"
ppType (TyApp "Addr#"       []) = "addrPrimTy"
ppType (TyApp "Float#"      []) = "floatPrimTy"
ppType (TyApp "Double#"     []) = "doublePrimTy"
632
ppType (TyApp "ByteArray#"  []) = "byteArrayPrimTy"
633
634
635
636
ppType (TyApp "RealWorld"   []) = "realWorldTy"
ppType (TyApp "ThreadId#"   []) = "threadIdPrimTy"
ppType (TyApp "ForeignObj#" []) = "foreignObjPrimTy"
ppType (TyApp "BCO#"        []) = "bcoPrimTy"
637
ppType (TyApp "()"          []) = "unitTy" 	-- unitTy is TysWiredIn's name for ()
638
639
640
641
642
643
644
645
646

ppType (TyVar "a")               = "alphaTy"
ppType (TyVar "b")               = "betaTy"
ppType (TyVar "c")               = "gammaTy"
ppType (TyVar "s")               = "deltaTy"
ppType (TyVar "o")               = "openAlphaTy"
ppType (TyApp "State#" [x])      = "mkStatePrimTy " ++ ppType x
ppType (TyApp "MutVar#" [x,y])   = "mkMutVarPrimTy " ++ ppType x 
                                   ++ " " ++ ppType y
647
648
ppType (TyApp "MutableArray#" [x,y]) = "mkMutableArrayPrimTy " ++ ppType x
                                    ++ " " ++ ppType y
649

650
ppType (TyApp "MutableByteArray#" [x]) = "mkMutableByteArrayPrimTy " 
651
652
653
654
655
656
657
658
659
660
661
                                   ++ ppType x

ppType (TyApp "Array#" [x])      = "mkArrayPrimTy " ++ ppType x


ppType (TyApp "Weak#"  [x])      = "mkWeakPrimTy " ++ ppType x
ppType (TyApp "StablePtr#"  [x])      = "mkStablePtrPrimTy " ++ ppType x
ppType (TyApp "StableName#"  [x])      = "mkStableNamePrimTy " ++ ppType x

ppType (TyApp "MVar#" [x,y])     = "mkMVarPrimTy " ++ ppType x 
                                   ++ " " ++ ppType y
662
663
ppType (TyApp "TVar#" [x,y])     = "mkTVarPrimTy " ++ ppType x 
                                   ++ " " ++ ppType y
664
665
666
667
668
669
670
671
672
673
674
675
ppType (TyUTup ts)               = "(mkTupleTy Unboxed " ++ show (length ts)
                                   ++ " "
                                   ++ listify (map ppType ts) ++ ")"

ppType (TyF s d) = "(mkFunTy (" ++ ppType s ++ ") (" ++ ppType d ++ "))"

ppType other
   = error ("ppType: can't handle: " ++ show other ++ "\n")

listify :: [String] -> String
listify ss = "[" ++ concat (intersperse ", " ss) ++ "]"

676
flatTys :: Ty -> ([Ty],Ty)
677
678
679
flatTys (TyF t1 t2) = case flatTys t2 of (ts,t) -> (t1:ts,t)
flatTys other       = ([],other)

680
tvsIn :: Ty -> [TyVar]
681
tvsIn (TyF t1 t2)    = tvsIn t1 ++ tvsIn t2
682
tvsIn (TyApp _ tys)  = concatMap tvsIn tys
683
684
685
tvsIn (TyVar tv)     = [tv]
tvsIn (TyUTup tys)   = concatMap tvsIn tys

686
687
688
689
690
691
tyconsIn :: Ty -> [TyCon]
tyconsIn (TyF t1 t2)    = tyconsIn t1 `union` tyconsIn t2
tyconsIn (TyApp tc tys) = foldr union [tc] $ map tyconsIn tys
tyconsIn (TyVar _)      = []
tyconsIn (TyUTup tys)   = foldr union [] $ map tyconsIn tys

692
arity :: Ty -> Int
693
694
arity = length . fst . flatTys