(* Copyright (c) 2008-2010, Adam Chlipala * All rights reserved. * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions are met: * * - Redistributions of source code must retain the above copyright notice, * this list of conditions and the following disclaimer. * - Redistributions in binary form must reproduce the above copyright notice, * this list of conditions and the following disclaimer in the documentation * and/or other materials provided with the distribution. * - The names of contributors may not be used to endorse or promote products * derived from this software without specific prior written permission. * * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE * POSSIBILITY OF SUCH DAMAGE. *) structure Compiler :> COMPILER = struct structure UrwebLrVals = UrwebLrValsFn(structure Token = LrParser.Token) structure Lex = UrwebLexFn(structure Tokens = UrwebLrVals.Tokens) structure UrwebP = Join(structure ParserData = UrwebLrVals.ParserData structure Lex = Lex structure LrParser = LrParser) type job = { prefix : string, database : string option, sources : string list, exe : string, sql : string option, debug : bool, profile : bool, timeout : int, ffi : string list, link : string list, headers : string list, scripts : string list, clientToServer : Settings.ffi list, effectful : Settings.ffi list, clientOnly : Settings.ffi list, serverOnly : Settings.ffi list, jsFuncs : (Settings.ffi * string) list, rewrites : Settings.rewrite list, filterUrl : Settings.rule list, filterMime : Settings.rule list, protocol : string option, dbms : string option } type ('src, 'dst) phase = { func : 'src -> 'dst, print : 'dst -> Print.PD.pp_desc } type pmap = (string * Time.time) list type ('src, 'dst) transform = { func : 'src -> 'dst option, print : 'dst -> Print.PD.pp_desc, time : 'src * pmap -> 'dst option * pmap } val debug = ref false fun transform (ph : ('src, 'dst) phase) name = { func = fn input => let val () = if !debug then print ("Starting " ^ name ^ "....\n") else () val v = #func ph input in if !debug then print ("Finished " ^ name ^ ".\n") else (); if ErrorMsg.anyErrors () then NONE else SOME v end, print = #print ph, time = fn (input, pmap) => let val befor = Time.now () val v = #func ph input val elapsed = Time.- (Time.now (), befor) in (if ErrorMsg.anyErrors () then NONE else SOME v, (name, elapsed) :: pmap) end } fun check (tr : ('src, 'dst) transform) x = (ErrorMsg.resetErrors (); ignore (#func tr x)) fun run (tr : ('src, 'dst) transform) x = (ErrorMsg.resetErrors (); #func tr x) fun runPrint (tr : ('src, 'dst) transform) input = (ErrorMsg.resetErrors (); case #func tr input of NONE => print "Failure\n" | SOME v => (print "Success\n"; Print.print (#print tr v); print "\n")) fun time (tr : ('src, 'dst) transform) input = let val (_, pmap) = #time tr (input, []) in app (fn (name, time) => print (name ^ ": " ^ LargeReal.toString (Time.toReal time) ^ "\n")) (rev pmap); print ("TOTAL: " ^ LargeReal.toString (Time.toReal (foldl Time.+ Time.zeroTime (map #2 pmap))) ^ "\n"); print "\n" end fun timePrint (tr : ('src, 'dst) transform) input = let val (ro, pmap) = #time tr (input, []) in app (fn (name, time) => print (name ^ ": " ^ LargeReal.toString (Time.toReal time) ^ "\n")) (rev pmap); print ("TOTAL: " ^ LargeReal.toString (Time.toReal (foldl Time.+ Time.zeroTime (map #2 pmap))) ^ "\n"); print "\n"; case ro of NONE => print "Failure\n" | SOME v => (print "Success\n"; Print.print (#print tr v); print "\n") end val parseUrs = {func = fn filename => let val fname = OS.FileSys.tmpName () val outf = TextIO.openOut fname val () = TextIO.output (outf, "sig\n") val inf = TextIO.openIn filename fun loop () = case TextIO.inputLine inf of NONE => () | SOME line => (TextIO.output (outf, line); loop ()) val () = loop () val () = TextIO.closeIn inf val () = TextIO.closeOut outf val () = (ErrorMsg.resetErrors (); ErrorMsg.resetPositioning filename; Lex.UserDeclarations.initialize ()) val file = TextIO.openIn fname fun get _ = TextIO.input file fun parseerror (s, p1, p2) = ErrorMsg.errorAt' (p1, p2) s val lexer = LrParser.Stream.streamify (Lex.makeLexer get) val (absyn, _) = UrwebP.parse (30, lexer, parseerror, ()) in TextIO.closeIn file; case absyn of [(Source.DSgn ("?", (Source.SgnConst sgis, _)), _)] => sgis | _ => (ErrorMsg.errorAt {file = filename, first = {line = 0, char = 0}, last = {line = 0, char = 0}} "Not a signature"; []) end handle LrParser.ParseError => [], print = Print.p_list_sep Print.PD.newline SourcePrint.p_sgn_item} (* The main parsing routine *) val parseUr = { func = fn filename => let val () = (ErrorMsg.resetErrors (); ErrorMsg.resetPositioning filename; Lex.UserDeclarations.initialize ()) val file = TextIO.openIn filename fun get _ = TextIO.input file fun parseerror (s, p1, p2) = ErrorMsg.errorAt' (p1, p2) s val lexer = LrParser.Stream.streamify (Lex.makeLexer get) val (absyn, _) = UrwebP.parse (30, lexer, parseerror, ()) in TextIO.closeIn file; case absyn of [(Source.DSgn ("?", _), _)] => (ErrorMsg.errorAt {file = filename, first = {line = 0, char = 0}, last = {line = 0, char = 0}} "File starts with 'sig'"; []) | _ => absyn end handle LrParser.ParseError => [], print = SourcePrint.p_file} fun p_job ({prefix, database, exe, sql, sources, debug, profile, timeout, ffi, link, headers, scripts, clientToServer, effectful, clientOnly, serverOnly, jsFuncs, ...} : job) = let open Print.PD open Print fun p_ffi name = p_list_sep (box []) (fn (m, s) => box [string name, space, string m, string ".", string s, newline]) in box [if debug then box [string "DEBUG", newline] else box [], if profile then box [string "PROFILE", newline] else box [], case database of NONE => string "No database." | SOME db => string ("Database: " ^ db), newline, string "Exe: ", string exe, newline, case sql of NONE => string "No SQL file." | SOME sql => string ("SQL fle: " ^ sql), newline, string "Timeout: ", string (Int.toString timeout), newline, p_list_sep (box []) (fn s => box [string "Ffi", space, string s, newline]) ffi, p_list_sep (box []) (fn s => box [string "Header", space, string s, newline]) headers, p_list_sep (box []) (fn s => box [string "Script", space, string s, newline]) scripts, p_list_sep (box []) (fn s => box [string "Link", space, string s, newline]) link, p_ffi "ClientToServer" clientToServer, p_ffi "Effectful" effectful, p_ffi "ClientOnly" clientOnly, p_ffi "ServerOnly" serverOnly, p_list_sep (box []) (fn ((m, s), s') => box [string "JsFunc", space, string m, string ".", string s, space, string "=", space, string s', newline]) jsFuncs, string "Sources:", p_list string sources, newline] end fun trim s = let val (_, s) = Substring.splitl Char.isSpace s val (s, _) = Substring.splitr Char.isSpace s in s end structure M = BinaryMapFn(struct type ord_key = string val compare = String.compare end) val pathmap = ref (M.insert (M.empty, "", Config.libUr)) fun addPath (k, v) = pathmap := M.insert (!pathmap, k, v) fun parseUrp' accLibs fname = let val pathmap = ref (!pathmap) val bigLibs = ref [] fun pu filename = let val dir = OS.Path.dir filename val inf = TextIO.openIn (OS.Path.joinBaseExt {base = filename, ext = SOME "urp"}) fun pathify fname = if size fname > 0 andalso String.sub (fname, 0) = #"$" then let val fname' = Substring.extract (fname, 1, NONE) val (befor, after) = Substring.splitl (fn ch => ch <> #"/") fname' in if Substring.isEmpty after then fname else case M.find (!pathmap, Substring.string befor) of NONE => fname | SOME rep => rep ^ Substring.string after end else fname fun relify fname = let val fname = pathify fname in OS.Path.concat (dir, fname) handle OS.Path.Path => fname end fun libify path = (if Posix.FileSys.access (path ^ ".urp", []) then path else path ^ "/lib") handle SysErr => path fun libify' path = (if Posix.FileSys.access (relify path ^ ".urp", []) then path else path ^ "/lib") handle SysErr => path val absDir = OS.Path.mkAbsolute {path = dir, relativeTo = OS.FileSys.getDir ()} fun relifyA fname = OS.Path.mkAbsolute {path = pathify fname, relativeTo = absDir} fun readSources acc = case TextIO.inputLine inf of NONE => rev acc | SOME line => let val acc = if CharVector.all Char.isSpace line then acc else let val fname = String.implode (List.filter (fn x => not (Char.isSpace x)) (String.explode line)) val fname = relifyA fname in fname :: acc end in readSources acc end val prefix = ref NONE val database = ref (Settings.getDbstring ()) val exe = ref (Settings.getExe ()) val sql = ref (Settings.getSql ()) val debug = ref (Settings.getDebug ()) val profile = ref false val timeout = ref NONE val ffi = ref [] val link = ref [] val headers = ref [] val scripts = ref [] val clientToServer = ref [] val effectful = ref [] val clientOnly = ref [] val serverOnly = ref [] val jsFuncs = ref [] val rewrites = ref [] val url = ref [] val mime = ref [] val libs = ref [] val protocol = ref NONE val dbms = ref NONE fun finish sources = let val job = { prefix = Option.getOpt (!prefix, "/"), database = !database, exe = Option.getOpt (!exe, OS.Path.joinBaseExt {base = OS.Path.base filename, ext = SOME "exe"}), sql = !sql, debug = !debug, profile = !profile, timeout = Option.getOpt (!timeout, 60), ffi = rev (!ffi), link = rev (!link), headers = rev (!headers), scripts = rev (!scripts), clientToServer = rev (!clientToServer), effectful = rev (!effectful), clientOnly = rev (!clientOnly), serverOnly = rev (!serverOnly), jsFuncs = rev (!jsFuncs), rewrites = rev (!rewrites), filterUrl = rev (!url), filterMime = rev (!mime), sources = sources, protocol = !protocol, dbms = !dbms } fun mergeO f (old, new) = case (old, new) of (NONE, _) => new | (_, NONE) => old | (SOME v1, SOME v2) => SOME (f (v1, v2)) fun same desc = mergeO (fn (x : string, y) => (if x = y then () else ErrorMsg.error ("Multiple " ^ desc ^ " values that don't agree"); x)) fun merge (old : job, new : job) = { prefix = #prefix old, database = mergeO (fn (old, _) => old) (#database old, #database new), exe = #exe old, sql = #sql old, debug = #debug old orelse #debug new, profile = #profile old orelse #profile new, timeout = #timeout old, ffi = #ffi old @ #ffi new, link = #link old @ #link new, headers = #headers old @ #headers new, scripts = #scripts old @ #scripts new, clientToServer = #clientToServer old @ #clientToServer new, effectful = #effectful old @ #effectful new, clientOnly = #clientOnly old @ #clientOnly new, serverOnly = #serverOnly old @ #serverOnly new, jsFuncs = #jsFuncs old @ #jsFuncs new, rewrites = #rewrites old @ #rewrites new, filterUrl = #filterUrl old @ #filterUrl new, filterMime = #filterMime old @ #filterMime new, sources = #sources new @ List.filter (fn s => List.all (fn s' => s' <> s) (#sources new)) (#sources old), protocol = mergeO #2 (#protocol old, #protocol new), dbms = mergeO #2 (#dbms old, #dbms new) } in if accLibs then foldr (fn (job', job) => merge (job, job')) job (!libs) else job end fun parsePkind s = case s of "all" => Settings.Any | "url" => Settings.Url | "table" => Settings.Table | "sequence" => Settings.Sequence | "view" => Settings.View | "relation" => Settings.Relation | "cookie" => Settings.Cookie | "style" => Settings.Style | _ => (ErrorMsg.error "Bad path kind spec"; Settings.Any) fun parseFrom s = if size s > 1 andalso String.sub (s, size s - 2) = #"/" andalso String.sub (s, size s - 1) = #"*" then (Settings.Prefix, String.substring (s, 0, size s - 1)) else (Settings.Exact, s) fun parseFkind s = case s of "url" => url | "mime" => mime | _ => (ErrorMsg.error "Bad filter kind"; url) fun parsePattern s = if size s > 0 andalso String.sub (s, size s - 1) = #"*" then (Settings.Prefix, String.substring (s, 0, size s - 1)) else (Settings.Exact, s) fun read () = case TextIO.inputLine inf of NONE => finish [] | SOME "\n" => finish (readSources []) | SOME line => let val (cmd, arg) = Substring.splitl (fn x => not (Char.isSpace x)) (Substring.full line) val cmd = Substring.string (trim cmd) val arg = Substring.string (trim arg) fun ffiS () = case String.fields (fn ch => ch = #".") arg of [m, x] => (m, x) | _ => (ErrorMsg.error (cmd ^ " argument not of the form Module.func"); ("", "")) fun ffiM () = case String.fields (fn ch => ch = #"=") arg of [f, s] => (case String.fields (fn ch => ch = #".") f of [m, x] => ((m, x), s) | _ => (ErrorMsg.error (cmd ^ " argument not of the form Module.func=func'"); (("", ""), ""))) | _ => (ErrorMsg.error (cmd ^ " argument not of the form Module.func=func'"); (("", ""), "")) in case cmd of "prefix" => (case !prefix of NONE => () | SOME _ => ErrorMsg.error "Duplicate 'prefix' directive"; prefix := SOME arg) | "database" => (case !database of NONE => database := SOME arg | SOME _ => ()) | "exe" => (case !exe of NONE => exe := SOME (relify arg) | SOME _ => ()) | "sql" => (case !sql of NONE => sql := SOME (relify arg) | SOME _ => ()) | "debug" => debug := true | "profile" => profile := true | "timeout" => (case !timeout of NONE => () | SOME _ => ErrorMsg.error "Duplicate 'timeout' directive"; timeout := SOME (valOf (Int.fromString arg))) | "ffi" => ffi := relify arg :: !ffi | "link" => let val arg = if size arg >= 1 andalso String.sub (arg, 0) = #"-" then arg else relifyA arg in link := arg :: !link end | "include" => headers := relifyA arg :: !headers | "script" => scripts := arg :: !scripts | "clientToServer" => clientToServer := ffiS () :: !clientToServer | "effectful" => effectful := ffiS () :: !effectful | "clientOnly" => clientOnly := ffiS () :: !clientOnly | "serverOnly" => serverOnly := ffiS () :: !serverOnly | "jsFunc" => jsFuncs := ffiM () :: !jsFuncs | "rewrite" => let fun doit (pkind, from, to) = let val pkind = parsePkind pkind val (kind, from) = parseFrom from in rewrites := {pkind = pkind, kind = kind, from = from, to = to} :: !rewrites end in case String.tokens Char.isSpace arg of [pkind, from, to] => doit (pkind, from, to) | [pkind, from] => doit (pkind, from, "") | _ => ErrorMsg.error "Bad 'rewrite' syntax" end | "allow" => (case String.tokens Char.isSpace arg of [fkind, pattern] => let val fkind = parseFkind fkind val (kind, pattern) = parsePattern pattern in fkind := {action = Settings.Allow, kind = kind, pattern = pattern} :: !fkind end | _ => ErrorMsg.error "Bad 'allow' syntax") | "deny" => (case String.tokens Char.isSpace arg of [fkind, pattern] => let val fkind = parseFkind fkind val (kind, pattern) = parsePattern pattern in fkind := {action = Settings.Deny, kind = kind, pattern = pattern} :: !fkind end | _ => ErrorMsg.error "Bad 'deny' syntax") | "library" => if accLibs then libs := pu (libify (relify arg)) :: !libs else bigLibs := libify' arg :: !bigLibs | "path" => (case String.fields (fn ch => ch = #"=") arg of [n, v] => pathmap := M.insert (!pathmap, n, v) | _ => ErrorMsg.error "path argument not of the form name=value'") | _ => ErrorMsg.error ("Unrecognized command '" ^ cmd ^ "'"); read () end val job = read () in TextIO.closeIn inf; Settings.setUrlPrefix (#prefix job); Settings.setTimeout (#timeout job); Settings.setHeaders (#headers job); Settings.setScripts (#scripts job); Settings.setClientToServer (#clientToServer job); Settings.setEffectful (#effectful job); Settings.setClientOnly (#clientOnly job); Settings.setServerOnly (#serverOnly job); Settings.setJsFuncs (#jsFuncs job); Settings.setRewriteRules (#rewrites job); Settings.setUrlRules (#filterUrl job); Settings.setMimeRules (#filterMime job); Option.app Settings.setProtocol (#protocol job); Option.app Settings.setDbms (#dbms job); job end in {Job = pu fname, Libs = !bigLibs} end fun p_job' {Job = j, Libs = _ : string list} = p_job j val parseUrp = { func = #Job o parseUrp' true, print = p_job } val parseUrp' = { func = parseUrp' false, print = p_job' } val toParseJob = transform parseUrp "parseJob" val toParseJob' = transform parseUrp' "parseJob'" fun op o (tr2 : ('b, 'c) transform, tr1 : ('a, 'b) transform) = { func = fn input => case #func tr1 input of NONE => NONE | SOME v => #func tr2 v, print = #print tr2, time = fn (input, pmap) => let val (ro, pmap) = #time tr1 (input, pmap) in case ro of NONE => (NONE, pmap) | SOME v => #time tr2 (v, pmap) end } fun capitalize "" = "" | capitalize s = str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE) structure SM = BinaryMapFn(struct type ord_key = string val compare = String.compare end) val moduleRoots = ref ([] : (string * string) list) fun addModuleRoot (k, v) = moduleRoots := (k, v) :: !moduleRoots structure SS = BinarySetFn(struct type ord_key = string val compare = String.compare end) val parse = { func = fn {database, sources = fnames, ffi, ...} : job => let val mrs = !moduleRoots val anyErrors = ref false fun checkErrors () = anyErrors := (!anyErrors orelse ErrorMsg.anyErrors ()) fun nameOf fname = capitalize (OS.Path.file fname) fun parseFfi fname = let val mname = nameOf fname val urs = OS.Path.joinBaseExt {base = fname, ext = SOME "urs"} val loc = {file = urs, first = ErrorMsg.dummyPos, last = ErrorMsg.dummyPos} val sgn = (Source.SgnConst (#func parseUrs urs), loc) in checkErrors (); (Source.DFfiStr (mname, sgn), loc) end val defed = ref SS.empty val fulls = ref SS.empty fun parseOne fname = let val mname = nameOf fname val ur = OS.Path.joinBaseExt {base = fname, ext = SOME "ur"} val urs = OS.Path.joinBaseExt {base = fname, ext = SOME "urs"} val sgnO = if Posix.FileSys.access (urs, []) then SOME (Source.SgnConst (#func parseUrs urs), {file = urs, first = ErrorMsg.dummyPos, last = ErrorMsg.dummyPos}) before checkErrors () else NONE val loc = {file = ur, first = ErrorMsg.dummyPos, last = ErrorMsg.dummyPos} val ds = #func parseUr ur val d = (Source.DStr (mname, sgnO, (Source.StrConst ds, loc)), loc) val fname = OS.Path.mkCanonical fname val d = case List.find (fn (root, name) => String.isPrefix (root ^ "/") fname) mrs of NONE => d | SOME (root, name) => let val fname = String.extract (fname, size root + 1, NONE) val pieces = name :: String.tokens (fn ch => ch = #"/") fname val pieces = List.filter (fn s => size s > 0 andalso Char.isAlpha (String.sub (s, 0))) pieces val pieces = map capitalize pieces val full = String.concatWith "." pieces fun makeD prefix pieces = case pieces of [] => (ErrorMsg.error "Empty module path"; (Source.DStyle "Boo", loc)) | [_] => d | piece :: pieces => let val this = case prefix of "" => piece | _ => prefix ^ "." ^ piece val old = SS.member (!defed, this) fun notThere (ch, s) = Substring.isEmpty (#2 (Substring.splitl (fn ch' => ch' <> ch) s)) fun simOpen () = SS.foldl (fn (full, ds) => if String.isPrefix (this ^ ".") full andalso notThere (#".", Substring.extract (full, size this + 1, NONE)) then let val parts = String.tokens (fn ch => ch = #".") full val part = List.last parts val imp = if length parts >= 2 then (Source.StrProj ((Source.StrVar (List.nth (parts, length parts - 2)), loc), part), loc) else (Source.StrVar part, loc) in (Source.DStr (part, NONE, imp), loc) :: ds end else ds) [] (!fulls) in defed := SS.add (!defed, this); (Source.DStr (piece, NONE, (Source.StrConst (if old then simOpen () @ [makeD this pieces] else [makeD this pieces]), loc)), loc) end in if SS.member (!fulls, full) then ErrorMsg.error ("Rooted module " ^ full ^ " has multiple versions.") else (); makeD "" pieces before ignore (foldl (fn (new, path) => let val new' = case path of "" => new | _ => path ^ "." ^ new in fulls := SS.add (!fulls, new'); new' end) "" pieces) end in checkErrors (); d end val dsFfi = map parseFfi ffi val ds = map parseOne fnames val loc = ErrorMsg.dummySpan in if !anyErrors then ErrorMsg.error "Parse failure" else (); let val final = List.last fnames val final = case List.find (fn (root, name) => String.isPrefix (root ^ "/") final) mrs of NONE => (Source.StrVar (nameOf final), loc) | SOME (root, name) => let val m = (Source.StrVar name, loc) val final = String.extract (final, size root + 1, NONE) in foldl (fn (x, m) => (Source.StrProj (m, capitalize x), loc)) m (String.fields (fn ch => ch = #"/") final) end val ds = dsFfi @ ds @ [(Source.DExport final, loc)] val ds = case database of NONE => ds | SOME s => (Source.DDatabase s, loc) :: ds in ds end handle Empty => ds end, print = SourcePrint.p_file } val toParse = transform parse "parse" o toParseJob fun libFile s = OS.Path.joinDirFile {dir = Config.libUr, file = s} fun clibFile s = OS.Path.joinDirFile {dir = Config.libC, file = s} val elaborate = { func = fn file => let val basis = #func parseUrs (libFile "basis.urs") val topSgn = #func parseUrs (libFile "top.urs") val topStr = #func parseUr (libFile "top.ur") in Elaborate.elabFile basis topStr topSgn ElabEnv.empty file end, print = ElabPrint.p_file ElabEnv.empty } val toElaborate = transform elaborate "elaborate" o toParse val unnest = { func = Unnest.unnest, print = ElabPrint.p_file ElabEnv.empty } val toUnnest = transform unnest "unnest" o toElaborate val termination = { func = (fn file => (Termination.check file; file)), print = ElabPrint.p_file ElabEnv.empty } val toTermination = transform termination "termination" o toUnnest val explify = { func = Explify.explify, print = ExplPrint.p_file ExplEnv.empty } val toExplify = transform explify "explify" o toUnnest val corify = { func = Corify.corify, print = CorePrint.p_file CoreEnv.empty } val toCorify = transform corify "corify" o toExplify (*val reduce_local = { func = ReduceLocal.reduce, print = CorePrint.p_file CoreEnv.empty } val toReduce_local = transform reduce_local "reduce_local" o toCorify*) val especialize = { func = ESpecialize.specialize, print = CorePrint.p_file CoreEnv.empty } val core_untangle = { func = CoreUntangle.untangle, print = CorePrint.p_file CoreEnv.empty } val toCore_untangle = transform core_untangle "core_untangle" o toCorify val shake = { func = Shake.shake, print = CorePrint.p_file CoreEnv.empty } val toShake1 = transform shake "shake1" o toCore_untangle val rpcify = { func = Rpcify.frob, print = CorePrint.p_file CoreEnv.empty } val toRpcify = transform rpcify "rpcify" o toShake1 val toCore_untangle2 = transform core_untangle "core_untangle2" o toRpcify val toShake2 = transform shake "shake2" o toCore_untangle2 val toEspecialize1 = transform especialize "especialize1" o toShake2 val toCore_untangle3 = transform core_untangle "core_untangle3" o toEspecialize1 val toShake3 = transform shake "shake3" o toCore_untangle3 val tag = { func = Tag.tag, print = CorePrint.p_file CoreEnv.empty } val toTag = transform tag "tag" o toShake3 val reduce = { func = Reduce.reduce, print = CorePrint.p_file CoreEnv.empty } val toReduce = transform reduce "reduce" o toTag val unpoly = { func = Unpoly.unpoly, print = CorePrint.p_file CoreEnv.empty } val toUnpoly = transform unpoly "unpoly" o toReduce val specialize = { func = Specialize.specialize, print = CorePrint.p_file CoreEnv.empty } val toSpecialize = transform specialize "specialize" o toUnpoly val toShake4 = transform shake "shake4" o toSpecialize val toEspecialize2 = transform especialize "especialize2" o toShake4 val toReduce2 = transform reduce "reduce2" o toEspecialize2 val toShake5 = transform shake "shake5" o toReduce2 val marshalcheck = { func = (fn file => (MarshalCheck.check file; file)), print = CorePrint.p_file CoreEnv.empty } val toMarshalcheck = transform marshalcheck "marshalcheck" o toShake5 val effectize = { func = Effective.effectize, print = CorePrint.p_file CoreEnv.empty } val toEffectize = transform effectize "effectize" o toMarshalcheck val monoize = { func = Monoize.monoize CoreEnv.empty, print = MonoPrint.p_file MonoEnv.empty } val toMonoize = transform monoize "monoize" o toEffectize val mono_opt = { func = MonoOpt.optimize, print = MonoPrint.p_file MonoEnv.empty } val toMono_opt1 = transform mono_opt "mono_opt1" o toMonoize val untangle = { func = Untangle.untangle, print = MonoPrint.p_file MonoEnv.empty } val toUntangle = transform untangle "untangle" o toMono_opt1 val mono_reduce = { func = MonoReduce.reduce, print = MonoPrint.p_file MonoEnv.empty } val toMono_reduce = transform mono_reduce "mono_reduce" o toUntangle val mono_shake = { func = MonoShake.shake, print = MonoPrint.p_file MonoEnv.empty } val toMono_shake = transform mono_shake "mono_shake1" o toMono_reduce val toMono_opt2 = transform mono_opt "mono_opt2" o toMono_shake val jscomp = { func = JsComp.process, print = MonoPrint.p_file MonoEnv.empty } val toJscomp = transform jscomp "jscomp" o toMono_opt2 val toMono_opt3 = transform mono_opt "mono_opt3" o toJscomp val fuse = { func = Fuse.fuse, print = MonoPrint.p_file MonoEnv.empty } val toFuse = transform fuse "fuse" o toMono_opt3 val toUntangle2 = transform untangle "untangle2" o toFuse val toMono_reduce2 = transform mono_reduce "mono_reduce2" o toUntangle2 val toMono_shake2 = transform mono_shake "mono_shake2" o toMono_reduce2 val toMono_opt4 = transform mono_opt "mono_opt4" o toMono_shake2 val toMono_reduce3 = transform mono_reduce "mono_reduce3" o toMono_opt4 val toFuse2 = transform fuse "shake2" o toMono_reduce3 val toUntangle3 = transform untangle "untangle3" o toFuse2 val toMono_shake3 = transform mono_shake "mono_shake3" o toUntangle3 val pathcheck = { func = (fn file => (PathCheck.check file; file)), print = MonoPrint.p_file MonoEnv.empty } val toPathcheck = transform pathcheck "pathcheck" o toMono_shake3 val cjrize = { func = Cjrize.cjrize, print = CjrPrint.p_file CjrEnv.empty } val toCjrize = transform cjrize "cjrize" o toPathcheck val scriptcheck = { func = ScriptCheck.classify, print = CjrPrint.p_file CjrEnv.empty } val toScriptcheck = transform scriptcheck "scriptcheck" o toCjrize val prepare = { func = Prepare.prepare, print = CjrPrint.p_file CjrEnv.empty } val toPrepare = transform prepare "prepare" o toScriptcheck val checknest = { func = fn f => if #supportsNestedPrepared (Settings.currentDbms ()) then f else Checknest.annotate f, print = CjrPrint.p_file CjrEnv.empty } val toChecknest = transform checknest "checknest" o toPrepare val sqlify = { func = Cjrize.cjrize, print = CjrPrint.p_sql CjrEnv.empty } val toSqlify = transform sqlify "sqlify" o toMono_opt2 fun compileC {cname, oname, ename, libs, profile, debug, link = link'} = let val proto = Settings.currentProtocol () val lib = if Settings.getStaticLinking () then #linkStatic proto ^ " " ^ Config.lib ^ "/../liburweb.a" else "-L" ^ Config.lib ^ "/.. -lurweb " ^ #linkDynamic proto val compile = "gcc " ^ Config.gccArgs ^ " -Wimplicit -Werror -O3 -fno-inline -I " ^ Config.includ ^ " " ^ #compile proto ^ " -c " ^ cname ^ " -o " ^ oname val link = "gcc -Werror -O3 -lm -lmhash -pthread " ^ Config.gccArgs ^ " " ^ libs ^ " " ^ lib ^ " " ^ oname ^ " -o " ^ ename val (compile, link) = if profile then (compile ^ " -pg", link ^ " -pg") else (compile, link) val (compile, link) = if debug then (compile ^ " -g", link ^ " -g") else (compile, link) val link = foldl (fn (s, link) => link ^ " " ^ s) link link' in OS.Process.isSuccess (OS.Process.system compile) andalso OS.Process.isSuccess (OS.Process.system link) end fun compile job = case run toChecknest job of NONE => false | SOME file => let val job = valOf (run (transform parseUrp "parseUrp") job) val (cname, oname, cleanup) = if #debug job then ("/tmp/webapp.c", "/tmp/webapp.o", fn () => ()) else let val dir = OS.FileSys.tmpName () val () = if OS.FileSys.access (dir, []) then OS.FileSys.remove dir else () val cname = OS.Path.joinDirFile {dir = dir, file = "webapp.c"} val oname = OS.Path.joinDirFile {dir = dir, file = "webapp.o"} in OS.FileSys.mkDir dir; (cname, oname, fn () => (OS.FileSys.remove cname; OS.FileSys.remove oname; OS.FileSys.rmDir dir) handle OS.SysErr _ => OS.FileSys.rmDir dir) end val ename = #exe job in let val outf = TextIO.openOut cname val s = TextIOPP.openOut {dst = outf, wid = 80} val hasDb = List.exists (fn (Cjr.DDatabase _, _) => true | _ => false) (#1 file) val libs = if hasDb then #link (Settings.currentDbms ()) else "" in Print.fprint s (CjrPrint.p_file CjrEnv.empty file); TextIO.output1 (outf, #"\n"); TextIO.closeOut outf; case #sql job of NONE => () | SOME sql => let val outf = TextIO.openOut sql val s = TextIOPP.openOut {dst = outf, wid = 80} in Print.fprint s (CjrPrint.p_sql CjrEnv.empty file); TextIO.closeOut outf end; compileC {cname = cname, oname = oname, ename = ename, libs = libs, profile = #profile job, debug = #debug job, link = #link job} before cleanup () end handle ex => (((cleanup ()) handle _ => ()); raise ex) end fun compiler job = if compile job then () else OS.Process.exit OS.Process.failure end