From 95d278b9b8e9c314541b8251a34a32fe6deeb896 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 13 Jul 2008 11:43:57 -0400 Subject: Starting with closure links --- src/compiler.sig | 2 + src/compiler.sml | 20 +++++- src/core.sml | 2 + src/core_print.sml | 6 ++ src/core_util.sig | 12 ++++ src/core_util.sml | 21 +++++++ src/corify.sml | 7 ++- src/elab_print.sml | 1 + src/elaborate.sml | 7 +-- src/lacweb.grm | 2 + src/lacweb.lex | 6 +- src/list_util.sig | 2 + src/list_util.sml | 10 +++ src/monoize.sml | 2 + src/sources | 3 + src/tag.sig | 32 ++++++++++ src/tag.sml | 174 +++++++++++++++++++++++++++++++++++++++++++++++++++++ 17 files changed, 299 insertions(+), 10 deletions(-) create mode 100644 src/tag.sig create mode 100644 src/tag.sml (limited to 'src') diff --git a/src/compiler.sig b/src/compiler.sig index 62d38308..eca871f8 100644 --- a/src/compiler.sig +++ b/src/compiler.sig @@ -43,6 +43,7 @@ signature COMPILER = sig val explify : job -> Expl.file option val corify : job -> Core.file option val shake' : job -> Core.file option + val tag : job -> Core.file option val reduce : job -> Core.file option val shake : job -> Core.file option val monoize : job -> Mono.file option @@ -54,6 +55,7 @@ signature COMPILER = sig val testExplify : job -> unit val testCorify : job -> unit val testShake' : job -> unit + val testTag : job -> unit val testReduce : job -> unit val testShake : job -> unit val testMonoize : job -> unit diff --git a/src/compiler.sml b/src/compiler.sml index 1f063633..e54fe5b4 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -196,8 +196,17 @@ fun shake' job = else SOME (Shake.shake file) +fun tag job = + case shake' job of + NONE => NONE + | SOME file => + if ErrorMsg.anyErrors () then + NONE + else + SOME (Tag.tag file) + fun reduce job = - case corify job of + case tag job of NONE => NONE | SOME file => if ErrorMsg.anyErrors () then @@ -285,6 +294,15 @@ fun testShake' job = handle CoreEnv.UnboundNamed n => print ("Unbound named " ^ Int.toString n ^ "\n") +fun testTag job = + (case tag job of + NONE => print "Failed\n" + | SOME file => + (Print.print (CorePrint.p_file CoreEnv.empty file); + print "\n")) + handle CoreEnv.UnboundNamed n => + print ("Unbound named " ^ Int.toString n ^ "\n") + fun testReduce job = (case reduce job of NONE => print "Failed\n" diff --git a/src/core.sml b/src/core.sml index fe969d18..69eafd33 100644 --- a/src/core.sml +++ b/src/core.sml @@ -76,6 +76,8 @@ datatype exp' = | EWrite of exp + | EClosure of int * exp list + withtype exp = exp' located datatype decl' = diff --git a/src/core_print.sml b/src/core_print.sml index b1cc9c2d..60ad619f 100644 --- a/src/core_print.sml +++ b/src/core_print.sml @@ -232,6 +232,12 @@ fun p_exp' par env (e, _) = p_exp env e, string ")"] + | EClosure (n, es) => box [string "CLOSURE(", + p_enamed env n, + p_list_sep (string "") (fn e => box [string ", ", + p_exp env e]) es, + string ")"] + and p_exp env = p_exp' false env fun p_decl env ((d, _) : decl) = diff --git a/src/core_util.sig b/src/core_util.sig index 423b93b4..5629e8fa 100644 --- a/src/core_util.sig +++ b/src/core_util.sig @@ -121,6 +121,12 @@ structure Decl : sig exp : Core.exp' * 'state -> 'state, decl : Core.decl' * 'state -> 'state} -> 'state -> Core.decl -> 'state + + val foldMap : {kind : Core.kind' * 'state -> Core.kind' * 'state, + con : Core.con' * 'state -> Core.con' * 'state, + exp : Core.exp' * 'state -> Core.exp' * 'state, + decl : Core.decl' * 'state -> Core.decl' * 'state} + -> 'state -> Core.decl -> Core.decl * 'state end structure File : sig @@ -151,6 +157,12 @@ structure File : sig exp : Core.exp' * 'state -> 'state, decl : Core.decl' * 'state -> 'state} -> 'state -> Core.file -> 'state + + val foldMap : {kind : Core.kind' * 'state -> Core.kind' * 'state, + con : Core.con' * 'state -> Core.con' * 'state, + exp : Core.exp' * 'state -> Core.exp' * 'state, + decl : Core.decl' * 'state -> Core.decl' * 'state} + -> 'state -> Core.file -> Core.file * 'state end end diff --git a/src/core_util.sml b/src/core_util.sml index 11d70de9..427a313d 100644 --- a/src/core_util.sml +++ b/src/core_util.sml @@ -291,6 +291,11 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, bind} = S.map2 (mfe ctx e, fn e' => (EWrite e', loc)) + + | EClosure (n, es) => + S.map2 (ListUtil.mapfold (mfe ctx) es, + fn es' => + (EClosure (n, es'), loc)) in mfe end @@ -401,6 +406,14 @@ fun fold {kind, con, exp, decl} s d = S.Continue (_, s) => s | S.Return _ => raise Fail "CoreUtil.Decl.fold: Impossible" +fun foldMap {kind, con, exp, decl} s d = + 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)), + decl = fn d => fn s => S.Continue (decl (d, s))} d s of + S.Continue v => v + | S.Return _ => raise Fail "CoreUtil.Decl.foldMap: Impossible" + end structure File = struct @@ -456,6 +469,14 @@ fun fold {kind, con, exp, decl} s d = S.Continue (_, s) => s | S.Return _ => raise Fail "CoreUtil.File.fold: Impossible" +fun foldMap {kind, con, exp, decl} s d = + 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)), + decl = fn d => fn s => S.Continue (decl (d, s))} d s of + S.Continue v => v + | S.Return _ => raise Fail "CoreUtil.File.foldMap: Impossible" + end end diff --git a/src/corify.sml b/src/corify.sml index faeda0d1..9c44140d 100644 --- a/src/corify.sml +++ b/src/corify.sml @@ -358,7 +358,8 @@ fun corifyExp st (e, loc) = | L.ECApp (e1, c) => (L'.ECApp (corifyExp st e1, corifyCon st c), loc) | L.ECAbs (x, k, e1) => (L'.ECAbs (x, corifyKind k, corifyExp st e1), loc) - | L.ERecord xes => (L'.ERecord (map (fn (c, e, t) => (corifyCon st c, corifyExp st e, corifyCon st t)) xes), loc) + | L.ERecord xes => (L'.ERecord (map (fn (c, e, t) => + (corifyCon st c, corifyExp st e, corifyCon st t)) xes), loc) | L.EField (e1, c, {field, rest}) => (L'.EField (corifyExp st e1, corifyCon st c, {field = corifyCon st field, rest = corifyCon st rest}), loc) | L.EFold k => (L'.EFold (corifyKind k), loc) @@ -450,8 +451,8 @@ fun corifyDecl ((d, loc : EM.span), st) = (case (#1 dom, #1 ran) of (L.TRecord _, L.CApp ((L.CModProj (_, [], "xml"), _), - (L.TRecord (L.CRecord (_, [((L.CName "Html", _), - _)]), _), _))) => + (L.CRecord (_, [((L.CName "Html", _), + _)]), _))) => let val ran = (L.TRecord (L.CRecord ((L.KType, loc), []), loc), loc) val e = (L.EModProj (m, ms, s), loc) diff --git a/src/elab_print.sml b/src/elab_print.sml index 8d676f4a..a95b2952 100644 --- a/src/elab_print.sml +++ b/src/elab_print.sml @@ -451,6 +451,7 @@ fun p_decl env ((d, _) : decl) = space, p_con env c2] | DExport (_, sgn, str) => box [string "export", + space, p_str env str, space, string ":", diff --git a/src/elaborate.sml b/src/elaborate.sml index 81b3e8c4..af5c6c95 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -1945,13 +1945,12 @@ fun elabDecl ((d, loc), (env, denv, gs)) = (case (hnormCon (env, denv) dom, hnormCon (env, denv) ran) of (((L'.TRecord domR, _), []), ((L'.CApp (tf, ranR), _), [])) => - (case hnormCon (env, denv) ranR of - (ranR, []) => + (case (hnormCon (env, denv) tf, hnormCon (env, denv) ranR) of + ((tf, []), (ranR, [])) => (case (hnormCon (env, denv) domR, hnormCon (env, denv) ranR) of ((domR, []), (ranR, [])) => (L'.SgiVal (x, n, (L'.TFun ((L'.TRecord domR, loc), - (L'.CApp (tf, - (L'.TRecord ranR, loc)), loc)), + (L'.CApp (tf, ranR), loc)), loc)), loc) | _ => all) | _ => all) diff --git a/src/lacweb.grm b/src/lacweb.grm index 914f3551..2cc23e78 100644 --- a/src/lacweb.grm +++ b/src/lacweb.grm @@ -281,6 +281,7 @@ eterm : LPAREN eexp RPAREN (#1 eexp, s (LPARENleft, RPARENright)) | path (EVar path, s (pathleft, pathright)) | LBRACE rexp RBRACE (ERecord rexp, s (LBRACEleft, RBRACEright)) + | UNIT (ERecord [], s (UNITleft, UNITright)) | INT (EPrim (Prim.Int INT), s (INTleft, INTright)) | FLOAT (EPrim (Prim.Float FLOAT), s (FLOATleft, FLOATright)) @@ -345,3 +346,4 @@ attr : SYMBOL EQ attrv ((CName (uppercaseFirst SYMBOL), s (SYMB attrv : INT (EPrim (Prim.Int INT), s (INTleft, INTright)) | FLOAT (EPrim (Prim.Float FLOAT), s (FLOATleft, FLOATright)) | STRING (EPrim (Prim.String STRING), s (STRINGleft, STRINGright)) + | LBRACE eexp RBRACE (eexp) diff --git a/src/lacweb.lex b/src/lacweb.lex index 41163a61..b54d9e21 100644 --- a/src/lacweb.lex +++ b/src/lacweb.lex @@ -227,8 +227,10 @@ notags = [^<{\n]+; ")" => (Tokens.RPAREN (pos yypos, pos yypos + size yytext)); "[" => (Tokens.LBRACK (pos yypos, pos yypos + size yytext)); "]" => (Tokens.RBRACK (pos yypos, pos yypos + size yytext)); - "{" => (Tokens.LBRACE (pos yypos, pos yypos + size yytext)); - "}" => (Tokens.RBRACE (pos yypos, pos yypos + size yytext)); + "{" => (enterBrace (); + Tokens.LBRACE (pos yypos, pos yypos + size yytext)); + "}" => (exitBrace (); + Tokens.RBRACE (pos yypos, pos yypos + size yytext)); "->" => (Tokens.ARROW (pos yypos, pos yypos + size yytext)); "=>" => (Tokens.DARROW (pos yypos, pos yypos + size yytext)); diff --git a/src/list_util.sig b/src/list_util.sig index b4ea338c..e0629c5d 100644 --- a/src/list_util.sig +++ b/src/list_util.sig @@ -27,6 +27,8 @@ signature LIST_UTIL = sig + val mapConcat : ('a -> 'b list) -> 'a list -> 'b list + val mapfold : ('data, 'state, 'abort) Search.mapfolder -> ('data list, 'state, 'abort) Search.mapfolder val mapfoldB : ('context * 'data -> 'context * ('state -> ('data * 'state, 'abort) Search.result)) diff --git a/src/list_util.sml b/src/list_util.sml index 7f87b87e..fff3e78e 100644 --- a/src/list_util.sml +++ b/src/list_util.sml @@ -29,6 +29,16 @@ structure ListUtil :> LIST_UTIL = struct structure S = Search +fun mapConcat f = + let + fun mc acc ls = + case ls of + [] => rev acc + | h :: t => mc (List.revAppend (f h, acc)) t + in + mc [] + end + fun mapfold f = let fun mf ls s = diff --git a/src/monoize.sml b/src/monoize.sml index 5f5db692..2e21a2bf 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -192,6 +192,8 @@ fun monoExp env (all as (e, loc)) = | L.EField (e, x, _) => (L'.EField (monoExp env e, monoName env x), loc) | L.EFold _ => poly () | L.EWrite e => (L'.EWrite (monoExp env e), loc) + + | L.EClosure _ => raise Fail "Monoize EClosure" end fun monoDecl env (all as (d, loc)) = diff --git a/src/sources b/src/sources index 7faec26b..2453e1c5 100644 --- a/src/sources +++ b/src/sources @@ -75,6 +75,9 @@ reduce.sml shake.sig shake.sml +tag.sig +tag.sml + mono.sml mono_util.sig diff --git a/src/tag.sig b/src/tag.sig new file mode 100644 index 00000000..c19a353e --- /dev/null +++ b/src/tag.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 TAG = sig + + val tag : Core.file -> Core.file + +end diff --git a/src/tag.sml b/src/tag.sml new file mode 100644 index 00000000..a244c294 --- /dev/null +++ b/src/tag.sml @@ -0,0 +1,174 @@ +(* 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 Tag :> TAG = struct + +open Core + +structure U = CoreUtil +structure E = CoreEnv + +structure IM = IntBinaryMap + +fun kind (k, s) = (k, s) +fun con (c, s) = (c, s) + +fun exp (e, s) = + case e of + EApp ( + (EApp ( + (EApp ( + (ECApp ( + (ECApp ( + (ECApp ( + (ECApp ( + (EFfi ("Basis", "tag"), + loc), given), _), absent), _), outer), _), inner), _), + attrs), _), + tag), _), + xml) => + (case attrs of + (ERecord xets, _) => + let + val (xets, s) = + ListUtil.foldlMap (fn ((x, e, t), (count, tags, newTags)) => + case x of + (CName "Link", _) => + let + fun unravel (e, _) = + case e of + ENamed n => (n, []) + | EApp (e1, e2) => + let + val (n, es) = unravel e1 + in + (n, es @ [e2]) + end + | _ => (ErrorMsg.errorAt loc "Invalid link expression"; + (0, [])) + + val (f, args) = unravel e + + val (cn, count, tags, newTags) = + case IM.find (tags, f) of + NONE => + (count, count + 1, IM.insert (tags, f, count), + (f, count) :: newTags) + | SOME cn => (cn, count, tags, newTags) + + val e = (EClosure (cn, args), loc) + val t = (CFfi ("Basis", "string"), loc) + in + ((x, e, t), + (count, tags, newTags)) + end + | _ => ((x, e, t), (count, tags, newTags))) + s xets + in + (EApp ( + (EApp ( + (EApp ( + (ECApp ( + (ECApp ( + (ECApp ( + (ECApp ( + (EFfi ("Basis", "tag"), + loc), given), loc), absent), loc), outer), loc), inner), loc), + (ERecord xets, loc)), loc), + tag), loc), + xml), s) + end + | _ => (ErrorMsg.errorAt loc "Attribute record is too complex"; + (e, s))) + + | _ => (e, s) + +fun decl (d, s) = (d, s) + +fun tag file = + let + val count = foldl (fn ((d, _), count) => + case d of + DCon (_, n, _, _) => Int.max (n, count) + | DVal (_, n, _, _, _) => Int.max (n, count) + | DExport _ => count) 0 file + + fun doDecl (d as (d', loc), (env, count, tags)) = + let + val (d, (count, tags, newTags)) = + U.Decl.foldMap {kind = kind, + con = con, + exp = exp, + decl = decl} + (count, tags, []) d + + val env = E.declBinds env d + + val newDs = ListUtil.mapConcat + (fn (f, cn) => + let + fun unravel (all as (t, _)) = + case t of + TFun (dom, ran) => + let + val (args, result) = unravel ran + in + (dom :: args, result) + end + | _ => ([], all) + + val (fnam, t, _, tag) = E.lookupENamed env f + val (args, result) = unravel t + + val (app, _) = foldl (fn (t, (app, n)) => + ((EApp (app, (ERel n, loc)), loc), + n - 1)) + ((ENamed f, loc), length args - 1) args + val body = (EWrite app, loc) + val unit = (TRecord (CRecord ((KType, loc), []), loc), loc) + val (abs, _, t) = foldr (fn (t, (abs, n, rest)) => + ((EAbs ("x" ^ Int.toString n, + t, + rest, + abs), loc), + n + 1, + (TFun (t, rest), loc))) + (body, 0, unit) args + in + [(DVal ("wrap_" ^ fnam, cn, t, abs, tag), loc), + (DExport cn, loc)] + end) newTags + in + (newDs @ [d], (env, count, tags)) + end + + val (file, _) = ListUtil.foldlMapConcat doDecl (CoreEnv.empty, count, IM.empty) file + in + file + end + +end -- cgit v1.2.3