From a08075494d9c16a349215fbcaefa3e1d14d2e0f9 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 20 Dec 2008 14:19:21 -0500 Subject: Start of JsComp --- src/compiler.sig | 2 + src/compiler.sml | 9 +- src/jscomp.sig | 32 +++++ src/jscomp.sml | 344 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ src/mono_env.sig | 1 + src/mono_env.sml | 11 ++ src/mono_opt.sml | 5 - src/mono_util.sig | 11 ++ src/mono_util.sml | 15 +++ src/prim.sig | 2 + src/prim.sml | 6 + src/sources | 3 + tests/alert.ur | 2 +- 13 files changed, 436 insertions(+), 7 deletions(-) create mode 100644 src/jscomp.sig create mode 100644 src/jscomp.sml diff --git a/src/compiler.sig b/src/compiler.sig index 59ad32be..1f1f4973 100644 --- a/src/compiler.sig +++ b/src/compiler.sig @@ -75,6 +75,7 @@ signature COMPILER = sig val untangle : (Mono.file, Mono.file) phase val mono_reduce : (Mono.file, Mono.file) phase val mono_shake : (Mono.file, Mono.file) phase + val jscomp : (Mono.file, Mono.file) phase val fuse : (Mono.file, Mono.file) phase val pathcheck : (Mono.file, Mono.file) phase val cjrize : (Mono.file, Cjr.file) phase @@ -101,6 +102,7 @@ signature COMPILER = sig val toUntangle : (string, Mono.file) transform val toMono_reduce : (string, Mono.file) transform val toMono_shake : (string, Mono.file) transform + val toJscomp : (string, Mono.file) transform val toMono_opt2 : (string, Mono.file) transform val toFuse : (string, Mono.file) transform val toUntangle2 : (string, Mono.file) transform diff --git a/src/compiler.sml b/src/compiler.sml index 0ff4ee6a..ecee1065 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -511,7 +511,14 @@ val mono_shake = { 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_reduce + +val toMono_opt2 = transform mono_opt "mono_opt2" o toJscomp val fuse = { func = Fuse.fuse, diff --git a/src/jscomp.sig b/src/jscomp.sig new file mode 100644 index 00000000..929c507d --- /dev/null +++ b/src/jscomp.sig @@ -0,0 +1,32 @@ +(* Copyright (c) 2008, 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 JSCOMP = sig + + val process : Mono.file -> Mono.file + +end diff --git a/src/jscomp.sml b/src/jscomp.sml new file mode 100644 index 00000000..0dd7882a --- /dev/null +++ b/src/jscomp.sml @@ -0,0 +1,344 @@ +(* Copyright (c) 2008, 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 JsComp :> JSCOMP = struct + +open Mono + +structure EM = ErrorMsg +structure E = MonoEnv +structure U = MonoUtil + +type state = { + decls : decl list, + script : string +} + +fun varDepth (e, _) = + case e of + EPrim _ => 0 + | ERel _ => 0 + | ENamed _ => 0 + | ECon (_, _, NONE) => 0 + | ECon (_, _, SOME e) => varDepth e + | ENone _ => 0 + | ESome (_, e) => varDepth e + | EFfi _ => 0 + | EFfiApp (_, _, es) => foldl Int.max 0 (map varDepth es) + | EApp (e1, e2) => Int.max (varDepth e1, varDepth e2) + | EAbs _ => 0 + | EUnop (_, e) => varDepth e + | EBinop (_, e1, e2) => Int.max (varDepth e1, varDepth e2) + | ERecord xes => foldl Int.max 0 (map (fn (_, e, _) => varDepth e) xes) + | EField (e, _) => varDepth e + | ECase (e, pes, _) => + foldl Int.max (varDepth e) + (map (fn (p, e) => E.patBindsN p + varDepth e) pes) + | EStrcat (e1, e2) => Int.max (varDepth e1, varDepth e2) + | EError (e, _) => varDepth e + | EWrite e => varDepth e + | ESeq (e1, e2) => Int.max (varDepth e1, varDepth e2) + | ELet (_, _, e1, e2) => Int.max (varDepth e1, 1 + varDepth e2) + | EClosure _ => 0 + | EQuery _ => 0 + | EDml _ => 0 + | ENextval _ => 0 + | EUnurlify _ => 0 + | EJavaScript _ => 0 + +fun jsExp inAttr outer = + let + val len = length outer + + fun jsE inner (e as (_, loc), st) = + let + fun str s = (EPrim (Prim.String s), loc) + + fun var n = Int.toString (len + inner - n - 1) + + fun patCon pc = + case pc of + PConVar n => str (Int.toString n) + | PConFfi {con, ...} => str ("\"_" ^ con ^ "\"") + + fun strcat es = + case es of + [] => (EPrim (Prim.String ""), loc) + | [x] => x + | x :: es' => (EStrcat (x, strcat es'), loc) + + fun isNullable (t, _) = + case t of + TOption _ => true + | _ => false + + fun unsupported s = + (EM.errorAt loc (s ^ " in code to be compiled to JavaScript"); + (str "ERROR", st)) + in + case #1 e of + EPrim (Prim.String s) => + (str ("\"" + ^ String.translate (fn #"'" => + if inAttr then + "\\047" + else + "'" + | #"<" => + if inAttr then + "<" + else + "\\074" + | #"\\" => "\\\\" + | ch => String.str ch) s + ^ "\""), st) + | EPrim p => (str (Prim.toString p), st) + | ERel n => + if n < inner then + (str ("uwr" ^ var n), st) + else + (str ("uwo" ^ var n), st) + | ENamed _ => raise Fail "Named" + | ECon (_, pc, NONE) => (patCon pc, st) + | ECon (_, pc, SOME e) => + let + val (s, st) = jsE inner (e, st) + in + (strcat [str "{n:", + patCon pc, + str ",v:", + s, + str "}"], st) + end + | ENone _ => (str "null", st) + | ESome (t, e) => + let + val (e, st) = jsE inner (e, st) + in + (if isNullable t then + strcat [str "{v:", e, str "}"] + else + e, st) + end + + | EFfi (_, s) => (str s, st) + | EFfiApp (_, s, []) => (str (s ^ "()"), st) + | EFfiApp (_, s, [e]) => + let + val (e, st) = jsE inner (e, st) + + in + (strcat [str (s ^ "("), + e, + str ")"], st) + end + | EFfiApp (_, s, e :: es) => + let + val (e, st) = jsE inner (e, st) + val (es, st) = ListUtil.foldlMapConcat + (fn (e, st) => + let + val (e, st) = jsE inner (e, st) + in + ([str ",", e], st) + end) + st es + in + (strcat (str (s ^ "(") + :: e + :: es + @ [str ")"]), st) + end + + | EApp (e1, e2) => + let + val (e1, st) = jsE inner (e1, st) + val (e2, st) = jsE inner (e2, st) + in + (strcat [e1, str "(", e2, str ")"], st) + end + | EAbs (_, _, _, e) => + let + val locals = List.tabulate + (varDepth e, + fn i => str ("var uwr" ^ Int.toString (len + inner + i) ^ ";")) + val (e, st) = jsE (inner + 1) (e, st) + in + (strcat (str ("function(uwr" + ^ Int.toString (len + inner) + ^ "){") + :: locals + @ [str "return ", + e, + str "}"]), + st) + end + + | EUnop (s, e) => + let + val (e, st) = jsE inner (e, st) + in + (strcat [str ("(" ^ s), + e, + str ")"], + st) + end + | EBinop (s, e1, e2) => + let + val (e1, st) = jsE inner (e1, st) + val (e2, st) = jsE inner (e2, st) + in + (strcat [str "(", + e1, + str s, + e2, + str ")"], + st) + end + + | ERecord [] => (str "null", st) + | ERecord [(x, e, _)] => + let + val (e, st) = jsE inner (e, st) + in + (strcat [str "{uw_x:", e, str "}"], st) + end + | ERecord ((x, e, _) :: xes) => + let + val (e, st) = jsE inner (e, st) + + val (es, st) = + foldr (fn ((x, e, _), (es, st)) => + let + val (e, st) = jsE inner (e, st) + in + (str (",uw_" ^ x ^ ":") + :: e + :: es, + st) + end) + ([str "}"], st) xes + in + (strcat (str ("{uw_" ^ x ^ ":") + :: e + :: es), + st) + end + | EField (e, x) => + let + val (e, st) = jsE inner (e, st) + in + (strcat [e, + str ("." ^ x)], st) + end + + | ECase _ => raise Fail "Jscomp: ECase" + + | EStrcat (e1, e2) => + let + val (e1, st) = jsE inner (e1, st) + val (e2, st) = jsE inner (e2, st) + in + (strcat [str "(", e1, str "+", e2, str ")"], st) + end + + | EError (e, _) => + let + val (e, st) = jsE inner (e, st) + in + (strcat [str "alert(\"ERROR: \"+", e, str ")"], + st) + end + + | EWrite _ => unsupported "EWrite" + + | ESeq (e1, e2) => + let + val (e1, st) = jsE inner (e1, st) + val (e2, st) = jsE inner (e2, st) + in + (strcat [str "(", e1, str ",", e2, str ")"], st) + end + | ELet (_, _, e1, e2) => + let + val (e1, st) = jsE inner (e1, st) + val (e2, st) = jsE (inner + 1) (e2, st) + in + (strcat [str ("(uwr" ^ Int.toString (len + inner) ^ "="), + e1, + str ",", + e2, + str ")"], st) + end + + | EClosure _ => unsupported "EClosure" + | EQuery _ => unsupported "Query" + | EDml _ => unsupported "DML" + | ENextval _ => unsupported "Nextval" + | EUnurlify _ => unsupported "EUnurlify" + | EJavaScript _ => unsupported "Nested JavaScript" + end + in + jsE + end + +val decl : state -> decl -> decl * state = + U.Decl.foldMapB {typ = fn x => x, + exp = fn (env, e, st) => + case e of + EJavaScript (EAbs (_, t, _, e), _) => + let + val (e, st) = jsExp true (t :: env) 0 (e, st) + in + (#1 e, st) + end + | _ => (e, st), + decl = fn (_, e, st) => (e, st), + bind = fn (env, U.Decl.RelE (_, t)) => t :: env + | (env, _) => env} + [] + +fun process file = + let + fun doDecl (d, st) = + let + val (d, st) = decl st d + in + (List.revAppend (#decls st, [d]), + {decls = [], + script = #script st}) + end + + val (ds, st) = ListUtil.foldlMapConcat doDecl + {decls = [], + script = ""} + file + in + ds + end + +end diff --git a/src/mono_env.sig b/src/mono_env.sig index cb6f2352..c59596ae 100644 --- a/src/mono_env.sig +++ b/src/mono_env.sig @@ -47,5 +47,6 @@ signature MONO_ENV = sig val declBinds : env -> Mono.decl -> env val patBinds : env -> Mono.pat -> env + val patBindsN : Mono.pat -> int end diff --git a/src/mono_env.sml b/src/mono_env.sml index 47ffd28d..cce4a4c4 100644 --- a/src/mono_env.sml +++ b/src/mono_env.sml @@ -122,4 +122,15 @@ fun patBinds env (p, loc) = | PNone _ => env | PSome (_, p) => patBinds env p +fun patBindsN (p, loc) = + case p of + PWild => 0 + | PVar _ => 1 + | PPrim _ => 0 + | PCon (_, _, NONE) => 0 + | PCon (_, _, SOME p) => patBindsN p + | PRecord xps => foldl (fn ((_, p, _), count) => count + patBindsN p) 0 xps + | PNone _ => 0 + | PSome (_, p) => patBindsN p + end diff --git a/src/mono_opt.sml b/src/mono_opt.sml index 7f83c003..6c0e6e21 100644 --- a/src/mono_opt.sml +++ b/src/mono_opt.sml @@ -360,11 +360,6 @@ fun exp e = | EWrite (EPrim (Prim.String ""), loc) => ERecord [] - | EJavaScript (EAbs (_, (TRecord [], _), _, (EFfiApp ("Basis", "alert", [s]), _)), loc) => - EStrcat ((EPrim (Prim.String "alert("), loc), - (EStrcat ((EFfiApp ("Basis", "jsifyString", [s]), loc), - (EPrim (Prim.String ")"), loc)), loc)) - | _ => e and optExp e = #1 (U.Exp.map {typ = typ, exp = exp} e) diff --git a/src/mono_util.sig b/src/mono_util.sig index 32a83855..2a96211a 100644 --- a/src/mono_util.sig +++ b/src/mono_util.sig @@ -71,6 +71,11 @@ structure Exp : sig val exists : {typ : Mono.typ' -> bool, exp : Mono.exp' -> bool} -> Mono.exp -> bool + + val foldB : {typ : Mono.typ' * 'state -> 'state, + exp : 'context * Mono.exp' * 'state -> 'state, + bind : 'context * binder -> 'context} + -> 'context -> 'state -> Mono.exp -> 'state end structure Decl : sig @@ -95,6 +100,12 @@ structure Decl : sig exp : Mono.exp' -> Mono.exp', decl : Mono.decl' -> Mono.decl'} -> Mono.decl -> Mono.decl + + val foldMapB : {typ : Mono.typ' * 'state -> Mono.typ' * 'state, + exp : 'context * Mono.exp' * 'state -> Mono.exp' * 'state, + decl : 'context * Mono.decl' * 'state -> Mono.decl' * 'state, + bind : 'context * binder -> 'context} + -> 'context -> 'state -> Mono.decl -> Mono.decl * 'state end structure File : sig diff --git a/src/mono_util.sml b/src/mono_util.sml index 18b5c948..ebc30984 100644 --- a/src/mono_util.sml +++ b/src/mono_util.sml @@ -357,6 +357,13 @@ fun exists {typ, exp} k = S.Return _ => true | S.Continue _ => false +fun foldB {typ, exp, bind} ctx s e = + case mapfoldB {typ = fn t => fn s => S.Continue (t, typ (t, s)), + exp = fn ctx => fn e => fn s => S.Continue (e, exp (ctx, e, s)), + bind = bind} ctx e s of + S.Continue (_, s) => s + | S.Return _ => raise Fail "MonoUtil.Exp.foldB: Impossible" + end structure Decl = struct @@ -433,6 +440,14 @@ fun map {typ, exp, decl} e = S.Return () => raise Fail "MonoUtil.Decl.map: Impossible" | S.Continue (e, ()) => e +fun foldMapB {typ, exp, decl, bind} ctx s d = + case mapfoldB {typ = fn c => fn s => S.Continue (typ (c, s)), + exp = fn ctx => fn e => fn s => S.Continue (exp (ctx, e, s)), + decl = fn ctx => fn d => fn s => S.Continue (decl (ctx, d, s)), + bind = bind} ctx d s of + S.Continue v => v + | S.Return _ => raise Fail "MonoUtil.Decl.foldMapB: Impossible" + end structure File = struct diff --git a/src/prim.sig b/src/prim.sig index 3083a26e..54625379 100644 --- a/src/prim.sig +++ b/src/prim.sig @@ -38,4 +38,6 @@ signature PRIM = sig val equal : t * t -> bool val compare : t * t -> order + val toString : t -> string + end diff --git a/src/prim.sml b/src/prim.sml index daf666e8..468b28d5 100644 --- a/src/prim.sml +++ b/src/prim.sml @@ -53,6 +53,12 @@ fun float2s n = else Real64.toString n +fun toString t = + case t of + Int n => int2s n + | Float n => float2s n + | String s => s + fun p_t_GCC t = case t of Int n => string (int2s n) diff --git a/src/sources b/src/sources index 6972dc36..05b1cc54 100644 --- a/src/sources +++ b/src/sources @@ -137,6 +137,9 @@ untangle.sml mono_shake.sig mono_shake.sml +jscomp.sig +jscomp.sml + pathcheck.sig pathcheck.sml diff --git a/tests/alert.ur b/tests/alert.ur index 7b2eaacf..3fe68d75 100644 --- a/tests/alert.ur +++ b/tests/alert.ur @@ -1,3 +1,3 @@ fun main () : transaction page = return - Click Me! + Click Me! -- cgit v1.2.3