| 46 |
exports: (GP.info -> result option) SymbolMap.map } |
exports: (GP.info -> result option) SymbolMap.map } |
| 47 |
end |
end |
| 48 |
|
|
| 49 |
functor CompileFn (structure MachDepVC : MACHDEP_VC) :> |
functor CompileFn (structure MachDepVC : MACHDEP_VC |
| 50 |
|
val compile_there : SrcPath.t -> bool) :> |
| 51 |
COMPILE where type bfc = MachDepVC.Binfile.bfContent = |
COMPILE where type bfc = MachDepVC.Binfile.bfContent = |
| 52 |
struct |
struct |
| 53 |
|
|
| 232 |
val { smlinfo = i, localimports = li, globalimports = gi } = n |
val { smlinfo = i, localimports = li, globalimports = gi } = n |
| 233 |
val binname = SmlInfo.binname i |
val binname = SmlInfo.binname i |
| 234 |
|
|
| 235 |
fun compile (stat, sym, pids) = let |
fun compile_here (stat, sym, pids) = let |
| 236 |
fun save bfc = let |
fun save bfc = let |
| 237 |
fun writer s = |
fun writer s = |
| 238 |
(BF.write { stream = s, content = bfc, |
(BF.write { stream = s, content = bfc, |
| 282 |
storeBFC (i, bfc); |
storeBFC (i, bfc); |
| 283 |
SOME memo |
SOME memo |
| 284 |
end |
end |
| 285 |
end (* compile *) |
end (* compile_here *) |
| 286 |
fun notlocal () = let |
fun notlocal () = let |
| 287 |
(* Ok, it is not in the local state, so we first have |
(* Ok, it is not in the local state, so we first have |
| 288 |
* to traverse all children before we can proceed... *) |
* to traverse all children before we can proceed... *) |
| 289 |
val k = #keep_going (#param gp) |
val k = #keep_going (#param gp) |
| 290 |
fun loc li_n = Option.map nofilter (snode gp li_n) |
fun loc li_n = Option.map nofilter (snode gp li_n) |
| 291 |
fun glob gi_n = fsbnode gp gi_n |
fun glob gi_n = fsbnode gp gi_n |
| 292 |
|
val gi_cl = |
| 293 |
|
map (fn gi_n => Concur.fork (fn () => glob gi_n)) gi |
| 294 |
|
val li_cl = |
| 295 |
|
map (fn li_n => Concur.fork (fn () => loc li_n)) li |
| 296 |
val e = |
val e = |
| 297 |
layerwork k loc |
layerwork k Concur.wait |
| 298 |
(layerwork k glob (SOME (pervenv gp)) gi) |
(layerwork k Concur.wait |
| 299 |
li |
(SOME (pervenv gp)) gi_cl) |
| 300 |
|
li_cl |
| 301 |
in |
in |
| 302 |
case e of |
case e of |
| 303 |
NONE => NONE |
NONE => NONE |
| 324 |
cleanup = fn () => () }) |
cleanup = fn () => () }) |
| 325 |
handle _ => NONE |
handle _ => NONE |
| 326 |
end (* load *) |
end (* load *) |
| 327 |
in |
fun tryload (what, otherwise) = |
| 328 |
case load () of |
case load () of |
| 329 |
NONE => compile (stat, sym, pids) |
NONE => otherwise () |
| 330 |
| SOME (bfc, ts) => let |
| SOME (bfc, ts) => let |
| 331 |
val memo = bfc2memo (bfc, stat, ts) |
val memo = bfc2memo (bfc, stat, ts) |
| 332 |
in |
in |
| 333 |
if isValidMemo (memo, pids, i) then |
if isValidMemo (memo, pids, i) then |
| 334 |
(Say.vsay ["[", binname, |
(Say.vsay ["[", binname, |
| 335 |
" loaded]\n"]; |
" ", what, "]\n"]; |
| 336 |
storeBFC (i, bfc); |
storeBFC (i, bfc); |
| 337 |
SOME memo) |
SOME memo) |
| 338 |
else compile (stat, sym, pids) |
else otherwise () |
| 339 |
end |
end |
| 340 |
|
fun compile_again () = |
| 341 |
|
compile_here (stat, sym, pids) |
| 342 |
|
fun compile () = let |
| 343 |
|
val sp = SmlInfo.sourcepath i |
| 344 |
|
in |
| 345 |
|
if compile_there sp then |
| 346 |
|
tryload ("compiled", compile_again) |
| 347 |
|
else compile_again () |
| 348 |
|
end |
| 349 |
|
in |
| 350 |
|
(* If anything goes wrong loading the first |
| 351 |
|
* time, we go and compile. Compiling |
| 352 |
|
* may mean compiling externally, and if so, |
| 353 |
|
* we must load the result of that. |
| 354 |
|
* If the second load also goes wrong, we |
| 355 |
|
* compile locally to gather error messages |
| 356 |
|
* and make everything look "normal". *) |
| 357 |
|
tryload ("loaded", compile) |
| 358 |
end (* fromfile *) |
end (* fromfile *) |
| 359 |
fun notglobal () = |
fun notglobal () = |
| 360 |
case fromfile () of |
case fromfile () of |
| 375 |
end (* notlocal *) |
end (* notlocal *) |
| 376 |
in |
in |
| 377 |
case SmlInfoMap.find (!localstate, i) of |
case SmlInfoMap.find (!localstate, i) of |
| 378 |
SOME mopt => Option.map memo2ed mopt |
SOME mopt_c => Option.map memo2ed (Concur.wait mopt_c) |
| 379 |
| NONE => let |
| NONE => let |
| 380 |
val mopt = notlocal () |
val mopt_c = Concur.fork |
| 381 |
in |
(fn () => notlocal () before |
| 382 |
(* "Not local" means that we have not processed |
(* "Not local" means that we have not processed |
| 383 |
* this file before. Therefore, we should now |
* this file before. Therefore, we should now |
| 384 |
* remove its parse tree... *) |
* remove its parse tree... *) |
| 385 |
SmlInfo.forgetParsetree i; |
SmlInfo.forgetParsetree i) |
| 386 |
|
in |
| 387 |
localstate := |
localstate := |
| 388 |
SmlInfoMap.insert (!localstate, i, mopt); |
SmlInfoMap.insert (!localstate, i, mopt_c); |
| 389 |
Option.map memo2ed mopt |
Option.map memo2ed (Concur.wait mopt_c) |
| 390 |
end |
end |
| 391 |
end (* snode *) |
end (* snode *) |
| 392 |
|
|
| 403 |
| loop (h :: t, success) = |
| loop (h :: t, success) = |
| 404 |
if isSome (impexp gp h) then loop (t, success) |
if isSome (impexp gp h) then loop (t, success) |
| 405 |
else if k then loop (t, false) else false |
else if k then loop (t, false) else false |
| 406 |
val eo = |
val eo_cl = |
| 407 |
layerwork k (impexp gp) (SOME emptyEnv) |
map (fn x => Concur.fork (fn () => impexp gp x)) |
| 408 |
(SymbolMap.listItems exports) |
(SymbolMap.listItems exports) |
| 409 |
|
val eo = layerwork k Concur.wait (SOME emptyEnv) eo_cl |
| 410 |
in |
in |
| 411 |
case eo of |
case eo of |
| 412 |
NONE => NONE |
NONE => NONE |
Parent Directory
| 
Revision Log
| 
Patch
