mlton/control/control-flags.sml

   1 (* Copyright (C) 2009-2012,2014-2017 Matthew Fluet.
   2  * Copyright (C) 1999-2008 Henry Cejtin, Matthew Fluet, Suresh
   3  *    Jagannathan, and Stephen Weeks.
   4  * Copyright (C) 1997-2000 NEC Research Institute.
   5  *
   6  * MLton is released under a BSD-style license.
   7  * See the file MLton-LICENSE for details.
   8  *)
   9
  10 structure ControlFlags: CONTROL_FLAGS =
  11 struct
  12
  13 structure C = Control ()
  14 open C
  15
  16 structure Align =
  17    struct
  18       datatype t = Align4 | Align8
  19
  20       val toString =
  21          fn Align4 => "4"
  22           | Align8 => "8"
  23    end
  24
  25 datatype align = datatype Align.t
  26
  27 val align = control {name = "align",
  28                      default = Align4,
  29                      toString = Align.toString}
  30
  31 val atMLtons = control {name = "atMLtons",
  32                         default = Vector.new0 (),
  33                         toString = fn v => Layout.toString (Vector.layout
  34                                                             String.layout v)}
  35
  36 structure Chunk =
  37    struct
  38       datatype t =
  39          OneChunk
  40        | ChunkPerFunc
  41        | Coalesce of {limit: int}
  42
  43       val toString =
  44          fn OneChunk => "one chunk"
  45           | ChunkPerFunc => "chunk per function"
  46           | Coalesce {limit} => concat ["coalesce ", Int.toString limit]
  47    end
  48
  49 datatype chunk = datatype Chunk.t
  50
  51 val chunk = control {name = "chunk",
  52                      default = Coalesce {limit = 4096},
  53                      toString = Chunk.toString}
  54
  55 val closureConvertGlobalize = control {name = "closureConvertGlobalize",
  56                                        default = true,
  57                                        toString = Bool.toString}
  58
  59 val closureConvertShrink = control {name = "closureConvertShrink",
  60                                     default = true,
  61                                     toString = Bool.toString}
  62
  63 structure Codegen =
  64    struct
  65       datatype t =
  66          AMD64Codegen
  67        | CCodegen
  68        | LLVMCodegen
  69        | X86Codegen
  70
  71       val all = [X86Codegen,AMD64Codegen,CCodegen,LLVMCodegen]
  72
  73       val toString: t -> string =
  74          fn AMD64Codegen => "amd64"
  75           | CCodegen => "c"
  76           | LLVMCodegen => "llvm"
  77           | X86Codegen => "x86"
  78    end
  79
  80 datatype codegen = datatype Codegen.t
  81
  82 val codegen = control {name = "codegen",
  83                        default = Codegen.X86Codegen,
  84                        toString = Codegen.toString}
  85
  86 val contifyIntoMain = control {name = "contifyIntoMain",
  87                                default = false,
  88                                toString = Bool.toString}
  89
  90 val debug = control {name = "debug",
  91                      default = false,
  92                      toString = Bool.toString}
  93
  94 val defaultChar = control {name = "defaultChar",
  95                            default = "char8",
  96                            toString = fn s => s}
  97 val defaultWideChar = control {name = "defaultWideChar",
  98                                default = "widechar32",
  99                                toString = fn s => s}
 100 val defaultInt = control {name = "defaultInt",
 101                           default = "int32",
 102                           toString = fn s => s}
 103 val defaultReal = control {name = "defaultReal",
 104                            default = "real64",
 105                            toString = fn s => s}
 106 val defaultWord = control {name = "defaultWord",
 107                            default = "word32",
 108                            toString = fn s => s}
 109
 110 val diagPasses =
 111    control {name = "diag passes",
 112             default = [],
 113             toString = List.toString
 114                        (Layout.toString o
 115                         Regexp.Compiled.layout)}
 116
 117 val executePasses =
 118    control {name = "execute passes",
 119             default = [],
 120             toString = List.toString
 121                        (Layout.toString o
 122                         (Layout.tuple2
 123                          (Regexp.Compiled.layout, Bool.layout)))}
 124
 125 structure Elaborate =
 126    struct
 127       structure DiagEIW =
 128          struct
 129             datatype t =
 130                Error
 131              | Ignore
 132              | Warn
 133
 134             val fromString: string -> t option =
 135                fn "error" => SOME Error
 136                 | "ignore" => SOME Ignore
 137                 | "warn" => SOME Warn
 138                 | _ => NONE
 139
 140             val toString: t -> string =
 141                fn Error => "error"
 142                 | Ignore => "ignore"
 143                 | Warn => "warn"
 144          end
 145
 146       structure DiagDI =
 147          struct
 148             datatype t =
 149                Default
 150              | Ignore
 151
 152             val fromString: string -> t option =
 153                fn "default" => SOME Default
 154                 | "ignore" => SOME Ignore
 155                 | _ => NONE
 156
 157             val toString: t -> string =
 158                fn Default => "default"
 159                 | Ignore => "ignore"
 160          end
 161
 162       structure ResolveScope =
 163          struct
 164             datatype t =
 165                Dec
 166              | Strdec
 167              | Topdec
 168              | Program
 169
 170             val fromString: string -> t option =
 171                fn "dec" => SOME Dec
 172                 | "strdec" => SOME Strdec
 173                 | "topdec" => SOME Topdec
 174                 | "program" => SOME Program
 175                 | _ => NONE
 176
 177             val toString: t -> string =
 178                fn Dec => "dec"
 179                 | Strdec => "strdec"
 180                 | Topdec => "topdec"
 181                 | Program => "program"
 182          end
 183
 184       structure Id =
 185          struct
 186             datatype t = T of {enabled: bool ref,
 187                                expert: bool,
 188                                name: string}
 189             fun equals (T {enabled = enabled1, ...},
 190                         T {enabled = enabled2, ...}) =
 191                enabled1 = enabled2
 192
 193             val enabled = fn (T {enabled, ...}) => !enabled
 194             val setEnabled = fn (T {enabled, ...}, b) => (enabled := b; true)
 195             val expert = fn (T {expert, ...}) => expert
 196             val name = fn (T {name, ...}) => name
 197          end
 198       structure Args =
 199          struct
 200             datatype t = T of {fillArgs: unit -> (unit -> unit),
 201                                processAnn: unit -> (unit -> unit),
 202                                processDef: unit -> bool}
 203             local
 204                fun make sel (T r) = sel r
 205             in
 206                fun processAnn args = (make #processAnn args) ()
 207                fun processDef args = (make #processDef args) ()
 208             end
 209          end
 210       datatype ('args, 'st) t = T of {args: 'args option ref,
 211                                       cur: 'st ref,
 212                                       def: 'st ref,
 213                                       id: Id.t}
 214       fun current (T {cur, ...}) = !cur
 215       fun default (T {def, ...}) = !def
 216       fun id (T {id, ...}) = id
 217       fun enabled ctrl = Id.enabled (id ctrl)
 218       fun expert ctrl = Id.expert (id ctrl)
 219       fun name ctrl = Id.name (id ctrl)
 220       fun equalsId (ctrl, id') = Id.equals (id ctrl, id')
 221
 222       datatype 'a parseResult =
 223          Bad | Good of 'a | Other | Proxy of 'a list * {deprecated: bool}
 224       val deGood =
 225          fn Good z => z
 226           | _ => Error.bug "Control.Elaborate.deGood"
 227
 228       val documentation: {choices: string list option,
 229                           expert: bool,
 230                           name: string} list ref = ref []
 231
 232       fun document {expert} =
 233          let
 234             val all = !documentation
 235             val all =
 236                if expert then all
 237                else List.keepAll (all, not o #expert)
 238             val all =
 239                List.insertionSort
 240                (all, fn ({name = n, ...}, {name = n', ...}) => n <= n')
 241             open Layout
 242          in
 243             align
 244             (List.map
 245              (all, fn {choices, name, ...} =>
 246               str (concat [name,
 247                            case choices of
 248                               NONE => ""
 249                             | SOME cs =>
 250                                  concat [" {",
 251                                          concat (List.separate (cs, "|")),
 252                                          "}"]])))
 253          end
 254
 255       local
 256          fun make ({choices: 'st list option,
 257                     default: 'st,
 258                     expert: bool,
 259                     toString: 'st -> string,
 260                     name: string,
 261                     newCur: 'st * 'args -> 'st,
 262                     newDef: 'st * 'args -> 'st,
 263                     parseArgs: string list -> 'args option},
 264                    {parseId: string -> Id.t parseResult,
 265                     parseIdAndArgs: string list -> (Id.t * Args.t) parseResult,
 266                     withDef: unit -> (unit -> unit),
 267                     snapshot: unit -> unit -> (unit -> unit)}) =
 268             let
 269                val () =
 270                   List.push
 271                   (documentation,
 272                    {choices = Option.map (choices, fn cs =>
 273                                           List.map (cs, toString)),
 274                     expert = expert,
 275                     name = name})
 276                val ctrl as T {args = argsRef, cur, def,
 277                               id as Id.T {enabled, ...}, ...} =
 278                   T {args = ref NONE,
 279                      cur = ref default,
 280                      def = control {name = concat ["elaborate ", name,
 281                                                    " (default)"],
 282                                     default = default,
 283                                     toString = toString},
 284                      id = Id.T {enabled = control {name = concat ["elaborate ", name,
 285                                                                   " (enabled)"],
 286                                                    default = true,
 287                                                    toString = Bool.toString},
 288                                 expert = expert,
 289                                 name = name}}
 290                val parseId = fn name' =>
 291                   if String.equals (name', name)
 292                      then Good id
 293                      else parseId name'
 294                val parseIdAndArgs = fn ss =>
 295                   case ss of
 296                      name'::args' =>
 297                         if String.equals (name', name)
 298                            then
 299                               case parseArgs args' of
 300                                  SOME v =>
 301                                     let
 302                                        fun fillArgs () =
 303                                           (argsRef := SOME v
 304                                            ; fn () => argsRef := NONE)
 305                                        fun processAnn () =
 306                                           if !enabled
 307                                              then let
 308                                                      val old = !cur
 309                                                      val new = newCur (old, v)
 310                                                   in
 311                                                      cur := new
 312                                                      ; fn () => cur := old
 313                                                   end
 314                                              else fn () => ()
 315                                        fun processDef () =
 316                                           let
 317                                              val old = !def
 318                                              val new = newDef (old, v)
 319                                           in
 320                                              def := new
 321                                              ; true
 322                                           end
 323                                        val args =
 324                                           Args.T {fillArgs = fillArgs,
 325                                                   processAnn = processAnn,
 326                                                   processDef = processDef}
 327                                     in
 328                                        Good (id, args)
 329                                     end
 330                                | NONE => Bad
 331                            else parseIdAndArgs ss
 332                    | _ => Bad
 333                val withDef : unit -> (unit -> unit) =
 334                   fn () =>
 335                   let
 336                      val restore = withDef ()
 337                      val old = !cur
 338                   in
 339                      cur := !def
 340                      ; fn () => (cur := old
 341                                  ; restore ())
 342                   end
 343                val snapshot : unit -> unit -> (unit -> unit) =
 344                   fn () =>
 345                   let
 346                      val withSaved = snapshot ()
 347                      val saved = !cur
 348                   in
 349                      fn () =>
 350                      let
 351                         val restore = withSaved ()
 352                         val old = !cur
 353                      in
 354                         cur := saved
 355                         ; fn () => (cur := old
 356                                     ; restore ())
 357                      end
 358                   end
 359             in
 360                (ctrl,
 361                 {parseId = parseId,
 362                  parseIdAndArgs = parseIdAndArgs,
 363                  withDef = withDef,
 364                  snapshot = snapshot})
 365             end
 366
 367          fun makeBool ({default: bool,
 368                         expert: bool,
 369                         name: string}, ac) =
 370             make ({choices = SOME (if default then [true, false]
 371                                    else [false, true]),
 372                    default = default,
 373                    expert = expert,
 374                    toString = Bool.toString,
 375                    name = name,
 376                    newCur = fn (_,b) => b,
 377                    newDef = fn (_,b) => b,
 378                    parseArgs = fn args' =>
 379                                case args' of
 380                                   [arg'] => Bool.fromString arg'
 381                                 | _ => NONE},
 382                   ac)
 383
 384          fun makeDiagnostic ({choices,
 385                               default,
 386                               diagToString,
 387                               diagFromString,
 388                               expert: bool,
 389                               name: string}, ac) =
 390              make ({choices = choices,
 391                     default = default,
 392                     expert = expert,
 393                     toString = diagToString,
 394                     name = name,
 395                     newCur = fn (_,d) => d,
 396                     newDef = fn (_,d) => d,
 397                     parseArgs = fn args' =>
 398                                 case args' of
 399                                    [arg'] => diagFromString arg'
 400                                  | _ => NONE},
 401                    ac)
 402          fun makeDiagEIW ({default: DiagEIW.t,
 403                            expert: bool,
 404                            name: string}, ac) =
 405             makeDiagnostic ({choices = (SOME
 406                                         (let
 407                                             datatype z = datatype DiagEIW.t
 408                                          in
 409                                             case default of
 410                                                Error => [Error, Ignore, Warn]
 411                                              | Ignore => [Ignore, Error, Warn]
 412                                              | Warn => [Warn, Ignore, Error]
 413                                          end)),
 414                              default = default,
 415                              diagToString = DiagEIW.toString,
 416                              diagFromString = DiagEIW.fromString,
 417                              expert = expert,
 418                              name = name}, ac)
 419          fun makeDiagDI ({default: DiagDI.t,
 420                           expert: bool,
 421                           name: string}, ac) =
 422             makeDiagnostic ({choices = (SOME
 423                                         (let
 424                                             datatype z = datatype DiagDI.t
 425                                          in
 426                                             case default of
 427                                                Default => [Default, Ignore]
 428                                              | Ignore => [Ignore, Default]
 429                                          end)),
 430                              default = default,
 431                              diagToString = DiagDI.toString,
 432                              diagFromString = DiagDI.fromString,
 433                              expert = expert,
 434                              name = name}, ac)
 435       in
 436          val ac =
 437             {parseId = fn _ => Bad,
 438              parseIdAndArgs = fn _ => Bad,
 439              withDef = fn () => (fn () => ()),
 440              snapshot = fn () => fn () => (fn () => ())}
 441
 442
 443          val (allowConstant, ac) =
 444             makeBool ({name = "allowConstant",
 445                        default = false, expert = true}, ac)
 446          val (allowFFI, ac) =
 447             makeBool ({name = "allowFFI",
 448                        default = false, expert = false}, ac)
 449          val (allowPrim, ac) =
 450             makeBool ({name = "allowPrim",
 451                        default = false, expert = true}, ac)
 452          val (allowOverload, ac) =
 453             makeBool ({name = "allowOverload",
 454                        default = false, expert = true}, ac)
 455          val (allowRedefineSpecialIds, ac) =
 456             makeBool ({name = "allowRedefineSpecialIds",
 457                        default = false, expert = true}, ac)
 458          val (allowSpecifySpecialIds, ac) =
 459             makeBool ({name = "allowSpecifySpecialIds",
 460                        default = false, expert = true}, ac)
 461          val (deadCode, ac) =
 462             makeBool ({name = "deadCode",
 463                        default = false, expert = true}, ac)
 464          val (forceUsed, ac) =
 465             make ({choices = NONE,
 466                    default = false,
 467                    expert = false,
 468                    toString = Bool.toString,
 469                    name = "forceUsed",
 470                    newCur = fn (b,()) => b,
 471                    newDef = fn (_,()) => true,
 472                    parseArgs = fn args' =>
 473                                case args' of
 474                                   [] => SOME ()
 475                                 | _ => NONE},
 476                   ac)
 477          val (ffiStr, ac) =
 478             make ({choices = SOME [SOME "<longstrid>"],
 479                    default = NONE,
 480                    expert = true,
 481                    toString = fn NONE => "" | SOME s => s,
 482                    name = "ffiStr",
 483                    newCur = fn (_,s) => SOME s,
 484                    newDef = fn _ => NONE,
 485                    parseArgs = fn args' =>
 486                                case args' of
 487                                   [s] => SOME s
 488                                 | _ => NONE},
 489                   ac)
 490          val (nonexhaustiveBind, ac) =
 491              makeDiagEIW ({name = "nonexhaustiveBind",
 492                            default = DiagEIW.Warn, expert = false}, ac)
 493          val (nonexhaustiveExnBind, ac) =
 494              makeDiagDI ({name = "nonexhaustiveExnBind",
 495                           default = DiagDI.Default, expert = false}, ac)
 496          val (redundantBind, ac) =
 497              makeDiagEIW ({name = "redundantBind",
 498                            default = DiagEIW.Warn, expert = false}, ac)
 499          val (nonexhaustiveMatch, ac) =
 500              makeDiagEIW ({name = "nonexhaustiveMatch",
 501                            default = DiagEIW.Warn, expert = false}, ac)
 502          val (nonexhaustiveExnMatch, ac) =
 503              makeDiagDI ({name = "nonexhaustiveExnMatch",
 504                           default = DiagDI.Default, expert = false}, ac)
 505          val (redundantMatch, ac) =
 506              makeDiagEIW ({name = "redundantMatch",
 507                            default = DiagEIW.Warn, expert = false}, ac)
 508          val (nonexhaustiveRaise, ac) =
 509              makeDiagEIW ({name = "nonexhaustiveRaise",
 510                            default = DiagEIW.Ignore, expert = false}, ac)
 511          val (nonexhaustiveExnRaise, ac) =
 512              makeDiagDI ({name = "nonexhaustiveExnRaise",
 513                           default = DiagDI.Ignore, expert = false}, ac)
 514          val (redundantRaise, ac) =
 515              makeDiagEIW ({name = "redundantRaise",
 516                            default = DiagEIW.Warn, expert = false}, ac)
 517          val (resolveScope, ac) =
 518             make ({choices = SOME [ResolveScope.Dec, ResolveScope.Strdec, ResolveScope.Topdec, ResolveScope.Program],
 519                    default = ResolveScope.Strdec,
 520                    expert = true,
 521                    toString = ResolveScope.toString,
 522                    name = "resolveScope",
 523                    newCur = fn (_,rs) => rs,
 524                    newDef = fn (_,rs) => rs,
 525                    parseArgs = fn args' =>
 526                                case args' of
 527                                   [arg'] => ResolveScope.fromString arg'
 528                                 | _ => NONE},
 529                   ac)
 530          val (sequenceNonUnit, ac) =
 531             makeDiagEIW ({name = "sequenceNonUnit",
 532                           default = DiagEIW.Ignore, expert = false}, ac)
 533          val (valrecConstr, ac) =
 534             makeDiagEIW ({name = "valrecConstr",
 535                           default = DiagEIW.Warn, expert = false}, ac)
 536          val (warnUnused, ac) =
 537             makeBool ({name = "warnUnused",
 538                        default = false, expert = false}, ac)
 539
 540          (* Successor ML *)
 541          val (allowDoDecls, ac) =
 542             makeBool ({name = "allowDoDecls",
 543                        default = false, expert = false}, ac)
 544          val (allowExtendedNumConsts, ac) =
 545             makeBool ({name = "allowExtendedNumConsts",
 546                        default = false, expert = false}, ac)
 547          val (allowExtendedTextConsts, ac) =
 548             makeBool ({name = "allowExtendedTextConsts",
 549                        default = false, expert = false}, ac)
 550          val (allowLineComments, ac) =
 551             makeBool ({name = "allowLineComments",
 552                        default = false, expert = false}, ac)
 553          val (allowOptBar, ac) =
 554             makeBool ({name = "allowOptBar",
 555                        default = false, expert = false}, ac)
 556          val (allowOptSemicolon, ac) =
 557             makeBool ({name = "allowOptSemicolon",
 558                        default = false, expert = false}, ac)
 559          val (allowOrPats, ac) =
 560             makeBool ({name = "allowOrPats",
 561                        default = false, expert = false}, ac)
 562          val (allowRecordPunExps, ac) =
 563             makeBool ({name = "allowRecordPunExps",
 564                        default = false, expert = false}, ac)
 565          val (allowSigWithtype, ac) =
 566             makeBool ({name = "allowSigWithtype",
 567                        default = false, expert = false}, ac)
 568          val (allowVectorExps, ac) =
 569             makeBool ({name = "allowVectorExps",
 570                        default = false, expert = false}, ac)
 571          val (allowVectorPats, ac) =
 572             makeBool ({name = "allowVectorPats",
 573                        default = false, expert = false}, ac)
 574          val extendedConstsCtrls =
 575             [allowExtendedNumConsts, allowExtendedTextConsts]
 576          val vectorCtrls =
 577             [allowVectorExps, allowVectorPats]
 578          val successorMLCtrls =
 579             [allowDoDecls, allowExtendedNumConsts,
 580              allowExtendedTextConsts, allowLineComments, allowOptBar,
 581              allowOptSemicolon, allowOrPats, allowRecordPunExps,
 582              allowSigWithtype, allowVectorExps, allowVectorPats]
 583
 584
 585          val {parseId, parseIdAndArgs, withDef, snapshot} = ac
 586       end
 587
 588       local
 589          fun makeProxy ({alts: (Id.t * ('args -> string list option)) list,
 590                          choices: 'args list option,
 591                          deprecated: bool,
 592                          expert: bool,
 593                          toString: 'args -> string,
 594                          name: string,
 595                          parseArgs: string list -> 'args option},
 596                         {parseId: string -> Id.t parseResult,
 597                          parseIdAndArgs: string list -> (Id.t * Args.t) parseResult}) =
 598             let
 599                val () =
 600                   if deprecated then () else
 601                   List.push
 602                   (documentation,
 603                    {choices = Option.map (choices, fn cs =>
 604                                           List.map (cs, toString)),
 605                     expert = expert,
 606                     name = name})
 607                val parseId = fn name' =>
 608                   if String.equals (name', name)
 609                      then Proxy (List.map (alts, fn (id, _) => id), {deprecated = deprecated})
 610                      else parseId name'
 611                val parseIdAndArgs = fn ss =>
 612                   case ss of
 613                      name'::args' =>
 614                         if String.equals (name', name)
 615                            then
 616                               case parseArgs args' of
 617                                  SOME v => let
 618                                               val alts =
 619                                                  List.keepAllMap
 620                                                  (alts, fn (id, mkArgs) =>
 621                                                   Option.map
 622                                                   (mkArgs v, fn ss =>
 623                                                    deGood (parseIdAndArgs ((Id.name id)::ss))))
 624                                            in
 625                                               Proxy (alts, {deprecated = deprecated})
 626                                            end
 627                                | NONE => Bad
 628                            else parseIdAndArgs ss
 629                    | _ => Bad
 630             in
 631                {parseId = parseId,
 632                 parseIdAndArgs = parseIdAndArgs}
 633             end
 634
 635          fun makeProxyBoolSimple ({alts: Id.t list,
 636                                    default: bool,
 637                                    deprecated: bool,
 638                                    expert: bool,
 639                                    name: string}, ac) =
 640             makeProxy ({alts = List.map (alts, fn id => (id, fn b => SOME [Bool.toString b])),
 641                         choices = SOME (if default then [true, false]
 642                                                    else [false, true]),
 643                         deprecated = deprecated,
 644                         expert = expert,
 645                         toString = Bool.toString,
 646                         name = name,
 647                         parseArgs = fn args' =>
 648                                     case args' of
 649                                        [arg'] => Bool.fromString arg'
 650                                      | _ => NONE},
 651                        ac)
 652       in
 653          val ac = {parseId = parseId, parseIdAndArgs = parseIdAndArgs}
 654
 655          (* Successor ML *)
 656          val ac =
 657             makeProxyBoolSimple ({alts = List.map (extendedConstsCtrls, id),
 658                                   default = false,
 659                                   deprecated = false,
 660                                   expert = false,
 661                                   name = "allowExtendedConsts"}, ac)
 662          val ac =
 663             makeProxyBoolSimple ({alts = List.map (vectorCtrls, id),
 664                                   default = false,
 665                                   deprecated = false,
 666                                   expert = false,
 667                                   name = "allowVectorExpsAndPats"}, ac)
 668          val ac =
 669             makeProxyBoolSimple ({alts = List.map (successorMLCtrls, id),
 670                                   default = false,
 671                                   deprecated = false,
 672                                   expert = false,
 673                                   name = "allowSuccessorML"}, ac)
 674
 675          val {parseId, parseIdAndArgs} = ac
 676       end
 677
 678       local
 679          fun checkPrefix (s, f) =
 680             case String.peeki (s, fn (_, c) => c = #":") of
 681                NONE => f s
 682              | SOME (i, _) =>
 683                   let
 684                      val comp = String.prefix (s, i)
 685                      val comp = String.deleteSurroundingWhitespace comp
 686                      val s = String.dropPrefix (s, i + 1)
 687                   in
 688                      if String.equals (comp, "mlton")
 689                         then f s
 690                         else Other
 691                   end
 692       in
 693          val parseId = fn s => checkPrefix (s, parseId)
 694          val parseIdAndArgs = fn s => checkPrefix (s, fn s => parseIdAndArgs (String.tokens (s, Char.isSpace)))
 695       end
 696
 697       val processDefault = fn s =>
 698          case parseIdAndArgs s of
 699             Bad => Bad
 700           | Good (id, args) => if Args.processDef args then Good id else Bad
 701           | Proxy (alts, {deprecated}) =>
 702                List.fold
 703                (alts, Proxy (List.map (alts, #1), {deprecated = deprecated}),
 704                 fn ((_,args),res) =>
 705                 if Args.processDef args then res else Bad)
 706           | Other => Bad
 707
 708       val processEnabled = fn (s, b) =>
 709          case parseId s of
 710             Bad => Bad
 711           | Proxy (alts, {deprecated}) =>
 712                List.fold
 713                (alts, Proxy (alts, {deprecated = deprecated}),
 714                 fn (id, res) =>
 715                 if Id.setEnabled (id, b) then res else Bad)
 716           | Good id => if Id.setEnabled (id, b) then Good id else Bad
 717           | Other => Bad
 718
 719       val withDef : (unit -> 'a) -> 'a = fn f =>
 720          let
 721             val restore = withDef ()
 722          in
 723             Exn.finally (f, restore)
 724          end
 725
 726       val snapshot : unit -> (unit -> 'a) -> 'a = fn () =>
 727          let
 728             val withSaved = snapshot ()
 729          in
 730             fn f =>
 731             let
 732                val restore = withSaved ()
 733             in
 734                Exn.finally (f, restore)
 735             end
 736          end
 737
 738    end
 739
 740 val elaborateOnly =
 741    control {name = "elaborate only",
 742             default = false,
 743             toString = Bool.toString}
 744
 745 val emitMain =
 746    control {name = "emit main",
 747             default = true,
 748             toString = Bool.toString}
 749
 750 val exportHeader =
 751    control {name = "export header",
 752             default = NONE,
 753             toString = Option.toString File.toString}
 754
 755 val exnHistory = control {name = "exn history",
 756                           default = false,
 757                           toString = Bool.toString}
 758
 759 structure Format =
 760    struct
 761       datatype t =
 762          Archive
 763        | Executable
 764        | LibArchive
 765        | Library
 766
 767       (* Default option first for usage message. *)
 768       val all = [Executable, Archive, LibArchive, Library]
 769
 770       val toString: t -> string =
 771         fn Archive => "archive"
 772          | Executable => "executable"
 773          | LibArchive => "libarchive"
 774          | Library => "library"
 775    end
 776
 777 datatype format = datatype Format.t
 778
 779 val format = control {name = "generated output format",
 780                       default = Format.Executable,
 781                       toString = Format.toString}
 782
 783 structure GcCheck =
 784    struct
 785       datatype t =
 786          Limit
 787        | First
 788        | Every
 789
 790       local open Layout
 791       in
 792          val layout =
 793             fn Limit => str "Limit"
 794              | First => str "First"
 795              | Every => str "Every"
 796       end
 797       val toString = Layout.toString o layout
 798    end
 799
 800 datatype gcCheck = datatype GcCheck.t
 801
 802 val gcCheck = control {name = "gc check",
 803                        default = Limit,
 804                        toString = GcCheck.toString}
 805
 806 val indentation = control {name = "indentation",
 807                            default = 3,
 808                            toString = Int.toString}
 809
 810 val inlineIntoMain = control {name = "inlineIntoMain",
 811                               default = true,
 812                               toString = Bool.toString}
 813
 814 val inlineLeafA =
 815    control {name = "inlineLeafA",
 816             default = {loops = true,
 817                        repeat = true,
 818                        size = SOME 20},
 819             toString =
 820             fn {loops, repeat, size} =>
 821             Layout.toString
 822             (Layout.record [("loops", Bool.layout loops),
 823                             ("repeat", Bool.layout repeat),
 824                             ("size", Option.layout Int.layout size)])}
 825 val inlineLeafB =
 826    control {name = "inlineLeafB",
 827             default = {loops = true,
 828                        repeat = true,
 829                        size = SOME 40},
 830             toString =
 831             fn {loops, repeat, size} =>
 832             Layout.toString
 833             (Layout.record [("loops", Bool.layout loops),
 834                             ("repeat", Bool.layout repeat),
 835                             ("size", Option.layout Int.layout size)])}
 836
 837 val inlineNonRec =
 838    control {name = "inlineNonRec",
 839             default = {small = 60,
 840                        product = 320},
 841             toString =
 842             fn {small, product} =>
 843             Layout.toString
 844             (Layout.record [("small", Int.layout small),
 845                             ("product", Int.layout product)])}
 846
 847 val inputFile = control {name = "input file",
 848                          default = "<bogus>",
 849                          toString = File.toString}
 850
 851 val keepAST = control {name = "keep AST",
 852                        default = false,
 853                        toString = Bool.toString}
 854
 855 val keepCoreML = control {name = "keep CoreML",
 856                           default = false,
 857                           toString = Bool.toString}
 858
 859 val keepDefUse = control {name = "keep def use",
 860                           default = true,
 861                           toString = Bool.toString}
 862
 863 val keepDot = control {name = "keep dot",
 864                        default = false,
 865                        toString = Bool.toString}
 866
 867 val keepMachine = control {name = "keep Machine",
 868                            default = false,
 869                            toString = Bool.toString}
 870
 871 val keepPasses = control {name = "keep passes",
 872                           default = [],
 873                           toString = List.toString
 874                                      (Layout.toString o
 875                                       Regexp.Compiled.layout)}
 876
 877 val keepRSSA = control {name = "keep RSSA",
 878                         default = false,
 879                         toString = Bool.toString}
 880
 881 val keepSSA = control {name = "keep SSA",
 882                        default = false,
 883                        toString = Bool.toString}
 884
 885 val keepSSA2 = control {name = "keep SSA2",
 886                         default = false,
 887                         toString = Bool.toString}
 888
 889 val keepSXML = control {name = "keep SXML",
 890                         default = false,
 891                         toString = Bool.toString}
 892
 893
 894 val keepXML = control {name = "keep XML",
 895                        default = false,
 896                        toString = Bool.toString}
 897
 898 val labelsHaveExtra_ = control {name = "extra_",
 899                                 default = false,
 900                                 toString = Bool.toString}
 901
 902 val libDir = control {name = "lib dir",
 903                       default = "<libDir unset>",
 904                       toString = fn s => s}
 905
 906 val libTargetDir = control {name = "lib target dir",
 907                             default = "<libTargetDir unset>",
 908                             toString = fn s => s}
 909
 910 val libname = ref ""
 911
 912 val loopSsaPasses = control {name = "loop ssa passes",
 913                              default = 1,
 914                              toString = Int.toString}
 915
 916 val loopSsa2Passes = control {name = "loop ssa2 passes",
 917                               default = 1,
 918                               toString = Int.toString}
 919
 920 val loopUnrollLimit = control {name = "loop unrolling limit",
 921                                 default = 150,
 922                                 toString = Int.toString}
 923 val loopUnswitchLimit = control {name = "loop unswitching limit",
 924                                   default = 300,
 925                                   toString = Int.toString}
 926
 927 val markCards = control {name = "mark cards",
 928                          default = true,
 929                          toString = Bool.toString}
 930
 931 val maxFunctionSize = control {name = "max function size",
 932                                default = 10000,
 933                                toString = Int.toString}
 934
 935 val mlbPathVars =
 936    control
 937    {name = "mlb path vars",
 938     default = [],
 939     toString = List.toString
 940                (fn {var, path} =>
 941                    concat ["{var = ", var, ", path = ", path, "}"])}
 942
 943 structure Native =
 944    struct
 945       val commented = control {name = "native commented",
 946                                default = 0,
 947                                toString = Int.toString}
 948
 949       val liveStack = control {name = "native live stack",
 950                                default = false,
 951                                toString = Bool.toString}
 952
 953       val optimize = control {name = "native optimize",
 954                               default = 1,
 955                               toString = Int.toString}
 956
 957       val moveHoist = control {name = "native move hoist",
 958                                default = true,
 959                                toString = Bool.toString}
 960
 961       val copyProp = control {name = "native copy prop",
 962                               default = true,
 963                               toString = Bool.toString}
 964
 965       val copyPropCutoff = control {name = "native copy prop cutoff",
 966                                     default = 1000,
 967                                     toString = Int.toString}
 968
 969       val cutoff = control {name = "native cutoff",
 970                             default = 100,
 971                             toString = Int.toString}
 972
 973       val liveTransfer = control {name = "native live transfer",
 974                                   default = 8,
 975                                   toString = Int.toString}
 976
 977       val shuffle = control {name = "native shuffle",
 978                              default = true,
 979                              toString = Bool.toString}
 980
 981       val IEEEFP = control {name = "native ieee fp",
 982                             default = false,
 983                             toString = Bool.toString}
 984
 985       val split = control {name = "native split",
 986                            default = SOME 20000,
 987                            toString = Option.toString Int.toString}
 988    end
 989
 990 val optFuel =
 991    control {name = "optFuel",
 992             default = NONE,
 993             toString = Option.toString Int.toString}
 994
 995 fun optFuelAvailAndUse () =
 996    case !optFuel of
 997       NONE => true
 998     | SOME i => if i > 0
 999                    then (optFuel := SOME (i - 1); true)
1000                    else false
1001 (* Suppress unused variable warning
1002  * This variable is purposefully unused in production,
1003  * but is retained to make it easy to use in development of new
1004  * optimization passes.
1005  *)
1006 val _ = optFuelAvailAndUse
1007
1008 val optimizationPasses:
1009    {il: string, set: string -> unit Result.t, get: unit -> string} list ref =
1010    control {name = "optimizationPasses",
1011             default = [],
1012             toString = List.toString
1013                        (fn {il,get,...} => concat ["<",il,"::",get (),">"])}
1014
1015 val polyvariance =
1016    control {name = "polyvariance",
1017             default = SOME {hofo = true,
1018                             rounds = 2,
1019                             small = 30,
1020                             product = 300},
1021             toString =
1022             fn p =>
1023             Layout.toString
1024             (Option.layout
1025              (fn {hofo, rounds, small, product} =>
1026               Layout.record [("hofo", Bool.layout hofo),
1027                              ("rounds", Int.layout rounds),
1028                              ("small", Int.layout small),
1029                              ("product", Int.layout product)])
1030              p)}
1031
1032 val positionIndependent = ref false
1033
1034 val preferAbsPaths = control {name = "prefer abs paths",
1035                               default = false,
1036                               toString = Bool.toString}
1037
1038 val profPasses =
1039    control {name = "prof passes",
1040             default = [],
1041             toString = List.toString
1042             (Layout.toString o
1043              Regexp.Compiled.layout)}
1044
1045 structure Profile =
1046    struct
1047       datatype t =
1048          ProfileNone
1049        | ProfileAlloc
1050        | ProfileCallStack
1051        | ProfileCount
1052        | ProfileDrop
1053        | ProfileLabel
1054        | ProfileTimeField
1055        | ProfileTimeLabel
1056
1057       val toString =
1058          fn ProfileNone => "None"
1059           | ProfileAlloc => "Alloc"
1060           | ProfileCallStack => "CallStack"
1061           | ProfileCount => "Count"
1062           | ProfileDrop => "Drop"
1063           | ProfileLabel => "Label"
1064           | ProfileTimeField => "TimeField"
1065           | ProfileTimeLabel => "TimeLabel"
1066    end
1067
1068 datatype profile = datatype Profile.t
1069
1070 val profile = control {name = "profile",
1071                        default = ProfileNone,
1072                        toString = Profile.toString}
1073
1074 val profileBranch = control {name = "profile branch",
1075                              default = false,
1076                              toString = Bool.toString}
1077
1078 val profileC = control {name = "profile C",
1079                         default = [],
1080                         toString = List.toString
1081                                    (Layout.toString o
1082                                     Regexp.Compiled.layout)}
1083
1084 structure ProfileIL =
1085    struct
1086       datatype t = ProfileSource | ProfileSSA | ProfileSSA2
1087
1088       val toString =
1089          fn ProfileSource => "ProfileSource"
1090           | ProfileSSA => "ProfileSSA"
1091           | ProfileSSA2 => "ProfileSSA2"
1092    end
1093
1094 datatype profileIL = datatype ProfileIL.t
1095
1096 val profileIL = control {name = "profile IL",
1097                          default = ProfileSource,
1098                          toString = ProfileIL.toString}
1099
1100 val profileInclExcl =
1101    control {name = "profile include/exclude",
1102             default = [],
1103             toString = List.toString
1104                        (Layout.toString o
1105                         (Layout.tuple2 (Regexp.Compiled.layout,
1106                                         Bool.layout)))}
1107
1108 val profileRaise = control {name = "profile raise",
1109                             default = false,
1110                             toString = Bool.toString}
1111
1112 val profileStack = control {name = "profile stack",
1113                             default = false,
1114                             toString = Bool.toString}
1115
1116 val profileVal = control {name = "profile val",
1117                           default = false,
1118                           toString = Bool.toString}
1119
1120 val showBasis = control {name = "show basis",
1121                          default = NONE,
1122                          toString = Option.toString File.toString}
1123
1124 val showBasisCompact = control {name = "show basis compact",
1125                                 default = false,
1126                                 toString = Bool.toString}
1127 val showBasisDef = control {name = "show basis def",
1128                             default = true,
1129                             toString = Bool.toString}
1130 val showBasisFlat = control {name = "show basis flat",
1131                              default = true,
1132                              toString = Bool.toString}
1133
1134 val showDefUse = control {name = "show def-use",
1135                           default = NONE,
1136                           toString = Option.toString File.toString}
1137
1138 val showTypes = control {name = "show types",
1139                          default = true,
1140                          toString = Bool.toString}
1141
1142 structure Target =
1143    struct
1144       datatype t =
1145          Cross of string
1146        | Self
1147
1148       val toString =
1149          fn Cross s => s
1150           | Self => "self"
1151    end
1152
1153 datatype target = datatype Target.t
1154
1155 val target = control {name = "target",
1156                       default = Self,
1157                       toString = Target.toString}
1158
1159 structure Target =
1160    struct
1161       open Target
1162
1163       datatype arch = datatype MLton.Platform.Arch.t
1164
1165       val arch = control {name = "target arch",
1166                           default = X86,
1167                           toString = MLton.Platform.Arch.toString}
1168
1169       datatype os = datatype MLton.Platform.OS.t
1170
1171       val os = control {name = "target OS",
1172                         default = Linux,
1173                         toString = MLton.Platform.OS.toString}
1174
1175       fun make s =
1176          let
1177             val r = ref NONE
1178             fun get () =
1179                case !r of
1180                   NONE => Error.bug ("ControlFlags.Target." ^ s ^ ": not set")
1181                 | SOME x => x
1182             fun set x = r := SOME x
1183          in
1184             (get, set)
1185          end
1186       val (bigEndian: unit -> bool, setBigEndian) = make "bigEndian"
1187
1188       structure Size =
1189          struct
1190             val (arrayMetaData: unit -> Bits.t, set_arrayMetaData) = make "Size.arrayMetaData"
1191             val (cint: unit -> Bits.t, set_cint) = make "Size.cint"
1192             val (cpointer: unit -> Bits.t, set_cpointer) = make "Size.cpointer"
1193             val (cptrdiff: unit -> Bits.t, set_cptrdiff) = make "Size.cptrdiff"
1194             val (csize: unit -> Bits.t, set_csize) = make "Size.csize"
1195             val (header: unit -> Bits.t, set_header) = make "Size.header"
1196             val (mplimb: unit -> Bits.t, set_mplimb) = make "Size.mplimb"
1197             val (normalMetaData: unit -> Bits.t, set_normalMetaData) = make "Size.noramlMetaData"
1198             val (objptr: unit -> Bits.t, set_objptr) = make "Size.objptr"
1199             val (seqIndex: unit -> Bits.t, set_seqIndex) = make "Size.seqIndex"
1200          end
1201       fun setSizes {arrayMetaData, cint, cpointer, cptrdiff, csize,
1202                     header, mplimb, normalMetaData, objptr, seqIndex} =
1203          (Size.set_arrayMetaData arrayMetaData
1204           ; Size.set_cint cint
1205           ; Size.set_cpointer cpointer
1206           ; Size.set_cptrdiff cptrdiff
1207           ; Size.set_csize csize
1208           ; Size.set_header header
1209           ; Size.set_mplimb mplimb
1210           ; Size.set_normalMetaData normalMetaData
1211           ; Size.set_objptr objptr
1212           ; Size.set_seqIndex seqIndex)
1213    end
1214
1215 fun mlbPathMap () =
1216    List.rev
1217       (List.concat
1218           [[{var = "LIB_MLTON_DIR",
1219              path = !libDir},
1220             {var = "TARGET",
1221              path = Target.toString (!target)},
1222             {var = "TARGET_ARCH",
1223              path = String.toLower (MLton.Platform.Arch.toString
1224                                     (!Target.arch))},
1225             {var = "TARGET_OS",
1226              path = String.toLower (MLton.Platform.OS.toString
1227                                     (!Target.os))},
1228             {var = "OBJPTR_REP",
1229              path = (case Bits.toInt (Target.Size.objptr ()) of
1230                         32 => "rep32"
1231                       | 64 => "rep64"
1232                       | _ => Error.bug "Control.mlbPathMap")},
1233             {var = "ARRAY_METADATA_SIZE",
1234              path = (case Bits.toInt (Target.Size.arrayMetaData ()) of
1235                         96 => "size96"
1236                       | 192 => "size192"
1237                       | _ => Error.bug "Control.mlbPathMap")},
1238             {var = "NORMAL_METADATA_SIZE",
1239              path = (case Bits.toInt (Target.Size.normalMetaData ()) of
1240                         32 => "size32"
1241                       | 64 => "size64"
1242                       | _ => Error.bug "Control.mlbPathMap")},
1243             {var = "SEQINDEX_INT",
1244              path = (case Bits.toInt (Target.Size.seqIndex ()) of
1245                         32 => "int32"
1246                       | 64 => "int64"
1247                       | _ => Error.bug "Control.mlbPathMap")},
1248             {var = "DEFAULT_CHAR",
1249              path = !defaultChar},
1250             {var = "DEFAULT_WIDECHAR",
1251              path = !defaultWideChar},
1252             {var = "DEFAULT_INT",
1253              path = !defaultInt},
1254             {var = "DEFAULT_REAL",
1255              path = !defaultReal},
1256             {var = "DEFAULT_WORD",
1257              path = !defaultWord}],
1258            !mlbPathVars])
1259
1260 val typeCheck = control {name = "type check",
1261                          default = false,
1262                          toString = Bool.toString}
1263
1264 structure Verbosity =
1265    struct
1266       datatype t =
1267          Silent
1268        | Top
1269        | Pass
1270        | Detail
1271
1272       val toString =
1273          fn Silent => "Silent"
1274           | Top => "Top"
1275           | Pass => "Pass"
1276           | Detail => "Detail"
1277    end
1278
1279 datatype verbosity = datatype Verbosity.t
1280
1281 val verbosity = control {name = "verbosity",
1282                          default = Silent,
1283                          toString = Verbosity.toString}
1284
1285 val warnAnn = control {name = "warn unrecognized annotation",
1286                        default = true,
1287                        toString = Bool.toString}
1288
1289 val warnDeprecated = control {name = "warn deprecated features",
1290                               default = true,
1291                               toString = Bool.toString}
1292
1293 val zoneCutDepth: int ref =
1294    control {name = "zone cut depth",
1295             default = 100,
1296             toString = Int.toString}
1297
1298 val defaults = setDefaults
1299
1300 val _ = defaults ()
1301
1302 end