[MLton-commit] r5839
Matthew Fluet
fluet at mlton.org
Wed Aug 8 18:34:00 PDT 2007
Don't hardcode the expected target sizes.
This has some overlap with the LookupConstants functionality;
unfortunately, we need to know the right sizes for mplimb, objptr,
header, and seqIndex in order to parseAndElaborate the Basis Library
(via the MLB path variables) to discover the other constants.
----------------------------------------------------------------------
U mlton/trunk/Makefile
U mlton/trunk/mlton/main/main.fun
U mlton/trunk/runtime/Makefile
_U mlton/trunk/runtime/gen/
U mlton/trunk/runtime/gen/.ignore
A mlton/trunk/runtime/gen/gen-sizes.c
----------------------------------------------------------------------
Modified: mlton/trunk/Makefile
===================================================================
--- mlton/trunk/Makefile 2007-08-09 01:04:29 UTC (rev 5838)
+++ mlton/trunk/Makefile 2007-08-09 01:33:59 UTC (rev 5839)
@@ -284,6 +284,7 @@
$(MAKE) -C runtime
$(CP) include/*.h "$(INC)/"
$(CP) runtime/*.a "$(LIB)/$(TARGET)/"
+ $(CP) runtime/gen/sizes "$(LIB)/$(TARGET)/"
mkdir -p "$(SRC)/basis-library/config/c/$(TARGET_ARCH)-$(TARGET_OS)"
$(CP) runtime/gen/c-types.sml \
basis-library/config/c/$(TARGET_ARCH)-$(TARGET_OS)/c-types.sml
Modified: mlton/trunk/mlton/main/main.fun
===================================================================
--- mlton/trunk/mlton/main/main.fun 2007-08-09 01:04:29 UTC (rev 5838)
+++ mlton/trunk/mlton/main/main.fun 2007-08-09 01:33:59 UTC (rev 5839)
@@ -734,25 +734,40 @@
| _ => Error.bug "incorrect args from shell script"
val () = setTargetType ("self", usage)
val result = parse args
+
+ val target = !target
+ val targetStr =
+ case target of
+ Cross s => s
+ | Self => "self"
+ val _ = libTargetDir := OS.Path.concat (!libDir, targetStr)
val targetArch = !Target.arch
+ val archStr = String.toLower (MLton.Platform.Arch.toString targetArch)
+ val targetOS = !Target.os
+ val OSStr = String.toLower (MLton.Platform.OS.toString targetOS)
+
+ val stop = !stop
+
val () =
align := (case !explicitAlign of
NONE => if defaultAlignIs8 () then Align8 else Align4
| SOME a => a)
val () =
codegen := (case !explicitCodegen of
- NONE => if hasCodegen (x86Codegen)
- then x86Codegen
- else if hasCodegen (amd64Codegen)
- then amd64Codegen
- else CCodegen
- | SOME Native => if hasCodegen (x86Codegen)
- then x86Codegen
- else if hasCodegen (amd64Codegen)
- then amd64Codegen
- else usage (concat ["can't use native codegen on ",
- MLton.Platform.Arch.toString targetArch,
- " target"])
+ NONE =>
+ if hasCodegen (x86Codegen)
+ then x86Codegen
+ else if hasCodegen (amd64Codegen)
+ then amd64Codegen
+ else CCodegen
+ | SOME Native =>
+ if hasCodegen (x86Codegen)
+ then x86Codegen
+ else if hasCodegen (amd64Codegen)
+ then amd64Codegen
+ else usage (concat ["can't use native codegen on ",
+ MLton.Platform.Arch.toString targetArch,
+ " target"])
| SOME (Explicit cg) => cg)
val () = MLton.Rusage.measureGC (!verbosity <> Silent)
val () = if !profileTimeSet
@@ -768,60 +783,46 @@
| _ => usage "can't use -profile with Exn.keepHistory"
; profileRaise := true)
else ()
+
val () =
Compile.setCommandLineConstant
{name = "CallStack.keep",
value = Bool.toString (!Control.profile = Control.ProfileCallStack)}
- val gcc = !gcc
- val stop = !stop
- val target = !target
- val targetStr =
- case target of
- Cross s => s
- | Self => "self"
- val _ = libTargetDir := OS.Path.concat (!libDir, targetStr)
- val archStr = String.toLower (MLton.Platform.Arch.toString targetArch)
- val targetOS = !Target.os
+
val () =
- Control.labelsHaveExtra_ := (case targetOS of
- Cygwin => true
- | Darwin => true
- | MinGW => true
- | _ => false)
- val () =
- case targetArch of
- AMD64 =>
- let
- val word32 = Bits.fromInt 32
- val word64 = Bits.fromInt 64
- in
- Control.Target.setSizes
- {cint = word32,
- cpointer = word64,
- cptrdiff = word64,
- csize = word64,
- header = word64,
- mplimb = word64,
- objptr = word64,
- seqIndex = word64}
- end
- | _ =>
- let
- val word32 = Bits.fromInt 32
- in
- Control.Target.setSizes
- {cint = word32,
- cpointer = word32,
- cptrdiff = word32,
- csize = word32,
- header = word32,
- mplimb = word32,
- objptr = word32,
- seqIndex = word32}
- end
- val OSStr = String.toLower (MLton.Platform.OS.toString targetOS)
+ let
+ val sizeMap =
+ List.map
+ (File.lines (OS.Path.joinDirFile {dir = !Control.libTargetDir,
+ file = "sizes"}),
+ fn line =>
+ case String.tokens (line, Char.isSpace) of
+ [ty, "=", size] =>
+ (case Int.fromString size of
+ NONE => Error.bug (concat ["strange size: ", size])
+ | SOME size =>
+ (ty, Bytes.toBits (Bytes.fromInt size)))
+ | _ => Error.bug (concat ["strange size mapping: ", line]))
+ fun lookup ty' =
+ case List.peek (sizeMap, fn (ty, _) => String.equals (ty, ty')) of
+ NONE => Error.bug (concat ["missing size mapping: ", ty'])
+ | SOME (_, size) => size
+ in
+ Control.Target.setSizes
+ {cint = lookup "cint",
+ cpointer = lookup "cpointer",
+ cptrdiff = lookup "cptrdiff",
+ csize = lookup "csize",
+ header = lookup "header",
+ mplimb = lookup "mplimb",
+ objptr = lookup "objptr",
+ seqIndex = lookup "seqIndex"}
+ end
+
fun tokenize l =
String.tokens (concat (List.separate (l, " ")), Char.isSpace)
+
+ val gcc = !gcc
fun addTargetOpts opts =
List.fold
(!opts, [], fn ({opt, pred}, ac) =>
@@ -859,6 +860,12 @@
MLton.Platform.Arch.toString targetArch,
" target"])
else ()
+ val () =
+ Control.labelsHaveExtra_ := (case targetOS of
+ Cygwin => true
+ | Darwin => true
+ | MinGW => true
+ | _ => false)
val _ =
chunk :=
(case !explicitChunk of
Modified: mlton/trunk/runtime/Makefile
===================================================================
--- mlton/trunk/runtime/Makefile 2007-08-09 01:04:29 UTC (rev 5838)
+++ mlton/trunk/runtime/Makefile 2007-08-09 01:33:59 UTC (rev 5839)
@@ -228,7 +228,7 @@
endif
ALL := libgdtoa.a libmlton.a libmlton-gdb.a
-ALL += gen/c-types.sml gen/basis-ffi.sml
+ALL += gen/c-types.sml gen/basis-ffi.sml gen/sizes
ifeq ($(OMIT_BYTECODE), yes)
else
ALL += bytecode/opcodes
@@ -289,6 +289,12 @@
rm -f basis-ffi.h
cp gen/basis-ffi.h basis-ffi.h
+gen/sizes: gen/gen-sizes.c libmlton.a
+ $(CC) $(OPTCFLAGS) $(WARNCFLAGS) -o gen/gen-sizes -I. -L. -lmlton gen/gen-sizes.c util.o
+ rm -f gen/sizes
+ cd gen && ./gen-sizes
+ rm -f gen/gen-sizes$(EXE)
+
bytecode/opcodes: bytecode/print-opcodes.c bytecode/opcode.h
$(CC) $(OPTCFLAGS) $(WARNCFLAGS) -o bytecode/print-opcodes bytecode/print-opcodes.c
rm -f bytecode/opcodes
Property changes on: mlton/trunk/runtime/gen
___________________________________________________________________
Name: svn:ignore
- c-types.h
c-types.sml
ml-types.h
+ c-types.h
c-types.sml
ml-types.h
sizes
Modified: mlton/trunk/runtime/gen/.ignore
===================================================================
--- mlton/trunk/runtime/gen/.ignore 2007-08-09 01:04:29 UTC (rev 5838)
+++ mlton/trunk/runtime/gen/.ignore 2007-08-09 01:33:59 UTC (rev 5839)
@@ -1,3 +1,4 @@
c-types.h
c-types.sml
ml-types.h
+sizes
Added: mlton/trunk/runtime/gen/gen-sizes.c
===================================================================
--- mlton/trunk/runtime/gen/gen-sizes.c 2007-08-09 01:04:29 UTC (rev 5838)
+++ mlton/trunk/runtime/gen/gen-sizes.c 2007-08-09 01:33:59 UTC (rev 5839)
@@ -0,0 +1,23 @@
+#define MLTON_GC_INTERNAL_TYPES
+#include "platform.h"
+struct GC_state gcState;
+
+int main (__attribute__ ((unused)) int argc,
+ __attribute__ ((unused)) char* argv[]) {
+ FILE *sizesFd;
+
+ sizesFd = fopen_safe ("sizes", "w");
+
+ fprintf (sizesFd, "cint = %zu\n", sizeof(C_Int_t));
+ fprintf (sizesFd, "cpointer = %zu\n", sizeof(C_Pointer_t));
+ fprintf (sizesFd, "cptrdiff = %zu\n", sizeof(C_Ptrdiff_t));
+ fprintf (sizesFd, "csize = %zu\n", sizeof(C_Size_t));
+ fprintf (sizesFd, "header = %zu\n", sizeof(GC_header));
+ fprintf (sizesFd, "mplimb = %zu\n", sizeof(C_MPLimb_t));
+ fprintf (sizesFd, "objptr = %zu\n", sizeof(objptr));
+ fprintf (sizesFd, "seqIndex = %zu\n", sizeof(GC_arrayLength));
+
+ fclose_safe(sizesFd);
+
+ return 0;
+}
More information about the MLton-commit
mailing list