Merge remote branch 'origin/abi-symbols' into fastcall-madness

diff --git a/Nmakefile b/Nmakefile
index 02d2b5f1ed413405a1a6eef81b4f616cace367c5..1edc14199ddd4bf58b3b61c0ed4b497f465cbd22 100755 (executable)
--- a/Nmakefile
+++ b/Nmakefile
@@ -1,17 +1,27 @@
-!IF DEFINED(DEBUG)
-LINK_FLAGS = /nologo /safeseh /DEBUG shell32.lib
-CL_FLAGS = /nologo /Zi /O2 /W3 /DFACTOR_DEBUG
-!ELSE
-LINK_FLAGS = /nologo /safeseh shell32.lib
+!IF DEFINED(PLATFORM)
+
+LINK_FLAGS = /nologo shell32.lib
 CL_FLAGS = /nologo /O2 /W3
+
+!IF DEFINED(DEBUG)
+LINK_FLAGS = $(LINK_FLAGS) /DEBUG
+CL_FLAGS = $(CL_FLAGS) /Zi /DFACTOR_DEBUG
+!ENDIF
+
+!IF "$(PLATFORM)" == "x86-32"
+LINK_FLAGS = $(LINK_FLAGS) /safeseh
+PLAF_DLL_OBJS = vm\os-windows-nt-x86.32.obj vm\safeseh.obj
+!ELSEIF "$(PLATFORM)" == "x86-64"
+PLAF_DLL_OBJS = vm\os-windows-nt-x86.64.obj
 !ENDIF
 
 ML_FLAGS = /nologo /safeseh
 
 EXE_OBJS = vm\main-windows-nt.obj vm\factor.res
 
-DLL_OBJS = vm\os-windows-nt.obj \
+DLL_OBJS = $(PLAF_DLL_OBJS) \
        vm\os-windows.obj \
+       vm\os-windows-nt.obj \
        vm\aging_collector.obj \
        vm\alien.obj \
        vm\arrays.obj \
@@ -49,7 +59,6 @@ DLL_OBJS = vm\os-windows-nt.obj \
        vm\profiler.obj \
        vm\quotations.obj \
        vm\run.obj \
-       vm\safeseh.obj \
        vm\strings.obj \
        vm\to_tenured_collector.obj \
        vm\tuples.obj \
@@ -69,8 +78,6 @@ DLL_OBJS = vm\os-windows-nt.obj \
 .rs.res:
        rc $<
 
-all: factor.com factor.exe factor.dll.lib libfactor-ffi-test.dll
-
 libfactor-ffi-test.dll: vm/ffi_test.obj
        link $(LINK_FLAGS) /out:libfactor-ffi-test.dll /dll vm/ffi_test.obj
 
@@ -83,6 +90,23 @@ factor.com: $(EXE_OBJS) $(DLL_OBJS)
 factor.exe: $(EXE_OBJS) $(DLL_OBJS)
        link $(LINK_FLAGS) /out:factor.exe /SUBSYSTEM:windows $(EXE_OBJS) $(DLL_OBJS)
 
+all: factor.com factor.exe factor.dll.lib libfactor-ffi-test.dll
+
+!ENDIF
+
+default:
+       @echo Usage: nmake /f Nmakefile platform
+       @echo Where platform is one of:
+       @echo x86-32
+       @echo x86-64
+       @exit 1
+
+x86-32:
+       nmake PLATFORM=x86-32 /f Nmakefile all
+
+x86-64:
+       nmake PLATFORM=x86-64 /f Nmakefile all
+
 clean:
        del vm\*.obj
        del factor.lib
@@ -91,6 +115,6 @@ clean:
        del factor.dll
        del factor.dll.lib
 
-.PHONY: all clean
+.PHONY: all default x86-32 x86-64 clean
 
 .SUFFIXES: .rs

diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor
index 20fd65fdac6c94d5491e80b9bc3d36767b4855e0..37177abbcd89ba268707174cd9e07ada9af0c1ac 100755 (executable)
--- a/basis/cpu/x86/32/32.factor
+++ b/basis/cpu/x86/32/32.factor
@@ -68,7 +68,7 @@ M:: x86.32 %dispatch ( src temp -- )
     [ align-code ]
     bi ;
 
-M: x86.32 pic-tail-reg EBX ;
+M: x86.32 pic-tail-reg EDX ;
 
 M: x86.32 reserved-stack-space 0 ;
 

diff --git a/basis/cpu/x86/32/bootstrap.factor b/basis/cpu/x86/32/bootstrap.factor
index b2cd241df1de6d47ab014faa1f4e14999e7d8591..4eb8335b678974d287a6a5277229a814d544f3ef 100644 (file)
--- a/basis/cpu/x86/32/bootstrap.factor
+++ b/basis/cpu/x86/32/bootstrap.factor
@@ -13,15 +13,16 @@ IN: bootstrap.x86
 : div-arg ( -- reg ) EAX ;
 : mod-arg ( -- reg ) EDX ;
 : temp0 ( -- reg ) EAX ;
-: temp1 ( -- reg ) EDX ;
-: temp2 ( -- reg ) ECX ;
-: temp3 ( -- reg ) EBX ;
+: temp1 ( -- reg ) ECX ;
+: temp2 ( -- reg ) EBX ;
+: temp3 ( -- reg ) EDX ;
+: pic-tail-reg ( -- reg ) EDX ;
 : stack-reg ( -- reg ) ESP ;
 : frame-reg ( -- reg ) EBP ;
