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/tag.sml | 174 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 174 insertions(+) create mode 100644 src/tag.sml (limited to 'src/tag.sml') 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