adamc@1: (* Copyright (c) 2008, Adam Chlipala adamc@1: * All rights reserved. adamc@1: * adamc@1: * Redistribution and use in source and binary forms, with or without adamc@1: * modification, are permitted provided that the following conditions are met: adamc@1: * adamc@1: * - Redistributions of source code must retain the above copyright notice, adamc@1: * this list of conditions and the following disclaimer. adamc@1: * - Redistributions in binary form must reproduce the above copyright notice, adamc@1: * this list of conditions and the following disclaimer in the documentation adamc@1: * and/or other materials provided with the distribution. adamc@1: * - The names of contributors may not be used to endorse or promote products adamc@1: * derived from this software without specific prior written permission. adamc@1: * adamc@1: * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" adamc@1: * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE adamc@1: * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE adamc@1: * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE adamc@1: * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR adamc@1: * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF adamc@1: * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS adamc@1: * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN adamc@1: * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) adamc@1: * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE adamc@1: * POSSIBILITY OF SUCH DAMAGE. adamc@1: *) adamc@1: adamc@244: (* Ur/Web language parser *) adamc@1: adamc@1: structure Compiler :> COMPILER = struct adamc@1: adamc@244: structure UrwebLrVals = UrwebLrValsFn(structure Token = LrParser.Token) adamc@244: structure Lex = UrwebLexFn(structure Tokens = UrwebLrVals.Tokens) adamc@244: structure UrwebP = Join(structure ParserData = UrwebLrVals.ParserData adamc@1: structure Lex = Lex adamc@1: structure LrParser = LrParser) adamc@1: adamc@270: type job = { adamc@270: database : string option, adamc@270: sources : string list adamc@270: } adamc@201: adamc@201: type ('src, 'dst) phase = { adamc@201: func : 'src -> 'dst, adamc@201: print : 'dst -> Print.PD.pp_desc adamc@201: } adamc@201: adamc@201: type pmap = (string * Time.time) list adamc@201: adamc@201: type ('src, 'dst) transform = { adamc@201: func : 'src -> 'dst option, adamc@201: print : 'dst -> Print.PD.pp_desc, adamc@201: time : 'src * pmap -> 'dst option * pmap adamc@201: } adamc@201: adamc@201: fun transform (ph : ('src, 'dst) phase) name = { adamc@201: func = fn input => let adamc@201: val v = #func ph input adamc@201: in adamc@201: if ErrorMsg.anyErrors () then adamc@201: NONE adamc@201: else adamc@201: SOME v adamc@201: end, adamc@201: print = #print ph, adamc@201: time = fn (input, pmap) => let adamc@201: val befor = Time.now () adamc@201: val v = #func ph input adamc@201: val elapsed = Time.- (Time.now (), befor) adamc@201: in adamc@201: (if ErrorMsg.anyErrors () then adamc@201: NONE adamc@201: else adamc@201: SOME v, adamc@201: (name, elapsed) :: pmap) adamc@201: end adamc@201: } adamc@201: adamc@270: fun op o (tr2 : ('b, 'c) transform, tr1 : ('a, 'b) transform) = { adamc@201: func = fn input => case #func tr1 input of adamc@201: NONE => NONE adamc@201: | SOME v => #func tr2 v, adamc@201: print = #print tr2, adamc@201: time = fn (input, pmap) => let adamc@201: val (ro, pmap) = #time tr1 (input, pmap) adamc@201: in adamc@201: case ro of adamc@201: NONE => (NONE, pmap) adamc@201: | SOME v => #time tr2 (v, pmap) adamc@201: end adamc@201: } adamc@201: adamc@201: fun run (tr : ('src, 'dst) transform) = #func tr adamc@201: adamc@201: fun runPrint (tr : ('src, 'dst) transform) input = adamc@201: case #func tr input of adamc@201: NONE => print "Failure\n" adamc@201: | SOME v => adamc@201: (print "Success\n"; adamc@201: Print.print (#print tr v); adamc@201: print "\n") adamc@201: adamc@201: fun time (tr : ('src, 'dst) transform) input = adamc@55: let adamc@201: val (_, pmap) = #time tr (input, []) adamc@201: in adamc@201: app (fn (name, time) => adamc@201: print (name ^ ": " ^ LargeReal.toString (Time.toReal time) ^ "\n")) (rev pmap); adamc@201: print ("TOTAL: " ^ LargeReal.toString (Time.toReal (foldl Time.+ Time.zeroTime (map #2 pmap))) ^ "\n"); adamc@201: print "\n" adamc@201: end adamc@55: adamc@201: fun timePrint (tr : ('src, 'dst) transform) input = adamc@201: let adamc@201: val (ro, pmap) = #time tr (input, []) adamc@55: in adamc@201: app (fn (name, time) => adamc@201: print (name ^ ": " ^ LargeReal.toString (Time.toReal time) ^ "\n")) (rev pmap); adamc@201: print ("TOTAL: " ^ LargeReal.toString (Time.toReal (foldl Time.+ Time.zeroTime (map #2 pmap))) ^ "\n"); adamc@201: print "\n"; adamc@201: case ro of adamc@201: NONE => print "Failure\n" adamc@201: | SOME v => adamc@201: (print "Success\n"; adamc@201: Print.print (#print tr v); adamc@201: print "\n") adamc@55: end adamc@55: adamc@244: val parseUrs = adamc@201: {func = fn filename => let adamc@201: val fname = OS.FileSys.tmpName () adamc@201: val outf = TextIO.openOut fname adamc@201: val () = TextIO.output (outf, "sig\n") adamc@201: val inf = TextIO.openIn filename adamc@201: fun loop () = adamc@201: case TextIO.inputLine inf of adamc@201: NONE => () adamc@201: | SOME line => (TextIO.output (outf, line); adamc@201: loop ()) adamc@201: val () = loop () adamc@201: val () = TextIO.closeIn inf adamc@201: val () = TextIO.closeOut outf adamc@201: adamc@201: val () = (ErrorMsg.resetErrors (); adamc@201: ErrorMsg.resetPositioning filename; adamc@201: Lex.UserDeclarations.initialize ()) adamc@201: val file = TextIO.openIn fname adamc@201: fun get _ = TextIO.input file adamc@201: fun parseerror (s, p1, p2) = ErrorMsg.errorAt' (p1, p2) s adamc@201: val lexer = LrParser.Stream.streamify (Lex.makeLexer get) adamc@244: val (absyn, _) = UrwebP.parse (30, lexer, parseerror, ()) adamc@201: in adamc@201: TextIO.closeIn file; adamc@201: case absyn of adamc@201: [(Source.DSgn ("?", (Source.SgnConst sgis, _)), _)] => sgis adamc@201: | _ => (ErrorMsg.errorAt {file = filename, adamc@201: first = {line = 0, adamc@201: char = 0}, adamc@201: last = {line = 0, adamc@201: char = 0}} "Not a signature"; adamc@201: []) adamc@201: end adamc@201: handle LrParser.ParseError => [], adamc@201: print = Print.p_list_sep Print.PD.newline SourcePrint.p_sgn_item} adamc@55: adamc@1: (* The main parsing routine *) adamc@244: val parseUr = { adamc@201: func = fn filename => adamc@201: let adamc@201: val () = (ErrorMsg.resetErrors (); adamc@201: ErrorMsg.resetPositioning filename; adamc@201: Lex.UserDeclarations.initialize ()) adamc@201: val file = TextIO.openIn filename adamc@201: fun get _ = TextIO.input file adamc@201: fun parseerror (s, p1, p2) = ErrorMsg.errorAt' (p1, p2) s adamc@201: val lexer = LrParser.Stream.streamify (Lex.makeLexer get) adamc@244: val (absyn, _) = UrwebP.parse (30, lexer, parseerror, ()) adamc@201: in adamc@201: TextIO.closeIn file; adamc@201: case absyn of adamc@201: [(Source.DSgn ("?", _), _)] => adamc@201: (ErrorMsg.errorAt {file = filename, adamc@201: first = {line = 0, adamc@201: char = 0}, adamc@201: last = {line = 0, adamc@201: char = 0}} "File starts with 'sig'"; adamc@201: []) adamc@201: | _ => absyn adamc@201: end adamc@201: handle LrParser.ParseError => [], adamc@201: print = SourcePrint.p_file} adamc@56: adamc@270: fun p_job {database, sources} = adamc@270: let adamc@270: open Print.PD adamc@270: open Print adamc@270: in adamc@270: box [case database of adamc@270: NONE => string "No database." adamc@270: | SOME db => string ("Database: " ^ db), adamc@270: newline, adamc@270: string "Sources:", adamc@270: p_list string sources, adamc@270: newline] adamc@270: end adamc@270: adamc@270: fun trim s = adamc@270: let adamc@270: val (_, s) = Substring.splitl Char.isSpace s adamc@270: val (s, _) = Substring.splitr Char.isSpace s adamc@270: in adamc@270: s adamc@270: end adamc@270: adamc@270: val parseUrp = { adamc@270: func = fn filename => adamc@270: let adamc@270: val dir = OS.Path.dir filename adamc@270: val inf = TextIO.openIn (OS.Path.joinBaseExt {base = filename, ext = SOME "urp"}) adamc@270: adamc@270: fun readSources acc = adamc@270: case TextIO.inputLine inf of adamc@270: NONE => rev acc adamc@270: | SOME line => adamc@270: let adamc@270: val acc = if CharVector.all Char.isSpace line then adamc@270: acc adamc@270: else adamc@270: let adamc@270: val fname = String.implode (List.filter (fn x => not (Char.isSpace x)) adamc@270: (String.explode line)) adamc@270: val fname = OS.Path.concat (dir, fname) adamc@271: handle OS.Path.Path => fname adamc@270: in adamc@270: fname :: acc adamc@270: end adamc@270: in adamc@270: readSources acc adamc@270: end adamc@270: adamc@270: fun read database = adamc@270: case TextIO.inputLine inf of adamc@270: NONE => {database = database, sources = []} adamc@270: | SOME "\n" => {database = database, sources = readSources []} adamc@270: | SOME line => adamc@270: let adamc@270: val (cmd, arg) = Substring.splitl (fn x => not (Char.isSpace x)) (Substring.full line) adamc@270: val cmd = Substring.string (trim cmd) adamc@270: val arg = Substring.string (trim arg) adamc@270: in adamc@270: case cmd of adamc@270: "database" => adamc@270: (case database of adamc@270: NONE => () adamc@270: | SOME _ => ErrorMsg.error "Duplicate 'database' directive"; adamc@270: read (SOME arg)) adamc@270: | _ => (ErrorMsg.error ("Unrecognized command '" ^ cmd ^ "'"); adamc@270: read database) adamc@270: end adamc@270: in adamc@270: read NONE adamc@270: before TextIO.closeIn inf adamc@270: end, adamc@270: print = p_job adamc@270: } adamc@270: adamc@270: val toParseJob = transform parseUrp "parseJob" adamc@270: adamc@56: fun capitalize "" = "" adamc@56: | capitalize s = str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE) adamc@56: adamc@201: val parse = { adamc@270: func = fn {database, sources = fnames} => adamc@201: let adamc@201: fun nameOf fname = capitalize (OS.Path.file fname) adamc@109: adamc@201: fun parseOne fname = adamc@201: let adamc@201: val mname = nameOf fname adamc@244: val ur = OS.Path.joinBaseExt {base = fname, ext = SOME "ur"} adamc@244: val urs = OS.Path.joinBaseExt {base = fname, ext = SOME "urs"} adamc@56: adamc@201: val sgnO = adamc@244: if Posix.FileSys.access (urs, []) then adamc@244: SOME (Source.SgnConst (#func parseUrs urs), adamc@244: {file = urs, adamc@201: first = ErrorMsg.dummyPos, adamc@201: last = ErrorMsg.dummyPos}) adamc@201: else adamc@201: NONE adamc@56: adamc@244: val loc = {file = ur, adamc@201: first = ErrorMsg.dummyPos, adamc@201: last = ErrorMsg.dummyPos} adamc@56: adamc@244: val ds = #func parseUr ur adamc@201: in adamc@201: (Source.DStr (mname, sgnO, (Source.StrConst ds, loc)), loc) adamc@201: end adamc@56: adamc@201: val ds = map parseOne fnames adamc@201: in adamc@201: let adamc@201: val final = nameOf (List.last fnames) adamc@271: adamc@271: val ds = ds @ [(Source.DExport (Source.StrVar final, ErrorMsg.dummySpan), ErrorMsg.dummySpan)] adamc@201: in adamc@271: case database of adamc@271: NONE => ds adamc@271: | SOME s => (Source.DDatabase s, ErrorMsg.dummySpan) :: ds adamc@201: end handle Empty => ds adamc@201: end, adamc@201: print = SourcePrint.p_file adamc@201: } adamc@56: adamc@270: val toParse = transform parse "parse" o toParseJob adamc@38: adamc@201: val elaborate = { adamc@201: func = fn file => let adamc@244: val basis = #func parseUrs "lib/basis.urs" adamc@201: in adamc@201: Elaborate.elabFile basis ElabEnv.empty file adamc@201: end, adamc@201: print = ElabPrint.p_file ElabEnv.empty adamc@201: } adamc@5: adamc@270: val toElaborate = transform elaborate "elaborate" o toParse adamc@201: adamc@201: val explify = { adamc@201: func = Explify.explify, adamc@201: print = ExplPrint.p_file ExplEnv.empty adamc@201: } adamc@201: adamc@270: val toExplify = transform explify "explify" o toElaborate adamc@201: adamc@201: val corify = { adamc@201: func = Corify.corify, adamc@201: print = CorePrint.p_file CoreEnv.empty adamc@201: } adamc@201: adamc@270: val toCorify = transform corify "corify" o toExplify adamc@201: adamc@202: val shake = { adamc@202: func = Shake.shake, adamc@202: print = CorePrint.p_file CoreEnv.empty adamc@202: } adamc@39: adamc@270: val toShake1 = transform shake "shake1" o toCorify adamc@110: adamc@202: val tag = { adamc@202: func = Tag.tag, adamc@202: print = CorePrint.p_file CoreEnv.empty adamc@202: } adamc@193: adamc@270: val toTag = transform tag "tag" o toShake1 adamc@20: adamc@202: val reduce = { adamc@202: func = Reduce.reduce, adamc@202: print = CorePrint.p_file CoreEnv.empty adamc@202: } adamc@25: adamc@270: val toReduce = transform reduce "reduce" o toTag adamc@23: adamc@202: val specialize = { adamc@202: func = Specialize.specialize, adamc@202: print = CorePrint.p_file CoreEnv.empty adamc@202: } adamc@132: adamc@270: val toSpecialize = transform specialize "specialize" o toReduce adamc@131: adamc@270: val toShake2 = transform shake "shake2" o toSpecialize adamc@133: adamc@202: val monoize = { adamc@202: func = Monoize.monoize CoreEnv.empty, adamc@202: print = MonoPrint.p_file MonoEnv.empty adamc@202: } adamc@134: adamc@270: val toMonoize = transform monoize "monoize" o toShake2 adamc@96: adamc@202: val mono_opt = { adamc@202: func = MonoOpt.optimize, adamc@202: print = MonoPrint.p_file MonoEnv.empty adamc@202: } adamc@29: adamc@270: val toMono_opt1 = transform mono_opt "mono_opt1" o toMonoize adamc@5: adamc@202: val untangle = { adamc@202: func = Untangle.untangle, adamc@202: print = MonoPrint.p_file MonoEnv.empty adamc@202: } adamc@1: adamc@270: val toUntangle = transform untangle "untangle" o toMono_opt1 adamc@38: adamc@202: val mono_reduce = { adamc@202: func = MonoReduce.reduce, adamc@202: print = MonoPrint.p_file MonoEnv.empty adamc@202: } adamc@16: adamc@270: val toMono_reduce = transform mono_reduce "mono_reduce" o toUntangle adamc@39: adamc@202: val mono_shake = { adamc@202: func = MonoShake.shake, adamc@202: print = MonoPrint.p_file MonoEnv.empty adamc@202: } adamc@110: adamc@270: val toMono_shake = transform mono_shake "mono_shake1" o toMono_reduce adamc@193: adamc@270: val toMono_opt2 = transform mono_opt "mono_opt2" o toMono_shake adamc@20: adamc@202: val cjrize = { adamc@202: func = Cjrize.cjrize, adamc@202: print = CjrPrint.p_file CjrEnv.empty adamc@202: } adamc@23: adamc@270: val toCjrize = transform cjrize "cjrize" o toMono_opt2 adamc@29: adamc@183: fun compileC {cname, oname, ename} = adamc@183: let adamc@183: val compile = "gcc -O3 -I include -c " ^ cname ^ " -o " ^ oname adamc@244: val link = "gcc -pthread -O3 clib/urweb.o " ^ oname ^ " clib/driver.o -o " ^ ename adamc@183: in adamc@183: if not (OS.Process.isSuccess (OS.Process.system compile)) then adamc@183: print "C compilation failed\n" adamc@183: else if not (OS.Process.isSuccess (OS.Process.system link)) then adamc@186: print "C linking failed\n" adamc@183: else adamc@183: print "Success\n" adamc@183: end adamc@183: adamc@202: fun compile job = adamc@202: case run toCjrize job of adamc@244: NONE => print "Ur compilation failed\n" adamc@29: | SOME file => adamc@202: let adamc@244: val cname = "/tmp/urweb.c" adamc@244: val oname = "/tmp/urweb.o" adamc@202: val ename = "/tmp/webapp" adamc@102: adamc@202: val outf = TextIO.openOut cname adamc@202: val s = TextIOPP.openOut {dst = outf, wid = 80} adamc@202: in adamc@202: Print.fprint s (CjrPrint.p_file CjrEnv.empty file); adamc@202: TextIO.closeOut outf; adamc@102: adamc@202: compileC {cname = cname, oname = oname, ename = ename} adamc@202: end adamc@29: adamc@1: end