[Chicken-hackers] [PATCH] Win64 support

[Felix]

The attached patch adds basic support for 64-bit Windows. Everything
compiles and installs and the test-suite seems to run ok. Running
"chicken-install -test numbers" gives a crash, which I'm going to
investigate.

Has been tested with Windows 7 and the SJLJ mingw64 build from
the mingw64-builds project. Fixes #950.


cheers,
felix

>From 967ccc4384bdb743bb09de8092a9c9254dd21f16 Mon Sep 17 00:00:00 2001
From: felix <address@hidden>
Date: Tue, 27 Nov 2012 21:22:40 +0100
Subject: [PATCH] Added support for 64-bit Windows. Since Win64 is an LLP64 
platform,
 references to "long" and some other data-types and C-runtime library
 functions have been aliased with macros.

---
 README       |   13 +++++++++++
 chicken.h    |   49 +++++++++++++++++++++++++++++++++--------
 posixwin.scm |   22 +++++++++---------
 runtime.c    |   67 +++++++++++++++++++++++++++++++++++----------------------
 tcp.scm      |    8 +++++-
 5 files changed, 110 insertions(+), 49 deletions(-)

diff --git a/README b/README
index d0190e0..c933bff 100644
--- a/README
+++ b/README
@@ -236,6 +236,11 @@
          LLVM version of gcc and with "clang", the LLVM-based C compiler,
          just set C_COMPILER to "llvm-gcc" or "clang".
 
+        LINKER=
+         Selects the linker to be used for creating executables and 
+         dynamic libraries from compiled C code. This should normally
+         be the same as C_COMPILER.
+
        PROFILE_OBJECTS=
          This variable allows you to profile (parts of) Chicken itself.
          Just pass in a whitespace-separated list of objects, without
@@ -481,6 +486,14 @@
            MSYS tools (in case you have some of them, in particular the
            sh.exe UNIX shell) are *NOT* visible in your PATH.
 
+         - 64-bit Windows is supported, invoke mingw32-make with the
+           "ARCH=x86-64" argument (this is currently not detected
+           auto- matically). The build has been tested on Windows 7
+           with the SJLJ binary package from "MinGW-builds", which
+           can be found here:
+
+           http://sourceforge.net/projects/mingwbuilds/
+
          - Cygwin will not be able to find the chicken shared libraries
            until Windows is rebooted.
 
diff --git a/chicken.h b/chicken.h
index 516b607..e128332 100644
--- a/chicken.h
+++ b/chicken.h
@@ -68,6 +68,8 @@
 #   define C_SIXTY_FOUR
 # elif defined(__mips64) && (!defined(__GNUC__) || _MIPS_SZPTR == 64)
 #   define C_SIXTY_FOUR
+# elif defined(__MINGW64__)
+#   define C_SIXTY_FOUR
 # endif
 #endif
 
@@ -91,6 +93,10 @@
 # define C_SOLARIS
 #endif
 
+#ifdef __MINGW64__
+# define C_LLP
+#endif
+
 
 /* Headers */
 
@@ -497,7 +503,11 @@ static inline int isinf_ld (long double x)
 #define C_F64_LOCATIVE            9
 
 #ifdef C_SIXTY_FOUR
-# define C_word                   long
+# ifdef C_LLP
+#  define C_word                  __int64
+# else
+#  define C_word                  long
+# endif
 # define C_u32                    uint32_t
 # define C_s32                    int32_t
 #else
@@ -520,6 +530,18 @@ static inline int isinf_ld (long double x)
 #define C_uword                   unsigned C_word
 #define C_header                  C_uword
 
+#if defined(C_LLP) && defined(C_SIXTY_FOUR)
+# define C_long                   __int64
+# define C_LONG_MAX               LONG_LONG_MAX
+# define C_LONG_MIN               LONG_LONG_MIN
+#else
+# define C_long                   long
+# define C_LONG_MAX               LONG_MAX
+# define C_LONG_MIN               LONG_MIN
+#endif
+
+#define C_ulong                   unsigned C_long
+
 #ifdef __cplusplus
 # define C_text(x)                ((C_char *)(x))
 #else