-: vm-reg ( -- reg ) ECX ;
+: vm-reg ( -- reg ) EBX ;
 : ctx-reg ( -- reg ) EBP ;
 : nv-regs ( -- seq ) { ESI EDI EBX } ;
-: nv-reg ( -- reg ) EBX ;
+: nv-reg ( -- reg ) ESI ;
 : ds-reg ( -- reg ) ESI ;
 : rs-reg ( -- reg ) EDI ;
 : fixnum>slot@ ( -- ) temp0 2 SAR ;
@@ -40,7 +41,7 @@ IN: bootstrap.x86
 ] jit-prolog jit-define
 
 [
-    temp3 0 MOV rc-absolute-cell rt-here jit-rel
+    pic-tail-reg 0 MOV rc-absolute-cell rt-here jit-rel
     0 JMP rc-relative rt-entry-point-pic-tail jit-rel
 ] jit-word-jump jit-define
 
@@ -53,8 +54,8 @@ IN: bootstrap.x86
 
 : jit-save-context ( -- )
     jit-load-context
-    EDX ESP -4 [+] LEA
-    ctx-reg context-callstack-top-offset [+] EDX MOV
+    ECX ESP -4 [+] LEA
+    ctx-reg context-callstack-top-offset [+] ECX MOV
     ctx-reg context-datastack-offset [+] ds-reg MOV
     ctx-reg context-retainstack-offset [+] rs-reg MOV ;
 
@@ -135,25 +136,25 @@ IN: bootstrap.x86
 
 [
     ! Load callstack object
-    EBX ds-reg [] MOV
+    temp3 ds-reg [] MOV
     ds-reg bootstrap-cell SUB
     ! Get ctx->callstack_bottom
     jit-load-vm
     jit-load-context
-    EAX ctx-reg context-callstack-bottom-offset [+] MOV
+    temp0 ctx-reg context-callstack-bottom-offset [+] MOV
     ! Get top of callstack object -- 'src' for memcpy
-    EBP EBX callstack-top-offset [+] LEA
+    temp1 temp3 callstack-top-offset [+] LEA
     ! Get callstack length, in bytes --- 'len' for memcpy
-    EDX EBX callstack-length-offset [+] MOV
-    EDX tag-bits get SHR
+    temp2 temp3 callstack-length-offset [+] MOV
+    temp2 tag-bits get SHR
     ! Compute new stack pointer -- 'dst' for memcpy
-    EAX EDX SUB
+    temp0 temp2 SUB
     ! Install new stack pointer
-    ESP EAX MOV
+    ESP temp0 MOV
     ! Call memcpy
-    EDX PUSH
-    EBP PUSH
-    EAX PUSH
+    temp2 PUSH
+    temp1 PUSH
+    temp0 PUSH
     "factor_memcpy" jit-call
     ESP 12 ADD
     ! Return with new callstack
@@ -177,7 +178,7 @@ IN: bootstrap.x86
 
 ! Inline cache miss entry points
 : jit-load-return-address ( -- )
-    EBX ESP stack-frame-size bootstrap-cell - [+] MOV ;
+    pic-tail-reg ESP stack-frame-size bootstrap-cell - [+] MOV ;
 
 ! These are always in tail position with an existing stack
 ! frame, and the stack. The frame setup takes this into account.
@@ -185,7 +186,7 @@ IN: bootstrap.x86
     jit-load-vm
     jit-save-context
     ESP 4 [+] vm-reg MOV
-    ESP [] EBX MOV
+    ESP [] pic-tail-reg MOV
     "inline_cache_miss" jit-call
     jit-restore-context ;
 
@@ -213,6 +214,7 @@ IN: bootstrap.x86
     [
         ESP [] EAX MOV
         ESP 4 [+] EDX MOV
+        jit-load-vm
         ESP 8 [+] vm-reg MOV
         jit-call
     ]
@@ -237,6 +239,7 @@ IN: bootstrap.x86
         EBX tag-bits get SAR
         ESP [] EBX MOV
         ESP 4 [+] EBP MOV
+        jit-load-vm
         ESP 8 [+] vm-reg MOV
         "overflow_fixnum_multiply" jit-call
     ]
@@ -266,7 +269,7 @@ IN: bootstrap.x86
     ! Load context and parameter from datastack
     EAX ds-reg [] MOV
     EAX EAX alien-offset [+] MOV
-    EBX ds-reg -4 [+] MOV
+    EDX ds-reg -4 [+] MOV
     ds-reg 8 SUB
 
     ! Make the new context active
@@ -280,7 +283,7 @@ IN: bootstrap.x86
 
     ! Store parameter to datastack
     ds-reg 4 ADD
-    ds-reg [] EBX MOV ;
+    ds-reg [] EDX MOV ;
 
 [ jit-set-context ] \ (set-context) define-sub-primitive
 
@@ -291,14 +294,14 @@ IN: bootstrap.x86
     "new_context" jit-call
 
     ! Save pointer to quotation and parameter
-    EBX ds-reg MOV
+    EDX ds-reg MOV
     ds-reg 8 SUB
 
     ! Make the new context active
     EAX jit-switch-context
 
     ! Push parameter
-    EAX EBX -4 [+] MOV
+    EAX EDX -4 [+] MOV
     ds-reg 4 ADD
     ds-reg [] EAX MOV
 
@@ -309,7 +312,7 @@ IN: bootstrap.x86
     0 PUSH
 
     ! Jump to initial quotation
