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.
6 * MLton is released under a BSD-style license.
7 * See the file MLton-LICENSE for details.
10 functor ElaborateMLBs (S: ELABORATE_MLBS_STRUCTS): ELABORATE_MLBS =
16 open Control.Elaborate
18 val deadCode = fn () => current deadCode
21 structure ElabControl = Control.Elaborate
23 fun check (c: (bool,bool) ElabControl.t, keyword: string, region) =
24 if ElabControl.current c
32 str (concat (if ElabControl.expert c
33 then [keyword, " disallowed"]
34 else [keyword, " disallowed, compile with -default-ann '",
35 ElabControl.name c, " true'"])),
42 structure Basexp = Basexp
43 structure Basdec = Basdec
44 structure Longstrid = Longstrid
45 structure ModIdBind = ModIdBind
54 structure ElaboratePrograms = ElaboratePrograms (structure Ast = Ast
55 structure CoreML = CoreML
60 open ElaboratePrograms
66 fun elaborateMLB (mlb : Basdec.t, {addPrim}) =
68 val decs = Buffer.new {dummy = ([], false)}
74 if ElabControl.default ElabControl.forceUsed
75 then Env.forceUsedLocal (E, f)
78 val emptySnapshot : (unit -> Env.Basis.t) -> Env.Basis.t =
80 val emptySnapshot = fn (f: unit -> Env.Basis.t) =>
81 emptySnapshot (fn () => withDef f)
88 let val primDecs = addPrim E
89 in Buffer.add (decs, (primDecs, false))
92 fun elabProg p = ElaboratePrograms.elaborateProgram (p, {env = E})
94 val psi : (File.t * Env.Basis.t Promise.t) HashSet.t =
95 HashSet.new {hash = String.hash o #1}
97 val elabBasexpInfo = Trace.info "ElaborateMLBs.elabBasexp"
98 val elabBasdecInfo = Trace.info "ElaborateMLBs.elabBasdec"
100 fun elabBasexp (basexp: Basexp.t) : Env.Basis.t option =
101 Trace.traceInfo' (elabBasexpInfo,
104 (fn (basexp: Basexp.t) =>
105 case Basexp.node basexp of
109 Env.makeBasis (E, fn () => elabBasdec basdec)
113 | Basexp.Var basid => Env.lookupBasid (E, basid)
114 | Basexp.Let (basdec, basexp) =>
118 ; elabBasexp basexp))) basexp
119 and elabBasdec (basdec: Basdec.t) : unit =
120 Trace.traceInfo' (elabBasdecInfo,
123 (fn (basdec: Basdec.t) =>
124 case Basdec.node basdec of
127 fun doit (lookup, extend, bnds) =
129 (Vector.map (bnds, fn {lhs, rhs} =>
130 {lhs = lhs, rhs = lookup (E, rhs)}),
132 Option.app (rhs, fn z => extend (E, lhs, z)))
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)
142 | Basdec.Basis basbinds =>
146 (basbinds, fn {name, def} =>
147 let val B = elabBasexp def
148 in {B = B, name = name}
152 (basbinds, fn {name, B, ...} =>
153 Option.app (B, fn B => Env.extendBasid (E, name, B)))
155 | Basdec.Local (basdec1, basdec2) =>
156 Env.localAll (E, fn () =>
157 elabBasdec basdec1, fn () =>
159 | Basdec.Seq basdecs =>
160 List.foreach(basdecs, elabBasdec)
161 | Basdec.Open basids =>
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) =>
168 val prog = Promise.force prog
170 Buffer.add (decs, (Decs.toList (elabProg prog), deadCode ()))
172 | Basdec.MLB ({fileAbs, ...}, basdec) =>
175 HashSet.lookupOrInsert
176 (psi, String.hash fileAbs, fn (fileAbs', _) =>
177 String.equals (fileAbs, fileAbs'), fn () =>
179 val basdec = Promise.force basdec
186 (E, fn () => elabBasdec basdec)))
190 val B = Promise.force B
191 handle Promise.Force =>
192 (* Basis forms a cycle;
193 * force the AST to generate error message.
195 (ignore (Promise.force basdec)
196 ; #2 (Env.makeBasis (E, fn () => ())))
201 (check (ElabControl.allowPrim, "_prim", Basdec.region basdec)
202 ; Env.openBasis (E, primBasis))
203 | Basdec.Ann (ann, reg, basdec) =>
211 (reg, seq [str "unrecognized annotation: ", str ann],
216 case parseIdAndArgs ann of
220 | ElabControl.Good (id, args) =>
222 val restore = Args.processAnn args
226 if equalsId (forceUsed, id) andalso enabled forceUsed
227 then Env.forceUsedLocal (E, fn () => elabBasdec basdec)
228 else if equalsId (ffiStr, id)
230 val ffi = valOf (current ffiStr)
232 Longstrid.fromSymbols
233 (List.map (String.split (ffi, #"."),
234 Longstrid.Symbol.fromString),
240 (Env.lookupLongstrid (E, ffi),
241 fn S => (Env.Structure.ffi := SOME S
242 ; Env.Structure.forceUsed S))
244 else elabBasdec basdec,
247 | ElabControl.Other => elabBasdec basdec
248 | ElabControl.Proxy (alts, {deprecated}) =>
250 val (ids, args) = List.unzip alts
252 if !Control.warnDeprecated andalso deprecated
257 (reg, seq [str "deprecated annotation: ", str ann, str ", use ",
258 List.layout (str o ElabControl.Id.name) ids],
263 List.map (args, Args.processAnn)
266 (fn () => elabBasdec basdec,
267 fn () => List.foreach (List.rev restores, fn restore => restore ()))
271 val _ = withDef (fn () => elabBasdec mlb)
273 (E, Buffer.toVector decs)