@@ -833,6 +855,7 @@ DECL_C_PROC_p0 (128,  1,0,0,0,0,0,0,0)
 # define C_realloc                  realloc
 # define C_strdup                   strdup
 # define C_strtol                   strtol
+# define C_strtoll                  strtoll
 # define C_strtod                   strtod
 # define C_strtoul                  strtoul
 # define C_fopen                    fopen
@@ -929,6 +952,12 @@ extern double trunc(double);
 # include "chicken-libc-stubs.h"
 #endif
 
+#ifdef C_LLP
+# define C_strtow                  C_strtoll
+#else
+# define C_strtow                  C_strtol
+#endif
+
 #define C_id(x)                    (x)
 #define C_return(x)                return(x)
 #define C_resize_stack(n)          C_do_resize_stack(n)
@@ -1525,7 +1554,7 @@ C_varextern C_TLS C_word
   *C_temporary_stack,
   *C_temporary_stack_bottom,
   *C_stack_limit;
-C_varextern C_TLS long
+C_varextern C_TLS C_long
   C_timer_interrupt_counter,
   C_initial_timer_interrupt_period;
 C_varextern C_TLS C_byte
@@ -1538,7 +1567,7 @@ C_varextern C_TLS int C_gui_mode;
 
 C_varextern C_TLS void (C_fcall *C_restart_trampoline)(void *proc) C_regparm 
C_noret;
 C_varextern C_TLS void (*C_pre_gc_hook)(int mode);
-C_varextern C_TLS void (*C_post_gc_hook)(int mode, long ms);
+C_varextern C_TLS void (*C_post_gc_hook)(int mode, C_long ms);
 C_varextern C_TLS void (*C_panic_hook)(C_char *msg);
 
 C_varextern C_TLS int
@@ -1756,7 +1785,7 @@ C_fctexport void C_ccall C_filter_heap_objects(C_word x, 
C_word closure, C_word
 C_fctexport C_word *C_a_i(C_word **a, int n);
 #endif
 
-C_fctexport time_t C_fcall C_seconds(long *ms) C_regparm;
+C_fctexport time_t C_fcall C_seconds(C_long *ms) C_regparm;
 C_fctexport C_word C_a_i_list(C_word **a, int c, ...);
 C_fctexport C_word C_a_i_string(C_word **a, int c, ...);
 C_fctexport C_word C_a_i_record(C_word **a, int c, ...);
@@ -2052,14 +2081,14 @@ C_inline C_word C_unsigned_int_to_num(C_word **ptr, 
C_uword n)
 }
 
 
-C_inline C_word C_long_to_num(C_word **ptr, long n)
+C_inline C_word C_long_to_num(C_word **ptr, C_long n)
 {
   if(C_fitsinfixnump(n)) return C_fix(n);
   else return C_flonum(ptr, (double)n);
 }
 
 
-C_inline C_word C_unsigned_long_to_num(C_word **ptr, unsigned long n)
+C_inline C_word C_unsigned_long_to_num(C_word **ptr, C_ulong n)
 {
   if(C_ufitsinfixnump(n)) return C_fix(n);
   else return C_flonum(ptr, (double)n);
@@ -2118,17 +2147,17 @@ C_inline void *C_scheme_or_c_pointer(C_word x)
 }
 
 
-C_inline long C_num_to_long(C_word x)
+C_inline C_long C_num_to_long(C_word x)
 {
   if(x & C_FIXNUM_BIT) return C_unfix(x);
-  else return (long)C_flonum_magnitude(x);
+  else return (C_long)C_flonum_magnitude(x);
 }
 
 
-C_inline unsigned long C_num_to_unsigned_long(C_word x)
+C_inline C_ulong C_num_to_unsigned_long(C_word x)
 {
   if(x & C_FIXNUM_BIT) return C_unfix(x);
-  else return (unsigned long)C_flonum_magnitude(x);
+  else return (C_ulong)C_flonum_magnitude(x);
 }
 
 
