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 335, Thu Jun 17 08:21:08 1999 UTC revision 592, Mon Apr 3 07:04:12 2000 UTC
# Line 6  Line 6 
6   *   *
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  local
                             val os: SMLofNJ.SysInfo.os_kind) = struct  
   
10      structure EM = GenericVC.ErrorMsg      structure EM = GenericVC.ErrorMsg
11      structure E = GenericVC.Environment      structure E = GenericVC.Environment
12      structure SE = GenericVC.CMStaticEnv      structure SE = GenericVC.StaticEnv
     structure BE = GenericVC.BareEnvironment  
13      structure PS = GenericVC.PersStamps      structure PS = GenericVC.PersStamps
14      structure CoerceEnv = GenericVC.CoerceEnv      structure GG = GroupGraph
15        structure DG = DependencyGraph
16      (* Since the bootstrap compiler never executes any of the code  in
17       * it produces, we don't need any dynamic values.  Therefore,  functor BootstrapCompileFn
18       * we create RecompPersstate (but not FullPersstate!) and              (structure MachDepVC : MACHDEP_VC
19       * instantiate Recomp as well as RecompTraversal.               val os : SMLofNJ.SysInfo.os_kind
20       * Since RecompPersstate is not part of any surrounding FullPersstate,               val load_plugin : SrcPath.context -> string -> bool) :> sig
21       * function "discard_value" simply does nothing. *)      val make' : string option -> bool
22      structure RecompPersstate =      val make : unit -> bool
23          RecompPersstateFn (structure MachDepVC = MachDepVC      val reset : unit -> unit
24                             val discard_code = true      val symval : string -> { get: unit -> int option, set: int option -> unit }
25                             fun discard_value (i: SmlInfo.info) = ())  end = struct
26      structure Recomp = RecompFn (structure PS = RecompPersstate)      structure SSV = SpecificSymValFn (structure MachDepVC = MachDepVC
27      structure RT = CompileGenericFn (structure CT = Recomp)                                        val os = os)
28        structure P = OS.Path
29        structure F = OS.FileSys
30        structure BF = MachDepVC.Binfile
31    
32        val arch = MachDepVC.architecture
33        val osname = FilenamePolicy.kind2name os
34        val archos = concat [arch, "-", osname]
35    
36        fun init_servers (GG.GROUP { grouppath, ... }) =
37            Servers.cmb { archos = archos,
38                          root = SrcPath.descr grouppath }
39          | init_servers GG.ERRORGROUP = ()
40    
41        structure StabModmap = StabModmapFn ()
42    
43        structure Compile = CompileFn (structure MachDepVC = MachDepVC
44                                       structure StabModmap = StabModmap
45                                       val compile_there =
46                                           Servers.compile o SrcPath.descr)
47    
48      fun recomp gp g = isSome (RT.group gp g)      structure BFC = BfcFn (structure MachDepVC = MachDepVC)
49    
50      (* instantiate Stabilize... *)      (* instantiate Stabilize... *)
51      structure Stabilize =      structure Stabilize =
52          StabilizeFn (fun bn2statenv gp i = #1 (#stat (valOf (RT.bnode gp i)))          StabilizeFn (structure MachDepVC = MachDepVC
53                       val recomp = recomp)                       structure StabModmap = StabModmap
54      (* ... and Parse *)                       fun recomp gp g = let
55      structure Parse = ParseFn (structure Stabilize = Stabilize)                           val { store, get } = BFC.new ()
56                             val _ = init_servers g
57      fun compile { binroot, pcmodespec, initgspec, maingspec } = let                           val { group, ... } =
58                                 Compile.newTraversal (fn _ => fn _ => (),
59          val keep_going = EnvConfig.getSet StdConfig.keep_going NONE                                                     store, g)
60                         in
61          val ctxt = AbsPath.cwdContext ()                           case Servers.withServers (fn () => group gp) of
62                                 NONE => NONE
63                               | SOME _ => SOME get
64                         end
65                         val getII = Compile.getII)
66    
67          val initgspec = AbsPath.native { context = ctxt, spec = initgspec }      structure VerifyStable = VerStabFn (structure Stabilize = Stabilize)
         val maingspec = AbsPath.native { context = ctxt, spec = maingspec }  
         val pcmodespec = AbsPath.native { context = ctxt, spec = pcmodespec }  
         val binroot = AbsPath.native { context = ctxt, spec = binroot }  
