Mercurial > urweb
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 |
| 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