diff --git a/posixwin.scm b/posixwin.scm
index 5b5d0b7..982cd2c 100644
--- a/posixwin.scm
+++ b/posixwin.scm
@@ -477,7 +477,7 @@ redir_io()
     return 1;
 }
 
-static int C_fcall
+static C_word C_fcall
 run_process(char *cmdline)
 {
     PROCESS_INFORMATION pi;
@@ -501,14 +501,14 @@ run_process(char *cmdline)
        CloseHandle(C_rd0);
        CloseHandle(C_wr1);
        C_rd0 = C_wr1 = INVALID_HANDLE_VALUE;
-       return (int)pi.hProcess;
+       return (C_word)pi.hProcess;
     }
     else
        return set_last_errno();
 }
 
-static int C_fcall
-pipe_write(int hpipe, void* buf, int count)
+static C_word C_fcall
+pipe_write(C_word hpipe, void* buf, int count)
 {
     DWORD done = 0;
     if (WriteFile((HANDLE)hpipe, buf, count, &done, NULL))
@@ -517,8 +517,8 @@ pipe_write(int hpipe, void* buf, int count)
        return set_last_errno();
 }
 
-static int C_fcall
-pipe_read(int hpipe)
+static C_word C_fcall
+pipe_read(C_word hpipe)
 {
     DWORD done = 0;
     /* TODO:
@@ -536,7 +536,7 @@ pipe_read(int hpipe)
 }
 
 static int C_fcall
-pipe_ready(int hpipe)
+pipe_ready(C_word hpipe)
 {
     DWORD avail = 0;
     if (PeekNamedPipe((HANDLE)hpipe, NULL, 0, NULL, &avail, NULL) && avail)
@@ -561,7 +561,7 @@ pipe_ready(int hpipe)
 #define close_handle(h) CloseHandle((HANDLE)h)
 
 static int C_fcall
-process_wait(int h, int t)
+process_wait(C_word h, C_word t)
 {
     if (WaitForSingleObject((HANDLE)h, (t ? 0 : INFINITE)) == WAIT_OBJECT_0)
     {
@@ -764,7 +764,7 @@ get_netinfo()
 */
 static int C_fcall
 C_process(const char * app, const char * cmdlin, const char ** env,
-         int * phandle,
+         C_word * phandle,
          int * pstdin_fd, int * pstdout_fd, int * pstderr_fd,
          int params)
 {
@@ -802,7 +802,7 @@ C_process(const char * app, const char * cmdlin, const char 
** env,
                HANDLE parent_end;
                if (modes[i]=='r') { child_io_handles[i]=a; parent_end=b; }
                else               { parent_end=a; child_io_handles[i]=b; }
-               success = (io_fds[i] = _open_osfhandle((long)parent_end,0)) >= 
0;
+               success = (io_fds[i] = _open_osfhandle((C_word)parent_end,0)) 
>= 0;
            }
        }
     }
@@ -875,7 +875,7 @@ C_process(const char * app, const char * cmdlin, const char 
** env,
 
     if (success)
     {
-       *phandle = (int)child_process;
+       *phandle = (C_word)child_process;
        *pstdin_fd = io_fds[0];
        *pstdout_fd = io_fds[1];
        *pstderr_fd = io_fds[2];
diff --git a/runtime.c b/runtime.c
index 48ec0e2..f4babdf 100644
--- a/runtime.c
+++ b/runtime.c
@@ -196,6 +196,12 @@ extern void _C_do_apply_hack(void *proc, C_word *args, int 
count) C_noret;
 # define UWORD_COUNT_FORMAT_STRING     "%u"
 #endif
 
+#ifdef C_LLP
+# define LONG_FORMAT_STRING            "%lldf"
+#else
+# define LONG_FORMAT_STRING            "%ld"
+#endif
+
 #define GC_MINOR           0
 #define GC_MAJOR           1
 #define GC_REALLOC         2
@@ -205,7 +211,7 @@ extern void _C_do_apply_hack(void *proc, C_word *args, int 
count) C_noret;
 
 #define nmax(x, y)                   ((x) > (y) ? (x) : (y))
 #define nmin(x, y)                   ((x) < (y) ? (x) : (y))
-#define percentage(n, p)             ((long)(((double)(n) * (double)p) / 100))
+#define percentage(n, p)             ((C_long)(((double)(n) * (double)p) / 
100))
 
 #define is_fptr(x)                   (((x) & C_GC_FORWARDING_BIT) != 0)
 #define ptr_to_fptr(x)               ((((x) >> FORWARDING_BIT_SHIFT) & 1) | 
