adamc@1
|
1 (* Copyright (c) 2008, Adam Chlipala
|
adamc@1
|
2 * All rights reserved.
|
adamc@1
|
3 *
|
adamc@1
|
4 * Redistribution and use in source and binary forms, with or without
|
adamc@1
|
5 * modification, are permitted provided that the following conditions are met:
|
adamc@1
|
6 *
|
adamc@1
|
7 * - Redistributions of source code must retain the above copyright notice,
|
adamc@1
|
8 * this list of conditions and the following disclaimer.
|
adamc@1
|
9 * - Redistributions in binary form must reproduce the above copyright notice,
|
adamc@1
|
10 * this list of conditions and the following disclaimer in the documentation
|
adamc@1
|
11 * and/or other materials provided with the distribution.
|
adamc@1
|
12 * - The names of contributors may not be used to endorse or promote products
|
adamc@1
|
13 * derived from this software without specific prior written permission.
|
adamc@1
|
14 *
|
adamc@1
|
15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
|
adamc@1
|
16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
|
adamc@1
|
17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
|
adamc@1
|
18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
|
adamc@1
|
19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
adamc@1
|
20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
adamc@1
|
21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
adamc@1
|
22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
adamc@1
|
23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
adamc@1
|
24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
adamc@1
|
25 * POSSIBILITY OF SUCH DAMAGE.
|
adamc@1
|
26 *)
|
adamc@1
|
27
|
adamc@244
|
28 (* Ur/Web language parser *)
|
adamc@1
|
29
|
adamc@1
|
30 structure Compiler :> COMPILER = struct
|
adamc@1
|
31
|
adamc@244
|
32 structure UrwebLrVals = UrwebLrValsFn(structure Token = LrParser.Token)
|
adamc@244
|
33 structure Lex = UrwebLexFn(structure Tokens = UrwebLrVals.Tokens)
|
adamc@244
|
34 structure UrwebP = Join(structure ParserData = UrwebLrVals.ParserData
|
adamc@1
|
35 structure Lex = Lex
|
adamc@1
|
36 structure LrParser = LrParser)
|
adamc@1
|
37
|
adamc@270
|
38 type job = {
|
adamc@270
|
39 database : string option,
|
adamc@274
|
40 sources : string list,
|
adamc@274
|
41 exe : string,
|
adamc@274
|
42 sql : string option,
|
adamc@274
|
43 debug : bool
|
adamc@270
|
44 }
|
adamc@201
|
45
|
adamc@201
|
46 type ('src, 'dst) phase = {
|
adamc@201
|
47 func : 'src -> 'dst,
|
adamc@201
|
48 print : 'dst -> Print.PD.pp_desc
|
adamc@201
|
49 }
|
adamc@201
|
50
|
adamc@201
|
51 type pmap = (string * Time.time) list
|
adamc@201
|
52
|
adamc@201
|
53 type ('src, 'dst) transform = {
|
adamc@201
|
54 func : 'src -> 'dst option,
|
adamc@201
|
55 print : 'dst -> Print.PD.pp_desc,
|
adamc@201
|
56 time : 'src * pmap -> 'dst option * pmap
|
adamc@201
|
57 }
|
adamc@201
|
58
|
adamc@201
|
59 fun transform (ph : ('src, 'dst) phase) name = {
|
adamc@201
|
60 func = fn input => let
|
adamc@201
|
61 val v = #func ph input
|
adamc@201
|
62 in
|
adamc@201
|
63 if ErrorMsg.anyErrors () then
|
adamc@201
|
64 NONE
|
adamc@201
|
65 else
|
adamc@201
|
66 SOME v
|
adamc@201
|
67 end,
|
adamc@201
|
68 print = #print ph,
|
adamc@201
|
69 time = fn (input, pmap) => let
|
adamc@201
|
70 val befor = Time.now ()
|
adamc@201
|
71 val v = #func ph input
|
adamc@201
|
72 val elapsed = Time.- (Time.now (), befor)
|
adamc@201
|
73 in
|
adamc@201
|
74 (if ErrorMsg.anyErrors () then
|
adamc@201
|
75 NONE
|
adamc@201
|
76 else
|
adamc@201
|
77 SOME v,
|
adamc@201
|
78 (name, elapsed) :: pmap)
|
adamc@201
|
79 end
|
adamc@201
|
80 }
|
adamc@201
|
81
|
adamc@270
|
82 fun op o (tr2 : ('b, 'c) transform, tr1 : ('a, 'b) transform) = {
|
adamc@201
|
83 func = fn input => case #func tr1 input of
|
adamc@201
|
84 NONE => NONE
|
adamc@201
|
85 | SOME v => #func tr2 v,
|
adamc@201
|
86 print = #print tr2,
|
adamc@201
|
87 time = fn (input, pmap) => let
|
adamc@201
|
88 val (ro, pmap) = #time tr1 (input, pmap)
|
adamc@201
|
89 in
|
adamc@201
|
90 case ro of
|
adamc@201
|
91 NONE => (NONE, pmap)
|
adamc@201
|
92 | SOME v => #time tr2 (v, pmap)
|
adamc@201
|
93 end
|
adamc@201
|
94 }
|
adamc@201
|
95
|
adamc@201
|
96 fun run (tr : ('src, 'dst) transform) = #func tr
|
adamc@201
|
97
|
adamc@201
|
98 fun runPrint (tr : ('src, 'dst) transform) input =
|
adamc@201
|
99 case #func tr input of
|
adamc@201
|
100 NONE => print "Failure\n"
|
adamc@201
|
101 | SOME v =>
|
adamc@201
|
102 (print "Success\n";
|
adamc@201
|
103 Print.print (#print tr v);
|
adamc@201
|
104 print "\n")
|
adamc@201
|
105
|
adamc@201
|
106 fun time (tr : ('src, 'dst) transform) input =
|
adamc@55
|
107 let
|
adamc@201
|
108 val (_, pmap) = #time tr (input, [])
|
adamc@201
|
109 in
|
adamc@201
|
110 app (fn (name, time) =>
|
adamc@201
|
111 print (name ^ ": " ^ LargeReal.toString (Time.toReal time) ^ "\n")) (rev pmap);
|
adamc@201
|
112 print ("TOTAL: " ^ LargeReal.toString (Time.toReal (foldl Time.+ Time.zeroTime (map #2 pmap))) ^ "\n");
|
adamc@201
|
113 print "\n"
|
adamc@201
|
114 end
|
adamc@55
|
115
|
adamc@201
|
116 fun timePrint (tr : ('src, 'dst) transform) input =
|
adamc@201
|
117 let
|
adamc@201
|
118 val (ro, pmap) = #time tr (input, [])
|
adamc@55
|
119 in
|
adamc@201
|
120 app (fn (name, time) =>
|
adamc@201
|
121 print (name ^ ": " ^ LargeReal.toString (Time.toReal time) ^ "\n")) (rev pmap);
|
adamc@201
|
122 print ("TOTAL: " ^ LargeReal.toString (Time.toReal (foldl Time.+ Time.zeroTime (map #2 pmap))) ^ "\n");
|
adamc@201
|
123 print "\n";
|
adamc@201
|
124 case ro of
|
adamc@201
|
125 NONE => print "Failure\n"
|
adamc@201
|
126 | SOME v =>
|
adamc@201
|
127 (print "Success\n";
|
adamc@201
|
128 Print.print (#print tr v);
|
adamc@201
|
129 print "\n")
|
adamc@55
|
130 end
|
adamc@55
|
131
|
adamc@244
|
132 val parseUrs =
|
adamc@201
|
133 {func = fn filename => let
|
adamc@201
|
134 val fname = OS.FileSys.tmpName ()
|
adamc@201
|
135 val outf = TextIO.openOut fname
|
adamc@201
|
136 val () = TextIO.output (outf, "sig\n")
|
adamc@201
|
137 val inf = TextIO.openIn filename
|
adamc@201
|
138 fun loop () =
|
adamc@201
|
139 case TextIO.inputLine inf of
|
adamc@201
|
140 NONE => ()
|
adamc@201
|
141 | SOME line => (TextIO.output (outf, line);
|
adamc@201
|
142 loop ())
|
adamc@201
|
143 val () = loop ()
|
adamc@201
|
144 val () = TextIO.closeIn inf
|
adamc@201
|
145 val () = TextIO.closeOut outf
|
adamc@201
|
146
|
adamc@201
|
147 val () = (ErrorMsg.resetErrors ();
|
adamc@201
|
148 ErrorMsg.resetPositioning filename;
|
adamc@201
|
149 Lex.UserDeclarations.initialize ())
|
adamc@201
|
150 val file = TextIO.openIn fname
|
adamc@201
|
151 fun get _ = TextIO.input file
|
adamc@201
|
152 fun parseerror (s, p1, p2) = ErrorMsg.errorAt' (p1, p2) s
|
adamc@201
|
153 val lexer = LrParser.Stream.streamify (Lex.makeLexer get)
|
adamc@244
|
154 val (absyn, _) = UrwebP.parse (30, lexer, parseerror, ())
|
adamc@201
|
155 in
|
adamc@201
|
156 TextIO.closeIn file;
|
adamc@201
|
157 case absyn of
|
adamc@201
|
158 [(Source.DSgn ("?", (Source.SgnConst sgis, _)), _)] => sgis
|
adamc@201
|
159 | _ => (ErrorMsg.errorAt {file = filename,
|
adamc@201
|
160 first = {line = 0,
|
adamc@201
|
161 char = 0},
|
adamc@201
|
162 last = {line = 0,
|
adamc@201
|
163 char = 0}} "Not a signature";
|
adamc@201
|
164 [])
|
adamc@201
|
165 end
|
adamc@201
|
166 handle LrParser.ParseError => [],
|
adamc@201
|
167 print = Print.p_list_sep Print.PD.newline SourcePrint.p_sgn_item}
|
adamc@55
|
168
|
adamc@1
|
169 (* The main parsing routine *)
|
adamc@244
|
170 val parseUr = {
|
adamc@201
|
171 func = fn filename =>
|
adamc@201
|
172 let
|
adamc@201
|
173 val () = (ErrorMsg.resetErrors ();
|
adamc@201
|
174 ErrorMsg.resetPositioning filename;
|
adamc@201
|
175 Lex.UserDeclarations.initialize ())
|
adamc@201
|
176 val file = TextIO.openIn filename
|
adamc@201
|
177 fun get _ = TextIO.input file
|
adamc@201
|
178 fun parseerror (s, p1, p2) = ErrorMsg.errorAt' (p1, p2) s
|
adamc@201
|
179 val lexer = LrParser.Stream.streamify (Lex.makeLexer get)
|
adamc@244
|
180 val (absyn, _) = UrwebP.parse (30, lexer, parseerror, ())
|
adamc@201
|
181 in
|
adamc@201
|
182 TextIO.closeIn file;
|
adamc@201
|
183 case absyn of
|
adamc@201
|
184 [(Source.DSgn ("?", _), _)] =>
|
adamc@201
|
185 (ErrorMsg.errorAt {file = filename,
|
adamc@201
|
186 first = {line = 0,
|
adamc@201
|
187 char = 0},
|
adamc@201
|
188 last = {line = 0,
|
adamc@201
|
189 char = 0}} "File starts with 'sig'";
|
adamc@201
|
190 [])
|
adamc@201
|
191 | _ => absyn
|
adamc@201
|
192 end
|
adamc@201
|
193 handle LrParser.ParseError => [],
|
adamc@201
|
194 print = SourcePrint.p_file}
|
adamc@56
|
195
|
adamc@274
|
196 fun p_job {database, exe, sql, sources, debug} =
|
adamc@270
|
197 let
|
adamc@270
|
198 open Print.PD
|
adamc@270
|
199 open Print
|
adamc@270
|
200 in
|
adamc@274
|
201 box [if debug then
|
adamc@274
|
202 box [string "DEBUG", newline]
|
adamc@274
|
203 else
|
adamc@274
|
204 box [],
|
adamc@274
|
205 case database of
|
adamc@270
|
206 NONE => string "No database."
|
adamc@270
|
207 | SOME db => string ("Database: " ^ db),
|
adamc@270
|
208 newline,
|
adamc@274
|
209 string "Exe: ",
|
adamc@274
|
210 string exe,
|
adamc@274
|
211 newline,
|
adamc@274
|
212 case sql of
|
adamc@274
|
213 NONE => string "No SQL file."
|
adamc@274
|
214 | SOME sql => string ("SQL fle: " ^ sql),
|
adamc@270
|
215 string "Sources:",
|
adamc@270
|
216 p_list string sources,
|
adamc@270
|
217 newline]
|
adamc@270
|
218 end
|
adamc@270
|
219
|
adamc@270
|
220 fun trim s =
|
adamc@270
|
221 let
|
adamc@270
|
222 val (_, s) = Substring.splitl Char.isSpace s
|
adamc@270
|
223 val (s, _) = Substring.splitr Char.isSpace s
|
adamc@270
|
224 in
|
adamc@270
|
225 s
|
adamc@270
|
226 end
|
adamc@270
|
227
|
adamc@270
|
228 val parseUrp = {
|
adamc@270
|
229 func = fn filename =>
|
adamc@270
|
230 let
|
adamc@270
|
231 val dir = OS.Path.dir filename
|
adamc@270
|
232 val inf = TextIO.openIn (OS.Path.joinBaseExt {base = filename, ext = SOME "urp"})
|
adamc@270
|
233
|
adamc@274
|
234 fun relify fname =
|
adamc@274
|
235 OS.Path.concat (dir, fname)
|
adamc@274
|
236 handle OS.Path.Path => fname
|
adamc@274
|
237
|
adamc@270
|
238 fun readSources acc =
|
adamc@270
|
239 case TextIO.inputLine inf of
|
adamc@270
|
240 NONE => rev acc
|
adamc@270
|
241 | SOME line =>
|
adamc@270
|
242 let
|
adamc@270
|
243 val acc = if CharVector.all Char.isSpace line then
|
adamc@270
|
244 acc
|
adamc@270
|
245 else
|
adamc@270
|
246 let
|
adamc@270
|
247 val fname = String.implode (List.filter (fn x => not (Char.isSpace x))
|
adamc@270
|
248 (String.explode line))
|
adamc@274
|
249 val fname = relify fname
|
adamc@270
|
250 in
|
adamc@270
|
251 fname :: acc
|
adamc@270
|
252 end
|
adamc@270
|
253 in
|
adamc@270
|
254 readSources acc
|
adamc@270
|
255 end
|
adamc@270
|
256
|
adamc@274
|
257 fun finish (database, exe, sql, debug, sources) =
|
adamc@274
|
258 {database = database,
|
adamc@274
|
259 exe = Option.getOpt (exe, OS.Path.joinBaseExt {base = OS.Path.base filename,
|
adamc@274
|
260 ext = SOME "exe"}),
|
adamc@274
|
261 sql = sql,
|
adamc@274
|
262 debug = debug,
|
adamc@274
|
263 sources = sources}
|
adamc@274
|
264
|
adamc@274
|
265 fun read (database, exe, sql, debug) =
|
adamc@270
|
266 case TextIO.inputLine inf of
|
adamc@274
|
267 NONE => finish (database, exe, sql, debug, [])
|
adamc@274
|
268 | SOME "\n" => finish (database, exe, sql, debug, readSources [])
|
adamc@270
|
269 | SOME line =>
|
adamc@270
|
270 let
|
adamc@270
|
271 val (cmd, arg) = Substring.splitl (fn x => not (Char.isSpace x)) (Substring.full line)
|
adamc@270
|
272 val cmd = Substring.string (trim cmd)
|
adamc@270
|
273 val arg = Substring.string (trim arg)
|
adamc@270
|
274 in
|
adamc@270
|
275 case cmd of
|
adamc@270
|
276 "database" =>
|
adamc@270
|
277 (case database of
|
adamc@270
|
278 NONE => ()
|
adamc@270
|
279 | SOME _ => ErrorMsg.error "Duplicate 'database' directive";
|
adamc@274
|
280 read (SOME arg, exe, sql, debug))
|
adamc@274
|
281 | "exe" =>
|
adamc@274
|
282 (case exe of
|
adamc@274
|
283 NONE => ()
|
adamc@274
|
284 | SOME _ => ErrorMsg.error "Duplicate 'exe' directive";
|
adamc@274
|
285 read (database, SOME (relify arg), sql, debug))
|
adamc@274
|
286 | "sql" =>
|
adamc@274
|
287 (case sql of
|
adamc@274
|
288 NONE => ()
|
adamc@274
|
289 | SOME _ => ErrorMsg.error "Duplicate 'sql' directive";
|
adamc@274
|
290 read (database, exe, SOME (relify arg), debug))
|
adamc@274
|
291 | "debug" => read (database, exe, sql, true)
|
adamc@270
|
292 | _ => (ErrorMsg.error ("Unrecognized command '" ^ cmd ^ "'");
|
adamc@274
|
293 read (database, exe, sql, debug))
|
adamc@270
|
294 end
|
adamc@270
|
295 in
|
adamc@274
|
296 read (NONE, NONE, NONE, false)
|
adamc@270
|
297 before TextIO.closeIn inf
|
adamc@270
|
298 end,
|
adamc@270
|
299 print = p_job
|
adamc@270
|
300 }
|
adamc@270
|
301
|
adamc@270
|
302 val toParseJob = transform parseUrp "parseJob"
|
adamc@270
|
303
|
adamc@56
|
304 fun capitalize "" = ""
|
adamc@56
|
305 | capitalize s = str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE)
|
adamc@56
|
306
|
adamc@201
|
307 val parse = {
|
adamc@274
|
308 func = fn {database, sources = fnames, ...} : job =>
|
adamc@201
|
309 let
|
adamc@201
|
310 fun nameOf fname = capitalize (OS.Path.file fname)
|
adamc@109
|
311
|
adamc@201
|
312 fun parseOne fname =
|
adamc@201
|
313 let
|
adamc@201
|
314 val mname = nameOf fname
|
adamc@244
|
315 val ur = OS.Path.joinBaseExt {base = fname, ext = SOME "ur"}
|
adamc@244
|
316 val urs = OS.Path.joinBaseExt {base = fname, ext = SOME "urs"}
|
adamc@56
|
317
|
adamc@201
|
318 val sgnO =
|
adamc@244
|
319 if Posix.FileSys.access (urs, []) then
|
adamc@244
|
320 SOME (Source.SgnConst (#func parseUrs urs),
|
adamc@244
|
321 {file = urs,
|
adamc@201
|
322 first = ErrorMsg.dummyPos,
|
adamc@201
|
323 last = ErrorMsg.dummyPos})
|
adamc@201
|
324 else
|
adamc@201
|
325 NONE
|
adamc@56
|
326
|
adamc@244
|
327 val loc = {file = ur,
|
adamc@201
|
328 first = ErrorMsg.dummyPos,
|
adamc@201
|
329 last = ErrorMsg.dummyPos}
|
adamc@56
|
330
|
adamc@244
|
331 val ds = #func parseUr ur
|
adamc@201
|
332 in
|
adamc@201
|
333 (Source.DStr (mname, sgnO, (Source.StrConst ds, loc)), loc)
|
adamc@201
|
334 end
|
adamc@56
|
335
|
adamc@201
|
336 val ds = map parseOne fnames
|
adamc@201
|
337 in
|
adamc@201
|
338 let
|
adamc@201
|
339 val final = nameOf (List.last fnames)
|
adamc@271
|
340
|
adamc@271
|
341 val ds = ds @ [(Source.DExport (Source.StrVar final, ErrorMsg.dummySpan), ErrorMsg.dummySpan)]
|
adamc@201
|
342 in
|
adamc@271
|
343 case database of
|
adamc@271
|
344 NONE => ds
|
adamc@271
|
345 | SOME s => (Source.DDatabase s, ErrorMsg.dummySpan) :: ds
|
adamc@201
|
346 end handle Empty => ds
|
adamc@201
|
347 end,
|
adamc@201
|
348 print = SourcePrint.p_file
|
adamc@201
|
349 }
|
adamc@56
|
350
|
adamc@270
|
351 val toParse = transform parse "parse" o toParseJob
|
adamc@38
|
352
|
adamc@201
|
353 val elaborate = {
|
adamc@201
|
354 func = fn file => let
|
adamc@244
|
355 val basis = #func parseUrs "lib/basis.urs"
|
adamc@201
|
356 in
|
adamc@201
|
357 Elaborate.elabFile basis ElabEnv.empty file
|
adamc@201
|
358 end,
|
adamc@201
|
359 print = ElabPrint.p_file ElabEnv.empty
|
adamc@201
|
360 }
|
adamc@5
|
361
|
adamc@270
|
362 val toElaborate = transform elaborate "elaborate" o toParse
|
adamc@201
|
363
|
adamc@201
|
364 val explify = {
|
adamc@201
|
365 func = Explify.explify,
|
adamc@201
|
366 print = ExplPrint.p_file ExplEnv.empty
|
adamc@201
|
367 }
|
adamc@201
|
368
|
adamc@270
|
369 val toExplify = transform explify "explify" o toElaborate
|
adamc@201
|
370
|
adamc@201
|
371 val corify = {
|
adamc@201
|
372 func = Corify.corify,
|
adamc@201
|
373 print = CorePrint.p_file CoreEnv.empty
|
adamc@201
|
374 }
|
adamc@201
|
375
|
adamc@270
|
376 val toCorify = transform corify "corify" o toExplify
|
adamc@201
|
377
|
adamc@202
|
378 val shake = {
|
adamc@202
|
379 func = Shake.shake,
|
adamc@202
|
380 print = CorePrint.p_file CoreEnv.empty
|
adamc@202
|
381 }
|
adamc@39
|
382
|
adamc@270
|
383 val toShake1 = transform shake "shake1" o toCorify
|
adamc@110
|
384
|
adamc@202
|
385 val tag = {
|
adamc@202
|
386 func = Tag.tag,
|
adamc@202
|
387 print = CorePrint.p_file CoreEnv.empty
|
adamc@202
|
388 }
|
adamc@193
|
389
|
adamc@270
|
390 val toTag = transform tag "tag" o toShake1
|
adamc@20
|
391
|
adamc@202
|
392 val reduce = {
|
adamc@202
|
393 func = Reduce.reduce,
|
adamc@202
|
394 print = CorePrint.p_file CoreEnv.empty
|
adamc@202
|
395 }
|
adamc@25
|
396
|
adamc@270
|
397 val toReduce = transform reduce "reduce" o toTag
|
adamc@23
|
398
|
adamc@202
|
399 val specialize = {
|
adamc@202
|
400 func = Specialize.specialize,
|
adamc@202
|
401 print = CorePrint.p_file CoreEnv.empty
|
adamc@202
|
402 }
|
adamc@132
|
403
|
adamc@270
|
404 val toSpecialize = transform specialize "specialize" o toReduce
|
adamc@131
|
405
|
adamc@270
|
406 val toShake2 = transform shake "shake2" o toSpecialize
|
adamc@133
|
407
|
adamc@202
|
408 val monoize = {
|
adamc@202
|
409 func = Monoize.monoize CoreEnv.empty,
|
adamc@202
|
410 print = MonoPrint.p_file MonoEnv.empty
|
adamc@202
|
411 }
|
adamc@134
|
412
|
adamc@270
|
413 val toMonoize = transform monoize "monoize" o toShake2
|
adamc@96
|
414
|
adamc@202
|
415 val mono_opt = {
|
adamc@202
|
416 func = MonoOpt.optimize,
|
adamc@202
|
417 print = MonoPrint.p_file MonoEnv.empty
|
adamc@202
|
418 }
|
adamc@29
|
419
|
adamc@270
|
420 val toMono_opt1 = transform mono_opt "mono_opt1" o toMonoize
|
adamc@5
|
421
|
adamc@202
|
422 val untangle = {
|
adamc@202
|
423 func = Untangle.untangle,
|
adamc@202
|
424 print = MonoPrint.p_file MonoEnv.empty
|
adamc@202
|
425 }
|
adamc@1
|
426
|
adamc@270
|
427 val toUntangle = transform untangle "untangle" o toMono_opt1
|
adamc@38
|
428
|
adamc@202
|
429 val mono_reduce = {
|
adamc@202
|
430 func = MonoReduce.reduce,
|
adamc@202
|
431 print = MonoPrint.p_file MonoEnv.empty
|
adamc@202
|
432 }
|
adamc@16
|
433
|
adamc@270
|
434 val toMono_reduce = transform mono_reduce "mono_reduce" o toUntangle
|
adamc@39
|
435
|
adamc@202
|
436 val mono_shake = {
|
adamc@202
|
437 func = MonoShake.shake,
|
adamc@202
|
438 print = MonoPrint.p_file MonoEnv.empty
|
adamc@202
|
439 }
|
adamc@110
|
440
|
adamc@270
|
441 val toMono_shake = transform mono_shake "mono_shake1" o toMono_reduce
|
adamc@193
|
442
|
adamc@270
|
443 val toMono_opt2 = transform mono_opt "mono_opt2" o toMono_shake
|
adamc@20
|
444
|
adamc@202
|
445 val cjrize = {
|
adamc@202
|
446 func = Cjrize.cjrize,
|
adamc@202
|
447 print = CjrPrint.p_file CjrEnv.empty
|
adamc@202
|
448 }
|
adamc@23
|
449
|
adamc@270
|
450 val toCjrize = transform cjrize "cjrize" o toMono_opt2
|
adamc@29
|
451
|
adamc@274
|
452 val sqlify = {
|
adamc@274
|
453 func = Cjrize.cjrize,
|
adamc@274
|
454 print = CjrPrint.p_sql CjrEnv.empty
|
adamc@274
|
455 }
|
adamc@274
|
456
|
adamc@274
|
457 val toSqlify = transform sqlify "sqlify" o toMono_opt2
|
adamc@274
|
458
|
adamc@183
|
459 fun compileC {cname, oname, ename} =
|
adamc@183
|
460 let
|
adamc@183
|
461 val compile = "gcc -O3 -I include -c " ^ cname ^ " -o " ^ oname
|
adamc@272
|
462 val link = "gcc -O3 -pthread -lpq clib/urweb.o " ^ oname ^ " clib/driver.o -o " ^ ename
|
adamc@183
|
463 in
|
adamc@183
|
464 if not (OS.Process.isSuccess (OS.Process.system compile)) then
|
adamc@183
|
465 print "C compilation failed\n"
|
adamc@183
|
466 else if not (OS.Process.isSuccess (OS.Process.system link)) then
|
adamc@186
|
467 print "C linking failed\n"
|
adamc@183
|
468 else
|
adamc@183
|
469 print "Success\n"
|
adamc@183
|
470 end
|
adamc@183
|
471
|
adamc@202
|
472 fun compile job =
|
adamc@202
|
473 case run toCjrize job of
|
adamc@244
|
474 NONE => print "Ur compilation failed\n"
|
adamc@29
|
475 | SOME file =>
|
adamc@202
|
476 let
|
adamc@274
|
477 val job = valOf (run (transform parseUrp "parseUrp") job)
|
adamc@102
|
478
|
adamc@274
|
479 val (cname, oname, cleanup) =
|
adamc@274
|
480 if #debug job then
|
adamc@274
|
481 ("/tmp/urweb.c", "/tmp/urweb.o", fn () => ())
|
adamc@274
|
482 else
|
adamc@274
|
483 let
|
adamc@274
|
484 val dir = OS.FileSys.tmpName ()
|
adamc@274
|
485 val cname = OS.Path.joinDirFile {dir = dir, file = "urweb.c"}
|
adamc@274
|
486 val oname = OS.Path.joinDirFile {dir = dir, file = "urweb.o"}
|
adamc@274
|
487 in
|
adamc@274
|
488 OS.FileSys.mkDir dir;
|
adamc@274
|
489 (cname, oname,
|
adamc@274
|
490 fn () => (OS.FileSys.remove cname;
|
adamc@274
|
491 OS.FileSys.remove oname;
|
adamc@274
|
492 OS.FileSys.rmDir dir))
|
adamc@274
|
493 end
|
adamc@274
|
494 val ename = #exe job
|
adamc@202
|
495 in
|
adamc@274
|
496 let
|
adamc@274
|
497 val outf = TextIO.openOut cname
|
adamc@274
|
498 val s = TextIOPP.openOut {dst = outf, wid = 80}
|
adamc@274
|
499 in
|
adamc@274
|
500 Print.fprint s (CjrPrint.p_file CjrEnv.empty file);
|
adamc@274
|
501 TextIO.closeOut outf;
|
adamc@102
|
502
|
adamc@274
|
503 case #sql job of
|
adamc@274
|
504 NONE => ()
|
adamc@274
|
505 | SOME sql =>
|
adamc@274
|
506 let
|
adamc@274
|
507 val outf = TextIO.openOut sql
|
adamc@274
|
508 val s = TextIOPP.openOut {dst = outf, wid = 80}
|
adamc@274
|
509 in
|
adamc@274
|
510 Print.fprint s (CjrPrint.p_sql CjrEnv.empty file);
|
adamc@274
|
511 TextIO.closeOut outf
|
adamc@274
|
512 end;
|
adamc@274
|
513
|
adamc@274
|
514 compileC {cname = cname, oname = oname, ename = ename};
|
adamc@274
|
515
|
adamc@274
|
516 cleanup ()
|
adamc@274
|
517 end
|
adamc@274
|
518 handle ex => (((cleanup ()) handle _ => ()); raise ex)
|
adamc@202
|
519 end
|
adamc@29
|
520
|
adamc@1
|
521 end
|