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

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

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