C_GC_FORWARDING_BIT | ((x) & ~1))
@@ -260,6 +266,10 @@ extern void _C_do_apply_hack(void *proc, C_word *args, int 
count) C_noret;
 
 #define C_pte(name)                  pt[ i ].id = #name; pt[ i++ ].ptr = (void 
*)name;
 
+#ifndef SIGBUS
+# define SIGBUS                      0
+#endif
+
 
 /* Type definitions: */
 
@@ -313,7 +323,7 @@ C_TLS C_word
   *C_temporary_stack_bottom,
   *C_temporary_stack_limit,
   *C_stack_limit;
-C_TLS long
+C_TLS C_long
   C_timer_interrupt_counter,
   C_initial_timer_interrupt_period;
 C_TLS C_byte 
@@ -326,7 +336,7 @@ C_TLS int (*C_gc_mutation_hook)(C_word *slot, C_word val);
 C_TLS void (*C_gc_trace_hook)(C_word *var, int mode);
 C_TLS void (*C_panic_hook)(C_char *msg) = NULL;
 C_TLS void (*C_pre_gc_hook)(int mode) = NULL;
-C_TLS void (*C_post_gc_hook)(int mode, long ms) = NULL;
+C_TLS void (*C_post_gc_hook)(int mode, C_long ms) = NULL;
 C_TLS void (C_fcall *C_restart_trampoline)(void *proc) C_regparm C_noret;
 
 C_TLS int
@@ -1366,7 +1376,7 @@ C_word arg_val(C_char *arg)
 {
   int len;
   C_char *end;
-  long val, mul = 1;
+  C_long val, mul = 1;
 
   if (arg == NULL) panic(C_text("illegal runtime-option argument"));
       
@@ -1387,7 +1397,7 @@ C_word arg_val(C_char *arg)
   default: mul = 1;
   }
 
-  val = strtol(arg, &end, 10);
+  val = C_strtow(arg, &end, 10);
 
   if((mul != 1 ? end[ 1 ] != '\0' : end[ 0 ] != '\0')) 
     panic(C_text("invalid runtime-option argument suffix"));
@@ -1418,7 +1428,7 @@ C_word CHICKEN_run(void *toplevel)
   stack_bottom = C_stack_pointer;
 
   if(debug_mode)
-    C_dbg(C_text("debug"), C_text("stack bottom is 0x%lx.\n"), 
(long)stack_bottom);
+    C_dbg(C_text("debug"), C_text("stack bottom is 0x%lx.\n"), 
(C_word)stack_bottom);
 
   /* The point of (usually) no return... */
 #ifdef HAVE_SIGSETJMP
@@ -1811,7 +1821,7 @@ C_regparm double C_fcall C_milliseconds(void)
 }
 
 
