Mercurial > urweb
changeset 764:7f653298dd66
C FFI compiler options
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Thu, 30 Apr 2009 17:15:14 -0400 |
| parents | af41ec2f302a |
| children | a28982de5645 |
| files | .hgignore include/types.h include/urweb.h src/cjr_print.sig src/cjr_print.sml src/compiler.sig src/compiler.sml src/corify.sml src/demo.sml src/jscomp.sml src/monoize.sig src/monoize.sml src/settings.sig src/settings.sml src/sources tests/Makefile tests/cffi.ur tests/cffi.urp tests/cffi.urs tests/test.c tests/test.h tests/test.urs |
| diffstat | 22 files changed, 251 insertions(+), 66 deletions(-) [+] |
line wrap: on
line diff
--- a/.hgignore Thu Apr 30 16:25:27 2009 -0400 +++ b/.hgignore Thu Apr 30 17:15:14 2009 -0400 @@ -13,7 +13,6 @@ *.grm.* *.o -./Makefile src/config.sml *.exe @@ -37,3 +36,8 @@ .depend Makefile.coq *.vo + +syntax: regexp + +^Makefile +^src/coq/Makefile
--- a/include/types.h Thu Apr 30 16:25:27 2009 -0400 +++ b/include/types.h Thu Apr 30 17:15:14 2009 -0400 @@ -1,3 +1,6 @@ +#ifndef URWEB_TYPES_H +#define URWEB_TYPES_H + #include <time.h> typedef long long uw_Basis_int; @@ -42,3 +45,4 @@ #define FLOATS_MAX 100 #define TIMES_MAX 100 +#endif
--- a/include/urweb.h Thu Apr 30 16:25:27 2009 -0400 +++ b/include/urweb.h Thu Apr 30 17:15:14 2009 -0400 @@ -1,3 +1,6 @@ +#ifndef URWEB_H +#define URWEB_H + #include <sys/types.h> #include "types.h" @@ -176,3 +179,5 @@ uw_Basis_int uw_Basis_blobSize(uw_context, uw_Basis_blob); __attribute__((noreturn)) void uw_return_blob(uw_context, uw_Basis_blob, uw_Basis_string mimeType); + +#endif
--- a/src/cjr_print.sig Thu Apr 30 16:25:27 2009 -0400 +++ b/src/cjr_print.sig Thu Apr 30 17:15:14 2009 -0400 @@ -36,6 +36,4 @@ val p_sql : CjrEnv.env -> Cjr.file Print.printer val debug : bool ref - - val timeout : int ref end
--- a/src/cjr_print.sml Thu Apr 30 16:25:27 2009 -0400 +++ b/src/cjr_print.sml Thu Apr 30 17:15:14 2009 -0400 @@ -1250,8 +1250,6 @@ urlify' IS.empty 0 t end -val timeout = ref 0 - fun p_exp' par env (e, loc) = case e of EPrim p => Prim.p_t_GCC p @@ -2832,7 +2830,7 @@ string (case side of ServerOnly => "" | _ => "<script src=\\\"" - ^ OS.Path.joinDirFile {dir = !Monoize.urlPrefix, + ^ OS.Path.joinDirFile {dir = Settings.getUrlPrefix (), file = "app.js"} ^ "\\\"></script>\\n"), string "\");", @@ -2844,7 +2842,7 @@ string ");", newline, string "uw_set_url_prefix(ctx, \"", - string (!Monoize.urlPrefix), + string (Settings.getUrlPrefix ()), string "\");", newline]), string "uw_set_needs_sig(ctx, ", @@ -3185,6 +3183,10 @@ else box [], newline, + p_list_sep (box []) (fn s => box [string "#include \"", + string s, + string "\"", + newline]) (Settings.getHeaders ()), string "#include \"", string (OS.Path.joinDirFile {dir = Config.includ, file = "urweb.h"}), @@ -3198,7 +3200,7 @@ string ";", newline, string "int uw_timeout = ", - string (Int.toString (!timeout)), + string (Int.toString (Settings.getTimeout ())), string ";", newline, newline,
--- a/src/compiler.sig Thu Apr 30 16:25:27 2009 -0400 +++ b/src/compiler.sig Thu Apr 30 17:15:14 2009 -0400 @@ -37,11 +37,14 @@ sql : string option, debug : bool, profile : bool, - timeout : int + timeout : int, + ffi : string list, + link : string list, + headers : string list } val compile : string -> unit val compileC : {cname : string, oname : string, ename : string, libs : string, - profile : bool, debug : bool} -> unit + profile : bool, debug : bool, link : string list} -> unit type ('src, 'dst) phase type ('src, 'dst) transform
--- a/src/compiler.sml Thu Apr 30 16:25:27 2009 -0400 +++ b/src/compiler.sml Thu Apr 30 17:15:14 2009 -0400 @@ -1,4 +1,4 @@ -(* Copyright (c) 2008, Adam Chlipala +(* Copyright (c) 2008-2009, Adam Chlipala * All rights reserved. * * Redistribution and use in source and binary forms, with or without @@ -25,8 +25,6 @@ * POSSIBILITY OF SUCH DAMAGE. *) -(* Ur/Web language parser *) - structure Compiler :> COMPILER = struct structure UrwebLrVals = UrwebLrValsFn(structure Token = LrParser.Token) @@ -43,7 +41,10 @@ sql : string option, debug : bool, profile : bool, - timeout : int + timeout : int, + ffi : string list, + link : string list, + headers : string list } type ('src, 'dst) phase = { @@ -201,7 +202,7 @@ handle LrParser.ParseError => [], print = SourcePrint.p_file} -fun p_job {prefix, database, exe, sql, sources, debug, profile, timeout} = +fun p_job {prefix, database, exe, sql, sources, debug, profile, timeout, ffi, link, headers} = let open Print.PD open Print @@ -228,6 +229,9 @@ 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 "Link", space, string s, newline]) link, string "Sources:", p_list string sources, newline] @@ -251,6 +255,10 @@ OS.Path.concat (dir, fname) handle OS.Path.Path => fname + val absDir = OS.Path.mkAbsolute {path = dir, relativeTo = OS.FileSys.getDir ()} + + fun relifyA fname = OS.Path.mkAbsolute {path = fname, relativeTo = absDir} + fun readSources acc = case TextIO.inputLine inf of NONE => rev acc @@ -270,21 +278,35 @@ readSources acc end - fun finish (prefix, database, exe, sql, debug, profile, timeout, sources) = - {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), + val prefix = ref NONE + val database = ref NONE + val exe = ref NONE + val sql = ref NONE + val debug = ref false + val profile = ref false + val timeout = ref NONE + val ffi = ref [] + val link = ref [] + val headers = ref [] + + fun finish sources = + {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 = !ffi, + link = !link, + headers = !headers, sources = sources} - fun read (prefix, database, exe, sql, debug, profile, timeout) = + fun read () = case TextIO.inputLine inf of - NONE => finish (prefix, database, exe, sql, debug, profile, timeout, []) - | SOME "\n" => finish (prefix, database, exe, sql, debug, profile, timeout, readSources []) + NONE => finish [] + | SOME "\n" => finish (readSources []) | SOME line => let val (cmd, arg) = Substring.splitl (fn x => not (Char.isSpace x)) (Substring.full line) @@ -293,41 +315,45 @@ in case cmd of "prefix" => - (case prefix of + (case !prefix of NONE => () | SOME _ => ErrorMsg.error "Duplicate 'prefix' directive"; - read (SOME arg, database, exe, sql, debug, profile, timeout)) + prefix := SOME arg) | "database" => - (case database of + (case !database of NONE => () | SOME _ => ErrorMsg.error "Duplicate 'database' directive"; - read (prefix, SOME arg, exe, sql, debug, profile, timeout)) + database := SOME arg) | "exe" => - (case exe of + (case !exe of NONE => () | SOME _ => ErrorMsg.error "Duplicate 'exe' directive"; - read (prefix, database, SOME (relify arg), sql, debug, profile, timeout)) + exe := SOME (relify arg)) | "sql" => - (case sql of + (case !sql of NONE => () | SOME _ => ErrorMsg.error "Duplicate 'sql' directive"; - read (prefix, database, exe, SOME (relify arg), debug, profile, timeout)) - | "debug" => read (prefix, database, exe, sql, true, profile, timeout) - | "profile" => read (prefix, database, exe, sql, debug, true, timeout) + sql := SOME (relify arg)) + | "debug" => debug := true + | "profile" => profile := true | "timeout" => - (case timeout of + (case !timeout of NONE => () | SOME _ => ErrorMsg.error "Duplicate 'timeout' directive"; - read (prefix, database, exe, sql, debug, profile, SOME (valOf (Int.fromString arg)))) - | _ => (ErrorMsg.error ("Unrecognized command '" ^ cmd ^ "'"); - read (prefix, database, exe, sql, debug, profile, timeout)) + timeout := SOME (valOf (Int.fromString arg))) + | "ffi" => ffi := relify arg :: !ffi + | "link" => link := relifyA arg :: !link + | "include" => headers := relifyA arg :: !headers + | _ => ErrorMsg.error ("Unrecognized command '" ^ cmd ^ "'"); + read () end - val job = read (NONE, NONE, NONE, NONE, false, false, NONE) + val job = read () in TextIO.closeIn inf; - Monoize.urlPrefix := #prefix job; - CjrPrint.timeout := #timeout job; + Settings.setUrlPrefix (#prefix job); + Settings.setTimeout (#timeout job); + Settings.setHeaders (#headers job); job end, print = p_job @@ -339,10 +365,24 @@ | capitalize s = str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE) val parse = { - func = fn {database, sources = fnames, ...} : job => + func = fn {database, sources = fnames, ffi, ...} : job => let 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 + (Source.DFfiStr (mname, sgn), loc) + end + fun parseOne fname = let val mname = nameOf fname @@ -367,12 +407,14 @@ (Source.DStr (mname, sgnO, (Source.StrConst ds, loc)), loc) end + val dsFfi = map parseFfi ffi val ds = map parseOne fnames in let val final = nameOf (List.last fnames) - val ds = ds @ [(Source.DExport (Source.StrVar final, ErrorMsg.dummySpan), ErrorMsg.dummySpan)] + val ds = dsFfi @ ds + @ [(Source.DExport (Source.StrVar final, ErrorMsg.dummySpan), ErrorMsg.dummySpan)] in case database of NONE => ds @@ -605,7 +647,7 @@ val toSqlify = transform sqlify "sqlify" o toMono_opt2 -fun compileC {cname, oname, ename, libs, profile, debug} = +fun compileC {cname, oname, ename, libs, profile, debug, link = link'} = let val urweb_o = clibFile "urweb.o" val driver_o = clibFile "driver.o" @@ -624,6 +666,8 @@ (compile ^ " -g", link ^ " -g") else (compile, link) + + val link = foldl (fn (s, link) => link ^ " " ^ s) link link' in if not (OS.Process.isSuccess (OS.Process.system compile)) then print "C compilation failed\n" @@ -689,7 +733,7 @@ end; compileC {cname = cname, oname = oname, ename = ename, libs = libs, - profile = #profile job, debug = #debug job}; + profile = #profile job, debug = #debug job, link = #link job}; cleanup () end
--- a/src/corify.sml Thu Apr 30 16:25:27 2009 -0400 +++ b/src/corify.sml Thu Apr 30 17:15:14 2009 -0400 @@ -890,7 +890,7 @@ val st = St.bindStr st m n (St.ffi m cmap conmap) in - (rev ds, St.basisIs (st, n)) + (rev ds, if m = "Basis" then St.basisIs (st, n) else st) end | _ => raise Fail "Non-const signature for FFI structure")
--- a/src/demo.sml Thu Apr 30 16:25:27 2009 -0400 +++ b/src/demo.sml Thu Apr 30 17:15:14 2009 -0400 @@ -94,7 +94,10 @@ file = "demo.sql"}), debug = false, timeout = Int.max (#timeout combined, #timeout urp), - profile = false + profile = false, + ffi = [], + link = [], + headers = [] } val parse = Compiler.run (Compiler.transform Compiler.parseUrp "Demo parseUrp")
--- a/src/jscomp.sml Thu Apr 30 16:25:27 2009 -0400 +++ b/src/jscomp.sml Thu Apr 30 17:15:14 2009 -0400 @@ -965,7 +965,7 @@ val (ek, st) = jsE inner (ek, st) val (unurl, st) = unurlifyExp loc (t, st) in - (strcat [str ("rc(cat(\"" ^ !Monoize.urlPrefix ^ "\","), + (strcat [str ("rc(cat(\"" ^ Settings.getUrlPrefix () ^ "\","), e, str ("), function(s){var t=s.split(\"/\");var i=0;return " ^ unurl ^ "},"),
--- a/src/monoize.sig Thu Apr 30 16:25:27 2009 -0400 +++ b/src/monoize.sig Thu Apr 30 17:15:14 2009 -0400 @@ -27,8 +27,6 @@ signature MONOIZE = sig - val urlPrefix : string ref - val monoize : CoreEnv.env -> Core.file -> Mono.file val liftExpInExp : int -> Mono.exp -> Mono.exp
--- a/src/monoize.sml Thu Apr 30 16:25:27 2009 -0400 +++ b/src/monoize.sml Thu Apr 30 17:15:14 2009 -0400 @@ -36,8 +36,6 @@ structure IM = IntBinaryMap structure IS = IntBinarySet -val urlPrefix = ref "/" - val dummyTyp = (L'.TDatatype (0, ref (L'.Enum, [])), E.dummySpan) structure U = MonoUtil @@ -376,7 +374,7 @@ let val (_, _, _, s) = Env.lookupENamed env fnam in - ((L'.EPrim (Prim.String (!urlPrefix ^ s)), loc), fm) + ((L'.EPrim (Prim.String (Settings.getUrlPrefix () ^ s)), loc), fm) end | L'.EClosure (fnam, args) => let @@ -399,7 +397,7 @@ | _ => (E.errorAt loc "Type mismatch encoding attribute"; (e, fm)) in - attrify (args, ft, (L'.EPrim (Prim.String (!urlPrefix ^ s)), loc), fm) + attrify (args, ft, (L'.EPrim (Prim.String (Settings.getUrlPrefix () ^ s)), loc), fm) end | _ => case t of @@ -1257,7 +1255,8 @@ ((L'.EAbs ("c", s, (L'.TFun (t, (L'.TFun (un, un), loc)), loc), (L'.EAbs ("v", t, (L'.TFun (un, un), loc), (L'.EAbs ("_", un, un, - (L'.EFfiApp ("Basis", "set_cookie", [(L'.EPrim (Prim.String (!urlPrefix)), + (L'.EFfiApp ("Basis", "set_cookie", [(L'.EPrim (Prim.String + (Settings.getUrlPrefix ())), loc), (L'.ERel 2, loc), e]), loc)), @@ -3138,14 +3137,7 @@ fun monoize env file = let - val p = !urlPrefix - val () = - if p = "" then - urlPrefix := "/" - else if String.sub (p, size p - 1) <> #"/" then - urlPrefix := p ^ "/" - else - () + (* Calculate which exported functions need cookie signature protection *) val rcook = foldl (fn ((d, _), rcook) =>
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/settings.sig Thu Apr 30 17:15:14 2009 -0400 @@ -0,0 +1,39 @@ +(* Copyright (c) 2008-2009, 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. + *) + +signature SETTINGS = sig + + val setUrlPrefix : string -> unit + val getUrlPrefix : unit -> string + + val setTimeout : int -> unit + val getTimeout : unit -> int + + val setHeaders : string list -> unit + val getHeaders : unit -> string list + +end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/settings.sml Thu Apr 30 17:15:14 2009 -0400 @@ -0,0 +1,49 @@ +(* Copyright (c) 2008-2009, 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 Settings :> SETTINGS = struct + +val urlPrefix = ref "/" +val timeout = ref 0 +val headers = ref ([] : string list) + +fun getUrlPrefix () = !urlPrefix +fun setUrlPrefix p = + urlPrefix := (if p = "" then + "/" + else if String.sub (p, size p - 1) <> #"/" then + p ^ "/" + else + p) + +fun getTimeout () = !timeout +fun setTimeout n = timeout := n + +fun getHeaders () = !headers +fun setHeaders ls = headers := ls + +end
--- a/src/sources Thu Apr 30 16:25:27 2009 -0400 +++ b/src/sources Thu Apr 30 17:15:14 2009 -0400 @@ -13,6 +13,9 @@ errormsg.sig errormsg.sml +settings.sig +settings.sml + print.sig print.sml
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/Makefile Thu Apr 30 17:15:14 2009 -0400 @@ -0,0 +1,4 @@ +all: test.o + +test.o: test.c + gcc -c test.c -o test.o
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/cffi.ur Thu Apr 30 17:15:14 2009 -0400 @@ -0,0 +1,3 @@ +fun main () = return <xml><body> + {[Test.out (Test.frob (Test.create "Hello ") "world!")]} +</body></xml>
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/cffi.urp Thu Apr 30 17:15:14 2009 -0400 @@ -0,0 +1,6 @@ +debug +ffi test +include test.h +link test.o + +cffi
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/cffi.urs Thu Apr 30 17:15:14 2009 -0400 @@ -0,0 +1,1 @@ +val main : unit -> transaction page
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/test.c Thu Apr 30 17:15:14 2009 -0400 @@ -0,0 +1,15 @@ +#include "../include/urweb.h" + +typedef uw_Basis_string uw_Test_t; + +uw_Test_t uw_Test_create(uw_context ctx, uw_Basis_string s) { + return s; +} + +uw_Basis_string uw_Test_out(uw_context ctx, uw_Test_t s) { + return s; +} + +uw_Test_t uw_Test_frob(uw_context ctx, uw_Test_t s1, uw_Basis_string s2) { + return uw_Basis_strcat(ctx, s1, s2); +}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/test.h Thu Apr 30 17:15:14 2009 -0400 @@ -0,0 +1,7 @@ +#include "../include/urweb.h" + +typedef uw_Basis_string uw_Test_t; + +uw_Test_t uw_Test_create(uw_context, uw_Basis_string); +uw_Basis_string uw_Test_out(uw_context, uw_Test_t); +uw_Test_t uw_Test_frob(uw_context, uw_Test_t, uw_Basis_string);