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/trunk/src/system/smlnj/installer/libinstall.sml
ViewVC logotype

Annotation of /sml/trunk/src/system/smlnj/installer/libinstall.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1411 - (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 :     * (C) 2003 The Fellowship of SML/NJ
13 :     *
14 :     * Author: Matthias Blume (blume@tti-c.org)
15 :     *)
16 :     structure LibInstall : sig
17 :    
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 :     unpackcmd: string option } -> unit
25 :    
26 :     end = struct
27 :    
28 :     structure P = OS.Path
29 :     structure F = OS.FileSys
30 :     structure SI = SMLofNJ.SysInfo
31 :     structure SM = RedBlackMapFn (type ord_key = string
32 :     val compare = String.compare)
33 :    
34 :     structure SCC = GraphSCCFn (type ord_key = string
35 :     val compare = String.compare)
36 :    
37 :     fun say l = TextIO.output (TextIO.stdErr, concat l)
38 : mblume 1411 fun warn l = say ("WARNING: " :: l)
39 : mblume 1391 fun fail l = (say ("FAILURE: " :: l);
40 :     OS.Process.exit OS.Process.failure)
41 :    
42 :     (* figure out who and what we are *)
43 :     val arch = String.map Char.toLower (SMLofNJ.SysInfo.getHostArch ())
44 :     val (isUnix, oskind) = case SI.getOSKind () of
45 :     SI.UNIX => (true, "unix")
46 :     | SI.WIN32 => (false, "win32")
47 :     | _ => fail ["os kind not supported\n"]
48 :    
49 :     val arch_oskind = concat [arch, "-", oskind]
50 :     val heap_suffix = SMLofNJ.SysInfo.getHeapSuffix ()
51 :    
52 :     (* File names in configuration files are used across all platforms
53 :     * and for that reason are written using CM's standard syntax
54 :     * which is like Unix pathname syntax. *)
55 :    
56 :     (* standard arc separator is / *)
57 :     fun usep #"/" = true
58 :     | usep _ = false
59 :    
60 :     (* convert standard syntax to native syntax *)
61 :     fun native f =
62 :     case String.fields usep f of
63 :     "" :: arcs => P.toString { vol = "", isAbs = true, arcs = arcs }
64 :     | arcs => P.toString { vol = "", isAbs = false, arcs = arcs }
65 :    
66 :     fun fexists f = F.access (f, []) handle _ => false
67 :    
68 :     fun rmfile f = F.remove f handle _ => ()
69 :    
70 :     (* several worklists for delayed execution *)
71 :     val stablist : (unit -> bool) list ref = ref []
72 :     val movlist : (unit -> unit) list ref = ref []
73 :     val salist : (unit -> unit) list ref = ref []
74 :    
75 :     (* make a directory (including parent, parent's parent, ...) *)
76 :     fun mkdir "" = ()
77 :     | mkdir d = if fexists d then () else (mkdir (P.dir d); F.mkDir d)
78 :    
79 :     (* move a stable library file to its final location *)
80 :     fun movelib src dst () =
81 :     (mkdir (P.dir dst); F.rename { old = src, new = dst })
82 :    
83 :     (* register a temporary anchor-value binding *)
84 :     fun localanchor { anchor, path } =
85 :     #set (CM.Anchor.anchor anchor) (SOME (native path))
86 :    
87 :     fun getInputTokens s =
88 :     Option.map (String.tokens Char.isSpace) (TextIO.inputLine s)
89 :    
90 :     (* Take a list of modules and dependencies (in depfile) and
91 :     * build the transitive closure of those modules.
92 :     * We do this by considering the dependency graph and construct
93 :     * a topological order for it. *)
94 :     fun resolve (modules, depfile) = let
95 :     val s = TextIO.openIn depfile
96 :     fun rd m =
97 :     case getInputTokens s of
98 :     NONE => (TextIO.closeIn s; fn x => getOpt (SM.find (m, x), []))
99 :     | SOME (x :: xs) => rd (SM.insert (m, x, xs))
100 :     | SOME [] => rd m
101 :     fun strip (SCC.SIMPLE c) = c
102 :     | strip _ = fail ["cyclic dependencies in ", depfile, "\n"]
103 :     in
104 :     rev (map strip (SCC.topOrder' { roots = modules,
105 :     follow = rd SM.empty }))
106 :     end
107 :    
108 :     (* do all the delayed stuff: *)
109 :    
110 :     (* stabilization of libraries... *)
111 :     fun dostabs () =
112 :     foldr (fn (f, true) => f () | (_, false) => false) true (!stablist)
113 :    
114 :     (* move stable library files to their final locations... *)
115 :     fun domoves () =
116 :     (app (fn f => f ()) (rev (!movlist)); true)
117 :     handle _ => false
118 :    
119 :     (* build those standalone programs that require libraries
120 :     * and, therefore, must be compiled "late"... *)
121 :     fun dolatesas () =
122 :     (app (fn f => f ()) (rev (!salist)); true)
123 :     handle _ => false
124 :    
125 :     (* our main routine *)
126 : mblume 1409 fun proc { smlnjroot, installdir, buildcmd, instcmd, unpackcmd } = let
127 : mblume 1391 val smlnjroot = F.fullPath smlnjroot
128 : mblume 1409 val installdir = F.fullPath installdir
129 : mblume 1391 val configdir = P.concat (smlnjroot, "config")
130 :    
131 :     (* dependency file: config/dependencies *)
132 :     val depfile = P.concat (configdir, "dependencies")
133 :    
134 :     (* find and open first usable targetsfiles *)
135 :     val targetsfiles =
136 :     [P.concat (configdir, "targets.customized"),
137 :     P.concat (configdir, "targets")]
138 :    
139 :     val s =
140 :     case List.find fexists targetsfiles of
141 :     SOME f => TextIO.openIn f
142 :     | NONE => fail ["no targetsfiles\n"]
143 :    
144 :     (* parse the targets file *)
145 : mblume 1411 fun loop ml =
146 : mblume 1391 case TextIO.inputLine s of
147 : mblume 1411 NONE => (TextIO.closeIn s; ml)
148 : mblume 1391 | SOME l =>
149 : mblume 1411 if String.sub (l, 0) = #"#" then loop ml
150 : mblume 1391 else (case String.tokens Char.isSpace l of
151 : mblume 1411 [x as ("dont_move_libraries" |
152 :     "move_libraries")] =>
153 :     (warn ["\"", x, "\" no longer supported",
154 :     " (installer always moves libraries)\n"];
155 :     loop ml)
156 :     | ["request", module] => loop (module :: ml)
157 :     | [] => loop ml
158 : mblume 1391 | _ => fail ["ill-formed targets line: ", l])
159 :    
160 : mblume 1411 val modules = loop []
161 : mblume 1391
162 :     (* now resolve dependencies; get full list of modules
163 :     * in correct build order: *)
164 :     val modules = resolve (modules, depfile)
165 :    
166 :     (* fetch and unpack source trees, using auxiliary helper command
167 :     * which takes the root directory as its first and the module
168 :     * names to be fetched as subsequent arguments. *)
169 :     val _ = case unpackcmd of
170 :     NONE => () (* archives must exist *)
171 :     | SOME cmd => let
172 :     val cmdline =
173 :     concat (cmd :: " " :: smlnjroot :: " " ::
174 :     foldr (fn (f, l) => " " :: f :: l)
175 :     [] modules)
176 :     in
177 :     if OS.Process.system cmdline = OS.Process.success
178 :     then ()
179 :     else fail ["unpacking failed\n"]
180 :     end
181 :    
182 : mblume 1409 val libdir = P.concat (installdir, "lib")
183 : mblume 1391 val srcdir = P.concat (smlnjroot, "src")
184 : mblume 1409 val bindir = P.concat (installdir, "bin")
185 : mblume 1391 val heapdir = P.concat (bindir, ".heap")
186 :     val cm_pathconfig = P.concat (libdir, "pathconfig")
187 :    
188 :     (* add an entry to lib/pathconfig *)
189 :     fun write_cm_pathconfig (a, p) = let
190 :     val s = TextIO.openAppend cm_pathconfig
191 :     in
192 :     TextIO.output (s, concat [a, " ", p, "\n"])
193 :     before TextIO.closeOut s
194 :     end
195 :    
196 :     (* at the end, read lib/pathconfig and eliminate duplicate entries *)
197 :     fun uniqconfig () = let
198 :     fun finish m = let
199 :     val s = TextIO.openOut cm_pathconfig
200 :     fun one (key, value) =
201 :     TextIO.output (s, concat [key, " ", value, "\n"])
202 :     in
203 :     SM.appi one m; TextIO.closeOut s
204 :     end
205 :     val s = TextIO.openIn cm_pathconfig
206 :     fun loop m =
207 :     case getInputTokens s of
208 :     NONE => (TextIO.closeIn s; finish m)
209 :     | SOME [key, value] => loop (SM.insert (m, key, value))
210 :     | SOME l => (say ("funny line in " :: cm_pathconfig :: ":" ::
211 :     foldr (fn (x, l) => " " :: x :: l)
212 :     ["\n"] l);
213 :     loop m)
214 :     in
215 :     loop SM.empty
216 :     end
217 :    
218 :     (* register library to be built *)
219 :     fun reglib { anchor, altanchor, relname, dir } = let
220 :     (* anchor: the anchor name currently used by the library
221 :     * to be registered for compilation
222 :     * altanchor: optional alternative anchor name which is
223 :     * to be used once the library is in its final location
224 :     * (this must be used if "anchor" is already bound
225 :     * and used for other libraries which come from the
226 :     * bootfile bundle),
227 :     * relname: path to library's .cm file relative to anchor
228 :     * (standard syntax)
229 :     * dir: directory name that anchor should be bound to,
230 :     * name is relative to srcdir and in standard syntax *)
231 :     val nrelname = native relname
232 :     val ndir = native dir
233 :     val libname = concat ["$", anchor, "/", relname]
234 :     val adir = P.concat (srcdir, ndir)
235 :     val finalanchor = getOpt (altanchor, anchor)
236 :     val { dir = nreldir, file = relbase } = P.splitDirFile nrelname
237 :     val relloc =
238 :     P.concat (nreldir, P.concat (CM.cm_dir_arc,
239 :     P.concat (arch_oskind, relbase)))
240 :     val srcfinalloc = P.concat (adir, relloc)
241 :     val (finalloc, finalconfigpath) =
242 : mblume 1411 (P.concat (libdir,
243 : mblume 1391 P.concat (finalanchor, relloc)),
244 :     finalanchor)
245 :     in
246 :     if fexists finalloc then
247 :     (say ["Library ", libname, " already existed in ",
248 :     finalloc, ". Will rebuild.\n"];
249 :     rmfile finalloc)
250 :     else ();
251 :     if fexists srcfinalloc then rmfile srcfinalloc else ();
252 :     if not (fexists (P.concat (adir, nrelname))) then
253 :     fail ["Source tree for ", libname, " at ",
254 :     P.concat (adir, nreldir), "(", relbase,
255 :     ") does not exist.\n"]
256 :     else
257 :     (say ["Scheduling library ", libname, " to be built as ",
258 :     finalloc, "\n"];
259 :     stablist := (fn () => CM.stabilize false libname)
260 :     :: !stablist;
261 :     #set (CM.Anchor.anchor anchor) (SOME adir);
262 : mblume 1411 movlist := movelib srcfinalloc finalloc :: !movlist;
263 : mblume 1391 write_cm_pathconfig (finalanchor, finalconfigpath))
264 :     end
265 :    
266 :     (* build a standalone program, using auxiliary build script *)
267 :     fun standalone { target, optheapdir, optsrcdir } = let
268 :     (* target: name of program; this is the same as the basename
269 :     * of the heap image to be generated as well as the
270 :     * final arc of the source tree's directory name
271 :     * optheapdir: optional subdirectory where the build command
272 :     * drops the heap image
273 :     * optsrcdir:
274 :     * The source tree for target is located in a directory
275 :     * named the same as the target itself. Normally it is
276 :     * a subdirectory of srcdir. With optsrcdir one can specify
277 :     * an alternative for srcdir by giving a path relative to
278 :     * the original srcdir. *)
279 :     val heapname = concat [target, ".", heap_suffix]
280 :     val targetheaploc =
281 :     case optheapdir of
282 :     NONE => heapname
283 :     | SOME hd => P.concat (native hd, heapname)
284 :     val mysrcdir =
285 :     case optsrcdir of
286 :     NONE => srcdir
287 :     | SOME sd => P.concat (srcdir, native sd)
288 :     val finalheaploc = P.concat (heapdir, heapname)
289 :     val treedir = P.concat (mysrcdir, target)
290 :     in
291 :     if fexists finalheaploc then
292 :     say ["Target ", target, " already exists.\n"]
293 :     else if not (fexists treedir) then
294 :     fail ["Source tree for ", target, " at ", treedir,
295 :     " does not exist.\n"]
296 :     else
297 :     (say ["Building ", target, ".\n"];
298 :     F.chDir treedir;
299 :     if OS.Process.system buildcmd = OS.Process.success then
300 :     if fexists targetheaploc then
301 :     (F.rename { old = targetheaploc,
302 :     new = finalheaploc };
303 :     instcmd target;
304 :     #set (CM.Anchor.anchor target) (SOME bindir))
305 :     else
306 :     fail ["Built ", target, "; ", heapname,
307 :     " still missing.\n"]
308 :     else
309 :     fail ["Building ", target, " failed.\n"];
310 :     write_cm_pathconfig (target, P.concat (P.parentArc, "bin"));
311 :     F.chDir smlnjroot)
312 :     end
313 :    
314 :     (* ------------------------------ *)
315 :    
316 :     (* abbreviations *)
317 :     fun r (a, r, d) = reglib { anchor = a, relname = r, dir = d,
318 :     altanchor = NONE }
319 :     fun r' (a, r, d, aa) = reglib { anchor = a, relname = r, dir = d,
320 :     altanchor = SOME aa }
321 :     fun a (anch, p) = localanchor { anchor = anch, path = p }
322 :    
323 :     fun sa (t, d) =
324 :     standalone { target = t, optheapdir = d, optsrcdir = NONE }
325 :    
326 :     fun sa' (t, d, s) =
327 :     standalone { target = t, optheapdir = d, optsrcdir = SOME s }
328 :    
329 :     (* ------------------------------ *)
330 :    
331 :     (* process one module *)
332 :     fun one "smlnj-lib" =
333 :     (if isUnix then
334 :     r ("unix-lib.cm", "unix-lib.cm", "smlnj-lib/Unix")
335 :     else ();
336 :     r ("inet-lib.cm", "inet-lib.cm", "smlnj-lib/INet");
337 :     r ("regexp-lib.cm", "regexp-lib.cm", "smlnj-lib/RegExp");
338 :     r ("reactive-lib.cm", "reactive-lib.cm", "smlnj-lib/Reactive");
339 :     r ("hash-cons-lib.cm", "hash-cons-lib.cm", "smlnj-lib/HashCons"))
340 :     | one "cml" =
341 :     (r ("cml", "core-cml.cm", "cml/src");
342 :     r ("cml", "cml-internal.cm", "cml/src");
343 :     r ("cml", "cml.cm", "cml/src");
344 :     r ("cml", "basis.cm", "cml/src"))
345 :     | one "cml-lib" =
346 :     (r ("cml-lib", "trace-cml.cm", "cml/cml-lib/cm-descr");
347 :     r ("cml-lib", "smlnj-lib.cm", "cml/cml-lib/cm-descr"))
348 :     | one "eXene" =
349 :     (r ("eXene.cm", "eXene.cm", "eXene"))
350 :     | one "ckit" =
351 :     (r ("ckit-lib.cm", "ckit-lib.cm", "../ckit/src"))
352 :     | one "ml-nlffi-lib" =
353 :     (r ("c", "memory/memory.cm", "ml-nlffi-lib");
354 :     r ("c", "internals/c-int.cm", "ml-nlffi-lib");
355 :     r ("c", "c.cm", "ml-nlffi-lib"))
356 :     | one "pgraph-util" =
357 :     (r ("pgraph-util.cm", "pgraph-util.cm", "cm/pgraph"))
358 :     | one "mlrisc" =
359 : mblume 1409 (a ("Control.cm", P.concat (libdir, "SMLNJ-MLRISC"));
360 :     a ("Lib.cm", P.concat (libdir, "SMLNJ-MLRISC"));
361 :     a ("Visual.cm", P.concat (libdir, "SMLNJ-MLRISC"));
362 :     a ("MLRISC.cm", P.concat (libdir, "SMLNJ-MLRISC"));
363 :     a ("MLTREE.cm", P.concat (libdir, "SMLNJ-MLRISC"));
364 :     a ("Graphs.cm", P.concat (libdir, "SMLNJ-MLRISC"));
365 :     a ("IA32.cm", P.concat (libdir, "SMLNJ-MLRISC"));
366 : mblume 1391 a ("Peephole.cm", "src/MLRISC/cm");
367 :     r' ("OTHER-MLRISC", "RA.cm", "MLRISC/cm", "SMLNJ-MLRISC");
368 :     r' ("OTHER-MLRISC", "Peephole.cm", "MLRISC/cm", "SMLNJ-MLRISC");
369 :     r' ("OTHER-MLRISC", "IA32-Peephole.cm", "MLRISC/cm", "SMLNJ-MLRISC"))
370 :     | one "mlrisc-tools" =
371 :     (r ("mlrisc-tools", "pp.cm", "MLRISC/Tools");
372 :     r ("mlrisc-tools", "source-map.cm", "MLRISC/Tools");
373 :     r ("mlrisc-tools", "sml-ast.cm", "MLRISC/Tools");
374 :     r ("mlrisc-tools", "prec-parser.cm", "MLRISC/Tools");
375 :     r ("mlrisc-tools", "parser.cm", "MLRISC/Tools");
376 :     r ("mlrisc-tools", "match-compiler.cm", "MLRISC/Tools"))
377 :     | one "ml-yacc" =
378 :     sa ("ml-yacc", SOME "src")
379 :     | one "ml-lex" =
380 :     sa ("ml-lex", NONE)
381 :     | one "ml-burg" =
382 :     sa ("ml-burg", NONE)
383 :     | one "ml-nlffigen" =
384 :     salist := (fn () => sa ("ml-nlffigen", NONE))
385 :     :: !salist
386 :     | one "nowhere" =
387 :     salist := (fn () => sa' ("nowhere", NONE, "MLRISC/Tools"))
388 :     :: !salist
389 :     | one module = fail ["unknown module: ", module, "\n"]
390 :     in
391 :     (app one modules;
392 :     if dostabs () andalso domoves () andalso dolatesas () then
393 :     uniqconfig ()
394 :     else fail ["stabilization failed\n"])
395 :     handle e => fail ["unexpected exception: ",
396 :     General.exnMessage e, "\n"];
397 :     OS.Process.exit OS.Process.success
398 :     end
399 :     end

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