From 5badaf182a69fc7d67f9ae2e5a0a8e5bf7edea36 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 26 Oct 2008 08:41:17 -0400 Subject: Avoid using libpq when unneeded --- src/compiler.sig | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'src/compiler.sig') diff --git a/src/compiler.sig b/src/compiler.sig index f0914d0f..0c95934a 100644 --- a/src/compiler.sig +++ b/src/compiler.sig @@ -38,7 +38,7 @@ signature COMPILER = sig debug : bool } val compile : string -> unit - val compileC : {cname : string, oname : string, ename : string} -> unit + val compileC : {cname : string, oname : string, ename : string, libs : string} -> unit type ('src, 'dst) phase type ('src, 'dst) transform -- cgit v1.2.3 From 0e88aba4fcbcf9587c289a555315ec30a112a2f0 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 30 Oct 2008 16:58:54 -0400 Subject: Especialize --- lib/basis.urs | 3 + src/compiler.sig | 2 + src/compiler.sml | 9 ++- src/core_env.sig | 3 + src/core_env.sml | 29 +++++++++ src/core_util.sig | 5 ++ src/core_util.sml | 7 +++ src/especialize.sig | 32 ++++++++++ src/especialize.sml | 176 ++++++++++++++++++++++++++++++++++++++++++++++++++++ src/reduce.sml | 32 +--------- src/sources | 3 + 11 files changed, 270 insertions(+), 31 deletions(-) create mode 100644 src/especialize.sig create mode 100644 src/especialize.sml (limited to 'src/compiler.sig') diff --git a/lib/basis.urs b/lib/basis.urs index 8992bc8c..0e6b9988 100644 --- a/lib/basis.urs +++ b/lib/basis.urs @@ -352,6 +352,9 @@ val tt : bodyTag [] val font : bodyTag [Size = int, Face = string] val h1 : bodyTag [] +val h2 : bodyTag [] +val h3 : bodyTag [] +val h4 : bodyTag [] val li : bodyTag [] val hr : bodyTag [] diff --git a/src/compiler.sig b/src/compiler.sig index 0c95934a..e26ec13c 100644 --- a/src/compiler.sig +++ b/src/compiler.sig @@ -61,6 +61,7 @@ signature COMPILER = sig val termination : (Elab.file, Elab.file) phase val explify : (Elab.file, Expl.file) phase val corify : (Expl.file, Core.file) phase + val especialize : (Core.file, Core.file) phase val shake : (Core.file, Core.file) phase val tag : (Core.file, Core.file) phase val reduce : (Core.file, Core.file) phase @@ -82,6 +83,7 @@ signature COMPILER = sig val toTermination : (string, Elab.file) transform val toExplify : (string, Expl.file) transform val toCorify : (string, Core.file) transform + val toEspecialize : (string, Core.file) transform val toShake1 : (string, Core.file) transform val toTag : (string, Core.file) transform val toReduce : (string, Core.file) transform diff --git a/src/compiler.sml b/src/compiler.sml index 1f88705c..4f1bce11 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -404,12 +404,19 @@ val corify = { val toCorify = transform corify "corify" o toExplify +val especialize = { + func = ESpecialize.specialize, + print = CorePrint.p_file CoreEnv.empty +} + +val toEspecialize = transform especialize "especialize" o toCorify + val shake = { func = Shake.shake, print = CorePrint.p_file CoreEnv.empty } -val toShake1 = transform shake "shake1" o toCorify +val toShake1 = transform shake "shake1" o toEspecialize val tag = { func = Tag.tag, diff --git a/src/core_env.sig b/src/core_env.sig index cdbf5946..98e345cc 100644 --- a/src/core_env.sig +++ b/src/core_env.sig @@ -33,6 +33,9 @@ signature CORE_ENV = sig val liftConInExp : int -> Core.exp -> Core.exp val subConInExp : (int * Core.con) -> Core.exp -> Core.exp + val liftExpInExp : int -> Core.exp -> Core.exp + val subExpInExp : (int * Core.exp) -> Core.exp -> Core.exp + type env val empty : env diff --git a/src/core_env.sml b/src/core_env.sml index b399f62f..0faf5aab 100644 --- a/src/core_env.sml +++ b/src/core_env.sml @@ -93,6 +93,35 @@ val subConInExp = bind = fn ((xn, rep), U.Exp.RelC _) => (xn+1, liftConInCon 0 rep) | (ctx, _) => ctx} +val liftExpInExp = + U.Exp.mapB {kind = fn k => k, + con = fn _ => fn c => c, + exp = fn bound => fn e => + case e of + ERel xn => + if xn < bound then + e + else + ERel (xn + 1) + | _ => e, + bind = fn (bound, U.Exp.RelE _) => bound + 1 + | (bound, _) => bound} + +val subExpInExp = + U.Exp.mapB {kind = fn k => k, + con = fn _ => fn c => c, + exp = fn (xn, rep) => fn e => + case e of + ERel xn' => + (case Int.compare (xn', xn) of + EQUAL => #1 rep + | GREATER=> ERel (xn' - 1) + | LESS => e) + | _ => e, + bind = fn ((xn, rep), U.Exp.RelE _) => (xn+1, liftExpInExp 0 rep) + | ((xn, rep), U.Exp.RelC _) => (xn, liftConInExp 0 rep) + | (ctx, _) => ctx} + (* Back to environments *) exception UnboundRel of int diff --git a/src/core_util.sig b/src/core_util.sig index 43750698..2ae75305 100644 --- a/src/core_util.sig +++ b/src/core_util.sig @@ -107,6 +107,11 @@ structure Exp : sig val exists : {kind : Core.kind' -> bool, con : Core.con' -> bool, exp : Core.exp' -> bool} -> Core.exp -> bool + + val foldMap : {kind : Core.kind' * 'state -> Core.kind' * 'state, + con : Core.con' * 'state -> Core.con' * 'state, + exp : Core.exp' * 'state -> Core.exp' * 'state} + -> 'state -> Core.exp -> Core.exp * 'state end structure Decl : sig diff --git a/src/core_util.sml b/src/core_util.sml index 49182c09..df8465ae 100644 --- a/src/core_util.sml +++ b/src/core_util.sml @@ -578,6 +578,13 @@ fun exists {kind, con, exp} k = S.Return _ => true | S.Continue _ => false +fun foldMap {kind, con, exp} s e = + case mapfold {kind = fn k => fn s => S.Continue (kind (k, s)), + con = fn c => fn s => S.Continue (con (c, s)), + exp = fn e => fn s => S.Continue (exp (e, s))} e s of + S.Continue v => v + | S.Return _ => raise Fail "CoreUtil.Exp.foldMap: Impossible" + end structure Decl = struct diff --git a/src/especialize.sig b/src/especialize.sig new file mode 100644 index 00000000..df83e81b --- /dev/null +++ b/src/especialize.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 ESPECIALIZE = sig + + val specialize : Core.file -> Core.file + +end diff --git a/src/especialize.sml b/src/especialize.sml new file mode 100644 index 00000000..a316ffaa --- /dev/null +++ b/src/especialize.sml @@ -0,0 +1,176 @@ +(* 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 ESpecialize :> ESPECIALIZE = struct + +open Core + +structure E = CoreEnv +structure U = CoreUtil + +structure ILK = struct +type ord_key = int list +val compare = Order.joinL Int.compare +end + +structure ILM = BinaryMapFn(ILK) +structure IM = IntBinaryMap + +type func = { + name : string, + args : int ILM.map, + body : exp, + typ : con, + tag : string +} + +type state = { + maxName : int, + funcs : func IM.map, + decls : (string * int * con * exp * string) list +} + +fun kind (k, st) = (k, st) +fun con (c, st) = (c, st) + +fun exp (e, st : state) = + let + fun getApp e = + case e of + ENamed f => SOME (f, [], []) + | EApp (e1, (ENamed x, _)) => + (case getApp (#1 e1) of + NONE => NONE + | SOME (f, xs, xs') => SOME (f, xs @ [x], xs')) + | EApp (e1, e2) => + (case getApp (#1 e1) of + NONE => NONE + | SOME (f, xs, xs') => SOME (f, xs, xs' @ [e2])) + | _ => NONE + in + case getApp e of + NONE => (e, st) + | SOME (_, [], _) => (e, st) + | SOME (f, xs, xs') => + case IM.find (#funcs st, f) of + NONE => (e, st) + | SOME {name, args, body, typ, tag} => + case ILM.find (args, xs) of + SOME f' => (#1 (foldl (fn (e, arg) => (EApp (e, arg), ErrorMsg.dummySpan)) + (ENamed f', ErrorMsg.dummySpan) xs'), + st) + | NONE => + let + fun subBody (body, typ, xs) = + case (#1 body, #1 typ, xs) of + (_, _, []) => SOME (body, typ) + | (EAbs (_, _, _, body'), TFun (_, typ'), x :: xs) => + subBody (E.subExpInExp (0, (ENamed x, ErrorMsg.dummySpan)) body', + typ', + xs) + | _ => NONE + in + case subBody (body, typ, xs) of + NONE => (e, st) + | SOME (body', typ') => + let + val f' = #maxName st + val funcs = IM.insert (#funcs st, f, {name = name, + args = ILM.insert (args, xs, f'), + body = body, + typ = typ, + tag = tag}) + val st = { + maxName = f' + 1, + funcs = funcs, + decls = #decls st + } + + val (body', st) = specExp st body' + val e' = foldl (fn (e, arg) => (EApp (e, arg), ErrorMsg.dummySpan)) + (ENamed f', ErrorMsg.dummySpan) xs' + in + (#1 e', + {maxName = #maxName st, + funcs = #funcs st, + decls = (name, f', typ', body', tag ^ "_espec") :: #decls st}) + end + end + end + +and specExp st = U.Exp.foldMap {kind = kind, con = con, exp = exp} st + +fun decl (d, st) = (d, st) + +val specDecl = U.Decl.foldMap {kind = kind, con = con, exp = exp, decl = decl} + +fun specialize file = + let + fun doDecl (d, st) = + let + val (d', st) = specDecl st d + + val funcs = #funcs st + val funcs = + case #1 d of + DVal (x, n, c, e as (EAbs _, _), tag) => + IM.insert (funcs, n, {name = x, + args = ILM.empty, + body = e, + typ = c, + tag = tag}) + | DValRec vis => + foldl (fn ((x, n, c, e, tag), funcs) => + IM.insert (funcs, n, {name = x, + args = ILM.empty, + body = e, + typ = c, + tag = tag})) + funcs vis + | _ => funcs + + val ds = + case #decls st of + [] => [d'] + | vis => [(DValRec vis, ErrorMsg.dummySpan), d'] + in + (ds, {maxName = #maxName st, + funcs = funcs, + decls = []}) + end + + val (ds, _) = ListUtil.foldlMapConcat doDecl + {maxName = U.File.maxName file + 1, + funcs = IM.empty, + decls = []} + file + in + ds + end + + +end diff --git a/src/reduce.sml b/src/reduce.sml index 927c8ff1..8dc4527f 100644 --- a/src/reduce.sml +++ b/src/reduce.sml @@ -37,36 +37,8 @@ structure U = CoreUtil val liftConInCon = E.liftConInCon val subConInCon = E.subConInCon val liftConInExp = E.liftConInExp - -val liftExpInExp = - U.Exp.mapB {kind = fn k => k, - con = fn _ => fn c => c, - exp = fn bound => fn e => - case e of - ERel xn => - if xn < bound then - e - else - ERel (xn + 1) - | _ => e, - bind = fn (bound, U.Exp.RelE _) => bound + 1 - | (bound, _) => bound} - -val subExpInExp = - U.Exp.mapB {kind = fn k => k, - con = fn _ => fn c => c, - exp = fn (xn, rep) => fn e => - case e of - ERel xn' => - (case Int.compare (xn', xn) of - EQUAL => #1 rep - | GREATER=> ERel (xn' - 1) - | LESS => e) - | _ => e, - bind = fn ((xn, rep), U.Exp.RelE _) => (xn+1, liftExpInExp 0 rep) - | ((xn, rep), U.Exp.RelC _) => (xn, liftConInExp 0 rep) - | (ctx, _) => ctx} - +val liftExpInExp = E.liftExpInExp +val subExpInExp = E.subExpInExp val liftConInExp = E.liftConInExp val subConInExp = E.subConInExp diff --git a/src/sources b/src/sources index 3568279c..ebf71d9e 100644 --- a/src/sources +++ b/src/sources @@ -93,6 +93,9 @@ unpoly.sml specialize.sig specialize.sml +especialize.sig +especialize.sml + tag.sig tag.sml -- cgit v1.2.3 From cfb8ffaf94885d8dc1b492a050830a9b4ffc3d04 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 1 Nov 2008 15:58:55 -0400 Subject: First Unnest tests working --- src/compiler.sig | 2 + src/compiler.sml | 9 +- src/elab_env.sig | 4 + src/elab_env.sml | 29 +++++ src/elab_print.sml | 4 +- src/elab_util.sig | 25 ++++ src/elab_util.sml | 107 ++++++++++++++- src/sources | 3 + src/termination.sml | 2 + src/unnest.sig | 34 +++++ src/unnest.sml | 369 ++++++++++++++++++++++++++++++++++++++++++++++++++++ tests/nest.ur | 41 ++++++ tests/nest.urp | 3 + 13 files changed, 627 insertions(+), 5 deletions(-) create mode 100644 src/unnest.sig create mode 100644 src/unnest.sml create mode 100644 tests/nest.ur create mode 100644 tests/nest.urp (limited to 'src/compiler.sig') diff --git a/src/compiler.sig b/src/compiler.sig index e26ec13c..bc1974a1 100644 --- a/src/compiler.sig +++ b/src/compiler.sig @@ -58,6 +58,7 @@ signature COMPILER = sig val parse : (job, Source.file) phase val elaborate : (Source.file, Elab.file) phase + val unnest : (Elab.file, Elab.file) phase val termination : (Elab.file, Elab.file) phase val explify : (Elab.file, Expl.file) phase val corify : (Expl.file, Core.file) phase @@ -80,6 +81,7 @@ signature COMPILER = sig val toParseJob : (string, job) transform val toParse : (string, Source.file) transform val toElaborate : (string, Elab.file) transform + val toUnnest : (string, Elab.file) transform val toTermination : (string, Elab.file) transform val toExplify : (string, Expl.file) transform val toCorify : (string, Core.file) transform diff --git a/src/compiler.sml b/src/compiler.sml index 4f1bce11..e92f86c3 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -383,12 +383,19 @@ val elaborate = { 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 toElaborate +val toTermination = transform termination "termination" o toUnnest val explify = { func = Explify.explify, diff --git a/src/elab_env.sig b/src/elab_env.sig index 727ee259..90cf8153 100644 --- a/src/elab_env.sig +++ b/src/elab_env.sig @@ -30,6 +30,10 @@ signature ELAB_ENV = sig exception SynUnif val liftConInCon : int -> Elab.con -> Elab.con + val liftExpInExp : int -> Elab.exp -> Elab.exp + + val subExpInExp : (int * Elab.exp) -> Elab.exp -> Elab.exp + type env val empty : env diff --git a/src/elab_env.sml b/src/elab_env.sml index f4f5d2cb..2732de13 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -61,6 +61,20 @@ val liftConInCon = val lift = liftConInCon 0 +val liftConInExp = + U.Exp.mapB {kind = fn k => k, + con = fn bound => fn c => + case c of + CRel xn => + if xn < bound then + c + else + CRel (xn + 1) + | _ => c, + exp = fn _ => fn e => e, + bind = fn (bound, U.Exp.RelC _) => bound + 1 + | (bound, _) => bound} + val liftExpInExp = U.Exp.mapB {kind = fn k => k, con = fn _ => fn c => c, @@ -78,6 +92,21 @@ val liftExpInExp = val liftExp = liftExpInExp 0 +val subExpInExp = + U.Exp.mapB {kind = fn k => k, + con = fn _ => fn c => c, + exp = fn (xn, rep) => fn e => + case e of + ERel xn' => + (case Int.compare (xn', xn) of + EQUAL => #1 rep + | GREATER=> ERel (xn' - 1) + | LESS => e) + | _ => e, + bind = fn ((xn, rep), U.Exp.RelE _) => (xn+1, liftExpInExp 0 rep) + | ((xn, rep), U.Exp.RelC _) => (xn, liftConInExp 0 rep) + | (ctx, _) => ctx} + (* Back to environments *) datatype 'a var' = diff --git a/src/elab_print.sml b/src/elab_print.sml index 3d7ce625..b236954e 100644 --- a/src/elab_print.sml +++ b/src/elab_print.sml @@ -198,7 +198,7 @@ fun p_patCon env pc = string (#1 (E.lookupENamed env n) ^ "__" ^ Int.toString n) else string (#1 (E.lookupENamed env n))) - handle E.UnboundRel _ => string ("UNBOUND_NAMED" ^ Int.toString n)) + handle E.UnboundNamed _ => string ("UNBOUND_NAMED" ^ Int.toString n)) | PConProj (m1, ms, x) => let val m1x = #1 (E.lookupStrNamed env m1) @@ -247,7 +247,7 @@ fun p_exp' par env (e, _) = string (#1 (E.lookupENamed env n) ^ "__" ^ Int.toString n) else string (#1 (E.lookupENamed env n))) - handle E.UnboundRel _ => string ("UNBOUND_NAMED" ^ Int.toString n)) + handle E.UnboundNamed _ => string ("UNBOUND_NAMED" ^ Int.toString n)) | EModProj (m1, ms, x) => let val m1x = #1 (E.lookupStrNamed env m1) diff --git a/src/elab_util.sig b/src/elab_util.sig index f4edd972..f9988981 100644 --- a/src/elab_util.sig +++ b/src/elab_util.sig @@ -57,6 +57,11 @@ structure Con : sig -> Elab.con -> Elab.con val exists : {kind : Elab.kind' -> bool, con : Elab.con' -> bool} -> Elab.con -> bool + + val foldB : {kind : Elab.kind' * 'state -> 'state, + con : 'context * Elab.con' * 'state -> 'state, + bind : 'context * binder -> 'context} + -> 'context -> 'state -> Elab.con -> 'state end structure Exp : sig @@ -83,6 +88,12 @@ structure Exp : sig val exists : {kind : Elab.kind' -> bool, con : Elab.con' -> bool, exp : Elab.exp' -> bool} -> Elab.exp -> bool + + val foldB : {kind : Elab.kind' * 'state -> 'state, + con : 'context * Elab.con' * 'state -> 'state, + exp : 'context * Elab.exp' * 'state -> 'state, + bind : 'context * binder -> 'context} + -> 'context -> 'state -> Elab.exp -> 'state end structure Sgn : sig @@ -156,6 +167,20 @@ structure Decl : sig str : Elab.str' -> 'a option, decl : Elab.decl' -> 'a option} -> Elab.decl -> 'a option + + val foldMapB : {kind : Elab.kind' * 'state -> Elab.kind' * 'state, + con : 'context * Elab.con' * 'state -> Elab.con' * 'state, + exp : 'context * Elab.exp' * 'state -> Elab.exp' * 'state, + sgn_item : 'context * Elab.sgn_item' * 'state -> Elab.sgn_item' * 'state, + sgn : 'context * Elab.sgn' * 'state -> Elab.sgn' * 'state, + str : 'context * Elab.str' * 'state -> Elab.str' * 'state, + decl : 'context * Elab.decl' * 'state -> Elab.decl' * 'state, + bind : 'context * binder -> 'context} + -> 'context -> 'state -> Elab.decl -> Elab.decl * 'state +end + +structure File : sig + val maxName : Elab.file -> int end end diff --git a/src/elab_util.sml b/src/elab_util.sml index 28fe8f22..2e190d1e 100644 --- a/src/elab_util.sml +++ b/src/elab_util.sml @@ -226,6 +226,13 @@ fun exists {kind, con} k = S.Return _ => true | S.Continue _ => false +fun foldB {kind, con, bind} ctx st c = + case mapfoldB {kind = fn k => fn st => S.Continue (k, kind (k, st)), + con = fn ctx => fn c => fn st => S.Continue (c, con (ctx, c, st)), + bind = bind} ctx c st of + S.Continue (_, st) => st + | S.Return _ => raise Fail "ElabUtil.Con.foldB: Impossible" + end structure Exp = struct @@ -340,8 +347,20 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, bind} = S.bind2 (mfe ctx e, fn e' => S.bind2 (ListUtil.mapfold (fn (p, e) => - S.map2 (mfe ctx e, - fn e' => (p, e'))) pes, + let + fun pb ((p, _), ctx) = + case p of + PWild => ctx + | PVar (x, t) => bind (ctx, RelE (x, t)) + | PPrim _ => ctx + | PCon (_, _, _, NONE) => ctx + | PCon (_, _, _, SOME p) => pb (p, ctx) + | PRecord xps => foldl (fn ((_, p, _), ctx) => + pb (p, ctx)) ctx xps + in + S.map2 (mfe (pb (p, ctx)) e, + fn e' => (p, e')) + end) pes, fn pes' => S.bind2 (mfc ctx disc, fn disc' => @@ -431,6 +450,14 @@ fun mapB {kind, con, exp, bind} ctx e = S.Continue (e, ()) => e | S.Return _ => raise Fail "ElabUtil.Exp.mapB: Impossible" +fun foldB {kind, con, exp, bind} ctx st e = + case mapfoldB {kind = fn k => fn st => S.Continue (k, kind (k, st)), + con = fn ctx => fn c => fn st => S.Continue (c, con (ctx, c, st)), + exp = fn ctx => fn e => fn st => S.Continue (e, exp (ctx, e, st)), + bind = bind} ctx e st of + S.Continue (_, st) => st + | S.Return _ => raise Fail "ElabUtil.Exp.foldB: Impossible" + end structure Sgn = struct @@ -888,6 +915,82 @@ fun search {kind, con, exp, sgn_item, sgn, str, decl} k = S.Return x => SOME x | S.Continue _ => NONE +fun foldMapB {kind, con, exp, sgn_item, sgn, str, decl, bind} ctx st d = + case mapfoldB {kind = fn x => fn st => S.Continue (kind (x, st)), + con = fn ctx => fn x => fn st => S.Continue (con (ctx, x, st)), + exp = fn ctx => fn x => fn st => S.Continue (exp (ctx, x, st)), + sgn_item = fn ctx => fn x => fn st => S.Continue (sgn_item (ctx, x, st)), + sgn = fn ctx => fn x => fn st => S.Continue (sgn (ctx, x, st)), + str = fn ctx => fn x => fn st => S.Continue (str (ctx, x, st)), + decl = fn ctx => fn x => fn st => S.Continue (decl (ctx, x, st)), + bind = bind} ctx d st of + S.Continue x => x + | S.Return _ => raise Fail "ElabUtil.Decl.foldMapB: Impossible" + +end + +structure File = struct + +fun maxName ds = foldl (fn (d, count) => Int.max (maxNameDecl d, count)) 0 ds + +and maxNameDecl (d, _) = + case d of + DCon (_, n, _, _) => n + | DDatatype (_, n, _, ns) => + foldl (fn ((_, n', _), m) => Int.max (n', m)) + n ns + | DDatatypeImp (_, n1, n2, _, _, _, ns) => + foldl (fn ((_, n', _), m) => Int.max (n', m)) + (Int.max (n1, n2)) ns + | DVal (_, n, _, _) => n + | DValRec vis => foldl (fn ((_, n, _, _), count) => Int.max (n, count)) 0 vis + | DStr (_, n, sgn, str) => Int.max (n, Int.max (maxNameSgn sgn, maxNameStr str)) + | DSgn (_, n, sgn) => Int.max (n, maxNameSgn sgn) + | DFfiStr (_, n, sgn) => Int.max (n, maxNameSgn sgn) + | DConstraint _ => 0 + | DClass (_, n, _) => n + | DExport _ => 0 + | DTable (n, _, _, _) => n + | DSequence (n, _, _) => n + | DDatabase _ => 0 + +and maxNameStr (str, _) = + case str of + StrConst ds => maxName ds + | StrVar n => n + | StrProj (str, _) => maxNameStr str + | StrFun (_, n, dom, ran, str) => foldl Int.max n [maxNameSgn dom, maxNameSgn ran, maxNameStr str] + | StrApp (str1, str2) => Int.max (maxNameStr str1, maxNameStr str2) + | StrError => 0 + +and maxNameSgn (sgn, _) = + case sgn of + SgnConst sgis => foldl (fn (sgi, count) => Int.max (maxNameSgi sgi, count)) 0 sgis + | SgnVar n => n + | SgnFun (_, n, dom, ran) => Int.max (n, Int.max (maxNameSgn dom, maxNameSgn ran)) + | SgnWhere (sgn, _, _) => maxNameSgn sgn + | SgnProj (n, _, _) => n + | SgnError => 0 + +and maxNameSgi (sgi, _) = + case sgi of + SgiConAbs (_, n, _) => n + | SgiCon (_, n, _, _) => n + | SgiDatatype (_, n, _, ns) => + foldl (fn ((_, n', _), m) => Int.max (n', m)) + n ns + | SgiDatatypeImp (_, n1, n2, _, _, _, ns) => + foldl (fn ((_, n', _), m) => Int.max (n', m)) + (Int.max (n1, n2)) ns + | SgiVal (_, n, _) => n + | SgiStr (_, n, sgn) => Int.max (n, maxNameSgn sgn) + | SgiSgn (_, n, sgn) => Int.max (n, maxNameSgn sgn) + | SgiConstraint _ => 0 + | SgiTable (n, _, _, _) => n + | SgiSequence (n, _, _) => n + | SgiClassAbs (_, n) => n + | SgiClass (_, n, _) => n + end end diff --git a/src/sources b/src/sources index ebf71d9e..984b5e23 100644 --- a/src/sources +++ b/src/sources @@ -50,6 +50,9 @@ elab_err.sml elaborate.sig elaborate.sml +unnest.sig +unnest.sml + termination.sig termination.sml diff --git a/src/termination.sml b/src/termination.sml index b0716eca..6ed4d92f 100644 --- a/src/termination.sml +++ b/src/termination.sml @@ -292,6 +292,8 @@ fun declOk' env (d, loc) = | EError => (Rabble, calls) | EUnif (ref (SOME e)) => exp parent (penv, calls) e | EUnif (ref NONE) => (Rabble, calls) + + | ELet (_, e) => exp parent (penv, calls) e end fun doVali (i, (_, f, _, e), calls) = diff --git a/src/unnest.sig b/src/unnest.sig new file mode 100644 index 00000000..6508a781 --- /dev/null +++ b/src/unnest.sig @@ -0,0 +1,34 @@ +(* 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. + *) + +(* Remove nested function definitions *) + +signature UNNEST = sig + + val unnest : Elab.file -> Elab.file + +end diff --git a/src/unnest.sml b/src/unnest.sml new file mode 100644 index 00000000..e5eddc42 --- /dev/null +++ b/src/unnest.sml @@ -0,0 +1,369 @@ +(* 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. + *) + +(* Remove nested function definitions *) + +structure Unnest :> UNNEST = struct + +open Elab + +structure E = ElabEnv +structure U = ElabUtil + +structure IS = IntBinarySet + +val fvsCon = U.Con.foldB {kind = fn (_, st) => st, + con = fn (cb, c, cvs) => + case c of + CRel n => + if n >= cb then + IS.add (cvs, n - cb) + else + cvs + | _ => cvs, + bind = fn (cb, b) => + case b of + U.Con.Rel _ => cb + 1 + | _ => cb} + 0 IS.empty + +fun fvsExp nr = U.Exp.foldB {kind = fn (_, st) => st, + con = fn ((cb, eb), c, st as (cvs, evs)) => + case c of + CRel n => + if n >= cb then + (IS.add (cvs, n - cb), evs) + else + st + | _ => st, + exp = fn ((cb, eb), e, st as (cvs, evs)) => + case e of + ERel n => + if n >= eb then + (cvs, IS.add (evs, n - eb)) + else + st + | _ => st, + bind = fn (ctx as (cb, eb), b) => + case b of + U.Exp.RelC _ => (cb + 1, eb) + | U.Exp.RelE _ => (cb, eb + 1) + | _ => ctx} + (0, nr) (IS.empty, IS.empty) + +fun positionOf (x : int) ls = + let + fun po n ls = + case ls of + [] => raise Fail "Unnest.positionOf" + | x' :: ls' => + if x' = x then + n + else + po (n + 1) ls' + in + po 0 ls + handle Fail _ => raise Fail ("Unnset.positionOf(" + ^ Int.toString x + ^ ", " + ^ String.concatWith ";" (map Int.toString ls) + ^ ")") + end + +fun squishCon cfv = + U.Con.mapB {kind = fn k => k, + con = fn cb => fn c => + case c of + CRel n => + if n >= cb then + CRel (positionOf (n - cb) cfv + cb) + else + c + | _ => c, + bind = fn (cb, b) => + case b of + U.Con.Rel _ => cb + 1 + | _ => cb} + 0 + +fun squishExp (nr, cfv, efv) = + U.Exp.mapB {kind = fn k => k, + con = fn (cb, eb) => fn c => + case c of + CRel n => + if n >= cb then + CRel (positionOf (n - cb) cfv + cb) + else + c + | _ => c, + exp = fn (cb, eb) => fn e => + case e of + ERel n => + if n >= eb then + ERel (positionOf (n - eb) efv + eb) + else + e + | _ => e, + bind = fn (ctx as (cb, eb), b) => + case b of + U.Exp.RelC _ => (cb + 1, eb) + | U.Exp.RelE _ => (cb, eb + 1) + | _ => ctx} + (0, nr) + +type state = { + maxName : int, + decls : decl list +} + +fun kind (k, st) = (k, st) + +fun exp ((ks, ts), e, st : state) = + case e of + ELet (eds, e) => + let + val doSubst = foldl (fn (p, e) => E.subExpInExp p e) + + val (eds, (maxName, ds, subs)) = + ListUtil.foldlMapConcat + (fn (ed, (maxName, ds, subs)) => + case #1 ed of + EDVal _ => ([ed], (maxName, ds, map (fn (n, e) => (n + 1, E.liftExpInExp 0 e)) subs)) + | EDValRec vis => + let + val loc = #2 ed + + val nr = length vis + val (cfv, efv) = foldl (fn ((_, t, e), (cfv, efv)) => + let + val (cfv', efv') = fvsExp nr e + (*val () = Print.prefaces "fvsExp" + [("e", ElabPrint.p_exp E.empty e), + ("cfv", Print.PD.string + (Int.toString (IS.numItems cfv'))), + ("efv", Print.PD.string + (Int.toString (IS.numItems efv')))]*) + val cfv'' = fvsCon t + in + (IS.union (cfv, IS.union (cfv', cfv'')), + IS.union (efv, efv')) + end) + (IS.empty, IS.empty) vis + + (*val () = print ("A: " ^ Int.toString (length ts) ^ ", " ^ Int.toString (length ks) ^ "\n")*) + val cfv = IS.foldl (fn (x, cfv) => + let + (*val () = print (Int.toString x ^ "\n")*) + val (_, t) = List.nth (ts, x) + in + IS.union (cfv, fvsCon t) + end) + cfv efv + (*val () = print "B\n"*) + + val (vis, maxName) = + ListUtil.foldlMap (fn ((x, t, e), maxName) => + ((x, maxName, t, e), + maxName + 1)) + maxName vis + + fun apply e = + let + val e = IS.foldl (fn (x, e) => + (ECApp (e, (CRel x, loc)), loc)) + e cfv + in + IS.foldl (fn (x, e) => + (EApp (e, (ERel x, loc)), loc)) + e efv + end + + val subs = map (fn (n, e) => (n + nr, E.liftExpInExp nr e)) subs + + val subs' = ListUtil.mapi (fn (i, (_, n, _, _)) => + let + val e = apply (ENamed n, loc) + in + (0, E.liftExpInExp (nr - i - 1) e) + end) + vis + val subs' = rev subs' + + val cfv = IS.listItems cfv + val efv = IS.listItems efv + val efn = length efv + + (*val subsInner = subs + @ map (fn (i, e) => + (i + efn, + E.liftExpInExp efn e)) subs'*) + + val subs = subs @ subs' + + val vis = map (fn (x, n, t, e) => + let + (*val () = Print.prefaces "preSubst" + [("e", ElabPrint.p_exp E.empty e)]*) + val e = doSubst e subs(*Inner*) + + (*val () = Print.prefaces "squishCon" + [("t", ElabPrint.p_con E.empty t)]*) + val t = squishCon cfv t + (*val () = Print.prefaces "squishExp" + [("e", ElabPrint.p_exp E.empty e)]*) + val e = squishExp (nr, cfv, efv) e + + val (e, t) = foldr (fn (ex, (e, t)) => + let + val (name, t') = List.nth (ts, ex) + in + ((EAbs (name, + t', + t, + e), loc), + (TFun (t', + t), loc)) + end) + (e, t) efv + + val (e, t) = foldr (fn (cx, (e, t)) => + let + val (name, k) = List.nth (ks, cx) + in + ((ECAbs (Explicit, + name, + k, + e), loc), + (TCFun (Explicit, + name, + k, + t), loc)) + end) + (e, t) cfv + in + (x, n, t, e) + end) + vis + + val d = (DValRec vis, #2 ed) + in + ([], (maxName, d :: ds, subs)) + end) + (#maxName st, #decls st, []) eds + in + (ELet (eds, doSubst e subs), + {maxName = maxName, + decls = ds}) + end + + | _ => (e, st) + +fun default (ctx, d, st) = (d, st) + +fun bind ((ks, ts), b) = + case b of + U.Decl.RelC p => (p :: ks, map (fn (name, t) => (name, E.liftConInCon 0 t)) ts) + | U.Decl.RelE p => (ks, p :: ts) + | _ => (ks, ts) + +val unnestDecl = U.Decl.foldMapB {kind = kind, + con = default, + exp = exp, + sgn_item = default, + sgn = default, + str = default, + decl = default, + bind = bind} + ([], []) + +fun unnest file = + let + fun doDecl (all as (d, loc), st : state) = + let + fun default () = ([all], st) + fun explore () = + let + val (d, st) = unnestDecl st all + in + (rev (d :: #decls st), + {maxName = #maxName st, + decls = []}) + end + in + case d of + DCon _ => default () + | DDatatype _ => default () + | DDatatypeImp _ => default () + | DVal _ => explore () + | DValRec _ => explore () + | DSgn _ => default () + | DStr (x, n, sgn, str) => + let + val (str, st) = doStr (str, st) + in + ([(DStr (x, n, sgn, str), loc)], st) + end + | DFfiStr _ => default () + | DConstraint _ => default () + | DExport _ => default () + | DTable _ => default () + | DSequence _ => default () + | DClass _ => default () + | DDatabase _ => default () + end + + and doStr (all as (str, loc), st) = + let + fun default () = (all, st) + in + case str of + StrConst ds => + let + val (ds, st) = ListUtil.foldlMapConcat doDecl st ds + in + ((StrConst ds, loc), st) + end + | StrVar _ => default () + | StrProj _ => default () + | StrFun (x, n, dom, ran, str) => + let + val (str, st) = doStr (str, st) + in + ((StrFun (x, n, dom, ran, str), loc), st) + end + | StrApp _ => default () + | StrError => raise Fail "Unnest: StrError" + end + + val (ds, _) = ListUtil.foldlMapConcat doDecl + {maxName = U.File.maxName file + 1, + decls = []} file + in + ds + end + +end diff --git a/tests/nest.ur b/tests/nest.ur new file mode 100644 index 00000000..c136b1e6 --- /dev/null +++ b/tests/nest.ur @@ -0,0 +1,41 @@ +fun add x = + let + fun add' y = x + y + in + add' 1 + add' 2 + end + +fun f (x : int) = + let + fun page () = return + {[x]} + + in + page + end + +fun f (x : int) = + let + fun page1 () = return + {[x]} + + + and page2 () = + case Some True of + Some r => return {[r]} + | _ => return Error + in + page1 + end + +datatype list t = Nil | Cons of t * list t + +fun length (t ::: Type) (ls : list t) = + let + fun length' ls acc = + case ls of + Nil => acc + | Cons (_, ls') => length' ls' (acc + 1) + in + length' ls 0 + end diff --git a/tests/nest.urp b/tests/nest.urp new file mode 100644 index 00000000..7f8a473a --- /dev/null +++ b/tests/nest.urp @@ -0,0 +1,3 @@ +debug + +nest -- cgit v1.2.3 From 24483b49c81a6ac1c99cd28ca3505150b5999863 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 1 Nov 2008 21:24:43 -0400 Subject: Nested save compiles --- src/compiler.sig | 2 + src/compiler.sml | 9 ++- src/core_untangle.sig | 32 ++++++++ src/core_untangle.sml | 215 ++++++++++++++++++++++++++++++++++++++++++++++++++ src/sources | 3 + 5 files changed, 260 insertions(+), 1 deletion(-) create mode 100644 src/core_untangle.sig create mode 100644 src/core_untangle.sml (limited to 'src/compiler.sig') diff --git a/src/compiler.sig b/src/compiler.sig index bc1974a1..6094da89 100644 --- a/src/compiler.sig +++ b/src/compiler.sig @@ -63,6 +63,7 @@ signature COMPILER = sig val explify : (Elab.file, Expl.file) phase val corify : (Expl.file, Core.file) phase val especialize : (Core.file, Core.file) phase + val core_untangle : (Core.file, Core.file) phase val shake : (Core.file, Core.file) phase val tag : (Core.file, Core.file) phase val reduce : (Core.file, Core.file) phase @@ -86,6 +87,7 @@ signature COMPILER = sig val toExplify : (string, Expl.file) transform val toCorify : (string, Core.file) transform val toEspecialize : (string, Core.file) transform + val toCore_untangle : (string, Core.file) transform val toShake1 : (string, Core.file) transform val toTag : (string, Core.file) transform val toReduce : (string, Core.file) transform diff --git a/src/compiler.sml b/src/compiler.sml index e92f86c3..1124bfda 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -418,12 +418,19 @@ val especialize = { val toEspecialize = transform especialize "especialize" o toCorify +val core_untangle = { + func = CoreUntangle.untangle, + print = CorePrint.p_file CoreEnv.empty +} + +val toCore_untangle = transform core_untangle "core_untangle" o toEspecialize + val shake = { func = Shake.shake, print = CorePrint.p_file CoreEnv.empty } -val toShake1 = transform shake "shake1" o toEspecialize +val toShake1 = transform shake "shake1" o toCore_untangle val tag = { func = Tag.tag, diff --git a/src/core_untangle.sig b/src/core_untangle.sig new file mode 100644 index 00000000..86e039e4 --- /dev/null +++ b/src/core_untangle.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 CORE_UNTANGLE = sig + + val untangle : Core.file -> Core.file + +end diff --git a/src/core_untangle.sml b/src/core_untangle.sml new file mode 100644 index 00000000..6f424614 --- /dev/null +++ b/src/core_untangle.sml @@ -0,0 +1,215 @@ +(* 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 CoreUntangle :> CORE_UNTANGLE = struct + +open Core + +structure U = CoreUtil +structure E = CoreEnv + +structure IS = IntBinarySet +structure IM = IntBinaryMap + +fun default (k, s) = s + +fun exp (e, s) = + case e of + ENamed n => IS.add (s, n) + + | _ => s + +fun untangle file = + let + fun decl (dAll as (d, loc)) = + case d of + DValRec vis => + let + val thisGroup = foldl (fn ((_, n, _, _, _), thisGroup) => + IS.add (thisGroup, n)) IS.empty vis + + val used = foldl (fn ((_, n, _, e, _), used) => + let + val usedHere = U.Exp.fold {con = default, + kind = default, + exp = exp} IS.empty e + in + IM.insert (used, n, IS.intersection (usedHere, thisGroup)) + end) + IM.empty vis + + fun p_graph reachable = + IM.appi (fn (n, reachableHere) => + (print (Int.toString n); + print ":"; + IS.app (fn n' => (print " "; + print (Int.toString n'))) reachableHere; + print "\n")) reachable + + (*val () = print "used:\n" + val () = p_graph used*) + + fun expand reachable = + let + val changed = ref false + + val reachable = + IM.mapi (fn (n, reachableHere) => + IS.foldl (fn (n', reachableHere) => + let + val more = valOf (IM.find (reachable, n')) + in + if IS.isEmpty (IS.difference (more, reachableHere)) then + reachableHere + else + (changed := true; + IS.union (more, reachableHere)) + end) + reachableHere reachableHere) reachable + in + (reachable, !changed) + end + + fun iterate reachable = + let + val (reachable, changed) = expand reachable + in + if changed then + iterate reachable + else + reachable + end + + val reachable = iterate used + + (*val () = print "reachable:\n" + val () = p_graph reachable*) + + fun sccs (nodes, acc) = + case IS.find (fn _ => true) nodes of + NONE => acc + | SOME rep => + let + val reachableHere = valOf (IM.find (reachable, rep)) + + val (nodes, scc) = IS.foldl (fn (node, (nodes, scc)) => + if node = rep then + (nodes, scc) + else + let + val reachableThere = + valOf (IM.find (reachable, node)) + in + if IS.member (reachableThere, rep) then + (IS.delete (nodes, node), + IS.add (scc, node)) + else + (nodes, scc) + end) + (IS.delete (nodes, rep), IS.singleton rep) reachableHere + in + sccs (nodes, scc :: acc) + end + + val sccs = sccs (thisGroup, []) + (*val () = app (fn nodes => (print "SCC:"; + IS.app (fn i => (print " "; + print (Int.toString i))) nodes; + print "\n")) sccs*) + + fun depends nodes1 nodes2 = + let + val node1 = valOf (IS.find (fn _ => true) nodes1) + val node2 = valOf (IS.find (fn _ => true) nodes2) + val reachable1 = valOf (IM.find (reachable, node1)) + in + IS.member (reachable1, node2) + end + + fun findReady (sccs, passed) = + case sccs of + [] => raise Fail "Untangle: Unable to topologically sort 'val rec'" + | nodes :: sccs => + if List.exists (depends nodes) passed + orelse List.exists (depends nodes) sccs then + findReady (sccs, nodes :: passed) + else + (nodes, List.revAppend (passed, sccs)) + + fun topo (sccs, acc) = + case sccs of + [] => rev acc + | _ => + let + val (node, sccs) = findReady (sccs, []) + in + topo (sccs, node :: acc) + end + + val sccs = topo (sccs, []) + (*val () = app (fn nodes => (print "SCC':"; + IS.app (fn i => (print " "; + print (Int.toString i))) nodes; + print "\n")) sccs*) + + fun isNonrec nodes = + case IS.find (fn _ => true) nodes of + NONE => NONE + | SOME node => + let + val nodes = IS.delete (nodes, node) + val reachableHere = valOf (IM.find (reachable, node)) + in + if IS.isEmpty nodes then + if IS.member (reachableHere, node) then + NONE + else + SOME node + else + NONE + end + + val ds = map (fn nodes => + case isNonrec nodes of + SOME node => + let + val vi = valOf (List.find (fn (_, n, _, _, _) => n = node) vis) + in + (DVal vi, loc) + end + | NONE => + (DValRec (List.filter (fn (_, n, _, _, _) => IS.member (nodes, n)) vis), loc)) + sccs + in + ds + end + | _ => [dAll] + in + ListUtil.mapConcat decl file + end + +end diff --git a/src/sources b/src/sources index 504013d8..9fd90e8c 100644 --- a/src/sources +++ b/src/sources @@ -99,6 +99,9 @@ specialize.sml especialize.sig especialize.sml +core_untangle.sig +core_untangle.sml + tag.sig tag.sml -- cgit v1.2.3 From 6d1ea82d46cb6f34b45d6e5abab29cacf006f1fb Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 9 Nov 2008 16:54:42 -0500 Subject: Defunctionalization gets CommentBlog working --- src/compiler.sig | 2 + src/compiler.sml | 9 +- src/core_util.sig | 12 +++ src/core_util.sml | 17 ++++ src/defunc.sig | 32 +++++++ src/defunc.sml | 256 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ src/sources | 3 + 7 files changed, 330 insertions(+), 1 deletion(-) create mode 100644 src/defunc.sig create mode 100644 src/defunc.sml (limited to 'src/compiler.sig') diff --git a/src/compiler.sig b/src/compiler.sig index 6094da89..402706be 100644 --- a/src/compiler.sig +++ b/src/compiler.sig @@ -65,6 +65,7 @@ signature COMPILER = sig val especialize : (Core.file, Core.file) phase val core_untangle : (Core.file, Core.file) phase val shake : (Core.file, Core.file) phase + val defunc : (Core.file, Core.file) phase val tag : (Core.file, Core.file) phase val reduce : (Core.file, Core.file) phase val unpoly : (Core.file, Core.file) phase @@ -89,6 +90,7 @@ signature COMPILER = sig val toEspecialize : (string, Core.file) transform val toCore_untangle : (string, Core.file) transform val toShake1 : (string, Core.file) transform + val toDefunc : (string, Core.file) transform val toTag : (string, Core.file) transform val toReduce : (string, Core.file) transform val toUnpoly : (string, Core.file) transform diff --git a/src/compiler.sml b/src/compiler.sml index 9705cfaf..93a03169 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -439,12 +439,19 @@ val shake = { val toShake1 = transform shake "shake1" o toCore_untangle +val defunc = { + func = Defunc.defunc, + print = CorePrint.p_file CoreEnv.empty +} + +val toDefunc = transform defunc "defunc" o toShake1 + val tag = { func = Tag.tag, print = CorePrint.p_file CoreEnv.empty } -val toTag = transform tag "tag" o toShake1 +val toTag = transform tag "tag" o toDefunc val reduce = { func = Reduce.reduce, diff --git a/src/core_util.sig b/src/core_util.sig index e435aeaf..100932c3 100644 --- a/src/core_util.sig +++ b/src/core_util.sig @@ -105,6 +105,12 @@ structure Exp : sig con : Core.con' * 'state -> 'state, exp : Core.exp' * 'state -> 'state} -> 'state -> Core.exp -> 'state + + val foldB : {kind : Core.kind' * 'state -> 'state, + con : 'context * Core.con' * 'state -> 'state, + exp : 'context * Core.exp' * 'state -> 'state, + bind : 'context * binder -> 'context} + -> 'context -> 'state -> Core.exp -> 'state val exists : {kind : Core.kind' -> bool, con : Core.con' -> bool, @@ -148,6 +154,12 @@ structure Decl : sig exp : Core.exp' * 'state -> Core.exp' * 'state, decl : Core.decl' * 'state -> Core.decl' * 'state} -> 'state -> Core.decl -> Core.decl * 'state + val foldMapB : {kind : Core.kind' * 'state -> Core.kind' * 'state, + con : 'context * Core.con' * 'state -> Core.con' * 'state, + exp : 'context * Core.exp' * 'state -> Core.exp' * 'state, + decl : 'context * Core.decl' * 'state -> Core.decl' * 'state, + bind : 'context * binder -> 'context} + -> 'context -> 'state -> Core.decl -> Core.decl * 'state end structure File : sig diff --git a/src/core_util.sml b/src/core_util.sml index 4d72f57e..f7e92f51 100644 --- a/src/core_util.sml +++ b/src/core_util.sml @@ -709,6 +709,14 @@ fun fold {kind, con, exp} s e = S.Continue (_, s) => s | S.Return _ => raise Fail "CoreUtil.Exp.fold: Impossible" +fun foldB {kind, con, exp, bind} ctx s e = + case mapfoldB {kind = fn k => fn s => S.Continue (k, kind (k, s)), + con = fn ctx => fn c => fn s => S.Continue (c, con (ctx, c, 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 "CoreUtil.Exp.foldB: Impossible" + fun exists {kind, con, exp} k = case mapfold {kind = fn k => fn () => if kind k then @@ -861,6 +869,15 @@ fun foldMap {kind, con, exp, decl} s d = S.Continue v => v | S.Return _ => raise Fail "CoreUtil.Decl.foldMap: Impossible" +fun foldMapB {kind, con, exp, decl, bind} ctx s d = + case mapfoldB {kind = fn k => fn s => S.Continue (kind (k, s)), + con = fn ctx => fn c => fn s => S.Continue (con (ctx, 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 "CoreUtil.Decl.foldMapB: Impossible" + end structure File = struct diff --git a/src/defunc.sig b/src/defunc.sig new file mode 100644 index 00000000..6e8f2136 --- /dev/null +++ b/src/defunc.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 DEFUNC = sig + + val defunc : Core.file -> Core.file + +end diff --git a/src/defunc.sml b/src/defunc.sml new file mode 100644 index 00000000..8771d782 --- /dev/null +++ b/src/defunc.sml @@ -0,0 +1,256 @@ +(* 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 Defunc :> DEFUNC = struct + +open Core + +structure E = CoreEnv +structure U = CoreUtil + +structure IS = IntBinarySet + +val functionInside = U.Con.exists {kind = fn _ => false, + con = fn TFun _ => true + | CFfi ("Basis", "transaction") => true + | _ => false} + +val freeVars = U.Exp.foldB {kind = fn (_, xs) => xs, + con = fn (_, _, xs) => xs, + exp = fn (bound, e, xs) => + case e of + ERel x => + if x >= bound then + IS.add (xs, x - bound) + else + xs + | _ => xs, + bind = fn (bound, b) => + case b of + U.Exp.RelE _ => bound + 1 + | _ => bound} + 0 IS.empty + +fun positionOf (v : int, ls) = + let + fun pof (pos, ls) = + case ls of + [] => raise Fail "Defunc.positionOf" + | v' :: ls' => + if v = v' then + pos + else + pof (pos + 1, ls') + in + pof (0, ls) + end + +fun squish fvs = + U.Exp.mapB {kind = fn k => k, + con = fn _ => fn c => c, + exp = fn bound => fn e => + case e of + ERel x => + if x >= bound then + ERel (positionOf (x - bound, fvs) + bound) + else + e + | _ => e, + bind = fn (bound, b) => + case b of + U.Exp.RelE _ => bound + 1 + | _ => bound} + 0 + +fun default (_, x, st) = (x, st) + +datatype 'a search = + Yes + | No + | Maybe of 'a + +structure EK = struct +type ord_key = exp +val compare = U.Exp.compare +end + +structure EM = BinaryMapFn(EK) + +type state = { + maxName : int, + funcs : int EM.map, + vis : (string * int * con * exp * string) list +} + +fun exp (env, e, st) = + case e of + ERecord xes => + let + val (xes, st) = + ListUtil.foldlMap + (fn (tup as (fnam as (CName x, loc), e, xt), st) => + if x <> "Link" andalso x <> "Action" then + (tup, st) + else + let + fun needsAttention (e, _) = + case e of + ENamed f => Maybe (#2 (E.lookupENamed env f)) + | EApp (f, _) => + (case needsAttention f of + No => No + | Yes => Yes + | Maybe t => + case t of + (TFun (dom, _), _) => + if functionInside dom then + Yes + else + No + | _ => No) + | _ => No + + fun headSymbol (e, _) = + case e of + ENamed f => f + | EApp (e, _) => headSymbol e + | _ => raise Fail "Defunc: headSymbol" + + fun rtype (e, _) = + case e of + ENamed f => #2 (E.lookupENamed env f) + | EApp (f, _) => + (case rtype f of + (TFun (_, ran), _) => ran + | _ => raise Fail "Defunc: rtype [1]") + | _ => raise Fail "Defunc: rtype [2]" + in + (*Print.prefaces "Found one!" + [("e", CorePrint.p_exp env e)];*) + case needsAttention e of + Yes => + let + (*val () = print "Yes\n"*) + val f = headSymbol e + + val fvs = IS.listItems (freeVars e) + + val e = squish fvs e + val (e, t) = foldl (fn (n, (e, t)) => + let + val (x, xt) = E.lookupERel env n + in + ((EAbs (x, xt, t, e), loc), + (TFun (xt, t), loc)) + end) + (e, rtype e) fvs + + val (f', st) = + case EM.find (#funcs st, e) of + SOME f' => (f', st) + | NONE => + let + val (fx, _, _, tag) = E.lookupENamed env f + val f' = #maxName st + + val vi = (fx, f', t, e, tag) + in + (f', {maxName = f' + 1, + funcs = EM.insert (#funcs st, e, f'), + vis = vi :: #vis st}) + end + + val e = foldr (fn (n, e) => + (EApp (e, (ERel n, loc)), loc)) + (ENamed f', loc) fvs + in + (*app (fn n => Print.prefaces + "Free" + [("n", CorePrint.p_exp env (ERel n, ErrorMsg.dummySpan))]) + fvs; + Print.prefaces "Squished" + [("e", CorePrint.p_exp CoreEnv.empty e)];*) + + ((fnam, e, xt), st) + end + | _ => (tup, st) + end + | (tup, st) => (tup, st)) + st xes + in + (ERecord xes, st) + end + | _ => (e, st) + +fun bind (env, b) = + case b of + U.Decl.RelC (x, k) => E.pushCRel env x k + | U.Decl.NamedC (x, n, k, co) => E.pushCNamed env x n k co + | U.Decl.RelE (x, t) => E.pushERel env x t + | U.Decl.NamedE (x, n, t, eo, s) => E.pushENamed env x n t eo s + +fun doDecl env = U.Decl.foldMapB {kind = fn x => x, + con = default, + exp = exp, + decl = default, + bind = bind} + env + +fun defunc file = + let + fun doDecl' (d, (env, st)) = + let + val env = E.declBinds env d + + val (d, st) = doDecl env st d + + val ds = + case #vis st of + [] => [d] + | vis => + case d of + (DValRec vis', loc) => [(DValRec (vis' @ vis), loc)] + | _ => [(DValRec vis, #2 d), d] + in + (ds, + (env, + {maxName = #maxName st, + funcs = #funcs st, + vis = []})) + end + + val (file, _) = ListUtil.foldlMapConcat doDecl' + (E.empty, + {maxName = U.File.maxName file + 1, + funcs = EM.empty, + vis = []}) + file + in + file + end + +end diff --git a/src/sources b/src/sources index 252ffe44..bddcac67 100644 --- a/src/sources +++ b/src/sources @@ -105,6 +105,9 @@ especialize.sml core_untangle.sig core_untangle.sml +defunc.sig +defunc.sml + tag.sig tag.sml -- cgit v1.2.3 From ded9f1e15308a0ed27c9892d4b0285abc25654f8 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 11 Nov 2008 15:12:24 -0500 Subject: Get preliminary ThreadedBlog working --- include/urweb.h | 2 + src/c/urweb.c | 8 ++ src/compiler.sig | 3 +- src/compiler.sml | 5 +- src/core_util.sig | 5 + src/core_util.sml | 8 ++ src/especialize.sml | 365 ++++++++++++++++++++++++++++------------------------ 7 files changed, 223 insertions(+), 173 deletions(-) (limited to 'src/compiler.sig') diff --git a/include/urweb.h b/include/urweb.h index 7e16fd40..d148654f 100644 --- a/include/urweb.h +++ b/include/urweb.h @@ -60,6 +60,7 @@ char *uw_Basis_urlifyInt(uw_context, uw_Basis_int); char *uw_Basis_urlifyFloat(uw_context, uw_Basis_float); char *uw_Basis_urlifyString(uw_context, uw_Basis_string); char *uw_Basis_urlifyBool(uw_context, uw_Basis_bool); +char *uw_Basis_urlifyTime(uw_context, uw_Basis_time); uw_unit uw_Basis_urlifyInt_w(uw_context, uw_Basis_int); uw_unit uw_Basis_urlifyFloat_w(uw_context, uw_Basis_float); @@ -70,6 +71,7 @@ uw_Basis_int uw_Basis_unurlifyInt(uw_context, char **); uw_Basis_float uw_Basis_unurlifyFloat(uw_context, char **); uw_Basis_string uw_Basis_unurlifyString(uw_context, char **); uw_Basis_bool uw_Basis_unurlifyBool(uw_context, char **); +uw_Basis_time uw_Basis_unurlifyTime(uw_context, char **); uw_Basis_string uw_Basis_strcat(uw_context, uw_Basis_string, uw_Basis_string); uw_Basis_string uw_Basis_strdup(uw_context, uw_Basis_string); diff --git a/src/c/urweb.c b/src/c/urweb.c index 57584f53..a347dd45 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -557,6 +557,10 @@ uw_unit uw_Basis_urlifyFloat_w(uw_context ctx, uw_Basis_float n) { return uw_unit_v; } +uw_Basis_string uw_Basis_urlifyTime(uw_context ctx, uw_Basis_time t) { + return uw_Basis_urlifyInt(ctx, t); +} + uw_unit uw_Basis_urlifyString_w(uw_context ctx, uw_Basis_string s) { uw_check(ctx, strlen(s) * 3); @@ -615,6 +619,10 @@ uw_Basis_float uw_Basis_unurlifyFloat(uw_context ctx, char **s) { return r; } +uw_Basis_time uw_Basis_unurlifyTime(uw_context ctx, char **s) { + return uw_Basis_unurlifyInt(ctx, s); +} + static uw_Basis_string uw_unurlifyString_to(uw_context ctx, char *r, char *s) { char *s1, *s2; int n; diff --git a/src/compiler.sig b/src/compiler.sig index 402706be..2bed20f9 100644 --- a/src/compiler.sig +++ b/src/compiler.sig @@ -90,7 +90,8 @@ signature COMPILER = sig val toEspecialize : (string, Core.file) transform val toCore_untangle : (string, Core.file) transform val toShake1 : (string, Core.file) transform - val toDefunc : (string, Core.file) transform + val toDefunc : (string, Core.file) transform + val toShake1' : (string, Core.file) transform val toTag : (string, Core.file) transform val toReduce : (string, Core.file) transform val toUnpoly : (string, Core.file) transform diff --git a/src/compiler.sml b/src/compiler.sml index 93a03169..b2f8f91c 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -446,12 +446,15 @@ val defunc = { val toDefunc = transform defunc "defunc" o toShake1 +val toCore_untangle' = transform core_untangle "core_untangle'" o toDefunc +val toShake1' = transform shake "shake1'" o toCore_untangle' + val tag = { func = Tag.tag, print = CorePrint.p_file CoreEnv.empty } -val toTag = transform tag "tag" o toDefunc +val toTag = transform tag "tag" o toShake1' val reduce = { func = Reduce.reduce, diff --git a/src/core_util.sig b/src/core_util.sig index 100932c3..39f50cc1 100644 --- a/src/core_util.sig +++ b/src/core_util.sig @@ -126,6 +126,11 @@ structure Exp : sig con : Core.con' * 'state -> Core.con' * 'state, exp : Core.exp' * 'state -> Core.exp' * 'state} -> 'state -> Core.exp -> Core.exp * 'state + val foldMapB : {kind : Core.kind' * 'state -> Core.kind' * 'state, + con : 'context * Core.con' * 'state -> Core.con' * 'state, + exp : 'context * Core.exp' * 'state -> Core.exp' * 'state, + bind : 'context * binder -> 'context} + -> 'context -> 'state -> Core.exp -> Core.exp * 'state end structure Decl : sig diff --git a/src/core_util.sml b/src/core_util.sml index f7e92f51..38004f74 100644 --- a/src/core_util.sml +++ b/src/core_util.sml @@ -763,6 +763,14 @@ fun foldMap {kind, con, exp} s e = S.Continue v => v | S.Return _ => raise Fail "CoreUtil.Exp.foldMap: Impossible" +fun foldMapB {kind, con, exp, bind} ctx s e = + case mapfoldB {kind = fn k => fn s => S.Continue (kind (k, s)), + con = fn ctx => fn c => fn s => S.Continue (con (ctx, c, s)), + exp = fn ctx => fn e => fn s => S.Continue (exp (ctx, e, s)), + bind = bind} ctx e s of + S.Continue v => v + | S.Return _ => raise Fail "CoreUtil.Exp.foldMapB: Impossible" + end structure Decl = struct diff --git a/src/especialize.sml b/src/especialize.sml index ffd4745b..220b48bd 100644 --- a/src/especialize.sml +++ b/src/especialize.sml @@ -43,47 +43,52 @@ structure KM = BinaryMapFn(K) structure IM = IntBinaryMap structure IS = IntBinarySet -val sizeOf = U.Exp.fold {kind = fn (_, n) => n, - con = fn (_, n) => n, - exp = fn (_, n) => n + 1} - 0 - -val isOpen = U.Exp.existsB {kind = fn _ => false, - con = fn ((nc, _), c) => - case c of - CRel n => n >= nc - | _ => false, - exp = fn ((_, ne), e) => +val freeVars = U.Exp.foldB {kind = fn (_, xs) => xs, + con = fn (_, _, xs) => xs, + exp = fn (bound, e, xs) => case e of - ERel n => n >= ne - | _ => false, - bind = fn ((nc, ne), b) => + ERel x => + if x >= bound then + IS.add (xs, x - bound) + else + xs + | _ => xs, + bind = fn (bound, b) => case b of - U.Exp.RelC _ => (nc + 1, ne) - | U.Exp.RelE _ => (nc, ne + 1) - | _ => (nc, ne)} - (0, 0) - -fun baseBad (e, _) = - case e of - EAbs (_, _, _, e) => sizeOf e > 20 - | ENamed _ => false - | _ => true - -fun isBad e = - case e of - (ERecord xes, _) => - length xes > 10 - orelse List.exists (fn (_, e, _) => baseBad e) xes - | _ => baseBad e - -fun skeyIn e = - if isBad e orelse isOpen e then - NONE - else - SOME e - -fun skeyOut e = e + U.Exp.RelE _ => bound + 1 + | _ => bound} + 0 IS.empty + +fun positionOf (v : int, ls) = + let + fun pof (pos, ls) = + case ls of + [] => raise Fail "Defunc.positionOf" + | v' :: ls' => + if v = v' then + pos + else + pof (pos + 1, ls') + in + pof (0, ls) + end + +fun squish fvs = + U.Exp.mapB {kind = fn k => k, + con = fn _ => fn c => c, + exp = fn bound => fn e => + case e of + ERel x => + if x >= bound then + ERel (positionOf (x - bound, fvs) + bound) + else + e + | _ => e, + bind = fn (bound, b) => + case b of + U.Exp.RelE _ => bound + 1 + | _ => bound} + 0 type func = { name : string, @@ -99,12 +104,12 @@ type state = { decls : (string * int * con * exp * string) list } -fun kind (k, st) = (k, st) -fun con (c, st) = (c, st) +fun kind x = x +fun default (_, x, st) = (x, st) fun specialize' file = let - fun default (_, fs) = fs + fun default' (_, fs) = fs fun actionableExp (e, fs) = case e of @@ -127,149 +132,159 @@ fun specialize' file = | _ => fs val actionable = - U.File.fold {kind = default, - con = default, + U.File.fold {kind = default', + con = default', exp = actionableExp, - decl = default} + decl = default'} IS.empty file - fun exp (e, st : state) = + fun bind (env, b) = + case b of + U.Decl.RelC (x, k) => E.pushCRel env x k + | U.Decl.NamedC (x, n, k, co) => E.pushCNamed env x n k co + | U.Decl.RelE (x, t) => E.pushERel env x t + | U.Decl.NamedE (x, n, t, eo, s) => E.pushENamed env x n t eo s + + fun exp (env, e, st : state) = let - fun getApp' e = + fun getApp e = case e of - ENamed f => SOME (f, [], []) + ENamed f => SOME (f, []) | EApp (e1, e2) => - (case getApp' (#1 e1) of + (case getApp (#1 e1) of NONE => NONE - | SOME (f, xs, xs') => - let - val k = - if List.null xs' then - skeyIn e2 - else - NONE - in - case k of - NONE => SOME (f, xs, xs' @ [e2]) - | SOME k => SOME (f, xs @ [k], xs') - end) + | SOME (f, xs) => SOME (f, xs @ [e2])) | _ => NONE - - fun getApp e = - case getApp' e of - NONE => NONE - | SOME (f, xs, xs') => - if List.all (fn (ERecord [], _) => true | _ => false) xs then - SOME (f, [], xs @ xs') - else - SOME (f, xs, xs') in case getApp e of NONE => (e, st) - | SOME (f, [], []) => (e, st) - | SOME (f, [], xs') => - (case IM.find (#funcs st, f) of - NONE => (e, st) - | SOME {typ, body, ...} => - let - val functionInside = U.Con.exists {kind = fn _ => false, - con = fn TFun _ => true - | CFfi ("Basis", "transaction") => true - | _ => false} - - fun hasFunarg (t, xs) = - case (t, xs) of - ((TFun (dom, ran), _), _ :: xs) => - functionInside dom - orelse hasFunarg (ran, xs) - | _ => false - in - if List.all (fn (ERel _, _) => false | _ => true) xs' - andalso List.exists (fn (ERecord [], _) => false | _ => true) xs' - andalso not (IS.member (actionable, f)) - andalso hasFunarg (typ, xs') then - let - val e = foldl (fn (arg, e) => (EApp (e, arg), ErrorMsg.dummySpan)) - body xs' - in - (*Print.prefaces "Unfolded" - [("e", CorePrint.p_exp CoreEnv.empty e)];*) - (#1 e, st) - end - else - (e, st) - end) - | SOME (f, xs, xs') => + | SOME (f, xs) => case IM.find (#funcs st, f) of NONE => (e, st) | SOME {name, args, body, typ, tag} => - case KM.find (args, xs) of - SOME f' => (#1 (foldl (fn (arg, e) => (EApp (e, arg), ErrorMsg.dummySpan)) - (ENamed f', ErrorMsg.dummySpan) xs'), - st) - | NONE => - let - fun subBody (body, typ, xs) = - case (#1 body, #1 typ, xs) of - (_, _, []) => SOME (body, typ) - | (EAbs (_, _, _, body'), TFun (_, typ'), x :: xs) => - let - val body'' = E.subExpInExp (0, skeyOut x) body' - in - subBody (body'', - typ', - xs) - end - | _ => NONE - in - case subBody (body, typ, xs) of - NONE => (e, st) - | SOME (body', typ') => + let + val functionInside = U.Con.exists {kind = fn _ => false, + con = fn TFun _ => true + | CFfi ("Basis", "transaction") => true + | _ => false} + val loc = ErrorMsg.dummySpan + + fun findSplit (xs, typ, fxs, fvs) = + case (#1 typ, xs) of + (TFun (dom, ran), e :: xs') => + if functionInside dom then + findSplit (xs', + ran, + e :: fxs, + IS.union (fvs, freeVars e)) + else + (rev fxs, xs, fvs) + | _ => (rev fxs, xs, fvs) + + val (fxs, xs, fvs) = findSplit (xs, typ, [], IS.empty) + + val fxs' = map (squish (IS.listItems fvs)) fxs + + fun firstRel () = + case fxs' of + (ERel _, _) :: _ => true + | _ => false + in + if firstRel () + orelse List.all (fn (ERel _, _) => true + | _ => false) fxs' then + (e, st) + else + case KM.find (args, fxs') of + SOME f' => + let + val e = (ENamed f', loc) + val e = IS.foldr (fn (arg, e) => (EApp (e, (ERel arg, loc)), loc)) + e fvs + val e = foldl (fn (arg, e) => (EApp (e, arg), loc)) + e xs + in + (*Print.prefaces "Brand new (reuse)" + [("e'", CorePrint.p_exp env e)];*) + (#1 e, st) + end + | NONE => let - (*val () = Print.prefaces "sub'd" - [("body'", CorePrint.p_exp CoreEnv.empty body')]*) - - val f' = #maxName st - val funcs = IM.insert (#funcs st, f, {name = name, - args = KM.insert (args, - xs, f'), - body = body, - typ = typ, - tag = tag}) - val st = { - maxName = f' + 1, - funcs = funcs, - decls = #decls st - } - - (*val () = print ("Created " ^ Int.toString f' ^ " from " - ^ Int.toString f ^ "\n") - val () = Print.prefaces "body'" - [("body'", CorePrint.p_exp CoreEnv.empty body')]*) - val (body', st) = specExp st body' - (*val () = Print.prefaces "body''" - [("body'", CorePrint.p_exp CoreEnv.empty body')]*) - val e' = foldl (fn (arg, e) => (EApp (e, arg), ErrorMsg.dummySpan)) - (ENamed f', ErrorMsg.dummySpan) xs' + fun subBody (body, typ, fxs') = + case (#1 body, #1 typ, fxs') of + (_, _, []) => SOME (body, typ) + | (EAbs (_, _, _, body'), TFun (_, typ'), x :: fxs'') => + let + val body'' = E.subExpInExp (0, x) body' + in + subBody (body'', + typ', + fxs'') + end + | _ => NONE in - (#1 e', - {maxName = #maxName st, - funcs = #funcs st, - decls = (name, f', typ', body', tag) :: #decls st}) + case subBody (body, typ, fxs') of + NONE => (e, st) + | SOME (body', typ') => + let + val f' = #maxName st + val args = KM.insert (args, fxs', f') + val funcs = IM.insert (#funcs st, f, {name = name, + args = args, + body = body, + typ = typ, + tag = tag}) + val st = { + maxName = f' + 1, + funcs = funcs, + decls = #decls st + } + + (*val () = Print.prefaces "specExp" + [("f", CorePrint.p_exp env (ENamed f, loc)), + ("f'", CorePrint.p_exp env (ENamed f', loc)), + ("xs", Print.p_list (CorePrint.p_exp env) xs), + ("fxs'", Print.p_list + (CorePrint.p_exp E.empty) fxs'), + ("e", CorePrint.p_exp env (e, loc))]*) + val (body', typ') = IS.foldl (fn (n, (body', typ')) => + let + val (x, xt) = E.lookupERel env n + in + ((EAbs (x, xt, typ', body'), + loc), + (TFun (xt, typ'), loc)) + end) + (body', typ') fvs + val (body', st) = specExp env st body' + + val e' = (ENamed f', loc) + val e' = IS.foldr (fn (arg, e) => (EApp (e, (ERel arg, loc)), loc)) + e' fvs + val e' = foldl (fn (arg, e) => (EApp (e, arg), loc)) + e' xs + (*val () = Print.prefaces "Brand new" + [("e'", CorePrint.p_exp env e'), + ("e", CorePrint.p_exp env (e, loc)), + ("body'", CorePrint.p_exp env body')]*) + in + (#1 e', + {maxName = #maxName st, + funcs = #funcs st, + decls = (name, f', typ', body', tag) :: #decls st}) + end end - end + end end - and specExp st = U.Exp.foldMap {kind = kind, con = con, exp = exp} st + and specExp env = U.Exp.foldMapB {kind = kind, con = default, exp = exp, bind = bind} env - fun decl (d, st) = (d, st) + val specDecl = U.Decl.foldMapB {kind = kind, con = default, exp = exp, decl = default, bind = bind} - val specDecl = U.Decl.foldMap {kind = kind, con = con, exp = exp, decl = decl} - - - - fun doDecl (d, (st : state, changed)) = + fun doDecl (d, (env, st : state, changed)) = let + val env = E.declBinds env d + val funcs = #funcs st val funcs = case #1 d of @@ -288,7 +303,7 @@ fun specialize' file = decls = []} (*val () = Print.prefaces "decl" [("d", CorePrint.p_decl CoreEnv.empty d)]*) - val (d', st) = specDecl st d + val (d', st) = specDecl env st d (*val () = print "/decl\n"*) val funcs = #funcs st @@ -314,16 +329,19 @@ fun specialize' file = (DValRec vis', _) => [(DValRec (vis @ vis'), ErrorMsg.dummySpan)] | _ => [(DValRec vis, ErrorMsg.dummySpan), d']) in - (ds, ({maxName = #maxName st, + (ds, (env, + {maxName = #maxName st, funcs = funcs, decls = []}, changed)) end - val (ds, (_, changed)) = ListUtil.foldlMapConcat doDecl - ({maxName = U.File.maxName file + 1, - funcs = IM.empty, - decls = []}, false) - file + val (ds, (_, _, changed)) = ListUtil.foldlMapConcat doDecl + (E.empty, + {maxName = U.File.maxName file + 1, + funcs = IM.empty, + decls = []}, + false) + file in (changed, ds) end @@ -331,10 +349,15 @@ fun specialize' file = fun specialize file = let (*val () = Print.prefaces "Intermediate" [("file", CorePrint.p_file CoreEnv.empty file)];*) + val file = ReduceLocal.reduce file val (changed, file) = specialize' file + val file = ReduceLocal.reduce file + (*val file = CoreUntangle.untangle file + val file = Shake.shake file*) in + (*print "Round over\n";*) if changed then - specialize (ReduceLocal.reduce file) + specialize file else file end -- cgit v1.2.3 From 0363434b9bbdea2e3ab9c432036941c0557ab62c Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 20 Nov 2008 12:16:30 -0500 Subject: Profiling support --- Makefile.in | 4 ++-- src/c/driver.c | 11 ++++++++++- src/compiler.sig | 5 +++-- src/compiler.sml | 43 ++++++++++++++++++++++++++++--------------- src/demo.sml | 3 ++- 5 files changed, 45 insertions(+), 21 deletions(-) (limited to 'src/compiler.sig') diff --git a/Makefile.in b/Makefile.in index 364b230f..ff1f4b6a 100644 --- a/Makefile.in +++ b/Makefile.in @@ -21,10 +21,10 @@ clean: rm -rf .cm src/.cm clib/urweb.o: src/c/urweb.c - gcc -O3 -I include -c src/c/urweb.c -o clib/urweb.o + gcc -O3 -I include -c src/c/urweb.c -o clib/urweb.o $(CFLAGS) clib/driver.o: src/c/driver.c - gcc -O3 -I include -c src/c/driver.c -o clib/driver.o + gcc -O3 -I include -c src/c/driver.c -o clib/driver.o $(CFLAGS) src/urweb.cm: src/prefix.cm src/sources cat src/prefix.cm src/sources \ diff --git a/src/c/driver.c b/src/c/driver.c index f80361b1..ce0d194e 100644 --- a/src/c/driver.c +++ b/src/c/driver.c @@ -1,10 +1,12 @@ #include #include +#include #include #include #include #include +#include #include @@ -297,6 +299,11 @@ static void help(char *cmd) { printf("Usage: %s [-p ] [-t ]\n", cmd); } +static void sigint(int signum) { + printf("Exiting....\n"); + exit(0); +} + int main(int argc, char *argv[]) { // The skeleton for this function comes from Beej's sockets tutorial. int sockfd; // listen on sock_fd @@ -304,7 +311,9 @@ int main(int argc, char *argv[]) { struct sockaddr_in their_addr; // connector's address information int sin_size, yes = 1; int uw_port = 8080, nthreads = 1, i, *names, opt; - + + signal(SIGINT, sigint); + while ((opt = getopt(argc, argv, "hp:t:")) != -1) { switch (opt) { case '?': diff --git a/src/compiler.sig b/src/compiler.sig index 2bed20f9..af086675 100644 --- a/src/compiler.sig +++ b/src/compiler.sig @@ -35,10 +35,11 @@ signature COMPILER = sig sources : string list, exe : string, sql : string option, - debug : bool + debug : bool, + profile : bool } val compile : string -> unit - val compileC : {cname : string, oname : string, ename : string, libs : string} -> unit + val compileC : {cname : string, oname : string, ename : string, libs : string, profile : bool} -> unit type ('src, 'dst) phase type ('src, 'dst) transform diff --git a/src/compiler.sml b/src/compiler.sml index b2f8f91c..6a6c4391 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -41,7 +41,8 @@ type job = { sources : string list, exe : string, sql : string option, - debug : bool + debug : bool, + profile : bool } type ('src, 'dst) phase = { @@ -199,7 +200,7 @@ val parseUr = { handle LrParser.ParseError => [], print = SourcePrint.p_file} -fun p_job {prefix, database, exe, sql, sources, debug} = +fun p_job {prefix, database, exe, sql, sources, debug, profile} = let open Print.PD open Print @@ -208,6 +209,10 @@ fun p_job {prefix, database, exe, sql, sources, debug} = 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), @@ -260,19 +265,20 @@ val parseUrp = { readSources acc end - fun finish (prefix, database, exe, sql, debug, sources) = + fun finish (prefix, database, exe, sql, debug, profile, 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, sources = sources} - fun read (prefix, database, exe, sql, debug) = + fun read (prefix, database, exe, sql, debug, profile) = case TextIO.inputLine inf of - NONE => finish (prefix, database, exe, sql, debug, []) - | SOME "\n" => finish (prefix, database, exe, sql, debug, readSources []) + NONE => finish (prefix, database, exe, sql, debug, profile, []) + | SOME "\n" => finish (prefix, database, exe, sql, debug, profile, readSources []) | SOME line => let val (cmd, arg) = Substring.splitl (fn x => not (Char.isSpace x)) (Substring.full line) @@ -284,28 +290,29 @@ val parseUrp = { (case prefix of NONE => () | SOME _ => ErrorMsg.error "Duplicate 'prefix' directive"; - read (SOME arg, database, exe, sql, debug)) + read (SOME arg, database, exe, sql, debug, profile)) | "database" => (case database of NONE => () | SOME _ => ErrorMsg.error "Duplicate 'database' directive"; - read (prefix, SOME arg, exe, sql, debug)) + read (prefix, SOME arg, exe, sql, debug, profile)) | "exe" => (case exe of NONE => () | SOME _ => ErrorMsg.error "Duplicate 'exe' directive"; - read (prefix, database, SOME (relify arg), sql, debug)) + read (prefix, database, SOME (relify arg), sql, debug, profile)) | "sql" => (case sql of NONE => () | SOME _ => ErrorMsg.error "Duplicate 'sql' directive"; - read (prefix, database, exe, SOME (relify arg), debug)) - | "debug" => read (prefix, database, exe, sql, true) + read (prefix, database, exe, SOME (relify arg), debug, profile)) + | "debug" => read (prefix, database, exe, sql, true, profile) + | "profile" => read (prefix, database, exe, sql, debug, true) | _ => (ErrorMsg.error ("Unrecognized command '" ^ cmd ^ "'"); - read (prefix, database, exe, sql, debug)) + read (prefix, database, exe, sql, debug, profile)) end - val job = read (NONE, NONE, NONE, NONE, false) + val job = read (NONE, NONE, NONE, NONE, false, false) in TextIO.closeIn inf; Monoize.urlPrefix := #prefix job; @@ -544,13 +551,19 @@ val sqlify = { val toSqlify = transform sqlify "sqlify" o toMono_opt2 -fun compileC {cname, oname, ename, libs} = +fun compileC {cname, oname, ename, libs, profile} = let val urweb_o = clibFile "urweb.o" val driver_o = clibFile "driver.o" val compile = "gcc " ^ Config.gccArgs ^ " -Wstrict-prototypes -Werror -O3 -I include -c " ^ cname ^ " -o " ^ oname val link = "gcc -Werror -O3 -lm -pthread " ^ libs ^ " " ^ urweb_o ^ " " ^ oname ^ " " ^ driver_o ^ " -o " ^ ename + + val (compile, link) = + if profile then + (compile ^ " -pg", link ^ " -pg") + else + (compile, link) in if not (OS.Process.isSuccess (OS.Process.system compile)) then print "C compilation failed\n" @@ -615,7 +628,7 @@ fun compile job = TextIO.closeOut outf end; - compileC {cname = cname, oname = oname, ename = ename, libs = libs}; + compileC {cname = cname, oname = oname, ename = ename, libs = libs, profile = #profile job}; cleanup () end diff --git a/src/demo.sml b/src/demo.sml index 580cd21f..4f0cb52e 100644 --- a/src/demo.sml +++ b/src/demo.sml @@ -92,7 +92,8 @@ fun make {prefix, dirname, guided} = file = "demo.exe"}, sql = SOME (OS.Path.joinDirFile {dir = dirname, file = "demo.sql"}), - debug = false + debug = false, + profile = false } val parse = Compiler.run (Compiler.transform Compiler.parseUrp "Demo parseUrp") -- cgit v1.2.3 From 940865b04fa534983982b261386a3b1926bd5531 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 25 Nov 2008 10:05:44 -0500 Subject: Fusing writes with recursive function calls --- CHANGELOG | 5 +++ src/compiler.sig | 4 ++ src/compiler.sml | 13 +++++- src/fuse.sig | 32 ++++++++++++++ src/fuse.sml | 130 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ src/mono_opt.sig | 1 + src/mono_opt.sml | 2 + src/mono_util.sig | 7 +++ src/mono_util.sml | 21 ++++++++- src/sources | 3 ++ 10 files changed, 216 insertions(+), 2 deletions(-) create mode 100644 src/fuse.sig create mode 100644 src/fuse.sml (limited to 'src/compiler.sig') diff --git a/CHANGELOG b/CHANGELOG index a9cc96db..cbd67118 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,8 @@ +======== +======== + +- Optimization: Fusing page writes with calls to recursive functions + ======== 20081120 ======== diff --git a/src/compiler.sig b/src/compiler.sig index af086675..8c52ea32 100644 --- a/src/compiler.sig +++ b/src/compiler.sig @@ -76,6 +76,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 fuse : (Mono.file, Mono.file) phase val pathcheck : (Mono.file, Mono.file) phase val cjrize : (Mono.file, Cjr.file) phase val prepare : (Cjr.file, Cjr.file) phase @@ -104,6 +105,9 @@ signature COMPILER = sig val toMono_reduce : (string, Mono.file) transform val toMono_shake : (string, Mono.file) transform val toMono_opt2 : (string, Mono.file) transform + val toFuse : (string, Mono.file) transform + val toUntangle2 : (string, Mono.file) transform + val toMono_shake2 : (string, Mono.file) transform val toPathcheck : (string, Mono.file) transform val toCjrize : (string, Cjr.file) transform val toPrepare : (string, Cjr.file) transform diff --git a/src/compiler.sml b/src/compiler.sml index 6a6c4391..aac4a924 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -523,12 +523,23 @@ val toMono_shake = transform mono_shake "mono_shake1" o toMono_reduce val toMono_opt2 = transform mono_opt "mono_opt2" o toMono_shake +val fuse = { + func = Fuse.fuse, + print = MonoPrint.p_file MonoEnv.empty +} + +val toFuse = transform fuse "fuse" o toMono_opt2 + +val toUntangle2 = transform untangle "untangle2" o toFuse + +val toMono_shake2 = transform mono_shake "mono_shake2" o toUntangle2 + val pathcheck = { func = (fn file => (PathCheck.check file; file)), print = MonoPrint.p_file MonoEnv.empty } -val toPathcheck = transform pathcheck "pathcheck" o toMono_opt2 +val toPathcheck = transform pathcheck "pathcheck" o toMono_shake2 val cjrize = { func = Cjrize.cjrize, diff --git a/src/fuse.sig b/src/fuse.sig new file mode 100644 index 00000000..3ad45ac9 --- /dev/null +++ b/src/fuse.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 FUSE = sig + + val fuse : Mono.file -> Mono.file + +end diff --git a/src/fuse.sml b/src/fuse.sml new file mode 100644 index 00000000..b6bd6b47 --- /dev/null +++ b/src/fuse.sml @@ -0,0 +1,130 @@ +(* 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 Fuse :> FUSE = struct + +open Mono +structure U = MonoUtil + +structure IM = IntBinaryMap + +fun returnsString (t, loc) = + let + fun rs (t, loc) = + case t of + TFfi ("Basis", "string") => SOME ([], (TRecord [], loc)) + | TFun (dom, ran) => + (case rs ran of + NONE => NONE + | SOME (args, ran') => SOME (dom :: args, (TFun (dom, ran'), loc))) + | _ => NONE + in + case t of + TFun (dom, ran) => + (case rs ran of + NONE => NONE + | SOME (args, ran') => SOME (dom :: args, (TFun (dom, ran'), loc))) + | _ => NONE + end + +fun fuse file = + let + fun doDecl (d as (_, loc), (funcs, maxName)) = + let + val (d, funcs, maxName) = + case #1 d of + DValRec vis => + let + val (vis', funcs, maxName) = + foldl (fn ((x, n, t, e, s), (vis', funcs, maxName)) => + case returnsString t of + NONE => (vis', funcs, maxName) + | SOME (args, t') => + let + fun getBody (e, args) = + case (#1 e, args) of + (_, []) => (e, []) + | (EAbs (x, t, _, e), _ :: args) => + let + val (body, args') = getBody (e, args) + in + (body, (x, t) :: args') + end + | _ => raise Fail "Fuse: getBody" + + val (body, args) = getBody (e, args) + val body = MonoOpt.optExp (EWrite body, loc) + val (body, _) = foldl (fn ((x, dom), (body, ran)) => + ((EAbs (x, dom, ran, body), loc), + (TFun (dom, ran), loc))) + (body, (TRecord [], loc)) args + in + ((x, maxName, t', body, s) :: vis', + IM.insert (funcs, n, maxName), + maxName + 1) + end) + ([], funcs, maxName) vis + in + ((DValRec (vis @ vis'), loc), funcs, maxName) + end + | _ => (d, funcs, maxName) + + fun exp e = + case e of + EWrite e' => + let + fun unravel (e, loc) = + case e of + ENamed n => + (case IM.find (funcs, n) of + NONE => NONE + | SOME n' => SOME (ENamed n', loc)) + | EApp (e1, e2) => + (case unravel e1 of + NONE => NONE + | SOME e1 => SOME (EApp (e1, e2), loc)) + | _ => NONE + in + case unravel e' of + NONE => e + | SOME (e', _) => e' + end + | _ => e + in + (U.Decl.map {typ = fn x => x, + exp = exp, + decl = fn x => x} + d, + (funcs, maxName)) + end + + val (file, _) = ListUtil.foldlMap doDecl (IM.empty, U.File.maxName file + 1) file + in + file + end + +end diff --git a/src/mono_opt.sig b/src/mono_opt.sig index d147e7bc..d0268087 100644 --- a/src/mono_opt.sig +++ b/src/mono_opt.sig @@ -28,5 +28,6 @@ signature MONO_OPT = sig val optimize : Mono.file -> Mono.file + val optExp : Mono.exp -> Mono.exp end diff --git a/src/mono_opt.sml b/src/mono_opt.sml index b56372c7..6c0e6e21 100644 --- a/src/mono_opt.sml +++ b/src/mono_opt.sml @@ -366,4 +366,6 @@ and optExp e = #1 (U.Exp.map {typ = typ, exp = exp} e) val optimize = U.File.map {typ = typ, exp = exp, decl = decl} +val optExp = U.Exp.map {typ = typ, exp = exp} + end diff --git a/src/mono_util.sig b/src/mono_util.sig index 4e9d5d91..32a83855 100644 --- a/src/mono_util.sig +++ b/src/mono_util.sig @@ -90,6 +90,11 @@ structure Decl : sig exp : Mono.exp' * 'state -> 'state, decl : Mono.decl' * 'state -> 'state} -> 'state -> Mono.decl -> 'state + + val map : {typ : Mono.typ' -> Mono.typ', + exp : Mono.exp' -> Mono.exp', + decl : Mono.decl' -> Mono.decl'} + -> Mono.decl -> Mono.decl end structure File : sig @@ -121,6 +126,8 @@ structure File : sig exp : Mono.exp' * 'state -> 'state, decl : Mono.decl' * 'state -> 'state} -> 'state -> Mono.file -> 'state + + val maxName : Mono.file -> int end end diff --git a/src/mono_util.sml b/src/mono_util.sml index 14ab1674..2b2476e7 100644 --- a/src/mono_util.sml +++ b/src/mono_util.sml @@ -422,6 +422,13 @@ fun fold {typ, exp, decl} s d = S.Continue (_, s) => s | S.Return _ => raise Fail "MonoUtil.Decl.fold: Impossible" +fun map {typ, exp, decl} e = + case mapfold {typ = fn c => fn () => S.Continue (typ c, ()), + exp = fn e => fn () => S.Continue (exp e, ()), + decl = fn d => fn () => S.Continue (decl d, ())} e () of + S.Return () => raise Fail "MonoUtil.Decl.map: Impossible" + | S.Continue (e, ()) => e + end structure File = struct @@ -490,7 +497,7 @@ fun map {typ, exp, decl} e = case mapfold {typ = fn c => fn () => S.Continue (typ c, ()), exp = fn e => fn () => S.Continue (exp e, ()), decl = fn d => fn () => S.Continue (decl d, ())} e () of - S.Return () => raise Fail "Mono_util.File.map" + S.Return () => raise Fail "MonoUtil.File.map: Impossible" | S.Continue (e, ()) => e fun fold {typ, exp, decl} s d = @@ -500,6 +507,18 @@ fun fold {typ, exp, decl} s d = S.Continue (_, s) => s | S.Return _ => raise Fail "MonoUtil.File.fold: Impossible" +val maxName = foldl (fn ((d, _) : decl, count) => + case d of + DDatatype (_, n, ns) => + foldl (fn ((_, n', _), m) => Int.max (n', m)) + (Int.max (n, count)) ns + | DVal (_, n, _, _, _) => Int.max (n, count) + | DValRec vis => foldl (fn ((_, n, _, _, _), count) => Int.max (n, count)) count vis + | DExport _ => count + | DTable _ => count + | DSequence _ => count + | DDatabase _ => count) 0 + end end diff --git a/src/sources b/src/sources index bddcac67..13f505d0 100644 --- a/src/sources +++ b/src/sources @@ -140,6 +140,9 @@ mono_shake.sml pathcheck.sig pathcheck.sml +fuse.sig +fuse.sml + cjr.sml cjr_env.sig -- cgit v1.2.3 From ca833ef09c3bbb51e38b98f70c480a767c83c829 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 27 Nov 2008 10:46:45 -0500 Subject: Stop using redundant Defunc pass --- src/compiler.sig | 3 --- src/compiler.sml | 12 +----------- 2 files changed, 1 insertion(+), 14 deletions(-) (limited to 'src/compiler.sig') diff --git a/src/compiler.sig b/src/compiler.sig index 8c52ea32..59ad32be 100644 --- a/src/compiler.sig +++ b/src/compiler.sig @@ -66,7 +66,6 @@ signature COMPILER = sig val especialize : (Core.file, Core.file) phase val core_untangle : (Core.file, Core.file) phase val shake : (Core.file, Core.file) phase - val defunc : (Core.file, Core.file) phase val tag : (Core.file, Core.file) phase val reduce : (Core.file, Core.file) phase val unpoly : (Core.file, Core.file) phase @@ -92,8 +91,6 @@ signature COMPILER = sig val toEspecialize : (string, Core.file) transform val toCore_untangle : (string, Core.file) transform val toShake1 : (string, Core.file) transform - val toDefunc : (string, Core.file) transform - val toShake1' : (string, Core.file) transform val toTag : (string, Core.file) transform val toReduce : (string, Core.file) transform val toUnpoly : (string, Core.file) transform diff --git a/src/compiler.sml b/src/compiler.sml index aac4a924..0ff4ee6a 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -446,22 +446,12 @@ val shake = { val toShake1 = transform shake "shake1" o toCore_untangle -val defunc = { - func = Defunc.defunc, - print = CorePrint.p_file CoreEnv.empty -} - -val toDefunc = transform defunc "defunc" o toShake1 - -val toCore_untangle' = transform core_untangle "core_untangle'" o toDefunc -val toShake1' = transform shake "shake1'" o toCore_untangle' - val tag = { func = Tag.tag, print = CorePrint.p_file CoreEnv.empty } -val toTag = transform tag "tag" o toShake1' +val toTag = transform tag "tag" o toShake1 val reduce = { func = Reduce.reduce, -- cgit v1.2.3 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 (limited to 'src/compiler.sig') 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 From d5c3faacb1c3114fe6802973a62528cda8be8ac7 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 21 Dec 2008 12:30:57 -0500 Subject: Handling singnal bind --- jslib/urweb.js | 3 +- src/cjrize.sml | 1 + src/compiler.sig | 3 +- src/compiler.sml | 8 +++-- src/jscomp.sml | 90 +++++++++++++++++++++++++++++++++++++++-------------- src/mono.sml | 1 + src/mono_opt.sml | 3 ++ src/mono_print.sml | 6 ++++ src/mono_reduce.sml | 5 +++ src/mono_util.sml | 6 ++++ src/monoize.sml | 18 +++++++++-- tests/sbind.ur | 5 +++ tests/sbind.urp | 3 ++ 13 files changed, 122 insertions(+), 30 deletions(-) create mode 100644 tests/sbind.ur create mode 100644 tests/sbind.urp (limited to 'src/compiler.sig') diff --git a/jslib/urweb.js b/jslib/urweb.js index b7a1af91..f552b26b 100644 --- a/jslib/urweb.js +++ b/jslib/urweb.js @@ -1,4 +1,5 @@ -function sreturn(v) { return {v : v} } +function sr(v) { return {v : v} } +function sb(x,y) { return {v : y(x.v).v} } function dyn(s) { var x = document.createElement("span"); diff --git a/src/cjrize.sml b/src/cjrize.sml index 78513ef7..a46c725e 100644 --- a/src/cjrize.sml +++ b/src/cjrize.sml @@ -423,6 +423,7 @@ fun cifyExp (eAll as (e, loc), sm) = | L.EJavaScript _ => raise Fail "Cjrize: EJavaScript remains" | L.ESignalReturn _ => raise Fail "Cjrize: ESignalReturn remains" + | L.ESignalBind _ => raise Fail "Cjrize: ESignalBind remains" fun cifyDecl ((d, loc), sm) = case d of diff --git a/src/compiler.sig b/src/compiler.sig index 1f1f4973..c156b268 100644 --- a/src/compiler.sig +++ b/src/compiler.sig @@ -102,8 +102,9 @@ 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 toJscomp : (string, Mono.file) transform + val toMono_opt3 : (string, Mono.file) transform val toFuse : (string, Mono.file) transform val toUntangle2 : (string, Mono.file) transform val toMono_shake2 : (string, Mono.file) transform diff --git a/src/compiler.sml b/src/compiler.sml index ecee1065..6d499283 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -511,21 +511,23 @@ 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 toJscomp = transform jscomp "jscomp" o toMono_opt2 -val toMono_opt2 = transform mono_opt "mono_opt2" o toJscomp +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_opt2 +val toFuse = transform fuse "fuse" o toMono_opt3 val toUntangle2 = transform untangle "untangle2" o toFuse diff --git a/src/jscomp.sml b/src/jscomp.sml index 95c18016..c38056e8 100644 --- a/src/jscomp.sml +++ b/src/jscomp.sml @@ -33,6 +33,20 @@ structure EM = ErrorMsg structure E = MonoEnv structure U = MonoUtil +val funcs = [(("Basis", "alert"), "alert"), + (("Basis", "htmlifyString"), "escape")] + +structure FM = BinaryMapFn(struct + type ord_key = string * string + fun compare ((m1, x1), (m2, x2)) = + Order.join (String.compare (m1, m2), + fn () => String.compare (x1, x2)) + end) + +val funcs = foldl (fn ((k, v), m) => FM.insert (m, k, v)) FM.empty funcs + +fun ffi k = FM.find (funcs, k) + type state = { decls : decl list, script : string @@ -70,6 +84,7 @@ fun varDepth (e, _) = | EUnurlify _ => 0 | EJavaScript _ => 0 | ESignalReturn e => varDepth e + | ESignalBind (e1, e2) => Int.max (varDepth e1, varDepth e2) fun strcat loc es = case es of @@ -150,33 +165,50 @@ fun jsExp mode outer = e, st) end - | EFfi (_, s) => (str s, st) - | EFfiApp (_, s, []) => (str (s ^ "()"), st) - | EFfiApp (_, s, [e]) => + | EFfi k => let - val (e, st) = jsE inner (e, st) - + val name = case ffi k of + NONE => (EM.errorAt loc "Unsupported FFI identifier in JavaScript"; + "ERROR") + | SOME s => s in - (strcat [str (s ^ "("), - e, - str ")"], st) + (str name, st) end - | EFfiApp (_, s, e :: es) => + | EFfiApp (m, x, args) => 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 + val name = case ffi (m, x) of + NONE => (EM.errorAt loc "Unsupported FFI function in JavaScript"; + "ERROR") + | SOME s => s in - (strcat (str (s ^ "(") - :: e - :: es - @ [str ")"]), st) + case args of + [] => (str (name ^ "()"), st) + | [e] => + let + val (e, st) = jsE inner (e, st) + + in + (strcat [str (name ^ "("), + e, + str ")"], st) + end + | 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 (name ^ "(") + :: e + :: es + @ [str ")"]), st) + end end | EApp (e1, e2) => @@ -317,11 +349,23 @@ fun jsExp mode outer = let val (e, st) = jsE inner (e, st) in - (strcat [str "sreturn(", + (strcat [str "sr(", e, str ")"], st) end + | ESignalBind (e1, e2) => + let + val (e1, st) = jsE inner (e1, st) + val (e2, st) = jsE inner (e2, st) + in + (strcat [str "sb(", + e1, + str ",", + e2, + str ")"], + st) + end end in jsE diff --git a/src/mono.sml b/src/mono.sml index 1a7fde00..54b77550 100644 --- a/src/mono.sml +++ b/src/mono.sml @@ -105,6 +105,7 @@ datatype exp' = | EJavaScript of javascript_mode * exp | ESignalReturn of exp + | ESignalBind of exp * exp withtype exp = exp' located diff --git a/src/mono_opt.sml b/src/mono_opt.sml index 6c0e6e21..550a055c 100644 --- a/src/mono_opt.sml +++ b/src/mono_opt.sml @@ -360,6 +360,9 @@ fun exp e = | EWrite (EPrim (Prim.String ""), loc) => ERecord [] + | ESignalBind ((ESignalReturn e1, loc), e2) => + optExp (EApp (e2, e1), loc) + | _ => e and optExp e = #1 (U.Exp.map {typ = typ, exp = exp} e) diff --git a/src/mono_print.sml b/src/mono_print.sml index e44bb74c..608fe269 100644 --- a/src/mono_print.sml +++ b/src/mono_print.sml @@ -285,6 +285,12 @@ fun p_exp' par env (e, _) = | ESignalReturn e => box [string "Return(", p_exp env e, string ")"] + | ESignalBind (e1, e2) => box [string "Return(", + p_exp env e1, + string ",", + space, + p_exp env e2, + string ")"] and p_exp env = p_exp' false env diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml index e1da02c9..841e034e 100644 --- a/src/mono_reduce.sml +++ b/src/mono_reduce.sml @@ -77,6 +77,7 @@ fun impure (e, _) = | EClosure (_, es) => List.exists impure es | EJavaScript (_, e) => impure e | ESignalReturn e => impure e + | ESignalBind (e1, e2) => impure e1 orelse impure e2 val liftExpInExp = Monoize.liftExpInExp @@ -333,6 +334,7 @@ fun reduce file = | EUnurlify (e, _) => summarize d e | EJavaScript (_, e) => summarize d e | ESignalReturn e => summarize d e + | ESignalBind (e1, e2) => summarize d e1 @ summarize d e2 fun exp env e = @@ -478,6 +480,9 @@ fun reduce file = | EStrcat ((EPrim (Prim.String s1), _), (EPrim (Prim.String s2), _)) => EPrim (Prim.String (s1 ^ s2)) + | ESignalBind ((ESignalReturn e1, loc), e2) => + #1 (reduceExp env (EApp (e2, e1), loc)) + | _ => e in (*Print.prefaces "exp'" [("r", MonoPrint.p_exp env (r, ErrorMsg.dummySpan))];*) diff --git a/src/mono_util.sml b/src/mono_util.sml index 9788a551..a85443d7 100644 --- a/src/mono_util.sml +++ b/src/mono_util.sml @@ -328,6 +328,12 @@ fun mapfoldB {typ = fc, exp = fe, bind} = S.map2 (mfe ctx e, fn e' => (ESignalReturn e', loc)) + | ESignalBind (e1, e2) => + S.bind2 (mfe ctx e1, + fn e1' => + S.map2 (mfe ctx e2, + fn e2' => + (ESignalBind (e1', e2'), loc))) in mfe end diff --git a/src/monoize.sml b/src/monoize.sml index 63d84d8c..30bd5daa 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -957,8 +957,8 @@ fun monoExp (env, st, fm) (all as (e, loc)) = val mt1 = (L'.TFun (un, t1), loc) val mt2 = (L'.TFun (un, t2), loc) in - ((L'.EAbs ("m1", mt1, (L'.TFun (mt1, (L'.TFun (mt2, (L'.TFun (un, un), loc)), loc)), loc), - (L'.EAbs ("m2", mt2, (L'.TFun (un, un), loc), + ((L'.EAbs ("m1", mt1, (L'.TFun ((L'.TFun (t1, mt2), loc), (L'.TFun (un, un), loc)), loc), + (L'.EAbs ("m2", (L'.TFun (t1, mt2), loc), (L'.TFun (un, un), loc), (L'.EAbs ("_", un, un, (L'.ELet ("r", t1, (L'.EApp ((L'.ERel 2, loc), (L'.ERecord [], loc)), loc), @@ -989,6 +989,20 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L'.ESignalReturn (L'.ERel 0, loc), loc)), loc), fm) end + | L.EApp ((L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "bind"), _), _), _), t1), _), t2), _), + (L.EFfi ("Basis", "signal_monad"), _)) => + let + val t1 = monoType env t1 + val t2 = monoType env t2 + val un = (L'.TRecord [], loc) + val mt1 = (L'.TSignal t1, loc) + val mt2 = (L'.TSignal t2, loc) + in + ((L'.EAbs ("m1", mt1, (L'.TFun ((L'.TFun (t1, mt2), loc), mt2), loc), + (L'.EAbs ("m2", (L'.TFun (t1, mt2), loc), mt2, + (L'.ESignalBind ((L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc), + fm) + end | L.ECApp ((L.EFfi ("Basis", "getCookie"), _), t) => let diff --git a/tests/sbind.ur b/tests/sbind.ur new file mode 100644 index 00000000..6e3ca782 --- /dev/null +++ b/tests/sbind.ur @@ -0,0 +1,5 @@ +fun main () : transaction page = return +

Before

+

{[s]}}/>

