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@346
|
96 fun check (tr : ('src, 'dst) transform) x = (ErrorMsg.resetErrors ();
|
adamc@346
|
97 ignore (#func tr x))
|
adamc@346
|
98
|
adamc@280
|
99 fun run (tr : ('src, 'dst) transform) x = (ErrorMsg.resetErrors ();
|
adamc@280
|
100 #func tr x)
|
adamc@201
|
101
|
adamc@201
|
102 fun runPrint (tr : ('src, 'dst) transform) input =
|
adamc@280
|
103 (ErrorMsg.resetErrors ();
|
adamc@280
|
104 case #func tr input of
|
adamc@280
|
105 NONE => print "Failure\n"
|
adamc@280
|
106 | SOME v =>
|
adamc@280
|
107 (print "Success\n";
|
adamc@280
|
108 Print.print (#print tr v);
|
adamc@280
|
109 print "\n"))
|
adamc@201
|
110
|
adamc@201
|
111 fun time (tr : ('src, 'dst) transform) input =
|
adamc@55
|
112 let
|
adamc@201
|
113 val (_, pmap) = #time tr (input, [])
|
adamc@201
|
114 in
|
adamc@201
|
115 app (fn (name, time) =>
|
adamc@201
|
116 print (name ^ ": " ^ LargeReal.toString (Time.toReal time) ^ "\n")) (rev pmap);
|
adamc@201
|
117 print ("TOTAL: " ^ LargeReal.toString (Time.toReal (foldl Time.+ Time.zeroTime (map #2 pmap))) ^ "\n");
|
adamc@201
|
118 print "\n"
|
adamc@201
|
119 end
|
adamc@55
|
120
|
adamc@201
|
121 fun timePrint (tr : ('src, 'dst) transform) input =
|
adamc@201
|
122 let
|
adamc@201
|
123 val (ro, pmap) = #time tr (input, [])
|
adamc@55
|
124 in
|
adamc@201
|
125 app (fn (name, time) =>
|
adamc@201
|
126 print (name ^ ": " ^ LargeReal.toString (Time.toReal time) ^ "\n")) (rev pmap);
|
adamc@201
|
127 print ("TOTAL: " ^ LargeReal.toString (Time.toReal (foldl Time.+ Time.zeroTime (map #2 pmap))) ^ "\n");
|
adamc@201
|
128 print "\n";
|
adamc@201
|
129 case ro of
|
adamc@201
|
130 NONE => print "Failure\n"
|
adamc@201
|
131 | SOME v =>
|
adamc@201
|
132 (print "Success\n";
|
adamc@201
|
133 Print.print (#print tr v);
|
adamc@201
|
134 print "\n")
|
adamc@55
|
135 end
|
adamc@55
|
136
|
adamc@244
|
137 val parseUrs =
|
adamc@201
|
138 {func = fn filename => let
|
adamc@201
|
139 val fname = OS.FileSys.tmpName ()
|
adamc@201
|
140 val outf = TextIO.openOut fname
|
adamc@201
|
141 val () = TextIO.output (outf, "sig\n")
|
adamc@201
|
142 val inf = TextIO.openIn filename
|
adamc@201
|
143 fun loop () =
|
adamc@201
|
144 case TextIO.inputLine inf of
|
adamc@201
|
145 NONE => ()
|
adamc@201
|
146 | SOME line => (TextIO.output (outf, line);
|
adamc@201
|
147 loop ())
|
adamc@201
|
148 val () = loop ()
|
adamc@201
|
149 val () = TextIO.closeIn inf
|
adamc@201
|
150 val () = TextIO.closeOut outf
|
adamc@201
|
151
|
adamc@201
|
152 val () = (ErrorMsg.resetErrors ();
|
adamc@201
|
153 ErrorMsg.resetPositioning filename;
|
adamc@201
|
154 Lex.UserDeclarations.initialize ())
|
adamc@201
|
155 val file = TextIO.openIn fname
|
adamc@201
|
156 fun get _ = TextIO.input file
|
adamc@201
|
157 fun parseerror (s, p1, p2) = ErrorMsg.errorAt' (p1, p2) s
|
adamc@201
|
158 val lexer = LrParser.Stream.streamify (Lex.makeLexer get)
|
adamc@244
|
159 val (absyn, _) = UrwebP.parse (30, lexer, parseerror, ())
|
adamc@201
|
160 in
|
adamc@201
|
161 TextIO.closeIn file;
|
adamc@201
|
162 case absyn of
|
adamc@201
|
163 [(Source.DSgn ("?", (Source.SgnConst sgis, _)), _)] => sgis
|
adamc@201
|
164 | _ => (ErrorMsg.errorAt {file = filename,
|
adamc@201
|
165 first = {line = 0,
|
adamc@201
|
166 char = 0},
|
adamc@201
|
167 last = {line = 0,
|
adamc@201
|
168 char = 0}} "Not a signature";
|
adamc@201
|
169 [])
|
adamc@201
|
170 end
|
adamc@201
|
171 handle LrParser.ParseError => [],
|
adamc@201
|
172 print = Print.p_list_sep Print.PD.newline SourcePrint.p_sgn_item}
|
adamc@55
|
173
|
adamc@1
|
174 (* The main parsing routine *)
|
adamc@244
|
175 val parseUr = {
|
adamc@201
|
176 func = fn filename =>
|
adamc@201
|
177 let
|
adamc@201
|
178 val () = (ErrorMsg.resetErrors ();
|
adamc@201
|
179 ErrorMsg.resetPositioning filename;
|
adamc@201
|
180 Lex.UserDeclarations.initialize ())
|
adamc@201
|
181 val file = TextIO.openIn filename
|
adamc@201
|
182 fun get _ = TextIO.input file
|
adamc@201
|
183 fun parseerror (s, p1, p2) = ErrorMsg.errorAt' (p1, p2) s
|
adamc@201
|
184 val lexer = LrParser.Stream.streamify (Lex.makeLexer get)
|
adamc@244
|
185 val (absyn, _) = UrwebP.parse (30, lexer, parseerror, ())
|
adamc@201
|
186 in
|
adamc@201
|
187 TextIO.closeIn file;
|
adamc@201
|
188 case absyn of
|
adamc@201
|
189 [(Source.DSgn ("?", _), _)] =>
|
adamc@201
|
190 (ErrorMsg.errorAt {file = filename,
|
adamc@201
|
191 first = {line = 0,
|
adamc@201
|
192 char = 0},
|
adamc@201
|
193 last = {line = 0,
|
adamc@201
|
194 char = 0}} "File starts with 'sig'";
|
adamc@201
|
195 [])
|
adamc@201
|
196 | _ => absyn
|
adamc@201
|
197 end
|
adamc@201
|
198 handle LrParser.ParseError => [],
|
adamc@201
|
199 print = SourcePrint.p_file}
|
adamc@56
|
200
|
adamc@274
|
201 fun p_job {database, exe, sql, sources, debug} =
|
adamc@270
|
202 let
|
adamc@270
|
203 open Print.PD
|
adamc@270
|
204 open Print
|
adamc@270
|
205 in
|
adamc@274
|
206 box [if debug then
|
adamc@274
|
207 box [string "DEBUG", newline]
|
adamc@274
|
208 else
|
adamc@274
|
209 box [],
|
adamc@274
|
210 case database of
|
adamc@270
|
211 NONE => string "No database."
|
adamc@270
|
212 | SOME db => string ("Database: " ^ db),
|
adamc@270
|
213 newline,
|
adamc@274
|
214 string "Exe: ",
|
adamc@274
|
215 string exe,
|
adamc@274
|
216 newline,
|
adamc@274
|
217 case sql of
|
adamc@274
|
218 NONE => string "No SQL file."
|
adamc@274
|
219 | SOME sql => string ("SQL fle: " ^ sql),
|
adamc@270
|
220 string "Sources:",
|
adamc@270
|
221 p_list string sources,
|
adamc@270
|
222 newline]
|
adamc@270
|
223 end
|
adamc@270
|
224
|
adamc@270
|
225 fun trim s =
|
adamc@270
|
226 let
|
adamc@270
|
227 val (_, s) = Substring.splitl Char.isSpace s
|
adamc@270
|
228 val (s, _) = Substring.splitr Char.isSpace s
|
adamc@270
|
229 in
|
adamc@270
|
230 s
|
adamc@270
|
231 end
|
adamc@270
|
232
|
adamc@270
|
233 val parseUrp = {
|
adamc@270
|
234 func = fn filename =>
|
adamc@270
|
235 let
|
adamc@270
|
236 val dir = OS.Path.dir filename
|
adamc@270
|
237 val inf = TextIO.openIn (OS.Path.joinBaseExt {base = filename, ext = SOME "urp"})
|
adamc@270
|
238
|
adamc@274
|
239 fun relify fname =
|
adamc@274
|
240 OS.Path.concat (dir, fname)
|
adamc@274
|
241 handle OS.Path.Path => fname
|
adamc@274
|
242
|
adamc@270
|
243 fun readSources acc =
|
adamc@270
|
244 case TextIO.inputLine inf of
|
adamc@270
|
245 NONE => rev acc
|
adamc@270
|
246 | SOME line =>
|
adamc@270
|
247 let
|
adamc@270
|
248 val acc = if CharVector.all Char.isSpace line then
|
adamc@270
|
249 acc
|
adamc@270
|
250 else
|
adamc@270
|
251 let
|
adamc@270
|
252 val fname = String.implode (List.filter (fn x => not (Char.isSpace x))
|
adamc@270
|
253 (String.explode line))
|
adamc@274
|
254 val fname = relify fname
|
adamc@270
|
255 in
|
adamc@270
|
256 fname :: acc
|
adamc@270
|
257 end
|
adamc@270
|
258 in
|
adamc@270
|
259 readSources acc
|
adamc@270
|
260 end
|
adamc@270
|
261
|
adamc@274
|
262 fun finish (database, exe, sql, debug, sources) =
|
adamc@274
|
263 {database = database,
|
adamc@274
|
264 exe = Option.getOpt (exe, OS.Path.joinBaseExt {base = OS.Path.base filename,
|
adamc@274
|
265 ext = SOME "exe"}),
|
adamc@274
|
266 sql = sql,
|
adamc@274
|
267 debug = debug,
|
adamc@274
|
268 sources = sources}
|
adamc@274
|
269
|
adamc@274
|
270 fun read (database, exe, sql, debug) =
|
adamc@270
|
271 case TextIO.inputLine inf of
|
adamc@274
|
272 NONE => finish (database, exe, sql, debug, [])
|
adamc@274
|
273 | SOME "\n" => finish (database, exe, sql, debug, readSources [])
|
adamc@270
|
274 | SOME line =>
|
adamc@270
|
275 let
|
adamc@270
|
276 val (cmd, arg) = Substring.splitl (fn x => not (Char.isSpace x)) (Substring.full line)
|
adamc@270
|
277 val cmd = Substring.string (trim cmd)
|
adamc@270
|
278 val arg = Substring.string (trim arg)
|
adamc@270
|
279 in
|
adamc@270
|
280 case cmd of
|
adamc@270
|
281 "database" =>
|
adamc@270
|
282 (case database of
|
adamc@270
|
283 NONE => ()
|
adamc@270
|
284 | SOME _ => ErrorMsg.error "Duplicate 'database' directive";
|
adamc@274
|
285 read (SOME arg, exe, sql, debug))
|
adamc@274
|
286 | "exe" =>
|
adamc@274
|
287 (case exe of
|
adamc@274
|
288 NONE => ()
|
adamc@274
|
289 | SOME _ => ErrorMsg.error "Duplicate 'exe' directive";
|
adamc@274
|
290 read (database, SOME (relify arg), sql, debug))
|
adamc@274
|
291 | "sql" =>
|
adamc@274
|
292 (case sql of
|
adamc@274
|
293 NONE => ()
|
adamc@274
|
294 | SOME _ => ErrorMsg.error "Duplicate 'sql' directive";
|
adamc@274
|
295 read (database, exe, SOME (relify arg), debug))
|
adamc@274
|
296 | "debug" => read (database, exe, sql, true)
|
adamc@270
|
297 | _ => (ErrorMsg.error ("Unrecognized command '" ^ cmd ^ "'");
|
adamc@274
|
298 read (database, exe, sql, debug))
|
adamc@270
|
299 end
|
adamc@270
|
300 in
|
adamc@274
|
301 read (NONE, NONE, NONE, false)
|
adamc@270
|
302 before TextIO.closeIn inf
|
adamc@270
|
303 end,
|
adamc@270
|
304 print = p_job
|
adamc@270
|
305 }
|
adamc@270
|
306
|
adamc@270
|
307 val toParseJob = transform parseUrp "parseJob"
|
adamc@270
|
308
|
adamc@56
|
309 fun capitalize "" = ""
|
adamc@56
|
310 | capitalize s = str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE)
|
adamc@56
|
311
|
adamc@201
|
312 val parse = {
|
adamc@274
|
313 func = fn {database, sources = fnames, ...} : job =>
|
adamc@201
|
314 let
|
adamc@201
|
315 fun nameOf fname = capitalize (OS.Path.file fname)
|
adamc@109
|
316
|
adamc@201
|
317 fun parseOne fname =
|
adamc@201
|
318 let
|
adamc@201
|
319 val mname = nameOf fname
|
adamc@244
|
320 val ur = OS.Path.joinBaseExt {base = fname, ext = SOME "ur"}
|
adamc@244
|
321 val urs = OS.Path.joinBaseExt {base = fname, ext = SOME "urs"}
|
adamc@56
|
322
|
adamc@201
|
323 val sgnO =
|
adamc@244
|
324 if Posix.FileSys.access (urs, []) then
|
adamc@244
|
325 SOME (Source.SgnConst (#func parseUrs urs),
|
adamc@244
|
326 {file = urs,
|
adamc@201
|
327 first = ErrorMsg.dummyPos,
|
adamc@201
|
328 last = ErrorMsg.dummyPos})
|
adamc@201
|
329 else
|
adamc@201
|
330 NONE
|
adamc@56
|
331
|
adamc@244
|
332 val loc = {file = ur,
|
adamc@201
|
333 first = ErrorMsg.dummyPos,
|
adamc@201
|
334 last = ErrorMsg.dummyPos}
|
adamc@56
|
335
|
adamc@244
|
336 val ds = #func parseUr ur
|
adamc@201
|
337 in
|
adamc@201
|
338 (Source.DStr (mname, sgnO, (Source.StrConst ds, loc)), loc)
|
adamc@201
|
339 end
|
adamc@56
|
340
|
adamc@201
|
341 val ds = map parseOne fnames
|
adamc@201
|
342 in
|
adamc@201
|
343 let
|
adamc@201
|
344 val final = nameOf (List.last fnames)
|
adamc@271
|
345
|
adamc@271
|
346 val ds = ds @ [(Source.DExport (Source.StrVar final, ErrorMsg.dummySpan), ErrorMsg.dummySpan)]
|
adamc@201
|
347 in
|
adamc@271
|
348 case database of
|
adamc@271
|
349 NONE => ds
|
adamc@271
|
350 | SOME s => (Source.DDatabase s, ErrorMsg.dummySpan) :: ds
|
adamc@201
|
351 end handle Empty => ds
|
adamc@201
|
352 end,
|
adamc@201
|
353 print = SourcePrint.p_file
|
adamc@201
|
354 }
|
adamc@56
|
355
|
adamc@270
|
356 val toParse = transform parse "parse" o toParseJob
|
adamc@38
|
357
|
adamc@201
|
358 val elaborate = {
|
adamc@201
|
359 func = fn file => let
|
adamc@244
|
360 val basis = #func parseUrs "lib/basis.urs"
|
adamc@325
|
361 val topSgn = #func parseUrs "lib/top.urs"
|
adamc@325
|
362 val topStr = #func parseUr "lib/top.ur"
|
adamc@201
|
363 in
|
adamc@325
|
364 Elaborate.elabFile basis topStr topSgn ElabEnv.empty file
|
adamc@201
|
365 end,
|
adamc@201
|
366 print = ElabPrint.p_file ElabEnv.empty
|
adamc@201
|
367 }
|
adamc@5
|
368
|
adamc@270
|
369 val toElaborate = transform elaborate "elaborate" o toParse
|
adamc@201
|
370
|
adamc@313
|
371 val termination = {
|
adamc@313
|
372 func = (fn file => (Termination.check file; file)),
|
adamc@313
|
373 print = ElabPrint.p_file ElabEnv.empty
|
adamc@313
|
374 }
|
adamc@313
|
375
|
adamc@313
|
376 val toTermination = transform termination "termination" o toElaborate
|
adamc@313
|
377
|
adamc@201
|
378 val explify = {
|
adamc@201
|
379 func = Explify.explify,
|
adamc@201
|
380 print = ExplPrint.p_file ExplEnv.empty
|
adamc@201
|
381 }
|
adamc@201
|
382
|
adamc@313
|
383 val toExplify = transform explify "explify" o toTermination
|
adamc@201
|
384
|
adamc@201
|
385 val corify = {
|
adamc@201
|
386 func = Corify.corify,
|
adamc@201
|
387 print = CorePrint.p_file CoreEnv.empty
|
adamc@201
|
388 }
|
adamc@201
|
389
|
adamc@270
|
390 val toCorify = transform corify "corify" o toExplify
|
adamc@201
|
391
|
adamc@202
|
392 val shake = {
|
adamc@202
|
393 func = Shake.shake,
|
adamc@202
|
394 print = CorePrint.p_file CoreEnv.empty
|
adamc@202
|
395 }
|
adamc@39
|
396
|
adamc@270
|
397 val toShake1 = transform shake "shake1" o toCorify
|
adamc@110
|
398
|
adamc@202
|
399 val tag = {
|
adamc@202
|
400 func = Tag.tag,
|
adamc@202
|
401 print = CorePrint.p_file CoreEnv.empty
|
adamc@202
|
402 }
|
adamc@193
|
403
|
adamc@270
|
404 val toTag = transform tag "tag" o toShake1
|
adamc@20
|
405
|
adamc@202
|
406 val reduce = {
|
adamc@202
|
407 func = Reduce.reduce,
|
adamc@202
|
408 print = CorePrint.p_file CoreEnv.empty
|
adamc@202
|
409 }
|
adamc@25
|
410
|
adamc@270
|
411 val toReduce = transform reduce "reduce" o toTag
|
adamc@23
|
412
|
adamc@315
|
413 val unpoly = {
|
adamc@315
|
414 func = Unpoly.unpoly,
|
adamc@315
|
415 print = CorePrint.p_file CoreEnv.empty
|
adamc@315
|
416 }
|
adamc@315
|
417
|
adamc@315
|
418 val toUnpoly = transform unpoly "unpoly" o toReduce
|
adamc@315
|
419
|
adamc@202
|
420 val specialize = {
|
adamc@202
|
421 func = Specialize.specialize,
|
adamc@202
|
422 print = CorePrint.p_file CoreEnv.empty
|
adamc@202
|
423 }
|
adamc@132
|
424
|
adamc@315
|
425 val toSpecialize = transform specialize "specialize" o toUnpoly
|
adamc@131
|
426
|
adamc@270
|
427 val toShake2 = transform shake "shake2" o toSpecialize
|
adamc@133
|
428
|
adamc@202
|
429 val monoize = {
|
adamc@202
|
430 func = Monoize.monoize CoreEnv.empty,
|
adamc@202
|
431 print = MonoPrint.p_file MonoEnv.empty
|
adamc@202
|
432 }
|
adamc@134
|
433
|
adamc@270
|
434 val toMonoize = transform monoize "monoize" o toShake2
|
adamc@96
|
435
|
adamc@202
|
436 val mono_opt = {
|
adamc@202
|
437 func = MonoOpt.optimize,
|
adamc@202
|
438 print = MonoPrint.p_file MonoEnv.empty
|
adamc@202
|
439 }
|
adamc@29
|
440
|
adamc@270
|
441 val toMono_opt1 = transform mono_opt "mono_opt1" o toMonoize
|
adamc@5
|
442
|
adamc@202
|
443 val untangle = {
|
adamc@202
|
444 func = Untangle.untangle,
|
adamc@202
|
445 print = MonoPrint.p_file MonoEnv.empty
|
adamc@202
|
446 }
|
adamc@1
|
447
|
adamc@270
|
448 val toUntangle = transform untangle "untangle" o toMono_opt1
|
adamc@38
|
449
|
adamc@202
|
450 val mono_reduce = {
|
adamc@202
|
451 func = MonoReduce.reduce,
|
adamc@202
|
452 print = MonoPrint.p_file MonoEnv.empty
|
adamc@202
|
453 }
|
adamc@16
|
454
|
adamc@270
|
455 val toMono_reduce = transform mono_reduce "mono_reduce" o toUntangle
|
adamc@39
|
456
|
adamc@202
|
457 val mono_shake = {
|
adamc@202
|
458 func = MonoShake.shake,
|
adamc@202
|
459 print = MonoPrint.p_file MonoEnv.empty
|
adamc@202
|
460 }
|
adamc@110
|
461
|
adamc@270
|
462 val toMono_shake = transform mono_shake "mono_shake1" o toMono_reduce
|
adamc@193
|
463
|
adamc@270
|
464 val toMono_opt2 = transform mono_opt "mono_opt2" o toMono_shake
|
adamc@20
|
465
|
adamc@202
|
466 val cjrize = {
|
adamc@202
|
467 func = Cjrize.cjrize,
|
adamc@202
|
468 print = CjrPrint.p_file CjrEnv.empty
|
adamc@202
|
469 }
|
adamc@23
|
470
|
adamc@270
|
471 val toCjrize = transform cjrize "cjrize" o toMono_opt2
|
adamc@29
|
472
|
adamc@282
|
473 val prepare = {
|
adamc@282
|
474 func = Prepare.prepare,
|
adamc@282
|
475 print = CjrPrint.p_file CjrEnv.empty
|
adamc@282
|
476 }
|
adamc@282
|
477
|
adamc@282
|
478 val toPrepare = transform prepare "prepare" o toCjrize
|
adamc@282
|
479
|
adamc@274
|
480 val sqlify = {
|
adamc@274
|
481 func = Cjrize.cjrize,
|
adamc@274
|
482 print = CjrPrint.p_sql CjrEnv.empty
|
adamc@274
|
483 }
|
adamc@274
|
484
|
adamc@274
|
485 val toSqlify = transform sqlify "sqlify" o toMono_opt2
|
adamc@274
|
486
|
adamc@183
|
487 fun compileC {cname, oname, ename} =
|
adamc@183
|
488 let
|
adamc@317
|
489 val compile = "gcc -Wstrict-prototypes -Werror -O3 -I include -c " ^ cname ^ " -o " ^ oname
|
adamc@317
|
490 val link = "gcc -Werror -O3 -pthread -lpq clib/urweb.o " ^ oname ^ " clib/driver.o -o " ^ ename
|
adamc@183
|
491 in
|
adamc@183
|
492 if not (OS.Process.isSuccess (OS.Process.system compile)) then
|
adamc@183
|
493 print "C compilation failed\n"
|
adamc@183
|
494 else if not (OS.Process.isSuccess (OS.Process.system link)) then
|
adamc@186
|
495 print "C linking failed\n"
|
adamc@183
|
496 else
|
adamc@183
|
497 print "Success\n"
|
adamc@183
|
498 end
|
adamc@183
|
499
|
adamc@202
|
500 fun compile job =
|
adamc@282
|
501 case run toPrepare job of
|
adamc@244
|
502 NONE => print "Ur compilation failed\n"
|
adamc@29
|
503 | SOME file =>
|
adamc@202
|
504 let
|
adamc@274
|
505 val job = valOf (run (transform parseUrp "parseUrp") job)
|
adamc@102
|
506
|
adamc@274
|
507 val (cname, oname, cleanup) =
|
adamc@274
|
508 if #debug job then
|
adamc@274
|
509 ("/tmp/urweb.c", "/tmp/urweb.o", fn () => ())
|
adamc@274
|
510 else
|
adamc@274
|
511 let
|
adamc@274
|
512 val dir = OS.FileSys.tmpName ()
|
adamc@274
|
513 val cname = OS.Path.joinDirFile {dir = dir, file = "urweb.c"}
|
adamc@274
|
514 val oname = OS.Path.joinDirFile {dir = dir, file = "urweb.o"}
|
adamc@274
|
515 in
|
adamc@274
|
516 OS.FileSys.mkDir dir;
|
adamc@274
|
517 (cname, oname,
|
adamc@274
|
518 fn () => (OS.FileSys.remove cname;
|
adamc@274
|
519 OS.FileSys.remove oname;
|
adamc@274
|
520 OS.FileSys.rmDir dir))
|
adamc@274
|
521 end
|
adamc@274
|
522 val ename = #exe job
|
adamc@202
|
523 in
|
adamc@274
|
524 let
|
adamc@274
|
525 val outf = TextIO.openOut cname
|
adamc@274
|
526 val s = TextIOPP.openOut {dst = outf, wid = 80}
|
adamc@274
|
527 in
|
adamc@274
|
528 Print.fprint s (CjrPrint.p_file CjrEnv.empty file);
|
adamc@274
|
529 TextIO.closeOut outf;
|
adamc@102
|
530
|
adamc@274
|
531 case #sql job of
|
adamc@274
|
532 NONE => ()
|
adamc@274
|
533 | SOME sql =>
|
adamc@274
|
534 let
|
adamc@274
|
535 val outf = TextIO.openOut sql
|
adamc@274
|
536 val s = TextIOPP.openOut {dst = outf, wid = 80}
|
adamc@274
|
537 in
|
adamc@274
|
538 Print.fprint s (CjrPrint.p_sql CjrEnv.empty file);
|
adamc@274
|
539 TextIO.closeOut outf
|
adamc@274
|
540 end;
|
adamc@274
|
541
|
adamc@274
|
542 compileC {cname = cname, oname = oname, ename = ename};
|
adamc@274
|
543
|
adamc@274
|
544 cleanup ()
|
adamc@274
|
545 end
|
adamc@274
|
546 handle ex => (((cleanup ()) handle _ => ()); raise ex)
|
adamc@202
|
547 end
|
adamc@29
|
548
|
adamc@1
|
549 end
|