diff options
| -rw-r--r-- | src/compiler.sig | 4 | ||||
| -rw-r--r-- | src/compiler.sml | 15 | ||||
| -rw-r--r-- | src/especialize.sml | 28 | ||||
| -rw-r--r-- | src/main.mlton.sml | 5 | ||||
| -rw-r--r-- | src/rpcify.sml | 4 |
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 |