Replace mkDerivedConstants.c with DeriveConstants.hs
authorIan Lynagh <ian@well-typed.com>
Sat, 10 Nov 2012 23:28:58 +0000 (23:28 +0000)
committerIan Lynagh <ian@well-typed.com>
Mon, 12 Nov 2012 22:37:55 +0000 (22:37 +0000)
DeriveConstants.hs works in a cross-compilation-friendly way. Rather
than running a C program that prints out the constants, we just compile
a C file which has the constants are encoded in symbol sizes. We then
parse the output of 'nm' to find out what the constants are.

Based on work by Gabor Greif <ggreif@gmail.com>.

compiler/ghc.mk
compiler/main/DynFlags.hs
ghc.mk
includes/ghc.mk
includes/mkDerivedConstants.c [deleted file]
includes/mkDerivedConstants.cross.awk [deleted file]
includes/mkSizeMacros.cross.awk [deleted file]
utils/deriveConstants/DeriveConstants.hs [new file with mode: 0644]
utils/deriveConstants/Makefile [new file with mode: 0644]
utils/deriveConstants/ghc.mk [new file with mode: 0644]

index 07e185f..f3b4fea 100644 (file)
@@ -28,6 +28,16 @@ ifneq "$(BINDIST)" "YES"
 compiler/stage1/package-data.mk : compiler/stage1/build/Config.hs
 compiler/stage2/package-data.mk : compiler/stage2/build/Config.hs
 compiler/stage3/package-data.mk : compiler/stage3/build/Config.hs
+
+compiler/stage1/build/DynFlags.o: $(includes_GHCCONSTANTS_HASKELL_TYPE)
+compiler/stage2/build/DynFlags.o: $(includes_GHCCONSTANTS_HASKELL_TYPE)
+compiler/stage3/build/DynFlags.o: $(includes_GHCCONSTANTS_HASKELL_TYPE)
+compiler/stage1/build/DynFlags.o: $(includes_GHCCONSTANTS_HASKELL_EXPORTS)
+compiler/stage2/build/DynFlags.o: $(includes_GHCCONSTANTS_HASKELL_EXPORTS)
+compiler/stage3/build/DynFlags.o: $(includes_GHCCONSTANTS_HASKELL_EXPORTS)
+compiler/stage1/build/DynFlags.o: $(includes_GHCCONSTANTS_HASKELL_WRAPPERS)
+compiler/stage2/build/DynFlags.o: $(includes_GHCCONSTANTS_HASKELL_WRAPPERS)
+compiler/stage3/build/DynFlags.o: $(includes_GHCCONSTANTS_HASKELL_WRAPPERS)
 endif
 
 compiler/stage%/build/Config.hs : mk/config.mk mk/project.mk | $$(dir $$@)/.
index 07ebd40..1bb3966 100644 (file)
@@ -1248,7 +1248,7 @@ defaultDynFlags mySettings =
       }
 
 defaultWays :: Settings -> [Way]
-defaultWays settings = if pc_dYNAMIC_BY_DEFAULT (sPlatformConstants settings)
+defaultWays settings = if pc_DYNAMIC_BY_DEFAULT (sPlatformConstants settings)
                        then [WayDyn]
                        else []
 
@@ -2571,7 +2571,7 @@ defaultFlags settings
 
     ++ default_PIC platform
 
-    ++ (if pc_dYNAMIC_BY_DEFAULT (sPlatformConstants settings)
+    ++ (if pc_DYNAMIC_BY_DEFAULT (sPlatformConstants settings)
         then wayGeneralFlags platform WayDyn
         else [Opt_Static])
 
diff --git a/ghc.mk b/ghc.mk
index 6c0a29a..2bddaeb 100644 (file)
--- a/ghc.mk
+++ b/ghc.mk
@@ -662,6 +662,7 @@ BUILD_DIRS += \
    $(MAYBE_COMPILER) \
    $(GHC_HSC2HS_DIR) \
    $(GHC_PKG_DIR) \
+   utils/deriveConstants \
    utils/testremove \
    $(MAYBE_GHCTAGS) \
    utils/ghc-pwd \
@@ -1294,6 +1295,7 @@ distclean : clean
        $(call removeFiles,libraries/unix/include/HsUnixConfig.h)
        $(call removeFiles,libraries/old-time/include/HsTimeConfig.h)
        $(call removeTrees,utils/ghc-pwd/dist-boot)
+       $(call removeTrees,includes/dist-derivedconstants)
        $(call removeTrees,inplace)
        $(call removeTrees,$(patsubst %, libraries/%/autom4te.cache, $(PACKAGES_STAGE1) $(PACKAGES_STAGE2)))
 
index 85df1da..ac5200d 100644 (file)
@@ -143,79 +143,45 @@ includes_GHCCONSTANTS_HASKELL_VALUE = includes/dist-derivedconstants/header/plat
 includes_GHCCONSTANTS_HASKELL_WRAPPERS = includes/dist-derivedconstants/header/GHCConstantsHaskellWrappers.hs
 includes_GHCCONSTANTS_HASKELL_EXPORTS = includes/dist-derivedconstants/header/GHCConstantsHaskellExports.hs
 
-INSTALL_LIBS += includes/dist-derivedconstants/header/platformConstants
+INSTALL_LIBS += $(includes_GHCCONSTANTS_HASKELL_VALUE)
 
-ifeq "$(PORTING_HOST)-$(AlienScript)" "YES-"
-
-DerivedConstants.h :
-       @echo "*** Cross-compiling: please copy DerivedConstants.h from the target system"
-       @exit 1
-
-else
-
-includes_dist-derivedconstants_C_SRCS = mkDerivedConstants.c
-includes_dist-derivedconstants_PROG   = mkDerivedConstants$(exeext)
-includes_dist-derivedconstants_INSTALL_INPLACE = YES
-
-$(eval $(call build-prog,includes,dist-derivedconstants,0))
-
-$(includes_dist-derivedconstants_depfile_c_asm) : $(includes_H_CONFIG) $(includes_H_PLATFORM) $(includes_H_FILES) $$(rts_H_FILES)
-includes/dist-derivedconstants/build/mkDerivedConstants.o : $(includes_H_CONFIG) $(includes_H_PLATFORM)
-
-ifneq "$(AlienScript)" ""
-$(INPLACE_BIN)/mkDerivedConstants$(exeext): includes/$(includes_dist-derivedconstants_C_SRCS) | $$(dir $$@)/.
-       $(WhatGccIsCalled) -o $@ $< $(CFLAGS) $(includes_CC_OPTS)
-endif
+DERIVE_CONSTANTS_FLAGS += --gcc-program "$(WhatGccIsCalled)"
+DERIVE_CONSTANTS_FLAGS += $(addprefix --gcc-flag$(space),$(includes_CC_OPTS) -fcommon)
+DERIVE_CONSTANTS_FLAGS += --nm-program "$(NM)"
 
 ifneq "$(BINDIST)" "YES"
-$(includes_DERIVEDCONSTANTS) : $(INPLACE_BIN)/mkDerivedConstants$(exeext) | $$(dir $$@)/.
-ifeq "$(AlienScript)" ""
-       ./$< >$@
-else
-       $(AlienScript) run ./$< >$@
-endif
+$(includes_DERIVEDCONSTANTS):           $$(includes_H_CONFIG) $$(includes_H_PLATFORM) $$(includes_H_FILES) $$(rts_H_FILES)
+$(includes_GHCCONSTANTS_HASKELL_VALUE): $$(includes_H_CONFIG) $$(includes_H_PLATFORM) $$(includes_H_FILES) $$(rts_H_FILES)
 
-$(includes_GHCCONSTANTS_HASKELL_TYPE) : $(INPLACE_BIN)/mkDerivedConstants$(exeext) | $$(dir $$@)/.
-ifeq "$(AlienScript)" ""
-       ./$< --gen-haskell-type >$@
-else
-       $(AlienScript) run ./$< --gen-haskell-type >$@
-endif
+$(includes_DERIVEDCONSTANTS): $(INPLACE_BIN)/deriveConstants$(exeext) | $$(dir $$@)/.
+       $< --gen-header -o $@ --tmpdir $(dir $@) $(DERIVE_CONSTANTS_FLAGS)
 
-$(includes_GHCCONSTANTS_HASKELL_VALUE) : $(INPLACE_BIN)/mkDerivedConstants$(exeext) | $$(dir $$@)/.
-ifeq "$(AlienScript)" ""
-       ./$< --gen-haskell-value >$@
-else
-       $(AlienScript) run ./$< --gen-haskell-value >$@
-endif
+$(includes_GHCCONSTANTS_HASKELL_TYPE): $(INPLACE_BIN)/deriveConstants$(exeext) | $$(dir $$@)/.
+       $< --gen-haskell-type -o $@ --tmpdir $(dir $@) $(DERIVE_CONSTANTS_FLAGS)
 
-$(includes_GHCCONSTANTS_HASKELL_WRAPPERS) : $(INPLACE_BIN)/mkDerivedConstants$(exeext) | $$(dir $$@)/.
-ifeq "$(AlienScript)" ""
-       ./$< --gen-haskell-wrappers >$@
-else
-       $(AlienScript) run ./$< --gen-haskell-wrappers >$@
-endif
+$(includes_GHCCONSTANTS_HASKELL_VALUE): $(INPLACE_BIN)/deriveConstants$(exeext) | $$(dir $$@)/.
+       $< --gen-haskell-value -o $@ --tmpdir $(dir $@) $(DERIVE_CONSTANTS_FLAGS)
 
-$(includes_GHCCONSTANTS_HASKELL_EXPORTS) : $(INPLACE_BIN)/mkDerivedConstants$(exeext) | $$(dir $$@)/.
-ifeq "$(AlienScript)" ""
-       ./$< --gen-haskell-exports >$@
-else
-       $(AlienScript) run ./$< --gen-haskell-exports >$@
-endif
-endif
+$(includes_GHCCONSTANTS_HASKELL_WRAPPERS): $(INPLACE_BIN)/deriveConstants$(exeext) | $$(dir $$@)/.
+       $< --gen-haskell-wrappers -o $@ --tmpdir $(dir $@) $(DERIVE_CONSTANTS_FLAGS)
 
+$(includes_GHCCONSTANTS_HASKELL_EXPORTS): $(INPLACE_BIN)/deriveConstants$(exeext) | $$(dir $$@)/.
+       $< --gen-haskell-exports -o $@ --tmpdir $(dir $@) $(DERIVE_CONSTANTS_FLAGS)
 endif
 
 # ---------------------------------------------------------------------------
 # Install all header files
 
 $(eval $(call clean-target,includes,,\
-  $(includes_H_CONFIG) $(includes_H_PLATFORM) \
-  $(includes_GHCCONSTANTS_HASKELL_TYPE) $(includes_GHCCONSTANTS_HASKELL_VALUE) $(includes_DERIVEDCONSTANTS)))
+  $(includes_H_CONFIG) $(includes_H_PLATFORM)))
 
 $(eval $(call all-target,includes,,\
   $(includes_H_CONFIG) $(includes_H_PLATFORM) \
-  $(includes_GHCCONSTANTS_HASKELL_TYPE) $(includes_GHCCONSTANTS_HASKELL_VALUE) $(includes_DERIVEDCONSTANTS)))
+  $(includes_GHCCONSTANTS_HASKELL_TYPE) \
+  $(includes_GHCCONSTANTS_HASKELL_VALUE) \
+  $(includes_GHCCONSTANTS_HASKELL_WRAPPERS) \
+  $(includes_GHCCONSTANTS_HASKELL_EXPORTS) \
+  $(includes_DERIVEDCONSTANTS)))
 
 install: install_includes
 