-C_regparm time_t C_fcall C_seconds(long *ms)
+C_regparm time_t C_fcall C_seconds(C_long *ms)
 {
 #ifdef C_NONUNIX
   if(ms != NULL) *ms = 0;
@@ -3064,7 +3074,7 @@ C_regparm void C_fcall C_reclaim(void *trampoline, void 
*proc)
 
   if(gc_mode == GC_MAJOR) gc_count_1 = 0;
 
-  if(C_post_gc_hook != NULL) C_post_gc_hook(gc_mode, (long)tgc);
+  if(C_post_gc_hook != NULL) C_post_gc_hook(gc_mode, (C_long)tgc);
 
   /* Unwind stack completely */
 #ifdef HAVE_SIGSETJMP
@@ -3279,10 +3289,10 @@ C_regparm void C_fcall C_rereclaim2(C_uword size, int 
double_plus)
   if(gc_report_flag) {
     C_dbg(C_text("GC"), C_text("(old) fromspace: \tstart=" UWORD_FORMAT_STRING 
                               ", \tlimit=" UWORD_FORMAT_STRING "\n"),
-         (long)fromspace_start, (long)C_fromspace_limit);
+         (C_word)fromspace_start, (C_word)C_fromspace_limit);
     C_dbg(C_text("GC"), C_text("(old) tospace:   \tstart=" UWORD_FORMAT_STRING
                               ", \tlimit=" UWORD_FORMAT_STRING "\n"),
-         (long)tospace_start, (long)tospace_limit);
+         (C_word)tospace_start, (C_word)tospace_limit);
   }
 
   heap_size = size;
@@ -3397,10 +3407,10 @@ C_regparm void C_fcall C_rereclaim2(C_uword size, int 
double_plus)
     C_dbg(C_text("GC"), C_text("resized heap to %d bytes\n"), heap_size);
     C_dbg(C_text("GC"), C_text("(new) fromspace: \tstart=" UWORD_FORMAT_STRING 
                               ", \tlimit=" UWORD_FORMAT_STRING "\n"),
-         (long)fromspace_start, (long)C_fromspace_limit);
+         (C_word)fromspace_start, (C_word)C_fromspace_limit);
     C_dbg(C_text("GC"), C_text("(new) tospace:   \tstart=" UWORD_FORMAT_STRING
                               ", \tlimit=" UWORD_FORMAT_STRING "\n"),
-         (long)tospace_start, (long)tospace_limit);
+         (C_word)tospace_start, (C_word)tospace_limit);
   }
 
   if(C_post_gc_hook != NULL) C_post_gc_hook(GC_REALLOC, 0);
