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/bootstrap/btcompile.sml
ViewVC logotype

Diff of /sml/trunk/src/cm/bootstrap/btcompile.sml

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

revision 518, Wed Jan 12 06:26:25 2000 UTC revision 537, Fri Feb 18 17:20:16 2000 UTC
# Line 45  Line 45 
45    
46      (* instantiate Stabilize... *)      (* instantiate Stabilize... *)
47      structure Stabilize =      structure Stabilize =
48          StabilizeFn (fun destroy_state _ i = Compile.evict i          StabilizeFn (structure MachDepVC = MachDepVC
                      structure MachDepVC = MachDepVC  
49                       fun recomp gp g = let                       fun recomp gp g = let
50                           val { store, get } = BFC.new ()                           val { store, get } = BFC.new ()
51                           val _ = init_servers g                           val _ = init_servers g
# Line 62  Line 61 
61    
62      (* ... and Parse *)      (* ... and Parse *)
63      structure Parse = ParseFn (structure Stabilize = Stabilize      structure Parse = ParseFn (structure Stabilize = Stabilize
64                                   val evictStale = Compile.evictStale
65                                 fun pending () = SymbolMap.empty)                                 fun pending () = SymbolMap.empty)
66    
67      (* copying an input file to an output file safely... *)      fun mkBootList g = let
68      fun copyFile (oi, ci, oo, co, inp, outp, eof) (inf, outf) = let          fun listName p =
69          fun workIn is = let              case P.fromString p of
70              fun workOut os = let                  { vol = "", isAbs = false, arcs = _ :: arc1 :: arcn } => let
71                  val N = 4096                      fun win32name () =
72                  fun loop () =                          concat (arc1 ::
73                      if eof is then () else (outp (os, inp (is, N)); loop ())                                  foldr (fn (a, r) => "\\" :: a :: r) [] arcn)
             in  
                 loop ()  
             end  
74          in          in
75              SafeIO.perform { openIt = fn () => oo outf,                      case os of
76                               closeIt = co,                          SMLofNJ.SysInfo.WIN32 => win32name ()
77                               work = workOut,                        | _ => P.toString { isAbs = false, vol = "",
78                               cleanup = fn _ =>                                            arcs = arc1 :: arcn }
                                  (F.remove outf handle _ => ()) }  
79          end          end
80                  | _ => raise Fail ("BootstrapCompile:listName: bad name: " ^ p)
81      in      in
82          SafeIO.perform { openIt = fn () => oi inf,          MkBootList.group listName g
                          closeIt = ci,  
                          work = workIn,  
                          cleanup = fn _ => () }  
83      end      end
84    
     val copyTextFile =  
         copyFile (TextIO.openIn, TextIO.closeIn,  
                   AutoDir.openTextOut, TextIO.closeOut,  
                   TextIO.inputN, TextIO.output, TextIO.endOfStream)  
   
     val copyBinFile =  
         copyFile (BinIO.openIn, BinIO.closeIn,  
                   AutoDir.openBinOut, BinIO.closeOut,  
                   BinIO.inputN, BinIO.output, BinIO.endOfStream)  
   
85      fun mk_compile deliver root dbopt = let      fun mk_compile deliver root dbopt = let
86    
87          val dirbase = getOpt (dbopt, BtNames.dirbaseDefault)          val dirbase = getOpt (dbopt, BtNames.dirbaseDefault)
# Line 105  Line 89 
89          val initgspec = BtNames.initgspec          val initgspec = BtNames.initgspec
90          val maingspec = BtNames.maingspec          val maingspec = BtNames.maingspec
91    
92          val bindir = concat [dirbase, ".bin.", archos]          val bindir = concat [dirbase, BtNames.bin_infix, archos]
93          val bootdir = concat [dirbase, ".boot.", archos]          val bootdir = concat [dirbase, BtNames.boot_infix, archos]
   
         fun listName (p, copy) =  
             case P.fromString p of  
                 { vol = "", isAbs = false, arcs = arc0 :: arc1 :: arcn } => let  
                     fun win32name () =  
                         concat (arc1 ::  
                                 foldr (fn (a, r) => "\\" :: a :: r) [] arcn)  
                     fun doCopy () = let  
                         val bootpath =  
                             P.toString { isAbs = false, vol = "",  
                                          arcs = bootdir :: arc1 :: arcn }  
                     in  
                         copyBinFile (p, bootpath)  
                     end  
                 in  
                     if copy andalso arc0 = bindir then doCopy () else ();  
                     case os of  
                         SMLofNJ.SysInfo.WIN32 => win32name ()  
                       | _ => P.toString { isAbs = false, vol = "",  
                                           arcs = arc1 :: arcn }  
                 end  
               | _ => raise Fail "BootstrapCompile:listName: bad name"  
94    
95          val keep_going = #get StdConfig.keep_going ()          val keep_going = #get StdConfig.keep_going ()
96    
97          val ctxt = SrcPath.cwdContext ()          val ctxt = SrcPath.cwdContext ()
98    
99          val pidfile = P.joinDirFile { dir = bootdir, file = "RTPID" }          val listfile = P.joinDirFile { dir = bootdir, file = BtNames.bootlist }
100          val listfile = P.joinDirFile { dir = bootdir, file = "BOOTLIST" }          val pidmapfile = P.joinDirFile { dir = bootdir, file = BtNames.pidmap }
101    
102          val pcmode = PathConfig.new ()          val pcmode = PathConfig.new ()
103          val _ = PathConfig.processSpecFile (pcmode, pcmodespec)          val _ = PathConfig.processSpecFile (pcmode, pcmodespec)
# Line 148  Line 110 
110                  NONE => stdpath maingspec                  NONE => stdpath maingspec
111                | SOME r => SrcPath.fromDescr pcmode r                | SOME r => SrcPath.fromDescr pcmode r
112    
         val cmifile = valOf (SrcPath.reAnchoredName (initgspec, bootdir))  
             handle Option => raise Fail "BootstrapCompile: cmifile"  
   
113          val fnpolicy =          val fnpolicy =
114              FilenamePolicy.separate { bindir = bindir, bootdir = bootdir }              FilenamePolicy.separate { bindir = bindir, bootdir = bootdir }
115                  { arch = arch, os = os }                  { arch = arch, os = os }
116    
117          fun mkParam { primconf, pervasive, pervcorepids }          fun mkParam corenv =
118                      { corenv } =              { fnpolicy = fnpolicy,
             { primconf = primconf,  
               fnpolicy = fnpolicy,  
119                pcmode = pcmode,                pcmode = pcmode,
120                symval = SSV.symval,                symval = SSV.symval,
121                keep_going = keep_going,                keep_going = keep_going,
122                pervasive = pervasive,                corenv = corenv }
               corenv = corenv,  
               pervcorepids = pervcorepids }  
123    
124          val emptydyn = E.dynamicPart E.emptyEnv          val emptydyn = E.dynamicPart E.emptyEnv
125    
126          (* first, build an initial GeneralParam.info, so we can          (* first, build an initial GeneralParam.info, so we can
127           * deal with the pervasive env and friends... *)           * deal with the pervasive env and friends... *)
128    
129          val primconf = Primitive.primEnvConf          val param_nocore = mkParam BE.emptyEnv
         val mkInitParam = mkParam { primconf = primconf,  
                                     pervasive = E.emptyEnv,  
                                     pervcorepids = PidSet.empty }  
   
         val param_nocore = mkInitParam { corenv = BE.staticPart BE.emptyEnv }  
130    
131          val groupreg = GroupReg.new ()          val groupreg = GroupReg.new ()
132          val errcons = EM.defaultConsumer ()          val errcons = EM.defaultConsumer ()
# Line 185  Line 135 
135    
136          fun mk_main_compile arg = let          fun mk_main_compile arg = let
137    
138              val { rts, core, pervasive, primitives, binpaths } = arg              val { core = core_n, pervasive = perv_n, others, src } = arg
139    
140              val ovldR = GenericVC.Control.overloadKW              val ovldR = GenericVC.Control.overloadKW
141              val savedOvld = !ovldR              val savedOvld = !ovldR
# Line 194  Line 144 
144    
145              (* here we build a new gp -- the one that uses the freshly              (* here we build a new gp -- the one that uses the freshly
146               * brewed pervasive env, core env, and primitives *)               * brewed pervasive env, core env, and primitives *)
147              val core = valOf (sbnode ginfo_nocore core)              val core = valOf (sbnode ginfo_nocore core_n)
148              val corenv =  CoerceEnv.es2bs (#env (#statenv core ()))              val corenv =
149              val core_sym = #symenv core ()                  BE.mkenv { static = CoerceEnv.es2bs (#env (#statenv core ())),
150                               symbolic = #symenv core (),
151                               dynamic = BE.dynamicPart BE.emptyEnv }
152    
153              (* The following is a bit of a hack (but corenv is a hack anyway):              (* The following is a bit of a hack (but corenv is a hack anyway):
154               * As soon as we have core available, we have to patch the               * As soon as we have core available, we have to patch the
155               * ginfo to include the correct corenv (because virtually               * ginfo to include the correct corenv (because virtually
156               * everybody else needs access to corenv). *)               * everybody else needs access to corenv). *)
157              val param_justcore = mkInitParam { corenv = corenv }              val param = mkParam corenv
158              val ginfo_justcore = { param = param_justcore, groupreg = groupreg,              val ginfo =
159                                     errcons = errcons }                  { param = param, groupreg = groupreg, errcons = errcons }
160    
161                val perv_fsbnode = (NONE, perv_n)
162    
163                fun rt n = valOf (sbnode ginfo n)
164                val pervasive = rt perv_n
165    
166              fun rt n = valOf (sbnode ginfo_justcore n)              fun rt2ie (n, ii: IInfo.info) = let
167              val rts = rt rts                  val bs = CoerceEnv.es2bs (#env (#statenv ii ()))
168              val pervasive = rt pervasive                  val (dae, mkDomain) = Statenv2DAEnv.cvt bs
   
             fun sn2pspec (name, n) = let  
                 val { statenv, symenv, statpid, sympid } = rt n  
                 val { env = static, ctxt } = statenv ()  
                 val env =  
                     E.mkenv { static = static,  
                               symbolic = symenv (),  
                               dynamic = emptydyn }  
                 val pidInfo =  
                     { statpid = statpid, sympid = sympid, ctxt = ctxt }  
169              in              in
170                  { name = name, env = env, pidInfo = pidInfo }                  { ie = ((NONE, n), dae), mkDomain = mkDomain }
171              end              end
172    
173              val pspecs = map sn2pspec primitives              fun add_exports (n, exports) = let
174                    val { ie, mkDomain } = rt2ie (n, rt n)
175                    fun ins_ie (sy, m) = SymbolMap.insert (m, sy, ie)
176                in
177                    SymbolSet.foldl ins_ie exports (mkDomain ())
178                end
179    
180                val special_exports = let
181                    fun mkie (n, rtn) = #ie (rt2ie (n, rtn))
182                in
183                    foldl SymbolMap.insert' SymbolMap.empty
184                          [(PervCoreAccess.pervStrSym, mkie (perv_n, pervasive)),
185                           (PervCoreAccess.coreStrSym, mkie (core_n, core))]
186                end
187    
188                val init_group = GroupGraph.GROUP
189                    { exports = foldl add_exports special_exports others,
190                      kind = GroupGraph.LIB (StringSet.empty, []),
191                      required = StringSet.singleton "primitive",
192                      grouppath = initgspec,
193                      sublibs = [] }
194    
195              val _ = ovldR := savedOvld              val _ = ovldR := savedOvld
196    
197              (* The following is a hack but must be done for both the symbolic              (* At this point we check if there is a usable stable version
198               * and later the dynamic part of the core environment:               * of the init group.  If so, we continue to use that. *)
199               * we must include these parts in the pervasive env. *)              val (stab, init_group, deliver) = let
200              val perv_sym = E.layerSymbolic (#symenv pervasive (),                  fun nostabinit () =
201                                              core_sym)                      if deliver then
202                            let val stabarg = { group = init_group,
203              val param =                                              anyerrors = ref false }
204                  mkParam { primconf = Primitive.configuration pspecs,                          in
205                            pervasive =                              case Stabilize.stabilize ginfo stabarg of
206                            E.mkenv { static = #env (#statenv pervasive ()),                                  SOME g => (SOME true, g, true)
207                                      symbolic = perv_sym,                                (* if we cannot stabilize the init group, then
208                                      dynamic = emptydyn },                                 * as a first remedy we turn delivery off *)
209                            pervcorepids =                                | NONE => (NONE, init_group, false)
210                              PidSet.addList (PidSet.empty,                          end
211                                              [#statpid pervasive,                      else (NONE, init_group, false)
212                                               #sympid pervasive,              in
213                                               #statpid core]) }                  if VerifyStable.verify ginfo init_group then let
214                          { corenv = corenv }                      fun load () =
215              val stab =                          Stabilize.loadStable ginfo
216                  if deliver then SOME true else NONE                            { getGroup = fn _ =>
217                                   raise Fail "CMB: initial getGroup",
218                                anyerrors = ref false }
219                              initgspec
220                    in
221                        case load () of
222                            NONE => nostabinit ()
223                          | SOME g =>
224                                (if deliver then SOME true else NONE, g, deliver)
225                    end
226                    else nostabinit ()
227                end
228    
229                val gr = GroupReg.new ()
230                val _ = GroupReg.register gr (initgspec, src)
231    
232                val parse_arg =
233                    { load_plugin = load_plugin,
234                      gr = gr,
235                      param = param,
236                      stabflag = stab,
237                      group = maingspec,
238                      init_group = init_group,
239                      paranoid = true }
240          in          in
241              Servers.dirbase dirbase;              Servers.dirbase dirbase;
242              case Parse.parse load_plugin NONE param stab maingspec of              Parse.reset ();
243                case Parse.parse parse_arg of
244                  NONE => NONE                  NONE => NONE
245                | SOME (g, gp) => let                | SOME (g, gp) => let
246                      fun thunk () = let                      fun thunk () = let
# Line 261  Line 252 
252                              Servers.withServers (fn () => recomp gp)                              Servers.withServers (fn () => recomp gp)
253                      in                      in
254                          if isSome res then let                          if isSome res then let
255                              val rtspid = PS.toHex (#statpid rts)                              val { l = bootitems, ss } = mkBootList g
256                              fun writeList s = let                              val stablelibs = Reachable.stableLibsOf g
257                                  fun add ((p, flag), l) = let                              fun inSet bi = StableSet.member (ss, bi)
258                                      val n = listName (p, true)                              val frontiers =
259                                  in                                  SrcPathMap.map (Reachable.frontier inSet)
260                                      if flag then n :: l else l                                                 stablelibs
261                                  end                              fun writeBootList s = let
262                                  fun transcribe (p, NONE) = listName (p, true)                                  fun wr str = TextIO.output (s, str ^ "\n")
                                   | transcribe (p, SOME (off, desc)) =  
                                     concat [listName (p, false),  
                                             "@", Int.toString off, ":", desc]  
                                 val bootstrings =  
                                     foldr add  
                                           (map transcribe (MkBootList.group g))  
                                           binpaths  
                                 fun show str =  
                                     (TextIO.output (s, str);  
                                      TextIO.output (s, "\n"))  
263                              in                              in
264                                  app show bootstrings                                  app wr bootitems
265                              end                              end
266                                fun writePid s i = let
267                                    val sn = BinInfo.stablename i
268                                    val os = BinInfo.offset i
269                                    val descr = BinInfo.describe i
270                                    val bfc = BFC.getStable
271                                        { stable = sn, offset = os, descr = descr }
272                                in
273                                    case BF.exportPidOf bfc of
274                                        NONE => ()
275                                      | SOME pid =>
276                                            (TextIO.output (s, " ");
277                                             TextIO.output (s, PS.toHex pid))
278                                end
279                                fun writePidLine s (p, set) =
280                                    if StableSet.isEmpty set then ()
281                                    else (TextIO.output (s, SrcPath.descr p);
282                                          StableSet.app (writePid s) set;
283                                          TextIO.output (s, "\n"))
284                                fun writePidMap s =
285                                    SrcPathMap.appi (writePidLine s) frontiers
286                          in                          in
287                              if deliver then                              if deliver then
288                                  (SafeIO.perform                                  (SafeIO.perform
289                                   { openIt = fn () =>                                   { openIt = fn () =>
290                                         AutoDir.openTextOut pidfile,                                         AutoDir.openTextOut listfile,
291                                     closeIt = TextIO.closeOut,                                     closeIt = TextIO.closeOut,
292                                     work = fn s =>                                     work = writeBootList,
                                        TextIO.output (s, rtspid ^ "\n"),  
293                                     cleanup = fn _ =>                                     cleanup = fn _ =>
294                                         OS.FileSys.remove pidfile                                         OS.FileSys.remove listfile
295                                         handle _ => () };                                         handle _ => () };
296                                   SafeIO.perform                                   SafeIO.perform
297                                   { openIt = fn () =>                                   { openIt = fn () =>
298                                         AutoDir.openTextOut listfile,                                         AutoDir.openTextOut pidmapfile,
299                                     closeIt = TextIO.closeOut,                                     closeIt = TextIO.closeOut,
300                                     work = writeList,                                     work = writePidMap,
301                                     cleanup = fn _ =>                                     cleanup = fn _ =>
302                                         OS.FileSys.remove listfile                                         OS.FileSys.remove pidmapfile
303                                         handle _ => () };                                         handle _ => () };
304                                   copyTextFile (SrcPath.osstring initgspec,                                   Say.say
305                                                 cmifile);                                        ["New boot directory has been built.\n"])
                                  Say.say ["Runtime System PID is: ",  
                                           rtspid, "\n"])  
306                              else ();                              else ();
307                              true                              true
308                          end                          end

Legend:
Removed from v.518  
changed lines
  Added in v.537

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