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