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 357, Mon Jun 28 08:46:30 1999 UTC revision 537, Fri Feb 18 17:20:16 2000 UTC
# Line 7  Line 7 
7   * Author: Matthias Blume (blume@kurims.kyoto-u.ac.jp)   * Author: Matthias Blume (blume@kurims.kyoto-u.ac.jp)
8   *)   *)
9  functor BootstrapCompileFn (structure MachDepVC: MACHDEP_VC  functor BootstrapCompileFn (structure MachDepVC: MACHDEP_VC
10                              val os: SMLofNJ.SysInfo.os_kind) :> sig                              val os : SMLofNJ.SysInfo.os_kind
11                                val load_plugin : string -> bool) :> sig
12      val compile :      val make' : string option -> bool
13          { dirbase: string,      val make : unit -> bool
14            pcmodespec: string,      val deliver' : string option -> bool
15            initgspec: string,      val deliver : unit -> bool
16            maingspec: string,      val reset : unit -> unit
17            stabilize: bool }      val symval : string -> { get: unit -> int option, set: int option -> unit }
         -> bool  
   
18  end = struct  end = struct
19    
20      structure EM = GenericVC.ErrorMsg      structure EM = GenericVC.ErrorMsg
# Line 27  Line 25 
25      structure CoerceEnv = GenericVC.CoerceEnv      structure CoerceEnv = GenericVC.CoerceEnv
26      structure SSV = SpecificSymValFn (structure MachDepVC = MachDepVC      structure SSV = SpecificSymValFn (structure MachDepVC = MachDepVC
27                                        val os = os)                                        val os = os)
28        structure P = OS.Path
29      (* Since the bootstrap compiler never executes any of the code      structure F = OS.FileSys
30       * it produces, we don't need any dynamic values.  Therefore,      structure BF = MachDepVC.Binfile
      * we create RecompPersstate (but not FullPersstate!) and  
      * instantiate Recomp as well as RecompTraversal.  
      * Since RecompPersstate is not part of any surrounding FullPersstate,  
      * function "discard_value" simply does nothing. *)  
     structure RecompPersstate =  
         RecompPersstateFn (structure MachDepVC = MachDepVC  
                            val discard_code = true  
                            fun discard_value (i: SmlInfo.info) = ())  
     structure Recomp = RecompFn (structure PS = RecompPersstate)  
     structure RT = CompileGenericFn (structure CT = Recomp)  
   
     fun recomp gp g = isSome (RT.group gp g)  
   
     (* instantiate Stabilize... *)  
     structure Stabilize =  
         StabilizeFn (fun bn2statenv gp i = #1 (#stat (valOf (RT.bnode gp i)))  
                      val getPid = RecompPersstate.pid_fetch_sml  
                      fun warmup (i, p) = ()  
                      val recomp = recomp)  
     (* ... and Parse *)  
     structure Parse = ParseFn (structure Stabilize = Stabilize)  
   
     fun compile { dirbase, pcmodespec, initgspec, maingspec, stabilize } = let  
31    
32          val arch = MachDepVC.architecture          val arch = MachDepVC.architecture
33          val osname = FilenamePolicy.kind2name os          val osname = FilenamePolicy.kind2name os
34          val bindir = concat [dirbase, ".bin.", arch, "-", osname]      val archos = concat [arch, "-", osname]
         val bootdir = concat [dirbase, ".boot.", arch, "-", osname]  
35    
36          val keep_going = EnvConfig.getSet StdConfig.keep_going NONE      fun init_servers (GroupGraph.GROUP { grouppath, ... }) =
37            Servers.cmb { archos = archos,
38                          root = SrcPath.descr grouppath }
39    
40          val ctxt = SrcPath.cwdContext ()      structure Compile = CompileFn (structure MachDepVC = MachDepVC
41                                       val compile_there =
42                                           Servers.compile o SrcPath.descr)
43    
44          val pidfile = OS.Path.joinDirFile { dir = bootdir, file = "RTPID" }      structure BFC = BfcFn (structure MachDepVC = MachDepVC)
         val listfile = OS.Path.joinDirFile { dir = bootdir, file = "BINLIST" }  
