Main.hs 35.9 KB
Newer Older
1 2 3 4 5 6
------------------------------------------------------------------
-- A primop-table mangling program                              --
------------------------------------------------------------------

module Main where

7 8
import Parser
import Syntax
9

10 11 12 13
import Data.Char
import Data.List
import Data.Maybe ( catMaybes )
import System.Environment ( getArgs )
14

15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 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 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108
vecOptions :: Entry -> [(String,String,Int)]
vecOptions i =
    concat [vecs | OptionVector vecs <- opts i]

desugarVectorSpec :: Entry -> [Entry]
desugarVectorSpec i@(Section {}) = [i]
desugarVectorSpec i              = case vecOptions i of
                                     []  -> [i]
                                     vos -> map genVecEntry vos
  where
    genVecEntry :: (String,String,Int) -> Entry
    genVecEntry (con,repCon,n) =
        case i of
          PrimOpSpec {} ->
              PrimVecOpSpec { cons    = "(" ++ concat (intersperse " " [cons i, vecCat, show n, vecWidth]) ++ ")"
                            , name    = name'
                            , prefix  = pfx
                            , veclen  = n
                            , elemrep = con ++ "ElemRep"
                            , ty      = desugarTy (ty i)
                            , cat     = cat i
                            , desc    = desc i
                            , opts    = opts i
                            }
          PrimTypeSpec {} ->
              PrimVecTypeSpec { ty      = desugarTy (ty i)
                              , prefix  = pfx
                              , veclen  = n
                              , elemrep = con ++ "ElemRep"
                              , desc    = desc i
                              , opts    = opts i
                              }
          _ ->
              error "vector options can only be given for primops and primtypes"
      where
        vecCons       = con++"X"++show n++"#"
        vecCat        = conCat con
        vecWidth      = conWidth con
        pfx           = lowerHead con++"X"++show n
        vecTyName     = pfx++"PrimTy"

        name' | Just pre <- splitSuffix (name i) "Array#"     = pre++vec++"Array#"
              | Just pre <- splitSuffix (name i) "OffAddr#"   = pre++vec++"OffAddr#"
              | Just pre <- splitSuffix (name i) "ArrayAs#"   = pre++con++"ArrayAs"++vec++"#"
              | Just pre <- splitSuffix (name i) "OffAddrAs#" = pre++con++"OffAddrAs"++vec++"#"
              | otherwise                                     = init (name i)++vec ++"#"
          where
            vec = con++"X"++show n

        splitSuffix :: Eq a => [a] -> [a] -> Maybe [a]
        splitSuffix s suf
            | drop len s == suf = Just (take len s)
            | otherwise         = Nothing
          where
            len = length s - length suf                            

        lowerHead s = toLower (head s) : tail s

        desugarTy :: Ty -> Ty
        desugarTy (TyF s d)           = TyF (desugarTy s) (desugarTy d)
        desugarTy (TyC s d)           = TyC (desugarTy s) (desugarTy d)
        desugarTy (TyApp SCALAR [])   = TyApp (TyCon repCon) []
        desugarTy (TyApp VECTOR [])   = TyApp (VecTyCon vecCons vecTyName) []
        desugarTy (TyApp VECTUPLE []) = TyUTup (replicate n (TyApp (TyCon repCon) []))
        desugarTy (TyApp tycon ts)    = TyApp tycon (map desugarTy ts)
        desugarTy t@(TyVar {})        = t
        desugarTy (TyUTup ts)         = TyUTup (map desugarTy ts)

    conCat :: String -> String
    conCat "Int8"   = "IntVec"
    conCat "Int16"  = "IntVec"
    conCat "Int32"  = "IntVec"
    conCat "Int64"  = "IntVec"
    conCat "Word8"  = "WordVec"
    conCat "Word16" = "WordVec"
    conCat "Word32" = "WordVec"
    conCat "Word64" = "WordVec"
    conCat "Float"  = "FloatVec"
    conCat "Double" = "FloatVec"
    conCat con      = error $ "conCat: unknown type constructor " ++ con ++ "\n"

    conWidth :: String -> String
    conWidth "Int8"   = "W8"
    conWidth "Int16"  = "W16"
    conWidth "Int32"  = "W32"
    conWidth "Int64"  = "W64"
    conWidth "Word8"  = "W8"
    conWidth "Word16" = "W16"
    conWidth "Word32" = "W32"
    conWidth "Word64" = "W64"
    conWidth "Float"  = "W32"
    conWidth "Double" = "W64"
    conWidth con      = error $ "conWidth: unknown type constructor " ++ con ++ "\n"

109
main :: IO ()
110 111
main = getArgs >>= \args ->
       if length args /= 1 || head args `notElem` known_args
ken's avatar
ken committed
112
       then error ("usage: genprimopcode command < primops.txt > ...\n"
113 114 115 116 117
                   ++ "   where command is one of\n"
                   ++ unlines (map ("            "++) known_args)
                  )
       else
       do s <- getContents