-    EAX EBX [] MOV
+    EAX EDX [] MOV
     jit-jump-quot ;
 
 [ jit-start-context ] \ (start-context) define-sub-primitive

diff --git a/basis/cpu/x86/64/bootstrap.factor b/basis/cpu/x86/64/bootstrap.factor
index 68c3d8b7025dc7a89322ca62262f8d4091729d52..39046bce6a0adbf5c1b8884914a2c9d6d2600138 100644 (file)
--- a/basis/cpu/x86/64/bootstrap.factor
+++ b/basis/cpu/x86/64/bootstrap.factor
@@ -11,10 +11,11 @@ IN: bootstrap.x86
 : shift-arg ( -- reg ) RCX ;
 : div-arg ( -- reg ) RAX ;
 : mod-arg ( -- reg ) RDX ;
-: temp0 ( -- reg ) RDI ;
-: temp1 ( -- reg ) RSI ;
+: temp0 ( -- reg ) RAX ;
+: temp1 ( -- reg ) RCX ;
 : temp2 ( -- reg ) RDX ;
 : temp3 ( -- reg ) RBX ;
+: pic-tail-reg ( -- reg ) RBX ;
 : return-reg ( -- reg ) RAX ;
 : nv-reg ( -- reg ) RBX ;
 : stack-reg ( -- reg ) RSP ;
@@ -42,7 +43,7 @@ IN: bootstrap.x86
 ] jit-prolog jit-define
 
 [
-    temp3 5 [RIP+] LEA
+    pic-tail-reg 5 [RIP+] LEA
     0 JMP rc-relative rt-entry-point-pic-tail jit-rel
 ] jit-word-jump jit-define
 

