mlton/elaborate/elaborate-mlbs.fun

   1 (* Copyright (C) 2010,2016 Matthew Fluet.
   2  * Copyright (C) 1999-2006 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 functor ElaborateMLBs (S: ELABORATE_MLBS_STRUCTS): ELABORATE_MLBS =
  11 struct
  12
  13 open S
  14
  15 local
  16    open Control.Elaborate
  17 in
  18    val deadCode = fn () => current deadCode
  19 end
  20
  21 structure ElabControl = Control.Elaborate
  22
  23 fun check (c: (bool,bool) ElabControl.t, keyword: string, region) =
  24    if ElabControl.current c
  25       then ()
  26    else
  27       let
  28          open Layout
  29       in
  30          Control.error
  31          (region,
  32           str (concat (if ElabControl.expert c
  33                           then [keyword, " disallowed"]
  34                           else [keyword, " disallowed, compile with -default-ann '",
  35                                 ElabControl.name c, " true'"])),
  36           empty)
  37       end
  38
  39 local
  40    open Ast
  41 in
  42    structure Basexp = Basexp
  43    structure Basdec = Basdec
  44    structure Longstrid = Longstrid
  45    structure ModIdBind = ModIdBind
  46 end
  47
  48 local
  49    open Env
  50 in
  51    structure Decs = Decs
  52 end
  53
  54 structure ElaboratePrograms = ElaboratePrograms (structure Ast = Ast
  55                                                  structure CoreML = CoreML
  56                                                  structure Decs = Decs
  57                                                  structure Env = Env)
  58
  59 local
  60    open ElaboratePrograms
  61 in
  62    structure Decs = Decs
  63    structure Env = Env
  64 end
  65
  66 fun elaborateMLB (mlb : Basdec.t, {addPrim}) =
  67    let
  68       val decs = Buffer.new {dummy = ([], false)}
  69
  70       val E = Env.empty ()
  71       fun withDef f =
  72          ElabControl.withDef
  73          (fn () =>
  74           if ElabControl.default ElabControl.forceUsed
  75              then Env.forceUsedLocal (E, f)
  76              else f ())
  77
  78       val emptySnapshot : (unit -> Env.Basis.t) -> Env.Basis.t =
  79          Env.snapshot E
  80       val emptySnapshot = fn (f: unit -> Env.Basis.t) =>
  81          emptySnapshot (fn () => withDef f)
  82
  83       val primBasis =
  84          emptySnapshot
  85          (fn () =>
  86           (#2 o Env.makeBasis)
  87           (E, fn () =>
  88            let val primDecs = addPrim E
  89            in Buffer.add (decs, (primDecs, false))
  90            end))
  91
  92       fun elabProg p = ElaboratePrograms.elaborateProgram (p, {env = E})
  93
  94       val psi : (File.t * Env.Basis.t Promise.t) HashSet.t =
  95          HashSet.new {hash = String.hash o #1}
  96
  97       val elabBasexpInfo = Trace.info "ElaborateMLBs.elabBasexp"
  98       val elabBasdecInfo = Trace.info "ElaborateMLBs.elabBasdec"
  99
 100       fun elabBasexp (basexp: Basexp.t) : Env.Basis.t option =
 101          Trace.traceInfo' (elabBasexpInfo,
 102                            Basexp.layout,
 103                            Layout.ignore)
 104          (fn (basexp: Basexp.t) =>
 105           case Basexp.node basexp of
 106              Basexp.Bas basdec =>
 107                 let
 108                    val ((), B) =
 109                       Env.makeBasis (E, fn () => elabBasdec basdec)
 110                 in
 111                    SOME B
 112                 end
 113            | Basexp.Var basid => Env.lookupBasid (E, basid)
 114            | Basexp.Let (basdec, basexp) =>
 115                 Env.scopeAll
 116                 (E, fn () =>
 117                  (elabBasdec basdec
 118                   ; elabBasexp basexp))) basexp
 119       and elabBasdec (basdec: Basdec.t) : unit =
 120          Trace.traceInfo' (elabBasdecInfo,
 121                            Basdec.layout,
 122                            Layout.ignore)
 123          (fn (basdec: Basdec.t) =>
 124           case Basdec.node basdec of
 125              Basdec.Defs def =>
 126                 let
 127                    fun doit (lookup, extend, bnds) =
 128                       Vector.foreach
 129                       (Vector.map (bnds, fn {lhs, rhs} =>
 130                                    {lhs = lhs, rhs = lookup (E, rhs)}),
 131                        fn {lhs, rhs} =>
 132                        Option.app (rhs, fn z => extend (E, lhs, z)))
 133                 in
 134                    case ModIdBind.node def of
 135                       ModIdBind.Fct bnds =>
 136                          doit (Env.lookupFctid, Env.extendFctid, bnds)
 137                     | ModIdBind.Sig bnds =>
 138                          doit (Env.lookupSigid, Env.extendSigid, bnds)
 139                     | ModIdBind.Str bnds =>
 140                          doit (Env.lookupStrid, Env.extendStrid, bnds)
 141                 end
 142            | Basdec.Basis basbinds =>
 143                 let
 144                    val basbinds =
 145                       Vector.map
 146                       (basbinds, fn {name, def} =>
 147                        let val B = elabBasexp def
 148                        in {B = B, name = name}
 149                        end)
 150                 in
 151                    Vector.foreach
 152                    (basbinds, fn {name, B, ...} =>
 153                     Option.app (B, fn B => Env.extendBasid (E, name, B)))
 154                 end
 155            | Basdec.Local (basdec1, basdec2) =>
 156                 Env.localAll (E, fn () =>
 157                               elabBasdec basdec1, fn () =>
 158                               elabBasdec basdec2)
 159            | Basdec.Seq basdecs =>
 160                 List.foreach(basdecs, elabBasdec)
 161            | Basdec.Open basids =>
 162                 Vector.foreach
 163                 (Vector.map (basids, fn basid =>
 164                              Env.lookupBasid (E, basid)), fn bo =>
 165                  Option.app (bo, fn b => Env.openBasis (E, b)))
 166            | Basdec.Prog (_, prog) =>
 167                 let
 168                    val prog = Promise.force prog
 169                 in
 170                    Buffer.add (decs, (Decs.toList (elabProg prog), deadCode ()))
 171                 end
 172            | Basdec.MLB ({fileAbs, ...}, basdec) =>
 173                 let
 174                    val (_, B) =
 175                       HashSet.lookupOrInsert
 176                       (psi, String.hash fileAbs, fn (fileAbs', _) =>
 177                        String.equals (fileAbs, fileAbs'), fn () =>
 178                        let
 179                           val basdec = Promise.force basdec
 180                           val B =
 181                              Promise.delay
 182                              (fn () =>
 183                               emptySnapshot
 184                               (fn () =>
 185                                (#2 o Env.makeBasis)
 186                                (E, fn () => elabBasdec basdec)))
 187                        in
 188                           (fileAbs, B)
 189                        end)
 190                    val B = Promise.force B
 191                            handle Promise.Force =>
 192                            (* Basis forms a cycle;
 193                             * force the AST to generate error message.
 194                             *)
 195                            (ignore (Promise.force basdec)
 196                             ; #2 (Env.makeBasis (E, fn () => ())))
 197                 in
 198                    Env.openBasis (E, B)
 199                 end
 200            | Basdec.Prim =>
 201                 (check (ElabControl.allowPrim, "_prim", Basdec.region basdec)
 202                  ; Env.openBasis (E, primBasis))
 203            | Basdec.Ann (ann, reg, basdec) =>
 204                 let
 205                    open ElabControl
 206                    fun warn () =
 207                       if !Control.warnAnn
 208                          then let open Layout
 209                               in
 210                                  Control.warning
 211                                  (reg, seq [str "unrecognized annotation: ", str ann],
 212                                   empty)
 213                               end
 214                          else ()
 215                 in
 216                    case parseIdAndArgs ann of
 217                       ElabControl.Bad =>
 218                          (warn ()
 219                           ; elabBasdec basdec)
 220                     | ElabControl.Good (id, args) =>
 221                          let
 222                             val restore = Args.processAnn args
 223                          in
 224                             Exn.finally
 225                             (fn () =>
 226                              if equalsId (forceUsed, id) andalso enabled forceUsed
 227                                 then Env.forceUsedLocal (E, fn () => elabBasdec basdec)
 228                              else if equalsId (ffiStr, id)
 229                                 then let
 230                                         val ffi = valOf (current ffiStr)
 231                                         val ffi =
 232                                            Longstrid.fromSymbols
 233                                            (List.map (String.split (ffi, #"."),
 234                                                       Longstrid.Symbol.fromString),
 235                                             reg)
 236                                      in
 237                                         elabBasdec basdec
 238                                         before
 239                                         Option.app
 240                                         (Env.lookupLongstrid (E, ffi),
 241                                          fn S => (Env.Structure.ffi := SOME S
 242                                                   ; Env.Structure.forceUsed S))
 243                                      end
 244                              else elabBasdec basdec,
 245                              restore)
 246                          end
 247                     | ElabControl.Other => elabBasdec basdec
 248                     | ElabControl.Proxy (alts, {deprecated}) =>
 249                          let
 250                             val (ids, args) = List.unzip alts
 251                             val () =
 252                                if !Control.warnDeprecated andalso deprecated
 253                                   then
 254                                      let open Layout
 255                                      in
 256                                         Control.warning
 257                                         (reg, seq [str "deprecated annotation: ", str ann, str ", use ",
 258                                                    List.layout (str o ElabControl.Id.name) ids],
 259                                          empty)
 260                                      end
 261                                else ()
 262                             val restores =
 263                                List.map (args, Args.processAnn)
 264                          in
 265                             Exn.finally
 266                             (fn () => elabBasdec basdec,
 267                              fn () => List.foreach (List.rev restores, fn restore => restore ()))
 268                          end
 269
 270                 end) basdec
 271       val _ = withDef (fn () => elabBasdec mlb)
 272    in
 273       (E, Buffer.toVector decs)
 274    end
 275
 276 end