From 82137590b9de8f10a6b0245cc881019baccd5340 Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adam@chlipala.net>
Date: Thu, 12 Jan 2012 20:37:39 -0500
Subject: -dumpSource flag; Especialize tweak: may specialize any argument
 sequence ending in a value of function-containing type

---
 src/compiler.sig    |  4 +++-
 src/compiler.sml    | 15 ++++++++++++---
 src/especialize.sml | 28 ++++++++++++++--------------
 src/main.mlton.sml  |  5 ++++-
 src/rpcify.sml      |  4 +++-
 5 files changed, 36 insertions(+), 20 deletions(-)

(limited to 'src')

diff --git a/src/compiler.sig b/src/compiler.sig
index 8bf493f1..53887ecb 100644
--- a/src/compiler.sig
+++ b/src/compiler.sig
@@ -1,4 +1,4 @@
-(* Copyright (c) 2008-2010, Adam Chlipala
+(* Copyright (c) 2008-2012, Adam Chlipala
  * All rights reserved.
  *
  * Redistribution and use in source and binary forms, with or without
@@ -185,6 +185,8 @@ signature COMPILER = sig
     val toSqlify : (string, Cjr.file) transform
 
     val debug : bool ref
+    val dumpSource : bool ref
+
     val doIflow : bool ref
 
     val addPath : string * string -> unit
diff --git a/src/compiler.sml b/src/compiler.sml
index 57c3e1ff..8ee86947 100644
--- a/src/compiler.sml
+++ b/src/compiler.sml
@@ -1,4 +1,4 @@
-(* Copyright (c) 2008-2011, Adam Chlipala
+(* Copyright (c) 2008-2012, Adam Chlipala
  * All rights reserved.
  *
  * Redistribution and use in source and binary forms, with or without
@@ -79,8 +79,11 @@ type ('src, 'dst) transform = {
 }
 
 val debug = ref false
+val dumpSource = ref false
 val doIflow = ref false
 
+val doDumpSource = ref (fn () => ())
+
 fun transform (ph : ('src, 'dst) phase) name = {
     func = fn input => let
                   val () = if !debug then
@@ -94,9 +97,15 @@ fun transform (ph : ('src, 'dst) phase) name = {
                   else
                       ();
                   if ErrorMsg.anyErrors () then
-                      NONE
+                      (!doDumpSource ();
+                       doDumpSource := (fn () => ());
+                       NONE)
                   else
-                      SOME v
+                      (if !dumpSource then
+                           doDumpSource := (fn () => Print.eprint (#print ph v))
+                       else
+                           ();
+                       SOME v)
               end,
     print = #print ph,
     time = fn (input, pmap) => let
diff --git a/src/especialize.sml b/src/especialize.sml
index a73d4064..fb1dfecd 100644
--- a/src/especialize.sml
+++ b/src/especialize.sml
@@ -1,4 +1,4 @@
-(* Copyright (c) 2008-2011, Adam Chlipala
+(* Copyright (c) 2008-2012, Adam Chlipala
  * All rights reserved.
  *
  * Redistribution and use in source and binary forms, with or without
@@ -210,13 +210,8 @@ fun calcConstArgs enclosingFunction e =
             case #1 e of
                 EAbs (_, _, _, e1) => enterAbs (depth + 1) e1
               | _ => ca depth e
-
-        val n = enterAbs 0 e
     in
-        if n = maxInt then
-            0
-        else
-            n
+        enterAbs 0 e
     end
 
 
@@ -373,18 +368,23 @@ fun specialize' (funcs, specialized) file =
 
                             val loc = ErrorMsg.dummySpan
 
+                            val oldXs = xs
+
                             fun findSplit av (constArgs, xs, typ, fxs, fvs) =
                                 case (#1 typ, xs) of
                                     (TFun (dom, ran), e :: xs') =>
                                     if constArgs > 0 then
-                                        findSplit av (constArgs - 1,
-                                                      xs',
-                                                      ran,
-                                                      e :: fxs,
-                                                      IS.union (fvs, freeVars e))
+                                        if functionInside dom then
+                                            (rev (e :: fxs), xs', IS.union (fvs, freeVars e))
+                                        else
+                                            findSplit av (constArgs - 1,
+                                                          xs',
+                                                          ran,
+                                                          e :: fxs,
+                                                          IS.union (fvs, freeVars e))
                                     else
-                                        (rev fxs, xs, fvs)
-                                  | _ => (rev fxs, xs, fvs)
+                                        ([], oldXs, IS.empty)
+                                  | _ => ([], oldXs, IS.empty)
 
                             val (fxs, xs, fvs) = findSplit true (constArgs, xs, typ, [], IS.empty)
 
diff --git a/src/main.mlton.sml b/src/main.mlton.sml
index 6f38efa8..57927258 100644
--- a/src/main.mlton.sml
+++ b/src/main.mlton.sml
@@ -1,4 +1,4 @@
-(* Copyright (c) 2008-2011, Adam Chlipala
+(* Copyright (c) 2008-2012, Adam Chlipala
  * All rights reserved.
  *
  * Redistribution and use in source and binary forms, with or without
@@ -85,6 +85,9 @@ fun doArgs args =
       | "-dumpTypes" :: rest =>
         (Elaborate.dumpTypes := true;
          doArgs rest)
+      | "-dumpSource" :: rest =>
+        (Compiler.dumpSource := true;
+         doArgs rest)
       | "-output" :: s :: rest =>
         (Settings.setExe (SOME s);
          doArgs rest)
diff --git a/src/rpcify.sml b/src/rpcify.sml
index 63330942..8d309a82 100644
--- a/src/rpcify.sml
+++ b/src/rpcify.sml
@@ -1,4 +1,4 @@
-(* Copyright (c) 2009, Adam Chlipala
+(* Copyright (c) 2009, 2012, Adam Chlipala
  * All rights reserved.
  *
  * Redistribution and use in source and binary forms, with or without
@@ -93,6 +93,8 @@ fun frob file =
                     case getApp (#1 trans, []) of
                         NONE => (ErrorMsg.errorAt (#2 trans)
                                                   "RPC code doesn't use a named function or transaction";
+                                 (*Print.preface ("Expression",
+                                                CorePrint.p_exp CoreEnv.empty trans);*)
                                  (#1 trans, st))
                       | SOME (n, args) =>
                         case IM.find (tfuncs, n) of
-- 
cgit v1.2.3