Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /sml/branches/rt-transition/system/smlnj/installer/generic-install.sml
ViewVC logotype

Annotation of /sml/branches/rt-transition/system/smlnj/installer/generic-install.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 3979 - (view) (download)

1 : mblume 1391 (* SML/NJ installer script -- written in SML.
2 :     * This script runs after the runtime system has been built and
3 :     * the interactive system has been booted from bootfiles.
4 :     *
5 :     * The remainder of the build process compiles additional libraries
6 :     * and installs certain standalone programs such as ml-yacc and ml-lex.
7 :     * This is the bulk of what used to be done by install.sh.
8 :     *
9 :     * The script is written in such a way that it can be used portably
10 :     * on both *nix- and win32-systems.
11 :     *
12 : blume 2720 * (C) 2007 The Fellowship of SML/NJ
13 : mblume 1391 *
14 :     * Author: Matthias Blume (blume@tti-c.org)
15 :     *)
16 : blume 2278 structure GenericInstall : sig
17 : mblume 1391
18 :     (* all filenames that are passed as arguments use native syntax: *)
19 :     val proc :
20 :     { smlnjroot: string,
21 : mblume 1409 installdir: string,
22 : mblume 1391 buildcmd: string,
23 :     instcmd : string -> unit,
24 : mblume 1725 unpack: (string list -> bool) option } -> unit
25 : mblume 1391
26 :     end = struct
27 :    
28 : blume 2297 structure U = InstallerUtil
29 : mblume 1391 structure P = OS.Path
30 :     structure F = OS.FileSys
31 :     structure SM = RedBlackMapFn (type ord_key = string
32 :     val compare = String.compare)
33 : mblume 1485 structure SS = RedBlackSetFn (type ord_key = string
34 :     val compare = String.compare)
35 : mblume 1391
36 :     structure SCC = GraphSCCFn (type ord_key = string
37 :     val compare = String.compare)
38 :    
39 : blume 2297 val say = U.say and warn = U.warn and fail = U.fail
40 : mblume 1391
41 : blume 2297 val { arch_oskind, heap_suffix, isUnix } = U.platformInfo ()
42 : mblume 1391
43 :     (* convert standard syntax to native syntax *)
44 : blume 2297 val native = P.fromUnixPath
45 : mblume 1391
46 :     (* several worklists for delayed execution *)
47 :     val stablist : (unit -> bool) list ref = ref []
48 :     val movlist : (unit -> unit) list ref = ref []
49 :     val salist : (unit -> unit) list ref = ref []
50 :    
51 :    
52 :     (* move a stable library file to its final location *)
53 :     fun movelib src dst () =
54 : blume 2297 (U.mkdir (P.dir dst); U.rename { old = src, new = dst })
55 : mblume 1391
56 :     (* register a temporary anchor-value binding *)
57 :     fun localanchor { anchor, path } =
58 :     #set (CM.Anchor.anchor anchor) (SOME (native path))
59 :    
60 :     fun getInputTokens s =
61 : blume 2090 case TextIO.inputLine s of
62 :     NONE => NONE
63 :     | SOME "" => NONE
64 :     | SOME l =>
65 :     if String.sub (l, 0) = #"#" then getInputTokens s
66 :     else SOME (String.tokens Char.isSpace l)
67 :     fun tokenLine l = String.concatWith " " l
68 : mblume 1391
69 :     (* Take a list of modules and dependencies (in depfile) and
70 :     * build the transitive closure of those modules.
71 :     * We do this by considering the dependency graph and construct
72 :     * a topological order for it. *)
73 :     fun resolve (modules, depfile) = let
74 :     val s = TextIO.openIn depfile
75 :     fun rd m =
76 :     case getInputTokens s of
77 :     NONE => (TextIO.closeIn s; fn x => getOpt (SM.find (m, x), []))
78 :     | SOME (x :: xs) => rd (SM.insert (m, x, xs))
79 :     | SOME [] => rd m
80 :     fun strip (SCC.SIMPLE c) = c
81 :     | strip _ = fail ["cyclic dependencies in ", depfile, "\n"]
82 :     in
83 :     rev (map strip (SCC.topOrder' { roots = modules,
84 :     follow = rd SM.empty }))
85 :     end
86 :    
87 :     (* do all the delayed stuff: *)
88 :    
89 :     (* stabilization of libraries... *)
90 :     fun dostabs () =
91 : blume 2291 foldr (fn (f, true) => f () | (_, false) => false) true (!stablist)
92 : mblume 1391
93 :     (* move stable library files to their final locations... *)
94 :     fun domoves () =
95 :     (app (fn f => f ()) (rev (!movlist)); true)
96 :     handle _ => false
97 :    
98 : mblume 1863 (* fold a function over the contents of a pathconfig file: *)
99 :     fun pc_fold g m f =
100 :     let val s = TextIO.openIn f
101 :     fun loop m =
102 :     case getInputTokens s of
103 :     NONE => (TextIO.closeIn s; m)
104 :     | SOME [k, v] => loop (g (m, k, v))
105 :     | SOME l => (say ("funny line in " :: f :: ":" ::
106 :     foldr (fn (x, l) => " " :: x :: l)
107 :     ["\n"] l);
108 :     loop m)
109 :     in loop m
110 :     end handle _ => m (* in case file does not exist *)
111 :    
112 : mblume 1391 (* build those standalone programs that require libraries
113 :     * and, therefore, must be compiled "late"... *)
114 :     fun dolatesas () =
115 :     (app (fn f => f ()) (rev (!salist)); true)
116 :     handle _ => false
117 :    
118 :     (* our main routine *)
119 : mblume 1725 fun proc { smlnjroot, installdir, buildcmd, instcmd, unpack } = let
120 : mblume 1391 val smlnjroot = F.fullPath smlnjroot
121 : mblume 1409 val installdir = F.fullPath installdir
122 : mblume 1863 val libdir = P.concat (installdir, "lib")
123 : mblume 1391 val configdir = P.concat (smlnjroot, "config")
124 : mblume 1863 val bindir = P.concat (installdir, "bin")
125 :     val heapdir = P.concat (bindir, ".heap")
126 :     val cm_pathconfig = P.concat (libdir, "pathconfig")
127 : mblume 1391
128 :     (* dependency file: config/dependencies *)
129 :     val depfile = P.concat (configdir, "dependencies")
130 :    
131 : mblume 1863 (* where to get additional path configurations *)
132 :     val extrapathconfig = P.concat (configdir, "extrapathconfig")
133 :    
134 : blume 2090 (* action file: mapping from "modules" to lists of "actions" *)
135 :     val actionfile = P.concat (configdir, "actions")
136 :    
137 : mblume 1863 (* add an entry to lib/pathconfig *)
138 :     fun write_cm_pathconfig (a, p) = let
139 :     val s = TextIO.openAppend cm_pathconfig
140 :     in
141 :     TextIO.output (s, concat [a, " ", p, "\n"])
142 :     before TextIO.closeOut s
143 :     end
144 :    
145 : blume 2288 fun augment_anchor_mapping pcfile =
146 : mblume 1863 pc_fold (fn ((), k, v) =>
147 :     (#set (CM.Anchor.anchor k)
148 :     (SOME (P.concat (libdir, native v)));
149 :     write_cm_pathconfig (k, v)))
150 :     ()
151 : blume 2288 pcfile
152 : mblume 1863
153 : blume 2288 (* augment anchor mapping with extra bindings: *)
154 :     val _ = augment_anchor_mapping extrapathconfig
155 :    
156 : mblume 1391 (* find and open first usable targetsfiles *)
157 :     val targetsfiles =
158 :     [P.concat (configdir, "targets.customized"),
159 :     P.concat (configdir, "targets")]
160 :    
161 :     val s =
162 : blume 2297 case List.find U.fexists targetsfiles of
163 : mblume 1391 SOME f => TextIO.openIn f
164 :     | NONE => fail ["no targetsfiles\n"]
165 :    
166 : blume 2720 (* ------------------------------ *)
167 :    
168 : jhr 3979 datatype action
169 :     = RegLib of { anchor: string, relname: string, dir: string,
170 : blume 2720 altanchor: string option }
171 :     * bool (* true = only on Unix *)
172 :     | Anchor of { anchor: string, path: string }
173 :     * bool (* true = relative to libdir *)
174 :     | Program of { target: string, optheapdir: string option,
175 :     dir: string }
176 :     * bool (* true = defer *)
177 :    
178 :     val (actions, allmoduleset) =
179 :     let val s = TextIO.openIn actionfile
180 :     fun opthd "-" = NONE
181 :     | opthd h = SOME h
182 :     fun progargs (mn, []) =
183 :     { target = mn, optheapdir = NONE, dir = mn }
184 :     | progargs (mn, [t]) =
185 :     { target = t, optheapdir = NONE, dir = mn }
186 :     | progargs (mn, [t, h]) =
187 :     { target = t, optheapdir = opthd h, dir = mn }
188 :     | progargs (mn, t :: h :: d :: _) =
189 :     { target = t, optheapdir = opthd h, dir = d }
190 :     fun libargs (a, r, d, aa) =
191 :     { anchor = a, relname = r, dir = d, altanchor = aa }
192 :     fun loop (m, ams) =
193 :     case getInputTokens s of
194 :     NONE => (m, ams)
195 :     | SOME [mn, "src"] =>
196 :     loop (m, SS.add (ams, mn))
197 :     | SOME [mn, "lib", a, r, d] =>
198 :     ins (m, ams, mn,
199 :     RegLib (libargs (a, r, d, NONE), false))
200 :     | SOME [mn, "lib", a, r, d, aa] =>
201 :     ins (m, ams, mn,
202 :     RegLib (libargs (a, r, d, SOME aa), false))
203 :     | SOME [mn, "ulib", a, r, d] =>
204 :     ins (m, ams, mn,
205 :     RegLib (libargs (a, r, d, NONE), true))
206 :     | SOME [mn, "ulib", a, r, d, aa] =>
207 :     ins (m, ams, mn,
208 :     RegLib (libargs (a, r, d, SOME aa), true))
209 :     | SOME [mn, "anchor", a, p] =>
210 :     ins (m, ams, mn,
211 :     Anchor ({ anchor = a, path = p }, false))
212 :     | SOME [mn, "libanchor", a, p] =>
213 :     ins (m, ams, mn,
214 :     Anchor ({ anchor = a, path = p }, true))
215 :     | SOME (mn :: "prog" :: args) =>
216 :     ins (m, ams, mn,
217 :     Program (progargs (mn, args), false))
218 :     | SOME (mn :: "dprog" :: args) =>
219 :     ins (m, ams, mn,
220 :     Program (progargs (mn, args), true))
221 :     | SOME [] =>
222 :     loop (m, ams)
223 :     | SOME other =>
224 :     fail ["Illegal line in ", actionfile, ": ",
225 :     String.concatWith " " other, "\n"]
226 :     and ins (m, ams, mn, a) =
227 :     loop (SM.insert (m, mn, a :: getOpt (SM.find (m, mn), [])),
228 :     SS.add (ams, mn))
229 :     in loop (SM.empty, SS.empty)
230 :     before TextIO.closeIn s
231 :     end
232 :    
233 :     (* ------------------------------ *)
234 :    
235 : mblume 1391 (* parse the targets file *)
236 : jhr 3979 fun loop (ml, srcReqs, allsrc) =
237 : blume 2090 case getInputTokens s of
238 : jhr 3979 NONE => (TextIO.closeIn s; (ml, srcReqs, allsrc))
239 : blume 2090 | SOME [x as ("dont_move_libraries" | "move_libraries")] =>
240 :     (warn ["\"", x, "\" no longer supported",
241 :     " (installer always moves libraries)\n"];
242 : jhr 3979 loop (ml, srcReqs, allsrc))
243 :     | SOME ["request", "src-smlnj"] => loop (ml, srcReqs, true)
244 :     | SOME ["request", module] => if SM.inDomain(actions, module)
245 :     then loop (module :: ml, srcReqs, allsrc)
246 :     else loop (ml, module :: srcReqs, allsrc) (* assume a src module *)
247 :     | SOME [] => loop (ml, srcReqs, allsrc)
248 : blume 2090 | SOME l => fail ["ill-formed targets line: ", tokenLine l, "\n"]
249 : mblume 1391
250 : jhr 3979 val (modules, srcReqs, allsrc) = loop ([], [], false)
251 : mblume 1391
252 :     (* now resolve dependencies; get full list of modules
253 :     * in correct build order: *)
254 :     val modules = resolve (modules, depfile)
255 : mblume 1485 val moduleset = SS.addList (SS.empty, modules)
256 : blume 2720 val srcmoduleset = if allsrc then SS.union (moduleset, allmoduleset)
257 : jhr 3979 else SS.addList (moduleset, srcReqs)
258 : mblume 1485
259 : mblume 1391 (* fetch and unpack source trees, using auxiliary helper command
260 :     * which takes the root directory as its first and the module
261 :     * names to be fetched as subsequent arguments. *)
262 : mblume 1725 val _ = case unpack of
263 : mblume 1391 NONE => () (* archives must exist *)
264 : mblume 1725 | SOME upck =>
265 :     if upck (SS.listItems srcmoduleset) then ()
266 :     else fail ["unpacking failed\n"]
267 : mblume 1391
268 :    
269 :     (* at the end, read lib/pathconfig and eliminate duplicate entries *)
270 :     fun uniqconfig () = let
271 : mblume 1863 fun swallow (f, m) = pc_fold SM.insert m f
272 :     fun finish m =
273 :     let val s = TextIO.openOut cm_pathconfig
274 :     fun one (k, v) = TextIO.output (s, concat [k, " ", v, "\n"])
275 :     in SM.appi one m; TextIO.closeOut s
276 :     end
277 :     in finish (pc_fold SM.insert SM.empty cm_pathconfig)
278 : mblume 1391 end
279 :    
280 :     (* register library to be built *)
281 :     fun reglib { anchor, altanchor, relname, dir } = let
282 :     (* anchor: the anchor name currently used by the library
283 :     * to be registered for compilation
284 :     * altanchor: optional alternative anchor name which is
285 :     * to be used once the library is in its final location
286 :     * (this must be used if "anchor" is already bound
287 :     * and used for other libraries which come from the
288 :     * bootfile bundle),
289 :     * relname: path to library's .cm file relative to anchor
290 :     * (standard syntax)
291 :     * dir: directory name that anchor should be bound to,
292 : blume 2090 * name is relative to smlnjroot and in standard syntax *)
293 : mblume 1391 val nrelname = native relname
294 :     val ndir = native dir
295 :     val libname = concat ["$", anchor, "/", relname]
296 : blume 2090 val adir = P.concat (smlnjroot, ndir)
297 : mblume 1391 val finalanchor = getOpt (altanchor, anchor)
298 :     val { dir = nreldir, file = relbase } = P.splitDirFile nrelname
299 :     val relloc =
300 : blume 2297 U.pconcat [nreldir, CM.cm_dir_arc, arch_oskind, relbase]
301 : mblume 1391 val srcfinalloc = P.concat (adir, relloc)
302 :     val (finalloc, finalconfigpath) =
303 : blume 2297 (U.pconcat [libdir, finalanchor, relloc], finalanchor)
304 : mblume 1391 in
305 : blume 2297 if U.fexists finalloc then
306 : mblume 1391 (say ["Library ", libname, " already existed in ",
307 :     finalloc, ". Will rebuild.\n"];
308 : blume 2297 U.rmfile finalloc)
309 : mblume 1391 else ();
310 : blume 2297 if U.fexists srcfinalloc then U.rmfile srcfinalloc else ();
311 :     if not (U.fexists (P.concat (adir, nrelname))) then
312 : mblume 1391 fail ["Source tree for ", libname, " at ",
313 :     P.concat (adir, nreldir), "(", relbase,
314 :     ") does not exist.\n"]
315 :     else
316 :     (say ["Scheduling library ", libname, " to be built as ",
317 :     finalloc, "\n"];
318 :     stablist := (fn () => CM.stabilize false libname)
319 :     :: !stablist;
320 :     #set (CM.Anchor.anchor anchor) (SOME adir);
321 : mblume 1411 movlist := movelib srcfinalloc finalloc :: !movlist;
322 : mblume 1391 write_cm_pathconfig (finalanchor, finalconfigpath))
323 :     end
324 :    
325 : mblume 1537 fun command_pathconfig target =
326 :     write_cm_pathconfig (target, P.concat (P.parentArc, "bin"))
327 :    
328 : mblume 1391 (* build a standalone program, using auxiliary build script *)
329 : blume 2090 fun standalone { target, optheapdir, dir } = let
330 : mblume 1391 (* target: name of program; this is the same as the basename
331 :     * of the heap image to be generated as well as the
332 :     * final arc of the source tree's directory name
333 :     * optheapdir: optional subdirectory where the build command
334 :     * drops the heap image
335 : blume 2090 * dir:
336 :     * The source tree for the target, relative to smlnjroot. *)
337 : mblume 1391 val heapname = concat [target, ".", heap_suffix]
338 :     val targetheaploc =
339 :     case optheapdir of
340 :     NONE => heapname
341 :     | SOME hd => P.concat (native hd, heapname)
342 : blume 2155 val treedir = P.concat (smlnjroot, native dir)
343 : mblume 1391 val finalheaploc = P.concat (heapdir, heapname)
344 : blume 2692 val already_existed = U.fexists finalheaploc
345 : mblume 1391 in
346 : blume 2692 if already_existed then
347 :     say ["Target ", target, " already existed. Will rebuild.\n"]
348 :     else ();
349 :     if not (U.fexists treedir) then
350 : mblume 1391 fail ["Source tree for ", target, " at ", treedir,
351 :     " does not exist.\n"]
352 :     else
353 :     (say ["Building ", target, ".\n"];
354 :     F.chDir treedir;
355 :     if OS.Process.system buildcmd = OS.Process.success then
356 : blume 2297 if U.fexists targetheaploc then
357 : blume 2692 (if already_existed
358 :     then U.rmfile finalheaploc
359 :     else ();
360 :     U.rename { old = targetheaploc,
361 : blume 2297 new = finalheaploc };
362 : mblume 1391 instcmd target;
363 :     #set (CM.Anchor.anchor target) (SOME bindir))
364 :     else
365 :     fail ["Built ", target, "; ", heapname,
366 :     " still missing.\n"]
367 :     else
368 :     fail ["Building ", target, " failed.\n"];
369 : mblume 1537 command_pathconfig target;
370 : mblume 1391 F.chDir smlnjroot)
371 :     end
372 :    
373 :     (* ------------------------------ *)
374 :    
375 : blume 2090 fun one module =
376 :     let fun perform (RegLib (args, justunix)) =
377 :     if not justunix orelse isUnix then reglib args else ()
378 :     | perform (Anchor ({ anchor, path }, false)) =
379 :     #set (CM.Anchor.anchor anchor) (SOME (native path))
380 :     | perform (Anchor ({ anchor, path }, true)) =
381 :     #set (CM.Anchor.anchor anchor)
382 : blume 2185 (SOME (P.concat (libdir, native path)))
383 : blume 2090 | perform (Program (args, false)) =
384 :     standalone args
385 :     | perform (Program (args, true)) =
386 :     salist := (fn () => standalone args) :: (!salist)
387 :     in case SM.find (actions, module) of
388 :     SOME al => app perform (rev al)
389 :     | NONE => fail ["unknown module: ", module, "\n"]
390 :     end
391 : mblume 1391 in
392 : mblume 1537 (command_pathconfig "bindir"; (* dummy -- for CM make tool *)
393 :     app one modules;
394 : mblume 1391 if dostabs () andalso domoves () andalso dolatesas () then
395 :     uniqconfig ()
396 :     else fail ["stabilization failed\n"])
397 :     handle e => fail ["unexpected exception: ",
398 :     General.exnMessage e, "\n"];
399 :     OS.Process.exit OS.Process.success
400 :     end
401 :     end

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