Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Diff of /sml/trunk/src/cm/compile/compile.sml
ViewVC logotype

Diff of /sml/trunk/src/cm/compile/compile.sml

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 447, Tue Oct 19 07:34:25 1999 UTC revision 448, Thu Oct 21 09:20:16 1999 UTC
# Line 46  Line 46 
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    
# Line 231  Line 232 
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,
# Line 281  Line 282 
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
# Line 318  Line 324 
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
# Line 351  Line 375 
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    
# Line 378  Line 403 
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

Legend:
Removed from v.447  
changed lines
  Added in v.448

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0