45    
46          val pcmode = let      (* instantiate Stabilize... *)
47              fun work s = let      structure Stabilize =
48                  fun loop l = let          StabilizeFn (structure MachDepVC = MachDepVC
49                      val line = TextIO.inputLine s                       fun recomp gp g = let
50                             val { store, get } = BFC.new ()
51                             val _ = init_servers g
52                             val { group, ... } =
53                                 Compile.newTraversal (fn _ => fn _ => (),
54                                                       store, g)
55                  in                  in
56                      if line = "" then PathConfig.hardwire l                           case Servers.withServers (fn () => group gp) of
57                      else case String.tokens Char.isSpace line of                               NONE => NONE
58                          [a, s] => loop ((a, s) :: l)                             | SOME _ => SOME get
                       | _ => (Say.say [pcmodespec,  
                                        ": malformed line (ignored)\n"];  
                               loop l)  
59                  end                  end
60                         val getII = Compile.getII)
61    
62        (* ... and Parse *)
63        structure Parse = ParseFn (structure Stabilize = Stabilize
64                                   val evictStale = Compile.evictStale
65                                   fun pending () = SymbolMap.empty)
66    
67        fun mkBootList g = let
68            fun listName p =
69                case P.fromString p of
70                    { vol = "", isAbs = false, arcs = _ :: arc1 :: arcn } => let
71                        fun win32name () =
72                            concat (arc1 ::
73                                    foldr (fn (a, r) => "\\" :: a :: r) [] arcn)
74              in              in
75                  loop []                      case os of
76                            SMLofNJ.SysInfo.WIN32 => win32name ()
77                          | _ => P.toString { isAbs = false, vol = "",
78                                              arcs = arc1 :: arcn }
79              end              end
80                  | _ => raise Fail ("BootstrapCompile:listName: bad name: " ^ p)
81          in          in
82              SafeIO.perform { openIt = fn () => TextIO.openIn pcmodespec,          MkBootList.group listName g
                              closeIt = TextIO.closeIn,  
                              work = work,  
                              cleanup = fn () => () }  
83          end          end
84    
85        fun mk_compile deliver root dbopt = let
86    
87            val dirbase = getOpt (dbopt, BtNames.dirbaseDefault)
88            val pcmodespec = BtNames.pcmodespec
89            val initgspec = BtNames.initgspec
90            val maingspec = BtNames.maingspec
91    
92            val bindir = concat [dirbase, BtNames.bin_infix, archos]
93            val bootdir = concat [dirbase, BtNames.boot_infix, archos]
94    
95            val keep_going = #get StdConfig.keep_going ()
96    
97            val ctxt = SrcPath.cwdContext ()
98    
99            val listfile = P.joinDirFile { dir = bootdir, file = BtNames.bootlist }
100            val pidmapfile = P.joinDirFile { dir = bootdir, file = BtNames.pidmap }
101    
102            val pcmode = PathConfig.new ()
103            val _ = PathConfig.processSpecFile (pcmode, pcmodespec)
104    
105          fun stdpath s = SrcPath.standard pcmode { context = ctxt, spec = s }          fun stdpath s = SrcPath.standard pcmode { context = ctxt, spec = s }
106    
107          val initgspec = stdpath initgspec          val initgspec = stdpath initgspec
108          val maingspec = stdpath maingspec          val maingspec =
109                case root of
110          val initfnpolicy =                  NONE => stdpath maingspec
111              FilenamePolicy.separate { bindir = bootdir, bootdir = bootdir }                | SOME r => SrcPath.fromDescr pcmode r
                 { arch = arch, os = os }  
