Starting work on Win64 port

Makefile

@@ -170,7 +170,7 @@ vm/resources.o:
 	$(CC) -c $(CFLAGS) -o $@ $<
 
 .S.o:
-	$(CC) -c $(CFLAGS) -o $@ $<
+	$(CC) -x assembler-with-cpp -c $(CFLAGS) -o $@ $<
 
 .m.o:
 	$(CC) -c $(CFLAGS) -o $@ $<

basis/alien/c-types/c-types.factor

@@ -435,7 +435,7 @@ M: long-long-type box-return ( type -- )
         [ >float ] >>unboxer-quot
     "double" define-primitive-type
 
-    os winnt? cpu x86.64? and "longlong" "long" ? "ptrdiff_t" typedef
+    "long" "ptrdiff_t" typedef
 
     "ulong" "size_t" typedef
 ] with-compilation-unit

basis/bootstrap/image/image.factor

@@ -25,7 +25,7 @@ IN: bootstrap.image
 : images ( -- seq )
     {
         "x86.32"
-        "x86.64"
+        "winnt-x86.64" "unix-x86.64"
         "linux-ppc" "macosx-ppc"
     } ;
 

basis/cpu/x86/32/32.factor

@@ -26,6 +26,8 @@ M: x86.32 stack-reg ESP ;
 M: x86.32 temp-reg-1 EAX ;
 M: x86.32 temp-reg-2 ECX ;
 
+M: x86.32 reserved-area-size 0 ;
+
 M: x86.32 %alien-global 0 [] MOV rc-absolute-cell rel-dlsym ;
 
 M: x86.32 %alien-invoke (CALL) rel-dlsym ;

basis/cpu/x86/32/bootstrap.factor

@@ -6,6 +6,7 @@ IN: bootstrap.x86
 
 4 \ cell set
 
+: stack-frame-size ( -- n ) 4 bootstrap-cells ;
 : shift-arg ( -- reg ) ECX ;
 : div-arg ( -- reg ) EAX ;
 : mod-arg ( -- reg ) EDX ;

basis/cpu/x86/64/64.factor

@@ -24,14 +24,12 @@ M: x86.64 stack-reg RSP ;
 M: x86.64 temp-reg-1 RAX ;
 M: x86.64 temp-reg-2 RCX ;
 
+: param-reg-1 int-regs param-regs first ; inline
+: param-reg-2 int-regs param-regs second ; inline
+
 M: int-regs return-reg drop RAX ;
-M: int-regs param-regs drop { RDI RSI RDX RCX R8 R9 } ;
-
 M: float-regs return-reg drop XMM0 ;
 
-M: float-regs param-regs
-    drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
-
 M: x86.64 rel-literal-x86 rc-relative rel-literal ;
 
 M: x86.64 %prologue ( n -- )
@@ -90,7 +88,7 @@ M: struct-type flatten-value-type ( type -- seq )
 
 M: x86.64 %prepare-unbox ( -- )
     ! First parameter is top of stack
-    RDI R14 [] MOV
+    param-reg-1 R14 [] MOV
     R14 cell SUB ;
 
 M: x86.64 %unbox ( n reg-class func -- )
@@ -103,27 +101,27 @@ M: x86.64 %unbox-long-long ( n func -- )
     int-regs swap %unbox ;
 
 : %unbox-struct-field ( c-type i -- )
