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

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