diff --git a/includes/mkDerivedConstants.c b/includes/mkDerivedConstants.c
deleted file mode 100644 (file)
index dedb386..0000000
+++ /dev/null
@@ -1,829 +0,0 @@
-/* --------------------------------------------------------------------------
- *
- * (c) The GHC Team, 1992-2012
- *
- * mkDerivedConstants.c
- *
- * Basically this is a C program that extracts information from the C
- * declarations in the header files (primarily struct field offsets)
- * and generates a header file that can be #included into non-C source
- * containing this information.
- *
- * ------------------------------------------------------------------------*/
-
-#define IN_STG_CODE 0
-
-/*
- * We need offsets of profiled things... better be careful that this
- * doesn't affect the offsets of anything else.
- */
-
-#define PROFILING
-#define THREADED_RTS
-
-#include "PosixSource.h"
-#include "Rts.h"
-#include "Stable.h"
-#include "Capability.h"
-
-#include <inttypes.h>
-#include <stdio.h>
-#include <string.h>
-
-#if !defined(PRIdPTR)
-#if SIZEOF_VOID_P == SIZEOF_INT
-/* compiling for 32bit target */
-#define PRIdPTR "d"
-#elif SIZEOF_VOID_P == SIZEOF_LONG
-/* compiling for 64bit target */
-#define PRIdPTR "ld"
-#else
-#error Cannot find definition for PRIdPTR
-#endif
-#endif
-
-enum Mode { Gen_Haskell_Type, Gen_Haskell_Value, Gen_Haskell_Wrappers, Gen_Haskell_Exports, Gen_Header } mode;
-
-#define str(a,b) #a "_" #b
-
-#define OFFSET(s_type, field) ((size_t)&(((s_type*)0)->field))
-#define FIELD_SIZE(s_type, field) ((size_t)sizeof(((s_type*)0)->field))
-#define TYPE_SIZE(type) (sizeof(type))
-
-#pragma GCC poison sizeof
-
-#define def_offset(str, offset)                                             \
-    switch (mode) {                                                         \
-    case Gen_Haskell_Type:                                                  \
-        printf("    , pc_OFFSET_" str " :: Int\n");                         \
-        break;                                                              \
-    case Gen_Haskell_Value:                                                 \
-        printf("    , pc_OFFSET_" str " = %" PRIdPTR "\n", (intptr_t)(offset)); \
-        break;                                                              \
-    case Gen_Haskell_Wrappers:                                              \
-        printf("oFFSET_" str " :: DynFlags -> Int\n");                      \
-        printf("oFFSET_" str " dflags = pc_OFFSET_" str " (sPlatformConstants (settings dflags))\n"); \
-        break;                                                              \
-    case Gen_Haskell_Exports:                                               \
-        printf("    oFFSET_" str ",\n");                                    \
-        break;                                                              \
-    case Gen_Header:                                                        \
-        printf("#define OFFSET_" str " %" PRIdPTR "\n", (intptr_t)(offset));  \
-        break;                                                              \
-    }
-
-#define ctype(type)                                                         \
-    switch (mode) {                                                         \
-    case Gen_Haskell_Type:                                                  \
-    case Gen_Haskell_Value:                                                 \
-    case Gen_Haskell_Wrappers:                                              \
-    case Gen_Haskell_Exports:                                               \
-        break;                                                              \
-    case Gen_Header:                                                        \
-        printf("#define SIZEOF_" #type " %" FMT_SizeT "\n",                 \
-               (size_t)TYPE_SIZE(type));                                    \
-        break;                                                              \
-    }
-
-/* Defining REP_x to be b32 etc
-   These are both the C-- types used in a load
-      e.g.  b32[addr]
-   and the names of the CmmTypes in the compiler
-      b32 :: CmmType
-*/
-#define field_type_(want_haskell, str, s_type, field)                       \
-    switch (mode) {                                                         \
-    case Gen_Haskell_Type:                                                  \
-        if (want_haskell) {                                                 \
-            printf("    , pc_REP_" str " :: Int\n");                        \
-            break;                                                          \
-        }                                                                   \
-    case Gen_Haskell_Value:                                                 \
-        if (want_haskell) {                                                 \
-            printf("    , pc_REP_" str " = %" PRIdPTR "\n", (intptr_t)(FIELD_SIZE(s_type, field))); \
-            break;                                                          \
-        }                                                                   \
-    case Gen_Haskell_Wrappers:                                              \
-    case Gen_Haskell_Exports:                                               \
-        break;                                                              \
-    case Gen_Header:                                                        \
-        printf("#define REP_" str " b");                                    \
-        printf("%" FMT_SizeT "\n", FIELD_SIZE(s_type, field) * 8);          \
-        break;                                                              \
-    }
-
-#define field_type_gcptr_(str, s_type, field)                               \
-    switch (mode) {                                                         \
-    case Gen_Haskell_Type:                                                  \
-    case Gen_Haskell_Value:                                                 \
-    case Gen_Haskell_Wrappers:                                              \
-    case Gen_Haskell_Exports:                                               \
-        break;                                                              \
-    case Gen_Header:                                                        \
-        printf("#define REP_" str " gcptr\n");                              \
-        break;                                                              \
-    }
-
-#define field_type(want_haskell, s_type, field) \
-    field_type_(want_haskell,str(s_type,field),s_type,field);
-
-#define field_offset_(str, s_type, field) \
-    def_offset(str, OFFSET(s_type,field));
-
-#define field_offset(s_type, field) \
-    field_offset_(str(s_type,field),s_type,field);
-
-/* An access macro for use in C-- sources. */
-#define struct_field_macro(str)                                             \
-    switch (mode) {                                                         \
-    case Gen_Haskell_Type:                                                  \
-    case Gen_Haskell_Value:                                                 \
-    case Gen_Haskell_Wrappers:                                              \
-    case Gen_Haskell_Exports:                                               \
-        break;                                                              \
-    case Gen_Header:                                                        \
-        printf("#define " str "(__ptr__)  REP_" str "[__ptr__+OFFSET_" str "]\n"); \
-        break;                                                              \
-    }
-
-/* Outputs the byte offset and MachRep for a field */
-#define struct_field_helper(want_haskell, s_type, field)    \
-    field_offset(s_type, field);                            \
-    field_type(want_haskell, s_type, field);                \
-    struct_field_macro(str(s_type,field))
-
-#define struct_field(s_type, field)         \
-    struct_field_helper(0, s_type, field)
-
-#define struct_field_h(s_type, field)       \
-    struct_field_helper(1, s_type, field)
-
-#define struct_field_(str, s_type, field)      \
-    field_offset_(str, s_type, field);         \
-    field_type_(0,str, s_type, field);         \
-    struct_field_macro(str)
-
-#define def_size(str, size)                                                 \
-    switch (mode) {                                                         \
-    case Gen_Haskell_Type:                                                  \
-        printf("    , pc_SIZEOF_" str " :: Int\n");                         \
-        break;                                                              \
-    case Gen_Haskell_Value:                                                 \
-        printf("    , pc_SIZEOF_" str " = %" FMT_SizeT "\n", (size_t)size); \
-        break;                                                              \
-    case Gen_Haskell_Wrappers:                                              \
-        printf("sIZEOF_" str " :: DynFlags -> Int\n");                      \
-        printf("sIZEOF_" str " dflags = pc_SIZEOF_" str " (sPlatformConstants (settings dflags))\n"); \
-        break;                                                              \
-    case Gen_Haskell_Exports:                                               \
-        printf("    sIZEOF_" str ",\n");                                    \
-        break;                                                              \
-    case Gen_Header:                                                        \
-        printf("#define SIZEOF_" str " %" FMT_SizeT "\n", (size_t)size);    \
-        break;                                                              \
-    }
-
-#define def_closure_size(str, size)                                         \
-    switch (mode) {                                                         \
-    case Gen_Haskell_Type:                                                  \
-    case Gen_Haskell_Value:                                                 \
-    case Gen_Haskell_Wrappers:                                              \
-    case Gen_Haskell_Exports:                                               \
-        break;                                                              \
-    case Gen_Header:                                                        \
-        printf("#define SIZEOF_" str " (SIZEOF_StgHeader+%" FMT_SizeT ")\n", (size_t)size); \
-        break;                                                              \
-    }
-
-#define struct_size(s_type) \
-    def_size(#s_type, TYPE_SIZE(s_type));
-
-/*
- * Size of a closure type, minus the header, named SIZEOF_<type>_NoHdr
- * Also, we #define SIZEOF_<type> to be the size of the whole closure for .cmm.
- */
-#define closure_size(s_type) \
-    def_size(#s_type "_NoHdr", TYPE_SIZE(s_type) - TYPE_SIZE(StgHeader)); \
-    def_closure_size(#s_type, TYPE_SIZE(s_type) - TYPE_SIZE(StgHeader));
-
-#define thunk_size(s_type) \
-    def_size(#s_type "_NoThunkHdr", TYPE_SIZE(s_type) - TYPE_SIZE(StgThunkHeader)); \
-    closure_size(s_type)
-
-/* An access macro for use in C-- sources. */
-#define closure_field_macro(str)                                            \
-    switch (mode) {                                                         \
-    case Gen_Haskell_Type:                                                  \
-    case Gen_Haskell_Value:                                                 \
-    case Gen_Haskell_Wrappers:                                              \
-    case Gen_Haskell_Exports:                                               \
-        break;                                                              \
-    case Gen_Header:                                                        \
-        printf("#define " str "(__ptr__)  REP_" str "[__ptr__+SIZEOF_StgHeader+OFFSET_" str "]\n"); \
-        break;                                                              \
-    }
-
-#define closure_field_offset_(str, s_type,field) \
-    def_offset(str, OFFSET(s_type,field) - TYPE_SIZE(StgHeader));
-
-#define closure_field_offset(s_type,field) \
-    closure_field_offset_(str(s_type,field),s_type,field)
-
-#define closure_payload_macro(str)                                          \
-    switch (mode) {                                                         \
-    case Gen_Haskell_Type:                                                  \
-    case Gen_Haskell_Value:                                                 \
-    case Gen_Haskell_Wrappers:                                              \
-    case Gen_Haskell_Exports:                                               \
-        break;                                                              \
-    case Gen_Header:                                                        \
-        printf("#define " str "(__ptr__,__ix__)  W_[__ptr__+SIZEOF_StgHeader+OFFSET_" str " + WDS(__ix__)]\n"); \
-        break;                                                              \
-    }
-
-#define closure_payload(s_type,field) \
-    closure_field_offset_(str(s_type,field),s_type,field); \
-    closure_payload_macro(str(s_type,field));
-
-/* Byte offset and MachRep for a closure field, minus the header */
-#define closure_field_(str, s_type, field) \
-    closure_field_offset_(str,s_type,field) \
-    field_type_(0, str, s_type, field); \
-    closure_field_macro(str)
-
-#define closure_field(s_type, field) \
-    closure_field_(str(s_type,field),s_type,field)
-
-/* Byte offset and MachRep for a closure field, minus the header */
-#define closure_field_gcptr_(str, s_type, field) \
-    closure_field_offset_(str,s_type,field) \
-    field_type_gcptr_(str, s_type, field); \
-    closure_field_macro(str)
-
-#define closure_field_gcptr(s_type, field) \
-    closure_field_gcptr_(str(s_type,field),s_type,field)
-
-/* Byte offset for a TSO field, minus the header and variable prof bit. */
-#define tso_payload_offset(s_type, field) \
-    def_offset(str(s_type,field), OFFSET(s_type,field) - TYPE_SIZE(StgHeader) - TYPE_SIZE(StgTSOProfInfo));
-
-/* Full byte offset for a TSO field, for use from Cmm */
-#define tso_field_offset_macro(str)                                         \
-    switch (mode) {                                                         \
-    case Gen_Haskell_Type:                                                  \
-    case Gen_Haskell_Value:                                                 \
-    case Gen_Haskell_Wrappers:                                              \
-    case Gen_Haskell_Exports:                                               \
-        break;                                                              \
-    case Gen_Header:                                                        \
-        printf("#define TSO_OFFSET_" str " (SIZEOF_StgHeader+SIZEOF_OPT_StgTSOProfInfo+OFFSET_" str ")\n"); \
-        break;                                                              \
-    }
-
-#define tso_field_offset(s_type, field) \
-    tso_payload_offset(s_type, field);         \
-    tso_field_offset_macro(str(s_type,field));
-
-#define tso_field_macro(str)                                                \
-    switch (mode) {                                                         \
-    case Gen_Haskell_Type:                                                  \
-    case Gen_Haskell_Value:                                                 \
-    case Gen_Haskell_Wrappers:                                              \
-    case Gen_Haskell_Exports:                                               \
-        break;                                                              \
-    case Gen_Header:                                                        \
-    printf("#define " str "(__ptr__)  REP_" str "[__ptr__+TSO_OFFSET_" str "]\n") \
-        break;                                                              \
-    }
-
-#define tso_field(s_type, field)        \
-    field_type(0, s_type, field);       \
-    tso_field_offset(s_type,field);     \
-    tso_field_macro(str(s_type,field))
-  
-#define opt_struct_size(s_type, option)                                                            \
-    switch (mode) {                                                         \
-    case Gen_Haskell_Type:                                                  \
-    case Gen_Haskell_Value:                                                 \
-    case Gen_Haskell_Wrappers:                                              \
-    case Gen_Haskell_Exports:                                               \
-        break;                                                              \
-    case Gen_Header:                                                        \
-        printf("#ifdef " #option "\n");                                                            \
-        printf("#define SIZEOF_OPT_" #s_type " SIZEOF_" #s_type "\n");     \
-        printf("#else\n");                                                                             \
-        printf("#define SIZEOF_OPT_" #s_type " 0\n");                              \
-        printf("#endif\n\n");                                               \
-        break;                                                              \
-    }
-
-#define FUN_OFFSET(sym) (OFFSET(Capability,f.sym) - OFFSET(Capability,r))
-
-void constantBool(char *haskellName, int val) {
-    switch (mode) {
-    case Gen_Haskell_Type:
-        printf("    , pc_%s :: Bool\n", haskellName);
-        break;
-    case Gen_Haskell_Value:
-        printf("    , pc_%s = %s\n", haskellName, val ? "True" : "False");
-        break;
-    case Gen_Haskell_Wrappers:
-        printf("%s :: DynFlags -> Bool\n", haskellName);
-        printf("%s dflags = pc_%s (sPlatformConstants (settings dflags))\n",
-               haskellName, haskellName);
-        break;
-    case Gen_Haskell_Exports:
-        printf("    %s,\n", haskellName);
-        break;
-    case Gen_Header:
-        break;
-    }
-}
-
-void constantIntegralC(char *haskellType, char *cName, char *haskellName,
-                       intptr_t val) {
-    switch (mode) {
-    case Gen_Haskell_Type:
-        printf("    , pc_%s :: %s\n", haskellName, haskellType);
-        break;
-    case Gen_Haskell_Value:
-        printf("    , pc_%s = %" PRIdPTR "\n", haskellName, val);
-        break;
-    case Gen_Haskell_Wrappers:
-        printf("%s :: DynFlags -> %s\n", haskellName, haskellType);
-        printf("%s dflags = pc_%s (sPlatformConstants (settings dflags))\n",
-               haskellName, haskellName);
-        break;
-    case Gen_Haskell_Exports:
-        printf("    %s,\n", haskellName);
-        break;
-    case Gen_Header:
-        if (cName != NULL) {
-            printf("#define %s %" PRIdPTR "\n", cName, val);
-        }
-        break;
-    }
-}
-
-void constantIntC(char *cName, char *haskellName, intptr_t val) {
-    /* If the value is larger than 2^28 or smaller than -2^28, then fail.
-       This test is a bit conservative, but if any constants are roughly
-       maxBoun or minBound then we probably need them to be Integer
-       rather than Int so that cross-compiling between 32bit and 64bit
-       platforms works. */
-    if (val > 268435456) {
-        printf("Value too large for constantInt: %" PRIdPTR "\n", val);
-        exit(1);
-    }
-    if (val < -268435456) {
-        printf("Value too small for constantInt: %" PRIdPTR "\n", val);
-        exit(1);
-    }
-
-    constantIntegralC("Int", cName, haskellName, val);
-}
-
-void constantInt(char *name, intptr_t val) {
-    constantIntC(NULL, name, val);
-}
-
-void constantInteger(char *name, intptr_t val) {
-    constantIntegralC("Integer", NULL, name, val);
-}
-
-int
-main(int argc, char *argv[])
-{
-    if (argc == 1) {
-        mode = Gen_Header;
-    }
-    else if (argc == 2) {
-        if (0 == strcmp("--gen-haskell-type", argv[1])) {
-            mode = Gen_Haskell_Type;
-        }
-        else if (0 == strcmp("--gen-haskell-value", argv[1])) {
-            mode = Gen_Haskell_Value;
-        }
-        else if (0 == strcmp("--gen-haskell-wrappers", argv[1])) {
-            mode = Gen_Haskell_Wrappers;
-        }
-        else if (0 == strcmp("--gen-haskell-exports", argv[1])) {
-            mode = Gen_Haskell_Exports;
-        }
-        else {
-            printf("Bad args\n");
-            exit(1);
-        }
-    }
-    else {
-        printf("Bad args\n");
-        exit(1);
-    }
-
-    switch (mode) {
-    case Gen_Haskell_Type:
-        printf("data PlatformConstants = PlatformConstants {\n");
-        /* Now a kludge that allows the real entries to all start with a
-           comma, which makes life a little easier */
-        printf("    pc_platformConstants :: ()\n");
-        break;
-    case Gen_Haskell_Value:
-        printf("PlatformConstants {\n");
-        printf("    pc_platformConstants = ()\n");
-        break;
-    case Gen_Haskell_Wrappers:
-    case Gen_Haskell_Exports:
-        break;
-    case Gen_Header:
-        printf("/* This file is created automatically.  Do not edit by hand.*/\n\n");
-
-        break;
-    }
-
-    // Closure header sizes.
-    constantIntC("STD_HDR_SIZE", "sTD_HDR_SIZE",
-                 sizeofW(StgHeader) - sizeofW(StgProfHeader));
-    /* grrr.. PROFILING is on so we need to subtract sizeofW(StgProfHeader) */
-    constantIntC("PROF_HDR_SIZE", "pROF_HDR_SIZE", sizeofW(StgProfHeader));
-
-    // Size of a storage manager block (in bytes).
-    constantIntC("BLOCK_SIZE", "bLOCK_SIZE", BLOCK_SIZE);
-    if (mode == Gen_Header) {
-        constantIntC("MBLOCK_SIZE", "mBLOCK_SIZE", MBLOCK_SIZE);
-    }
-    // blocks that fit in an MBlock, leaving space for the block descriptors
-    constantIntC("BLOCKS_PER_MBLOCK", "bLOCKS_PER_MBLOCK", BLOCKS_PER_MBLOCK);
-    // could be derived, but better to save doing the calculation twice
-
-
-    field_offset(StgRegTable, rR1);
-    field_offset(StgRegTable, rR2);
-    field_offset(StgRegTable, rR3);
-    field_offset(StgRegTable, rR4);
-    field_offset(StgRegTable, rR5);
-    field_offset(StgRegTable, rR6);
-    field_offset(StgRegTable, rR7);
-    field_offset(StgRegTable, rR8);
-    field_offset(StgRegTable, rR9);
-    field_offset(StgRegTable, rR10);
-    field_offset(StgRegTable, rF1);
-    field_offset(StgRegTable, rF2);
-    field_offset(StgRegTable, rF3);
-    field_offset(StgRegTable, rF4);
-    field_offset(StgRegTable, rF5);
-    field_offset(StgRegTable, rF6);
-    field_offset(StgRegTable, rD1);
-    field_offset(StgRegTable, rD2);
-    field_offset(StgRegTable, rD3);
-    field_offset(StgRegTable, rD4);
-    field_offset(StgRegTable, rD5);
-    field_offset(StgRegTable, rD6);
-    field_offset(StgRegTable, rL1);
-    field_offset(StgRegTable, rSp);
-    field_offset(StgRegTable, rSpLim);
-    field_offset(StgRegTable, rHp);
-    field_offset(StgRegTable, rHpLim);
-    field_offset(StgRegTable, rCCCS);
-    field_offset(StgRegTable, rCurrentTSO);
-    field_offset(StgRegTable, rCurrentNursery);
-    field_offset(StgRegTable, rHpAlloc);
-    if (mode == Gen_Header) {
-        struct_field(StgRegTable, rRet);
-        struct_field(StgRegTable, rNursery);
-    }
-
-    def_offset("stgEagerBlackholeInfo", FUN_OFFSET(stgEagerBlackholeInfo));
-    def_offset("stgGCEnter1", FUN_OFFSET(stgGCEnter1));
-    def_offset("stgGCFun", FUN_OFFSET(stgGCFun));
-
-    field_offset(Capability, r);
-    if (mode == Gen_Header) {
-        field_offset(Capability, lock);
-        struct_field(Capability, no);
-        struct_field(Capability, mut_lists);
-        struct_field(Capability, context_switch);
-        struct_field(Capability, interrupt);
-        struct_field(Capability, sparks);
-    }
-
-    struct_field(bdescr, start);
-    struct_field(bdescr, free);
-    struct_field(bdescr, blocks);
-    if (mode == Gen_Header) {
-        struct_field(bdescr, gen_no);
-        struct_field(bdescr, link);
-
-        struct_size(generation);
-        struct_field(generation, n_new_large_words);
-    }
-
-    struct_size(CostCentreStack);
-    if (mode == Gen_Header) {
-        struct_field(CostCentreStack, ccsID);
-    }
-    struct_field_h(CostCentreStack, mem_alloc);
-    struct_field_h(CostCentreStack, scc_count);
-    if (mode == Gen_Header) {
-        struct_field(CostCentreStack, prevStack);
-
-        struct_field(CostCentre, ccID);
-        struct_field(CostCentre, link);
-
-        struct_field(StgHeader, info);
-    }
-    struct_field_("StgHeader_ccs",  StgHeader, prof.ccs);
-    struct_field_("StgHeader_ldvw", StgHeader, prof.hp.ldvw);
-
-    struct_size(StgSMPThunkHeader);
-
-    if (mode == Gen_Header) {
-        closure_payload(StgClosure,payload);
-    }
-
-    struct_field_h(StgEntCounter, allocs);
-    struct_field(StgEntCounter, registeredp);
-    struct_field(StgEntCounter, link);
-    struct_field(StgEntCounter, entry_count);
-
-    closure_size(StgUpdateFrame);
-    if (mode == Gen_Header) {
-        closure_size(StgCatchFrame);
-        closure_size(StgStopFrame);
-    }
-
-    closure_size(StgMutArrPtrs);
-    closure_field(StgMutArrPtrs, ptrs);
-    closure_field(StgMutArrPtrs, size);
-
-    closure_size(StgArrWords);
-    if (mode == Gen_Header) {
-        closure_field(StgArrWords, bytes);
-        closure_payload(StgArrWords, payload);
-
-        closure_field(StgTSO, _link);
-        closure_field(StgTSO, global_link);
-        closure_field(StgTSO, what_next);
-        closure_field(StgTSO, why_blocked);
-        closure_field(StgTSO, block_info);
-        closure_field(StgTSO, blocked_exceptions);
-        closure_field(StgTSO, id);
-        closure_field(StgTSO, cap);
-        closure_field(StgTSO, saved_errno);
-        closure_field(StgTSO, trec);
-        closure_field(StgTSO, flags);
-        closure_field(StgTSO, dirty);
-        closure_field(StgTSO, bq);
-    }
-    closure_field_("StgTSO_cccs", StgTSO, prof.cccs);
-    closure_field(StgTSO, stackobj);
-
-    closure_field(StgStack, sp);
-    closure_field_offset(StgStack, stack);
-    if (mode == Gen_Header) {
-    closure_field(StgStack, stack_size);
-        closure_field(StgStack, dirty);
-
-        struct_size(StgTSOProfInfo);
-
-        opt_struct_size(StgTSOProfInfo,PROFILING);
-    }
-
-    closure_field(StgUpdateFrame, updatee);
-
-    if (mode == Gen_Header) {
-        closure_field(StgCatchFrame, handler);
-        closure_field(StgCatchFrame, exceptions_blocked);
-
-        closure_size(StgPAP);
-        closure_field(StgPAP, n_args);
-        closure_field_gcptr(StgPAP, fun);
-        closure_field(StgPAP, arity);
-        closure_payload(StgPAP, payload);
-
-        thunk_size(StgAP);
-        closure_field(StgAP, n_args);
-        closure_field_gcptr(StgAP, fun);
-        closure_payload(StgAP, payload);
-
-        thunk_size(StgAP_STACK);
-        closure_field(StgAP_STACK, size);
-        closure_field_gcptr(StgAP_STACK, fun);
-        closure_payload(StgAP_STACK, payload);
-
-        thunk_size(StgSelector);
-
-        closure_field_gcptr(StgInd, indirectee);
-
-        closure_size(StgMutVar);
-        closure_field(StgMutVar, var);
-
-        closure_size(StgAtomicallyFrame);
-        closure_field(StgAtomicallyFrame, code);
-        closure_field(StgAtomicallyFrame, next_invariant_to_check);
-        closure_field(StgAtomicallyFrame, result);
-
-        closure_field(StgInvariantCheckQueue, invariant);
-        closure_field(StgInvariantCheckQueue, my_execution);
-        closure_field(StgInvariantCheckQueue, next_queue_entry);
-
-        closure_field(StgAtomicInvariant, code);
-
-        closure_field(StgTRecHeader, enclosing_trec);
-
-        closure_size(StgCatchSTMFrame);
-        closure_field(StgCatchSTMFrame, handler);
-        closure_field(StgCatchSTMFrame, code);
-
-        closure_size(StgCatchRetryFrame);
-        closure_field(StgCatchRetryFrame, running_alt_code);
-        closure_field(StgCatchRetryFrame, first_code);
-        closure_field(StgCatchRetryFrame, alt_code);
-
-        closure_field(StgTVarWatchQueue, closure);
-        closure_field(StgTVarWatchQueue, next_queue_entry);
-        closure_field(StgTVarWatchQueue, prev_queue_entry);
-
-        closure_size(StgTVar);
-        closure_field(StgTVar, current_value);
-        closure_field(StgTVar, first_watch_queue_entry);
-        closure_field(StgTVar, num_updates);
-
-        closure_size(StgWeak);
-        closure_field(StgWeak,link);
-        closure_field(StgWeak,key);
-        closure_field(StgWeak,value);
-        closure_field(StgWeak,finalizer);
-        closure_field(StgWeak,cfinalizer);
-
-        closure_size(StgDeadWeak);
-        closure_field(StgDeadWeak,link);
-
-        closure_size(StgMVar);
-        closure_field(StgMVar,head);
-        closure_field(StgMVar,tail);
-        closure_field(StgMVar,value);
-
-        closure_size(StgMVarTSOQueue);
-        closure_field(StgMVarTSOQueue, link);
-        closure_field(StgMVarTSOQueue, tso);
-
-        closure_size(StgBCO);
-        closure_field(StgBCO, instrs);
-        closure_field(StgBCO, literals);
-        closure_field(StgBCO, ptrs);
-        closure_field(StgBCO, arity);
-        closure_field(StgBCO, size);
-        closure_payload(StgBCO, bitmap);
-
-        closure_size(StgStableName);
-        closure_field(StgStableName,sn);
-
-        closure_size(StgBlockingQueue);
-        closure_field(StgBlockingQueue, bh);
-        closure_field(StgBlockingQueue, owner);
-        closure_field(StgBlockingQueue, queue);
-        closure_field(StgBlockingQueue, link);
-
-        closure_size(MessageBlackHole);
-        closure_field(MessageBlackHole, link);
-        closure_field(MessageBlackHole, tso);
-        closure_field(MessageBlackHole, bh);
-
-        struct_field_("RtsFlags_ProfFlags_showCCSOnException",
-                     RTS_FLAGS, ProfFlags.showCCSOnException);
-        struct_field_("RtsFlags_DebugFlags_apply",
-                     RTS_FLAGS, DebugFlags.apply);
-        struct_field_("RtsFlags_DebugFlags_sanity",
-                     RTS_FLAGS, DebugFlags.sanity);
-        struct_field_("RtsFlags_DebugFlags_weak",
-                     RTS_FLAGS, DebugFlags.weak);
-        struct_field_("RtsFlags_GcFlags_initialStkSize",
-                     RTS_FLAGS, GcFlags.initialStkSize);
-        struct_field_("RtsFlags_MiscFlags_tickInterval",
-                     RTS_FLAGS, MiscFlags.tickInterval);
-
-        struct_size(StgFunInfoExtraFwd);
-        struct_field(StgFunInfoExtraFwd, slow_apply);
-        struct_field(StgFunInfoExtraFwd, fun_type);
-        struct_field(StgFunInfoExtraFwd, arity);
-        struct_field_("StgFunInfoExtraFwd_bitmap", StgFunInfoExtraFwd, b.bitmap);
-    }
-
-    struct_size(StgFunInfoExtraRev);
-    if (mode == Gen_Header) {
-        struct_field(StgFunInfoExtraRev, slow_apply_offset);
-        struct_field(StgFunInfoExtraRev, fun_type);
-        struct_field(StgFunInfoExtraRev, arity);
-        struct_field_("StgFunInfoExtraRev_bitmap", StgFunInfoExtraRev, b.bitmap);
-
-        struct_field(StgLargeBitmap, size);
-        field_offset(StgLargeBitmap, bitmap);
-
-        struct_size(snEntry);
-        struct_field(snEntry,sn_obj);
-        struct_field(snEntry,addr);
-    }
-
-#ifdef mingw32_HOST_OS
-    /* Note that this conditional part only affects the C headers.
-       That's important, as it means we get the same PlatformConstants
-       type on all platforms. */
-    if (mode == Gen_Header) {
-        struct_size(StgAsyncIOResult);
-        struct_field(StgAsyncIOResult, reqID);
-        struct_field(StgAsyncIOResult, len);
-        struct_field(StgAsyncIOResult, errCode);
-    }
-#endif
-
-    // pre-compiled thunk types
-    constantInt("mAX_SPEC_SELECTEE_SIZE", MAX_SPEC_SELECTEE_SIZE);
-    constantInt("mAX_SPEC_AP_SIZE", MAX_SPEC_AP_SIZE);
-
-    // closure sizes: these do NOT include the header (see below for
-    // header sizes)
-    constantInt("mIN_PAYLOAD_SIZE", MIN_PAYLOAD_SIZE);
-
-    constantInt("mIN_INTLIKE", MIN_INTLIKE);
-    constantInt("mAX_INTLIKE", MAX_INTLIKE);
-
-    constantInt("mIN_CHARLIKE", MIN_CHARLIKE);
-    constantInt("mAX_CHARLIKE", MAX_CHARLIKE);
-
-    constantInt("mUT_ARR_PTRS_CARD_BITS", MUT_ARR_PTRS_CARD_BITS);
-
-    // A section of code-generator-related MAGIC CONSTANTS.
-    constantInt("mAX_Vanilla_REG",      MAX_VANILLA_REG);
-    constantInt("mAX_Float_REG",        MAX_FLOAT_REG);
-    constantInt("mAX_Double_REG",       MAX_DOUBLE_REG);
-    constantInt("mAX_Long_REG",         MAX_LONG_REG);
-    constantInt("mAX_SSE_REG",          MAX_SSE_REG);
-    constantInt("mAX_Real_Vanilla_REG", MAX_REAL_VANILLA_REG);
-    constantInt("mAX_Real_Float_REG",   MAX_REAL_FLOAT_REG);
-    constantInt("mAX_Real_Double_REG",  MAX_REAL_DOUBLE_REG);
-    constantInt("mAX_Real_SSE_REG",     MAX_REAL_SSE_REG);
-    constantInt("mAX_Real_Long_REG",    MAX_REAL_LONG_REG);
-
-    // This tells the native code generator the size of the spill
-    // area is has available.
-    constantInt("rESERVED_C_STACK_BYTES", RESERVED_C_STACK_BYTES);
-    // The amount of (Haskell) stack to leave free for saving registers when
-    // returning to the scheduler.
-    constantInt("rESERVED_STACK_WORDS", RESERVED_STACK_WORDS);
-    // Continuations that need more than this amount of stack should do their
-    // own stack check (see bug #1466).
-    constantInt("aP_STACK_SPLIM", AP_STACK_SPLIM);
-
-    // Size of a word, in bytes
-    constantInt("wORD_SIZE", SIZEOF_HSWORD);
-
-    // Size of a double in StgWords.
-    constantInt("dOUBLE_SIZE", SIZEOF_DOUBLE);
-
-    // Size of a C int, in bytes. May be smaller than wORD_SIZE.
-    constantInt("cINT_SIZE", SIZEOF_INT);
-    constantInt("cLONG_SIZE", SIZEOF_LONG);
-    constantInt("cLONG_LONG_SIZE", SIZEOF_LONG_LONG);
-
-    // Number of bits to shift a bitfield left by in an info table.
-    constantInt("bITMAP_BITS_SHIFT", BITMAP_BITS_SHIFT);
-
-    // Amount of pointer bits used for semi-tagging constructor closures
-    constantInt("tAG_BITS", TAG_BITS);
-
-    constantBool("wORDS_BIGENDIAN",
-#ifdef WORDS_BIGENDIAN
-                                    1
-#else
-                                    0
-#endif
-                                         );
-
-    constantBool("dYNAMIC_BY_DEFAULT",
-#ifdef DYNAMIC_BY_DEFAULT
-                                       1
-#else
-                                       0
-#endif
-                                         );
-
-    constantInt("lDV_SHIFT", LDV_SHIFT);
-    constantInteger("iLDV_CREATE_MASK",  LDV_CREATE_MASK);
-    constantInteger("iLDV_STATE_CREATE", LDV_STATE_CREATE);
-    constantInteger("iLDV_STATE_USE",    LDV_STATE_USE);
-
-    switch (mode) {
-    case Gen_Haskell_Type:
-        printf("  } deriving Read\n");
-        break;
-    case Gen_Haskell_Value:
-        printf("  }\n");
-        break;
-    case Gen_Haskell_Wrappers:
-    case Gen_Haskell_Exports:
-    case Gen_Header:
-        break;
-    }
-
-    return 0;
-}
diff --git a/includes/mkDerivedConstants.cross.awk b/includes/mkDerivedConstants.cross.awk
deleted file mode 100644 (file)
index c66655e..0000000
+++ /dev/null
@@ -1,350 +0,0 @@
-## This script rewrites normal C structs into successively
-## greater ones so that field offset computation becomes a
-## sizeof lookup and thus amenable to compile-time computations.
-
-## Usage: pipe stg/Regs.h into 'awk' running this script
-##        to obtain a .c file that can be compiled to .o
-##        with the gcc from the cross toolchain. Then
-##        use another 'awk' script to process the 'nm'
-##        output of the object file.
-
-## Motivation: since in general we can not run executables
-##             created by the cross toolchain, we need another
-##             way of finding out field offsets and type sizes
-##             of the target platform.
-
-BEGIN {
-  interesting = 0
-  seed = 0
-  print "/* this file is generated by mkDerivedConstants.cross.awk, do not touch */"
-  print "/* needs to be compiled with the target gcc */"
-  print ""
-  print "#include \"Rts.h\""
-  print "#include \"Capability.h\""
-  print ""
-  ## these do not have a proper typedef; supply them here
-  print "#define FLAG_STRUCT_TYPE(IT) typedef struct IT ## _FLAGS IT ## _FLAGS"
-  print "FLAG_STRUCT_TYPE(GC);"
-  print "FLAG_STRUCT_TYPE(DEBUG);"
-  print "FLAG_STRUCT_TYPE(COST_CENTRE);"
-  print "FLAG_STRUCT_TYPE(PROFILING);"
-  print "FLAG_STRUCT_TYPE(TRACE);"
-  print "FLAG_STRUCT_TYPE(CONCURRENT);"
-  print "FLAG_STRUCT_TYPE(MISC);"
-  print "FLAG_STRUCT_TYPE(PAR);"
-  print "FLAG_STRUCT_TYPE(TICKY);"
-  ## these we do know how to get the field size,
-  ## so do not bother mining it
-  print "#define DO_NOT_MINE_UNION_MEMBER(STRUCT, NESTED_MEMBER, ID) char nestedfieldsize$ ## STRUCT ## $ ## ID [sizeof ((STRUCT*)0)->NESTED_MEMBER]"
-  print "DO_NOT_MINE_UNION_MEMBER(StgHeader, prof.hp.ldvw, prof_hp_ldvw);"
-  print "DO_NOT_MINE_UNION_MEMBER(StgFunInfoExtraFwd, b.bitmap, b_bitmap);"
-  print "DO_NOT_MINE_UNION_MEMBER(StgFunInfoExtraRev, b.bitmap, b_bitmap);"
-}
-
-## pass through embedded unions
-eat_union && /^[ \t]*}[ \t]*[_0-9a-zA-Z][_0-9a-zA-Z]*[ \t]*;[ \t]*$/ {
-  sub(/^[ \t]*}[ \t]*/, "")
-  sub(/[ \t]*;[ \t]*$/, "")
-  new_offset_struct_name = struct_name $0
-  print ""
-
-  eat_union = 0
-
-  if (!offset_struct_name)
-  {
-    print "char starting" new_offset_struct_name "[2];"
-  }
-  else
-  {
-    assumptions = assumptions "\n" "char sizeof" new_offset_struct_name "[offsetof(^^^, " $0 ")];"
-    assumptions = assumptions "\n" "typedef char verify_size" new_offset_struct_name "[sizeof sizeof" new_offset_struct_name " == offsetof(^^^, " $0 ") ? 1 : -1];"
-  }
-
-  offset_struct_name = new_offset_struct_name
-  next
-}
-
-eat_union {
-  next
-}
-
-/# [0-9]* "rts\// {
-  ours = 1
-  next
-}
-
-/# [0-9]* "includes\// {
-  ours = 1
-  next
-}
-
-## filter out non-ghc headers
-/# [0-9]* "/ {
-  ours = 0
-  next
-}
-
-!ours {
-  next
-}
-
-!interesting {
-  struct_name = "$" seed "$"
-  offset_struct_name = ""
-  known_struct_name = ""
-  eat_union = 0
-  assumptions = ""
-}
-
-## kill empty line
-/^[ \t]*$/ {
-  next
-}
-
-/^# [0-9]/ {
-  print
-  next
-}
-
-/^typedef struct[ \t][ \t]*[_0-9a-zA-Z]*[ \t]*{[ \t]*$/ {
-  if (interesting) error "previous struct not closed?"
-  interesting = 1
-  print ""
-  print "/* ### Creating offset structs for " $3 " ### */"
-  next
-}
-
-/^struct[ \t][ \t]*[_0-9a-zA-Z]*[ \t]*{[ \t]*$/ {
-  if (interesting) error "previous struct not closed?"
-  interesting = 1
-  known_struct_name = $2
-  sub(/_$/, "", known_struct_name);
-  print ""
-  print "/* ### Creating offset structs for " known_struct_name " ### */"
-  print "char associate$" known_struct_name "$" seed ";"
-  next
-}
-
-## end of struct
-##
-interesting && /^[ \t]*}[ \t]*[_0-9a-zA-Z][_0-9a-zA-Z]*[ \t]*;[ \t]*$/{
-  sub(/;$/, "", $2)
-
-  print "char associate$" $2 "$" seed ";"
-  print "char SIZEOF$" seed "[sizeof(" $2 ")];"
-  print ""
-  print ""
-  gsub(/\^\^\^/, $2, assumptions);
-  print assumptions
-  ++seed
-  interesting = 0
-  next
-}
-
-## Ptr-typedef
-interesting && /^[ \t]*}[ \t]*\*[_0-9a-zA-Z][_0-9a-zA-Z]*Ptr[ \t]*;[ \t]*$/{
-  sub(/Ptr;$/, "", $2)
-  sub(/^\*/, "", $2)
-
-  print "char associate$" $2 "$" seed ";"
-  print "char SIZEOF$" seed "[sizeof(" $2 ")];"
-  print ""
-  print ""
-  gsub(/\^\^\^/, $2, assumptions);
-  print assumptions
-  ++seed
-  interesting = 0
-  next
-}
-
-interesting && /^[ \t]*}[; \t]*$/ {
-  print "char SIZEOF$" seed "[sizeof(" known_struct_name ")];"
-  print ""
-  print ""
-  gsub(/\^\^\^/, known_struct_name, assumptions);
-  print assumptions
-  ++seed
-  interesting = 0
-}
-
-# collapse whitespace after '*'
-interesting {
-  # normalize some types
-  sub(/struct StgClosure_[ \t]*\*/, "StgClosure *")
-  gsub(/\*[ \t]*volatile/, "*")
-  # group stars together
-  gsub(/\*[ \t]*/, "*")
-  sub(/\*/, " *")
-  print "//   " $0
-  # remove volatile
-  sub(/[ \t]volatile[ \t]/, " ")
-  # remove const
-  sub(/[ \t]const[ \t]/, " ")
-}
-
-## (pointer to struct) member of struct
-##
-interesting && /^[ \t]*struct[ \t][ \t]*[_0-9a-zA-Z][_0-9a-zA-Z]*[ \t]*\*[ \t]*[_0-9a-zA-Z][_0-9a-zA-Z]*[ \t]*;[ \t]*$/ {
-  if (!$4) {
-    sub(/^\*/, "", $3)
-    $4 = $3
-  }
-  sub(/;$/, "", $4)
-
-  new_offset_struct_name = struct_name $4
-  print ""
-
-  if (!offset_struct_name)
-  {
-    print "char starting" new_offset_struct_name "[2];"
-  }
-  else
-  {
-    assumptions = assumptions "\n" "char sizeof" new_offset_struct_name "[offsetof(^^^, " $4 ")];"
-    assumptions = assumptions "\n" "typedef char verify_size" new_offset_struct_name "[sizeof sizeof" new_offset_struct_name " == offsetof(^^^, " $4 ") ? 1 : -1];"
-  }
-  print "char fieldsize" new_offset_struct_name "[sizeof(struct " $2 "*)];"
-  print ""
-  print ""
-  offset_struct_name = new_offset_struct_name
-  next
-}
-
-## (simple pointer) member of struct
-##
-interesting && /^[ \t]*[_0-9a-zA-Z][_0-9a-zA-Z]*[ \t][ \t]*\*\**[_0-9a-zA-Z][_0-9a-zA-Z]*[ \t]*;[ \t]*$/ {
-  sub(/;$/, "", $2)
-  sub(/^\**/, "", $2)
-
-  new_offset_struct_name = struct_name $2
-  print ""
-
-  if (!offset_struct_name)
-  {
-    print "char starting" new_offset_struct_name "[2];"
-  }
-  else
-  {
-    assumptions = assumptions "\n" "char sizeof" new_offset_struct_name "[offsetof(^^^, " $2 ")];"
-    assumptions = assumptions "\n" "typedef char verify_size" new_offset_struct_name "[sizeof sizeof" new_offset_struct_name " == offsetof(^^^, " $2 ") ? 1 : -1];"
-  }
-  print "char fieldsize" new_offset_struct_name "[sizeof(" $1 "*)];"
-  print ""
-  print ""
-  offset_struct_name = new_offset_struct_name
-  next
-}
-
-## member of struct
-##
-interesting && /^[ \t]*[_0-9a-zA-Z][_0-9a-zA-Z]*[ \t][ \t]*[_0-9a-zA-Z][_0-9a-zA-Z]*;[ \t]*$/ {
-  sub(/;$/, "", $2)
-
-  new_offset_struct_name = struct_name $2
-  print ""
-
-  if (!offset_struct_name)
-  {
-    print "char starting" new_offset_struct_name "[2];"
-  }
-  else
-  {
-    assumptions = assumptions "\n" "char sizeof" new_offset_struct_name "[offsetof(^^^, " $2 ")];"
-    assumptions = assumptions "\n" "typedef char verify_size" new_offset_struct_name "[sizeof sizeof" new_offset_struct_name " == offsetof(^^^, " $2 ") ? 1 : -1];"
-  }
-  print "char fieldsize" new_offset_struct_name "[sizeof(" $1 ")];"
-  print ""
-  print ""
-  offset_struct_name = new_offset_struct_name
-  next
-}
-
-## struct member of struct
-##
-interesting && /^[ \t]*struct[ \t][ \t]*[_0-9a-zA-Z][_0-9a-zA-Z]*[ \t][ \t]*[_0-9a-zA-Z][_0-9a-zA-Z]*;[ \t]*$/ {
-  sub(/;$/, "", $3)
-
-  new_offset_struct_name = struct_name $3
-  print ""
-
-  if (!offset_struct_name)
-  {
-    print "char starting" new_offset_struct_name "[2];"
-  }
-  else
-  {
-    assumptions = assumptions "\n" "char sizeof" new_offset_struct_name "[offsetof(^^^, " $3 ")];"
-    assumptions = assumptions "\n" "typedef char verify_size" new_offset_struct_name "[sizeof sizeof" new_offset_struct_name " == offsetof(^^^, " $3 ") ? 1 : -1];"
-  }
-  print "char fieldsize" new_offset_struct_name "[sizeof(struct " $2 ")];"
-  print ""
-  print ""
-  offset_struct_name = new_offset_struct_name
-  next
-}
-
-## embedded union
-interesting && /^[ \t]*union[ \t]*{[ \t]*$/ {
-  eat_union = 1
-  next
-}
-
-## array member
-interesting && /^[ \t]*[_0-9a-zA-Z][_0-9a-zA-Z]*[ \t][ \t]*\**[_0-9a-zA-Z][_0-9a-zA-Z]*\[.*\];[ \t]*$/ {
-  sub(/;[ \t]*$/, "", $0)
-
-  full = $0
-  sub(/^[ \t]*[_0-9a-zA-Z][_0-9a-zA-Z]*[ \t][ \t]*/, "", full)
-  split(full, parts, "[")
-  mname = parts[1]
-  sub(/^\**/, "", mname)
-
-  new_offset_struct_name = struct_name mname
-  print ""
-
-  if (!offset_struct_name)
-  {
-    print "char starting" new_offset_struct_name "[2];"
-  }
-  else
-  {
-    assumptions = assumptions "\n" "char sizeof" new_offset_struct_name "[offsetof(^^^, " mname ")];"
-    assumptions = assumptions "\n" "typedef char verify_size" new_offset_struct_name "[sizeof sizeof" new_offset_struct_name " == offsetof(^^^, " mname ") ? 1 : -1];"
-  }
-
-  print ""
-  print ""
-  offset_struct_name = new_offset_struct_name
-  next
-}
-
-
-## padded member of struct
-##   of this form: StgHalfInt slow_apply_offset; StgHalfWord __pad_slow_apply_offset;;
-##
-interesting && /^[ \t]*[_0-9a-zA-Z][_0-9a-zA-Z]*[ \t][ \t]*[_0-9a-zA-Z][_0-9a-zA-Z]*;[ \t]*[_0-9a-zA-Z][_0-9a-zA-Z]*[ \t][ \t]*__pad_[a-zA-Z][_0-9a-zA-Z]*;;*[ \t]*$/ {
-  mname = $2
-  sub(/;$/, "", mname)
-
-  new_offset_struct_name = struct_name mname
-  print ""
-
-  if (!offset_struct_name)
-  {
-    print "char starting" new_offset_struct_name "[2];"
-  }
-  else
-  {
-    assumptions = assumptions "\n" "char sizeof" new_offset_struct_name "[offsetof(^^^, " mname ")];"
-    assumptions = assumptions "\n" "typedef char verify_size" new_offset_struct_name "[sizeof sizeof" new_offset_struct_name " == offsetof(^^^, " mname ") ? 1 : -1];"
-  }
-  print ""
-  print ""
-  offset_struct_name = new_offset_struct_name
-  next
-}
-
-interesting && /;[ \t]*$/ {
-  print "Member not recognized: " $0 > "/dev/stderr"
-  exit 1
-}
\ No newline at end of file
diff --git a/includes/mkSizeMacros.cross.awk b/includes/mkSizeMacros.cross.awk
deleted file mode 100644 (file)
index e33e4ff..0000000
+++ /dev/null
@@ -1,82 +0,0 @@
-BEGIN {
-  print "#define OFFSET(s_type, field) OFFSET_ ## s_type ## _ ## field"
-  print "#define FIELD_SIZE(s_type, field) FIELD_SIZE_ ## s_type ## _ ## field"
-  print "#define TYPE_SIZE(type) TYPE_SIZE_ ## type"
-  print ""
-}
-
-/^0[0-9a-zA-Z]* C _*associate\$/ {
-  sub(/_*associate\$/, "", $3)
-  split($3, arr, "$")
-  assoc[arr[2]] = arr[1]
-  next
-}
-
-/^00*2 C _*starting\$[0-9]*\$[_0-9a-zA-Z]*$/ {
-  sub(/_*starting\$/, "", $3)
-  split($3, arr, "$")
-  sub(/^0*/, "", $1)
-  print "#define OFFSET_" assoc[arr[1]] "_" arr[2] " 0x0"
-  next
-}
-
-/^0[0-9a-zA-Z]* C _*sizeof\$[0-9]*\$[_0-9a-zA-Z]*$/ {
-  sub(/_*sizeof\$/, "", $3)
-  split($3, arr, "$")
-  sub(/^0*/, "", $1)
-  print "#define OFFSET_" assoc[arr[1]] "_" arr[2] " 0x" $1
-  next
-}
-
-/^0[0-9a-zA-Z]* C _*fieldsize\$[0-9]*\$[_0-9a-zA-Z]*$/ {
-  sub(/_*fieldsize\$/, "", $3)
-  split($3, arr, "$")
-  sub(/^0*/, "", $1)
-  print "#define FIELD_SIZE_" assoc[arr[1]] "_" arr[2] " 0x" $1 "UL"
-  next
-}
-
-/^0[0-9a-zA-Z]* C _*nestedfieldsize\$[_0-9a-zA-Z]*\$[_0-9a-zA-Z]*$/ {
-  sub(/_*nestedfieldsize\$/, "", $3)
-  split($3, arr, "$")
-  sub(/^0*/, "", $1)
-  print "#define FIELD_SIZE_" arr[1] "_" arr[2] " 0x" $1 "UL"
-  next
-}
-
-/^0[0-9a-zA-Z]* C _*SIZEOF\$[0-9]*$/ {
-  sub(/_*SIZEOF\$/, "", $3)
-  sub(/^0*/, "", $1)
-  print "#define TYPE_SIZE_" assoc[$3] " 0x" $1
-  next
-}
-
-{ print "// " $0 }
-
-END {
-    ## some indirect offsets
-    print "#define OFFSET_StgHeader_prof_ccs (OFFSET_StgHeader_prof + OFFSET_StgProfHeader_ccs)"
-    print "#define OFFSET_StgHeader_prof_hp_ldvw (OFFSET_StgHeader_prof + OFFSET_StgProfHeader_hp + 0)"
-    print "#define OFFSET_StgTSO_prof_cccs (OFFSET_StgTSO_prof + OFFSET_StgTSOProfInfo_cccs)"
-    print "#define OFFSET_RTS_FLAGS_ProfFlags_showCCSOnException (OFFSET_RTS_FLAGS_ProfFlags + OFFSET_PROFILING_FLAGS_showCCSOnException)"
-
-
-    print "#define OFFSET_RTS_FLAGS_DebugFlags_apply (OFFSET_RTS_FLAGS_DebugFlags + OFFSET_DEBUG_FLAGS_apply)"
-    print "#define OFFSET_RTS_FLAGS_DebugFlags_sanity (OFFSET_RTS_FLAGS_DebugFlags + OFFSET_DEBUG_FLAGS_sanity)"
-    print "#define OFFSET_RTS_FLAGS_DebugFlags_weak (OFFSET_RTS_FLAGS_DebugFlags + OFFSET_DEBUG_FLAGS_weak)"
-    print "#define OFFSET_RTS_FLAGS_GcFlags_initialStkSize (OFFSET_RTS_FLAGS_GcFlags + OFFSET_GC_FLAGS_initialStkSize)"
-    print "#define OFFSET_RTS_FLAGS_MiscFlags_tickInterval (OFFSET_RTS_FLAGS_MiscFlags + OFFSET_MISC_FLAGS_tickInterval)"
-
-    print "#define OFFSET_StgFunInfoExtraFwd_b_bitmap (OFFSET_StgFunInfoExtraFwd_b + 0)"
-    print "#define OFFSET_StgFunInfoExtraRev_b_bitmap (OFFSET_StgFunInfoExtraRev_b + 0)"
-
-    ## some indirect field sizes
-    print "#define FIELD_SIZE_StgHeader_prof_ccs FIELD_SIZE_StgProfHeader_ccs"
-    print "#define FIELD_SIZE_StgTSO_prof_cccs FIELD_SIZE_StgTSOProfInfo_cccs"
-    print "#define FIELD_SIZE_RTS_FLAGS_ProfFlags_showCCSOnException FIELD_SIZE_PROFILING_FLAGS_showCCSOnException"
-    print "#define FIELD_SIZE_RTS_FLAGS_DebugFlags_apply FIELD_SIZE_DEBUG_FLAGS_apply"
-    print "#define FIELD_SIZE_RTS_FLAGS_DebugFlags_sanity FIELD_SIZE_DEBUG_FLAGS_sanity"
-    print "#define FIELD_SIZE_RTS_FLAGS_DebugFlags_weak FIELD_SIZE_DEBUG_FLAGS_weak"
-    print "#define FIELD_SIZE_RTS_FLAGS_GcFlags_initialStkSize FIELD_SIZE_GC_FLAGS_initialStkSize"
-    print "#define FIELD_SIZE_RTS_FLAGS_MiscFlags_tickInterval FIELD_SIZE_MISC_FLAGS_tickInterval"
-}
diff --git a/utils/deriveConstants/DeriveConstants.hs b/utils/deriveConstants/DeriveConstants.hs
new file mode 100644 (file)
index 0000000..7cb979e
--- /dev/null
@@ -0,0 +1,858 @@
+
+{- ------------------------------------------------------------------------
+
+(c) The GHC Team, 1992-2012
+
+DeriveConstants is a program that extracts information from the C
+declarations in the header files (primarily struct field offsets)
+and generates various files, such as a header file that can be #included
+into non-C source containing this information.
+
+------------------------------------------------------------------------ -}
+
+import Control.Monad
+import Data.Bits
+import Data.Char
+import Data.List
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Data.Maybe
+import Numeric
+import System.Environment
+import System.Exit
+import System.FilePath
+import System.IO
+import System.Info
+import System.Process
+
+main :: IO ()
+main = do opts <- parseArgs
+          let getOption descr opt = case opt opts of
+                                    Just x -> return x
+                                    Nothing -> die ("No " ++ descr ++ " given")
+          mode <- getOption "mode" o_mode
+          fn <- getOption "output filename" o_outputFilename
+          case mode of
+              Gen_Haskell_Type     -> writeHaskellType     fn haskellWanteds
+              Gen_Haskell_Wrappers -> writeHaskellWrappers fn haskellWanteds
+              Gen_Haskell_Exports  -> writeHaskellExports  fn haskellWanteds
+              Gen_Computed cm ->
+                  do tmpdir  <- getOption "tmpdir"      o_tmpdir
+                     gccProg <- getOption "gcc program" o_gccProg
+                     nmProg  <- getOption "nm program"  o_nmProg
+                     rs <- getWanted tmpdir gccProg (o_gccFlags opts) nmProg
+                     let haskellRs = [ what
+                                     | (wh, what) <- rs
+                                     , wh `elem` [Haskell, Both] ]
+                         cRs = [ what
+                               | (wh, what) <- rs
+                               , wh `elem` [C, Both] ]
+                     case cm of
+                         ComputeHaskell -> writeHaskellValue fn haskellRs
+                         ComputeHeader  -> writeHeader       fn cRs
+    where haskellWanteds = [ what | (wh, what) <- wanteds,
+                                    wh `elem` [Haskell, Both] ]
+
+data Options = Options {
+                   o_mode :: Maybe Mode,
+                   o_tmpdir :: Maybe FilePath,
+                   o_outputFilename :: Maybe FilePath,
+                   o_gccProg :: Maybe FilePath,
+                   o_gccFlags :: [String],
+                   o_nmProg :: Maybe FilePath
+               }
+
+parseArgs :: IO Options
+parseArgs = do args <- getArgs
+               opts <- f emptyOptions args
+               return (opts {o_gccFlags = reverse (o_gccFlags opts)})
+    where emptyOptions = Options {
+                             o_mode = Nothing,
+                             o_tmpdir = Nothing,
+                             o_outputFilename = Nothing,
+                             o_gccProg = Nothing,
+                             o_gccFlags = [],
+                             o_nmProg = Nothing
+                         }
+          f opts [] = return opts
+          f opts ("--gen-haskell-type" : args')
+              = f (opts {o_mode = Just Gen_Haskell_Type}) args'
+          f opts ("--gen-haskell-value" : args')
+              = f (opts {o_mode = Just (Gen_Computed ComputeHaskell)}) args'
+          f opts ("--gen-haskell-wrappers" : args')
+              = f (opts {o_mode = Just Gen_Haskell_Wrappers}) args'
+          f opts ("--gen-haskell-exports" : args')
+              = f (opts {o_mode = Just Gen_Haskell_Exports}) args'
+          f opts ("--gen-header" : args')
+              = f (opts {o_mode = Just (Gen_Computed ComputeHeader)}) args'
+          f opts ("--tmpdir" : dir : args')
+              = f (opts {o_tmpdir = Just dir}) args'
+          f opts ("-o" : fn : args')
+              = f (opts {o_outputFilename = Just fn}) args'
+          f opts ("--gcc-program" : prog : args')
+              = f (opts {o_gccProg = Just prog}) args'
+          f opts ("--gcc-flag" : flag : args')
+              = f (opts {o_gccFlags = flag : o_gccFlags opts}) args'
+          f opts ("--nm-program" : prog : args')
+              = f (opts {o_nmProg = Just prog}) args'
+          f _ (flag : _) = die ("Unrecognised flag: " ++ show flag)
+
+data Mode = Gen_Haskell_Type
+          | Gen_Haskell_Wrappers
+          | Gen_Haskell_Exports
+          | Gen_Computed ComputeMode
+
+data ComputeMode = ComputeHaskell | ComputeHeader
+
+type Wanteds = [(Where, What Fst)]
+type Results = [(Where, What Snd)]
+
+type Name = String
+newtype CExpr = CExpr String
+newtype CPPExpr = CPPExpr String
+data What f = GetFieldType   Name (f CExpr   Integer)
+            | GetClosureSize Name (f CExpr   Integer)
+            | GetWord        Name (f CExpr   Integer)
+            | GetInt         Name (f CExpr   Integer)
+            | GetNatural     Name (f CExpr   Integer)
+            | GetBool        Name (f CPPExpr Bool)
+            | StructFieldMacro    Name
+            | ClosureFieldMacro   Name
+            | ClosurePayloadMacro Name
+            | FieldTypeGcptrMacro Name
+
+data Fst a b = Fst a
+data Snd a b = Snd b
+
+data Where = C | Haskell | Both
+    deriving Eq
+
+constantInt :: Where -> Name -> String -> Wanteds
+constantInt w name expr = [(w, GetInt name (Fst (CExpr expr)))]
+
+constantWord :: Where -> Name -> String -> Wanteds
+constantWord w name expr = [(w, GetWord name (Fst (CExpr expr)))]
+
+constantNatural :: Where -> Name -> String -> Wanteds
+constantNatural w name expr = [(w, GetNatural name (Fst (CExpr expr)))]
+
+constantBool :: Where -> Name -> String -> Wanteds
+constantBool w name expr = [(w, GetBool name (Fst (CPPExpr expr)))]
+
+fieldOffset :: Where -> String -> String -> Wanteds
+fieldOffset w theType theField = fieldOffset_ w nameBase theType theField
+    where nameBase = theType ++ "_" ++ theField
+
+fieldOffset_ :: Where -> Name -> String -> String -> Wanteds
+fieldOffset_ w nameBase theType theField = [(w, GetWord name (Fst (CExpr expr)))]
+    where name = "OFFSET_" ++ nameBase
+          expr = "OFFSET(" ++ theType ++ ", " ++ theField ++ ")"
+
+-- FieldType is for defining REP_x to be b32 etc
+-- These are both the C-- types used in a load
+--    e.g.  b32[addr]
+-- and the names of the CmmTypes in the compiler
+--    b32 :: CmmType
+fieldType' :: Where -> String -> String -> Wanteds
+fieldType' w theType theField
+    = fieldType_' w nameBase theType theField
+    where nameBase = theType ++ "_" ++ theField
+
+fieldType_' :: Where -> Name -> String -> String -> Wanteds
+fieldType_' w nameBase theType theField
+    = [(w, GetFieldType name (Fst (CExpr expr)))]
+    where name = "REP_" ++ nameBase
+          expr = "FIELD_SIZE(" ++ theType ++ ", " ++ theField ++ ")"
+
+structField :: Where -> String -> String -> Wanteds
+structField = structFieldHelper C
+
+structFieldH :: Where -> String -> String -> Wanteds
+structFieldH w = structFieldHelper w w
+
+structField_ :: Where -> Name -> String -> String -> Wanteds
+structField_ w nameBase theType theField
+    = fieldOffset_ w nameBase theType theField
+   ++ fieldType_' C nameBase theType theField
+   ++ structFieldMacro nameBase
+
+structFieldMacro :: Name -> Wanteds
+structFieldMacro nameBase = [(C, StructFieldMacro nameBase)]
+
+-- Outputs the byte offset and MachRep for a field
+structFieldHelper :: Where -> Where -> String -> String -> Wanteds
+structFieldHelper wFT w theType theField = fieldOffset w theType theField
+                                        ++ fieldType' wFT theType theField
+                                        ++ structFieldMacro nameBase
+    where nameBase = theType ++ "_" ++ theField
+
+closureFieldMacro :: Name -> Wanteds
+closureFieldMacro nameBase = [(C, ClosureFieldMacro nameBase)]
+
+closurePayload :: Where -> String -> String -> Wanteds
+closurePayload w theType theField
+    = closureFieldOffset_ w nameBase theType theField
+   ++ closurePayloadMacro nameBase
+    where nameBase = theType ++ "_" ++ theField
+
+closurePayloadMacro :: Name -> Wanteds
+closurePayloadMacro nameBase = [(C, ClosurePayloadMacro nameBase)]
+
+-- Byte offset and MachRep for a closure field, minus the header
+closureField_ :: Where -> Name -> String -> String -> Wanteds
+closureField_ w nameBase theType theField
+    = closureFieldOffset_ w nameBase theType theField
+   ++ fieldType_' C nameBase theType theField
+   ++ closureFieldMacro nameBase
+
+closureField :: Where -> String -> String -> Wanteds
+closureField w theType theField = closureField_ w nameBase theType theField
+    where nameBase = theType ++ "_" ++ theField
+
+closureFieldOffset_ :: Where -> Name -> String -> String -> Wanteds
+closureFieldOffset_ w nameBase theType theField
+    = defOffset w nameBase (CExpr ("OFFSET(" ++ theType ++ ", " ++ theField ++ ") - TYPE_SIZE(StgHeader)"))
+
+-- Size of a closure type, minus the header, named SIZEOF_<type>_NoHdr
+-- Also, we #define SIZEOF_<type> to be the size of the whole closure for .cmm.
+closureSize :: Where -> String -> Wanteds
+closureSize w theType = defSize        w (theType ++ "_NoHdr") (CExpr expr)
+                     ++ defClosureSize C theType               (CExpr expr)
+    where expr = "TYPE_SIZE(" ++ theType ++ ") - TYPE_SIZE(StgHeader)"
+
+-- Byte offset and MachRep for a closure field, minus the header
+closureFieldGcptr :: Where -> String -> String -> Wanteds
+closureFieldGcptr w theType theField
+    = closureFieldOffset_ w nameBase theType theField
+   ++ fieldTypeGcptr nameBase
+   ++ closureFieldMacro nameBase
+    where nameBase = theType ++ "_" ++ theField
+
+fieldTypeGcptr :: Name -> Wanteds
+fieldTypeGcptr nameBase = [(C, FieldTypeGcptrMacro nameBase)]
+
+closureFieldOffset :: Where -> String -> String -> Wanteds
+closureFieldOffset w theType theField
+    = defOffset w nameBase (CExpr expr)
+    where nameBase = theType ++ "_" ++ theField
+          expr = "OFFSET(" ++ theType ++ ", " ++ theField ++ ") - TYPE_SIZE(StgHeader)"
+
+thunkSize :: Where -> String -> Wanteds
+thunkSize w theType
+    = defSize w (theType ++ "_NoThunkHdr") (CExpr expr)
+  ++ closureSize w theType
+    where expr = "TYPE_SIZE(" ++ theType ++ ") - TYPE_SIZE(StgThunkHeader)"
+
+defIntOffset :: Where -> Name -> String -> Wanteds
+defIntOffset w nameBase cExpr = [(w, GetInt ("OFFSET_" ++ nameBase) (Fst (CExpr cExpr)))]
+
+defOffset :: Where -> Name -> CExpr -> Wanteds
+defOffset w nameBase cExpr = [(w, GetWord ("OFFSET_" ++ nameBase) (Fst cExpr))]
+
+structSize :: Where -> String -> Wanteds
+structSize w theType = defSize w theType (CExpr ("TYPE_SIZE(" ++ theType ++ ")"))
+
+defSize :: Where -> Name -> CExpr -> Wanteds
+defSize w nameBase cExpr = [(w, GetWord ("SIZEOF_" ++ nameBase) (Fst cExpr))]
+
+defClosureSize :: Where -> Name -> CExpr -> Wanteds
+defClosureSize w nameBase cExpr = [(w, GetClosureSize ("SIZEOF_" ++ nameBase) (Fst cExpr))]
+
+haskellise :: Name -> Name
+haskellise (c : cs) = toLower c : cs
+haskellise "" = ""
+
+wanteds :: Wanteds
+wanteds = concat
+          [-- Closure header sizes.
+           constantWord Both "STD_HDR_SIZE"
+                             -- grrr.. PROFILING is on so we need to
+                             -- subtract sizeofW(StgProfHeader)
+                             "sizeofW(StgHeader) - sizeofW(StgProfHeader)"
+          ,constantWord Both "PROF_HDR_SIZE" "sizeofW(StgProfHeader)"
+
+           -- Size of a storage manager block (in bytes).
+          ,constantWord Both "BLOCK_SIZE"  "BLOCK_SIZE"
+          ,constantWord C    "MBLOCK_SIZE" "MBLOCK_SIZE"
+           -- blocks that fit in an MBlock, leaving space for the block
+           -- descriptors
+          ,constantWord Both "BLOCKS_PER_MBLOCK" "BLOCKS_PER_MBLOCK"
+           -- could be derived, but better to save doing the calculation twice
+
+          ,fieldOffset Both "StgRegTable" "rR1"
+          ,fieldOffset Both "StgRegTable" "rR2"
+          ,fieldOffset Both "StgRegTable" "rR3"
+          ,fieldOffset Both "StgRegTable" "rR4"
+          ,fieldOffset Both "StgRegTable" "rR5"
+          ,fieldOffset Both "StgRegTable" "rR6"
+          ,fieldOffset Both "StgRegTable" "rR7"
+          ,fieldOffset Both "StgRegTable" "rR8"
+          ,fieldOffset Both "StgRegTable" "rR9"
+          ,fieldOffset Both "StgRegTable" "rR10"
+          ,fieldOffset Both "StgRegTable" "rF1"
+          ,fieldOffset Both "StgRegTable" "rF2"
+          ,fieldOffset Both "StgRegTable" "rF3"
+          ,fieldOffset Both "StgRegTable" "rF4"
+          ,fieldOffset Both "StgRegTable" "rF5"
+          ,fieldOffset Both "StgRegTable" "rF6"
+          ,fieldOffset Both "StgRegTable" "rD1"
+          ,fieldOffset Both "StgRegTable" "rD2"
+          ,fieldOffset Both "StgRegTable" "rD3"
+          ,fieldOffset Both "StgRegTable" "rD4"
+          ,fieldOffset Both "StgRegTable" "rD5"
+          ,fieldOffset Both "StgRegTable" "rD6"
+          ,fieldOffset Both "StgRegTable" "rL1"
+          ,fieldOffset Both "StgRegTable" "rSp"
+          ,fieldOffset Both "StgRegTable" "rSpLim"
+          ,fieldOffset Both "StgRegTable" "rHp"
+          ,fieldOffset Both "StgRegTable" "rHpLim"
+          ,fieldOffset Both "StgRegTable" "rCCCS"
+          ,fieldOffset Both "StgRegTable" "rCurrentTSO"
+          ,fieldOffset Both "StgRegTable" "rCurrentNursery"
+          ,fieldOffset Both "StgRegTable" "rHpAlloc"
+          ,structField C    "StgRegTable" "rRet"
+          ,structField C    "StgRegTable" "rNursery"
+
+          ,defIntOffset Both "stgEagerBlackholeInfo"
+                             "FUN_OFFSET(stgEagerBlackholeInfo)"
+          ,defIntOffset Both "stgGCEnter1" "FUN_OFFSET(stgGCEnter1)"
+          ,defIntOffset Both "stgGCFun"    "FUN_OFFSET(stgGCFun)"
+
+          ,fieldOffset Both "Capability" "r"
+          ,fieldOffset C    "Capability" "lock"
+          ,structField C    "Capability" "no"
+          ,structField C    "Capability" "mut_lists"
+          ,structField C    "Capability" "context_switch"
+          ,structField C    "Capability" "interrupt"
+          ,structField C    "Capability" "sparks"
+
+          ,structField Both "bdescr" "start"
+          ,structField Both "bdescr" "free"
+          ,structField Both "bdescr" "blocks"
+          ,structField C    "bdescr" "gen_no"
+          ,structField C    "bdescr" "link"
+
+          ,structSize C  "generation"
+          ,structField C "generation" "n_new_large_words"
+
+          ,structSize Both   "CostCentreStack"
+          ,structField C     "CostCentreStack" "ccsID"
+          ,structFieldH Both "CostCentreStack" "mem_alloc"
+          ,structFieldH Both "CostCentreStack" "scc_count"
+          ,structField C     "CostCentreStack" "prevStack"
+
+          ,structField C "CostCentre" "ccID"
+          ,structField C "CostCentre" "link"
+
+          ,structField C     "StgHeader" "info"
+          ,structField_ Both "StgHeader_ccs" "StgHeader" "prof.ccs"
+          ,structField_ Both "StgHeader_ldvw" "StgHeader" "prof.hp.ldvw"
+
+          ,structSize Both "StgSMPThunkHeader"
+
+          ,closurePayload C "StgClosure" "payload"
+
+          ,structFieldH Both "StgEntCounter" "allocs"
+          ,structField  Both "StgEntCounter" "registeredp"
+          ,structField  Both "StgEntCounter" "link"
+          ,structField  Both "StgEntCounter" "entry_count"
+
+          ,closureSize Both "StgUpdateFrame"
+          ,closureSize C    "StgCatchFrame"
+          ,closureSize C    "StgStopFrame"
+
+          ,closureSize  Both "StgMutArrPtrs"
+          ,closureField Both "StgMutArrPtrs" "ptrs"
+          ,closureField Both "StgMutArrPtrs" "size"
+
+          ,closureSize    Both "StgArrWords"
+          ,closureField   C    "StgArrWords" "bytes"
+          ,closurePayload C    "StgArrWords" "payload"
+
+          ,closureField  C    "StgTSO"      "_link"
+          ,closureField  C    "StgTSO"      "global_link"
+          ,closureField  C    "StgTSO"      "what_next"
+          ,closureField  C    "StgTSO"      "why_blocked"
+          ,closureField  C    "StgTSO"      "block_info"
+          ,closureField  C    "StgTSO"      "blocked_exceptions"
+          ,closureField  C    "StgTSO"      "id"
+          ,closureField  C    "StgTSO"      "cap"
+          ,closureField  C    "StgTSO"      "saved_errno"
+          ,closureField  C    "StgTSO"      "trec"
+          ,closureField  C    "StgTSO"      "flags"
+          ,closureField  C    "StgTSO"      "dirty"
+          ,closureField  C    "StgTSO"      "bq"
+          ,closureField_ Both "StgTSO_cccs" "StgTSO" "prof.cccs"
+          ,closureField  Both "StgTSO"      "stackobj"
+
+          ,closureField       Both "StgStack" "sp"
+          ,closureFieldOffset Both "StgStack" "stack"
+          ,closureField       C    "StgStack" "stack_size"
+          ,closureField       C    "StgStack" "dirty"
+
+          ,structSize C "StgTSOProfInfo"
+
+          ,closureField Both "StgUpdateFrame" "updatee"
+
+          ,closureField C "StgCatchFrame" "handler"
+          ,closureField C "StgCatchFrame" "exceptions_blocked"
+
+          ,closureSize       C "StgPAP"
+          ,closureField      C "StgPAP" "n_args"
+          ,closureFieldGcptr C "StgPAP" "fun"
+          ,closureField      C "StgPAP" "arity"
+          ,closurePayload    C "StgPAP" "payload"
+
+          ,thunkSize         C "StgAP"
+          ,closureField      C "StgAP" "n_args"
+          ,closureFieldGcptr C "StgAP" "fun"
+          ,closurePayload    C "StgAP" "payload"
+
+          ,thunkSize         C "StgAP_STACK"
+          ,closureField      C "StgAP_STACK" "size"
+          ,closureFieldGcptr C "StgAP_STACK" "fun"
+          ,closurePayload    C "StgAP_STACK" "payload"
+
+          ,thunkSize C "StgSelector"
+
+          ,closureFieldGcptr C "StgInd" "indirectee"
+
+          ,closureSize  C "StgMutVar"
+          ,closureField C "StgMutVar" "var"
+
+          ,closureSize  C "StgAtomicallyFrame"
+          ,closureField C "StgAtomicallyFrame" "code"
+          ,closureField C "StgAtomicallyFrame" "next_invariant_to_check"
+          ,closureField C "StgAtomicallyFrame" "result"
+
+          ,closureField C "StgInvariantCheckQueue" "invariant"
+          ,closureField C "StgInvariantCheckQueue" "my_execution"
+          ,closureField C "StgInvariantCheckQueue" "next_queue_entry"
+
+          ,closureField C "StgAtomicInvariant" "code"
+
+          ,closureField C "StgTRecHeader" "enclosing_trec"
+
+          ,closureSize  C "StgCatchSTMFrame"
+          ,closureField C "StgCatchSTMFrame" "handler"
+          ,closureField C "StgCatchSTMFrame" "code"
+
+          ,closureSize  C "StgCatchRetryFrame"
+          ,closureField C "StgCatchRetryFrame" "running_alt_code"
+          ,closureField C "StgCatchRetryFrame" "first_code"
+          ,closureField C "StgCatchRetryFrame" "alt_code"
+
+          ,closureField C "StgTVarWatchQueue" "closure"
+          ,closureField C "StgTVarWatchQueue" "next_queue_entry"
+          ,closureField C "StgTVarWatchQueue" "prev_queue_entry"
+
+          ,closureSize  C "StgTVar"
+          ,closureField C "StgTVar" "current_value"
+          ,closureField C "StgTVar" "first_watch_queue_entry"
+          ,closureField C "StgTVar" "num_updates"
+
+          ,closureSize  C "StgWeak"
+          ,closureField C "StgWeak" "link"
+          ,closureField C "StgWeak" "key"
+          ,closureField C "StgWeak" "value"
+          ,closureField C "StgWeak" "finalizer"
+          ,closureField C "StgWeak" "cfinalizer"
+
+          ,closureSize  C "StgDeadWeak"
+          ,closureField C "StgDeadWeak" "link"
+
+          ,closureSize  C "StgMVar"
+          ,closureField C "StgMVar" "head"
+          ,closureField C "StgMVar" "tail"
+          ,closureField C "StgMVar" "value"
+
+          ,closureSize  C "StgMVarTSOQueue"
+          ,closureField C "StgMVarTSOQueue" "link"
+          ,closureField C "StgMVarTSOQueue" "tso"
+
+          ,closureSize    C "StgBCO"
+          ,closureField   C "StgBCO" "instrs"
+          ,closureField   C "StgBCO" "literals"
+          ,closureField   C "StgBCO" "ptrs"
+          ,closureField   C "StgBCO" "arity"
+          ,closureField   C "StgBCO" "size"
+          ,closurePayload C "StgBCO" "bitmap"
+
+          ,closureSize  C "StgStableName"
+          ,closureField C "StgStableName" "sn"
+
+          ,closureSize  C "StgBlockingQueue"
+          ,closureField C "StgBlockingQueue" "bh"
+          ,closureField C "StgBlockingQueue" "owner"
+          ,closureField C "StgBlockingQueue" "queue"
+          ,closureField C "StgBlockingQueue" "link"
+
+          ,closureSize  C "MessageBlackHole"
+          ,closureField C "MessageBlackHole" "link"
+          ,closureField C "MessageBlackHole" "tso"
+          ,closureField C "MessageBlackHole" "bh"
+
+          ,structField_ C "RtsFlags_ProfFlags_showCCSOnException"
+                          "RTS_FLAGS" "ProfFlags.showCCSOnException"
+          ,structField_ C "RtsFlags_DebugFlags_apply"
+                          "RTS_FLAGS" "DebugFlags.apply"
+          ,structField_ C "RtsFlags_DebugFlags_sanity"
+                          "RTS_FLAGS" "DebugFlags.sanity"
+          ,structField_ C "RtsFlags_DebugFlags_weak"
+                          "RTS_FLAGS" "DebugFlags.weak"
+          ,structField_ C "RtsFlags_GcFlags_initialStkSize"
+                          "RTS_FLAGS" "GcFlags.initialStkSize"
+          ,structField_ C "RtsFlags_MiscFlags_tickInterval"
+                          "RTS_FLAGS" "MiscFlags.tickInterval"
+
+          ,structSize   C "StgFunInfoExtraFwd"
+          ,structField  C "StgFunInfoExtraFwd" "slow_apply"
+          ,structField  C "StgFunInfoExtraFwd" "fun_type"
+          ,structField  C "StgFunInfoExtraFwd" "arity"
+          ,structField_ C "StgFunInfoExtraFwd_bitmap" "StgFunInfoExtraFwd" "b.bitmap"
+
+          ,structSize   Both "StgFunInfoExtraRev"
+          ,structField  C    "StgFunInfoExtraRev" "slow_apply_offset"
+          ,structField  C    "StgFunInfoExtraRev" "fun_type"
+          ,structField  C    "StgFunInfoExtraRev" "arity"
+          ,structField_ C    "StgFunInfoExtraRev_bitmap" "StgFunInfoExtraRev" "b.bitmap"
+
+          ,structField C "StgLargeBitmap" "size"
+          ,fieldOffset C "StgLargeBitmap" "bitmap"
+
+          ,structSize  C "snEntry"
+          ,structField C "snEntry" "sn_obj"
+          ,structField C "snEntry" "addr"
+
+           -- Note that this conditional part only affects the C headers.
+           -- That's important, as it means we get the same PlatformConstants
+           -- type on all platforms.
+          ,if os == "mingw32"
+           then concat [structSize  C "StgAsyncIOResult"
+                       ,structField C "StgAsyncIOResult" "reqID"
+                       ,structField C "StgAsyncIOResult" "len"
+                       ,structField C "StgAsyncIOResult" "errCode"]
+           else []
+
+          -- pre-compiled thunk types
+          ,constantWord Haskell "MAX_SPEC_SELECTEE_SIZE" "MAX_SPEC_SELECTEE_SIZE"
+          ,constantWord Haskell "MAX_SPEC_AP_SIZE"       "MAX_SPEC_AP_SIZE"
+
+          -- closure sizes: these do NOT include the header (see below for
+          -- header sizes)
+          ,constantWord Haskell "MIN_PAYLOAD_SIZE" "MIN_PAYLOAD_SIZE"
+
+          ,constantInt  Haskell "MIN_INTLIKE" "MIN_INTLIKE"
+          ,constantWord Haskell "MAX_INTLIKE" "MAX_INTLIKE"
+
+          ,constantWord Haskell "MIN_CHARLIKE" "MIN_CHARLIKE"
+          ,constantWord Haskell "MAX_CHARLIKE" "MAX_CHARLIKE"
+
+          ,constantWord Haskell "MUT_ARR_PTRS_CARD_BITS" "MUT_ARR_PTRS_CARD_BITS"
+
+          -- A section of code-generator-related MAGIC CONSTANTS.
+          ,constantWord Haskell "MAX_Vanilla_REG"      "MAX_VANILLA_REG"
+          ,constantWord Haskell "MAX_Float_REG"        "MAX_FLOAT_REG"
+          ,constantWord Haskell "MAX_Double_REG"       "MAX_DOUBLE_REG"
+          ,constantWord Haskell "MAX_Long_REG"         "MAX_LONG_REG"
+          ,constantWord Haskell "MAX_SSE_REG"          "MAX_SSE_REG"
+          ,constantWord Haskell "MAX_Real_Vanilla_REG" "MAX_REAL_VANILLA_REG"
+          ,constantWord Haskell "MAX_Real_Float_REG"   "MAX_REAL_FLOAT_REG"
+          ,constantWord Haskell "MAX_Real_Double_REG"  "MAX_REAL_DOUBLE_REG"
+          ,constantWord Haskell "MAX_Real_SSE_REG"     "MAX_REAL_SSE_REG"
+          ,constantWord Haskell "MAX_Real_Long_REG"    "MAX_REAL_LONG_REG"
+
+          -- This tells the native code generator the size of the spill
+          -- area is has available.
+          ,constantWord Haskell "RESERVED_C_STACK_BYTES" "RESERVED_C_STACK_BYTES"
+          -- The amount of (Haskell) stack to leave free for saving
+          -- registers when returning to the scheduler.
+          ,constantWord Haskell "RESERVED_STACK_WORDS" "RESERVED_STACK_WORDS"
+          -- Continuations that need more than this amount of stack
+          -- should do their own stack check (see bug #1466).
+          ,constantWord Haskell "AP_STACK_SPLIM" "AP_STACK_SPLIM"
+
+          -- Size of a word, in bytes
+          ,constantWord Haskell "WORD_SIZE" "SIZEOF_HSWORD"
+
+          -- Size of a double in StgWords.
+          ,constantWord Haskell "DOUBLE_SIZE" "SIZEOF_DOUBLE"
+
+          -- Size of a C int, in bytes. May be smaller than wORD_SIZE.
+          ,constantWord Haskell "CINT_SIZE"       "SIZEOF_INT"
+          ,constantWord Haskell "CLONG_SIZE"      "SIZEOF_LONG"
+          ,constantWord Haskell "CLONG_LONG_SIZE" "SIZEOF_LONG_LONG"
+
+          -- Number of bits to shift a bitfield left by in an info table.
+          ,constantWord Haskell "BITMAP_BITS_SHIFT" "BITMAP_BITS_SHIFT"
+
+          -- Amount of pointer bits used for semi-tagging constructor closures
+          ,constantWord Haskell "TAG_BITS" "TAG_BITS"
+
+          ,constantBool Haskell "WORDS_BIGENDIAN"    "defined(WORDS_BIGENDIAN)"
+          ,constantBool Haskell "DYNAMIC_BY_DEFAULT" "defined(DYNAMIC_BY_DEFAULT)"
+
+          ,constantWord    Haskell "LDV_SHIFT"         "LDV_SHIFT"
+          ,constantNatural Haskell "ILDV_CREATE_MASK"  "LDV_CREATE_MASK"
+          ,constantNatural Haskell "ILDV_STATE_CREATE" "LDV_STATE_CREATE"
+          ,constantNatural Haskell "ILDV_STATE_USE"    "LDV_STATE_USE"
+          ]
+
+getWanted :: FilePath -> FilePath -> [String] -> FilePath -> IO Results
+getWanted tmpdir gccProgram gccFlags nmProgram
+    = do let cStuff = unlines (headers ++ concatMap (doWanted . snd) wanteds)
+             cFile = tmpdir </> "tmp.c"
+             oFile = tmpdir </> "tmp.o"
+         writeFile cFile cStuff
+         execute gccProgram (gccFlags ++ ["-c", cFile, "-o", oFile])
+         xs <- readProcess nmProgram [oFile] ""
+         let ls = lines xs
+             ms = map parseNmLine ls
+             m = Map.fromList $ catMaybes ms
+         rs <- mapM (lookupResult m) wanteds
+         return rs
+    where headers = ["#define IN_STG_CODE 0",
+                     "",
+                     "/*",
+                     " * We need offsets of profiled things...",
+                     " * better be careful that this doesn't",
+                     " * affect the offsets of anything else.",
+                     " */",
+                     "",
+                     "#define PROFILING",
+                     "#define THREADED_RTS",
+                     "",
+                     "#include \"PosixSource.h\"",
+                     "#include \"Rts.h\"",
+                     "#include \"Stable.h\"",
+                     "#include \"Capability.h\"",
+                     "",
+                     "#include <inttypes.h>",
+                     "#include <stdio.h>",
+                     "#include <string.h>",
+                     "",
+                     "#define OFFSET(s_type, field) ((size_t)&(((s_type*)0)->field))",
+                     "#define FIELD_SIZE(s_type, field) ((size_t)sizeof(((s_type*)0)->field))",
+                     "#define TYPE_SIZE(type) (sizeof(type))",
+                     "#define FUN_OFFSET(sym) (OFFSET(Capability,f.sym) - OFFSET(Capability,r))",
+                     "",
+                     "#pragma GCC poison sizeof"
+                     ]
+
+          prefix = "derivedConstant"
+          mkFullName name = prefix ++ name
+
+          -- We add 1 to the value, as some platforms will make a symbol
+          -- of size 1 when for
+          --     char foo[0];
+          -- We then subtract 1 again when parsing.
+          doWanted (GetFieldType name (Fst (CExpr cExpr)))
+              = ["char " ++ mkFullName name ++ "[1 + " ++ cExpr ++ "];"]
+          doWanted (GetClosureSize name (Fst (CExpr cExpr)))
+              = ["char " ++ mkFullName name ++ "[1 + " ++ cExpr ++ "];"]
+          doWanted (GetWord name (Fst (CExpr cExpr)))
+              = ["char " ++ mkFullName name ++ "[1 + " ++ cExpr ++ "];"]
+          doWanted (GetInt name (Fst (CExpr cExpr)))
+              = ["char " ++ mkFullName name ++ "Mag[1 + ((intptr_t)(" ++ cExpr ++ ") >= 0 ? (" ++ cExpr ++ ") : -(" ++ cExpr ++ "))];",
+                 "char " ++ mkFullName name ++ "Sig[(intptr_t)(" ++ cExpr ++ ") >= 0 ? 3 : 1];"]
+          doWanted (GetNatural name (Fst (CExpr cExpr)))
+              = -- These casts fix "right shift count >= width of type"
+                -- warnings
+                let cExpr' = "(uint64_t)(size_t)(" ++ cExpr ++ ")"
+                in ["char " ++ mkFullName name ++ "0[1 + ((" ++ cExpr' ++ ") & 0xFFFF)];",
+                    "char " ++ mkFullName name ++ "1[1 + (((" ++ cExpr' ++ ") >> 16) & 0xFFFF)];",
+                    "char " ++ mkFullName name ++ "2[1 + (((" ++ cExpr' ++ ") >> 32) & 0xFFFF)];",
+                    "char " ++ mkFullName name ++ "3[1 + (((" ++ cExpr' ++ ") >> 48) & 0xFFFF)];"]
+          doWanted (GetBool name (Fst (CPPExpr cppExpr)))
+              = ["#if " ++ cppExpr,
+                 "char " ++ mkFullName name ++ "[1];",
+                 "#else",
+                 "char " ++ mkFullName name ++ "[2];",
+                 "#endif"]
+          doWanted (StructFieldMacro {}) = []
+          doWanted (ClosureFieldMacro {}) = []
+          doWanted (ClosurePayloadMacro {}) = []
+          doWanted (FieldTypeGcptrMacro {}) = []
+
+          -- parseNmLine parses nm output that looks like
+          -- "0000000b C derivedConstantMAX_Vanilla_REG"
+          -- and returns ("MAX_Vanilla_REG", 11)
+          parseNmLine xs0 = case break (' ' ==) xs0 of
+                            (x1, ' ' : xs1) ->
+                                case break (' ' ==) xs1 of
+                                (x2, ' ' : x3) ->
+                                    case readHex x1 of
+                                    [(size, "")] ->
+                                        case x2 of
+                                        "C" ->
+                                            let x3' = case x3 of
+                                                      '_' : rest -> rest
+                                                      _          -> x3
+                                            in case stripPrefix prefix x3' of
+                                               Just name ->
+                                                   Just (name, size)
+                                               _ -> Nothing
+                                        _ -> Nothing
+                                    _ -> Nothing
+                                _ -> Nothing
+                            _ -> Nothing
+
+          -- If an Int value is larger than 2^28 or smaller
+          -- than -2^28, then fail.
+          -- This test is a bit conservative, but if any
+          -- constants are roughly maxBound or minBound then
+          -- we probably need them to be Integer rather than
+          -- Int so that -- cross-compiling between 32bit and
+          -- 64bit platforms works.
+          lookupSmall :: Map String Integer -> Name -> IO Integer
+          lookupSmall m name
+              = case Map.lookup name m of
+                Just v
+                 | v >   2^(28 :: Int) ||
+                   v < -(2^(28 :: Int)) ->
+                    die ("Value too large for GetWord: " ++ show v)
+                 | otherwise -> return v
+                Nothing -> die ("Can't find " ++ show name)
+
+          lookupResult :: Map String Integer -> (Where, What Fst)
+                       -> IO (Where, What Snd)
+          lookupResult m (w, GetWord name _)
+              = do v <- lookupSmall m name
+                   return (w, GetWord name (Snd (v - 1)))
+          lookupResult m (w, GetInt name _)
+              = do mag <- lookupSmall m (name ++ "Mag")
+                   sig <- lookupSmall m (name ++ "Sig")
+                   return (w, GetWord name (Snd ((mag - 1) * (sig - 2))))
+          lookupResult m (w, GetNatural name _)
+              = do v0 <- lookupSmall m (name ++ "0")
+                   v1 <- lookupSmall m (name ++ "1")
+                   v2 <- lookupSmall m (name ++ "2")
+                   v3 <- lookupSmall m (name ++ "3")
+                   let v = (v0 - 1)
+                         + shiftL (v1 - 1) 16
+                         + shiftL (v2 - 1) 32
+                         + shiftL (v3 - 1) 48
+                   return (w, GetWord name (Snd v))
+          lookupResult m (w, GetBool name _)
+              = do v <- lookupSmall m name
+                   case v of
+                       1 -> return (w, GetBool name (Snd True))
+                       2 -> return (w, GetBool name (Snd False))
+                       _ -> die ("Bad boolean: " ++ show v)
+          lookupResult m (w, GetFieldType name _)
+              = do v <- lookupSmall m name
+                   return (w, GetFieldType name (Snd (v - 1)))
+          lookupResult m (w, GetClosureSize name _)
+              = do v <- lookupSmall m name
+                   return (w, GetClosureSize name (Snd (v - 1)))
+          lookupResult _ (w, StructFieldMacro name)
+              = return (w, StructFieldMacro name)
+          lookupResult _ (w, ClosureFieldMacro name)
+              = return (w, ClosureFieldMacro name)
+          lookupResult _ (w, ClosurePayloadMacro name)
+              = return (w, ClosurePayloadMacro name)
+          lookupResult _ (w, FieldTypeGcptrMacro name)
+              = return (w, FieldTypeGcptrMacro name)
+
+writeHaskellType :: FilePath -> [What Fst] -> IO ()
+writeHaskellType fn ws = writeFile fn xs
+    where xs = unlines (headers ++ body ++ footers)
+          headers = ["data PlatformConstants = PlatformConstants {"
+                     -- Now a kludge that allows the real entries to
+                     -- all start with a comma, which makes life a
+                     -- little easier
+                    ,"    pc_platformConstants :: ()"]
+          footers = ["  } deriving Read"]
+          body = concatMap doWhat ws
+          doWhat (GetClosureSize name _) = ["    , pc_" ++ name ++ " :: Int"]
+          doWhat (GetFieldType   name _) = ["    , pc_" ++ name ++ " :: Int"]
+          doWhat (GetWord        name _) = ["    , pc_" ++ name ++ " :: Int"]
+          doWhat (GetInt         name _) = ["    , pc_" ++ name ++ " :: Int"]
+          doWhat (GetNatural     name _) = ["    , pc_" ++ name ++ " :: Integer"]
+          doWhat (GetBool        name _) = ["    , pc_" ++ name ++ " :: Bool"]
+          doWhat (StructFieldMacro {}) = []
+          doWhat (ClosureFieldMacro {}) = []
+          doWhat (ClosurePayloadMacro {}) = []
+          doWhat (FieldTypeGcptrMacro {}) = []
+
+writeHaskellValue :: FilePath -> [What Snd] -> IO ()
+writeHaskellValue fn rs = writeFile fn xs
+    where xs = unlines (headers ++ body ++ footers)
+          headers = ["PlatformConstants {"
+                    ,"    pc_platformConstants = ()"]
+          footers = ["  }"]
+          body = concatMap doWhat rs
+          doWhat (GetClosureSize name (Snd v)) = ["    , pc_" ++ name ++ " = " ++ show v]
+          doWhat (GetFieldType   name (Snd v)) = ["    , pc_" ++ name ++ " = " ++ show v]
+          doWhat (GetWord        name (Snd v)) = ["    , pc_" ++ name ++ " = " ++ show v]
+          doWhat (GetInt         name (Snd v)) = ["    , pc_" ++ name ++ " = " ++ show v]
+          doWhat (GetNatural     name (Snd v)) = ["    , pc_" ++ name ++ " = " ++ show v]
+          doWhat (GetBool        name (Snd v)) = ["    , pc_" ++ name ++ " = " ++ show v]
+          doWhat (StructFieldMacro {}) = []
+          doWhat (ClosureFieldMacro {}) = []
+          doWhat (ClosurePayloadMacro {}) = []
+          doWhat (FieldTypeGcptrMacro {}) = []
+
+writeHaskellWrappers :: FilePath -> [What Fst] -> IO ()
+writeHaskellWrappers fn ws = writeFile fn xs
+    where xs = unlines body
+          body = concatMap doWhat ws
+          doWhat (GetFieldType {}) = []
+          doWhat (GetClosureSize {}) = []
+          doWhat (GetWord name _) = [haskellise name ++ " :: DynFlags -> Int",
+                                    haskellise name ++ " dflags = pc_" ++ name ++ " (sPlatformConstants (settings dflags))"]
+          doWhat (GetInt name _) = [haskellise name ++ " :: DynFlags -> Int",
+                                   haskellise name ++ " dflags = pc_" ++ name ++ " (sPlatformConstants (settings dflags))"]
+          doWhat (GetNatural name _) = [haskellise name ++ " :: DynFlags -> Integer",
+                                        haskellise name ++ " dflags = pc_" ++ name ++ " (sPlatformConstants (settings dflags))"]
+          doWhat (GetBool name _) = [haskellise name ++ " :: DynFlags -> Bool",
+                                     haskellise name ++ " dflags = pc_" ++ name ++ " (sPlatformConstants (settings dflags))"]
+          doWhat (StructFieldMacro {}) = []
+          doWhat (ClosureFieldMacro {}) = []
+          doWhat (ClosurePayloadMacro {}) = []
+          doWhat (FieldTypeGcptrMacro {}) = []
+
+writeHaskellExports :: FilePath -> [What Fst] -> IO ()
+writeHaskellExports fn ws = writeFile fn xs
+    where xs = unlines body
+          body = concatMap doWhat ws
+          doWhat (GetFieldType {}) = []
+          doWhat (GetClosureSize {}) = []
+          doWhat (GetWord    name _) = ["    " ++ haskellise name ++ ","]
+          doWhat (GetInt     name _) = ["    " ++ haskellise name ++ ","]
+          doWhat (GetNatural name _) = ["    " ++ haskellise name ++ ","]
+          doWhat (GetBool    name _) = ["    " ++ haskellise name ++ ","]
+          doWhat (StructFieldMacro {}) = []
+          doWhat (ClosureFieldMacro {}) = []
+          doWhat (ClosurePayloadMacro {}) = []
+          doWhat (FieldTypeGcptrMacro {}) = []
+
+writeHeader :: FilePath -> [What Snd] -> IO ()
+writeHeader fn rs = writeFile fn xs
+    where xs = unlines (headers ++ body)
+          headers = ["/* This file is created automatically.  Do not edit by hand.*/", ""]
+          body = concatMap doWhat rs
+          doWhat (GetFieldType   name (Snd v)) = ["#define " ++ name ++ " b" ++ show (v * 8)]
+          doWhat (GetClosureSize name (Snd v)) = ["#define " ++ name ++ " (SIZEOF_StgHeader+" ++ show v ++ ")"]
+          doWhat (GetWord        name (Snd v)) = ["#define " ++ name ++ " " ++ show v]
+          doWhat (GetInt         name (Snd v)) = ["#define " ++ name ++ " " ++ show v]
+          doWhat (GetNatural     name (Snd v)) = ["#define " ++ name ++ " " ++ show v]
+          doWhat (GetBool        name (Snd v)) = ["#define " ++ name ++ " " ++ show (fromEnum v)]
+          doWhat (StructFieldMacro nameBase) =
+                     ["#define " ++ nameBase ++ "(__ptr__) REP_" ++ nameBase ++ "[__ptr__+OFFSET_" ++ nameBase ++ "]"]
+          doWhat (ClosureFieldMacro nameBase) =
+                     ["#define " ++ nameBase ++ "(__ptr__) REP_" ++ nameBase ++ "[__ptr__+SIZEOF_StgHeader+OFFSET_" ++ nameBase ++ "]"]
+          doWhat (ClosurePayloadMacro nameBase) =
+                     ["#define " ++ nameBase ++ "(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_" ++ nameBase ++ " + WDS(__ix__)]"]
+          doWhat (FieldTypeGcptrMacro nameBase) =
+                     ["#define REP_" ++ nameBase ++ " gcptr"]
+
+die :: String -> IO a
+die err = do hPutStrLn stderr err
+             exitFailure
+
+execute :: FilePath -> [String] -> IO ()
+execute prog args = do ec <- rawSystem prog args
+                       unless (ec == ExitSuccess) $
+                           die ("Executing " ++ show prog ++ " failed")
+
diff --git a/utils/deriveConstants/Makefile b/utils/deriveConstants/Makefile
new file mode 100644 (file)
index 0000000..f3a9921
--- /dev/null
@@ -0,0 +1,15 @@
+# -----------------------------------------------------------------------------
+#
+# (c) 2009-1012 The University of Glasgow
+#
+# This file is part of the GHC build system.
+#
+# To understand how the build system works and how to modify it, see
+#      http://hackage.haskell.org/trac/ghc/wiki/Building/Architecture
+#      http://hackage.haskell.org/trac/ghc/wiki/Building/Modifying
+#
+# -----------------------------------------------------------------------------
+
+dir = utils/deriveConstants
+TOP = ../..
+include $(TOP)/mk/sub-makefile.mk
diff --git a/utils/deriveConstants/ghc.mk b/utils/deriveConstants/ghc.mk
new file mode 100644 (file)
index 0000000..baed84e
--- /dev/null
@@ -0,0 +1,19 @@
+# -----------------------------------------------------------------------------
+#
+# (c) 2009-2012 The University of Glasgow
+#
+# This file is part of the GHC build system.
+#
+# To understand how the build system works and how to modify it, see
+#      http://hackage.haskell.org/trac/ghc/wiki/Building/Architecture
+#      http://hackage.haskell.org/trac/ghc/wiki/Building/Modifying
+#
+# -----------------------------------------------------------------------------
+
+utils/deriveConstants_dist_MODULES = DeriveConstants
+utils/deriveConstants_dist_PROG    = deriveConstants
+utils/deriveConstants_dist_INSTALL_INPLACE = YES
+utils/deriveConstants_HC_OPTS += -package process -package containers
+
+$(eval $(call build-prog,utils/deriveConstants,dist,0))
+