[MLton-devel] cvs commit: C codegen now puts chunks in separate files
Stephen Weeks
MLton@mlton.org
Tue, 01 Apr 2003 18:55:58 -0800
sweeks 03/04/01 18:55:57
Modified: include ccodegen.h codegen.h
mlton/atoms sources.cm
mlton/backend backend.fun chunkify.fun equivalence-graph.fun
equivalence-graph.sig machine.fun machine.sig
mlton/codegen/c-codegen c-codegen.fun
mlton/main main.sml
Log:
Changed the C codegen so that each chunk appears in a separate C file
instead of putting them all in one file. This should make compiling
large programs with the C codegen a lot faster. This is done with the
intent of cross-compiling MLton to the Sparc using the C codegen.
This change required some modifications to the command-line processor
in main, so that it can handle the multiple C files that are generated
by the codegen.
I also improved the chunkifier so that it merges unrelated chunks
while obeying the size constraint, so that the number of chunks is
kept small. For example, a self compile requires 151 chunks.
Here are the timings of four self compiles, for each of the
possibilities of a native-compiled (N) or C-compiled (C) mlton
compilng itself natively (N) or using the C codegen (C).
total pre-codegen Compile C and Assemble
---------------- -------------- ----------------------
CC 1275.91 + 61.06 198.81 + 48.84 1032.12 + 0.24
CN 392.65 + 126.18 193.92 + 48.83 19.14 + 0.53
NN 265.53 + 54.68 138.94 + 34.74 19.24 + 0.50
NC 1224.23 + 40.60 143.38 + 36.32 1033.07 + 0.14
Here are the (text + data) sizes for the two compilers
native 7,637,478 + 843,840
C 8,472,030 + 1,150,280
So, while using the C codegen is a lot slower than using the native
codegen, it is still a viable option.
Revision Changes Path
1.53 +63 -67 mlton/include/ccodegen.h
Index: ccodegen.h
===================================================================
RCS file: /cvsroot/mlton/mlton/include/ccodegen.h,v
retrieving revision 1.52
retrieving revision 1.53
diff -u -r1.52 -r1.53
--- ccodegen.h 31 Mar 2003 21:06:15 -0000 1.52
+++ ccodegen.h 2 Apr 2003 02:55:55 -0000 1.53
@@ -3,26 +3,19 @@
#include "codegen.h"
-/* Globals */
-static pointer arrayAllocateRes;
-static int nextFun;
-static int sizeRes;
-static pointer stackRes;
-
-/* The CReturn's must be globals and cannot be per chunk because
- * they may be assigned in one chunk and read in another. See, e.g.
- * Array_allocate.
- */
-static char CReturnC;
-static double CReturnD;
-static int CReturnI;
-static char *CReturnP;
-static uint CReturnU;
-
#ifndef DEBUG_CCODEGEN
#define DEBUG_CCODEGEN FALSE
#endif
+extern char CReturnC;
+extern double CReturnD;
+extern int CReturnI;
+extern char *CReturnP;
+extern uint CReturnU;
+extern struct cont (*nextChunks []) ();
+extern int nextFun;
+extern bool returnToC;
+
#define IsInt(p) (0x3 & (int)(p))
#define BZ(x, l) \
@@ -54,7 +47,7 @@
};
#define DeclareChunk(n) \
- static struct cont ChunkName(n)(void)
+ struct cont ChunkName(n)(void)
#define Chunk(n) \
DeclareChunk(n) { \
@@ -90,8 +83,6 @@
/* Calling SML from C */
/* ------------------------------------------------- */
-static bool returnToC;
-
#define Thread_returnToC() \
do { \
if (DEBUG_CCODEGEN) \
@@ -101,58 +92,63 @@
return cont; \
} while (0)
-static struct cont (*nextChunks[])();
-
-void MLton_callFromC () {
- struct cont cont;
- GC_state s;
-
- if (DEBUG_CCODEGEN)
- fprintf (stderr, "MLton_callFromC() starting\n");
- s = &gcState;
- s->savedThread = s->currentThread;
- /* Return to the C Handler thread. */
- GC_switchToThread (s, s->callFromCHandler);
- nextFun = *(int*)(s->stackTop - WORD_SIZE);
- cont.nextChunk = nextChunks[nextFun];
- returnToC = FALSE;
- do {
- cont=(*(struct cont(*)(void))cont.nextChunk)();
- } while (not returnToC);
- GC_switchToThread (s, s->savedThread);
- s->savedThread = BOGUS_THREAD;
- if (DEBUG_CCODEGEN)
- fprintf (stderr, "MLton_callFromC done\n");
-}
-
/* ------------------------------------------------- */
/* main */
/* ------------------------------------------------- */
-#define Main(cs, mg, mfs, mlw, mmc, ps, mc, ml) \
-int main (int argc, char **argv) { \
- struct cont cont; \
- gcState.native = FALSE; \
- Initialize(cs, mg, mfs, mlw, mmc, ps); \
- if (gcState.isOriginal) { \
- real_Init(); \
- PrepFarJump(mc, ml); \
- } else { \
- /* Return to the saved world */ \
- nextFun = *(int*)(gcState.stackTop - WORD_SIZE); \
- cont.nextChunk = nextChunks[nextFun]; \
- } \
- /* Trampoline */ \
- while (1) { \
- cont=(*(struct cont(*)(void))cont.nextChunk)(); \
- cont=(*(struct cont(*)(void))cont.nextChunk)(); \
- cont=(*(struct cont(*)(void))cont.nextChunk)(); \
- cont=(*(struct cont(*)(void))cont.nextChunk)(); \
- cont=(*(struct cont(*)(void))cont.nextChunk)(); \
- cont=(*(struct cont(*)(void))cont.nextChunk)(); \
- cont=(*(struct cont(*)(void))cont.nextChunk)(); \
- cont=(*(struct cont(*)(void))cont.nextChunk)(); \
- } \
+#define Main(cs, mg, mfs, mlw, mmc, ps, mc, ml) \
+/* Globals */ \
+char CReturnC; /* The CReturn's must be globals and cannot be per chunk */ \
+double CReturnD; /* because they may be assigned in one chunk and read in */ \
+int CReturnI; /* another. See, e.g. Array_allocate. */ \
+char *CReturnP; \
+uint CReturnU; \
+int nextFun; \
+bool returnToC; \
+void MLton_callFromC () { \
+ struct cont cont; \
+ GC_state s; \
+ \
+ if (DEBUG_CCODEGEN) \
+ fprintf (stderr, "MLton_callFromC() starting\n"); \
+ s = &gcState; \
+ s->savedThread = s->currentThread; \
+ /* Return to the C Handler thread. */ \
+ GC_switchToThread (s, s->callFromCHandler); \
+ nextFun = *(int*)(s->stackTop - WORD_SIZE); \
+ cont.nextChunk = nextChunks[nextFun]; \
+ returnToC = FALSE; \
+ do { \
+ cont=(*(struct cont(*)(void))cont.nextChunk)(); \
+ } while (not returnToC); \
+ GC_switchToThread (s, s->savedThread); \
+ s->savedThread = BOGUS_THREAD; \
+ if (DEBUG_CCODEGEN) \
+ fprintf (stderr, "MLton_callFromC done\n"); \
+} \
+int main (int argc, char **argv) { \
+ struct cont cont; \
+ gcState.native = FALSE; \
+ Initialize(cs, mg, mfs, mlw, mmc, ps); \
+ if (gcState.isOriginal) { \
+ real_Init(); \
+ PrepFarJump(mc, ml); \
+ } else { \
+ /* Return to the saved world */ \
+ nextFun = *(int*)(gcState.stackTop - WORD_SIZE); \
+ cont.nextChunk = nextChunks[nextFun]; \
+ } \
+ /* Trampoline */ \
+ while (1) { \
+ cont=(*(struct cont(*)(void))cont.nextChunk)(); \
+ cont=(*(struct cont(*)(void))cont.nextChunk)(); \
+ cont=(*(struct cont(*)(void))cont.nextChunk)(); \
+ cont=(*(struct cont(*)(void))cont.nextChunk)(); \
+ cont=(*(struct cont(*)(void))cont.nextChunk)(); \
+ cont=(*(struct cont(*)(void))cont.nextChunk)(); \
+ cont=(*(struct cont(*)(void))cont.nextChunk)(); \
+ cont=(*(struct cont(*)(void))cont.nextChunk)(); \
+ } \
}
/* ------------------------------------------------- */
1.9 +32 -22 mlton/include/codegen.h
Index: codegen.h
===================================================================
RCS file: /cvsroot/mlton/mlton/include/codegen.h,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- codegen.h 31 Mar 2003 21:06:17 -0000 1.8
+++ codegen.h 2 Apr 2003 02:55:55 -0000 1.9
@@ -1,6 +1,14 @@
#ifndef _CODEGEN_H_
#define _CODEGEN_H_
+extern struct GC_state gcState;
+extern char globaluchar[];
+extern double globaldouble[];
+extern int globalint[];
+extern pointer globalpointer[];
+extern uint globaluint[];
+extern pointer globalpointerNonRoot[];
+
/* The label must be declared as weak because gcc's optimizer may prove that
* the code that declares the label is dead and hence eliminate declaration.
*/
@@ -19,29 +27,31 @@
#define Real(c, f) globaldouble[c] = f;
#define EndReals }
-/* gcState can't be static because stuff in mlton-lib.c refers to it */
-struct GC_state gcState;
+#define LoadArray(a, f) sfread (a, sizeof(*a), cardof(a), f)
+#define SaveArray(a, fd) swrite (fd, a, sizeof(*a) * cardof(a))
-#define Globals(c, d, i, p, u, nr) \
- char globaluchar[c]; \
- double globaldouble[d]; \
- int globalint[i]; \
- pointer globalpointer[p]; \
- uint globaluint[u]; \
- pointer globalpointerNonRoot[nr]; \
- void saveGlobals (int fd) { \
- swrite (fd, globaluchar, sizeof(char) * c); \
- swrite (fd, globaldouble, sizeof(double) * d); \
- swrite (fd, globalint, sizeof(int) * i); \
- swrite (fd, globalpointer, sizeof(pointer) * p); \
- swrite (fd, globaluint, sizeof(uint) * u); \
- } \
- static void loadGlobals (FILE *file) { \
- sfread (globaluchar, sizeof(char), c, file); \
- sfread (globaldouble, sizeof(double), d, file); \
- sfread (globalint, sizeof(int), i, file); \
- sfread (globalpointer, sizeof(pointer), p, file); \
- sfread (globaluint, sizeof(uint), u, file); \
+/* gcState can't be static because stuff in mlton-lib.c refers to it */ \
+#define Globals(c, d, i, p, u, nr) \
+ struct GC_state gcState; \
+ char globaluchar[c]; \
+ double globaldouble[d]; \
+ int globalint[i]; \
+ pointer globalpointer[p]; \
+ uint globaluint[u]; \
+ pointer globalpointerNonRoot[nr]; \
+ static void saveGlobals (int fd) { \
+ SaveArray (globaluchar, fd); \
+ SaveArray (globaldouble, fd); \
+ SaveArray (globalint, fd); \
+ SaveArray (globalpointer, fd); \
+ SaveArray (globaluint, fd); \
+ } \
+ static void loadGlobals (FILE *file) { \
+ LoadArray (globaluchar, file); \
+ LoadArray (globaldouble, file); \
+ LoadArray (globalint, file); \
+ LoadArray (globalpointer, file); \
+ LoadArray (globaluint, file); \
}
#define Initialize(cs, mg, mfs, mlw, mmc, ps) \
1.10 +1 -0 mlton/mlton/atoms/sources.cm
Index: sources.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/sources.cm,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- sources.cm 20 Jan 2003 20:38:28 -0000 1.9
+++ sources.cm 2 Apr 2003 02:55:55 -0000 1.10
@@ -10,6 +10,7 @@
signature AST
signature ATOMS
signature ID
+signature ID_NO_AST
signature CASES
signature CON
signature CONST
1.49 +1 -1 mlton/mlton/backend/backend.fun
Index: backend.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/backend.fun,v
retrieving revision 1.48
retrieving revision 1.49
diff -u -r1.48 -r1.49
--- backend.fun 23 Jan 2003 03:34:36 -0000 1.48
+++ backend.fun 2 Apr 2003 02:55:55 -0000 1.49
@@ -105,7 +105,7 @@
fun new (): t =
T {blocks = ref [],
- chunkLabel = M.ChunkLabel.new ()}
+ chunkLabel = M.ChunkLabel.newNoname ()}
fun newBlock (T {blocks, ...}, z) =
List.push (blocks, M.Block.T z)
1.15 +14 -11 mlton/mlton/backend/chunkify.fun
Index: chunkify.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/chunkify.fun,v
retrieving revision 1.14
retrieving revision 1.15
diff -u -r1.14 -r1.15
--- chunkify.fun 20 Dec 2002 17:33:08 -0000 1.14
+++ chunkify.fun 2 Apr 2003 02:55:56 -0000 1.15
@@ -131,7 +131,8 @@
Property.getSetOnce (Label.plist,
Property.initRaise ("class", Label.layout))
(* Build the initial partition.
- * Ensure that all Ssa labels are in the same equivalence class.
+ * Ensure that all Ssa labels that jump to one another are in the same
+ * equivalence class.
*)
val _ =
List.foreach
@@ -141,7 +142,8 @@
val _ =
Vector.foreach
(blocks, fn b as Block.T {label, ...} =>
- setLabelClass (label, Graph.newClass (graph, blockSize b)))
+ setLabelClass (label,
+ Graph.newClass (graph, {size = blockSize b})))
val _ = setFuncClass (name, labelClass start)
val _ =
Vector.foreach
@@ -175,16 +177,15 @@
(blocks, fn Block.T {label, transfer, ...} =>
case transfer of
Call {func, ...} =>
- Graph.addEdge (graph, {from = labelClass label,
- to = funcClass func})
+ Graph.addEdge (graph, labelClass label,
+ funcClass func)
| Return _ =>
let
val from = labelClass label
in
List.foreach
(returnsTo, fn c =>
- Graph.addEdge (graph, {from = from,
- to = c}))
+ Graph.addEdge (graph, from, c))
end
| _ => ())
in
@@ -193,7 +194,7 @@
val _ =
if limit = 0
then ()
- else Graph.greedy {graph = graph, maxClassSize = limit}
+ else Graph.coarsen (graph, {maxClassSize = limit})
type chunk = {funcs: Func.t list ref,
labels: Label.t list ref}
val chunks: chunk list ref = ref []
@@ -201,10 +202,12 @@
Property.get
(Class.plist,
Property.initFun (fn _ =>
- let val c = {funcs = ref [],
- labels = ref []}
- in List.push (chunks, c)
- ; c
+ let
+ val c = {funcs = ref [],
+ labels = ref []}
+ val _ = List.push (chunks, c)
+ in
+ c
end))
val _ =
let
1.3 +79 -97 mlton/mlton/backend/equivalence-graph.fun
Index: equivalence-graph.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/equivalence-graph.fun,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- equivalence-graph.fun 10 Apr 2002 07:02:19 -0000 1.2
+++ equivalence-graph.fun 2 Apr 2003 02:55:56 -0000 1.3
@@ -5,7 +5,7 @@
* MLton is released under the GNU General Public License (GPL).
* Please see the file MLton-LICENSE for license information.
*)
-functor EquivalenceGraph(S: EQUIVALENCE_GRAPH_STRUCTS): EQUIVALENCE_GRAPH =
+functor EquivalenceGraph (S: EQUIVALENCE_GRAPH_STRUCTS): EQUIVALENCE_GRAPH =
struct
open S
@@ -13,118 +13,100 @@
structure Set = DisjointSet
structure Plist = PropertyList
-(* A simple implementation where greedy doesn't do anything *)
structure Class =
struct
- type t = Plist.t Set.t
- val plist = Set.value
- end
-type t = unit
-fun new() = ()
-fun newClass _ = Set.singleton(PropertyList.new())
-fun addEdge _ = ()
-fun ==(_, c, c') = Set.union(c, c')
-fun greedy _ = ()
-
-(* A slightly trickier implementation where greedy just walks over the edges
- * in order.
- *)
-structure Class =
- struct
- datatype t = T of {size: int ref,
- plist: Plist.t} Set.t
+ datatype t = T of {plist: Plist.t,
+ size: int ref} Set.t
local
- fun make sel (T s) = sel(Set.value s)
- in val plist = make #plist
+ fun make sel (T s) = sel (Set.value s)
+ in
+ val plist = make #plist
val size = make (! o #size)
end
- fun setSize(T s, n) = #size(Set.value s) := n
+ fun setSize (T s, n) = #size (Set.value s) := n
- fun new(size: int): t = T(Set.singleton{size = ref size,
- plist = Plist.new()})
+ fun new (size: int): t =
+ T (Set.singleton {plist = Plist.new (),
+ size = ref size})
- fun ==(c as T s, T s') =
- if Set.equals(s, s')
+ fun == (c as T s, T s') =
+ if Set.equals (s, s')
then ()
- else let val {size = ref n, plist} = Set.value s
- val {size = ref n', plist} = Set.value s'
- in Set.union(s, s')
- ; setSize(c, n + n')
- end
+ else
+ let
+ val {size = ref n, ...} = Set.value s
+ val {size = ref n', ...} = Set.value s'
+ in
+ Set.union (s, s')
+ ; setSize (c, n + n')
+ end
end
-datatype t = T of {edges: (Class.t * Class.t) list ref}
+datatype t = T of {classes: Class.t list ref,
+ edges: (Class.t * Class.t) list ref}
-fun new() = T{edges = ref []}
+fun new () = T {classes = ref [],
+ edges = ref []}
-fun newClass(_, n) = Class.new n
+fun newClass (T {classes, ...}, {size}) =
+ let
+ val c = Class.new size
+ val _ = List.push (classes, c)
+ in
+ c
+ end
-fun addEdge(T{edges, ...}, {from, to}) =
- List.push(edges, (from, to))
+fun addEdge (T {edges, ...}, c, c') =
+ List.push (edges, (c, c'))
-fun ==(_, c, c') = Class.==(c, c')
-
-fun greedy{graph = T{edges, ...}, maxClassSize} =
- List.foreach(!edges, fn (c, c') =>
- if Class.size c + Class.size c' <= maxClassSize
- then Class.==(c, c')
- else ())
-
-(*
- * Given an edge, return how desirable it is to merge the endpoints
- * of the edge. The result is an int option because we return
- * NONE if they are not mergable.
- * Note, it looks at the details inside Class, but the whole thing
- * is just a hack.
- *)
-fun goodness (Class.T lhs: Class.t, Class.T rhs: Class.t): int option =
- if Set.equals (lhs, rhs)
- then NONE
- else let val {size = ref lsize, ...} = Set.value lhs
- val {size = ref rsize, ...} = Set.value rhs
- in SOME (~ (lsize + rsize))
- end
-
-fun findBest (edges: (Class.t * Class.t) list)
- : (Class.t * Class.t) option =
- let fun folder (e: Class.t * Class.t,
- ac: (int * (Class.t * Class.t)) option) =
- case goodness e of
- NONE => ac
- | SOME g =>
- case ac of
- NONE => SOME (g, e)
- | SOME (g', _) =>
- if g > g'
- then SOME (g, e)
- else ac
- in case List.fold (edges, NONE, folder) of
- NONE => NONE
- | SOME (goodness, e) => (
-(* print ("\nHCC:\tgoodness " ^
- * Int.toString goodness ^
- * "\n");
- *)
- SOME e
- )
- end
-
-fun greedy' {graph = T {edges, ...}, maxClassSize} =
- let fun loop () =
- case findBest (! edges) of
- NONE => ()
- | SOME (lhs, rhs) =>
- if Class.size lhs + Class.size rhs <= maxClassSize
- then (
- Class.== (lhs, rhs);
- loop ()
- )
- else ()
- in loop ()
- end
+fun == (_, c, c') = Class.== (c, c')
+fun coarsen (T {classes, edges, ...}, {maxClassSize}) =
+ let
+ (* Combine classes with an edge between them where possible. *)
+ val _ =
+ List.foreach (!edges, fn (c, c') =>
+ if Class.size c + Class.size c' <= maxClassSize
+ then Class.== (c, c')
+ else ())
+ (* Get a list of all classes without duplicates. *)
+ val {get, ...} =
+ Property.get (Class.plist, Property.initFun (fn _ => ref false))
+ val classes =
+ List.fold
+ (!classes, [], fn (class, ac) =>
+ let
+ val r = get class
+ in
+ if !r
+ then ac
+ else (r := true
+ ; class :: ac)
+ end)
+ (* Sort classes in decreasing order of size. *)
+ val classes =
+ QuickSort.sortList (classes, fn (c, c') =>
+ Class.size c >= Class.size c')
+ (* Combine classes where possible. *)
+ fun loop (cs: Class.t list): unit =
+ case cs of
+ [] => ()
+ | c :: cs =>
+ loop
+ (rev
+ (List.fold
+ (cs, [], fn (c', ac) =>
+ if Class.size c + Class.size c' <= maxClassSize
+ then (Class.== (c, c')
+ ; ac)
+ else c' :: ac)))
+ val _ = loop classes
+ in
+ ()
+ end
+
end
-structure EquivalenceGraph = EquivalenceGraph()
+structure EquivalenceGraph = EquivalenceGraph ()
1.3 +24 -21 mlton/mlton/backend/equivalence-graph.sig
Index: equivalence-graph.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/equivalence-graph.sig,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- equivalence-graph.sig 10 Apr 2002 07:02:19 -0000 1.2
+++ equivalence-graph.sig 2 Apr 2003 02:55:56 -0000 1.3
@@ -11,6 +11,14 @@
sig
end
+(* An equivalence graph is an equivalence relation with a weight function on
+ * classes and an edge relation between classes.
+ *
+ * The main operation is coarsen, which takes an equivalence graph and coarsens
+ * the equivalence relation so that the class weights are as large as possible
+ * subject to a constraint.
+ *)
+
signature EQUIVALENCE_GRAPH =
sig
include EQUIVALENCE_GRAPH_STRUCTS
@@ -23,34 +31,29 @@
val plist: t -> PropertyList.t
end
- (* The type of directed graphs with equivalence relations on nodes. *)
+ (* The type of equivalence graphs. *)
type t
- (* Return a new graph. *)
- val new: unit -> t
-
- (* newNode(g, i) adds a new node to graph g, where the size of the node
- * is i. The new node is not equivalent to any other node. Return the
- * class of the node.
- *)
- val newClass: t * int -> Class.t
-
- (* Add a new edge between two classes.
- * Increment the weight of the edge if it's already there.
- *)
- val addEdge: t * {from: Class.t, to: Class.t} -> unit
-
(* Make two classes equivalent.
* The size of the resulting class is the sum of the sizes of the original
- * two classes. This is a noop if the classes are already equal.
+ * two classes. This is a no-op if the classes are already equivalent.
*)
val == : t * Class.t * Class.t -> unit
+ (* Add a new edge between two classes. *)
+ val addEdge: t * Class.t * Class.t -> unit
+
(* Make the equivalence relation as coarse as possible so that the
- * number of edges between classes in minimized, subject to the constraint
- * that the sum of the node sizes in an equivalence class is <= maxNodeSize.
- * Classes for which this constraint was violated by previous calls to ==
- * should not be made coarser.
+ * number of edges between classes is minimized, subject to the constraint
+ * that the sum of the node sizes in an equivalence class is
+ * <= maxClassSize. Classes for which this constraint was violated by
+ * previous calls to == should not be made coarser.
*)
- val greedy: {graph: t, maxClassSize: int} -> unit
+ val coarsen: t * {maxClassSize: int} -> unit
+
+ (* Return a new relation. *)
+ val new: unit -> t
+
+ (* newClass (g, {classSize}) adds a new class to the equivalence graph. *)
+ val newClass: t * {size: int} -> Class.t
end
1.43 +3 -3 mlton/mlton/backend/machine.fun
Index: machine.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/machine.fun,v
retrieving revision 1.42
retrieving revision 1.43
diff -u -r1.42 -r1.43
--- machine.fun 23 Jan 2003 03:34:36 -0000 1.42
+++ machine.fun 2 Apr 2003 02:55:56 -0000 1.43
@@ -25,7 +25,7 @@
structure SourceInfo = SourceInfo)
open Atoms
-structure ChunkLabel = IntUniqueId ()
+structure ChunkLabel = IdNoAst (val noname = "ChunkLabel")
structure SmallIntInf =
struct
@@ -605,8 +605,8 @@
structure Chunk =
struct
- datatype t = T of {chunkLabel: ChunkLabel.t,
- blocks: Block.t vector,
+ datatype t = T of {blocks: Block.t vector,
+ chunkLabel: ChunkLabel.t,
regMax: Runtime.Type.t -> int}
fun layout (T {blocks, ...}) =
1.33 +1 -1 mlton/mlton/backend/machine.sig
Index: machine.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/machine.sig,v
retrieving revision 1.32
retrieving revision 1.33
diff -u -r1.32 -r1.33
--- machine.sig 23 Jan 2003 03:34:36 -0000 1.32
+++ machine.sig 2 Apr 2003 02:55:56 -0000 1.33
@@ -25,7 +25,7 @@
sharing Type = Switch.Type
structure CFunction: C_FUNCTION
sharing CFunction = Runtime.CFunction
- structure ChunkLabel: UNIQUE_ID
+ structure ChunkLabel: ID_NO_AST
structure Register:
sig
1.48 +93 -59 mlton/mlton/codegen/c-codegen/c-codegen.fun
Index: c-codegen.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/c-codegen/c-codegen.fun,v
retrieving revision 1.47
retrieving revision 1.48
diff -u -r1.47 -r1.48
--- c-codegen.fun 25 Mar 2003 04:31:24 -0000 1.47
+++ c-codegen.fun 2 Apr 2003 02:55:56 -0000 1.48
@@ -116,17 +116,9 @@
print (concat [dst, " = ", src, ";\n"])
end
-structure Label =
- struct
- open Label
-
- fun toStringIndex l = (toString l) ^ "_index"
- end
-
structure Operand =
struct
open Operand
-
val layout = Layout.str o toString
end
@@ -134,6 +126,12 @@
fun creturn (t: Runtime.Type.t): string =
concat ["CReturn", Runtime.Type.name t]
+fun outputIncludes (includes, print) =
+ (List.foreach (includes, fn i => (print "#include <";
+ print i;
+ print ">\n"))
+ ; print "\n")
+
fun outputDeclarations
{additionalMainArgs: string list,
includes: string list,
@@ -147,11 +145,6 @@
rest: unit -> unit
}: unit =
let
- fun outputIncludes () =
- (List.foreach (includes, fn i => (print "#include <";
- print i;
- print ">\n"))
- ; print "\n")
fun declareGlobals () =
C.call ("Globals",
List.map (List.map (let open Runtime.Type
@@ -280,7 +273,7 @@
end
in
print (concat ["#define ", name, "CODEGEN\n\n"])
- ; outputIncludes ()
+ ; outputIncludes (includes, print)
; declareGlobals ()
; declareIntInfs ()
; declareStrings ()
@@ -349,30 +342,31 @@
in
Kind.frameInfoOpt kind
end
- val {print, done, ...} = outputC ()
- fun declareChunks () =
- List.foreach (chunks, fn Chunk.T {chunkLabel, ...} =>
- C.call ("DeclareChunk",
- [ChunkLabel.toString chunkLabel],
- print))
- fun declareNextChunks () =
- (print "static struct cont ( *nextChunks []) () = {"
- ; Vector.foreach (entryLabels, fn l =>
- let
- val {chunkLabel, ...} = labelInfo l
- in
- print "\t"
- ; C.callNoSemi ("Chunkp",
- [ChunkLabel.toString chunkLabel],
- print)
- ; print ",\n"
- end)
- ; print "};\n")
- fun declareIndices () =
- Vector.foreachi
- (entryLabels, fn (i, l) =>
- (print (concat ["#define ", Label.toStringIndex l, " ",
- C.int i, "\n"])))
+ val {get = chunkLabelIndex: ChunkLabel.t -> int, ...} =
+ Property.getSet (ChunkLabel.plist,
+ Property.initFun (let
+ val c = Counter.new 0
+ in
+ fn _ => Counter.next c
+ end))
+ val chunkLabelToString = C.int o chunkLabelIndex
+ fun declareChunk (Chunk.T {chunkLabel, ...}, print) =
+ C.call ("DeclareChunk",
+ [chunkLabelToString chunkLabel],
+ print)
+ val {get = labelIndex, set = setLabelIndex, ...} =
+ Property.getSetOnce (Label.plist,
+ Property.initRaise ("index", Label.layout))
+ val _ =
+ Vector.foreachi (entryLabels, fn (i, l) => setLabelIndex (l, i))
+ fun labelToStringIndex (l: Label.t): string =
+ let
+ val s = C.int (labelIndex l)
+ in
+ if 0 = !Control.Native.commented
+ then s
+ else concat [s, " /* ", Label.toString l, " */"]
+ end
local
datatype z = datatype Operand.t
fun toString (z: Operand.t): string =
@@ -395,7 +389,7 @@
else "NR",
"(", Int.toString (Global.index g), ")"]
| Int n => C.int n
- | Label l => Label.toStringIndex l
+ | Label l => labelToStringIndex l
| Line => "__LINE__"
| Offset {base, offset, ty} =>
concat ["O", Type.name ty,
@@ -431,7 +425,7 @@
val operandToString = toString
end
- fun outputStatement s =
+ fun outputStatement (s, print) =
let
datatype z = datatype Statement.t
in
@@ -495,6 +489,28 @@
val profiling = !Control.profile <> Control.ProfileNone
fun outputChunk (chunk as Chunk.T {chunkLabel, blocks, regMax, ...}) =
let
+ val {done, print, ...} = outputC ()
+ fun declareChunks () =
+ let
+ val {get, ...} =
+ Property.get (ChunkLabel.plist,
+ Property.initFun (fn _ => ref false))
+ val _ =
+ Vector.foreach
+ (blocks, fn Block.T {transfer, ...} =>
+ case transfer of
+ Transfer.Call {label, ...} =>
+ get (labelChunk label) := true
+ | _ => ())
+ val _ =
+ List.foreach
+ (chunks, fn c as Chunk.T {chunkLabel, ...} =>
+ if ! (get chunkLabel)
+ then declareChunk (c, print)
+ else ())
+ in
+ ()
+ end
fun labelFrameSize (l: Label.t): int =
Program.frameSize (program, valOf (labelFrameInfo l))
(* Count how many times each label is jumped to. *)
@@ -655,7 +671,8 @@
Vector.layout Operand.layout live,
str " */\n"])
end)
- val _ = Vector.foreach (statements, outputStatement)
+ val _ = Vector.foreach (statements, fn s =>
+ outputStatement (s, print))
val _ = outputTransfer (transfer, l)
in ()
end) arg
@@ -782,8 +799,8 @@
then gotoLabel label
else
C.call ("\tFarJump",
- [ChunkLabel.toString dstChunk,
- Label.toStringIndex label],
+ [chunkLabelToString dstChunk,
+ labelToStringIndex label],
print)
end
| Goto dst => gotoLabel dst
@@ -874,37 +891,54 @@
C.call (d, [C.int i], print))
end)
in
- C.callNoSemi ("Chunk", [ChunkLabel.toString chunkLabel], print)
+ print (concat ["#define CCODEGEN\n\n"])
+ ; outputIncludes (includes, print)
+ ; declareChunks ()
+ ; C.callNoSemi ("Chunk", [chunkLabelToString chunkLabel], print)
; print "\n"
; declareRegisters ()
- ; C.callNoSemi ("ChunkSwitch", [ChunkLabel.toString chunkLabel],
+ ; C.callNoSemi ("ChunkSwitch", [chunkLabelToString chunkLabel],
print)
; print "\n"
; Vector.foreach (blocks, fn Block.T {kind, label, ...} =>
if Kind.isEntry kind
then (print "case "
- ; print (Label.toStringIndex label)
+ ; print (labelToStringIndex label)
; print ":\n"
; gotoLabel label)
else ())
; print "EndChunk\n"
+ ; done ()
end
val additionalMainArgs =
- [ChunkLabel.toString chunkLabel,
- Label.toStringIndex label]
+ [chunkLabelToString chunkLabel,
+ labelToStringIndex label]
+ val {print, done, ...} = outputC ()
fun rest () =
- (declareChunks ()
- ; declareNextChunks ()
- ; declareIndices ()
- ; List.foreach (chunks, outputChunk))
+ (List.foreach (chunks, fn c => declareChunk (c, print))
+ ; print "struct cont ( *nextChunks []) () = {"
+ ; Vector.foreach (entryLabels, fn l =>
+ let
+ val {chunkLabel, ...} = labelInfo l
+ in
+ print "\t"
+ ; C.callNoSemi ("Chunkp",
+ [chunkLabelToString chunkLabel],
+ print)
+ ; print ",\n"
+ end)
+ ; print "};\n")
+ val _ =
+ outputDeclarations {additionalMainArgs = additionalMainArgs,
+ includes = includes,
+ name = "C",
+ program = program,
+ print = print,
+ rest = rest}
+ val _ = done ()
+ val _ = List.foreach (chunks, outputChunk)
in
- outputDeclarations {additionalMainArgs = additionalMainArgs,
- includes = includes,
- name = "C",
- program = program,
- print = print,
- rest = rest}
- ; done ()
+ ()
end
end
1.127 +221 -246 mlton/mlton/main/main.sml
Index: main.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/main/main.sml,v
retrieving revision 1.126
retrieving revision 1.127
diff -u -r1.126 -r1.127
--- main.sml 25 Feb 2003 22:30:49 -0000 1.126
+++ main.sml 2 Apr 2003 02:55:57 -0000 1.127
@@ -342,7 +342,7 @@
end
val mainUsage =
- "mlton [option ...] file.{cm|sml|c|o} [file.{S|o} ...] [library ...]"
+ "mlton [option ...] file.{cm|sml|c|o} [file.{c|S|o} ...] [library ...]"
val {parse, usage} =
Popt.makeUsage {mainUsage = mainUsage,
@@ -411,7 +411,7 @@
; outputHeader' (No, Out.standard)))
| Result.Yes (input :: rest) =>
let
- val _ = inputFile := (File.base o File.fileOf) input
+ val _ = inputFile := File.base (File.fileOf input)
val (start, base) =
let
val rec loop =
@@ -423,261 +423,233 @@
String.size suf))
else loop sufs
datatype z = datatype Place.t
- in loop [(".cm", CM),
+ in
+ loop [(".cm", CM),
(".sml", SML),
(".c", Generated),
(".o", O)]
end
- val (sfiles, rest) =
- case start of
- Place.Generated =>
- List.splitPrefix (rest, fn s =>
- String.isSuffix {string = s,
- suffix = ".S"})
- | _ => ([], rest)
+ val (csoFiles, rest) =
+ List.splitPrefix (rest, fn s =>
+ List.exists
+ ([".c", ".o", ".s", ".S"], fn suffix =>
+ String.isSuffix {string = s,
+ suffix = suffix}))
val stop = !stop
- in case Place.compare (start, stop) of
- GREATER => usage (concat ["cannot go from ", Place.toString start,
- " to ", Place.toString stop])
- | EQUAL => usage "nothing to do"
- | LESS =>
- let
- val _ =
- if !verbosity = Top
- then printVersion ()
- else ()
- val tempFiles: File.t list ref = ref []
- val tmpDir =
- case Process.getEnv "TMPDIR" of
- NONE => "/tmp"
- | SOME d => d
- fun temp (suf: string): File.t =
- let
- val (f, out) =
- File.temp {prefix = concat [tmpDir, "/file"],
- suffix = suf}
- val _ = Out.close out
- val _ = List.push (tempFiles, f)
- in
- f
- end
- fun suffix s = concat [base, s]
- fun file (b, suf) = (if b then suffix else temp) suf
- fun maybeOut suf =
- case !output of
- NONE => suffix suf
- | SOME f => f
- fun list (prefix: string, l: string list): string list =
- List.map (l, fn s => prefix ^ s)
- fun docc (inputs: File.t list,
- output: File.t,
- switches: string list,
- linkLibs: string list) =
- System.system
- (gcc, List.concat [switches,
- ["-o", output],
- inputs,
- linkLibs])
- val definesAndIncludes =
- List.concat [list ("-D", !defines),
- list ("-I", rev (includeDirs))]
- (* This mess is necessary because the linker on linux
- * adds a dependency to a shared library even if there are
- * no references to it. So, on linux, we explicitly link
- * with libgmp.a instead of using -lgmp.
- *)
- val linkWithGmp =
- case !hostType of
- Cygwin => ["-lgmp"]
- | FreeBSD => ["-L/usr/local/lib/", "-lgmp"]
- | Linux =>
- let
- val conf = "/etc/ld.so.conf"
- val dirs =
- if File.canRead conf
- then File.lines conf
- else []
- val dirs = "/lib\n" :: "/usr/lib\n" :: dirs
- in
- case (List.peekMap
- (dirs, fn d =>
- let
- val lib =
- concat [String.dropSuffix (d, 1),
- "/libgmp.a"]
- in
- if File.canRead lib
- then SOME lib
- else NONE
- end)) of
- NONE => ["-lgmp"]
- | SOME lib => [lib]
- end
- val linkLibs: string list =
- List.concat [list ("-L", rev (libDirs)),
- list ("-l",
- (if !debug
- then "mlton-gdb"
- else "mlton")
- :: !libs),
- linkWithGmp]
- datatype debugFormat =
- Dwarf | DwarfPlus | Dwarf2 | Stabs | StabsPlus
- val debugFormat = StabsPlus
- val (gccDebug, asDebug) =
- case debugFormat of
- Dwarf => (["-gdwarf", "-g2"], "-Wa,--gdwarf2")
- | DwarfPlus => (["-gdwarf+", "-g2"], "-Wa,--gdwarf2")
- | Dwarf2 => (["-gdwarf-2", "-g2"], "-Wa,--gdwarf2")
- | Stabs => (["-gstabs", "-g2"], "-Wa,--gstabs")
- | StabsPlus => (["-gstabs+", "-g2"], "-Wa,--gstabs")
- fun compileO (inputs: File.t list) =
- let
- val output = maybeOut ""
- val _ =
- trace (Top, "Link")
- (fn () =>
- docc (inputs, output,
- List.concat
- [case host of
- Cross s => ["-b", s]
- | Self => [],
- if !debug then gccDebug else [],
- if !static then ["-static"] else []],
- rest @ linkLibs))
+ in
+ case Place.compare (start, stop) of
+ GREATER => usage (concat ["cannot go from ", Place.toString start,
+ " to ", Place.toString stop])
+ | EQUAL => usage "nothing to do"
+ | LESS =>
+ let
+ val _ =
+ if !verbosity = Top
+ then printVersion ()
+ else ()
+ val tempFiles: File.t list ref = ref []
+ val tmpDir =
+ case Process.getEnv "TMPDIR" of
+ NONE => "/tmp"
+ | SOME d => d
+ fun temp (suf: string): File.t =
+ let
+ val (f, out) =
+ File.temp {prefix = concat [tmpDir, "/file"],
+ suffix = suf}
+ val _ = Out.close out
+ val _ = List.push (tempFiles, f)
+ in
+ f
+ end
+ fun suffix s = concat [base, s]
+ fun file (b, suf) = (if b then suffix else temp) suf
+ fun maybeOut suf =
+ case !output of
+ NONE => suffix suf
+ | SOME f => f
+ fun list (prefix: string, l: string list): string list =
+ List.map (l, fn s => prefix ^ s)
+ fun docc (inputs: File.t list,
+ output: File.t,
+ switches: string list,
+ linkLibs: string list): unit =
+ System.system
+ (gcc, List.concat [switches,
+ ["-o", output],
+ inputs,
+ linkLibs])
+ val definesAndIncludes =
+ List.concat [list ("-D", !defines),
+ list ("-I", rev (includeDirs))]
+ (* This mess is necessary because the linker on linux
+ * adds a dependency to a shared library even if there are
+ * no references to it. So, on linux, we explicitly link
+ * with libgmp.a instead of using -lgmp.
+ *)
+ val linkWithGmp =
+ case !hostType of
+ Cygwin => ["-lgmp"]
+ | FreeBSD => ["-L/usr/local/lib/", "-lgmp"]
+ | Linux =>
+ let
+ val conf = "/etc/ld.so.conf"
+ val dirs =
+ if File.canRead conf
+ then File.lines conf
+ else []
+ val dirs = "/lib\n" :: "/usr/lib\n" :: dirs
+ in
+ case (List.peekMap
+ (dirs, fn d =>
+ let
+ val lib =
+ concat [String.dropSuffix (d, 1),
+ "/libgmp.a"]
+ in
+ if File.canRead lib
+ then SOME lib
+ else NONE
+ end)) of
+ NONE => ["-lgmp"]
+ | SOME lib => [lib]
+ end
+ val linkLibs: string list =
+ List.concat [list ("-L", rev (libDirs)),
+ list ("-l",
+ (if !debug
+ then "mlton-gdb"
+ else "mlton")
+ :: !libs),
+ linkWithGmp]
+ datatype debugFormat =
+ Dwarf | DwarfPlus | Dwarf2 | Stabs | StabsPlus
+ (* The -Wa,--gstabs says to pass the --gstabs option to the
+ * assembler. This tells the assembler to generate stabs
+ * debugging information for each assembler line.
+ *)
+ val debugFormat = StabsPlus
+ val (gccDebug, asDebug) =
+ case debugFormat of
+ Dwarf => (["-gdwarf", "-g2"], "-Wa,--gdwarf2")
+ | DwarfPlus => (["-gdwarf+", "-g2"], "-Wa,--gdwarf2")
+ | Dwarf2 => (["-gdwarf-2", "-g2"], "-Wa,--gdwarf2")
+ | Stabs => (["-gstabs", "-g2"], "-Wa,--gstabs")
+ | StabsPlus => (["-gstabs+", "-g2"], "-Wa,--gstabs")
+ fun compileO (inputs: File.t list): unit =
+ let
+ val output = maybeOut ""
+ val _ =
+ trace (Top, "Link")
+ (fn () =>
+ docc (inputs, output,
+ List.concat
+ [case host of
+ Cross s => ["-b", s]
+ | Self => [],
+ if !debug then gccDebug else [],
+ if !static then ["-static"] else []],
+ rest @ linkLibs))
+ ()
+ (* gcc on Cygwin appends .exe, which I don't want, so
+ * move the output file to it's rightful place.
+ *)
+ val _ =
+ case MLton.hostType of
+ MLton.Cygwin =>
+ if String.contains (output, #".")
+ then ()
+ else
+ File.move {from = concat [output, ".exe"],
+ to = output}
+ | MLton.FreeBSD => ()
+ | MLton.Linux => ()
+ in
()
- (* gcc on Cygwin appends .exe, which I don't want, so
- * move the output file to it's rightful place.
- *)
- val _ =
- case MLton.hostType of
- MLton.Cygwin =>
- if String.contains (output, #".")
- then ()
- else
- File.move {from = concat [output, ".exe"],
- to = output}
- | MLton.FreeBSD => ()
- | MLton.Linux => ()
- in
- ()
- end
- fun compileS (main: File.t, inputs: File.t list) =
+ end
+ fun compileCSO (inputs: File.t list): unit =
let
- val switches = ["-c"]
val r = ref 0
- fun doit (input: File.t, isMain: bool): File.t =
- let
- val switches =
- if !debug
- then
- (* The -Wa,--gstabs says to pass the
- * --gstabs option to the assembler.
- * This tells the assembler to generate
- * stabs debugging information for each
- * assembler line.
- *)
- (if isMain
- then gccDebug
- else [asDebug]) @ switches
- else switches
- val switches =
- case host of
- Cross s => "-b" :: s :: switches
- | Self => switches
- val output =
- if stop = Place.O orelse !keepO
- then
- if isMain
- then suffix ".o"
- else
- if !keepGenerated
- then
- concat
- [String.dropSuffix (input, 1),
- "o"]
- else
- suffix
- (Int.inc r
- ; concat [".", Int.toString (!r),
- ".o"])
- else temp ".o"
- in docc ([input], output, switches, [])
- ; output
- end
- val outputs =
- trace (Top, "Assemble")
+ val oFiles =
+ trace (Top, "Compile C and Assemble")
(fn () =>
- doit (main, true)
- :: List.revMap (inputs, fn i => doit (i, false)))
+ List.fold
+ (inputs, [], fn (input, ac) =>
+ if String.isSuffix {string = input,
+ suffix = ".o"}
+ then input :: ac
+ else
+ let
+ val (debugSwitches, switches) =
+ if String.isSuffix {string = input,
+ suffix = ".c"}
+ then
+ (gccDebug,
+ List.concat
+ [definesAndIncludes,
+ [concat
+ ["-O",
+ Int.toString (!optimization)]],
+ if !Native.native
+ then []
+ else String.tokens (!gccSwitches,
+ Char.isSpace)])
+ else ([asDebug], [])
+ val switches =
+ if !debug
+ then debugSwitches @ switches
+ else switches
+ val switches =
+ case host of
+ Cross s => "-b" :: s :: switches
+ | Self => switches
+ val switches = "-c" :: switches
+ val output =
+ if stop = Place.O orelse !keepO
+ then
+ if !keepGenerated
+ then
+ concat
+ [String.dropSuffix (input, 1),
+ "o"]
+ else
+ (Int.inc r
+ ; (suffix
+ (concat [".", Int.toString (!r),
+ ".o"])))
+ else temp ".o"
+ val _ = docc ([input], output, switches, [])
+ in
+ output :: ac
+ end))
()
- in case stop of
- Place.O => ()
- | _ => compileO outputs
- end
- fun compileC (cFile: File.t,
- sFiles: File.t list) =
- let
- val switches =
- List.concat
- [["-S"],
- if !debug then gccDebug else [],
- definesAndIncludes,
- [concat ["-O", Int.toString (!optimization)]],
- if !Native.native
- then []
- else String.tokens (!gccSwitches, Char.isSpace)]
- val switches =
- case host of
- Cross s => "-b" :: s :: switches
- | Self => switches
- val output = temp ".s"
- val _ =
- trace (Top, "Compile C")
- (fn () => docc ([cFile], output, switches, []))
- ()
- in compileS (output, sFiles)
+ in
+ case stop of
+ Place.O => ()
+ | _ => compileO oFiles
end
fun compileSml (files: File.t list) =
let
val docc =
fn {input, output} =>
docc ([input], output, definesAndIncludes, linkLibs)
- val cFile = ref NONE
- val sFiles = ref []
- fun cOut () =
- let
- val suf = ".c"
- val file =
- case stop of
- Place.Generated => maybeOut suf
- | _ => file (!keepGenerated, suf)
- in cFile := SOME file
- ; file
- end
+ val outputs: File.t list ref = ref []
val r = ref 0
- fun sOut () =
+ fun make (style: style, suf: string) () =
let
- val suf = concat [".",
- Int.toString (!r),
- if !debug then ".s" else ".S"]
+ val suf = concat [".", Int.toString (!r), suf]
+ val _ = Int.inc r
val file = (if !keepGenerated
orelse stop = Place.Generated
then suffix
else temp) suf
- val _ = Int.inc r
- in List.push (sFiles, file)
- ; file
- end
- fun make (style: style,
- f: unit -> File.t) () =
- let
- val f = f ()
- val out = Out.openOut f
+ val _ = List.push (outputs, file)
+ val out = Out.openOut file
fun print s = Out.output (out, s)
val _ = outputHeader' (style, out)
fun done () = Out.close out
- in {file = f,
+ in
+ {file = file,
print = print,
done = done}
end
@@ -697,14 +669,15 @@
Compile.compile
{input = files,
docc = docc,
- outputC = make (Control.C, cOut),
- outputS = make (Control.Assembly, sOut)}
+ outputC = make (Control.C, ".c"),
+ outputS = make (Control.Assembly,
+ if !debug then ".s" else ".S")}
(* Shrink the heap before calling gcc. *)
val _ = MLton.GC.pack ()
in
case stop of
Place.Generated => ()
- | _ => compileC (valOf (!cFile), !sFiles)
+ | _ => compileCSO (List.concat [!outputs, csoFiles])
end
fun compileCM input =
let
@@ -718,22 +691,24 @@
(Out.output
(out, concat ["(*#line 0.0 \"", f, "\"*)\n"])
; File.outputContents (f, out))))))
- in case stop of
- Place.Files =>
- List.foreach (files, fn f => print (concat [f, "\n"]))
- | Place.SML => saveSML (maybeOut ".sml")
- | _ =>
- (if !keepSML
- then saveSML (suffix ".sml")
- else ()
- ; compileSml files)
+ in
+ case stop of
+ Place.Files =>
+ List.foreach
+ (files, fn f => print (concat [f, "\n"]))
+ | Place.SML => saveSML (maybeOut ".sml")
+ | _ =>
+ (if !keepSML
+ then saveSML (suffix ".sml")
+ else ()
+ ; compileSml files)
end
fun compile () =
case start of
Place.CM => compileCM input
| Place.SML => compileSml [input]
- | Place.Generated => compileC (input, sfiles)
- | Place.O => compileO [input]
+ | Place.Generated => compileCSO (input :: csoFiles)
+ | Place.O => compileCSO (input :: csoFiles)
| _ => Error.bug "invalid start"
val doit
= trace (Top, "MLton")
-------------------------------------------------------
This SF.net email is sponsored by: ValueWeb:
Dedicated Hosting for just $79/mo with 500 GB of bandwidth!
No other company gives more support or power for your dedicated server
http://click.atdmt.com/AFF/go/sdnxxaff00300020aff/direct/01/
_______________________________________________
MLton-devel mailing list
MLton-devel@lists.sourceforge.net
https://lists.sourceforge.net/lists/listinfo/mlton-devel