-    ! Alien must be in RDI.
+    ! Alien must be in param-reg-1.
-    RDI swap cells [+] swap reg-class>> {
+    param-reg-1 swap cells [+] swap reg-class>> {
         { int-regs [ int-regs get pop swap MOV ] }
         { double-float-regs [ float-regs get pop swap MOVSD ] }
     } case ;
 
 M: x86.64 %unbox-small-struct ( c-type -- )
-    ! Alien must be in RDI.
+    ! Alien must be in param-reg-1.
     "alien_offset" f %alien-invoke
-    ! Move alien_offset() return value to RDI so that we don't
+    ! Move alien_offset() return value to param-reg-1 so that we don't
     ! clobber it.
-    RDI RAX MOV
+    param-reg-1 RAX MOV
     [
         flatten-small-struct [ %unbox-struct-field ] each-index
     ] with-return-regs ;
 
 M: x86.64 %unbox-large-struct ( n c-type -- )
-    ! Source is in RDI
+    ! Source is in param-reg-1
     heap-size
     ! Load destination address
-    RSI rot stack@ LEA
+    param-reg-2 rot stack@ LEA
     ! Load structure size
     RDX swap MOV
     ! Copy the struct to the C stack
@@ -160,8 +158,8 @@ M: x86.64 %box-small-struct ( c-type -- )
     [
         [ flatten-small-struct [ %box-struct-field ] each-index ]
         [ RDX swap heap-size MOV ] bi
-        RDI 0 box-struct-field@ MOV
+        param-reg-1 0 box-struct-field@ MOV
-        RSI 1 box-struct-field@ MOV
+        param-reg-2 1 box-struct-field@ MOV
         "box_small_struct" f %alien-invoke
     ] with-return-regs ;
 
@@ -170,9 +168,9 @@ M: x86.64 %box-small-struct ( c-type -- )
 
 M: x86.64 %box-large-struct ( n c-type -- )
     ! Struct size is parameter 2
-    RSI swap heap-size MOV
+    param-reg-2 swap heap-size MOV
     ! Compute destination address
-    RDI swap struct-return@ LEA
+    param-reg-1 swap struct-return@ LEA
     ! Copy the struct from the C stack
     "box_value_struct" f %alien-invoke ;
 
@@ -200,7 +198,7 @@ M: x86.64 %alien-indirect ( -- )
     RBP CALL ;
 
 M: x86.64 %alien-callback ( quot -- )
-    RDI swap %load-indirect
+    param-reg-1 swap %load-indirect
     "c_to_factor" f %alien-invoke ;
 
 M: x86.64 %callback-value ( ctype -- )
@@ -208,11 +206,11 @@ M: x86.64 %callback-value ( ctype -- )
     %prepare-unbox
     ! Save top of data stack
     RSP 8 SUB
-    RDI PUSH
+    param-reg-1 PUSH
     ! Restore data/call/retain stacks
     "unnest_stacks" f %alien-invoke
-    ! Put former top of data stack in RDI
+    ! Put former top of data stack in param-reg-1
-    RDI POP
+    param-reg-1 POP
     RSP 8 ADD
     ! Unbox former top of data stack to return registers
     unbox-return ;
@@ -223,3 +221,10 @@ enable-alien-4-intrinsics
 
 ! SSE2 is always available on x86-64.
 enable-float-intrinsics
+
+USE: vocabs.loader
+
+{
+    { [ os unix? ] [ "cpu.x86.64.unix" require ] }
+    { [ os winnt? ] [ "cpu.x86.64.winnt" require ] }
+} cond

basis/cpu/x86/64/bootstrap.factor

@@ -9,8 +9,6 @@ IN: bootstrap.x86
 : shift-arg ( -- reg ) RCX ;
 : div-arg ( -- reg ) RAX ;
 : mod-arg ( -- reg ) RDX ;
-: arg0 ( -- reg ) RDI ;
-: arg1 ( -- reg ) RSI ;
 : temp-reg ( -- reg ) RBX ;
 : stack-reg ( -- reg ) RSP ;
 : ds-reg ( -- reg ) R14 ;

basis/cpu/x86/64/unix/bootstrap.factor

@@ -0,0 +1,12 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: bootstrap.image.private kernel namespaces system
+cpu.x86.assembler layouts vocabs parser ;
+IN: bootstrap.x86
+
+: stack-frame-size ( -- n ) 4 bootstrap-cells ;
+: arg0 ( -- reg ) RDI ;
+: arg1 ( -- reg ) RSI ;
+
+<< "resource:basis/cpu/x86/64/bootstrap.factor" parsed-file parsed >>
+call

basis/cpu/x86/64/unix/unix.factor

@@ -0,0 +1,12 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel layouts system compiler.cfg.registers
+cpu.architecture cpu.x86.assembler ;
+IN: cpu.x86.64.unix
+
+M: int-regs param-regs drop { RDI RSI RDX RCX R8 R9 } ;
+
+M: float-regs param-regs
+    drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
+
+M: x86.64 reserved-area-size 0 ;

basis/cpu/x86/64/winnt/bootstrap.factor

@@ -0,0 +1,12 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: bootstrap.image.private kernel namespaces system
+cpu.x86.assembler layouts vocabs parser ;
+IN: bootstrap.x86
+
+: stack-frame-size ( -- n ) 8 bootstrap-cells ;
+: arg0 ( -- reg ) RCX ;
+: arg1 ( -- reg ) RDX ;
+
+<< "resource:basis/cpu/x86/64/bootstrap.factor" parse-file parsed >>
+call

basis/cpu/x86/64/winnt/winnt.factor

@@ -0,0 +1,17 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel layouts system alien.c-types compiler.cfg.registers
+cpu.architecture cpu.x86.assembler cpu.x86 ;
+IN: cpu.x86.64.winnt
+
+M: int-regs param-regs drop { RCX RDX R8 R9 } ;
+
+M: float-regs param-regs drop { XMM0 XMM1 XMM2 XMM3 } ;
+
+M: x86.64 reserved-area-size 4 cells ;
+
+<<
+"longlong" "ptrdiff_t" typedef
+"int" "long" typedef
+"uint" "ulong" typedef
+>>

basis/cpu/x86/bootstrap.factor

@@ -10,8 +10,6 @@ big-endian off
 
 1 jit-code-format set
 
-: stack-frame-size ( -- n ) 4 bootstrap-cells ;
-
 [
     ! Load word
     temp-reg 0 MOV
@@ -30,7 +28,7 @@ big-endian off
     temp-reg 0 MOV                             ! load XT
     stack-frame-size PUSH                      ! save stack frame size
     temp-reg PUSH                              ! push XT
-    arg1 PUSH                                  ! alignment
+    stack-reg stack-frame-size 3 bootstrap-cells - SUB   ! alignment
 ] rc-absolute-cell rt-label 1 rex-length + jit-prolog jit-define
 
 [
@@ -302,14 +300,14 @@ big-endian off
     shift-arg ds-reg [] MOV                    ! load shift count
     shift-arg tag-bits get SAR                 ! untag shift count
     ds-reg bootstrap-cell SUB                  ! adjust stack pointer
-    arg0 ds-reg [] MOV                         ! load value
+    temp-reg ds-reg [] MOV                     ! load value
-    arg1 arg0 MOV                              ! make a copy
+    arg1 temp-reg MOV                          ! make a copy
     arg1 CL SHL                                ! compute positive shift value in arg1
     shift-arg NEG                              ! compute negative shift value in arg0
-    arg0 CL SAR
+    temp-reg CL SAR
-    arg0 tag-mask get bitnot AND
+    temp-reg tag-mask get bitnot AND
     shift-arg 0 CMP                            ! if shift count was negative, move arg0 to arg1
-    arg1 arg0 CMOVGE
+    arg1 temp-reg CMOVGE
     ds-reg [] arg1 MOV                         ! push to stack
 ] f f f \ fixnum-shift-fast define-sub-primitive
 

basis/cpu/x86/x86.factor

@@ -39,12 +39,15 @@ M: x86 %inc-r ( n -- ) rs-reg (%inc) ;
 : align-stack ( n -- n' )
     os macosx? cpu x86.64? or [ 16 align ] when ;
 
+HOOK: reserved-area-size cpu ( -- n )
+
 M: x86 stack-frame-size ( stack-frame -- i )
     [ spill-counts>> [ swap reg-size * ] { } assoc>map sum ]
     [ params>> ]
     [ return>> ]
     tri + +
     3 cells +
+    reserved-area-size +
     align-stack ;
 
 M: x86 %call ( label -- ) CALL ;
@@ -465,7 +468,7 @@ M: x86 %compare-float-branch ( label cc src1 src2 -- )
 : stack@ ( n -- op ) stack-reg swap [+] ;
 
 : spill-integer-base ( stack-frame -- n )
-    [ params>> ] [ return>> ] bi + ;
+    [ params>> ] [ return>> ] bi + reserved-area-size + ;
 
 : spill-integer@ ( n -- op )
     cells
@@ -473,10 +476,9 @@ M: x86 %compare-float-branch ( label cc src1 src2 -- )
     + stack@ ;
 
 : spill-float-base ( stack-frame -- n )
+    [ spill-integer-base ]
     [ spill-counts>> int-regs swap at int-regs reg-size * ]
-    [ params>> ]
+    bi + ;
-    [ return>> ]
-    tri + + ;
 
 : spill-float@ ( n -- op )
     double-float-regs reg-size *

vm/Config.windows.nt.x86.64

@@ -1,5 +1,5 @@
 #WIN64_PATH=/k/MinGW/win64/bin
-WIN64_PATH=/cygdrive/k/MinGW/win64/bin/x86_64-pc-mingw32
+#WIN64_PATH=/cygdrive/k/MinGW/win64/bin/x86_64-pc-mingw32
 CC=$(WIN64_PATH)-gcc.exe
 WINDRES=$(WIN64_PATH)-windres.exe
 include vm/Config.windows.nt

vm/callstack.c

@@ -116,6 +116,8 @@ CELL frame_executing(F_STACK_FRAME *frame)
 
 F_STACK_FRAME *frame_successor(F_STACK_FRAME *frame)
 {
+	if(frame->size == 0)
+		critical_error("Stack frame has zero size",frame);
 	return (F_STACK_FRAME *)((CELL)frame - frame->size);
 }
 

vm/cpu-x86.32.S

@@ -11,6 +11,7 @@ and the callstack top is passed in EDX */
 #define RETURN_REG %eax
 
 #define CELL_SIZE 4
+#define STACK_PADDING 12
 
 #define PUSH_NONVOLATILE \
 	push %ebx ; \

vm/cpu-x86.64.S

@@ -1,34 +1,65 @@
 #include "asm.h"
 
-#define ARG0 %rdi
-#define ARG1 %rsi
 #define STACK_REG %rsp
 #define DS_REG %r14
 #define RETURN_REG %rax
 
 #define CELL_SIZE 8
+#define STACK_PADDING 56
 
-#define PUSH_NONVOLATILE \
+#ifdef WINDOWS
+
+	#define ARG0 %rcx
+	#define ARG1 %rdx
+	#define ARG2 %r8
+	#define ARG3 %r9
+
+	#define PUSH_NONVOLATILE \
+		push %r12 ; \
+		push %r13 ; \
+		push %rdi ; \
+		push %rsi ; \
+		push %rbx ; \
+		push %rbp
+
+	#define POP_NONVOLATILE \
+		pop %rbp ; \
+		pop %rbx ; \
+		pop %rsi ; \
+		pop %rdi ; \
+		pop %r13 ; \
+		pop %r12
+
+#else
+
+	#define ARG0 %rdi
+	#define ARG1 %rsi
+	#define ARG2 %rdx
+	#define ARG3 %rcx
+
+	#define PUSH_NONVOLATILE \
 		push %rbx ; \
 		push %rbp ; \
 		push %r12 ; \
-	push %r13 ;
+		push %r13
 
-#define POP_NONVOLATILE \
+	#define POP_NONVOLATILE \
 		pop %r13 ; \
 		pop %r12 ; \
 		pop %rbp ; \
 		pop %rbx
 
+#endif
+
 #define QUOT_XT_OFFSET 21
 
 /* We pass a function pointer to memcpy to work around a Mac OS X
 ABI limitation which would otherwise require us to do a bizzaro PC-relative
 trampoline to retrieve the function address */
 DEF(void,set_callstack,(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, void *memcpy)):
-	sub %rdx,%rdi                      /* compute new stack pointer */
+	sub ARG2,ARG0                      /* compute new stack pointer */
-	mov %rdi,%rsp
+	mov ARG0,%rsp
-	call *%rcx                         /* call memcpy */
+	call *ARG3                         /* call memcpy */
 	ret                                /* return _with new stack_ */
 
 #include "cpu-x86.S"

vm/cpu-x86.S

@@ -1,31 +1,34 @@
 DEF(F_FASTCALL void,c_to_factor,(CELL quot)):
 	PUSH_NONVOLATILE
-	push ARG0                             /* Save quot */
+	push ARG0
 
-	lea -CELL_SIZE(STACK_REG),ARG0        /* Save stack pointer */
+	/* Save stack pointer */
+	lea -CELL_SIZE(STACK_REG),ARG0      
+
+	/* Create register shadow area for Win64 */
+	sub $32,STACK_REG                    
 	call MANGLE(save_callstack_bottom)
+	add $32,STACK_REG
 
-	mov (STACK_REG),ARG0                  /* Pass quot as arg 1 */
+	/* Call quot-xt */
-	call *QUOT_XT_OFFSET(ARG0)            /* Call quot-xt */
+	mov (STACK_REG),ARG0
+	call *QUOT_XT_OFFSET(ARG0)
 
-	POP ARG0
+	pop ARG0
 	POP_NONVOLATILE
 	ret
 
 DEF(F_FASTCALL void,throw_impl,(CELL quot, F_STACK_FRAME *rewind_to)):
-	mov ARG1,STACK_REG                    /* rewind_to */
+	/* rewind_to */
+	mov ARG1,STACK_REG                    
 	jmp *QUOT_XT_OFFSET(ARG0)
 
 DEF(FASTCALL void,lazy_jit_compile,(CELL quot)):
 	mov STACK_REG,ARG1           /* Save stack pointer */
-	push ARG1                    /* Alignment */
+	sub $STACK_PADDING,STACK_REG
-	push ARG1
-	push ARG1
 	call MANGLE(primitive_jit_compile)
 	mov RETURN_REG,ARG0          /* No-op on 32-bit */
-	pop ARG1                     /* OK to clobber ARG1 here */
+	add $STACK_PADDING,STACK_REG
-	pop ARG1
-	pop ARG1
         jmp *QUOT_XT_OFFSET(ARG0)    /* Call the quotation */
 
 #ifdef WINDOWS

vm/data_gc.c

@@ -438,6 +438,8 @@ void collect_gen_cards(CELL gen)
 old->new references */
 void collect_cards(void)
 {
+	GC_PRINT("Collect cards\n");
+
 	int i;
 	for(i = collecting_gen + 1; i < data_heap->gen_count; i++)
 		collect_gen_cards(i);
@@ -465,7 +467,10 @@ void collect_callstack(F_CONTEXT *stacks)
 	{
 		CELL top = (CELL)stacks->callstack_top;
 		CELL bottom = (CELL)stacks->callstack_bottom;
+
+		GC_PRINT("Collect callstack %ld %ld\n",top,bottom);
 		iterate_callstack(top,bottom,collect_stack_frame);
+		GC_PRINT("Done\n");
 	}
 }
 
@@ -481,6 +486,7 @@ void collect_gc_locals(void)
 the user environment and extra roots registered with REGISTER_ROOT */
 void collect_roots(void)
 {
+	GC_PRINT("Collect roots\n");
 	copy_handle(&T);
 	copy_handle(&bignum_zero);
 	copy_handle(&bignum_pos_one);

vm/factor.c

@@ -167,7 +167,6 @@ void init_factor_from_args(F_CHAR *image, int argc, F_CHAR **argv, bool embedded
 	}
 
 	init_factor(&p);
-
 	nest_stacks();
 
 	F_ARRAY *args = allot_array(ARRAY_TYPE,argc,F);

vm/math.c

@@ -363,13 +363,13 @@ CELL unbox_array_size(void)
 	case BIGNUM_TYPE:
 		{
 			bignum_type zero = untag_object(bignum_zero);
-			bignum_type max = ulong_to_bignum(ARRAY_SIZE_MAX);
+			bignum_type max = cell_to_bignum(ARRAY_SIZE_MAX);
 			bignum_type n = untag_object(dpeek());
 			if(bignum_compare(n,zero) != bignum_comparison_less
 				&& bignum_compare(n,max) == bignum_comparison_less)
 			{
 				dpop();
-				return bignum_to_ulong(n);
+				return bignum_to_cell(n);
 			}
 			break;
 		}