+

After

+ diff --git a/tests/sbind.urp b/tests/sbind.urp new file mode 100644 index 00000000..d8735c70 --- /dev/null +++ b/tests/sbind.urp @@ -0,0 +1,3 @@ +debug + +sbind -- cgit v1.2.3 From 0d98ce87ef495ab8652327866b9a2253cbe824d7 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 13 Jan 2009 15:17:11 -0500 Subject: Initial experiments with nested --- jslib/urweb.js | 3 +++ lib/basis.urs | 11 +++++++++++ src/compiler.sig | 1 + src/compiler.sml | 3 ++- src/elaborate.sml | 4 ++-- src/jscomp.sml | 33 ++++++++++++++++++++++++++------- src/mono_reduce.sml | 11 ++++++----- src/monoize.sml | 29 +++++++++++++++++++++++++++++ tests/dlist.ur | 22 ++++++++++++++++++++++ tests/dlist.urp | 3 +++ 10 files changed, 105 insertions(+), 15 deletions(-) create mode 100644 tests/dlist.ur create mode 100644 tests/dlist.urp (limited to 'src/compiler.sig') diff --git a/jslib/urweb.js b/jslib/urweb.js index 8e39f9f3..0ee19992 100644 --- a/jslib/urweb.js +++ b/jslib/urweb.js @@ -13,6 +13,9 @@ function sv(s, v) { s.v = v; callAll(s.h); } +function sg(s) { + return s.v; +} function ss(s) { return s; diff --git a/lib/basis.urs b/lib/basis.urs index 9b09e8d2..b4a40fde 100644 --- a/lib/basis.urs +++ b/lib/basis.urs @@ -86,6 +86,7 @@ val transaction_monad : monad transaction con source :: Type -> Type val source : t ::: Type -> t -> transaction (source t) val set : t ::: Type -> source t -> t -> transaction unit +val get : t ::: Type -> source t -> transaction t con signal :: Type -> Type val signal_monad : monad signal @@ -443,6 +444,16 @@ val submit : ctx ::: {Unit} -> use ::: {Type} -> tag [Value = string, Action = $use -> transaction page] ([Form] ++ ctx) ([Form] ++ ctx) use [] +(*** AJAX-oriented widgets *) + +con cformTag = fn (attrs :: {Type}) => + ctx ::: {Unit} + -> fn [[Body] ~ ctx] => + unit -> tag attrs ([Body] ++ ctx) [] [] [] + +val ctextbox : cformTag [Value = string, Size = int, Source = source string] +val button : cformTag [Value = string, Onclick = transaction unit] + (*** Tables *) val tabl : other ::: {Unit} -> fn [other ~ [Body, Table]] => diff --git a/src/compiler.sig b/src/compiler.sig index c156b268..b126fb51 100644 --- a/src/compiler.sig +++ b/src/compiler.sig @@ -107,6 +107,7 @@ signature COMPILER = sig val toMono_opt3 : (string, Mono.file) transform val toFuse : (string, Mono.file) transform val toUntangle2 : (string, Mono.file) transform + val toMono_reduce2 : (string, Mono.file) transform val toMono_shake2 : (string, Mono.file) transform val toPathcheck : (string, Mono.file) transform val toCjrize : (string, Cjr.file) transform diff --git a/src/compiler.sml b/src/compiler.sml index 6d499283..52181401 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -531,7 +531,8 @@ val toFuse = transform fuse "fuse" o toMono_opt3 val toUntangle2 = transform untangle "untangle2" o toFuse -val toMono_shake2 = transform mono_shake "mono_shake2" o toUntangle2 +val toMono_reduce2 = transform mono_reduce "mono_reduce2" o toUntangle2 +val toMono_shake2 = transform mono_shake "mono_shake2" o toMono_reduce2 val pathcheck = { func = (fn file => (PathCheck.check file; file)), diff --git a/src/elaborate.sml b/src/elaborate.sml index c18cfb49..39cb85b2 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -3003,10 +3003,10 @@ fun elabDecl (dAll as (d, loc), (env, denv, gs : constraint list)) = val env = E.pushDatatype env n xs xcs val d' = (L'.DDatatype (x, n, xs, xcs), loc) in - if positive then + (*if positive then () else - declError env (Nonpositive d'); + declError env (Nonpositive d');*) ([d'], (env, denv, gs' @ gs)) end diff --git a/src/jscomp.sml b/src/jscomp.sml index 64cb1771..1b675abd 100644 --- a/src/jscomp.sml +++ b/src/jscomp.sml @@ -37,6 +37,7 @@ structure IS = IntBinarySet structure IM = IntBinaryMap val funcs = [(("Basis", "alert"), "alert"), + (("Basis", "get_client_source"), "sg"), (("Basis", "htmlifyBool"), "bs"), (("Basis", "htmlifyFloat"), "ts"), (("Basis", "htmlifyInt"), "ts"), @@ -435,11 +436,22 @@ fun process file = fail, str ")"]) - fun deStrcat (e, _) = + val jsifyString = String.translate (fn #"\"" => "\\\"" + | #"\\" => "\\\\" + | ch => String.str ch) + + fun jsifyStringMulti (n, s) = + case n of + 0 => s + | _ => jsifyStringMulti (n - 1, jsifyString s) + + fun deStrcat level (all as (e, _)) = case e of - EPrim (Prim.String s) => s - | EStrcat (e1, e2) => deStrcat e1 ^ deStrcat e2 - | _ => raise Fail "Jscomp: deStrcat" + EPrim (Prim.String s) => jsifyStringMulti (level, s) + | EStrcat (e1, e2) => deStrcat level e1 ^ deStrcat level e2 + | EFfiApp ("Basis", "jsifyString", [e]) => "\"" ^ deStrcat (level + 1) e ^ "\"" + | _ => (Print.prefaces "deStrcat" [("e", MonoPrint.p_exp MonoEnv.empty all)]; + raise Fail "Jscomp: deStrcat") val quoteExp = quoteExp loc in @@ -474,7 +486,8 @@ fun process file = maxName = #maxName st} val (e, st) = jsExp mode skip [] 0 (e, st) - val e = deStrcat e + val () = Print.prefaces "Pre-e" [("e", MonoPrint.p_exp MonoEnv.empty e)] + val e = deStrcat 0 e val sc = "_n" ^ Int.toString n ^ "=" ^ e ^ ";\n" in @@ -745,14 +758,20 @@ fun process file = str ")"], st) end - | EJavaScript (_, _, SOME _) => (e, st) + | EJavaScript (Source _, _, SOME _) => (e, st) + | EJavaScript (_, _, SOME e) => ((EFfiApp ("Basis", "jsifyString", [e]), loc), st) | EClosure _ => unsupported "EClosure" | EQuery _ => unsupported "Query" | EDml _ => unsupported "DML" | ENextval _ => unsupported "Nextval" | EUnurlify _ => unsupported "EUnurlify" - | EJavaScript (_, e, _) => unsupported "Nested JavaScript" + | EJavaScript (_, e, _) => + let + val (e, st) = jsE inner (e, st) + in + ((EFfiApp ("Basis", "jsifyString", [e]), loc), st) + end | ESignalReturn e => let diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml index 0117623f..878fec92 100644 --- a/src/mono_reduce.sml +++ b/src/mono_reduce.sml @@ -479,11 +479,12 @@ fun reduce file = | WriteDb => not writesDb andalso not readsDb andalso verifyCompatible effs in (*Print.prefaces "verifyCompatible" - [("e'", MonoPrint.p_exp env e'), - ("b", MonoPrint.p_exp (E.pushERel env x t NONE) b), - ("effs_e'", Print.p_list p_event effs_e'), - ("effs_b", Print.p_list p_event effs_b)];*) - if List.null effs_e' orelse verifyCompatible effs_b then + [("e'", MonoPrint.p_exp env e'), + ("b", MonoPrint.p_exp (E.pushERel env x t NONE) b), + ("effs_e'", Print.p_list p_event effs_e'), + ("effs_b", Print.p_list p_event effs_b)];*) + if List.null effs_e' orelse (List.all (fn eff => eff <> Unsure) effs_e' + andalso verifyCompatible effs_b) then trySub () else e diff --git a/src/monoize.sml b/src/monoize.sml index 56310c1b..993034e4 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -1000,6 +1000,18 @@ fun monoExp (env, st, fm) (all as (e, loc)) = loc)), loc)), loc)), loc), fm) end + | L.ECApp ((L.EFfi ("Basis", "get"), _), t) => + let + val t = monoType env t + in + ((L'.EAbs ("src", (L'.TSource, loc), + (L'.TFun ((L'.TRecord [], loc), t), loc), + (L'.EAbs ("_", (L'.TRecord [], loc), t, + (L'.EFfiApp ("Basis", "get_client_source", + [(L'.ERel 1, loc)]), + loc)), loc)), loc), + fm) + end | L.EApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "return"), _), _), _), t), _), (L.EFfi ("Basis", "signal_monad"), _)) => @@ -1905,6 +1917,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = | _ => raise Fail "Monoize: Bad dyn attributes") | "submit" => normal ("input type=\"submit\"", NONE, NONE) + | "button" => normal ("input type=\"submit\"", NONE, NONE) | "textbox" => (case targs of @@ -1978,6 +1991,22 @@ fun monoExp (env, st, fm) (all as (e, loc)) = | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs); raise Fail "No name passed to lselect tag")) + | "ctextbox" => + (case List.find (fn ("Source", _, _) => true | _ => false) attrs of + NONE => + let + val (ts, fm) = tagStart "input" + in + ((L'.EStrcat (ts, + (L'.EPrim (Prim.String "/>"), loc)), + loc), fm) + end + | SOME (_, src, _) => + (strcat [str ""], + fm)) + | "option" => normal ("option", NONE, NONE) | "tabl" => normal ("table", NONE, NONE) diff --git a/tests/dlist.ur b/tests/dlist.ur new file mode 100644 index 00000000..211291bc --- /dev/null +++ b/tests/dlist.ur @@ -0,0 +1,22 @@ +datatype dlist = Nil | Cons of string * source dlist + +fun delist dl = + case dl of + Nil => [] + | Cons (x, s) => {[x]} :: {delistSource s} + +and delistSource s = + +fun main () : transaction page = + ns <- source Nil; + s <- source ns; + tb <- source ""; + return +
+
+ +