112    
113          val mainfnpolicy =          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, fnpolicy }          fun mkParam corenv =
118                      { corenv } =              { fnpolicy = fnpolicy,
             { primconf = primconf,  
               fnpolicy = fnpolicy,  
119                pcmode = pcmode,                pcmode = pcmode,
120                symenv = SSV.env,                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... *)
         local  
             (* We could actually go and calculate the actual pid of primEnv.  
              * But in reality it's pretty pointless to do so... *)  
             val bogusPid = PS.fromBytes (Byte.stringToBytes "0123456789abcdef")  
             val pspec = { name = "primitive",  
                           env = E.mkenv { static = E.primEnv,  
                                           symbolic = E.symbolicPart E.emptyEnv,  
                                           dynamic = emptydyn },  
                           pidInfo = { statpid = bogusPid,  
                                       sympid = bogusPid,  
                                       ctxt = SE.empty } }  
         in  
             val primconf = Primitive.configuration [pspec]  
         end  
   
         val mkInitParam = mkParam { primconf = primconf,  
                                     pervasive = E.emptyEnv,  
                                     pervcorepids = PidSet.empty,  
                                     fnpolicy = initfnpolicy }  
128    
129          val param_nocore = mkInitParam { corenv = BE.staticPart BE.emptyEnv }          val param_nocore = mkParam BE.emptyEnv
130    
131          val groupreg = GroupReg.new ()          val groupreg = GroupReg.new ()
132          val errcons = EM.defaultConsumer ()          val errcons = EM.defaultConsumer ()
133          val ginfo_nocore = { param = param_nocore, groupreg = groupreg,          val ginfo_nocore = { param = param_nocore, groupreg = groupreg,
134                               errcons = errcons }                               errcons = errcons }
135    
136          fun main_compile arg = let          fun mk_main_compile arg = let
137              val { rts, core, pervasive, primitives, binpaths } = arg  
138                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
142              val _ = ovldR := true              val _ = ovldR := true
143                val sbnode = Compile.newSbnodeTraversal ()
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 (RT.snode ginfo_nocore core)              val core = valOf (sbnode ginfo_nocore core_n)
148              val corenv =  CoerceEnv.es2bs (#1 (#stat core))              val corenv =
149              val core_sym = #1 (#sym 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 rt2ie (n, ii: IInfo.info) = let
167                    val bs = CoerceEnv.es2bs (#env (#statenv ii ()))
168                    val (dae, mkDomain) = Statenv2DAEnv.cvt bs
169                in
170                    { ie = ((NONE, n), dae), mkDomain = mkDomain }
171                end
172    
173              fun rt n = valOf (RT.snode ginfo_justcore n)              fun add_exports (n, exports) = let
174              val rts = rt rts                  val { ie, mkDomain } = rt2ie (n, rt n)
175              val pervasive = rt pervasive                  fun ins_ie (sy, m) = SymbolMap.insert (m, sy, ie)
176                in
177                    SymbolSet.foldl ins_ie exports (mkDomain ())
178                end
179    
180              fun sn2pspec (name, n) = let              val special_exports = let
181                  val { stat = (s, sp), sym = (sy, syp), ctxt } = rt n                  fun mkie (n, rtn) = #ie (rt2ie (n, rtn))
                 val env =  
                     E.mkenv { static = s, symbolic = sy, dynamic = emptydyn }  
                 val pidInfo = { statpid = sp, sympid = syp, ctxt = ctxt }  
182              in              in
183                  { name = name, env = env, pidInfo = pidInfo }                  foldl SymbolMap.insert' SymbolMap.empty
184                          [(PervCoreAccess.pervStrSym, mkie (perv_n, pervasive)),
185                           (PervCoreAccess.coreStrSym, mkie (core_n, core))]
186              end              end
187    
188              val pspecs = map sn2pspec primitives              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              (* This 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 (#1 (#sym pervasive), core_sym)                  fun nostabinit () =
201                        if deliver then
202              val param =                          let val stabarg = { group = init_group,
203                  mkParam { primconf = Primitive.configuration pspecs,                                              anyerrors = ref false }
                           pervasive = E.mkenv { static = #1 (#stat pervasive),  
                                                 symbolic = perv_sym,  
                                                 dynamic = emptydyn },  
                           pervcorepids =  
                             PidSet.addList (PidSet.empty,  
                                             [#2 (#stat pervasive),  
                                              #2 (#sym pervasive),  
                                              #2 (#stat core)]),  
                           fnpolicy = mainfnpolicy }  
                         { corenv = corenv }  
             val stableflag = if stabilize then SOME true else NONE  
204          in          in
205              case Parse.parse NONE param stableflag maingspec of                              case Stabilize.stabilize ginfo stabarg of
206                  NONE => false                                  SOME g => (SOME true, g, true)
207                | SOME (g, gp) =>                                (* if we cannot stabilize the init group, then
208                      if recomp gp g then let                                 * as a first remedy we turn delivery off *)
209                          val rtspid = PS.toHex (#2 (#stat rts))                                | NONE => (NONE, init_group, false)
210                          val bootfiles =                          end
211                              map (fn x => (x, NONE)) binpaths @                      else (NONE, init_group, false)
212                              MkBootList.group g              in
213                          fun writeList s = let                  if VerifyStable.verify ginfo init_group then let
214                              fun offset NONE = ["\n"]                      fun load () =
215                                | offset (SOME i) = ["@", Int.toString i, "\n"]                          Stabilize.loadStable ginfo
216                              fun showBootFile (p, off) =                            { getGroup = fn _ =>
217                                  TextIO.output (s, concat (p :: offset off))                                 raise Fail "CMB: initial getGroup",
218                          in                              anyerrors = ref false }
219                              app showBootFile bootfiles                            initgspec
220                          end                  in
221                      in                      case load () of
222                          Say.say ["Runtime System PID is: ", rtspid, "\n"];                          NONE => nostabinit ()
223                          SafeIO.perform { openIt = fn () =>                        | SOME g =>
224                                             AutoDir.openTextOut pidfile,                              (if deliver then SOME true else NONE, g, deliver)
225                                           closeIt = TextIO.closeOut,                  end
226                                           work = fn s =>                  else nostabinit ()
227                                             TextIO.output (s, rtspid ^ "\n"),              end
228                                           cleanup = fn () =>  
229                                             OS.FileSys.remove pidfile              val gr = GroupReg.new ()
230                                             handle _ => () };              val _ = GroupReg.register gr (initgspec, src)
231                          SafeIO.perform { openIt = fn () =>  
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
241                Servers.dirbase dirbase;
242                Parse.reset ();
243                case Parse.parse parse_arg of
244                    NONE => NONE
245                  | SOME (g, gp) => let
246                        fun thunk () = let
247                            val _ = init_servers g
248                            fun store _ = ()
249                            val { group = recomp, ... } =
250                                Compile.newTraversal (fn _ => fn _ => (), store, g)
251                            val res =
252                                Servers.withServers (fn () => recomp gp)
253                        in
254                            if isSome res then let
255                                val { l = bootitems, ss } = mkBootList g
256                                val stablelibs = Reachable.stableLibsOf g
257                                fun inSet bi = StableSet.member (ss, bi)
258                                val frontiers =
259                                    SrcPathMap.map (Reachable.frontier inSet)
260                                                   stablelibs
261                                fun writeBootList s = let
262                                    fun wr str = TextIO.output (s, str ^ "\n")
263                                in
264                                    app wr bootitems
265                                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
287                                if deliver then
288                                    (SafeIO.perform
289                                     { openIt = fn () =>
290                                             AutoDir.openTextOut listfile,                                             AutoDir.openTextOut listfile,
291                                           closeIt = TextIO.closeOut,                                           closeIt = TextIO.closeOut,
292                                           work = writeList,                                     work = writeBootList,
293                                           cleanup = fn () =>                                     cleanup = fn _ =>
294                                             OS.FileSys.remove listfile                                             OS.FileSys.remove listfile
295                                             handle _ => () };                                             handle _ => () };
296                                     SafeIO.perform
297                                     { openIt = fn () =>
298                                           AutoDir.openTextOut pidmapfile,
299                                       closeIt = TextIO.closeOut,
300                                       work = writePidMap,
301                                       cleanup = fn _ =>
302                                           OS.FileSys.remove pidmapfile
303                                           handle _ => () };
304                                     Say.say
305                                          ["New boot directory has been built.\n"])
306                                else ();
307                          true                          true
308                      end                      end
309                      else false                      else false
310          end handle Option => (RT.reset (); false)                      end
311                    in
312                        SOME ((g, gp, pcmode), thunk)
313                    end
314            end handle Option => (Compile.reset (); NONE)
315                     (* to catch valOf failures in "rt" *)                     (* to catch valOf failures in "rt" *)
316      in      in
317          case BuildInitDG.build ginfo_nocore initgspec of          case BuildInitDG.build ginfo_nocore initgspec of
318              SOME x => main_compile x              SOME x => mk_main_compile x
319            | NONE => false            | NONE => NONE
320      end      end
321    
322        fun compile deliver dbopt =
323            case mk_compile deliver NONE dbopt of
324                NONE => false
325              | SOME (_, thunk) => thunk ()
326    
327        local
328            fun slave (dirbase, root) =
329                case mk_compile false (SOME root) (SOME dirbase) of
330                    NONE => NONE
331                  | SOME ((g, gp, pcmode), _) => let
332                        val trav = Compile.newSbnodeTraversal () gp
333                        fun trav' sbn = isSome (trav sbn)
334                    in
335                        SOME (g, trav', pcmode)
336                    end
337        in
338            val _ = CMBSlaveHook.init archos slave
339        end
340    
341        fun reset () =
342            (Compile.reset ();
343             Parse.reset ())
344    
345        val make' = compile false
346        fun make () = make' NONE
347        fun deliver' arg =
348            SafeIO.perform { openIt = fn () => (),
349                             closeIt = reset,
350                             work = fn () => compile true arg,
351                             cleanup = fn _ => () }
352        fun deliver () = deliver' NONE
353        val symval = SSV.symval
354  end  end

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

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