changeset 1677:3cfc79f92db7

-dumpSource flag; Especialize tweak: may specialize any argument sequence ending in a value of function-containing type
author Adam Chlipala <adam@chlipala.net>
date Thu, 12 Jan 2012 20:37:39 -0500 (2012-01-13)
parents 266814b15dd6
children d05299e561c8
files src/compiler.sig src/compiler.sml src/especialize.sml src/main.mlton.sml src/rpcify.sml
diffstat 5 files changed, 36 insertions(+), 20 deletions(-) [+]
line wrap: on
line diff
--- a/src/compiler.sig	Wed Jan 11 14:52:31 2012 -0500
+++ b/src/compiler.sig	Thu Jan 12 20:37:39 2012 -0500
@@ -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 @@
     val toSqlify : (string, Cjr.file) transform
 
     val debug : bool ref
+    val dumpSource : bool ref
+
     val doIflow : bool ref
 
     val addPath : string * string -> unit
--- a/src/compiler.sml	Wed Jan 11 14:52:31 2012 -0500
+++ b/src/compiler.sml	Thu Jan 12 20:37:39 2012 -0500
@@ -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 @@
 }
 
 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 @@
                   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
--- a/src/especialize.sml	Wed Jan 11 14:52:31 2012 -0500
+++ b/src/especialize.sml	Thu Jan 12 20:37:39 2012 -0500
@@ -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 @@
             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 @@
 
                             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)
 
--- a/src/main.mlton.sml	Wed Jan 11 14:52:31 2012 -0500
+++ b/src/main.mlton.sml	Thu Jan 12 20:37:39 2012 -0500
@@ -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 @@
       | "-dumpTypes" :: rest =>
         (Elaborate.dumpTypes := true;
          doArgs rest)
+      | "-dumpSource" :: rest =>
+        (Compiler.dumpSource := true;
+         doArgs rest)
       | "-output" :: s :: rest =>
         (Settings.setExe (SOME s);
          doArgs rest)
--- a/src/rpcify.sml	Wed Jan 11 14:52:31 2012 -0500
+++ b/src/rpcify.sml	Thu Jan 12 20:37:39 2012 -0500
@@ -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 @@
                     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