mlnlffigen/ast-to-spec.sml

   1 (* ast-to-spec.sml
   2  * 2005 Matthew Fluet (mfluet@acm.org)
   3  *  Adapted for MLton.
   4  *)
   5
   6 (*
   7  * ast-to-spec.sml - Conversion from CKIT "ast" to a "spec" (see spec.sml).
   8  *
   9  *  (C) 2001, Lucent Technologies, Bell Labs
  10  *
  11  * author: Matthias Blume (blume@research.bell-labs.com)
  12  *)
  13 structure AstToSpec = struct
  14
  15     structure A = Ast
  16     structure B = Bindings
  17
  18     structure SS = StringSet
  19     structure SM = StringMap
  20
  21     datatype context = CONTEXT of { gensym: unit -> string, anon: bool }
  22
  23     exception VoidType
  24     exception Ellipsis
  25     exception Duplicate of string
  26     exception SkipFunction of string
  27
  28     fun bug m = raise Fail ("AstToSpec: bug: " ^ m)
  29     fun err m = raise Fail ("AstToSpec: error: " ^ m)
  30     fun warn m = TextIO.output (TextIO.stdErr, "AstToSpec: warning: " ^ m)
  31
  32     fun build { bundle, sizes: Sizes.sizes, collect_enums,
  33                 cfiles, match, allSU, eshift, gensym_suffix } =
  34     let
  35
  36         val curLoc = ref "?"
  37
  38         fun warnLoc m = warn (concat [!curLoc, ": ", m])
  39
  40         val { ast, tidtab, errorCount, warningCount,
  41               auxiliaryInfo = { aidtab, implicits, env } } = bundle
  42
  43         fun realFunctionDefComing sy = let
  44             fun isTheDef (A.DECL (A.FunctionDef (id, _, _), _, _)) =
  45                 Symbol.equal (#name id, sy)
  46               | isTheDef _ = false
  47         in
  48             List.exists isTheDef ast
  49         end
  50
  51         val srcOf = SourceMap.locToString
  52
  53         fun isThisFile SourceMap.UNKNOWN = false
  54           | isThisFile (SourceMap.LOC { srcFile, ... }) =
  55             List.exists (fn f => f = srcFile) cfiles orelse
  56             match srcFile
  57
  58         fun includedSU (tag, loc) = (allSU orelse isThisFile loc)
  59         fun includedEnum (tag, loc) = isThisFile loc
  60
  61         fun includedTy (n, loc) = isThisFile loc
  62
  63         fun isFunction t = TypeUtil.isFunction tidtab t
  64         fun getFunction t = TypeUtil.getFunction tidtab t
  65         fun getCoreType t = TypeUtil.getCoreType tidtab t
  66
  67         fun constness t =
  68             if TypeUtil.isConst tidtab t then Spec.RO
  69             else case getCoreType t of
  70                      A.Array (_, t) => constness t
  71                    | _ => Spec.RW
  72
  73         val sizerec = { sizes = sizes, err = err, warn = warn, bug = bug }
  74
  75         fun sizeOf t = #bytes (Sizeof.byteSizeOf sizerec tidtab t)
  76
  77         val bytebits = #bits (#char sizes)
  78         val intbits = #bits (#int sizes)
  79         val intalign = #align (#int sizes)
  80
  81         fun getField (m, l) = Sizeof.getField sizerec (m, l)
  82
  83         fun fieldOffsets t =
  84             case Sizeof.fieldOffsets sizerec tidtab t of
  85                 NONE => bug "no field offsets"
  86               | SOME l => l
  87
  88         val structs = ref []
  89         val unions = ref []
  90         val gtys = ref SM.empty
  91         val gvars = ref SM.empty
  92         val gfuns = ref SM.empty
  93         val named_enums = ref SM.empty
  94         val anon_enums = ref SM.empty
  95
  96         val seen_structs = ref SS.empty
  97         val seen_unions = ref SS.empty
  98
  99         val nexttag = ref 0
 100         val tags = Tidtab.uidtab () : (string * bool) Tidtab.uidtab
 101
 102         fun mk_context_td tdname =
 103             let val next = ref 0
 104             in
 105                 CONTEXT
 106                     { gensym =
 107                       fn () => let
 108                              val n = !next
 109                          in
 110                              next := n + 1;
 111                              concat ["'",
 112                                      if n = 0 then "" else Int.toString n,
 113                                      tdname]
 114                          end,
 115                       anon = false }
 116             end
 117
 118         fun mk_context_su (parent_tag, anon) =
 119             let val next = ref 0
 120             in
 121                 CONTEXT { gensym =
 122                           fn () => let
 123                                  val n = !next
 124                              in
 125                                  next := n + 1;
 126                                  concat [parent_tag, "'", Int.toString n]
 127                              end,
 128                           anon = anon }
 129             end
 130
 131         val tl_context =
 132             let val next = ref 0
 133             in
 134                 CONTEXT { gensym =
 135                           fn () => let
 136                                  val n = !next
 137                              in
 138                                  next := n + 1;
 139                                  Int.toString n
 140                              end,
 141                           anon = true }
 142             end
 143
 144         fun tagname (SOME t, _, _) = (t, false)
 145           | tagname (NONE, CONTEXT { gensym, anon }, tid) =
 146             (case Tidtab.find (tags, tid) of
 147                  SOME ta => ta
 148                | NONE => let
 149                      val t = gensym ()
 150                  in
 151                      Tidtab.insert (tags, tid, (t, anon));
 152                      (t, anon)
 153                  end)
 154
 155         fun reported_tagname (t, false) = t
 156           | reported_tagname (t, true) = t ^ gensym_suffix
 157
 158         fun valty C A.Void = raise VoidType
 159           | valty C A.Ellipses = raise Ellipsis
 160           | valty C (A.Qual (q, t)) = valty C t
 161           | valty C (A.Numeric (_, _, A.SIGNED, A.CHAR, _)) = Spec.BASIC Spec.SCHAR
 162           | valty C (A.Numeric (_, _, A.UNSIGNED, A.CHAR, _)) = Spec.BASIC Spec.UCHAR
 163           | valty C (A.Numeric (_, _, A.SIGNED, A.SHORT, _)) = Spec.BASIC Spec.SSHORT
 164           | valty C (A.Numeric (_, _, A.UNSIGNED, A.SHORT, _)) = Spec.BASIC Spec.USHORT
 165           | valty C (A.Numeric (_, _, A.SIGNED, A.INT, _)) = Spec.BASIC Spec.SINT
 166           | valty C (A.Numeric (_, _, A.UNSIGNED, A.INT, _)) = Spec.BASIC Spec.UINT
 167           | valty C (A.Numeric (_, _, A.SIGNED, A.LONG, _)) = Spec.BASIC Spec.SLONG
 168           | valty C (A.Numeric (_, _, A.UNSIGNED, A.LONG, _)) = Spec.BASIC Spec.ULONG
 169           | valty C (A.Numeric (_, _, A.SIGNED, A.LONGLONG, _)) =
 170               Spec.BASIC Spec.SLONGLONG
 171           | valty C (A.Numeric (_, _, A.UNSIGNED, A.LONGLONG, _)) =
 172               Spec.BASIC Spec.ULONGLONG
 173           | valty C (A.Numeric (_, _, _, A.FLOAT, _)) = Spec.BASIC Spec.FLOAT
 174           | valty C (A.Numeric (_, _, _, A.DOUBLE, _)) = Spec.BASIC Spec.DOUBLE
 175           | valty C (A.Numeric (_, _, _, A.LONGDOUBLE, _)) =
 176               Spec.UNIMPLEMENTED "long double"
 177           | valty C (A.Array (NONE, t)) = valty C (A.Pointer t)
 178           | valty C (A.Array (SOME (n, _), t)) =
 179             let val d = Int.fromLarge n
 180             in
 181                 if d < 0 then err "negative dimension"
 182                 else Spec.ARR { t = valty C t, d = d, esz = sizeOf t }
 183             end
 184           | valty C (A.Pointer t) =
 185             (case getCoreType t of
 186                  A.Void => Spec.VOIDPTR
 187                | A.Function f => fptrty C f
 188                | _ => Spec.PTR (cobj C t))
 189           | valty C (A.Function f) = fptrty C f
 190           | valty C (A.StructRef tid) = typeref (tid, Spec.STRUCT, C)
 191           | valty C (A.UnionRef tid) = typeref (tid, Spec.UNION, C)
 192           | valty C (A.EnumRef tid) = typeref (tid, fn t => Spec.ENUM (t, false), C)
 193           | valty C (A.TypeRef tid) =
 194             typeref (tid, fn _ => bug "missing typedef info", C)
 195           | valty C A.Error = err "Error type"
 196
 197         and valty_nonvoid C t = valty C t
 198             handle VoidType => err "void variable type"
 199
 200         and fun_valty_nonvoid C t =
 201             case valty_nonvoid C t of
 202                 Spec.STRUCT tag =>
 203                     raise SkipFunction "struct argument not supported"
 204               | Spec.UNION tag =>
 205                     raise SkipFunction "union argument not supported"
 206               | ty => ty
 207
 208         and typeref (tid, otherwise, C) =
 209             case Tidtab.find (tidtab, tid) of
 210                 NONE => bug "tid not bound in tidtab"
 211               | SOME { name = SOME n, ntype = NONE, ... } => otherwise n
 212               | SOME { name = NONE, ntype = NONE, ... } =>
 213                 bug "both name and ntype missing in tidtab binding"
 214               | SOME { name, ntype = SOME nct, location, ... } =>
 215                 (case nct of
 216                      B.Struct (tid, members) =>
 217                      structty (tid, name, C, members, location)
 218                    | B.Union (tid, members) =>
 219                      unionty (tid, name, C, members, location)
 220                    | B.Enum (tid, edefs) =>
 221                      enumty (tid, name, C, edefs, location)
 222                    | B.Typedef (_, t) => let
 223                          val n =
 224                              case name of
 225                                  NONE => bug "missing name in typedef"
 226                                | SOME n => n
 227                          val C' = mk_context_td n
 228                          val res = valty C' t
 229                          fun sameName { src, name, spec } = name = n
 230                      in
 231                          if includedTy (n, location) andalso
 232                             not (SM.inDomain (!gtys, n)) then
 233                              gtys := SM.insert (!gtys, n,
 234                                                 { src = srcOf location,
 235                                                   name = n, spec = res })
 236                          else ();
 237                          res
 238                      end)
 239
 240         and enumty (tid, name, C, edefs, location) = let
 241             val (tag_stem, anon) = tagname (name, C, tid)
 242             val tag = reported_tagname (tag_stem, anon)
 243             fun one ({ name, uid, location, ctype, kind }, i) =
 244                 { name = Symbol.name name, spec = i }
 245             val enums = if anon then anon_enums else named_enums
 246         in
 247             enums := SM.insert (!enums, tag,
 248                                 { src = srcOf location,
 249                                   tag = tag,
 250                                   anon = anon,
 251                                   descr = tag,
 252                                   exclude = not (includedEnum (tag, location)),
 253                                   spec = map one edefs });
 254             Spec.ENUM (tag, anon)
 255         end
 256
 257         and structty (tid, name, C, members, location) = let
 258             val (tag_stem, anon) = tagname (name, C, tid)
 259             val tag = reported_tagname (tag_stem, anon)
 260             val ty = Spec.STRUCT tag
 261             val C' = mk_context_su (tag_stem, anon)
 262         in
 263             if SS.member (!seen_structs, tag) then ()
 264             else let
 265                     val _ = seen_structs := SS.add (!seen_structs, tag)
 266
 267                     val fol = fieldOffsets (A.StructRef tid)
 268                     val ssize = sizeOf (A.StructRef tid)
 269
 270                     fun bfspec (offset, bits, shift, (c, t)) = let
 271                         val offset = offset
 272                         val bits = Word.fromLargeInt bits
 273                         val shift = eshift (shift, intbits, bits)
 274                         val r = { offset = offset,
 275                                   constness = c,
 276                                   bits = bits,
 277                                   shift = shift }
 278                     in
 279                         case t of
 280                             Spec.BASIC Spec.UINT => Spec.UBF r
 281                           | Spec.BASIC Spec.SINT => Spec.SBF r
 282                           | _ => err "non-int bitfield"
 283                     end
 284
 285                     fun synthetic (synth, (_, false), _) = ([], synth)
 286                       | synthetic (synth, (endp, true), startp) =
 287                         if endp = startp then ([], synth)
 288                         else ([{ name = Int.toString synth,
 289                                  spec = Spec.OFIELD
 290                                         { offset = endp,
 291                                           spec = (Spec.RW,
 292                                                   Spec.ARR { t = Spec.BASIC Spec.UCHAR,
 293                                                              d = startp - endp,
 294                                                              esz = 1 }),
 295                                           synthetic = true } }],
 296                               synth+1)
 297
 298                     fun build ([], synth, gap) =
 299                         #1 (synthetic (synth, gap, ssize))
 300                       | build ((t, SOME m, NONE) :: rest, synth, gap) =
 301                         let val bitoff = #bitOffset (getField (m, fol))
 302                             val bytoff = bitoff div bytebits
 303                             val (filler, synth) =
 304                                 synthetic (synth, gap, bytoff)
 305                             val endp = bytoff + sizeOf t
 306                         in
 307                             if bitoff mod bytebits <> 0 then
 308                                 bug "non-bitfield not on byte boundary"
 309                             else
 310                                 filler @
 311                                 { name = Symbol.name (#name m),
 312                                   spec = Spec.OFIELD
 313                                              { offset = bytoff,
 314                                                spec = cobj C' t,
 315                                                synthetic = false } } ::
 316                                 build (rest, synth, (endp, false))
 317                         end
 318                       | build ((t, SOME m, SOME b) :: rest, synth, gap) =
 319                         let val bitoff = #bitOffset (getField (m, fol))
 320                             val bytoff =
 321                                 (intalign * (bitoff div intalign))
 322                                 div bytebits
 323                             val gap = (#1 gap, true)
 324                         in
 325                             { name = Symbol.name (#name m),
 326                               spec = bfspec (bytoff, b,
 327                                              bitoff mod intalign,
 328                                              cobj C' t) } ::
 329                             build (rest, synth, gap)
 330                         end
 331                       | build ((t, NONE, SOME _) :: rest, synth, gap) =
 332                         build (rest, synth, (#1 gap, true))
 333                       | build ((_, NONE, NONE) :: _, _, _) =
 334                         bug "unnamed struct member (not bitfield)"
 335
 336                     val fields = build (members, 0, (0, false))
 337                 in
 338                     structs := { src = srcOf location,
 339                                  tag = tag,
 340                                  anon = anon,
 341                                  size = Word.fromInt ssize,
 342                                  exclude = not (includedSU (tag, location)),
 343                                  fields = fields } :: !structs
 344                 end;
 345             ty
 346         end
 347
 348         and unionty (tid, name, C, members, location) = let
 349             val (tag_stem, anon) = tagname (name, C, tid)
 350             val tag = reported_tagname (tag_stem, anon)
 351             val C' = mk_context_su (tag_stem, anon)
 352             val ty = Spec.UNION tag
 353             val lsz = ref 0
 354             fun mkField (t, m: A.member) = let
 355                 val sz = sizeOf t
 356             in
 357                 { name = Symbol.name (#name m),
 358                   spec = Spec.OFIELD { offset = 0,
 359                                        spec = cobj C' t,
 360                                        synthetic = false } }
 361             end
 362         in
 363             if SS.member (!seen_unions, tag) then ()
 364             else let
 365                     val _ = seen_unions := SS.add (!seen_unions, tag)
 366                     val all = map mkField members
 367                 in
 368                     unions := { src = srcOf location,
 369                                 tag = tag,
 370                                 anon = anon,
 371                                 size = Word.fromInt (sizeOf (A.UnionRef tid)),
 372                                 exclude = not (includedSU (tag, location)),
 373                                 all = all } :: !unions
 374                 end;
 375             ty
 376         end
 377
 378         and cobj C t = (constness t, valty_nonvoid C t)
 379
 380         and fptrty C f = Spec.FPTR (cft C f)
 381
 382         and cft C (res, args) =
 383             { res = case getCoreType res of
 384                         A.Void => NONE
 385                       | _ => SOME (valty_nonvoid C res),
 386               args = case args of
 387                          [(arg, _)] => (case getCoreType arg of
 388                                        A.Void => []
 389                                      | _ => [fun_valty_nonvoid C arg])
 390                        | _ => let fun build [] = []
 391                                     | build [(x, _)] =
 392                                       ([fun_valty_nonvoid C x]
 393                                        handle Ellipsis =>
 394                                               (warnLoc
 395                                                    ("varargs not supported; \
 396                                                     \ignoring the ellipsis\n");
 397                                                    []))
 398                                     | build ((x, _) :: xs) =
 399                                       fun_valty_nonvoid C x :: build xs
 400                               in
 401                                   build args
 402                               end }
 403
 404         fun ft_argnames (res, args) =
 405             let val optids = map (fn (_, optid) => optid) args
 406             in
 407                 if List.exists (not o isSome) optids then NONE
 408                 else SOME (map valOf optids)
 409             end
 410
 411         fun functionName (f: A.id, ailo: A.id list option) = let
 412             val n = Symbol.name (#name f)
 413             val anlo = Option.map (map (Symbol.name o #name)) ailo
 414         in
 415             if n = "_init" orelse n = "_fini" orelse
 416                SM.inDomain (!gfuns, n) then ()
 417             else let
 418                      fun doit () =
 419                      (case getFunction (#ctype f) of
 420                           SOME fs =>
 421                           gfuns := SM.insert (!gfuns, n,
 422                                               { src = !curLoc,
 423                                                 name = n,
 424                                                 spec = cft tl_context fs,
 425                                                 argnames = anlo })
 426                         | NONE => bug "function without function type")
 427                      handle SkipFunction reason =>
 428                          warnLoc (reason ^ "; skipping function\n")
 429                  in
 430                  case #stClass f of
 431                      A.EXTERN => doit ()
 432                    | A.DEFAULT => doit ()
 433                    | A.AUTO => ()
 434                    | A.REGISTER => ()
 435                    | A.STATIC => ()
 436                  end
 437         end
 438
 439         fun varDecl (v: A.id) = let
 440             fun doit () =
 441                 (case getFunction (#ctype v) of
 442                      SOME fs => if realFunctionDefComing (#name v) then ()
 443                                 else functionName (v, ft_argnames fs)
 444                    | NONE =>
 445                      let val n = Symbol.name (#name v)
 446                      in
 447                          if SM.inDomain (!gvars, n) then ()
 448                          else gvars := SM.insert
 449                                            (!gvars, n,
 450                                             { src = !curLoc, name = n,
 451                                               spec = cobj tl_context
 452                                                           (#ctype v) })
 453                      end)
 454         in
 455             case #stClass v of
 456                 A.EXTERN => doit ()
 457               | A.DEFAULT => doit ()
 458               | A.AUTO => ()
 459               | A.REGISTER => ()
 460               | A.STATIC => ()
 461         end
 462
 463         fun dotid tid =
 464             (* Spec.SINT is an arbitrary choice; the value gets
 465              * ignored anyway *)
 466             (ignore (typeref (tid, fn _ => Spec.BASIC Spec.SINT, tl_context))
 467              handle VoidType => ())     (* ignore type aliases for void *)
 468
 469         fun declaration (A.TypeDecl { tid, ... }) = dotid tid
 470           | declaration (A.VarDecl (v, _)) = varDecl v
 471
 472         fun coreExternalDecl (A.ExternalDecl d) = declaration d
 473           | coreExternalDecl (A.FunctionDef (f, argids, _)) =
 474             functionName (f, SOME argids)
 475           | coreExternalDecl (A.ExternalDeclExt _) = ()
 476
 477         fun externalDecl (A.DECL (d, _, l)) =
 478             if isThisFile l then (curLoc := SourceMap.locToString l;
 479                                   coreExternalDecl d)
 480             else ()
 481
 482         fun doast l = app externalDecl l
 483
 484         fun gen_enums () = let
 485             val ael = SM.listItems (!anon_enums)
 486             val nel = SM.listItems (!named_enums)
 487             infix $
 488             fun x $ [] = [x]
 489               | x $ y = x :: ", " :: y
 490             fun onev (v as { name, spec }, m) =
 491                 if SM.inDomain (m, name) then raise Duplicate name
 492                 else SM.insert (m, name, v)
 493             fun onee ({ src, tag, anon, spec, descr, exclude }, (m, sl)) =
 494                 (foldl onev m spec, src $ sl)
 495         in
 496             if collect_enums then
 497                 let val (m, sl) = foldl onee (SM.empty, []) ael
 498                 in
 499                     if SM.isEmpty m then nel
 500                     else { src = concat (rev sl),
 501                            tag = "'",
 502                            anon = false,
 503                            descr = "collected from unnamed enumerations",
 504                            exclude = false,
 505                            spec = SM.listItems m }
 506                          :: nel
 507                 end handle Duplicate name =>
 508                            (warn (concat ["constant ", name,
 509                                           " defined more than once;\
 510                                           \ disabling `-collect'\n"]);
 511                             ael @ nel)
 512             else ael @ nel
 513         end
 514     in
 515         doast ast;
 516         app (dotid o #1) (Tidtab.listItemsi tidtab);
 517         { structs = !structs,
 518           unions = !unions,
 519           gtys = SM.listItems (!gtys),
 520           gvars = SM.listItems (!gvars),
 521           gfuns = SM.listItems (!gfuns),
 522           enums = gen_enums () } : Spec.spec
 523     end
 524 end