ghc/utils/genprimopcode/Main.hs

   1
   2 ------------------------------------------------------------------
   3 -- A primop-table mangling program                              --
   4 ------------------------------------------------------------------
   5
   6 module Main where
   7
   8 import Parsec
   9 import Monad
  10 import Char
  11 import List
  12 import System ( getArgs )
  13 import Maybe ( catMaybes )
  14
  15 main = getArgs >>= \args ->
  16        if length args /= 1 || head args `notElem` known_args
  17        then error ("usage: genprimopcode command < primops.i > ...\n"
  18                    ++ "   where command is one of\n"
  19                    ++ unlines (map ("            "++) known_args)
  20                   )
  21        else
  22        do s <- getContents
  23           let pres = parse pTop "" s
  24           case pres of
  25              Left err -> do putStr "parse error at "
  26                             print err
  27              Right p_o_specs
  28                 -> myseq (sanityTop p_o_specs) (
  29                    case head args of
  30
  31                       "--data-decl"
  32                          -> putStr (gen_data_decl p_o_specs)
  33
  34                       "--has-side-effects"
  35                          -> putStr (gen_switch_from_attribs
  36                                        "has_side_effects"
  37                                        "primOpHasSideEffects" p_o_specs)
  38
  39                       "--out-of-line"
  40                          -> putStr (gen_switch_from_attribs
  41                                        "out_of_line"
  42                                        "primOpOutOfLine" p_o_specs)
  43
  44                       "--commutable"
  45                          -> putStr (gen_switch_from_attribs
  46                                        "commutable"
  47                                        "commutableOp" p_o_specs)
  48
  49                       "--needs-wrapper"
  50                          -> putStr (gen_switch_from_attribs
  51                                        "needs_wrapper"
  52                                        "primOpNeedsWrapper" p_o_specs)
  53
  54                       "--can-fail"
  55                          -> putStr (gen_switch_from_attribs
  56                                        "can_fail"
  57                                        "primOpCanFail" p_o_specs)
  58
  59                       "--strictness"
  60                          -> putStr (gen_switch_from_attribs
  61                                        "strictness"
  62                                        "primOpStrictness" p_o_specs)
  63
  64                       "--usage"
  65                          -> putStr (gen_switch_from_attribs
  66                                        "usage"
  67                                        "primOpUsg" p_o_specs)
  68
  69                       "--primop-primop-info"
  70                          -> putStr (gen_primop_info p_o_specs)
  71
  72                       "--primop-tag"
  73                          -> putStr (gen_primop_tag p_o_specs)
  74
  75                       "--primop-list"
  76                          -> putStr (gen_primop_list p_o_specs)
  77
  78                       "--make-haskell-wrappers"
  79                          -> putStr (gen_wrappers p_o_specs)
  80
  81                       "--make-latex-table"
  82                          -> putStr (gen_latex_table p_o_specs)
  83                    )
  84
  85
  86 known_args
  87    = [ "--data-decl",
  88        "--has-side-effects",
  89        "--out-of-line",
  90        "--commutable",
  91        "--needs-wrapper",
  92        "--can-fail",
  93        "--strictness",
  94        "--usage",
  95        "--primop-primop-info",
  96        "--primop-tag",
  97        "--primop-list",
  98        "--make-haskell-wrappers",
  99        "--make-latex-table"
 100      ]
 101
 102 ------------------------------------------------------------------
 103 -- Code generators -----------------------------------------------
 104 ------------------------------------------------------------------
 105
 106 gen_latex_table (Info defaults pos)
 107    = "\\begin{tabular}{|l|l|}\n"
 108      ++ "\\hline\nName &\t Type\\\\\n\\hline\n"
 109      ++ (concat (map f pos))
 110      ++ "\\end{tabular}"
 111      where
 112        f spec = "@" ++ (encode (name spec)) ++ "@ &\t@" ++ (pty (ty spec)) ++ "@\\\\\n"
 113        encode s = s
 114        pty (TyF t1 t2) = pbty t1 ++ " -> " ++ pty t2
 115        pty t = pbty t
 116        pbty (TyApp tc ts) = (encode tc) ++ (concat (map (' ':) (map paty ts)))
 117        pbty (TyUTup ts) = (mkUtupnm (length ts)) ++ (concat (map (' ':) (map paty ts)))
 118        pbty t = paty t
 119        paty (TyVar tv) = encode tv
 120        paty t = "(" ++ pty t ++ ")"
 121        mkUtupnm 1 = "ZL#z32U#ZR"
 122        mkUtupnm n = "Z" ++ (show (n-1)) ++ "U"
 123
 124 gen_wrappers (Info defaults pos)
 125    = "module PrelPrimopWrappers where\n"
 126      ++ "import qualified PrelGHC\n"
 127      ++ unlines (map f (filter (not.dodgy) pos))
 128      where
 129         f spec = let args = map (\n -> "a" ++ show n) [1 .. arity (ty spec)]
 130                      src_name = wrap (name spec)
 131                  in "{-# NOINLINE " ++ src_name ++ " #-}\n" ++
 132                     src_name ++ " " ++ unwords args
 133                      ++ " = (PrelGHC." ++ name spec ++ ") " ++ unwords args
 134         wrap nm | isLower (head nm) = nm
 135                 | otherwise = "(" ++ nm ++ ")"
 136
 137         dodgy spec
 138            = name spec `elem`
 139              [-- C code generator can't handle these
 140               "seq#",
 141               "tagToEnum#",
 142               -- not interested in parallel support
 143               "par#", "parGlobal#", "parLocal#", "parAt#",
 144               "parAtAbs#", "parAtRel#", "parAtForNow#"
 145              ]
 146
 147
 148 gen_primop_list (Info defaults pos)
 149    = unlines (
 150         [      "   [" ++ cons (head pos)       ]
 151         ++
 152         map (\pi -> "   , " ++ cons pi) (tail pos)
 153         ++
 154         [     "   ]"     ]
 155      )
 156
 157 gen_primop_tag (Info defaults pos)
 158    = unlines (zipWith f pos [1..])
 159      where
 160         f i n = "tagOf_PrimOp " ++ cons i
 161                 ++ " = _ILIT(" ++ show n ++ ") :: FastInt"
 162
 163 gen_data_decl (Info defaults pos)
 164    = let conss = map cons pos
 165      in  "data PrimOp\n   = " ++ head conss ++ "\n"
 166          ++ unlines (map ("   | "++) (tail conss))
 167
 168 gen_switch_from_attribs :: String -> String -> Info -> String
 169 gen_switch_from_attribs attrib_name fn_name (Info defaults pos)
 170    = let defv = lookup_attrib attrib_name defaults
 171          alts = catMaybes (map mkAlt pos)
 172
 173          getAltRhs (OptionFalse _)    = "False"
 174          getAltRhs (OptionTrue _)     = "True"
 175          getAltRhs (OptionString _ s) = s
 176
 177          mkAlt po
 178             = case lookup_attrib attrib_name (opts po) of
 179                  Nothing -> Nothing
 180                  Just xx -> Just (fn_name ++ " " ++ cons po ++ " = " ++ getAltRhs xx)
 181
 182          lookup_attrib nm [] = Nothing
 183          lookup_attrib nm (a:as)
 184             = if get_attrib_name a == nm then Just a else lookup_attrib nm as
 185      in
 186          case defv of
 187             Nothing -> error ("gen_switch_from: " ++ attrib_name)
 188             Just xx
 189                -> unlines alts
 190                   ++ fn_name ++ " other = " ++ getAltRhs xx ++ "\n"
 191
 192 ------------------------------------------------------------------
 193 -- Create PrimOpInfo text from PrimOpSpecs -----------------------
 194 ------------------------------------------------------------------
 195
 196
 197 gen_primop_info (Info defaults pos)
 198    = unlines (map mkPOItext pos)
 199
 200 mkPOItext i = mkPOI_LHS_text i ++ mkPOI_RHS_text i
 201
 202 mkPOI_LHS_text i
 203    = "primOpInfo " ++ cons i ++ " = "
 204
 205 mkPOI_RHS_text i
 206    = case cat i of
 207         Compare
 208            -> case ty i of
 209                  TyF t1 (TyF t2 td)
 210                     -> "mkCompare " ++ sl_name i ++ ppType t1
 211         Monadic
 212            -> case ty i of
 213                  TyF t1 td
 214                     -> "mkMonadic " ++ sl_name i ++ ppType t1
 215         Dyadic
 216            -> case ty i of
 217                  TyF t1 (TyF t2 td)
 218                     -> "mkDyadic " ++ sl_name i ++ ppType t1
 219         GenPrimOp
 220            -> let (argTys, resTy) = flatTys (ty i)
 221                   tvs = nub (tvsIn (ty i))
 222               in
 223                   "mkGenPrimOp " ++ sl_name i ++ " "
 224                       ++ listify (map ppTyVar tvs) ++ " "
 225                       ++ listify (map ppType argTys) ++ " "
 226                       ++ "(" ++ ppType resTy ++ ")"
 227
 228 sl_name i = "SLIT(\"" ++ name i ++ "\") "
 229
 230 ppTyVar "a" = "alphaTyVar"
 231 ppTyVar "b" = "betaTyVar"
 232 ppTyVar "c" = "gammaTyVar"
 233 ppTyVar "s" = "deltaTyVar"
 234 ppTyVar "o" = "openAlphaTyVar"
 235
 236
 237 ppType (TyApp "Bool"        []) = "boolTy"
 238
 239 ppType (TyApp "Int#"        []) = "intPrimTy"
 240 ppType (TyApp "Int64#"      []) = "int64PrimTy"
 241 ppType (TyApp "Char#"       []) = "charPrimTy"
 242 ppType (TyApp "Word#"       []) = "wordPrimTy"
 243 ppType (TyApp "Word64#"     []) = "word64PrimTy"
 244 ppType (TyApp "Addr#"       []) = "addrPrimTy"
 245 ppType (TyApp "Float#"      []) = "floatPrimTy"
 246 ppType (TyApp "Double#"     []) = "doublePrimTy"
 247 ppType (TyApp "ByteArr#"    []) = "byteArrayPrimTy"
 248 ppType (TyApp "RealWorld"   []) = "realWorldTy"
 249 ppType (TyApp "ThreadId#"   []) = "threadIdPrimTy"
 250 ppType (TyApp "ForeignObj#" []) = "foreignObjPrimTy"
 251 ppType (TyApp "BCO#"        []) = "bcoPrimTy"
 252 ppType (TyApp "Unit"        []) = "unitTy"   -- dodgy
 253
 254
 255 ppType (TyVar "a")               = "alphaTy"
 256 ppType (TyVar "b")               = "betaTy"
 257 ppType (TyVar "c")               = "gammaTy"
 258 ppType (TyVar "s")               = "deltaTy"
 259 ppType (TyVar "o")               = "openAlphaTy"
 260 ppType (TyApp "State#" [x])      = "mkStatePrimTy " ++ ppType x
 261 ppType (TyApp "MutVar#" [x,y])   = "mkMutVarPrimTy " ++ ppType x
 262                                    ++ " " ++ ppType y
 263 ppType (TyApp "MutArr#" [x,y])   = "mkMutableArrayPrimTy " ++ ppType x
 264                                    ++ " " ++ ppType y
 265
 266 ppType (TyApp "MutByteArr#" [x]) = "mkMutableByteArrayPrimTy "
 267                                    ++ ppType x
 268
 269 ppType (TyApp "Array#" [x])      = "mkArrayPrimTy " ++ ppType x
 270
 271
 272 ppType (TyApp "Weak#"  [x])      = "mkWeakPrimTy " ++ ppType x
 273 ppType (TyApp "StablePtr#"  [x])      = "mkStablePtrPrimTy " ++ ppType x
 274 ppType (TyApp "StableName#"  [x])      = "mkStableNamePrimTy " ++ ppType x
 275
 276 ppType (TyApp "MVar#" [x,y])     = "mkMVarPrimTy " ++ ppType x
 277                                    ++ " " ++ ppType y
 278 ppType (TyUTup ts)               = "(mkTupleTy Unboxed " ++ show (length ts)
 279                                    ++ " "
 280                                    ++ listify (map ppType ts) ++ ")"
 281
 282 ppType (TyF s d) = "(mkFunTy (" ++ ppType s ++ ") (" ++ ppType d ++ "))"
 283
 284 ppType other
 285    = error ("ppType: can't handle: " ++ show other ++ "\n")
 286
 287 listify :: [String] -> String
 288 listify ss = "[" ++ concat (intersperse ", " ss) ++ "]"
 289
 290 flatTys (TyF t1 t2) = case flatTys t2 of (ts,t) -> (t1:ts,t)
 291 flatTys other       = ([],other)
 292
 293 tvsIn (TyF t1 t2)    = tvsIn t1 ++ tvsIn t2
 294 tvsIn (TyApp tc tys) = concatMap tvsIn tys
 295 tvsIn (TyVar tv)     = [tv]
 296 tvsIn (TyUTup tys)   = concatMap tvsIn tys
 297
 298 arity = length . fst . flatTys
 299
 300
 301 ------------------------------------------------------------------
 302 -- Abstract syntax -----------------------------------------------
 303 ------------------------------------------------------------------
 304
 305 -- info for all primops; the totality of the info in primops.txt
 306 data Info
 307    = Info [Option] [PrimOpSpec]   -- defaults, primops
 308      deriving Show
 309
 310 -- info for one primop
 311 data PrimOpSpec
 312     = PrimOpSpec { cons  :: String,      -- PrimOp name
 313                    name  :: String,      -- name in prog text
 314                    ty    :: Ty,          -- type
 315                    cat   :: Category,    -- category
 316                    opts  :: [Option] }   -- default overrides
 317     deriving Show
 318
 319 -- a binding of property to value
 320 data Option
 321    = OptionFalse  String          -- name = False
 322    | OptionTrue   String          -- name = True
 323    | OptionString String String   -- name = { ... unparsed stuff ... }
 324      deriving Show
 325
 326 -- categorises primops
 327 data Category
 328    = Dyadic | Monadic | Compare | GenPrimOp
 329      deriving Show
 330
 331 -- types
 332 data Ty
 333    = TyF    Ty Ty
 334    | TyApp  TyCon [Ty]
 335    | TyVar  TyVar
 336    | TyUTup [Ty]   -- unboxed tuples; just a TyCon really,
 337                    -- but convenient like this
 338    deriving (Eq,Show)
 339
 340 type TyVar = String
 341 type TyCon = String
 342
 343
 344 ------------------------------------------------------------------
 345 -- Sanity checking -----------------------------------------------
 346 ------------------------------------------------------------------
 347
 348 {- Do some simple sanity checks:
 349     * all the default field names are unique
 350     * for each PrimOpSpec, all override field names are unique
 351     * for each PrimOpSpec, all overriden field names
 352           have a corresponding default value
 353     * that primop types correspond in certain ways to the
 354       Category: eg if Comparison, the type must be of the form
 355          T -> T -> Bool.
 356    Dies with "error" if there's a problem, else returns ().
 357 -}
 358 myseq () x = x
 359 myseqAll (():ys) x = myseqAll ys x
 360 myseqAll []      x = x
 361
 362 sanityTop :: Info -> ()
 363 sanityTop (Info defs primops)
 364    = let opt_names = map get_attrib_name defs
 365      in
 366      if   length opt_names /= length (nub opt_names)
 367      then error ("non-unique default attribute names: " ++ show opt_names ++ "\n")
 368      else myseqAll (map (sanityPrimOp opt_names) primops) ()
 369
 370 sanityPrimOp def_names p
 371    = let p_names = map get_attrib_name (opts p)
 372          p_names_ok
 373             = length p_names == length (nub p_names)
 374               && all (`elem` def_names) p_names
 375          ty_ok = sane_ty (cat p) (ty p)
 376      in
 377          if   not p_names_ok
 378          then error ("attribute names are non-unique or have no default in\n" ++
 379                      "info for primop " ++ cons p ++ "\n")
 380          else
 381          if   not ty_ok
 382          then error ("type of primop " ++ cons p ++ " doesn't make sense w.r.t" ++
 383                      " category " ++ show (cat p) ++ "\n")
 384          else ()
 385
 386 sane_ty Compare (TyF t1 (TyF t2 td))
 387    | t1 == t2 && td == TyApp "Bool" []  = True
 388 sane_ty Monadic (TyF t1 td)
 389    | t1 == td  = True
 390 sane_ty Dyadic (TyF t1 (TyF t2 td))
 391    | t1 == t2 && t2 == t2  = True
 392 sane_ty GenPrimOp any_old_thing
 393    = True
 394 sane_ty _ _
 395    = False
 396
 397 get_attrib_name (OptionFalse nm) = nm
 398 get_attrib_name (OptionTrue nm)  = nm
 399 get_attrib_name (OptionString nm _) = nm
 400
 401 ------------------------------------------------------------------
 402 -- The parser ----------------------------------------------------
 403 ------------------------------------------------------------------
 404
 405 -- Due to lack of proper lexing facilities, a hack to zap any
 406 -- leading comments
 407 pTop :: Parser Info
 408 pTop = then4 (\_ ds ss _ -> Info ds ss)
 409              pCommentAndWhitespace pDefaults (many pPrimOpSpec)
 410              (lit "thats_all_folks")
 411
 412 pDefaults :: Parser [Option]
 413 pDefaults = then2 sel22 (lit "defaults") (many pOption)
 414
 415 pOption :: Parser Option
 416 pOption
 417    = alts [
 418         then3 (\nm eq ff -> OptionFalse nm)  pName (lit "=") (lit "False"),
 419         then3 (\nm eq tt -> OptionTrue nm)   pName (lit "=") (lit "True"),
 420         then3 (\nm eq zz -> OptionString nm zz)
 421               pName (lit "=") pStuffBetweenBraces
 422      ]
 423
 424 pPrimOpSpec :: Parser PrimOpSpec
 425 pPrimOpSpec
 426    = then6 (\_ c n k t o -> PrimOpSpec { cons = c, name = n, ty = t,
 427                                          cat = k, opts = o } )
 428            (lit "primop") pConstructor stringLiteral
 429            pCategory pType pOptions
 430
 431 pOptions :: Parser [Option]
 432 pOptions = optdef [] (then2 sel22 (lit "with") (many pOption))
 433
 434 pCategory :: Parser Category
 435 pCategory
 436    = alts [
 437         apply (const Dyadic)    (lit "Dyadic"),
 438         apply (const Monadic)   (lit "Monadic"),
 439         apply (const Compare)   (lit "Compare"),
 440         apply (const GenPrimOp) (lit "GenPrimOp")
 441      ]
 442
 443 pStuffBetweenBraces
 444     = lexeme (then3 sel23
 445                     (char '{') (many (satisfy (not . (== '}'))))
 446                     (char '}'))
 447
 448 -------------------
 449 -- Parsing types --
 450 -------------------
 451
 452 pType :: Parser Ty
 453 pType = then2 (\t maybe_tt -> case maybe_tt of
 454                                  Just tt -> TyF t tt
 455                                  Nothing -> t)
 456               paT
 457               (opt (then2 sel22 (lit "->") pType))
 458
 459 -- Atomic types
 460 paT = alts [ then2 TyApp pTycon (many ppT),
 461              pUnboxedTupleTy,
 462              then3 sel23 (lit "(") pType (lit ")"),
 463              ppT
 464       ]
 465
 466 -- the magic bit in the middle is:  T (,T)*  so to speak
 467 pUnboxedTupleTy
 468    = then3 (\ _ ts _ -> TyUTup ts)
 469            (lit "(#")
 470            (then2 (:) pType (many (then2 sel22 (lit ",") pType)))
 471            (lit "#)")
 472
 473 -- Primitive types
 474 ppT = alts [apply TyVar pTyvar,
 475             apply (\tc -> TyApp tc []) pTycon
 476            ]
 477
 478 pTyvar       = sat (`notElem` ["primop","with"]) pName
 479 pTycon       = pConstructor
 480 pName        = lexeme (then2 (:) lower (many isIdChar))
 481 pConstructor = lexeme (then2 (:) upper (many isIdChar))
 482
 483 isIdChar = satisfy (`elem` idChars)
 484 idChars  = ['a' .. 'z'] ++ ['A' .. 'Z'] ++ ['0' .. '9'] ++ "#_"
 485
 486 sat pred p
 487    = do x <- try p
 488         if pred x
 489          then return x
 490          else pzero
 491
 492 ------------------------------------------------------------------
 493 -- Helpful additions to Daan's parser stuff ----------------------
 494 ------------------------------------------------------------------
 495
 496 alts [p1]       = try p1
 497 alts (p1:p2:ps) = (try p1) <|> alts (p2:ps)
 498
 499 then2 f p1 p2
 500    = do x1 <- p1 ; x2 <- p2 ; return (f x1 x2)
 501 then3 f p1 p2 p3
 502    = do x1 <- p1 ; x2 <- p2 ; x3 <- p3 ; return (f x1 x2 x3)
 503 then4 f p1 p2 p3 p4
 504    = do x1 <- p1 ; x2 <- p2 ; x3 <- p3 ; x4 <- p4 ; return (f x1 x2 x3 x4)
 505 then5 f p1 p2 p3 p4 p5
 506    = do x1 <- p1 ; x2 <- p2 ; x3 <- p3 ; x4 <- p4 ; x5 <- p5
 507         return (f x1 x2 x3 x4 x5)
 508 then6 f p1 p2 p3 p4 p5 p6
 509    = do x1 <- p1 ; x2 <- p2 ; x3 <- p3 ; x4 <- p4 ; x5 <- p5 ; x6 <- p6
 510         return (f x1 x2 x3 x4 x5 x6)
 511 opt p
 512    = (do x <- p; return (Just x)) <|> return Nothing
 513 optdef d p
 514    = (do x <- p; return x) <|> return d
 515
 516 sel12 a b = a
 517 sel22 a b = b
 518 sel23 a b c = b
 519 apply f p = liftM f p
 520
 521 -- Hacks for zapping whitespace and comments, unfortunately needed
 522 -- because Daan won't let us have a lexer before the parser :-(
 523 lexeme  :: Parser p -> Parser p
 524 lexeme p = then2 sel12 p pCommentAndWhitespace
 525
 526 lit :: String -> Parser ()
 527 lit s = apply (const ()) (lexeme (string s))
 528
 529 pCommentAndWhitespace :: Parser ()
 530 pCommentAndWhitespace
 531    = apply (const ()) (many (alts [pLineComment,
 532                                    apply (const ()) (satisfy isSpace)]))
 533      <|>
 534      return ()
 535
 536 pLineComment :: Parser ()
 537 pLineComment
 538    = try (then3 (\_ _ _ -> ()) (string "--") (many (satisfy (/= '\n'))) (char '\n'))
 539
 540 stringLiteral :: Parser String
 541 stringLiteral   = lexeme (
 542                       do { between (char '"')
 543                                    (char '"' <?> "end of string")
 544                                    (many (noneOf "\""))
 545                          }
 546                       <?> "literal string")
 547
 548
 549
 550 ------------------------------------------------------------------
 551 -- end                                                          --
 552 ------------------------------------------------------------------
 553
 554
 555