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