@@ -4454,7 +4464,7 @@ C_regparm C_word C_fcall 
C_establish_signal_handler(C_word signum, C_word reason
 C_regparm C_word C_fcall C_copy_block(C_word from, C_word to)
 {
   int n = C_header_size(from);
-  long bytes;
+  C_long bytes;
 
   if(C_header_bits(from) & C_BYTEBLOCK_BIT) {
     bytes = n;
@@ -4472,7 +4482,7 @@ C_regparm C_word C_fcall C_copy_block(C_word from, C_word 
to)
 C_regparm C_word C_fcall C_evict_block(C_word from, C_word ptr)
 {
   int n = C_header_size(from);
-  long bytes;
+  C_long bytes;
   C_word *p = (C_word *)C_pointer_address(ptr);
 
   if(C_header_bits(from) & C_BYTEBLOCK_BIT) bytes = n;
@@ -7100,7 +7110,7 @@ void C_ccall C_gc(C_word c, C_word closure, C_word k, ...)
 {
   int f;
   C_word arg;
-  long size = 0;
+  C_long size = 0;
   va_list v;
 
   va_start(v, k);
@@ -7546,7 +7556,7 @@ static int from_n_nary(C_char *str, int base, double *r)
 
 C_regparm C_word C_fcall convert_string_to_number(C_char *str, int radix, 
C_word *fix, double *flo)
 {
-  unsigned long ln;
+  C_ulong ln;
   C_word n;
   C_char *eptr, *eptr2;
   double fn;
@@ -7578,9 +7588,9 @@ C_regparm C_word C_fcall convert_string_to_number(C_char 
*str, int radix, C_word
   if(C_strpbrk(str, "xX\0") != NULL) return 0;
 
   errno = 0;
-  n = C_strtol(str, &eptr, radix);
+  n = C_strtow(str, &eptr, radix);
   
-  if(((n == LONG_MAX || n == LONG_MIN) && errno == ERANGE) || *eptr != '\0') {
+  if(((n == C_LONG_MAX || n == C_LONG_MIN) && errno == ERANGE) || *eptr != 
'\0') {
     if(radix != 10)
       return from_n_nary(str, radix, flo) ? 2 : 0;
 
@@ -7659,9 +7669,9 @@ void C_ccall C_number_to_string(C_word c, C_word closure, 
C_word k, C_word num,
 
     switch(radix) {
 #ifdef C_SIXTY_FOUR
-    case 8: C_sprintf(p = buffer + 1, C_text("%lo"), num); break;
-    case 10: C_sprintf(p = buffer + 1, C_text("%ld"), num); break;
-    case 16: C_sprintf(p = buffer + 1, C_text("%lx"), num); break;
+    case 8: C_sprintf(p = buffer + 1, C_text("%llo"), num); break;
+    case 10: C_sprintf(p = buffer + 1, C_text("%lld"), num); break;
+    case 16: C_sprintf(p = buffer + 1, C_text("%llx"), num); break;
 #else
     case 8: C_sprintf(p = buffer + 1, C_text("%o"), num); break;
     case 10: C_sprintf(p = buffer + 1, C_text("%d"), num); break;
@@ -7748,8 +7758,9 @@ C_fixnum_to_string(C_word c, C_word self, C_word k, 
C_word num)
   C_word *a, s;
   int n;
 
+  /*XXX is this necessary? */
 #ifdef C_SIXTY_FOUR
-  C_sprintf(buffer, C_text("%ld"), C_unfix(num));
+  C_sprintf(buffer, C_text(LONG_FORMAT_STRING), C_unfix(num));
 #else
   C_sprintf(buffer, C_text("%d"), C_unfix(num));
 #endif
@@ -8779,7 +8790,11 @@ C_regparm C_word C_fcall C_i_o_fixnum_times(C_word n1, 
C_word n2)
   C_word x1, x2;
   C_uword x1u, x2u;
 #ifdef C_SIXTY_FOUR
+# ifdef C_LLP
+  C_uword c = 1ULL<<63ULL;
+# else
   C_uword c = 1UL<<63UL;
+# endif
 #else
   C_uword c = 1UL<<31UL;
 #endif
@@ -8804,7 +8819,7 @@ C_regparm C_word C_fcall C_i_o_fixnum_quotient(C_word n1, 
C_word n2)
 {
   C_word x1, x2;
 #ifdef C_SIXTY_FOUR
-  static long eight_0 = 0x8000000000000000L;
+  static C_long eight_0 = 0x8000000000000000L;
 #else
   static int eight_0 = 0x80000000;
 #endif
@@ -8891,7 +8906,7 @@ static C_regparm C_uword C_fcall decode_size(C_char **str)
 static C_regparm C_word C_fcall decode_literal2(C_word **ptr, C_char **str,
                                                C_word *dest)
 {
-  unsigned long bits = *((*str)++) & 0xff;
+  C_ulong bits = *((*str)++) & 0xff;
   C_word *data, *dptr, val;
   C_uword size;
 
@@ -9121,10 +9136,10 @@ C_dump_heap_state(C_word c, C_word closure, C_word k)
 }
 
 
-static unsigned long
+static C_ulong
 hdump_hash(C_word key)
 {
-  return (unsigned long)key % HDUMP_TABLE_SIZE;
+  return (C_ulong)key % HDUMP_TABLE_SIZE;
 }
 
 
diff --git a/tcp.scm b/tcp.scm
index 238923c..490ed8d 100644
--- a/tcp.scm
+++ b/tcp.scm
@@ -44,8 +44,12 @@
 # define socklen_t       int
 static WSADATA wsa;
 # define fcntl(a, b, c)  0
-# define EWOULDBLOCK     0
-# define EINPROGRESS     0
+# ifndef EWOULDBLOCK
+#  define EWOULDBLOCK     0
+# endif
+# ifndef EINPROGRESS
+#  define EINPROGRESS     0
+# endif
 # define typecorrect_getsockopt(socket, level, optname, optval, optlen)        
\
     getsockopt(socket, level, optname, (char *)optval, optlen)
 #else
-- 
1.7.0.4