# HG changeset patch # User Adam Chlipala # Date 1371298727 14400 # Node ID 3683d1a8c1c8ccc278450ecac33171046aa1520d # Parent 0480b8f29a479b738d122da382626baa97b5b385 Add Sigcheck phase to avoid issues with signatures in global initializers diff -r 0480b8f29a47 -r 3683d1a8c1c8 src/compiler.sig --- a/src/compiler.sig Fri Jun 07 16:11:52 2013 -0400 +++ b/src/compiler.sig Sat Jun 15 08:18:47 2013 -0400 @@ -121,6 +121,7 @@ val fuse : (Mono.file, Mono.file) phase val pathcheck : (Mono.file, Mono.file) phase val sidecheck : (Mono.file, Mono.file) phase + val sigcheck : (Mono.file, Mono.file) phase val cjrize : (Mono.file, Cjr.file) phase val prepare : (Cjr.file, Cjr.file) phase val checknest : (Cjr.file, Cjr.file) phase @@ -184,6 +185,7 @@ val toMono_shake3 : (string, Mono.file) transform val toPathcheck : (string, Mono.file) transform val toSidecheck : (string, Mono.file) transform + val toSigcheck : (string, Mono.file) transform val toCjrize : (string, Cjr.file) transform val toPrepare : (string, Cjr.file) transform val toChecknest : (string, Cjr.file) transform diff -r 0480b8f29a47 -r 3683d1a8c1c8 src/compiler.sml --- a/src/compiler.sml Fri Jun 07 16:11:52 2013 -0400 +++ b/src/compiler.sml Sat Jun 15 08:18:47 2013 -0400 @@ -1410,12 +1410,19 @@ val toSidecheck = transform sidecheck "sidecheck" o toPathcheck +val sigcheck = { + func = SigCheck.check, + print = MonoPrint.p_file MonoEnv.empty +} + +val toSigcheck = transform sigcheck "sigcheck" o toSidecheck + val cjrize = { func = Cjrize.cjrize, print = CjrPrint.p_file CjrEnv.empty } -val toCjrize = transform cjrize "cjrize" o toSidecheck +val toCjrize = transform cjrize "cjrize" o toSigcheck val prepare = { func = Prepare.prepare, diff -r 0480b8f29a47 -r 3683d1a8c1c8 src/sigcheck.sig --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/sigcheck.sig Sat Jun 15 08:18:47 2013 -0400 @@ -0,0 +1,36 @@ +(* Copyright (c) 2013, 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. + *) + +(* Make sure that no global variable initializers mention signature generation, + * because said generation only makes sense in the context of a page view. + * Replace such global variables with functions. *) + +signature SIG_CHECK = sig + + val check : Mono.file -> Mono.file + +end diff -r 0480b8f29a47 -r 3683d1a8c1c8 src/sigcheck.sml --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/sigcheck.sml Sat Jun 15 08:18:47 2013 -0400 @@ -0,0 +1,97 @@ +(* Copyright (c) 2013, 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 SigCheck :> SIG_CHECK = struct + +open Mono + +structure IS = IntBinarySet +structure E = ErrorMsg + +fun check (ds, sl) = + let + fun isSiggy siggers = + MonoUtil.Decl.exists {typ = fn _ => false, + decl = fn _ => false, + exp = fn e => + case e of + ERel n => IS.member (siggers, n) + | EFfiApp ("Basis", "sigString", _) => true + | _ => false} + + fun sigify' sigdecs e = + case e of + ENamed n => if IS.member (sigdecs, n) then + (EApp ((e, E.dummySpan), + (ERecord [], E.dummySpan))) + else + e + | _ => e + + fun sigify sigdecs = + MonoUtil.Decl.map {typ = fn x => x, + decl = fn d => d, + exp = sigify' sigdecs} + + fun sigifyE sigdecs = + MonoUtil.Exp.map {typ = fn x => x, + exp = sigify' sigdecs} + + fun isFun (e, _) = + case e of + EAbs _ => true + | _ => false + + fun doDecl (d : decl, (siggers, sigdecs)) = + case #1 d of + DVal (x, n, t, e, s) => + if isSiggy siggers d then + if isFun e then + (sigify sigdecs d, (IS.add (siggers, n), sigdecs)) + else + ((DVal (x, n, (TFun ((TRecord [], #2 d), t), #2 d), + (EAbs ("_", (TRecord [], #2 d), t, sigifyE sigdecs e), #2 d), + s), #2 d), + (IS.add (siggers, n), + IS.add (sigdecs, n))) + else + (sigify sigdecs d, (siggers, sigdecs)) + | DValRec vis => + if isSiggy siggers d then + (sigify sigdecs d, + (foldl IS.add' siggers (map #2 vis), + sigdecs)) + else + (sigify sigdecs d, (siggers, sigdecs)) + | _ => (sigify sigdecs d, (siggers, sigdecs)) + + val (ds, _) = ListUtil.foldlMap doDecl (IS.empty, IS.empty) ds + in + (ds, sl) + end + +end diff -r 0480b8f29a47 -r 3683d1a8c1c8 src/sources --- a/src/sources Fri Jun 07 16:11:52 2013 -0400 +++ b/src/sources Sat Jun 15 08:18:47 2013 -0400 @@ -200,6 +200,9 @@ sidecheck.sig sidecheck.sml +sigcheck.sig +sigcheck.sml + cjr.sml postgres.sig