From 5065f39dec026ab59c2dbc994ead6168d1d71325 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 3 Dec 2010 22:35:38 -0700 Subject: [PATCH] win64: racket3m --- collects/compiler/private/xform.rkt | 6 ++++-- src/foreign/foreign.c | 4 ++-- src/foreign/foreign.rktc | 4 ++-- src/racket/gc2/gc2.h | 2 +- src/racket/gc2/newgc.c | 4 ++++ src/racket/include/schthread.h | 1 + src/racket/src/error.c | 12 ++++++------ src/racket/src/fun.c | 4 ++-- src/racket/src/read.c | 12 ++++++------ src/worksp/gc2/make.rkt | 29 +++++++++++++++++++---------- src/worksp/mzconfig.h | 4 ++++ 11 files changed, 51 insertions(+), 31 deletions(-) diff --git a/collects/compiler/private/xform.rkt b/collects/compiler/private/xform.rkt index 3fc1fdeea0..688f1e7d9e 100644 --- a/collects/compiler/private/xform.rkt +++ b/collects/compiler/private/xform.rkt @@ -423,11 +423,13 @@ (if (eq? (system-type) 'windows) (lambda (s) (let ([split (let loop ([s s]) - (let ([m (regexp-match "([^ ]*) (.*)" s)]) + (let ([m (regexp-match #rx"((?:\"[ ()]\"|[^ ])*) (.*)" s)]) (if m (cons (cadr m) (loop (caddr m))) (list s))))]) - (apply (verbose process*) (find-executable-path (car split) #f) + (apply (verbose process*) (find-executable-path + (regexp-replace* #rx"\"([ ()])\"" (car split) "\\1") + #f) (cdr split)))) (verbose process))) diff --git a/src/foreign/foreign.c b/src/foreign/foreign.c index ed5ae66de3..ae237a110e 100644 --- a/src/foreign/foreign.c +++ b/src/foreign/foreign.c @@ -431,7 +431,7 @@ static Scheme_Object *foreign_ffi_obj_name(int argc, Scheme_Object *argv[]) /* These will make sense in Racket when longs are longer than ints (needed * for libffi's int32 types). There is no need to deal with bignums because * mzscheme's fixnums are longs. */ -inline int scheme_get_realint_val(Scheme_Object *o, int *v) +MZ_INLINE int scheme_get_realint_val(Scheme_Object *o, int *v) { if (SCHEME_INTP(o)) { uintptr_t lv = SCHEME_INT_VAL(o); @@ -442,7 +442,7 @@ inline int scheme_get_realint_val(Scheme_Object *o, int *v) return 1; } else return 0; } -inline int scheme_get_unsigned_realint_val(Scheme_Object *o, unsigned int *v) +MZ_INLINE int scheme_get_unsigned_realint_val(Scheme_Object *o, unsigned int *v) { if (SCHEME_INTP(o)) { uintptr_t lv = SCHEME_INT_VAL(o); diff --git a/src/foreign/foreign.rktc b/src/foreign/foreign.rktc index 35f2936f14..f517cfe844 100755 --- a/src/foreign/foreign.rktc +++ b/src/foreign/foreign.rktc @@ -345,7 +345,7 @@ THREAD_LOCAL_DECL(static Scheme_Hash_Table *opened_libs); /* These will make sense in Racket when longs are longer than ints (needed * for libffi's int32 types). There is no need to deal with bignums because * mzscheme's fixnums are longs. */ -inline int scheme_get_realint_val(Scheme_Object *o, int *v) +MZ_INLINE int scheme_get_realint_val(Scheme_Object *o, int *v) { if (SCHEME_INTP(o)) { uintptr_t lv = SCHEME_INT_VAL(o); @@ -356,7 +356,7 @@ inline int scheme_get_realint_val(Scheme_Object *o, int *v) return 1; } else return 0; } -inline int scheme_get_unsigned_realint_val(Scheme_Object *o, unsigned int *v) +MZ_INLINE int scheme_get_unsigned_realint_val(Scheme_Object *o, unsigned int *v) { if (SCHEME_INTP(o)) { uintptr_t lv = SCHEME_INT_VAL(o); diff --git a/src/racket/gc2/gc2.h b/src/racket/gc2/gc2.h index 57b038d877..03f91a3c8a 100644 --- a/src/racket/gc2/gc2.h +++ b/src/racket/gc2/gc2.h @@ -486,7 +486,7 @@ GC2_EXTERN void GC_adopt_message_allocator(void *msg_memory); #endif /* Macros (implementation-specific): */ -#ifdef __x86_64__ +#if defined(__x86_64__) || defined(_WIN64) # define gcLOG_WORD_SIZE 3 #else # define gcLOG_WORD_SIZE 2 diff --git a/src/racket/gc2/newgc.c b/src/racket/gc2/newgc.c index 46839ad120..1086f85f71 100644 --- a/src/racket/gc2/newgc.c +++ b/src/racket/gc2/newgc.c @@ -600,6 +600,10 @@ int GC_is_allocated(void *p) /* Allocation */ /*****************************************************************************/ +#ifdef _WIN64 +# define GC_ALIGN_SIXTEEN +#endif + /* struct objhead is defined in gc2_obj.h */ /* Make sure alloction starts out double-word aligned. The header on each allocated object is one word, so to make diff --git a/src/racket/include/schthread.h b/src/racket/include/schthread.h index 6110226377..59f81f1199 100644 --- a/src/racket/include/schthread.h +++ b/src/racket/include/schthread.h @@ -399,6 +399,7 @@ XFORM_GC_VARIABLE_STACK_THROUGH_FUNCTION; # ifdef MZ_XFORM START_XFORM_SKIP; # endif +MZ_EXTERN Thread_Local_Variables *scheme_external_get_thread_local_variables(); static __inline Thread_Local_Variables *scheme_get_thread_local_variables() { return scheme_external_get_thread_local_variables(); } diff --git a/src/racket/src/error.c b/src/racket/src/error.c index 8a3f34e291..3a24b17853 100644 --- a/src/racket/src/error.c +++ b/src/racket/src/error.c @@ -1044,7 +1044,7 @@ static char *make_arity_expect_string(const char *name, int namelen, if (arity_str) { pos = scheme_sprintf(s, slen, "%t: expects %t, given %d", - name, namelen, arity_str, arity_len, xargc); + name, (intptr_t)namelen, arity_str, (intptr_t)arity_len, xargc); } else if (minc < 0) { const char *n; int nlen; @@ -1061,20 +1061,20 @@ static char *make_arity_expect_string(const char *name, int namelen, } pos = scheme_sprintf(s, slen, "%t: no clause matching %d argument%s", - n, nlen, + n, (intptr_t)nlen, xargc, xargc == 1 ? "" : "s"); } else if (!maxc) pos = scheme_sprintf(s, slen, "%t: expects no arguments, given %d", - name, namelen, xargc); + name, (intptr_t)namelen, xargc); else if (maxc < 0) pos = scheme_sprintf(s, slen, "%t: expects at least %d argument%s, given %d", - name, namelen, xminc, (xminc == 1) ? "" : "s", xargc); + name, (intptr_t)namelen, xminc, (xminc == 1) ? "" : "s", xargc); else if (minc == maxc) pos = scheme_sprintf(s, slen, "%t: expects %d argument%s, given %d", - name, namelen, xminc, (xminc == 1) ? "" : "s", xargc); + name, (intptr_t)namelen, xminc, (xminc == 1) ? "" : "s", xargc); else pos = scheme_sprintf(s, slen, "%t: expects %d to %d arguments, given %d", - name, namelen, xminc, xmaxc, xargc); + name, (intptr_t)namelen, xminc, xmaxc, xargc); if (xargc && argv) { len /= xargc; diff --git a/src/racket/src/fun.c b/src/racket/src/fun.c index 538451085b..c4d45c658f 100644 --- a/src/racket/src/fun.c +++ b/src/racket/src/fun.c @@ -1881,10 +1881,10 @@ Scheme_Object *scheme_source_to_name(Scheme_Object *code) } if (cstx->srcloc->line >= 0) { - sprintf(buf, "%s%s%ld:%ld", + sprintf(buf, "%s%s%" PRINTF_INTPTR_SIZE_PREFIX "d:%" PRINTF_INTPTR_SIZE_PREFIX "d", src, (src[0] ? ":" : ""), cstx->srcloc->line, cstx->srcloc->col - 1); } else { - sprintf(buf, "%s%s%ld", + sprintf(buf, "%s%s%" PRINTF_INTPTR_SIZE_PREFIX "d", src, (src[0] ? "::" : ""), cstx->srcloc->pos); } diff --git a/src/racket/src/read.c b/src/racket/src/read.c index 6d1c39fe79..143cabdd73 100644 --- a/src/racket/src/read.c +++ b/src/racket/src/read.c @@ -1557,7 +1557,7 @@ read_inner_inner(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_Table * } scheme_read_err(port, stxsrc, line, col, pos, fl, ch, indentation, "read: bad input: `#%u'", - found, fl); + found, (intptr_t)fl); return NULL; } break; @@ -1650,7 +1650,7 @@ read_inner_inner(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_Table * scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), ch, indentation, "read: bad syntax `#%c%u'", - orig_ch, a, cnt); + orig_ch, a, (intptr_t)cnt); return NULL; } } @@ -1760,7 +1760,7 @@ read_inner_inner(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_Table * ch, indentation, "read: bad syntax `#ha%5%u'", str_part, - one_more, NOT_EOF_OR_SPECIAL(ch) ? 1 : 0); + one_more, (intptr_t)(NOT_EOF_OR_SPECIAL(ch) ? 1 : 0)); return NULL; } } @@ -3412,7 +3412,7 @@ read_here_string(Scheme_Object *port, Scheme_Object *stxsrc, scheme_read_err(port, stxsrc, line, col, pos, MINSPAN(port, pos, init_span), EOF, indentation, "read: found end-of-file before terminating %u%s", tag, - (tlen > 50) ? 50 : tlen, + (intptr_t)((tlen > 50) ? 50 : tlen), (tlen > 50) ? "..." : ""); return NULL; } @@ -3950,7 +3950,7 @@ read_delimited_constant(int ch, const mzchar *str, first_ch, str_part, one_more, - NOT_EOF_OR_SPECIAL(ch) ? 1 : 0); + (intptr_t)(NOT_EOF_OR_SPECIAL(ch) ? 1 : 0)); return NULL; } @@ -4098,7 +4098,7 @@ read_character(Scheme_Object *port, scheme_read_err(port, stxsrc, line, col, pos, count + 2, 0, indentation, "read: bad character constant #\\%c%u", (maxc == 4) ? 'u' : 'U', - nbuf, count); + nbuf, (intptr_t)count); return NULL; } else { ch = n; diff --git a/src/worksp/gc2/make.rkt b/src/worksp/gc2/make.rkt index fe18d36a24..5e5a957227 100644 --- a/src/worksp/gc2/make.rkt +++ b/src/worksp/gc2/make.rkt @@ -14,10 +14,15 @@ (define opt-flags "/O2 /Oy-") (define re:only #f) -(unless (find-executable-path "cl.exe" #f) - (error (string-append - "Cannot find executable \"cl.exe\".\n" - "You may need to find and run \"vsvars32.bat\"."))) +(define win64? (equal? "win32\\x86_64" (path->string (system-library-subpath #f)))) + +(define cl.exe + (let ([p (find-executable-path "cl.exe" #f)]) + (unless p + (error (string-append + "Cannot find executable \"cl.exe\".\n" + "You may need to find and run \"vsvars32.bat\"."))) + "cl.exe")) (unless (directory-exists? "xsrc") (make-directory "xsrc")) @@ -110,7 +115,8 @@ (list "--depends" "--cpp" - (format "cl.exe /MT /E ~a ~a ~a" + (format "~a /MT /E ~a ~a ~a" + cl.exe common-cpp-defs expand-extra-flags includes) @@ -139,14 +145,14 @@ (check-timestamp t2 f) (>= t t2))) deps)))) - (unless (system- (format "cl.exe ~a /MT /Zi ~a /c ~a /Fdxsrc/ /Fo~a" flags opt-flags c o)) + (unless (system- (format "~a ~a /MT /Zi ~a /c ~a /Fdxsrc/ /Fo~a" cl.exe flags opt-flags c o)) (error "failed compile")))) (define common-deps (list "../../racket/gc2/xform.rkt" "../../racket/gc2/xform-mod.rkt")) -(define (find-obj f d) (format "../~a/release/~a.obj" d f)) -(define (find-lib f d) (format "../~a/release/~a.lib" d f)) +(define (find-obj f d) (format "../~a/~arelease/~a.obj" d (if win64? "x64/" "") f)) +(define (find-lib f d) (format "../~a/~arelease/~a.lib" d (if win64? "x64/" "") f)) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -247,8 +253,10 @@ (> (file-or-directory-modify-seconds f) ms)) objs) - (unless (system- (format "cl.exe ~a /MT /Zi /Fe~a ~a ~a /link ~a~a~a" + (unless (system- (format "~a ~a ~a /MT /Zi /Fe~a ~a ~a /link ~a~a~a" + cl.exe (if exe? "" "/LD /DLL") + (if win64? "/MACHINE:x64" "") dll (let loop ([objs (append objs sys-libs)]) (if (null? objs) @@ -338,7 +346,8 @@ "../../../GRacket.exe" " /subsystem:windows" #t)) (system- "mt.exe -manifest ../../../GRacket.exe.manifest -outputresource:../../../GRacket.exe;1") -(system- "cl.exe /MT /O2 /DMZ_PRECISE_GC /I../../racket/include /I.. /c ../../racket/dynsrc/mzdyn.c /Fomzdyn3m.obj") +(system- (format "~a /MT /O2 /DMZ_PRECISE_GC /I../../racket/include /I.. /c ../../racket/dynsrc/mzdyn.c /Fomzdyn3m.obj" + cl.exe)) (system- "lib.exe -def:../../racket/dynsrc/mzdyn.def -out:mzdyn3m.lib") (define (copy-file/diff src dest) diff --git a/src/worksp/mzconfig.h b/src/worksp/mzconfig.h index 1fb7254bdc..f449d74d7e 100644 --- a/src/worksp/mzconfig.h +++ b/src/worksp/mzconfig.h @@ -25,6 +25,10 @@ /* The size of a `long long', as computed by sizeof. */ #undef SIZEOF_LONG_LONG +#ifdef _WIN64 +# define SIZEOF_VOID_P 8 +#endif + /* Direction of stack growth: 1 = up, -1 = down, 0 = unknown */ #define STACK_DIRECTION -1