Index: include/common-main.h =================================================================== --- include/common-main.h (revision 6672) +++ include/common-main.h (working copy) @@ -35,7 +35,7 @@ #define LoadArray(a, f) if (fread (a, sizeof(*a), cardof(a), f) != cardof(a)) return -1; #define SaveArray(a, f) if (fwrite(a, sizeof(*a), cardof(a), f) != cardof(a)) return -1; -Pointer gcStateAddress; +INTERNAL Pointer gcStateAddress; #define Initialize(al, mg, mfs, mmc, pk, ps) \ gcStateAddress = &gcState; \ @@ -72,6 +72,10 @@ gcState.profiling.stack = ps; \ MLton_init (argc, argv, &gcState); \ -void MLton_callFromC (); +#define LIB_PASTE(x,y) x ## y +#define LIB_OPEN(x) LIB_PASTE(x, _open) +#define LIB_CLOSE(x) LIB_PASTE(x, _close) +static void MLton_callFromC (); + #endif /* #ifndef _COMMON_MAIN_H_ */ Index: include/amd64-main.h =================================================================== --- include/amd64-main.h (revision 6672) +++ include/amd64-main.h (working copy) @@ -11,21 +11,21 @@ #include "common-main.h" /* Globals */ -Word64 applyFFTempFun; -Word64 applyFFTempStackArg; -Word64 applyFFTempRegArg[6]; -Real32 applyFFTempXmmsRegArgD[8]; -Real64 applyFFTempXmmsRegArgS[8]; -Word32 checkTemp; -Word64 cReturnTemp[16]; -Pointer c_stackP; -Word64 fpcvtTemp; -Word32 fpeqTemp; -Word64 divTemp; -Word64 indexTemp; -Word64 raTemp1; -Word64 spill[32]; -Word64 stackTopTemp; +INTERNAL Word64 applyFFTempFun; +INTERNAL Word64 applyFFTempStackArg; +INTERNAL Word64 applyFFTempRegArg[6]; +INTERNAL Real32 applyFFTempXmmsRegArgD[8]; +INTERNAL Real64 applyFFTempXmmsRegArgS[8]; +INTERNAL Word32 checkTemp; +INTERNAL Word64 cReturnTemp[16]; +INTERNAL Pointer c_stackP; +INTERNAL Word64 fpcvtTemp; +INTERNAL Word32 fpeqTemp; +INTERNAL Word64 divTemp; +INTERNAL Word64 indexTemp; +INTERNAL Word64 raTemp1; +INTERNAL Word64 spill[32]; +INTERNAL Word64 stackTopTemp; #ifndef DEBUG_AMD64CODEGEN #define DEBUG_AMD64CODEGEN FALSE @@ -35,9 +35,9 @@ return *((GC_frameIndex*)(ra - sizeof(GC_frameIndex))); } -#define MLtonMain(al, mg, mfs, mmc, pk, ps, ml) \ +#define MLtonCallFromC \ void MLton_jumpToSML (pointer jump); \ -void MLton_callFromC () { \ +static void MLton_callFromC () { \ pointer jump; \ GC_state s; \ \ @@ -60,8 +60,11 @@ if (DEBUG_AMD64CODEGEN) \ fprintf (stderr, "MLton_callFromC() done\n"); \ return; \ -} \ -int MLton_main (int argc, char* argv[]) { \ +} + +#define MLtonMain(al, mg, mfs, mmc, pk, ps, ml) \ +MLtonCallFromC \ +EXPORTED int MLton_main (int argc, char* argv[]) { \ pointer jump; \ extern pointer ml; \ \ @@ -76,4 +79,27 @@ return 1; \ } +#define MLtonLibrary(al, mg, mfs, mmc, pk, ps, ml) \ +MLtonCallFromC \ +EXPORTED void LIB_OPEN(LIBNAME) (int argc, char* argv[]) { \ + pointer jump; \ + extern pointer ml; \ + \ + Initialize (al, mg, mfs, mmc, pk, ps); \ + if (gcState.amOriginal) { \ + real_Init(); \ + jump = (pointer)&ml; \ + } else { \ + jump = *(pointer*)(gcState.stackTop - GC_RETURNADDRESS_SIZE); \ + } \ + MLton_jumpToSML(jump); \ + GC_switchToThread (&gcState, GC_getSavedThread (&gcState), 0); \ +} \ +EXPORTED void LIB_CLOSE(LIBNAME) () { \ + pointer jump; \ + jump = *(pointer*)(gcState.stackTop - GC_RETURNADDRESS_SIZE); \ + MLton_jumpToSML(jump); \ + GC_done(&gcState); \ +} + #endif /* #ifndef _AMD64_MAIN_H_ */ Index: include/bytecode.h =================================================================== --- include/bytecode.h (revision 6672) +++ include/bytecode.h (working copy) @@ -8,6 +8,7 @@ #include #include "ml-types.h" #include "c-types.h" +#include "export.h" typedef Pointer CPointer; typedef Pointer Objptr; Index: include/bytecode-main.h =================================================================== --- include/bytecode-main.h (revision 6672) +++ include/bytecode-main.h (working copy) @@ -15,14 +15,14 @@ #define DEBUG_CODEGEN FALSE #endif -struct Bytecode MLton_bytecode; +INTERNAL struct Bytecode MLton_bytecode; static GC_frameIndex returnAddressToFrameIndex (GC_returnAddress ra) { return *((GC_frameIndex*)(MLton_bytecode.code + ra - sizeof(GC_frameIndex))); } -#define MLtonMain(al, mg, mfs, mmc, pk, ps, ml) \ -void MLton_callFromC () { \ +#define MLtonCallFromC \ +static void MLton_callFromC () { \ uintptr_t nextFun; \ GC_state s; \ \ @@ -46,7 +46,10 @@ if (DEBUG_CODEGEN) \ fprintf (stderr, "MLton_callFromC done\n"); \ } \ -int MLton_main (int argc, char* argv[]) { \ + +#define MLtonMain(al, mg, mfs, mmc, pk, ps, ml) \ +MLtonCallFromC \ +EXPORTED int MLton_main (int argc, char* argv[]) { \ uintptr_t nextFun; \ Initialize (al, mg, mfs, mmc, pk, ps); \ if (gcState.amOriginal) { \ @@ -57,6 +60,29 @@ nextFun = *(uintptr_t*)(gcState.stackTop - GC_RETURNADDRESS_SIZE); \ } \ MLton_Bytecode_interpret (&MLton_bytecode, nextFun); \ + return 1; \ } +#define MLtonLibrary(al, mg, mfs, mmc, pk, ps, ml) \ +MLtonCallFromC \ +EXPORTED void LIB_OPEN(LIBNAME) (int argc, char* argv[]) { \ + uintptr_t nextFun; \ + Initialize (al, mg, mfs, mmc, pk, ps); \ + if (gcState.amOriginal) { \ + real_Init(); \ + nextFun = ml; \ + } else { \ + /* Return to the saved world */ \ + nextFun = *(uintptr_t*)(gcState.stackTop - GC_RETURNADDRESS_SIZE); \ + } \ + MLton_Bytecode_interpret (&MLton_bytecode, nextFun); \ + GC_switchToThread (&gcState, GC_getSavedThread (&gcState), 0); \ +} \ +EXPORTED void LIB_CLOSE(LIBNAME) () { \ + uintptr_t nextFun; \ + nextFun = *(uintptr_t*)(gcState.stackTop - GC_RETURNADDRESS_SIZE); \ + MLton_Bytecode_interpret (&MLton_bytecode, nextFun); \ + GC_done(&gcState); \ +} + #endif /* #ifndef _BYTECODE_MAIN_H */ Index: include/c-main.h =================================================================== --- include/c-main.h (revision 6672) +++ include/c-main.h (working copy) @@ -16,11 +16,11 @@ return (GC_frameIndex)ra; } -#define MLtonMain(al, mg, mfs, mmc, pk, ps, mc, ml) \ +#define MLtonCallFromC \ /* Globals */ \ -uintptr_t nextFun; \ -int returnToC; \ -void MLton_callFromC () { \ +INTERNAL uintptr_t nextFun; \ +INTERNAL int returnToC; \ +static void MLton_callFromC () { \ struct cont cont; \ GC_state s; \ \ @@ -47,8 +47,11 @@ s->limit = 0; \ if (DEBUG_CCODEGEN) \ fprintf (stderr, "MLton_callFromC done\n"); \ -} \ -int MLton_main (int argc, char* argv[]) { \ +} + +#define MLtonMain(al, mg, mfs, mmc, pk, ps, mc, ml) \ +MLtonCallFromC \ +EXPORTED int MLton_main (int argc, char* argv[]) { \ struct cont cont; \ Initialize (al, mg, mfs, mmc, pk, ps); \ if (gcState.amOriginal) { \ @@ -70,6 +73,37 @@ cont=(*(struct cont(*)(void))cont.nextChunk)(); \ cont=(*(struct cont(*)(void))cont.nextChunk)(); \ } \ + return 1; \ } +#define MLtonLibrary(al, mg, mfs, mmc, pk, ps, mc, ml) \ +MLtonCallFromC \ +EXPORTED void LIB_OPEN(LIBNAME) (int argc, char* argv[]) { \ + struct cont cont; \ + Initialize (al, mg, mfs, mmc, pk, ps); \ + if (gcState.amOriginal) { \ + real_Init(); \ + PrepFarJump(mc, ml); \ + } else { \ + /* Return to the saved world */ \ + nextFun = *(uintptr_t*)(gcState.stackTop - GC_RETURNADDRESS_SIZE); \ + cont.nextChunk = nextChunks[nextFun]; \ + } \ + /* Trampoline */ \ + do { \ + cont=(*(struct cont(*)(void))cont.nextChunk)(); \ + } while (not returnToC); \ + GC_switchToThread (&gcState, GC_getSavedThread (&gcState), 0); \ +} \ +EXPORTED void LIB_CLOSE(LIBNAME) () { \ + struct cont cont; \ + nextFun = *(uintptr_t*)(gcState.stackTop - GC_RETURNADDRESS_SIZE); \ + cont.nextChunk = nextChunks[nextFun]; \ + returnToC = false; \ + do { \ + cont=(*(struct cont(*)(void))cont.nextChunk)(); \ + } while (not returnToC); \ + GC_done(&gcState); \ +} + #endif /* #ifndef _C_MAIN_H */ Index: include/x86-main.h =================================================================== --- include/x86-main.h (revision 6672) +++ include/x86-main.h (working copy) @@ -11,28 +11,28 @@ #include "common-main.h" /* Globals */ -Word32 applyFFTemp; -Word32 applyFFTemp2; -Word32 checkTemp; -Word32 cReturnTemp[16]; -Pointer c_stackP; -Word32 divTemp; -Word32 fildTemp; -Word32 fpswTemp; -Word32 indexTemp; -Word32 raTemp1; -Real64 raTemp2; -Real64 realTemp1D; -Real64 realTemp2D; -Real64 realTemp3D; -Real32 realTemp1S; -Real32 realTemp2S; -Real32 realTemp3S; -Word32 spill[16]; -Word32 stackTopTemp; -Word8 wordTemp1B; -Word16 wordTemp1W; -Word32 wordTemp1L; +INTERNAL Word32 applyFFTemp; +INTERNAL Word32 applyFFTemp2; +INTERNAL Word32 checkTemp; +INTERNAL Word32 cReturnTemp[16]; +INTERNAL Pointer c_stackP; +INTERNAL Word32 divTemp; +INTERNAL Word32 fildTemp; +INTERNAL Word32 fpswTemp; +INTERNAL Word32 indexTemp; +INTERNAL Word32 raTemp1; +INTERNAL Real64 raTemp2; +INTERNAL Real64 realTemp1D; +INTERNAL Real64 realTemp2D; +INTERNAL Real64 realTemp3D; +INTERNAL Real32 realTemp1S; +INTERNAL Real32 realTemp2S; +INTERNAL Real32 realTemp3S; +INTERNAL Word32 spill[16]; +INTERNAL Word32 stackTopTemp; +INTERNAL Word8 wordTemp1B; +INTERNAL Word16 wordTemp1W; +INTERNAL Word32 wordTemp1L; #ifndef DEBUG_X86CODEGEN #define DEBUG_X86CODEGEN FALSE @@ -42,9 +42,9 @@ return *((GC_frameIndex*)(ra - sizeof(GC_frameIndex))); } -#define MLtonMain(al, mg, mfs, mmc, pk, ps, ml) \ +#define MLtonCallFromC \ void MLton_jumpToSML (pointer jump); \ -void MLton_callFromC () { \ +static void MLton_callFromC () { \ pointer jump; \ GC_state s; \ \ @@ -68,8 +68,11 @@ if (DEBUG_X86CODEGEN) \ fprintf (stderr, "MLton_callFromC() done\n"); \ return; \ -} \ -int MLton_main (int argc, char* argv[]) { \ +} + +#define MLtonMain(al, mg, mfs, mmc, pk, ps, ml) \ +MLtonCallFromC \ +EXPORTED int MLton_main (int argc, char* argv[]) { \ pointer jump; \ extern pointer ml; \ \ @@ -84,5 +87,27 @@ return 1; \ } +#define MLtonLibrary(al, mg, mfs, mmc, pk, ps, ml) \ +MLtonCallFromC \ +EXPORTED void LIB_OPEN(LIBNAME) (int argc, char* argv[]) { \ + pointer jump; \ + extern pointer ml; \ + \ + Initialize (al, mg, mfs, mmc, pk, ps); \ + if (gcState.amOriginal) { \ + real_Init(); \ + jump = (pointer)&ml; \ + } else { \ + jump = *(pointer*)(gcState.stackTop - GC_RETURNADDRESS_SIZE); \ + } \ + MLton_jumpToSML(jump); \ + GC_switchToThread (&gcState, GC_getSavedThread (&gcState), 0); \ +} \ +EXPORTED void LIB_CLOSE(LIBNAME) () { \ + pointer jump; \ + jump = *(pointer*)(gcState.stackTop - GC_RETURNADDRESS_SIZE); \ + MLton_jumpToSML(jump); \ + GC_done(&gcState); \ +} + #endif /* #ifndef _X86_MAIN_H_ */ - Index: include/c-chunk.h =================================================================== --- include/c-chunk.h (revision 6672) +++ include/c-chunk.h (working copy) @@ -144,7 +144,7 @@ fprintf (stderr, "%s:%d: Thread_returnToC()\n", \ __FILE__, __LINE__); \ returnToC = TRUE; \ - return cont; \ + goto leaveChunk; \ } while (0) /* ------------------------------------------------- */ @@ -212,7 +212,7 @@ #define MLTON_CODEGEN_MEMCPY(decl) #endif MLTON_CODEGEN_MEMCPY(void * memcpy(void *, const void*, size_t);) -#include "basis-ffi.h" +/* imported via FFI, so elided: #include "basis-ffi.h" */ #include "basis/coerce.h" #include "basis/cpointer.h" #include "basis/Real/Real-ops.h" Index: include/c-common.h =================================================================== --- include/c-common.h (revision 6672) +++ include/c-common.h (working copy) @@ -13,6 +13,8 @@ #define DEBUG_CCODEGEN FALSE #endif +#include "export.h" + struct cont { void *nextChunk; }; @@ -25,7 +27,7 @@ #define ChunkName(n) Chunk ## n #define DeclareChunk(n) \ - struct cont ChunkName(n)(void) + INTERNAL struct cont ChunkName(n)(void) #define Chunkp(n) &(ChunkName(n)) Index: runtime/bytecode/interpret.c =================================================================== --- runtime/bytecode/interpret.c (revision 6672) +++ runtime/bytecode/interpret.c (working copy) @@ -597,6 +597,8 @@ Switch(32); Switch(64); case opcodeSym (Thread_returnToC): + FlushFrontier (); + FlushStackTop (); maybe goto done; default: assert (FALSE); Index: runtime/export.h =================================================================== --- runtime/export.h (revision 0) +++ runtime/export.h (revision 0) @@ -0,0 +1,24 @@ +/* Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + */ + +#ifndef _MLTON_EXPORT_H_ +#define _MLTON_EXPORT_H_ + +/* ------------------------------------------------- */ +/* Symbols */ +/* ------------------------------------------------- */ + +#if __GNUC__ >= 4 +#define EXPORTED __attribute__((visibility("default"))) +#define INTERNAL __attribute__((visibility("hidden"))) +#else +#define EXPORTED +#define INTERNAL +#endif + +#endif /* _MLTON_EXPORT_H_ */ Index: runtime/platform.h =================================================================== --- runtime/platform.h (revision 6672) +++ runtime/platform.h (working copy) @@ -13,6 +13,7 @@ #include "util.h" #include "ml-types.h" #include "c-types.h" +#include "export.h" #ifndef MLton_Platform_Arch_host #error MLton_Platform_Arch_host not defined Index: runtime/Makefile =================================================================== --- runtime/Makefile (revision 6672) +++ runtime/Makefile (working copy) @@ -33,13 +33,21 @@ FLAGS := EXE := OPTFLAGS := -O2 -fomit-frame-pointer +DEBUGFLAGS := -O1 -fno-inline -fkeep-inline-functions -g2 +PICFLAGS := -fPIC -DPIC GCOPTFLAGS := -DEBUGFLAGS := -O1 -fno-inline -fkeep-inline-functions -g2 GCDEBUGFLAGS := +GCPICFLAGS := WARNFLAGS := OPTWARNFLAGS := DEBUGWARNFLAGS := +PICWARNFLAGS := +# Make mlton static library symbols private +ifeq ($(findstring $(GCC_MAJOR_VERSION), 4),$(GCC_MAJOR_VERSION)) +FLAGS += -fvisibility=hidden +endif + ifeq ($(TARGET_ARCH), amd64) FLAGS += -m64 ifeq ($(findstring $(GCC_VERSION), 3.4 4.0 4.1),$(GCC_VERSION)) @@ -113,8 +121,10 @@ CFLAGS := -I. -Iplatform $(FLAGS) OPTCFLAGS := $(CFLAGS) $(CPPFLAGS) $(OPTFLAGS) DEBUGCFLAGS := $(CFLAGS) $(CPPFLAGS) -DASSERT=1 $(DEBUGFLAGS) +PICCFLAGS := $(CFLAGS) $(CPPFLAGS) $(OPTFLAGS) $(PICFLAGS) GCOPTCFLAGS = $(GCOPTFLAGS) GCDEBUGCFLAGS = $(GCDEBUGFLAGS) +GCPICCFLAGS = $(GCOPTFLAGS) $(GCPICFLAGS) WARNCFLAGS := WARNCFLAGS += -pedantic -Wall ifeq ($(findstring $(GCC_MAJOR_VERSION), 3),$(GCC_MAJOR_VERSION)) @@ -167,6 +177,7 @@ OPTWARNCFLAGS := $(WARNCFLAGS) -Wdisabled-optimization $(OPTWARNFLAGS) DEBUGWARNCFLAGS := $(WARNCFLAGS) $(DEBUGWARNFLAGS) +PICWARNCFLAGS := $(WARNCFLAGS) $(OPTWARNFLAGS) $(PICWARNFLAGS) UTILHFILES := \ util.h \ @@ -212,25 +223,35 @@ gc-gdb.o \ platform-gdb.o \ platform/$(TARGET_OS)-gdb.o +PIC_OBJS := \ + util-pic.o \ + gc-pic.o \ + platform-pic.o \ + platform/$(TARGET_OS)-pic.o OMIT_BYTECODE := no ifeq ($(OMIT_BYTECODE), yes) else OBJS += bytecode/interpret.o DEBUG_OBJS += bytecode/interpret-gdb.o + PIC_OBJS += bytecode/interpret-pic.o endif ifeq ($(COMPILE_FAST), yes) OBJS += basis.o DEBUG_OBJS += basis-gdb.o + PIC_OBJS += basis-pic.o else OBJS += \ $(foreach f, $(basename $(BASISCFILES)), $(f).o) DEBUG_OBJS += \ $(foreach f, $(basename $(BASISCFILES)), $(f)-gdb.o) + PIC_OBJS += \ + $(foreach f, $(basename $(BASISCFILES)), $(f)-pic.o) endif -ALL := libgdtoa.a libmlton.a libmlton-gdb.a +ALL := libgdtoa.a libgdtoa-gdb.a libgdtoa-pic.a \ + libmlton.a libmlton-gdb.a libmlton-pic.a ALL += gen/c-types.sml gen/basis-ffi.sml gen/sizes ifeq ($(OMIT_BYTECODE), yes) else @@ -248,6 +269,24 @@ $(AR) libgdtoa.a gdtoa/*.o $(RANLIB) libgdtoa.a +libgdtoa-gdb.a: gdtoa/arith.h + cd gdtoa && \ + $(CC) $(DEBUGCFLAGS) $(DEBUGWARNCFLAGS) \ + -w -O1 -c -DINFNAN_CHECK \ + *.c + $(RM) gdtoa/arithchk.o + $(AR) libgdtoa-gdb.a gdtoa/*.o + $(RANLIB) libgdtoa-gdb.a + +libgdtoa-pic.a: gdtoa/arith.h + cd gdtoa && \ + $(CC) $(PICCFLAGS) $(PICWARNCFLAGS) \ + -w -O1 -c -DINFNAN_CHECK \ + *.c + $(RM) gdtoa/arithchk.o + $(AR) libgdtoa-pic.a gdtoa/*.o + $(RANLIB) libgdtoa-pic.a + gdtoa/arithchk.c: gzip -dc gdtoa.tgz | tar xf - patch -s -p0 > basis.c @@ -305,12 +348,18 @@ rm -f bytecode/print-opcodes$(EXE) +util-pic.o: util.c $(UTILCFILES) cenv.h $(UTILHFILES) + $(CC) $(PICCFLAGS) $(PICWARNCFLAGS) -c -o $@ $< + util-gdb.o: util.c $(UTILCFILES) cenv.h $(UTILHFILES) $(CC) $(DEBUGCFLAGS) $(DEBUGWARNCFLAGS) -c -o $@ $< util.o: util.c $(UTILCFILES) cenv.h $(UTILHFILES) $(CC) $(OPTCFLAGS) $(OPTWARNCFLAGS) -c -o $@ $< +gc-pic.o: gc.c $(GCCFILES) $(HFILES) + $(CC) $(PICCFLAGS) $(GCPICCFLAGS) $(PICWARNCFLAGS) -c -o $@ $< + gc-gdb.o: gc.c $(GCCFILES) $(HFILES) $(CC) $(DEBUGCFLAGS) $(GCDEBUGCFLAGS) $(DEBUGWARNCFLAGS) -c -o $@ $< @@ -318,10 +367,12 @@ $(CC) $(OPTCFLAGS) $(GCOPTCFLAGS) $(OPTWARNCFLAGS) -c -o $@ $< ## Needs -Wno-float-equal for Real_equal, included via "c-chunk.h". +bytecode/interpret-pic.o: bytecode/interpret.c $(HFILES) $(BYTECODEHFILES) + $(CC) -I../include $(PICCFLAGS) $(PICWARNCFLAGS) -Wno-float-equal -c -o $@ $< + bytecode/interpret-gdb.o: bytecode/interpret.c $(HFILES) $(BYTECODEHFILES) $(CC) -I../include $(DEBUGCFLAGS) $(DEBUGWARNCFLAGS) -Wno-float-equal -c -o $@ $< -## Needs -Wno-float-equal for Real_equal, included via "c-chunk.h". bytecode/interpret.o: bytecode/interpret.c $(HFILES) $(BYTECODEHFILES) $(CC) -I../include $(OPTCFLAGS) $(GCOPTCFLAGS) $(OPTWARNCFLAGS) -Wno-float-equal -c -o $@ $< @@ -329,31 +380,34 @@ ## Needs -Wno-float-equal for Real_equal; ## needs -Wno-format-nonliteralfor Date_strfTime; ## needs -Wno-redundant-decls for 'extern struct GC_state gcState'. +basis-pic.o: basis.c $(BASISCFILES) $(HFILES) + $(CC) -Ibasis -Ibasis/Word -Ibasis/Real $(PICCFLAGS) $(PICWARNCFLAGS) -Wno-float-equal -Wno-format-nonliteral -Wno-redundant-decls -c -o $@ $< basis-gdb.o: basis.c $(BASISCFILES) $(HFILES) $(CC) -Ibasis -Ibasis/Word -Ibasis/Real $(DEBUGCFLAGS) $(DEBUGWARNCFLAGS) -Wno-float-equal -Wno-format-nonliteral -Wno-redundant-decls -c -o $@ $< +basis.o: basis.c $(BASISCFILES) $(HFILES) + $(CC) -Ibasis -Ibasis/Word -Ibasis/Real $(OPTCFLAGS) $(OPTWARNCFLAGS) -Wno-float-equal -Wno-format-nonliteral -Wno-redundant-decls -c -o $@ $< ## Needs -Wno-float-equal for Real_equal. +basis/Real/Real-pic.o: basis/Real/Real.c $(HFILES) + $(CC) $(PICCFLAGS) $(PICWARNCFLAGS) -Wno-float-equal -c -o $@ $< basis/Real/Real-gdb.o: basis/Real/Real.c $(HFILES) + $(CC) $(DEBUGCFLAGS) $(DEBUGWARNCFLAGS) -Wno-float-equal -c -o $@ $< +basis/Real/Real.o: basis/Real/Real.c $(HFILES) $(CC) $(OPTCFLAGS) $(OPTWARNCFLAGS) -Wno-float-equal -c -o $@ $< ## Needs -Wno-format-nonliteralfor Date_strfTime. +basis/System/Date-pic.o: basis/System/Date.c $(HFILES) + $(CC) $(PICCFLAGS) $(PICWARNCFLAGS) -Wno-format-nonliteral -c -o $@ $< basis/System/Date-gdb.o: basis/System/Date.c $(HFILES) + $(CC) $(DEBUGCFLAGS) $(DEBUGWARNCFLAGS) -Wno-format-nonliteral -c -o $@ $< +basis/System/Date.o: basis/System/Date.c $(HFILES) $(CC) $(OPTCFLAGS) $(OPTWARNCFLAGS) -Wno-format-nonliteral -c -o $@ $< + +%-pic.o: %.c $(HFILES) + $(CC) $(PICCFLAGS) $(PICWARNCFLAGS) -c -o $@ $< + %-gdb.o: %.c $(HFILES) $(CC) $(DEBUGCFLAGS) $(DEBUGWARNCFLAGS) -c -o $@ $< - -## Needs -Wno-float-equal for Real_equal; -## needs -Wno-format-nonliteral for Date_strfTime; -## needs -Wno-redundant-decls for 'extern struct GC_state gcState'. -basis.o: basis.c $(BASISCFILES) $(HFILES) - $(CC) -Ibasis -Ibasis/Word -Ibasis/Real $(OPTCFLAGS) $(OPTWARNCFLAGS) -Wno-float-equal -Wno-format-nonliteral -Wno-redundant-decls -c -o $@ $< -## Needs -Wno-float-equal for Real_equal. -basis/Real/Real.o: basis/Real/Real.c $(HFILES) - $(CC) $(OPTCFLAGS) $(OPTWARNCFLAGS) -Wno-float-equal -c -o $@ $< -## Needs -Wno-format-nonliteralfor Date_strfTime. -basis/System/Date.o: basis/System/Date.c $(HFILES) - $(CC) $(OPTCFLAGS) $(OPTWARNCFLAGS) -Wno-format-nonliteral -c -o $@ $< - %.o: %.c $(HFILES) $(CC) $(OPTCFLAGS) $(OPTWARNCFLAGS) -c -o $@ $< Index: mlton/control/control-flags.sig =================================================================== --- mlton/control/control-flags.sig (revision 6672) +++ mlton/control/control-flags.sig (working copy) @@ -145,6 +145,20 @@ val exnHistory: bool ref + structure Format: + sig + datatype t = + Archive + | Executable + | Library + val all: t list + val toString: t -> string + end + + datatype format = datatype Format.t + + val format: Format.t ref + (* *) datatype gcCheck = Limit Index: mlton/control/control-flags.sml =================================================================== --- mlton/control/control-flags.sml (revision 6672) +++ mlton/control/control-flags.sml (working copy) @@ -614,6 +614,27 @@ default = false, toString = Bool.toString} +structure Format = + struct + datatype t = + Archive + | Executable + | Library + + val all = [Archive, Executable, Library] + + val toString: t -> string = + fn Archive => "archive" + | Executable => "executable" + | Library => "library" + end + +datatype format = datatype Format.t + +val format = control {name = "generated output format", + default = Format.Executable, + toString = Format.toString} + structure GcCheck = struct datatype t = Index: mlton/atoms/ffi.fun =================================================================== --- mlton/atoms/ffi.fun (revision 6672) +++ mlton/atoms/ffi.fun (working copy) @@ -44,7 +44,7 @@ fun declareExports {print} = let - val _ = print "Pointer MLton_FFI_opArgsResPtr;\n" + val _ = print "INTERNAL Pointer MLton_FFI_opArgsResPtr;\n" in List.foreach (!symbols, fn {name, ty} => @@ -69,7 +69,8 @@ "(Pointer)(&", x, ");\n"]) end) val header = - concat [case res of + concat ["EXPORTED ", + case res of NONE => "void" | SOME t => CType.toString t, if convention <> Convention.Cdecl Index: mlton/main/compile.fun =================================================================== --- mlton/main/compile.fun (revision 6672) +++ mlton/main/compile.fun (working copy) @@ -424,6 +424,10 @@ val _ = print "typedef void* CPointer;\n" val _ = print "typedef Pointer Objptr;\n" val _ = print "\n" + val _ = + if !Control.format = Control.Executable then () else + (print ("void " ^ File.base f ^ "_open(int argc, const char** argv);\n") + ;print ("void " ^ File.base f ^ "_close();\n")) val _ = Ffi.declareHeaders {print = print} in () Index: mlton/main/lookup-constant.fun =================================================================== --- mlton/main/lookup-constant.fun (revision 6672) +++ mlton/main/lookup-constant.fun (working copy) @@ -33,6 +33,10 @@ | x86Codegen => 2 | amd64Codegen => 3)), ("MLton_FFI_numExports", fn () => int (Ffi.numExports ())), + ("MLton_Platform_Format", fn () => case !format of + Archive => "archive" + | Executable => "executable" + | Library => "library"), ("MLton_Profile_isOn", fn () => bool (case !profile of ProfileNone => false | ProfileCallStack => false Index: mlton/main/main.fun =================================================================== --- mlton/main/main.fun (revision 6672) +++ mlton/main/main.fun (working copy) @@ -53,6 +53,7 @@ end val gcc: string ref = ref "" +val ar: string ref = ref "ar" val asOpts: {opt: string, pred: OptPred.t} list ref = ref [] val ccOpts: {opt: string, pred: OptPred.t} list ref = ref [] val linkOpts: {opt: string, pred: OptPred.t} list ref = ref [] @@ -203,6 +204,8 @@ | "8" => Align8 | _ => usage (concat ["invalid -align flag: ", s]))))), + (Expert, "ar", " ", "path to ar executable", + SpaceString (fn s => ar := s)), (Normal, "as-opt", " ", "pass option to assembler", (SpaceString o tokenizeOpt) (fn s => List.push (asOpts, {opt = s, pred = OptPred.Yes}))), @@ -353,6 +356,21 @@ boolRef expert), (Normal, "export-header", " ", "write C header file for _export's", SpaceString (fn s => exportHeader := SOME s)), + (Expert, "format", + concat [" {", + String.concatWith + (List.keepAllMap + (Control.Format.all, fn cg => SOME (Control.Format.toString cg)), + "|"), + "}"], + "generated output format", + SpaceString (fn s => + Control.format + := (case List.peek + (Control.Format.all, fn cg => + s = Control.Format.toString cg) of + SOME cg => cg + | NONE => usage (concat ["invalid -format flag: ", s])))), (Expert, "gc-check", " {limit|first|every}", "force GCs", SpaceString (fn s => gcCheck := @@ -869,6 +887,18 @@ file = s ^ "-" ^ gccFile} end | Self => !gcc + val ar = + case target of + Cross s => + let + val {dir = arDir, file = arFile} = + OS.Path.splitDirFile (!ar) + in + OS.Path.joinDirFile + {dir = arDir, + file = s ^ "-" ^ arFile} + end + | Self => !ar fun addTargetOpts opts = List.fold @@ -887,8 +917,13 @@ val ccOpts = addTargetOpts ccOpts val ccOpts = concat ["-I", !libTargetDir, "/include"] :: ccOpts val linkOpts = - List.concat [[concat ["-L", !libTargetDir], - if !debugRuntime then "-lmlton-gdb" else "-lmlton"], + List.concat [[concat ["-L", !libTargetDir]], + if !format = Library then + ["-lmlton-pic", "-lgdtoa-pic"] + else if !debugRuntime then + ["-lmlton-gdb", "-lgdtoa-gdb"] + else + ["-lmlton", "-lgdtoa"], addTargetOpts linkOpts] val _ = if not (hasCodegen (!codegen)) @@ -1061,6 +1096,10 @@ case !output of NONE => suffix suf | SOME f => f + fun libname () = + case !exportHeader of + NONE => "lib" + | SOME f => File.base f val _ = atMLtons := Vector.fromList @@ -1081,17 +1120,28 @@ | StabsPlus => (["-gstabs+", "-g2"], "-Wa,--gstabs") fun compileO (inputs: File.t list): unit = let - val output = maybeOut "" + val output = + case !format of + Archive => maybeOut ".a" + | Executable => maybeOut "" + | Library => maybeOut ".so" + val libOpts = + [ "-shared", "-Wl,-Bsymbolic" ] val _ = trace (Top, "Link") (fn () => - System.system - (gcc, - List.concat - [["-o", output], - if !debug then gccDebug else [], - inputs, - linkOpts])) + if !format = Archive + then (File.remove output + ;System.system + (ar, List.concat [["rcs", output], inputs])) + else System.system + (gcc, + List.concat + [["-o", output], + if !format = Library then libOpts else [], + if !debug then gccDebug else [], + inputs, + linkOpts])) () (* gcc on Cygwin appends .exe, which I don't want, so * move the output file to it's rightful place. @@ -1132,11 +1182,16 @@ let val debugSwitches = gccDebug @ ["-DASSERT=1"] val output = mkOutputO (c, input) + val _ = System.system (gcc, List.concat [[ "-std=gnu99", "-c" ], + if !format = Executable + then [] else [ "-DLIBNAME=" ^ libname () ], + if !format = Library + then [ "-fPIC", "-DPIC" ] else [], if !debug then debugSwitches else [], ccOpts, ["-o", output], Index: mlton/codegen/c-codegen/c-codegen.fun =================================================================== --- mlton/codegen/c-codegen/c-codegen.fun (revision 6672) +++ mlton/codegen/c-codegen/c-codegen.fun (working copy) @@ -400,7 +400,10 @@ | Control.ProfileTimeField => "PROFILE_TIME_FIELD" | Control.ProfileTimeLabel => "PROFILE_TIME_LABEL" in - C.callNoSemi ("MLtonMain", + C.callNoSemi (case !Control.format of + Control.Archive => "MLtonLibrary" + | Control.Executable => "MLtonMain" + | Control.Library => "MLtonLibrary", [C.int align, magic, C.bytes maxFrameSize, @@ -412,7 +415,7 @@ ; print "\n" end fun declareMain () = - if !Control.emitMain + if !Control.emitMain andalso !Control.format = Control.Executable then List.foreach (["int main (int argc, char* argv[]) {", "return (MLton_main (argc, argv));", @@ -453,7 +456,7 @@ end in outputIncludes (includes, print) - ; declareGlobals ("", print) + ; declareGlobals ("INTERNAL ", print) ; declareExports () ; declareLoadSaveGlobals () ; declareIntInfs () @@ -1195,7 +1198,7 @@ val {print, done, ...} = outputC () fun rest () = (List.foreach (chunks, fn c => declareChunk (c, print)) - ; print "struct cont ( *nextChunks []) () = {" + ; print "INTERNAL struct cont ( *nextChunks []) () = {" ; Vector.foreach (entryLabels, fn l => let val {chunkLabel, ...} = labelInfo l Index: mlton/codegen/x86-codegen/x86.fun =================================================================== --- mlton/codegen/x86-codegen/x86.fun (revision 6672) +++ mlton/codegen/x86-codegen/x86.fun (working copy) @@ -3350,6 +3350,8 @@ ","))] | Global l => seq [str ".globl ", + Label.layout l, + str "\n.hidden ", Label.layout l] | IndirectSymbol l => seq [str ".indirect_symbol ", Index: mlton/codegen/x86-codegen/x86-codegen.fun =================================================================== --- mlton/codegen/x86-codegen/x86-codegen.fun (revision 6672) +++ mlton/codegen/x86-codegen/x86-codegen.fun (working copy) @@ -145,7 +145,7 @@ Int.max (max, regMax t)) val m = m + 1 in - print (concat [CType.toString t, + print (concat ["INTERNAL ", CType.toString t, " local", CType.toString t, "[", Int.toString m, "];\n"]) end) Index: mlton/codegen/amd64-codegen/amd64.fun =================================================================== --- mlton/codegen/amd64-codegen/amd64.fun (revision 6672) +++ mlton/codegen/amd64-codegen/amd64.fun (working copy) @@ -3143,6 +3143,8 @@ ","))] | Global l => seq [str ".globl ", + Label.layout l, + str "\n.hidden ", Label.layout l] | IndirectSymbol l => seq [str ".indirect_symbol ", Index: mlton/codegen/amd64-codegen/amd64-codegen.fun =================================================================== --- mlton/codegen/amd64-codegen/amd64-codegen.fun (revision 6672) +++ mlton/codegen/amd64-codegen/amd64-codegen.fun (working copy) @@ -145,7 +145,7 @@ Int.max (max, regMax t)) val m = m + 1 in - print (concat [CType.toString t, + print (concat ["INTERNAL ", CType.toString t, " local", CType.toString t, "[", Int.toString m, "];\n"]) end) Index: mlton/codegen/bytecode/bytecode.fun =================================================================== --- mlton/codegen/bytecode/bytecode.fun (revision 6672) +++ mlton/codegen/bytecode/bytecode.fun (working copy) @@ -825,7 +825,7 @@ val () = done () val {done, print, ...} = outputC () fun declareCallC () = - (print "void MLton_callC (int i) {\n" + (print "INTERNAL void MLton_callC (int i) {\n" ; print "switch (i) {\n" ; List.foreach (!callCs, fn {display, index} => (print (concat ["case ", Int.toString index, ":\n\t"]) Index: basis-library/mlton/platform.sig =================================================================== --- basis-library/mlton/platform.sig (revision 6672) +++ basis-library/mlton/platform.sig (working copy) @@ -17,6 +17,15 @@ val toString: t -> string end + structure Format: + sig + datatype t = Archive | Executable | Library + + val fromString: string -> t option + val host: t + val toString: t -> string + end + structure OS: sig datatype t = AIX | Cygwin | Darwin | FreeBSD | HPUX Index: basis-library/mlton/platform.sml =================================================================== --- basis-library/mlton/platform.sml (revision 6672) +++ basis-library/mlton/platform.sml (working copy) @@ -39,6 +39,25 @@ fun toString a = #2 (valOf (peek (all, fn (a', _) => a = a'))) end + structure Format = + struct + open Format + + val all = [ + (Archive, "Archive"), + (Executable, "Executable"), + (Library, "Library")] + + fun fromString s = + let + val s = String.toLower s + in + omap (peek (all, fn (_, s') => s = String.toLower s'), #1) + end + + fun toString a = #2 (valOf (peek (all, fn (a', _) => a = a'))) + end + structure OS = struct open OS Index: basis-library/mlton/mlton.sml =================================================================== --- basis-library/mlton/mlton.sml (revision 6672) +++ basis-library/mlton/mlton.sml (working copy) @@ -149,8 +149,29 @@ end val _ = - (Primitive.TopLevel.setHandler MLtonExn.defaultTopLevelHandler - ; Primitive.TopLevel.setSuffix Exit.defaultTopLevelSuffix) + let + open Primitive.TopLevel + open MLtonPlatform.Format + + fun librarySuffix () = + let + open Cleaner + val () = MLtonThread.libraryReturnToC () + val () = clean atExit + val () = MLtonThread.libraryReturnToC () + in + () + end + + val suffix = + case host of + Archive => librarySuffix + | Executable => Exit.defaultTopLevelSuffix + | Library => librarySuffix + in + setHandler MLtonExn.defaultTopLevelHandler + ; setSuffix suffix + end end (* Patch OS.FileSys.tmpName to use mkstemp. *) Index: basis-library/mlton/thread.sig =================================================================== --- basis-library/mlton/thread.sig (revision 6672) +++ basis-library/mlton/thread.sig (working copy) @@ -62,6 +62,7 @@ include MLTON_THREAD val amInSignalHandler: unit -> bool + val libraryReturnToC: unit -> unit val register: int * (MLtonPointer.t -> unit) -> unit val setSignalHandler: (Runnable.t -> Runnable.t) -> unit val switchToSignalHandler: unit -> unit Index: basis-library/mlton/thread.sml =================================================================== --- basis-library/mlton/thread.sml (revision 6672) +++ basis-library/mlton/thread.sml (working copy) @@ -263,4 +263,15 @@ end end + (* Returning to C ends the life of a thread (it cannot be resumed). + * So we create a thread, save the main thread and switch to the new thread. + * The library main loop pops the saved thread after execution. + *) + fun libraryReturnToC () = + let + val doomed = toPrimitive (new Prim.returnToC) + val () = Prim.setSaved (gcState, Prim.current gcState) + in + Prim.switchTo doomed + end end Index: basis-library/primitive/prim-mlton.sml =================================================================== --- basis-library/primitive/prim-mlton.sml (revision 6672) +++ basis-library/primitive/prim-mlton.sml (working copy) @@ -183,6 +183,21 @@ val hostIsBigEndian = _const "MLton_Platform_Arch_bigendian": bool; end + structure Format = + struct + datatype t = + Archive + | Executable + | Library + + val host: t = + case _build_const "MLton_Platform_Format": String8.string; of + "archive" => Archive + | "executable" => Executable + | "library" => Library + | _ => raise Primitive.Exn.Fail8 "strange MLton_Platform_Format" + end + structure OS = struct datatype t = Index: doc/changelog =================================================================== --- doc/changelog (revision 6672) +++ doc/changelog (working copy) @@ -1,5 +1,15 @@ Here are the changes from version 20070826 to version YYYYMMDD. +* 2008-07-24 + - Added support for compiling to a C library. The relevant new compiler + options are '-ar' and '-format'. Libraries are named based on the + name of the -export-header file. Libraries have two extra methods: + * NAME_open(argc, argv) initializes the library and runs the SML code + until it reaches the end of the program. If the SML code exits or + raises an uncaught exception, the entire program will terminate. + * NAME_close() will execute any registered atExit functions, any + outstanding finalizers, and frees the ML heap. + * 2008-07-16 - Fixed bug in the name mangling of _import-ed functions with the stdcall convention. Index: bin/mlton-script =================================================================== --- bin/mlton-script (revision 6672) +++ bin/mlton-script (working copy) @@ -85,7 +85,7 @@ -cc-opt-quote "-I$lib/include" \ -cc-opt '-O1' \ -cc-opt '-fno-strict-aliasing -fomit-frame-pointer -w' \ - -link-opt '-lgdtoa -lm -lgmp' \ + -link-opt '-lm -lgmp' \ -mlb-path-map "$lib/mlb-path-map" \ -target-as-opt amd64 '-m64' \ -target-cc-opt amd64 '-m64' \