118
          case parse s of
apt's avatar
apt committed
119
             Left err -> error ("parse error at " ++ (show err))
Austin Seipp's avatar
Austin Seipp committed
120
             Right p_o_specs@(Info _ _)
121
                -> seq (sanityTop p_o_specs) (
122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141
                   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)

142
                      "--code-size"
143
                         -> putStr (gen_switch_from_attribs 
144 145
                                       "code_size"
                                       "primOpCodeSize" p_o_specs)
146

147 148
                      "--can-fail"
                         -> putStr (gen_switch_from_attribs
149 150 151 152 153 154 155 156
                                       "can_fail" 
                                       "primOpCanFail" p_o_specs)

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

157 158 159 160 161
                      "--fixity"
                         -> putStr (gen_switch_from_attribs
                                       "fixity"
                                       "primOpFixity" p_o_specs)

162 163 164 165 166 167 168 169 170
                      "--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)

171 172 173 174 175 176 177 178 179 180 181 182
                      "--primop-vector-uniques" 
                         -> putStr (gen_primop_vector_uniques p_o_specs)

                      "--primop-vector-tys" 
                         -> putStr (gen_primop_vector_tys p_o_specs)

                      "--primop-vector-tys-exports" 
                         -> putStr (gen_primop_vector_tys_exports p_o_specs)

                      "--primop-vector-tycons" 
                         -> putStr (gen_primop_vector_tycons p_o_specs)

183 184
                      "--make-haskell-wrappers" 
                         -> putStr (gen_wrappers p_o_specs)
dterei's avatar
dterei committed
185
                        
Dinko Tenev's avatar
Dinko Tenev committed
186 187 188
                      "--make-haskell-source" 
                         -> putStr (gen_hs_source p_o_specs)

dterei's avatar
dterei committed
189 190
                      "--make-latex-doc"
                         -> 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 197 198 199 200
known_args 
   = [ "--data-decl",
       "--has-side-effects",
       "--out-of-line",
       "--commutable",
201
       "--code-size",
202 203
       "--can-fail",
       "--strictness",
204
       "--fixity",
205 206 207
       "--primop-primop-info",
       "--primop-tag",
       "--primop-list",
208 209 210 211
       "--primop-vector-uniques",
       "--primop-vector-tys",
       "--primop-vector-tys-exports",
       "--primop-vector-tycons",
apt's avatar
apt committed
212
       "--make-haskell-wrappers",
Dinko Tenev's avatar
Dinko Tenev committed
213
       "--make-haskell-source",
apt's avatar
apt committed
214
       "--make-latex-doc"
215 216 217 218 219 220
     ]

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

221
gen_hs_source :: Info -> String
222
gen_hs_source (Info defaults entries) =
223 224 225 226 227 228
       "{-\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"
229
        ++ (replicate 77 '-' ++ "\n") -- For 80-col cleanliness
dterei's avatar
dterei committed
230 231 232
        ++ "-- |\n"
        ++ "-- Module      :  GHC.Prim\n"
        ++ "-- \n"
Gabor Greif's avatar
Gabor Greif committed
233
        ++ "-- Maintainer  :  ghc-devs@haskell.org\n"
dterei's avatar
dterei committed
234 235 236 237 238 239
        ++ "-- Stability   :  internal\n"
        ++ "-- Portability :  non-portable (GHC extensions)\n"
        ++ "--\n"
        ++ "-- GHC\'s primitive types and operations.\n"
        ++ "-- Use GHC.Exts from the base package instead of importing this\n"
        ++ "-- module directly.\n"
240 241 242 243 244 245 246
        ++ "--\n"
        ++ (replicate 77 '-' ++ "\n") -- For 80-col cleanliness
        ++ "{-# LANGUAGE Unsafe #-}\n"
        ++ "{-# LANGUAGE MagicHash #-}\n"
        ++ "{-# LANGUAGE MultiParamTypeClasses #-}\n"
        ++ "{-# LANGUAGE NoImplicitPrelude #-}\n"
        ++ "{-# LANGUAGE UnboxedTuples #-}\n"
247

248 249 250 251 252 253
        ++ "{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}\n"
                -- We generate a binding for coerce, like
                --   coerce :: Coercible a b => a -> b
                --   coerce = let x = x in x
                -- and we don't want a complaint that the constraint is redundant
                -- Remember, this silly file is only for Haddock's consumption
254

dterei's avatar
dterei committed
255
        ++ "module GHC.Prim (\n"
