summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/compiler.sig4
-rw-r--r--src/compiler.sml15
-rw-r--r--src/especialize.sml28
-rw-r--r--src/main.mlton.sml5
-rw-r--r--src/rpcify.sml4
5 files changed, 36 insertions, 20 deletions
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