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/cm/bootstrap/build-initdg.sml
ViewVC logotype

Annotation of /sml/branches/rt-transition/cm/bootstrap/build-initdg.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 2837 - (view) (download)

1 : blume 326 (*
2 :     * Build a simple dependency graph from a direct DAG description.
3 :     * - This is used in the bootstrap compiler to establish the
4 : blume 592 * pervasive env and the primitives which later get used by
5 :     * the rest of the system.
6 :     * - One important job is to set up a binding to "structure _Core".
7 : blume 326 *
8 :     * (C) 1999 Lucent Technologies, Bell Laboratories
9 :     *
10 :     * Author: Matthias Blume (blume@kurims.kyoto-u.ac.jp)
11 :     *)
12 : blume 327 signature BUILD_INIT_DG = sig
13 : blume 666 val build : GeneralParams.info -> SrcPath.file ->
14 : blume 592 { pervasive: DependencyGraph.sbnode,
15 : blume 537 others: DependencyGraph.sbnode list,
16 : blume 879 src: Source.inputSource } option
17 : blume 326 end
18 :    
19 : blume 327 structure BuildInitDG :> BUILD_INIT_DG = struct
20 : blume 326
21 : blume 879 structure S = Source
22 :     structure EM = ErrorMsg
23 :     structure SM = SourceMap
24 : blume 326 structure DG = DependencyGraph
25 : blume 879 structure LSC = Control.LambdaSplitting
26 : blume 326
27 :     fun build (gp: GeneralParams.info) specgroup = let
28 : mblume 1347 val ovldR = Control.overloadKW
29 : mblume 1633 val ovldC = { save'restore =
30 :     fn () => let val orig = !ovldR in
31 :     fn () => ovldR := orig
32 :     end,
33 :     set = fn () => ovldR := true }
34 : blume 666 val penv = #penv (#param gp)
35 : blume 326 val errcons = #errcons gp
36 :     val groupreg = #groupreg gp
37 :    
38 : blume 666 val context = SrcPath.dir specgroup
39 : blume 354 val _ = Say.vsay ["[reading init spec from ",
40 :     SrcPath.descr specgroup, "]\n"]
41 : blume 326
42 : blume 715 fun defined symbol = isSome (#get (#symval (#param gp) symbol) ())
43 :    
44 : mblume 1633 fun work stream = let
45 : blume 354 val source = S.newSource (SrcPath.osstring specgroup,
46 :     1, stream, false, errcons)
47 : blume 345 val sourceMap = #sourceMap source
48 : blume 326
49 : blume 345 val _ = GroupReg.register groupreg (specgroup, source)
50 : blume 326
51 : blume 345 fun error r m = EM.error source r EM.COMPLAIN m EM.nullErrorBody
52 : blume 326
53 : blume 345 fun lineIn pos = let
54 :     fun sep c = Char.isSpace c orelse Char.contains "(),=;" c
55 : blume 735 val sub = String.sub
56 :     val null = List.null
57 :     fun return (pos, line) = SOME (String.tokens sep line, pos)
58 : mblume 1368 fun loop (pos, NONE, []) = NONE
59 :     | loop (pos, NONE, lines) = return (pos, concat (rev lines))
60 :     | loop (pos, SOME line, lines) = let
61 : blume 735 val len = size line
62 :     val newpos = pos + len
63 :     val iscont =
64 :     len >= 2 andalso
65 :     sub (line, len -1 ) = #"\n" andalso
66 :     sub (line, len - 2) = #"\\"
67 :     in
68 : blume 879 SourceMap.newline sourceMap newpos;
69 : blume 735 if iscont then
70 :     loop (newpos, TextIO.inputLine stream,
71 :     substring (line, 0, len - 2) :: lines)
72 :     else if null lines andalso sub (line, 0) = #"#" then
73 :     SOME ([], newpos)
74 :     else return (newpos, concat (rev (line :: lines)))
75 :     end
76 : blume 345 in
77 : blume 735 loop (pos, TextIO.inputLine stream, [])
78 : blume 345 end
79 : blume 326
80 : blume 537 fun loop (split, m, pos) =
81 : blume 345 case lineIn pos of
82 :     NONE => (error (pos, pos) "unexpected end of file"; NONE)
83 :     | SOME (line, newpos) => let
84 :     val error = error (pos, newpos)
85 : blume 592 fun sml (spec, s, xe, rts, ecs) = let
86 : blume 666 val p = SrcPath.file
87 :     (SrcPath.standard
88 :     { env = penv, err = error }
89 :     { context = context, spec = spec })
90 : blume 537 val attribs =
91 : blume 592 { split = s, is_rts = rts, extra_compenv = xe,
92 : blume 1137 explicit_core_sym = ecs, noguid = false }
93 : mblume 1879 in SmlInfo.info' attribs gp
94 :     { sourcepath = p,
95 :     group = (specgroup, (pos, newpos)),
96 :     sh_spec = Sharing.DONTCARE,
97 :     setup = (NONE, NONE),
98 :     locl = false,
99 :     controllers = [ovldC] }
100 : blume 345 end
101 :     fun bogus n =
102 : blume 818 DG.SNODE { smlinfo = sml (n, LSC.UseDefault, NONE,
103 : blume 592 false, NONE),
104 : blume 345 localimports = [], globalimports = [] }
105 :     fun look n =
106 :     case StringMap.find (m, n) of
107 :     SOME x => x
108 : blume 537 | NONE => (error ("undefined: " ^ n); bogus n)
109 : blume 592 fun node (name, file, args, is_rts, ecs) = let
110 : blume 537 fun one (arg, (li, needs_primenv)) =
111 :     if arg = "primitive" then (li, true)
112 :     else (look arg :: li, needs_primenv)
113 :     val (li, needs_primenv) =
114 :     foldr one ([], false) args
115 :     val xe =
116 : blume 905 if needs_primenv then SOME PrimEnv.primEnv
117 : blume 537 else NONE
118 : blume 592 val i = sml (file, split, xe, is_rts, ecs)
119 : blume 345 val n = DG.SNODE { smlinfo = i,
120 : blume 371 localimports = li,
121 : blume 537 globalimports = [] }
122 : blume 345 in
123 : blume 537 loop (split, StringMap.insert (m, name, n), newpos)
124 : blume 345 end
125 : blume 537 val looksb = DG.SB_SNODE o look
126 : blume 715
127 : blume 1145 fun spl args = let
128 :     fun invalid () =
129 :     (error "invalid split spec"; LSC.UseDefault)
130 :     in
131 :     case args of
132 :     [] => LSC.UseDefault
133 :     | [x] =>
134 :     (case LSplitArg.arg x of
135 :     SOME ls => ls
136 :     | NONE => invalid ())
137 :     | _ => invalid ()
138 :     end
139 :    
140 : blume 715 fun proc [] = loop (split, m, newpos)
141 : blume 1145 | proc ("split" :: arg) = loop (spl arg, m, newpos)
142 : blume 818 | proc ["nosplit"] =
143 :     loop (LSC.Suggest NONE, m, newpos)
144 : blume 715 | proc ("bind" :: name :: file :: args) =
145 :     node (name, file, args, false, NONE)
146 :     | proc ("rts-placeholder" :: name :: file :: args) =
147 :     node (name, file, args, true, NONE)
148 :     | proc ("bind-core" :: ecs :: name :: file :: args) =
149 :     node (name, file, args, false,
150 :     SOME (Symbol.strSymbol ecs))
151 :     | proc ("return" :: pervasive :: prims) =
152 :     SOME { pervasive = looksb pervasive,
153 :     others = map looksb prims,
154 :     src = source }
155 :     | proc ("ifdef" :: symbol :: line) =
156 :     proc (if defined symbol then line else [])
157 :     | proc ("ifndef" :: symbol :: line) =
158 :     proc (if defined symbol then [] else line)
159 :     | proc _ = (error "malformed line"; NONE)
160 : blume 326 in
161 : blume 715 proc line
162 : blume 326 end
163 : blume 345 in
164 : blume 818 loop (LSC.UseDefault, StringMap.empty, 1)
165 : blume 345 end
166 : mblume 1633 fun openIt () = TextIO.openIn (SrcPath.osstring specgroup)
167 : blume 326 in
168 : mblume 1633 SafeIO.perform { openIt = openIt, closeIt = TextIO.closeIn,
169 :     work = work, cleanup = fn _ => () }
170 : blume 326 end
171 :     end

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