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 461, Thu Nov 4 08:06:56 1999 UTC revision 462, Fri Nov 5 05:45:48 1999 UTC
# Line 171  Line 171 
171              { envs = fn () => rlayer (e (), e' ()),              { envs = fn () => rlayer (e (), e' ()),
172                pids = PidSet.union (p, p') }                pids = PidSet.union (p, p') }
173    
174          fun layerwork k w v0 l = let          (* I would rather not use an exception here, but short of a better
175              fun lw v0 [] = v0           * implementation of concurrency I see no choice.
176                | lw NONE (h :: t) =           * The problem is that at each node we sequentiallay wait for the
177                  if k then (ignore (w h); lw NONE t)           * children nodes.  But the scheduler might (and probably will)
178                  else NONE           * let a child run that we are not currently waiting for, so an
179                | lw (SOME v) (h :: t) = let           * error there will not result in "wait" to immediately return
180                      fun lay (NONE, v) = NONE           * as it should for clean error recovery.
181                        | lay (SOME v', v) = SOME (layer (v', v))           * Using the exception avoids having to implement a
182                  in           * "wait for any child -- whichever finishes first" kind of call. *)
183                      lw (lay (w h, v)) t          exception Abort
184                  end  
185          in          fun layer'wait u (p, NONE) =
186              lw v0 l              (ignore (Concur.waitU u p); NONE)
187          end            | layer'wait u (p, SOME e) =
188                (case Concur.waitU u p of
189                     SOME e' => SOME (layer (e', e))
190                   | NONE => NONE)
191    
192          fun mkTraversal (notify, storeBFC, getUrgency) = let          fun mkTraversal (notify, storeBFC, getUrgency) = let
193              val localstate = ref SmlInfoMap.empty              val localstate = ref SmlInfoMap.empty
# Line 221  Line 224 
224                  val { smlinfo = i, localimports = li, globalimports = gi } = n                  val { smlinfo = i, localimports = li, globalimports = gi } = n
225                  val binname = SmlInfo.binname i                  val binname = SmlInfo.binname i
226    
227                    fun fail () =
228                        if #keep_going (#param gp) then NONE else raise Abort
229    
230                  fun compile_here (stat, sym, pids) = let                  fun compile_here (stat, sym, pids) = let
231                      fun save bfc = let                      fun save bfc = let
232                          fun writer s =                          fun writer s =
# Line 248  Line 254 
254                      end (* save *)                      end (* save *)
255                  in                  in
256                      case SmlInfo.parsetree gp i of                      case SmlInfo.parsetree gp i of
257                          NONE => NONE                          NONE => fail ()
258                        | SOME (ast, source) => let                        | SOME (ast, source) => let
259                              val corenv = #corenv (#param gp)                              val corenv = #corenv (#param gp)
260                              val cmData = PidSet.listItems pids                              val cmData = PidSet.listItems pids
# Line 268  Line 274 
274                              save bfc;                              save bfc;
275                              storeBFC (i, bfc);                              storeBFC (i, bfc);
276                              SOME memo                              SOME memo
277                          end handle _ => NONE (* catch elaborator exn *)                          end handle _ => fail () (* catch elaborator exn *)
278                  end (* compile_here *)                  end (* compile_here *)
279                  fun notlocal () = let                  fun notlocal () = let
280                      val urgency = getUrgency i                      val urgency = getUrgency i
281                      (* Ok, it is not in the local state, so we first have                      (* Ok, it is not in the local state, so we first have
282                       * to traverse all children before we can proceed... *)                       * to traverse all children before we can proceed... *)
                     val k = #keep_going (#param gp)  
283                      fun loc li_n = Option.map nofilter (snode gp li_n)                      fun loc li_n = Option.map nofilter (snode gp li_n)
284                      fun glob gi_n = fsbnode gp gi_n                      fun glob gi_n = fsbnode gp gi_n
285                      val gi_cl =                      val gi_cl =
# Line 282  Line 287 
287                      val li_cl =                      val li_cl =
288                          map (fn li_n => Concur.fork (fn () => loc li_n)) li                          map (fn li_n => Concur.fork (fn () => loc li_n)) li
289                      val e =                      val e =
290                          layerwork k (Concur.wait' urgency)                          foldl (layer'wait urgency)
291                                   (layerwork k (Concur.wait' urgency)                                (foldl (layer'wait urgency)
292                                                (SOME (pervenv gp)) gi_cl)                                       (SOME (pervenv gp))
293                                         gi_cl)
294                                   li_cl                                   li_cl
295                  in                  in
296                      case e of                      case e of
# Line 364  Line 370 
370                          end                          end
371                  end (* notlocal *)                  end (* notlocal *)
372              in              in
373                    (* Here we just wait (no "waitU") so we don't get
374                     * priority over threads that may have to clean up after
375                     * errors. *)
376                  case SmlInfoMap.find (!localstate, i) of                  case SmlInfoMap.find (!localstate, i) of
377                      SOME mopt_c => Option.map memo2ed (Concur.wait mopt_c)                      SOME mopt_c => Option.map memo2ed (Concur.wait mopt_c)
378                    | NONE => let                    | NONE => let
# Line 391  Line 400 
400              fun getUrgency i = getOpt (SmlInfoMap.find (um, i), 0)              fun getUrgency i = getOpt (SmlInfoMap.find (um, i), 0)
401              val { impexp, ... } = mkTraversal (notify, storeBFC, getUrgency)              val { impexp, ... } = mkTraversal (notify, storeBFC, getUrgency)
402              fun group gp = let              fun group gp = let
                 val k = #keep_going (#param gp)  
                 fun loop ([], success) = success  
                   | loop (h :: t, success) =  
                     if isSome (impexp gp h) then loop (t, success)  
                     else if k then loop (t, false) else false  
403                  val eo_cl =                  val eo_cl =
404                      map (fn x => Concur.fork (fn () => impexp gp x))                      map (fn x => Concur.fork (fn () => impexp gp x))
405                          (SymbolMap.listItems exports)                          (SymbolMap.listItems exports)
406                  val eo = layerwork k Concur.wait (SOME emptyEnv) eo_cl                  val eo = foldl (layer'wait 0) (SOME emptyEnv) eo_cl
407              in              in
408                  case eo of                  case eo of
409                      NONE => (Servers.reset false; NONE)                      NONE => (Servers.reset false; NONE)
410                    | SOME e => SOME (#envs e ())                    | SOME e => SOME (#envs e ())
411              end              end handle Abort => (Servers.reset false; NONE)
412              fun mkExport ie gp =              fun mkExport ie gp =
413                  case impexp gp ie of                  case impexp gp ie handle Abort => NONE of
414                      NONE => (Servers.reset false; NONE)                      NONE => (Servers.reset false; NONE)
415                    | SOME e => SOME (#envs e ())                    | SOME e => SOME (#envs e ())
416          in          in
# Line 419  Line 423 
423                                                 fn _ => (),                                                 fn _ => (),
424                                                 fn _ => 0)                                                 fn _ => 0)
425              fun sbn_trav gp g = let              fun sbn_trav gp g = let
426                  val r = sbnode gp g                  val r = sbnode gp g handle Abort => NONE
427              in              in
428                  if isSome r then () else Servers.reset false;                  if isSome r then () else Servers.reset false;
429                  r                  r

Legend:
Removed from v.461  
changed lines
  Added in v.462

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