diff --git a/basis/cpu/x86/bootstrap.factor b/basis/cpu/x86/bootstrap.factor
index 80b56f9f9159f581433fba9d18876048e75d6478..b1866e110a096a1d53ab05a5f6272a42ee317c92 100644 (file)
--- a/basis/cpu/x86/bootstrap.factor
+++ b/basis/cpu/x86/bootstrap.factor
@@ -12,8 +12,9 @@ big-endian off
 [
     ! Optimizing compiler's side of callback accesses
     ! arguments that are on the stack via the frame pointer.
-    ! On x86-64, some arguments are passed in registers, and
-    ! so the only register that is safe for use here is nv-reg.
+    ! On x86-32 fastcall, and x86-64, some arguments are passed
+    ! in registers, and so the only registers that are safe for
+    ! use here are frame-reg, nv-reg and vm-reg.
     frame-reg PUSH
     frame-reg stack-reg MOV
 
@@ -73,15 +74,15 @@ big-endian off
 
 [
     ! Load word
-    nv-reg 0 MOV rc-absolute-cell rt-literal jit-rel
+    temp0 0 MOV rc-absolute-cell rt-literal jit-rel
     ! Bump profiling counter
-    nv-reg profile-count-offset [+] 1 tag-fixnum ADD
+    temp0 profile-count-offset [+] 1 tag-fixnum ADD
     ! Load word->code
-    nv-reg nv-reg word-code-offset [+] MOV
+    temp0 temp0 word-code-offset [+] MOV
     ! Compute word entry point
-    nv-reg compiled-header-size ADD
+    temp0 compiled-header-size ADD
     ! Jump to entry point
-    nv-reg JMP
+    temp0 JMP
 ] jit-profiling jit-define
 
 [
@@ -200,7 +201,7 @@ big-endian off
 
 ! ! ! Polymorphic inline caches
 
-! The PIC stubs are not permitted to touch temp3.
+! The PIC stubs are not permitted to touch pic-tail-reg.
 
 ! Load a value from a stack position
 [
@@ -477,23 +478,23 @@ big-endian off
     ! load value
     temp3 ds-reg [] MOV
     ! make a copy
-    temp1 temp3 MOV
-    ! compute positive shift value in temp1
-    temp1 CL SHL
+    temp2 temp3 MOV
+    ! compute positive shift value in temp2
+    temp2 CL SHL
     shift-arg NEG
     ! compute negative shift value in temp3
     temp3 CL SAR
     temp3 tag-mask get bitnot AND
     shift-arg 0 CMP
-    ! if shift count was negative, move temp0 to temp1
-    temp1 temp3 CMOVGE
+    ! if shift count was negative, move temp0 to temp2
+    temp2 temp3 CMOVGE
     ! push to stack
-    ds-reg [] temp1 MOV
+    ds-reg [] temp2 MOV
 ] \ fixnum-shift-fast define-sub-primitive
 
 : jit-fixnum-/mod ( -- )
     ! load second parameter
-    temp3 ds-reg [] MOV
+    temp1 ds-reg [] MOV
     ! load first parameter
     div-arg ds-reg bootstrap-cell neg [+] MOV
     ! make a copy
@@ -501,7 +502,7 @@ big-endian off
     ! sign-extend
     mod-arg bootstrap-cell-bits 1 - SAR
     ! divide
-    temp3 IDIV ;
+    temp1 IDIV ;
 
 [
     jit-fixnum-/mod

diff --git a/basis/debugger/debugger.factor b/basis/debugger/debugger.factor
index 8f448ff23756f2beea489dc73b556b2cf78204c6..8856871f1126c37e3f4d0719a5ccd3628772debb 100644 (file)
--- a/basis/debugger/debugger.factor
+++ b/basis/debugger/debugger.factor
@@ -270,20 +270,20 @@ M: no-current-vocab summary
 
 M: no-word-error summary
     name>>
-    "No word named ``"
-    "'' found in current vocabulary search path" surround ;
+    "No word named “"
+    "” found in current vocabulary search path" surround ;
 
 M: no-word-error error. summary print ;
 
 M: no-word-in-vocab summary
     [ vocab>> ] [ word>> ] bi
-    [ "No word named ``" % % "'' found in ``" % % "'' vocabulary" % ] "" make ;
+    [ "No word named “" % % "” found in “" % % "” vocabulary" % ] "" make ;
 
 M: no-word-in-vocab error. summary print ;
 
 M: ambiguous-use-error summary
     words>> first name>>
-    "More than one vocabulary defines a word named ``" "''" surround ;
+    "More than one vocabulary defines a word named “" "”" surround ;
 
 M: ambiguous-use-error error. summary print ;
 
@@ -306,6 +306,9 @@ M: bad-inheritance summary
 M: not-in-a-method-error summary
     drop "call-next-method can only be called in a method definition" ;
 
+M: version-control-merge-conflict summary
+    drop "Version control merge conflict in source code" ;
+
 GENERIC: expected>string ( obj -- str )
 
 M: f expected>string drop "end of input" ;

diff --git a/basis/io/monitors/recursive/recursive.factor b/basis/io/monitors/recursive/recursive.factor
index b573e2fa2b43f49b72cae37d35f512e94cee9508..70daed901851d66083e3dd98b424114f1e74e6a9 100644 (file)
--- a/basis/io/monitors/recursive/recursive.factor
+++ b/basis/io/monitors/recursive/recursive.factor
@@ -1,9 +1,10 @@
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors sequences assocs arrays continuations
 destructors combinators kernel threads concurrency.messaging
 concurrency.mailboxes concurrency.promises io.files io.files.info
-io.directories io.pathnames io.monitors debugger fry ;
+io.directories io.pathnames io.monitors io.monitors.private
+debugger fry ;
 IN: io.monitors.recursive
 
 ! Simulate recursive monitors on platforms that don't have them
@@ -71,12 +72,14 @@ M: recursive-monitor dispose*
     ] with with each ;
 
 : pump-loop ( -- )
-    receive dup +stop+ eq? [
-        drop stop-pump
-    ] [
-        [ '[ _ update-hierarchy ] ignore-errors ] [ pump-step ] bi
-        pump-loop
-    ] if ;
+    receive {
+        { [ dup +stop+ eq? ] [ drop stop-pump ] }
+        { [ dup monitor-disposed eq? ] [ drop ] }
+        [
+            [ '[ _ update-hierarchy ] ignore-errors ] [ pump-step ] bi
+            pump-loop
+        ]
+    } cond ;
 
 : monitor-ready ( error/t -- )
     monitor tget ready>> fulfill ;

diff --git a/basis/ui/gadgets/grids/grids-docs.factor b/basis/ui/gadgets/grids/grids-docs.factor
index 10b3bb7259f5aaa2bfba8ccfc667095ef2ce8215..1632072ca2cd38d30d2be815562894a85cd0b4be 100644 (file)
--- a/basis/ui/gadgets/grids/grids-docs.factor
+++ b/basis/ui/gadgets/grids/grids-docs.factor
@@ -2,7 +2,7 @@ USING: ui.gadgets help.markup help.syntax arrays ;
 IN: ui.gadgets.grids
 
 ARTICLE: "ui-grid-layout" "Grid layouts"
-"Grid gadgets layout their children in a rectangular grid."
+"Grid gadgets layout their children in a rectangular grid. The grid is represented as a sequence of sequences of gadgets. Every child sequence is a row of gadgets. Every row must have an equal number of gadgets in it."
 { $subsections grid }
 "Creating grids from a fixed set of gadgets:"
 { $subsections <grid> }

diff --git a/core/bootstrap/syntax.factor b/core/bootstrap/syntax.factor
index c13f9f9026a1c78c35a51358e0ba306ff35746a7..9395447aa6ffaf2b4e75f32da0c950cce04a42a3 100644 (file)
--- a/core/bootstrap/syntax.factor
+++ b/core/bootstrap/syntax.factor
@@ -89,6 +89,12 @@ IN: bootstrap.syntax
         "read-only"
         "call("
         "execute("
+        "<<<<<<"
+        "======"
+        ">>>>>>"
+        "<<<<<<<"
+        "======="
+        ">>>>>>>"
     } [ "syntax" create drop ] each
 
     "t" "syntax" lookup define-symbol

diff --git a/core/combinators/combinators-tests.factor b/core/combinators/combinators-tests.factor
index b239b1eac9a2ab28ee034d0b8ec2889a8ab297f0..1e7a61daaaca52bbd725eaa88f4ea2becb20563d 100644 (file)
--- a/core/combinators/combinators-tests.factor
+++ b/core/combinators/combinators-tests.factor
@@ -35,6 +35,24 @@ IN: combinators.tests
 [ 7 ] [ 1 3 [ 2 * ] [ + ] compose compile-call(-test-1 ] unit-test
 [ 4 ] [ 1 3 [ { + } [ ] like call ] compile-call(-test-1 ] unit-test
 
+[ [ ] call( -- * ) ] must-fail
+
+: compile-call(-test-2 ( -- ) [ ] call( -- * ) ;
+
+[ compile-call(-test-2 ] [ wrong-values? ] must-fail-with
+
+: compile-call(-test-3 ( quot -- ) call( -- * ) ;
+
+[ [ ] compile-call(-test-3 ] [ wrong-values? ] must-fail-with
+
+: compile-execute(-test-3 ( a -- ) \ . execute( value -- * ) ;
+
+[ 10 compile-execute(-test-3 ] [ wrong-values? ] must-fail-with
+
+: compile-execute(-test-4 ( a word -- ) execute( value -- * ) ;
+
+[ 10 \ . compile-execute(-test-4 ] [ wrong-values? ] must-fail-with
+
 ! Compiled
 : cond-test-1 ( obj -- str )
     {

diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor
index 7ef2ed5f9fd9d7dabc0632d81147b1365994dadc..bbfee30b3deceabcde0c0fa7967aea48871896b0 100644 (file)
--- a/core/combinators/combinators.factor
+++ b/core/combinators/combinators.factor
@@ -26,15 +26,17 @@ ERROR: wrong-values quot call-site ;
 ! We can't USE: effects here so we forward reference slots instead
 SLOT: in
 SLOT: out
+SLOT: terminated?
 
 : call-effect ( quot effect -- )
     ! Don't use fancy combinators here, since this word always
     ! runs unoptimized
-    [ datastack ] 2dip
     2dup [
-        [ dip ] dip
-        dup in>> length swap out>> length
-        check-datastack
+        [ [ datastack ] dip dip ] dip
+        dup terminated?>> [ 2drop f ] [
+            dup in>> length swap out>> length
+            check-datastack
+        ] if
     ] 2dip rot
     [ 2drop ] [ wrong-values ] if ;
 

diff --git a/core/parser/parser.factor b/core/parser/parser.factor
index 3257bd69a4b2f137023ca8ec2cbce7cfa67d579e..be43979b31a6181b9f89cf5ab1096cfc89acad47 100644 (file)
--- a/core/parser/parser.factor
+++ b/core/parser/parser.factor
@@ -207,3 +207,5 @@ print-use-hook [ [ ] ] initialize
 
 : ?run-file ( path -- )
     dup exists? [ run-file ] [ drop ] if ;
+
+ERROR: version-control-merge-conflict ;

diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor
index bd70b0be62235d1ab443a04d92c79851c381d81e..de719c72726bab9df1169e40136a2ccdb6acaa5b 100644 (file)
--- a/core/syntax/syntax.factor
+++ b/core/syntax/syntax.factor
@@ -257,4 +257,12 @@ IN: bootstrap.syntax
     "call(" [ \ call-effect parse-call( ] define-core-syntax
 
     "execute(" [ \ execute-effect parse-call( ] define-core-syntax
+
+    "<<<<<<<" [ version-control-merge-conflict ] define-core-syntax
+    "=======" [ version-control-merge-conflict ] define-core-syntax
+    ">>>>>>>" [ version-control-merge-conflict ] define-core-syntax
+
+    "<<<<<<" [ version-control-merge-conflict ] define-core-syntax
+    "======" [ version-control-merge-conflict ] define-core-syntax
+    ">>>>>>" [ version-control-merge-conflict ] define-core-syntax
 ] with-compilation-unit

diff --git a/extra/cursors/cursors-tests.factor b/extra/cursors/cursors-tests.factor
index 770fd01ffd1ac371f77ed950b86e5520f3c81b34..df168a900878da7c5f4e0c52c252c79917b4f6d8 100644 (file)
--- a/extra/cursors/cursors-tests.factor
+++ b/extra/cursors/cursors-tests.factor
@@ -25,20 +25,6 @@ IN: cursors.tests
 [ B{ } ] [ [ { } [ , ] each ] B{ } make ] unit-test
 [ { 2 4 6 8 10 } ] [ { 1 2 3 4 5 } [ 2 * ] map ] unit-test
 
-[ { "roses: lutefisk" "tulips: lox" } ]
-[
-    [
-        { { "roses" "lutefisk" } { "tulips" "lox" } }
-        [ ": " glue , ] assoc-each
-    ] { } make
-] unit-test
-
-[ { "roses: lutefisk" "tulips: lox" } ]
-[
-    { { "roses" "lutefisk" } { "tulips" "lox" } }
-    [ ": " glue ] { } assoc>map
-] unit-test
-
 [ { "roses: lutefisk" "tulips: lox" } ]
 [
     [
@@ -69,8 +55,14 @@ IN: cursors.tests
 [ { 2 4 6 8 10 } ] [ { 1 2 3 4 5 } compile-test-map ] unit-test
 
 [ { "roses: lutefisk" "tulips: lox" } ]
-[ [ { { "roses" "lutefisk" } { "tulips" "lox" } } compile-test-assoc-each ] { } make ] unit-test
+[
+    [ H{ { "roses" "lutefisk" } { "tulips" "lox" } } compile-test-assoc-each ]
+    { } make natural-sort
+] unit-test
 
 [ { "roses: lutefisk" "tulips: lox" } ]
-[ { { "roses" "lutefisk" } { "tulips" "lox" } } compile-test-assoc>map ] unit-test
+[
+    H{ { "roses" "lutefisk" } { "tulips" "lox" } } compile-test-assoc>map
+    natural-sort
+] unit-test
 

diff --git a/extra/cursors/cursors.factor b/extra/cursors/cursors.factor
index d7fe5fb893b4ec0412fd5ace29c2a6cece411070..776a5523c4a5f6b91d2c2831f488431168ea7251 100644 (file)
--- a/extra/cursors/cursors.factor
+++ b/extra/cursors/cursors.factor
@@ -61,13 +61,19 @@ ERROR: invalid-cursor cursor ;
 
 MIXIN: input-cursor
 
-GENERIC: cursor-value ( cursor -- value )
+GENERIC: cursor-key-value ( cursor -- key value )
 <PRIVATE
-GENERIC: cursor-value-unsafe ( cursor -- value )
+GENERIC: cursor-key-value-unsafe ( cursor -- key value )
 PRIVATE>
-M: input-cursor cursor-value-unsafe cursor-value ; inline
-M: input-cursor cursor-value
-    dup cursor-valid? [ cursor-value-unsafe ] [ invalid-cursor ] if ; inline
+M: input-cursor cursor-key-value-unsafe cursor-key-value ; inline
+M: input-cursor cursor-key-value
+    dup cursor-valid? [ cursor-key-value-unsafe ] [ invalid-cursor ] if ; inline
+
+: cursor-key ( cursor -- key ) cursor-key-value drop ;
+: cursor-value ( cursor -- key ) cursor-key-value nip ;
+
+: cursor-key-unsafe ( cursor -- key ) cursor-key-value-unsafe drop ;
+: cursor-value-unsafe ( cursor -- key ) cursor-key-value-unsafe nip ;
 
 !
 ! output cursors
@@ -155,7 +161,7 @@ M: numeric-cursor cursor>= [ value>> ] bi@ >= ; inline
 
 INSTANCE: numeric-cursor input-cursor
 
-M: numeric-cursor cursor-value value>> ; inline
+M: numeric-cursor cursor-key-value value>> dup ; inline
 
 !
 ! linear cursor
@@ -278,8 +284,8 @@ M: sequence-cursor cursor-distance ( cursor cursor -- n )
 
 INSTANCE: sequence-cursor input-cursor
 
-M: sequence-cursor cursor-value-unsafe [ n>> ] [ seq>> ] bi nth-unsafe ; inline
-M: sequence-cursor cursor-value [ n>> ] [ seq>> ] bi nth ; inline
+M: sequence-cursor cursor-key-value-unsafe [ n>> dup ] [ seq>> ] bi nth-unsafe ; inline
+M: sequence-cursor cursor-key-value [ n>> dup ] [ seq>> ] bi nth ; inline
 
 INSTANCE: sequence-cursor output-cursor
 
@@ -362,13 +368,9 @@ M: forward-cursor new-sequence-cursor
     over map-as ; inline
 
 !
-! assoc cursors
+! assoc combinators
 !
 
-MIXIN: assoc-cursor
-
-GENERIC: cursor-key-value ( cursor -- key value )
-
 : -assoc- ( quot -- quot' )
     '[ cursor-key-value @ ] ; inline
 
@@ -380,11 +382,6 @@ GENERIC: cursor-key-value ( cursor -- key value )
 : assoc>map ( ... assoc quot: ( ... k v -- ... newx ) exemplar -- ... newcontainer )
     [ assoc- ] dip -map-as ; inline
 
-INSTANCE: input-cursor assoc-cursor
-
-M: input-cursor cursor-key-value
-    cursor-value-unsafe first2 ; inline
-
 !
 ! hashtable cursor
 !
@@ -421,16 +418,11 @@ M: hashtable-cursor inc-cursor ( cursor -- cursor' )
     [ hashtable>> dup array>> ] [ n>> 2 + ] bi
     (inc-hashtable-cursor) <hashtable-cursor> ; inline
 
-INSTANCE: hashtable-cursor assoc-cursor
-    
-M: hashtable-cursor cursor-key-value
-    [ n>> ] [ hashtable>> array>> ] bi
-    [ nth-unsafe ] [ [ 1 + ] dip nth-unsafe ] 2bi ; inline
-
 INSTANCE: hashtable-cursor input-cursor
 
-M: hashtable-cursor cursor-value-unsafe
-    cursor-key-value 2array ; inline
+M: hashtable-cursor cursor-key-value-unsafe
+    [ n>> ] [ hashtable>> array>> ] bi
+    [ nth-unsafe ] [ [ 1 + ] dip nth-unsafe ] 2bi ; inline
 
 INSTANCE: hashtable container
 
@@ -472,7 +464,7 @@ M: zip-cursor cursor-distance-hint ( cursor cursor -- n )
 M: zip-cursor inc-cursor ( cursor -- cursor' )
     [ keys>> inc-cursor ] [ values>> inc-cursor ] bi <zip-cursor> ; inline
     
-INSTANCE: zip-cursor assoc-cursor
+INSTANCE: zip-cursor input-cursor
 
 M: zip-cursor cursor-key-value
     [ keys>> cursor-value-unsafe ] [ values>> cursor-value-unsafe ] bi ; inline

diff --git a/extra/mason/child/child-tests.factor b/extra/mason/child/child-tests.factor
index f8046ac8e567b8ac7a2815c93453af42dec1d09d..1018a1ec4040308aefda582eda3f2c6f841a1764 100644 (file)
--- a/extra/mason/child/child-tests.factor
+++ b/extra/mason/child/child-tests.factor
@@ -1,7 +1,7 @@
 IN: mason.child.tests
 USING: mason.child mason.config tools.test namespaces io kernel sequences ;
 
-[ { "nmake" "/f" "nmakefile" } ] [
+[ { "nmake" "/f" "nmakefile" "x86-32" } ] [
     [
         "winnt" target-os set
         "x86.32" target-cpu set

diff --git a/extra/mason/child/child.factor b/extra/mason/child/child.factor
index 017e4401d8ecae31e6f2bc753d8f640b9b2ef972..d9821f8fcc82a7efdd12fd33413dbc27a5187542 100644 (file)
--- a/extra/mason/child/child.factor
+++ b/extra/mason/child/child.factor
@@ -4,13 +4,20 @@ USING: accessors arrays calendar combinators.short-circuit fry
 continuations debugger io.directories io.files io.launcher
 io.pathnames io.encodings.ascii kernel make mason.common mason.config
 mason.platform mason.report mason.notify namespaces sequences
-quotations macros system combinators ;
+quotations macros system combinators splitting ;
 IN: mason.child
 
+: nmake-cmd ( -- args )
+    { "nmake" "/f" "nmakefile" }
+    target-cpu get "." split "-" join suffix ;
+
+: gnu-make-cmd ( -- args )
+    gnu-make platform 2array ;
+
 : make-cmd ( -- args )
     {
-        { [ target-os get "winnt" = ] [ { "nmake" "/f" "nmakefile" } ] }
-        [ gnu-make platform 2array ]
+        { [ target-os get "winnt" = ] [ nmake-cmd ] }
+        [ gnu-make-cmd ]
     } cond ;
 
 : make-vm ( -- )

diff --git a/vm/Config.windows.nt.x86.32 b/vm/Config.windows.nt.x86.32
index d27629fe8358552f93499239c2f1cb63a70aca9b..73bf064ce54042bf08adcfa3506c4fdc557727c7 100644 (file)
--- a/vm/Config.windows.nt.x86.32
+++ b/vm/Config.windows.nt.x86.32
@@ -1,3 +1,4 @@
+PLAF_DLL_OBJS += vm/os-windows-nt-x86.32.o
 DLL_PATH=http://factorcode.org/dlls
 WINDRES=windres
 include vm/Config.windows.nt

diff --git a/vm/Config.windows.nt.x86.64 b/vm/Config.windows.nt.x86.64
index ddb61480e5cf8c340bf8a1708b0cda2fa259d5a4..495a3ccac9ac49925dde97c13c13132955445463 100644 (file)
--- a/vm/Config.windows.nt.x86.64
+++ b/vm/Config.windows.nt.x86.64
@@ -1,3 +1,4 @@
+PLAF_DLL_OBJS += vm/os-windows-nt-x86.64.o
 DLL_PATH=http://factorcode.org/dlls/64
 CC=$(WIN64_PATH)-gcc.exe
 WINDRES=$(WIN64_PATH)-windres.exe

diff --git a/vm/code_heap.cpp b/vm/code_heap.cpp
index 40fe00b0e9ff6a2ac906ac6ef606887998db6796..96d95416655ccb4af9251b28890fc46b637b9fcc 100755 (executable)
--- a/vm/code_heap.cpp
+++ b/vm/code_heap.cpp
@@ -7,8 +7,14 @@ code_heap::code_heap(cell size)
 {
        if(size > ((u64)1 << (sizeof(cell) * 8 - 6))) fatal_error("Heap too large",size);
        seg = new segment(align_page(size),true);
-       if(!seg) fatal_error("Out of memory in heap allocator",size);
-       allocator = new free_list_allocator<code_block>(size,seg->start);
+       if(!seg) fatal_error("Out of memory in code_heap constructor",size);
+
+       cell start = seg->start + seh_area_size;
+
+       allocator = new free_list_allocator<code_block>(seg->end - start,start);
+
+       /* See os-windows-nt-x86.64.cpp for seh_area usage */
+       seh_area = (char *)seg->start;
 }
 
 code_heap::~code_heap()

diff --git a/vm/code_heap.hpp b/vm/code_heap.hpp
index 78ffa6c76a19cd06926c002f8031daca7aba8337..20ce03c8357a83648c483dc993ef8000eb6f3917 100755 (executable)
--- a/vm/code_heap.hpp
+++ b/vm/code_heap.hpp
@@ -1,10 +1,19 @@
 namespace factor
 {
 
+#if defined(WINDOWS) && defined(FACTOR_64)
+       const cell seh_area_size = 1024;
+#else
+       const cell seh_area_size = 0;
+#endif
+
 struct code_heap {
        /* The actual memory area */
        segment *seg;
 
+       /* Memory area reserved for SEH. Only used on Windows */
+       char *seh_area;
+
        /* Memory allocator */
        free_list_allocator<code_block> *allocator;
 

diff --git a/vm/image.cpp b/vm/image.cpp
index c74351c1911301846969058ea466505df2433ff3..ccce96a952c56970c8b728293989347173338bc6 100755 (executable)
--- a/vm/image.cpp
+++ b/vm/image.cpp
@@ -258,7 +258,7 @@ void factor_vm::load_image(vm_parameters *p)
        init_objects(&h);
 
        cell data_offset = data->tenured->start - h.data_relocation_base;
-       cell code_offset = code->seg->start - h.code_relocation_base;
+       cell code_offset = code->allocator->start - h.code_relocation_base;
 
        fixup_data(data_offset,code_offset);
        fixup_code(data_offset,code_offset);
@@ -285,7 +285,7 @@ bool factor_vm::save_image(const vm_char *saving_filename, const vm_char *filena
        h.version = image_version;
        h.data_relocation_base = data->tenured->start;
        h.data_size = data->tenured->occupied_space();
-       h.code_relocation_base = code->seg->start;
+       h.code_relocation_base = code->allocator->start;
        h.code_size = code->allocator->occupied_space();
 
        h.true_object = true_object;

diff --git a/vm/os-windows-nt-x86.32.cpp b/vm/os-windows-nt-x86.32.cpp
new file mode 100644 (file)
index 0000000..61cf9f6
--- /dev/null
+++ b/vm/os-windows-nt-x86.32.cpp
@@ -0,0 +1,12 @@
+#include "master.hpp"
+
+namespace factor
+{
+
+void factor_vm::c_to_factor_toplevel(cell quot)
+{
+       /* 32-bit Windows SEH is set up in basis/cpu/x86/32/winnt/bootstrap.factor */
+       c_to_factor(quot);
+}
+
+}

diff --git a/vm/os-windows-nt-x86.64.cpp b/vm/os-windows-nt-x86.64.cpp
new file mode 100644 (file)
index 0000000..876d0c5
--- /dev/null
+++ b/vm/os-windows-nt-x86.64.cpp
@@ -0,0 +1,85 @@
+#include "master.hpp"
+
+namespace factor {
+
+typedef unsigned char UBYTE;
+
+const UBYTE UNW_FLAG_EHANDLER = 0x1;
+
+struct UNWIND_INFO {
+       UBYTE Version:3;
+       UBYTE Flags:5;
+       UBYTE SizeOfProlog;
+       UBYTE CountOfCodes;
+       UBYTE FrameRegister:4;
+       UBYTE FrameOffset:4;
+       ULONG ExceptionHandler;
+       ULONG ExceptionData[1];
+};
+
+struct seh_data {
+       UNWIND_INFO unwind_info;
+       RUNTIME_FUNCTION func;
+       UBYTE handler[32];
+};
+
+void factor_vm::c_to_factor_toplevel(cell quot)
+{
+       /* The annoying thing about Win64 SEH is that the offsets in
+        * function tables are 32-bit integers, and the exception handler
+        * itself must reside between the start and end pointers, so
+        * we stick everything at the beginning of the code heap and
+        * generate a small trampoline that jumps to the real
+        * exception handler. */
+
+       seh_data *seh_area = (seh_data *)code->seh_area;
+       cell base = code->seg->start;
+
+       /* Should look at generating this with the Factor assembler */
+
+       /* mov rax,0 */
+       seh_area->handler[0] = 0x48;
+       seh_area->handler[1] = 0xb8;
+       seh_area->handler[2] = 0x0;
+       seh_area->handler[3] = 0x0;
+       seh_area->handler[4] = 0x0;
+       seh_area->handler[5] = 0x0;
+       seh_area->handler[6] = 0x0;
+       seh_area->handler[7] = 0x0;
+       seh_area->handler[8] = 0x0;
+       seh_area->handler[9] = 0x0;
+
+       /* jmp rax */
+       seh_area->handler[10] = 0x48;
+       seh_area->handler[11] = 0xff;
+       seh_area->handler[12] = 0xe0;
+
+       /* Store address of exception handler in the operand of the 'mov' */
+       cell handler = (cell)&factor::exception_handler;
+       memcpy(&seh_area->handler[2],&handler,sizeof(cell));
+
+       UNWIND_INFO *unwind_info = &seh_area->unwind_info;
+       unwind_info->Version = 1;
+       unwind_info->Flags = UNW_FLAG_EHANDLER;
+       unwind_info->SizeOfProlog = 0;
+       unwind_info->CountOfCodes = 0;
+       unwind_info->FrameRegister = 0;
+       unwind_info->FrameOffset = 0;
+       unwind_info->ExceptionHandler = (DWORD)((cell)&seh_area->handler[0] - base);
+       unwind_info->ExceptionData[0] = 0;
+
+       RUNTIME_FUNCTION *func = &seh_area->func;
+       func->BeginAddress = 0;
+       func->EndAddress = (DWORD)(code->seg->end - base);
+       func->UnwindData = (DWORD)((cell)&seh_area->unwind_info - base);
+
+       if(!RtlAddFunctionTable(func,1,base))
+               fatal_error("RtlAddFunctionTable() failed",0);
+
+       c_to_factor(quot);
+
+       if(!RtlDeleteFunctionTable(func))
+               fatal_error("RtlDeleteFunctionTable() failed",0);
+}
+
+}

diff --git a/vm/os-windows-nt.cpp b/vm/os-windows-nt.cpp
index b7f86233a1da77c1a85805cff88a0afc801d36b1..4fea294a12da583fb82ff55565c83a67f636113d 100755 (executable)
--- a/vm/os-windows-nt.cpp
+++ b/vm/os-windows-nt.cpp
@@ -84,7 +84,7 @@ LONG factor_vm::exception_handler(PEXCEPTION_RECORD e, void *frame, PCONTEXT c,
                break;
        }
 
-       return ExceptionContinueExecution;
+       return 0;
 }
 
 VM_C_API LONG exception_handler(PEXCEPTION_RECORD e, void *frame, PCONTEXT c, void *dispatch)
@@ -92,11 +92,6 @@ VM_C_API LONG exception_handler(PEXCEPTION_RECORD e, void *frame, PCONTEXT c, vo
        return current_vm()->exception_handler(e,frame,c,dispatch);
 }
 
-void factor_vm::c_to_factor_toplevel(cell quot)
-{
-       c_to_factor(quot);
-}
-
 void factor_vm::open_console()
 {
 }