68    
69          fun build_pcmode () = let      (* ... and Parse *)
70              val s = AbsPath.openTextIn pcmodespec      structure Parse = ParseFn (structure Stabilize = Stabilize
71              fun loop l = let                                 structure StabModmap = StabModmap
72                  val line = TextIO.inputLine s                                 val evictStale = Compile.evictStale
73                                   fun pending () = SymbolMap.empty)
74    
75        fun mkBootList g = let
76            fun listName p =
77                case P.fromString p of
78                    { vol = "", isAbs = false, arcs = _ :: arc1 :: arcn } => let
79                        fun win32name () =
80                            concat (arc1 ::
81                                    foldr (fn (a, r) => "\\" :: a :: r) [] arcn)
82              in              in
83                  if line = "" then PathConfig.hardwire l                      case os of
84                  else case String.tokens Char.isSpace line of                          SMLofNJ.SysInfo.WIN32 => win32name ()
85                      [a, s] => loop ((a, s) :: l)                        | _ => P.toString { isAbs = false, vol = "",
86                    | _ => (Say.say [AbsPath.name pcmodespec,                                            arcs = arc1 :: arcn }
                                    ": malformed line (ignored)\n"];  
                           loop l)  
87              end              end
88                  | _ => raise Fail ("BootstrapCompile:listName: bad name: " ^ p)
89          in          in
90              loop [] before TextIO.closeIn s          MkBootList.group listName g
91          end          end
92    
93          val pcmode = build_pcmode ()      local
94            fun internal_reset () =
95                (Compile.reset ();
96                 Parse.reset ();
97                 StabModmap.reset ())
98        in
99            fun reset () =
100                (Say.vsay ["[CMB reset]\n"];
101                 internal_reset ())
102            val checkDirbase = let
103                val prev = ref NONE
104                fun ck db =
105                    (case !prev of
106                         NONE => prev := SOME db
107                       | SOME db' =>
108                         if db = db' then ()
109                         else (Say.vsay ["[new dirbase is `", db,
110                                         "'; CMB reset]\n"];
111                               internal_reset ();
112                               prev := SOME db))
113            in
114                ck
115            end
116        end
117    
118        fun mk_compile { deliver, root, dirbase = dbopt, paranoid } = let
119    
120            val _ = StabModmap.reset ()
121    
122            val dirbase = getOpt (dbopt, BtNames.dirbaseDefault)
123            val _ = checkDirbase dirbase
124            val pcmodespec = BtNames.pcmodespec
125            val initgspec = BtNames.initgspec
126            val maingspec = BtNames.maingspec
127    
128            val bindir = concat [dirbase, BtNames.bin_infix, archos]
129            val bootdir = concat [dirbase, BtNames.boot_infix, archos]
130    
131            val keep_going = #get StdConfig.keep_going ()
132    
133            val ctxt = SrcPath.cwdContext ()
134    
135            val listfile = P.joinDirFile { dir = bootdir, file = BtNames.bootlist }
136            val pidmapfile = P.joinDirFile { dir = bootdir, file = BtNames.pidmap }
137    
138            val pcmode = PathConfig.new ()
139            val _ = PathConfig.processSpecFile (pcmode, pcmodespec)
140    
141            fun stdpath s = SrcPath.standard pcmode { context = ctxt, spec = s }
142    
143            val initgspec = stdpath initgspec
144            val maingspec =
145                case root of
146                    NONE => stdpath maingspec
147                  | SOME r => SrcPath.fromDescr pcmode r
148    
149          val fnpolicy =          val fnpolicy =
150              FilenamePolicy.separate { root = binroot,              FilenamePolicy.separate { bindir = bindir, bootdir = bootdir }
151                                        parentArc = "DOTDOT",                  { arch = arch, os = os }
152                                        absArc = "ABSOLUTE" }  
153                                      { arch = MachDepVC.architecture, os = os }          val param =
154                { fnpolicy = fnpolicy,
155                  pcmode = pcmode,
156                  symval = SSV.symval,
157                  keep_going = keep_going }
158    
159          val emptydyn = E.dynamicPart E.emptyEnv          val emptydyn = E.dynamicPart E.emptyEnv
160    
161          (* first, build an initial GeneralParam.info, so we can          (* first, build an initial GeneralParam.info, so we can
162           * 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 param_nocore = { primconf = primconf,  
                              fnpolicy = fnpolicy,  
                              pcmode = pcmode,  
                              keep_going = keep_going,  
                              pervasive = E.emptyEnv,  
                              corenv = BE.staticPart BE.emptyEnv,  
                              pervcorepids = PidSet.empty }  
163    
164          val groupreg = GroupReg.new ()          val groupreg = GroupReg.new ()
165          val errcons = EM.defaultConsumer ()          val errcons = EM.defaultConsumer ()
166          val ginfo_nocore = { param = param_nocore, groupreg = groupreg,          val ginfo = { param = param, groupreg = groupreg, errcons = errcons }
                              errcons = errcons }  
167    
168          fun main_compile arg = let          fun mk_main_compile arg = let
             val { rts, core, pervasive, primitives, binpaths } = arg  
169    
170                val { pervasive = perv_n, others, src } = arg
171    
172                fun recompInitGroup () = let
173              val ovldR = GenericVC.Control.overloadKW              val ovldR = GenericVC.Control.overloadKW
174              val savedOvld = !ovldR              val savedOvld = !ovldR
175              val _ = ovldR := true              val _ = ovldR := true
176                    val sbnode = Compile.newSbnodeTraversal ()
177    
178              (* here we build a new gp -- the one that uses the freshly                  val perv_fsbnode = (NONE, perv_n)
              * brewed pervasive env, core env, and primitives *)  
             val core = valOf (RT.snode ginfo_nocore core)  
             val corenv =  CoerceEnv.es2bs (#1 (#stat core))  
             (* even though we have a pid for the core, we can't use it  
              * (otherwise we would invalidate earlier compilation results) *)  
             val pervcorepids = PidSet.empty  
   
             (* The following is a bit of a hack (but corenv is a hack anyway):  
              * As soon as we have core available, we have to patch the  
              * ginfo to include the correct corenv (because virtually  
              * everybody else needs access to corenv). *)  
             val param_justcore = { primconf = primconf,  
                                    fnpolicy = fnpolicy,  
                                    pcmode = pcmode,  
                                    keep_going = keep_going,  
                                    pervasive = E.emptyEnv,  
                                    corenv = corenv,  
                                    pervcorepids = pervcorepids }  
             val ginfo_justcore = { param = param_justcore, groupreg = groupreg,  
                                    errcons = errcons }  
179    
180              fun rt n = valOf (RT.snode ginfo_justcore n)                  fun rt n = valOf (sbnode ginfo n)
181              val rts = rt rts                  val pervasive = rt perv_n
             val pervasive = rt pervasive  
182    
183              fun sn2pspec (name, n) = let                  fun rt2ie (n, ii: IInfo.info) = let
184                  val { stat = (s, sp), sym = (sy, syp), ctxt } = rt n                      val s = #statenv ii ()
185                  val env =                      val (dae, mkDomain) = Statenv2DAEnv.cvt s
                     E.mkenv { static = s, symbolic = sy, dynamic = emptydyn }  
                 val pidInfo = { statpid = sp, sympid = syp, ctxt = ctxt }  
186              in              in
187                  { name = name, env = env, pidInfo = pidInfo }                      (* Link path info = NONE, will be reset at import
188                         * time (in members.sml). *)
189                        { ie = ((NONE, n), dae), mkDomain = mkDomain }
190              end              end
191    
192              val pspecs = map sn2pspec primitives                  fun add_exports (n, exports) = let
193                        val { ie, mkDomain } = rt2ie (n, rt n)
194                        fun ins_ie (sy, m) = SymbolMap.insert (m, sy, ie)
195                    in
196                        SymbolSet.foldl ins_ie exports (mkDomain ())
197                    end
198    
199              val _ = ovldR := savedOvld                  val special_exports = let
200                        fun mkie (n, rtn) = #ie (rt2ie (n, rtn))
201                    in
202                        SymbolMap.insert (SymbolMap.empty,
203                                          PervAccess.pervStrSym,
204                                          mkie (perv_n, pervasive))
205                    end
206                in
207                    GG.GROUP { exports = foldl add_exports special_exports others,
208                               kind = GroupGraph.LIB { wrapped = StringSet.empty,
209                                                       subgroups = [] },
210                               required = StringSet.singleton "primitive",
211                               grouppath = initgspec,
212                               sublibs = [] }
213                    before (ovldR := savedOvld)
214                end
215    
216              val param = { primconf = Primitive.configuration pspecs,              (* just go and load the stable init group or signal failure *)
217                            fnpolicy = fnpolicy,              fun loadInitGroup () = let
218                            pcmode = pcmode,                  val lsarg =
219                            keep_going = keep_going,                      { getGroup = fn _ => raise Fail "CMB: initial getGroup",
220                            pervasive = E.mkenv { static = #1 (#stat pervasive),                        anyerrors = ref false }
                                                 symbolic = #1 (#sym pervasive),  
                                                 dynamic = emptydyn },  
                           corenv = CoerceEnv.es2bs (#1 (#stat core)),  
                           pervcorepids =  
                             PidSet.addList (PidSet.empty,  
                                             [#2 (#stat pervasive),  
                                              #2 (#sym pervasive),  
                                              #2 (#stat core)]) }  
221          in          in
222              case Parse.parse param NONE maingspec of                  case Stabilize.loadStable ginfo lsarg initgspec of
223                  NONE => NONE                  NONE => NONE
224                | SOME (g, gp) =>                    | SOME (g as GG.GROUP { exports, ... }) => SOME g
225                      if recomp gp g then                    | SOME GG.ERRORGROUP => NONE
226                          SOME { rtspid = PS.toHex (#2 (#stat rts)),              end
227                                 bootfiles =  
228                                   map (fn x => (x, NONE)) binpaths @              (* Don't try to load the stable init group. Instead, recompile
229                                   MkBootList.group g }               * directly. *)
230                      else NONE              fun dontLoadInitGroup () = let
231          end handle Option => (RT.clearFailures (); NONE)                  val g0 = recompInitGroup ()
232                    val stabarg = { group = g0, anyerrors = ref false }
233                in
234                    if deliver then
235                        case Stabilize.stabilize ginfo stabarg of
236                            SOME g => g
237                          | NONE => raise Fail "CMB: cannot stabilize init group"
238                    else g0
239                end
240    
241                (* Try loading the init group from the stable file if possible;
242                 * recompile if loading fails *)
243                fun tryLoadInitGroup () =
244                    case loadInitGroup () of
245                        SOME g => g
246                      | NONE => dontLoadInitGroup ()
247    
248                (* Ok, now, based on "paranoid" and stable verification,
249                 * call the appropriate function(s) to get the init group. *)
250                val init_group =
251                    if paranoid then let
252                        val export_nodes = perv_n :: others
253                        val ver_arg = (initgspec, export_nodes, [],
254                                       SrcPathSet.empty)
255                        val em = StableMap.empty
256                    in
257                        if VerifyStable.verify' ginfo em ver_arg then
258                            tryLoadInitGroup ()
259                        else dontLoadInitGroup ()
260                    end
261                    else tryLoadInitGroup ()
262    
263    
264                val stab = if deliver then SOME true else NONE
265    
266                val gr = GroupReg.new ()
267                val _ = GroupReg.register gr (initgspec, src)
268    
269                val parse_arg =
270                    { load_plugin = load_plugin,
271                      gr = gr,
272                      param = param,
273                      stabflag = stab,
274                      group = maingspec,
275                      init_group = init_group,
276                      paranoid = paranoid }
277            in
278                Servers.dirbase dirbase;
279                case Parse.parse parse_arg of
280                    NONE => NONE
281                  | SOME (g, gp) => let
282                        fun thunk () = let
283                            val _ = init_servers g
284                            fun store _ = ()
285                            val { group = recomp, ... } =
286                                Compile.newTraversal (fn _ => fn _ => (), store, g)
287                            val res =
288                                Servers.withServers (fn () => recomp gp)
289                        in
290                            if isSome res then let
291                                val { l = bootitems, ss } = mkBootList g
292                                val stablelibs = Reachable.stableLibsOf g
293                                fun inSet bi = StableSet.member (ss, bi)
294                                val frontiers =
295                                    SrcPathMap.map (Reachable.frontier inSet)
296                                                   stablelibs
297                                fun writeBootList s = let
298                                    fun wr str = TextIO.output (s, str ^ "\n")
299                                    val numitems = length bootitems
300                                    fun biggerlen (s, n) = Int.max (size s, n)
301                                    val maxlen = foldl biggerlen 0 bootitems
302                                in
303                                    wr (concat ["%", Int.toString numitems,
304                                                " ", Int.toString maxlen]);
305                                    app wr bootitems
306                                end
307                                fun writePid s i = let
308                                    val sn = BinInfo.stablename i
309                                    val os = BinInfo.offset i
310                                    val descr = BinInfo.describe i
311                                    val bfc = BFC.getStable
312                                        { stable = sn, offset = os, descr = descr }
313                                in
314                                    case BF.exportPidOf bfc of
315                                        NONE => ()
316                                      | SOME pid =>
317                                            (TextIO.output (s, " ");
318                                             TextIO.output (s, PS.toHex pid))
319                                end
320                                fun writePidLine s (p, set) =
321                                    if StableSet.isEmpty set then ()
322                                    else (TextIO.output (s, SrcPath.descr p);
323                                          StableSet.app (writePid s) set;
324                                          TextIO.output (s, "\n"))
325                                fun writePidMap s =
326                                    SrcPathMap.appi (writePidLine s) frontiers
327                            in
328                                if deliver then
329                                    (SafeIO.perform
330                                     { openIt = fn () =>
331                                           AutoDir.openTextOut listfile,
332                                       closeIt = TextIO.closeOut,
333                                       work = writeBootList,
334                                       cleanup = fn _ =>
335                                           OS.FileSys.remove listfile
336                                           handle _ => () };
337                                     SafeIO.perform
338                                     { openIt = fn () =>
339                                           AutoDir.openTextOut pidmapfile,
340                                       closeIt = TextIO.closeOut,
341                                       work = writePidMap,
342                                       cleanup = fn _ =>
343                                           OS.FileSys.remove pidmapfile
344                                           handle _ => () };
345                                     Say.say
346                                          ["New boot directory has been built.\n"])
347                                else ();
348                                true
349                            end
350                            else false
351                        end
352                    in
353                        SOME ((g, gp, pcmode), thunk)
354                    end
355            end handle Option => (Compile.reset (); NONE)
356                     (* to catch valOf failures in "rt" *)                     (* to catch valOf failures in "rt" *)
357      in      in
358          case BuildInitDG.build ginfo_nocore initgspec of          case BuildInitDG.build ginfo initgspec of
359              SOME x => main_compile x              SOME x => mk_main_compile x
360            | NONE => NONE            | NONE => NONE
361      end      end
362    
363        fun compile dbopt =
364            case mk_compile { deliver = true, root = NONE,
365                              dirbase = dbopt, paranoid = true } of
366                NONE => false
367              | SOME (_, thunk) => thunk ()
368    
369        local
370            fun slave (dirbase, root) =
371                case mk_compile { deliver = false, root = SOME root,
372                                  dirbase = SOME dirbase, paranoid = false } of
373                    NONE => NONE
374                  | SOME ((g, gp, pcmode), _) => let
375                        val trav = Compile.newSbnodeTraversal () gp
376                        fun trav' sbn = isSome (trav sbn)
377                    in
378                        SOME (g, trav', pcmode)
379                    end
380        in
381            val _ = CMBSlaveHook.init archos slave
382        end
383    
384        val make' = compile
385        fun make () = make' NONE
386        val symval = SSV.symval
387  end  end
388    end (* local *)

Legend:
Removed from v.335  
changed lines
  Added in v.592

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