256
        ++ unlines (map (("        " ++) . hdr) entries')
dterei's avatar
dterei committed
257
        ++ ") where\n"
258 259
    ++ "\n"
    ++ "{-\n"
dterei's avatar
dterei committed
260
        ++ unlines (map opt defaults)
261
    ++ "-}\n"
262
    ++ "import GHC.Types (Coercible)\n"
263 264 265 266 267 268 269 270 271 272 273 274 275 276 277

    ++ "default ()"  -- If we don't say this then the default type include Integer
                     -- so that runs off and loads modules that are not part of
                     -- pacakge ghc-prim at all.  And that in turn somehow ends up
                     -- with Declaration for $fEqMaybe:
                     --       attempting to use module ‘GHC.Classes’
                     --       (libraries/ghc-prim/./GHC/Classes.hs) which is not loaded
                     -- coming from LoadIface.homeModError
                     -- I'm not sure precisely why; but I *am* sure that we don't need
                     -- any type-class defaulting; and it's clearly wrong to need
                     -- the base package when haddocking ghc-prim

       -- Now the main payload
    ++ unlines (concatMap ent entries') ++ "\n\n\n"

278 279 280
     where entries' = concatMap desugarVectorSpec entries

           opt (OptionFalse n)    = n ++ " = False"
dterei's avatar
dterei committed
281 282
           opt (OptionTrue n)     = n ++ " = True"
           opt (OptionString n v) = n ++ " = { " ++ v ++ "}"
Simon Marlow's avatar
Simon Marlow committed
283
           opt (OptionInteger n v) = n ++ " = " ++ show v
284
           opt (OptionVector _)    = ""
285
           opt (OptionFixity mf) = "fixity" ++ " = " ++ show mf
Dinko Tenev's avatar
Dinko Tenev committed
286

287 288 289 290 291 292 293 294 295 296 297 298 299 300 301
           hdr s@(Section {})                                    = sec s
           hdr (PrimOpSpec { name = n })                         = wrapOp n ++ ","
           hdr (PrimVecOpSpec { name = n })                      = wrapOp n ++ ","
           hdr (PseudoOpSpec { name = n })                       = wrapOp n ++ ","
           hdr (PrimTypeSpec { ty = TyApp (TyCon n) _ })         = wrapTy n ++ ","
           hdr (PrimTypeSpec {})                                 = error $ "Illegal type spec"
           hdr (PrimVecTypeSpec { ty = TyApp (VecTyCon n _) _ }) = wrapTy n ++ ","
           hdr (PrimVecTypeSpec {})                              = error $ "Illegal type spec"

           ent   (Section {})         = []
           ent o@(PrimOpSpec {})      = spec o
           ent o@(PrimVecOpSpec {})   = spec o
           ent o@(PrimTypeSpec {})    = spec o
           ent o@(PrimVecTypeSpec {}) = spec o
           ent o@(PseudoOpSpec {})    = spec o
Dinko Tenev's avatar
Dinko Tenev committed
302

dterei's avatar
dterei committed
303 304
           sec s = "\n-- * " ++ escape (title s) ++ "\n"
                        ++ (unlines $ map ("-- " ++ ) $ lines $ unlatex $ escape $ "|" ++ desc s) ++ "\n"
Dinko Tenev's avatar
Dinko Tenev committed
305

dterei's avatar
dterei committed
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
dterei's avatar
dterei committed
312
                        PseudoOpSpec { name = n, ty = t } ->
313
                            prim_decl n t
dterei's avatar
dterei committed
314
                        PrimTypeSpec { ty = t }   ->
315
                            [ "data " ++ pprTy t ]
316 317
                        PrimVecTypeSpec { ty = t }   ->
                            [ "data " ++ pprTy t ]
dterei's avatar
dterei committed
318 319 320 321 322 323
                        Section { } -> []

                   comm = case (desc o) of
                        [] -> ""
                        d -> "\n" ++ (unlines $ map ("-- " ++ ) $ lines $ unlatex $ escape $ "|" ++ d)

324 325 326 327 328
           prim_fixity n options = [ pprFixity fixity n | OptionFixity (Just fixity) <- options ]

           prim_decl n t = [ wrapOp n ++ " :: " ++ pprTy t,
                             wrapOp n ++ " = " ++ wrapOpRhs n ]

dterei's avatar
dterei committed
329 330
           wrapOp nm | isAlpha (head nm) = nm
                     | otherwise         = "(" ++ nm ++ ")"
331

dterei's avatar
dterei committed
332 333
           wrapTy nm | isAlpha (head nm) = nm
                     | otherwise         = "(" ++ nm ++ ")"
334 335 336 337 338

           wrapOpRhs "tagToEnum#" = "let x = x in x"
           wrapOpRhs nm           = wrapOp nm
              -- Special case for tagToEnum#: see Note [Placeholder declarations]

dterei's avatar
dterei committed
339 340 341 342 343 344 345 346 347 348 349 350 351
           unlatex s = case s of
                '\\':'t':'e':'x':'t':'t':'t':'{':cs -> markup "@" "@" cs
                '{':'\\':'t':'t':cs -> markup "@" "@" cs
                '{':'\\':'i':'t':cs -> markup "/" "/" cs
                c : cs -> c : unlatex cs
                [] -> []
           markup s t xs = s ++ mk (dropWhile isSpace xs)
                where mk ""        = t
                      mk ('\n':cs) = ' ' : mk cs
                      mk ('}':cs)  = t ++ unlatex cs
                      mk (c:cs)    = c : mk cs
           escape = concatMap (\c -> if c `elem` special then '\\':c:[] else c:[])
                where special = "/'`\"@<"
Dinko Tenev's avatar
Dinko Tenev committed
352

353 354
           pprFixity (Fixity i d) n = pprFixityDir d ++ " " ++ show i ++ " " ++ n

355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375
{- Note [Placeholder declarations]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We are generating fake declarations for things in GHC.Prim, just to
keep GHC's renamer and typechecker happy enough for what Haddock
needs.  Our main plan is to say
        foo :: <type>
        foo = foo
We have to silence GHC's complaints about unboxed-top-level declarations
with an ad-hoc fix in TcBinds: see Note [Compiling GHC.Prim] in TcBinds.

That works for all the primitive functions except tagToEnum#.
If we generate the binding
        tagToEnum# = tagToEnum#
GHC will complain about "tagToEnum# must appear applied to one argument".
We could hack GHC to silence this complaint when compiling GHC.Prim,
but it seems easier to generate
        tagToEnum# = let x = x in x
We don't do this for *all* bindings because for ones with an unboxed
RHS we would get other complaints (e.g.can't unify "*" with "#").
-}

Ian Lynagh's avatar
Ian Lynagh committed
376
pprTy :: Ty -> String
377 378 379
pprTy = pty
    where
          pty (TyF t1 t2) = pbty t1 ++ " -> " ++ pty t2
380
          pty (TyC t1 t2) = pbty t1 ++ " => " ++ pty t2
381
          pty t      = pbty t
382
          pbty (TyApp tc ts) = show tc ++ concat (map (' ' :) (map paty ts))
383 384 385 386 387 388 389
          pbty (TyUTup ts)   = "(# "
                            ++ concat (intersperse "," (map pty ts))
                            ++ " #)"
          pbty t             = paty t

          paty (TyVar tv)    = tv
          paty t             = "(" ++ pty t ++ ")"
390

391
gen_latex_doc :: Info -> String
apt's avatar
apt committed
392 393
gen_latex_doc (Info defaults entries)
   = "\\primopdefaults{" 
dterei's avatar
dterei committed
394 395
         ++ mk_options defaults
         ++ "}\n"
apt's avatar
apt committed
396
     ++ (concat (map mk_entry entries))
397
     where mk_entry (PrimOpSpec {cons=constr,name=n,ty=t,cat=c,desc=d,opts=o}) =
dterei's avatar
dterei committed
398 399 400 401 402 403 404 405 406 407
                 "\\primopdesc{" 
                 ++ 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
                 ++ "}\n"
408 409
           mk_entry (PrimVecOpSpec {}) =
                 ""
410
           mk_entry (Section {title=ti,desc=d}) =
dterei's avatar
dterei committed
411 412 413
                 "\\primopsection{" 
                 ++ latex_encode ti ++ "}{"
                 ++ d ++ "}\n"
414
           mk_entry (PrimTypeSpec {ty=t,desc=d,opts=o}) =
dterei's avatar
dterei committed
415 416 417 418 419 420
                 "\\primtypespec{"
                 ++ latex_encode (mk_source_ty t) ++ "}{"
                 ++ latex_encode (mk_core_ty t) ++ "}{"
                 ++ d ++ "}{"
                 ++ mk_options o
                 ++ "}\n"
421 422
           mk_entry (PrimVecTypeSpec {}) =
                 ""
423
           mk_entry (PseudoOpSpec {name=n,ty=t,desc=d,opts=o}) =
dterei's avatar
dterei committed
424 425 426 427 428 429 430 431 432
                 "\\pseudoopspec{"
                 ++ latex_encode (zencode n) ++ "}{"
                 ++ latex_encode (mk_source_ty t) ++ "}{"
                 ++ latex_encode (mk_core_ty t) ++ "}{"
                 ++ d ++ "}{"
                 ++ mk_options o
                 ++ "}\n"
           mk_source_ty typ = pty typ
             where pty (TyF t1 t2) = pbty t1 ++ " -> " ++ pty t2
433
                   pty (TyC t1 t2) = pbty t1 ++ " => " ++ pty t2
dterei's avatar
dterei committed
434
                   pty t = pbty t
435
                   pbty (TyApp tc ts) = show tc ++ (concat (map (' ':) (map paty ts)))
dterei's avatar
dterei committed
436 437 438 439 440 441 442
                   pbty (TyUTup ts) = "(# " ++ (concat (intersperse "," (map pty ts))) ++ " #)"
                   pbty t = paty t
                   paty (TyVar tv) = tv
                   paty t = "(" ++ pty t ++ ")"
           
           mk_core_ty typ = foralls ++ (pty typ)
             where pty (TyF t1 t2) = pbty t1 ++ " -> " ++ pty t2
443
                   pty (TyC t1 t2) = pbty t1 ++ " => " ++ pty t2
dterei's avatar
dterei committed
444
                   pty t = pbty t
445
                   pbty (TyApp tc ts) = (zencode (show tc)) ++ (concat (map (' ':) (map paty ts)))
dterei's avatar
dterei committed
446 447 448
                   pbty (TyUTup ts) = (zencode (utuplenm (length ts))) ++ (concat ((map (' ':) (map paty ts))))
                   pbty t = paty t
                   paty (TyVar tv) = zencode tv
449
                   paty (TyApp tc []) = zencode (show tc)
dterei's avatar
dterei committed
450 451 452 453 454 455 456 457 458
                   paty t = "(" ++ pty t ++ ")"
                   utuplenm 1 = "(# #)"
                   utuplenm n = "(#" ++ (replicate (n-1) ',') ++ "#)"
                   foralls = if tvars == [] then "" else "%forall " ++ (tbinds tvars)
                   tvars = tvars_of typ
                   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
459
           tvars_of (TyC t1 t2) = tvars_of t1 `union` tvars_of t2
dterei's avatar
dterei committed
460 461 462 463
           tvars_of (TyApp _ ts) = foldl union [] (map tvars_of ts)
           tvars_of (TyUTup ts) = foldr union [] (map tvars_of ts)
           tvars_of (TyVar tv) = [tv]
           
464
           mk_options o =
dterei's avatar
dterei committed
465 466 467 468 469 470
             "\\primoptions{"
              ++ mk_has_side_effects o ++ "}{"
              ++ mk_out_of_line o ++ "}{"
              ++ mk_commutable o ++ "}{"
              ++ mk_needs_wrapper o ++ "}{"
              ++ mk_can_fail o ++ "}{"
471
              ++ mk_fixity o ++ "}{"
dterei's avatar
dterei committed
472 473 474 475 476 477 478 479 480 481 482 483 484 485
              ++ latex_encode (mk_strictness o) ++ "}{"
              ++ "}"

           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."

           mk_bool_opt o opt_name if_true if_false =
             case lookup_attrib opt_name o of
               Just (OptionTrue _) -> if_true
               Just (OptionFalse _) -> if_false
               Just (OptionString _ _) -> error "String value for boolean option"
Simon Marlow's avatar
Simon Marlow committed
486
               Just (OptionInteger _ _) -> error "Integer value for boolean option"
487
               Just (OptionFixity _) -> error "Fixity value for boolean option"
488
               Just (OptionVector _) -> error "vector template for boolean option"
Simon Marlow's avatar
Simon Marlow committed
489
               Nothing -> ""
dterei's avatar
dterei committed
490 491 492 493
           
           mk_strictness o = 
             case lookup_attrib "strictness" o of
               Just (OptionString _ s) -> s  -- for now
494
               Just _ -> error "Wrong value for strictness"
dterei's avatar
dterei committed
495 496
               Nothing -> "" 

497 498 499 500 501
           mk_fixity o = case lookup_attrib "fixity" o of
             Just (OptionFixity (Just (Fixity i d)))
               -> pprFixityDir d ++ " " ++ show i
             _ -> ""

dterei's avatar
dterei committed
502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563
           zencode xs =
             case maybe_tuple xs of
                Just n  -> n            -- Tuples go to Z2T etc
                Nothing -> concat (map encode_ch xs)
             where
               maybe_tuple "(# #)" = Just("Z1H")
               maybe_tuple ('(' : '#' : cs) = case count_commas (0::Int) cs of
                                                (n, '#' : ')' : _) -> Just ('Z' : shows (n+1) "H")
                                                _                  -> Nothing
               maybe_tuple "()" = Just("Z0T")
               maybe_tuple ('(' : cs)       = case count_commas (0::Int) cs of
                                                (n, ')' : _) -> Just ('Z' : shows (n+1) "T")
                                                _            -> Nothing
               maybe_tuple _                 = Nothing
               
               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)
apt's avatar
apt committed
564

565
gen_wrappers :: Info -> String
566
gen_wrappers (Info _ entries)
567
   = "{-# LANGUAGE MagicHash, NoImplicitPrelude, UnboxedTuples #-}\n"
dterei's avatar
dterei committed
568 569
        -- Dependencies on Prelude must be explicit in libraries/base, but we
        -- don't need the Prelude here so we add NoImplicitPrelude.
570
     ++ "module GHC.PrimopWrappers where\n" 
571
     ++ "import qualified GHC.Prim\n" 
Ian Lynagh's avatar
Ian Lynagh committed
572
     ++ "import GHC.Tuple ()\n"
573 574
     ++ "import GHC.Prim (" ++ types ++ ")\n"
     ++ unlines (concatMap f specs)
575
     where
576 577 578
        specs = filter (not.dodgy) $
                filter (not.is_llvm_only) $
                filter is_primop entries
579
        tycons = foldr union [] $ map (tyconsIn . ty) specs
580 581
        tycons' = filter (`notElem` [TyCon "()", TyCon "Bool"]) tycons
        types = concat $ intersperse ", " $ map show tycons'
582 583
        f spec = let args = map (\n -> "a" ++ show n) [1 .. arity (ty spec)]
                     src_name = wrap (name spec)
584 585 586 587 588
                     lhs = src_name ++ " " ++ unwords args
                     rhs = "(GHC.Prim." ++ name spec ++ ") " ++ unwords args
                 in ["{-# NOINLINE " ++ src_name ++ " #-}",
                     src_name ++ " :: " ++ pprTy (ty spec),
                     lhs ++ " = " ++ rhs]
589 590 591 592 593
        wrap nm | isLower (head nm) = nm
                | otherwise = "(" ++ nm ++ ")"

        dodgy spec
           = name spec `elem` 
594 595 596 597
             [-- tagToEnum# is really magical, and can't have
              -- a wrapper since its implementation depends on
              -- the type of its result
              "tagToEnum#"
598 599
             ]

gmainland's avatar
gmainland committed
600 601 602 603 604
        is_llvm_only :: Entry -> Bool
        is_llvm_only entry =
            case lookup_attrib "llvm_only" (opts entry) of
              Just (OptionTrue _) -> True
              _                   -> False
605

606
gen_primop_list :: Info -> String
607
gen_primop_list (Info _ entries)
608
   = unlines (
apt's avatar
apt committed
609
        [      "   [" ++ cons first       ]
610
        ++
611
        map (\p -> "   , " ++ cons p) rest
612 613
        ++ 
        [     "   ]"     ]
614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665
     ) where (first:rest) = concatMap desugarVectorSpec (filter is_primop entries)

mIN_VECTOR_UNIQUE :: Int
mIN_VECTOR_UNIQUE = 300

gen_primop_vector_uniques :: Info -> String
gen_primop_vector_uniques (Info _ entries)
   = unlines $
     concatMap mkVecUnique (specs `zip` [mIN_VECTOR_UNIQUE..])
  where
    specs = concatMap desugarVectorSpec (filter is_vector (filter is_primtype entries))

    mkVecUnique :: (Entry, Int) -> [String]
    mkVecUnique (i, unique) =
        [ key_id ++ " :: Unique"
        , key_id ++ " = mkPreludeTyConUnique " ++ show unique
        ]
      where
        key_id = prefix i ++ "PrimTyConKey"

gen_primop_vector_tys :: Info -> String
gen_primop_vector_tys (Info _ entries)
   = unlines $
     concatMap mkVecTypes specs
  where
    specs = concatMap desugarVectorSpec (filter is_vector (filter is_primtype entries))

    mkVecTypes :: Entry -> [String]
    mkVecTypes i =
        [ name_id ++ " :: Name"
        , name_id ++ " = mkPrimTc (fsLit \"" ++ pprTy (ty i) ++ "\") " ++ key_id ++ " " ++ tycon_id
        , ty_id ++ " :: Type"
        , ty_id ++ " = mkTyConTy " ++ tycon_id
        , tycon_id ++ " :: TyCon"
        , tycon_id ++ " = pcPrimTyCon0 " ++ name_id ++
                      " (VecRep " ++ show (veclen i) ++ " " ++ elemrep i ++ ")"
        ]
      where
        key_id   = prefix i ++ "PrimTyConKey"
        name_id  = prefix i ++ "PrimTyConName"
        ty_id    = prefix i ++ "PrimTy"
        tycon_id = prefix i ++ "PrimTyCon"

gen_primop_vector_tys_exports :: Info -> String
gen_primop_vector_tys_exports (Info _ entries)
   = unlines $
    map mkVecTypes specs
  where
    specs = concatMap desugarVectorSpec (filter is_vector (filter is_primtype entries))

    mkVecTypes :: Entry -> String
    mkVecTypes i =
666
        "        " ++ ty_id ++ ", " ++ tycon_id ++ ","
667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682
      where
        ty_id    = prefix i ++ "PrimTy"
        tycon_id = prefix i ++ "PrimTyCon"

gen_primop_vector_tycons :: Info -> String
gen_primop_vector_tycons (Info _ entries)
   = unlines $
     map mkVecTypes specs
  where
    specs = concatMap desugarVectorSpec (filter is_vector (filter is_primtype entries))

    mkVecTypes :: Entry -> String
    mkVecTypes i =
        "    , " ++ tycon_id
      where
        tycon_id = prefix i ++ "PrimTyCon"
683

684
gen_primop_tag :: Info -> String
685
gen_primop_tag (Info _ entries)
686 687
   = unlines (max_def_type : max_def :
              tagOf_type : zipWith f primop_entries [1 :: Int ..])
688
     where
689
        primop_entries = concatMap desugarVectorSpec $ filter is_primop entries
690 691
        tagOf_type = "primOpTag :: PrimOp -> Int"
        f i n = "primOpTag " ++ cons i ++ " = " ++ show n
692 693
        max_def_type = "maxPrimOpTag :: Int"
        max_def      = "maxPrimOpTag = " ++ show (length primop_entries)
694

695
gen_data_decl :: Info -> String
696 697 698 699 700 701 702 703 704 705 706
gen_data_decl (Info _ entries) =
    "data PrimOp\n   = " ++ head conss ++ "\n"
     ++ unlines (map ("   | "++) (tail conss))
  where
    conss = map genCons (filter is_primop entries)
            
    genCons :: Entry -> String
    genCons entry =
        case vecOptions entry of
          [] -> cons entry
          _  -> cons entry ++ " PrimOpVecCat Length Width"
707 708

gen_switch_from_attribs :: String -> String -> Info -> String
apt's avatar
apt committed
709
gen_switch_from_attribs attrib_name fn_name (Info defaults entries)
710
   = let defv = lookup_attrib attrib_name defaults
711
         alternatives = catMaybes (map mkAlt (filter is_primop entries))
712 713 714

         getAltRhs (OptionFalse _)    = "False"
         getAltRhs (OptionTrue _)     = "True"
715
         getAltRhs (OptionInteger _ i) = show i
716
         getAltRhs (OptionString _ s) = s
717
         getAltRhs (OptionVector _) = "True"
718
         getAltRhs (OptionFixity mf) = show mf
719 720 721 722

         mkAlt po
            = case lookup_attrib attrib_name (opts po) of
                 Nothing -> Nothing
723 724 725
                 Just xx -> case vecOptions po of
                              [] -> Just (fn_name ++ " " ++ cons po ++ " = " ++ getAltRhs xx)
                              _  -> Just (fn_name ++ " (" ++ cons po ++ " _ _ _) = " ++ getAltRhs xx)
726 727 728 729 730

     in
         case defv of
            Nothing -> error ("gen_switch_from: " ++ attrib_name)
            Just xx 
731
               -> unlines alternatives
732
                  ++ fn_name ++ " _ = " ++ getAltRhs xx ++ "\n"
733 734 735 736 737

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

738
gen_primop_info :: Info -> String
739
gen_primop_info (Info _ entries)
740
   = unlines (map mkPOItext (concatMap desugarVectorSpec (filter is_primop entries)))
741

742
mkPOItext :: Entry -> String
743 744
mkPOItext i = mkPOI_LHS_text i ++ mkPOI_RHS_text i

745
mkPOI_LHS_text :: Entry -> String
746 747 748
mkPOI_LHS_text i
   = "primOpInfo " ++ cons i ++ " = "

749
mkPOI_RHS_text :: Entry -> String
750 751 752 753
mkPOI_RHS_text i
   = case cat i of
        Compare 
           -> case ty i of
754
                 TyF t1 (TyF _ _) 
755
                    -> "mkCompare " ++ sl_name i ++ ppType t1
756
                 _ -> error "Type error in comparison op"
757 758
        Monadic
           -> case ty i of
759
                 TyF t1 _
760
                    -> "mkMonadic " ++ sl_name i ++ ppType t1
761
                 _ -> error "Type error in monadic op"
762 763
        Dyadic
           -> case ty i of
764
                 TyF t1 (TyF _ _)
765
                    -> "mkDyadic " ++ sl_name i ++ ppType t1
766
                 _ -> error "Type error in dyadic op"
767 768 769 770 771 772 773 774
        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 ++ ")"
775

776
sl_name :: Entry -> String
777
sl_name i = "(fsLit \"" ++ name i ++ "\") "
778

779
ppTyVar :: String -> String
780 781 782 783
ppTyVar "a" = "alphaTyVar"
ppTyVar "b" = "betaTyVar"
ppTyVar "c" = "gammaTyVar"
ppTyVar "s" = "deltaTyVar"
784
ppTyVar "o" = "levity1TyVar, openAlphaTyVar"
785
ppTyVar _   = error "Unknown type var"
786

787
ppType :: Ty -> String
788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806
ppType (TyApp (TyCon "Any")         []) = "anyTy"
ppType (TyApp (TyCon "Bool")        []) = "boolTy"

ppType (TyApp (TyCon "Int#")        []) = "intPrimTy"
ppType (TyApp (TyCon "Int32#")      []) = "int32PrimTy"
ppType (TyApp (TyCon "Int64#")      []) = "int64PrimTy"
ppType (TyApp (TyCon "Char#")       []) = "charPrimTy"
ppType (TyApp (TyCon "Word#")       []) = "wordPrimTy"
ppType (TyApp (TyCon "Word32#")     []) = "word32PrimTy"
ppType (TyApp (TyCon "Word64#")     []) = "word64PrimTy"
ppType (TyApp (TyCon "Addr#")       []) = "addrPrimTy"
ppType (TyApp (TyCon "Float#")      []) = "floatPrimTy"
ppType (TyApp (TyCon "Double#")     []) = "doublePrimTy"
ppType (TyApp (TyCon "ByteArray#")  []) = "byteArrayPrimTy"
ppType (TyApp (TyCon "RealWorld")   []) = "realWorldTy"
ppType (TyApp (TyCon "ThreadId#")   []) = "threadIdPrimTy"
ppType (TyApp (TyCon "ForeignObj#") []) = "foreignObjPrimTy"
ppType (TyApp (TyCon "BCO#")        []) = "bcoPrimTy"
ppType (TyApp (TyCon "()")          []) = "unitTy"      -- unitTy is TysWiredIn's name for ()
807

808 809 810 811 812 813
ppType (TyVar "a")                      = "alphaTy"
ppType (TyVar "b")                      = "betaTy"
ppType (TyVar "c")                      = "gammaTy"
ppType (TyVar "s")                      = "deltaTy"
ppType (TyVar "o")                      = "openAlphaTy"

814 815 816 817 818 819
ppType (TyApp (TyCon "State#") [x])             = "mkStatePrimTy " ++ ppType x
ppType (TyApp (TyCon "MutVar#") [x,y])          = "mkMutVarPrimTy " ++ ppType x 
                                                   ++ " " ++ ppType y
ppType (TyApp (TyCon "MutableArray#") [x,y])    = "mkMutableArrayPrimTy " ++ ppType x
                                                   ++ " " ++ ppType y
ppType (TyApp (TyCon "MutableArrayArray#") [x]) = "mkMutableArrayArrayPrimTy " ++ ppType x
820 821
ppType (TyApp (TyCon "SmallMutableArray#") [x,y]) = "mkSmallMutableArrayPrimTy " ++ ppType x
                                                    ++ " " ++ ppType y
822 823 824 825
ppType (TyApp (TyCon "MutableByteArray#") [x])  = "mkMutableByteArrayPrimTy " 
                                                   ++ ppType x
ppType (TyApp (TyCon "Array#") [x])             = "mkArrayPrimTy " ++ ppType x
ppType (TyApp (TyCon "ArrayArray#") [])         = "mkArrayArrayPrimTy"
826
ppType (TyApp (TyCon "SmallArray#") [x])        = "mkSmallArrayPrimTy " ++ ppType x
827 828 829 830 831 832 833 834 835


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

ppType (TyApp (TyCon "MVar#") [x,y])     = "mkMVarPrimTy " ++ ppType x 
                                           ++ " " ++ ppType y
ppType (TyApp (TyCon "TVar#") [x,y])     = "mkTVarPrimTy " ++ ppType x 
836
                                           ++ " " ++ ppType y
837 838 839

ppType (TyApp (VecTyCon _ pptc) [])      = pptc

840
ppType (TyUTup ts) = "(mkTupleTy Unboxed " 
841
                     ++ listify (map ppType ts) ++ ")"
842 843

ppType (TyF s d) = "(mkFunTy (" ++ ppType s ++ ") (" ++ ppType d ++ "))"
844
ppType (TyC s d) = "(mkFunTy (" ++ ppType s ++ ") (" ++ ppType d ++ "))"
845 846 847 848

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

849 850 851 852 853
pprFixityDir :: FixityDirection -> String
pprFixityDir InfixN = "infix"
pprFixityDir InfixL = "infixl"
pprFixityDir InfixR = "infixr"

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

857
flatTys :: Ty -> ([Ty],Ty)
858
flatTys (TyF t1 t2) = case flatTys t2 of (ts,t) -> (t1:ts,t)
859
flatTys (TyC t1 t2) = case flatTys t2 of (ts,t) -> (t1:ts,t)
860 861
flatTys other       = ([],other)

862
tvsIn :: Ty -> [TyVar]
863
tvsIn (TyF t1 t2)    = tvsIn t1 ++ tvsIn t2
864
tvsIn (TyC t1 t2)    = tvsIn t1 ++ tvsIn t2
865
tvsIn (TyApp _ tys)  = concatMap tvsIn tys
866 867 868
tvsIn (TyVar tv)     = [tv]
tvsIn (TyUTup tys)   = concatMap tvsIn tys

869 870
tyconsIn :: Ty -> [TyCon]
tyconsIn (TyF t1 t2)    = tyconsIn t1 `union` tyconsIn t2
871
tyconsIn (TyC t1 t2)    = tyconsIn t1 `union` tyconsIn t2
872 873 874 875
tyconsIn (TyApp tc tys) = foldr union [tc] $ map tyconsIn tys
tyconsIn (TyVar _)      = []
tyconsIn (TyUTup tys)   = foldr union [] $ map tyconsIn tys

876
arity :: Ty -> Int
877
arity = length . fst . flatTys