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/config/libinstall.sml
ViewVC logotype

Annotation of /sml/trunk/config/libinstall.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1369 - (view) (download)

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

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