Mercurial > urweb

changeset 1856:3683d1a8c1c8

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Add Sigcheck phase to avoid issues with signatures in global initializers
author Adam Chlipala <adam@chlipala.net>
date Sat, 15 Jun 2013 08:18:47 -0400
parents 0480b8f29a47
children 79c0c22e13ae
files src/compiler.sig src/compiler.sml src/sigcheck.sig src/sigcheck.sml src/sources
diffstat 5 files changed, 146 insertions(+), 1 deletions(-) [+]
line wrap: on
line diff
--- 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
--- 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,
--- /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
--- /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
--- 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