From bb8cd5a84c60eff65f6017a32af0441f539c0849 Mon Sep 17 00:00:00 2001 From: Sheepson Apprentice Date: Tue, 22 Dec 2009 11:09:42 -0600 Subject: [PATCH 01/72] fix spacing in factor.sh --- build-support/factor.sh | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/build-support/factor.sh b/build-support/factor.sh index 2f8745aeef..c2775f435a 100755 --- a/build-support/factor.sh +++ b/build-support/factor.sh @@ -25,9 +25,9 @@ test_program_installed() { exit_script() { if [[ $FIND_MAKE_TARGET -eq true ]] ; then - echo $MAKE_TARGET; - fi - exit $1 + echo $MAKE_TARGET; + fi + exit $1 } ensure_program_installed() { @@ -347,7 +347,7 @@ update_script_name() { update_script() { update_script=`update_script_name` - bash_path=`which bash` + bash_path=`which bash` echo "#!$bash_path" >"$update_script" echo "git pull \"$GIT_URL\" master" >>"$update_script" echo "if [[ \$? -eq 0 ]]; then exec \"$0\" $SCRIPT_ARGS; else echo \"git pull failed\"; exit 2; fi" \ @@ -433,7 +433,7 @@ make_factor() { update_boot_images() { echo "Deleting old images..." $DELETE checksums.txt* > /dev/null 2>&1 - # delete boot images with one or two characters after the dot + # delete boot images with one or two characters after the dot $DELETE $BOOT_IMAGE.{?,??} > /dev/null 2>&1 $DELETE temp/staging.*.image > /dev/null 2>&1 if [[ -f $BOOT_IMAGE ]] ; then From cbef261fde4cbfea7e959bebd18180f0b816c15d Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 4 Jan 2010 10:59:00 -0500 Subject: [PATCH 02/72] update fica constant --- extra/taxes/usa/fica/fica.factor | 1 + 1 file changed, 1 insertion(+) diff --git a/extra/taxes/usa/fica/fica.factor b/extra/taxes/usa/fica/fica.factor index 251f60e6d7..4541a15eca 100644 --- a/extra/taxes/usa/fica/fica.factor +++ b/extra/taxes/usa/fica/fica.factor @@ -9,6 +9,7 @@ ERROR: fica-base-unknown ; : fica-base-rate ( year -- x ) H{ + { 2009 106800 } { 2008 102000 } { 2007 97500 } } at [ fica-base-unknown ] unless* ; From e675288577362687a1c6b4f81e8b00505fe30e1f Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 4 Jan 2010 14:24:13 -0600 Subject: [PATCH 03/72] fix bug in constructor redefinition --- extra/constructors/constructors.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/constructors/constructors.factor b/extra/constructors/constructors.factor index 3cee399925..747c8f53fc 100644 --- a/extra/constructors/constructors.factor +++ b/extra/constructors/constructors.factor @@ -49,8 +49,8 @@ MACRO:: slots>constructor ( class slots -- quot ) reverse? [ reverse ] when '[ @ _ [ execute( obj -- obj ) ] each ] effect define-declared ; -: scan-constructor ( -- class word ) - scan-word [ name>> "<" ">" surround create-in ] keep ; +: scan-constructor ( -- word class ) + scan-word [ name>> "<" ">" surround create-in dup reset-generic ] keep ; : parse-constructor ( -- class word effect def ) scan-constructor complete-effect parse-definition ; From 36d2ac89211b3321a90e6924816904d43874e050 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 6 Jan 2010 15:47:36 +1300 Subject: [PATCH 04/72] vm: move c_to_factor, lazy_jit_compile_impl, throw_impl, set_callstack assembly routines into non-optimizing compiler for x86-64 --- Makefile | 1 + basis/bootstrap/image/image.factor | 17 +- basis/compiler/constants/constants.factor | 2 + basis/cpu/architecture/architecture.factor | 2 +- basis/cpu/ppc/bootstrap.factor | 8 +- basis/cpu/x86/32/32.factor | 2 +- basis/cpu/x86/32/bootstrap.factor | 6 +- basis/cpu/x86/64/64.factor | 2 +- basis/cpu/x86/64/bootstrap.factor | 122 ++++++++++---- basis/cpu/x86/assembler/assembler.factor | 5 + basis/cpu/x86/bootstrap.factor | 2 +- basis/cpu/x86/x86.factor | 20 +-- basis/prettyprint/prettyprint.factor | 4 +- basis/vm/vm.factor | 2 +- core/bootstrap/primitives.factor | 57 +++---- vm/callstack.cpp | 14 -- vm/code_block_visitor.hpp | 2 - vm/cpu-x86.64.S | 177 +-------------------- vm/cpu-x86.S | 1 - vm/cpu-x86.hpp | 12 -- vm/entry_points.cpp | 22 +++ vm/entry_points.hpp | 6 + vm/errors.cpp | 6 +- vm/factor.cpp | 1 + vm/master.hpp | 1 + vm/objects.hpp | 7 +- vm/os-genunix.cpp | 2 +- vm/os-macosx.mm | 2 +- vm/os-windows-nt.cpp | 13 +- vm/primitives.cpp | 2 - vm/quotations.cpp | 39 ++++- vm/vm.cpp | 1 + vm/vm.hpp | 13 +- 33 files changed, 253 insertions(+), 320 deletions(-) create mode 100644 vm/entry_points.cpp create mode 100644 vm/entry_points.hpp diff --git a/Makefile b/Makefile index 80621d8f0a..772f3f9875 100755 --- a/Makefile +++ b/Makefile @@ -47,6 +47,7 @@ DLL_OBJS = $(PLAF_DLL_OBJS) \ vm/data_heap_checker.o \ vm/debug.o \ vm/dispatch.o \ + vm/entry_points.o \ vm/errors.o \ vm/factor.o \ vm/free_list.o \ diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor index bf2d14e3aa..1565373cab 100644 --- a/basis/bootstrap/image/image.factor +++ b/basis/bootstrap/image/image.factor @@ -155,7 +155,7 @@ SYMBOL: jit-literals : define-sub-primitive ( quot word -- ) [ make-jit 3array ] dip sub-primitives get set-at ; -: define-sub-primitive* ( quot non-tail-quot tail-quot word -- ) +: define-combinator-primitive ( quot non-tail-quot tail-quot word -- ) [ [ make-jit ] [ make-jit 2nip ] @@ -202,6 +202,10 @@ USERENV: jit-3dip 39 USERENV: jit-execute 40 USERENV: jit-declare-word 41 +USERENV: c-to-factor-word 42 +USERENV: lazy-jit-compile-word 43 +USERENV: unwind-native-frames-word 44 + USERENV: callback-stub 48 ! PIC stubs @@ -534,11 +538,14 @@ M: quotation ' \ dip jit-dip-word set \ 2dip jit-2dip-word set \ 3dip jit-3dip-word set - \ inline-cache-miss \ pic-miss-word set - \ inline-cache-miss-tail \ pic-miss-tail-word set - \ mega-cache-lookup \ mega-lookup-word set - \ mega-cache-miss \ mega-miss-word set + \ inline-cache-miss pic-miss-word set + \ inline-cache-miss-tail pic-miss-tail-word set + \ mega-cache-lookup mega-lookup-word set + \ mega-cache-miss mega-miss-word set \ declare jit-declare-word set + \ c-to-factor c-to-factor-word set + \ lazy-jit-compile lazy-jit-compile-word set + \ unwind-native-frames unwind-native-frames-word set [ undefined ] undefined-quot set ; : emit-userenvs ( -- ) diff --git a/basis/compiler/constants/constants.factor b/basis/compiler/constants/constants.factor index 83b50b61f4..bc7f037b4a 100644 --- a/basis/compiler/constants/constants.factor +++ b/basis/compiler/constants/constants.factor @@ -25,6 +25,8 @@ CONSTANT: deck-bits 18 : word-code-offset ( -- n ) 11 \ word type-number slot-offset ; inline : array-start-offset ( -- n ) 2 array type-number slot-offset ; inline : compiled-header-size ( -- n ) 4 bootstrap-cells ; inline +: callstack-length-offset ( -- n ) 1 \ callstack type-number slot-offset ; inline +: callstack-top-offset ( -- n ) 2 \ callstack type-number slot-offset ; inline ! Relocation classes CONSTANT: rc-absolute-cell 0 diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor index 5127b56acf..03090dc4b5 100644 --- a/basis/cpu/architecture/architecture.factor +++ b/basis/cpu/architecture/architecture.factor @@ -550,7 +550,7 @@ HOOK: %save-param-reg cpu ( stack reg rep -- ) HOOK: %load-param-reg cpu ( stack reg rep -- ) -HOOK: %load-context cpu ( temp1 temp2 -- ) +HOOK: %restore-context cpu ( temp1 temp2 -- ) HOOK: %save-context cpu ( temp1 temp2 -- ) diff --git a/basis/cpu/ppc/bootstrap.factor b/basis/cpu/ppc/bootstrap.factor index a5267b898b..837acd0ea1 100644 --- a/basis/cpu/ppc/bootstrap.factor +++ b/basis/cpu/ppc/bootstrap.factor @@ -215,12 +215,12 @@ CONSTANT: vm-reg 15 [ jit-load-return-address jit-inline-cache-miss ] [ 3 MTLR BLRL ] [ 3 MTCTR BCTR ] -\ inline-cache-miss define-sub-primitive* +\ inline-cache-miss define-combinator-primitive [ jit-inline-cache-miss ] [ 3 MTLR BLRL ] [ 3 MTCTR BCTR ] -\ inline-cache-miss-tail define-sub-primitive* +\ inline-cache-miss-tail define-combinator-primitive ! ! ! Megamorphic caches @@ -271,7 +271,7 @@ CONSTANT: vm-reg 15 5 3 quot-xt-offset LWZ ] [ 5 MTLR BLRL ] -[ 5 MTCTR BCTR ] \ (call) define-sub-primitive* +[ 5 MTCTR BCTR ] \ (call) define-combinator-primitive [ 3 ds-reg 0 LWZ @@ -279,7 +279,7 @@ CONSTANT: vm-reg 15 4 3 word-xt-offset LWZ ] [ 4 MTLR BLRL ] -[ 4 MTCTR BCTR ] \ (execute) define-sub-primitive* +[ 4 MTCTR BCTR ] \ (execute) define-combinator-primitive [ 3 ds-reg 0 LWZ diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index 8b44b65809..e741012bc4 100644 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -235,7 +235,7 @@ M: x86.32 %alien-indirect ( -- ) EBP CALL ; M: x86.32 %alien-callback ( quot -- ) - EAX EDX %load-context + EAX EDX %restore-context EAX swap %load-reference EDX %mov-vm-ptr EAX quot-xt-offset [+] CALL diff --git a/basis/cpu/x86/32/bootstrap.factor b/basis/cpu/x86/32/bootstrap.factor index 580db11946..9c57804e3a 100644 --- a/basis/cpu/x86/32/bootstrap.factor +++ b/basis/cpu/x86/32/bootstrap.factor @@ -77,7 +77,7 @@ IN: bootstrap.x86 ] [ EAX quot-xt-offset [+] CALL ] [ EAX quot-xt-offset [+] JMP ] -\ (call) define-sub-primitive* +\ (call) define-combinator-primitive ! Inline cache miss entry points : jit-load-return-address ( -- ) @@ -96,12 +96,12 @@ IN: bootstrap.x86 [ jit-load-return-address jit-inline-cache-miss ] [ EAX CALL ] [ EAX JMP ] -\ inline-cache-miss define-sub-primitive* +\ inline-cache-miss define-combinator-primitive [ jit-inline-cache-miss ] [ EAX CALL ] [ EAX JMP ] -\ inline-cache-miss-tail define-sub-primitive* +\ inline-cache-miss-tail define-combinator-primitive ! Overflowing fixnum arithmetic : jit-overflow ( insn func -- ) diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor index 5fc6ae8c16..071f45d127 100644 --- a/basis/cpu/x86/64/64.factor +++ b/basis/cpu/x86/64/64.factor @@ -223,7 +223,7 @@ M: x86.64 %alien-indirect ( -- ) RBP CALL ; M: x86.64 %alien-callback ( quot -- ) - param-reg-0 param-reg-1 %load-context + param-reg-0 param-reg-1 %restore-context param-reg-0 swap %load-reference param-reg-1 %mov-vm-ptr param-reg-0 quot-xt-offset [+] CALL diff --git a/basis/cpu/x86/64/bootstrap.factor b/basis/cpu/x86/64/bootstrap.factor index a1bdcbd1ff..4c059141af 100644 --- a/basis/cpu/x86/64/bootstrap.factor +++ b/basis/cpu/x86/64/bootstrap.factor @@ -1,9 +1,10 @@ -! Copyright (C) 2007, 2009 Slava Pestov. +! Copyright (C) 2007, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: bootstrap.image.private kernel kernel.private namespaces system layouts vocabs parser compiler.constants math math.private cpu.x86.assembler cpu.x86.assembler.operands sequences generic.single.private ; +FROM: vm => context-field-offset vm-field-offset ; IN: bootstrap.x86 8 \ cell set @@ -15,9 +16,12 @@ IN: bootstrap.x86 : temp1 ( -- reg ) RSI ; : temp2 ( -- reg ) RDX ; : temp3 ( -- reg ) RBX ; +: return-reg ( -- reg ) RAX ; : safe-reg ( -- reg ) RAX ; : stack-reg ( -- reg ) RSP ; : frame-reg ( -- reg ) RBP ; +: vm-reg ( -- reg ) R12 ; +: ctx-reg ( -- reg ) R13 ; : ds-reg ( -- reg ) R14 ; : rs-reg ( -- reg ) R15 ; : fixnum>slot@ ( -- ) temp0 1 SAR ; @@ -25,60 +29,114 @@ IN: bootstrap.x86 [ ! load XT - RDI 0 MOV rc-absolute-cell rt-this jit-rel + safe-reg 0 MOV rc-absolute-cell rt-this jit-rel ! save stack frame size stack-frame-size PUSH ! push XT - RDI PUSH + safe-reg PUSH ! alignment RSP stack-frame-size 3 bootstrap-cells - SUB ] jit-prolog jit-define : jit-load-vm ( -- ) - RBP 0 MOV 0 rc-absolute-cell jit-vm ; + vm-reg 0 MOV 0 rc-absolute-cell jit-vm ; + +: jit-load-context ( -- ) + ! VM pointer must be in vm-reg already + ctx-reg vm-reg "ctx" vm-field-offset [+] MOV ; : jit-save-context ( -- ) - ! VM pointer must be in RBP already - RCX RBP [] MOV - ! save ctx->callstack_top - RAX RSP -8 [+] LEA - RCX [] RAX MOV - ! save ctx->datastack - RCX 16 [+] ds-reg MOV - ! save ctx->retainstack - RCX 24 [+] rs-reg MOV ; + jit-load-context + safe-reg RSP -8 [+] LEA + ctx-reg "callstack-top" context-field-offset [+] safe-reg MOV + ctx-reg "datastack" context-field-offset [+] ds-reg MOV + ctx-reg "retainstack" context-field-offset [+] rs-reg MOV ; : jit-restore-context ( -- ) - ! VM pointer must be in EBP already - RCX RBP [] MOV - ! restore ctx->datastack - ds-reg RCX 16 [+] MOV - ! restore ctx->retainstack - rs-reg RCX 24 [+] MOV ; + jit-load-context + ds-reg ctx-reg "datastack" context-field-offset [+] MOV + rs-reg ctx-reg "retainstack" context-field-offset [+] MOV ; [ jit-load-vm - ! save ds, rs registers jit-save-context ! call the primitive - arg1 RBP MOV + arg1 vm-reg MOV RAX 0 MOV rc-absolute-cell rt-primitive jit-rel RAX CALL - ! restore ds, rs registers jit-restore-context ] jit-primitive jit-define [ - ! load from stack + jit-load-vm + jit-restore-context + ! save ctx->callstack_bottom + safe-reg stack-reg stack-frame-size bootstrap-cell - [+] LEA + ctx-reg "callstack-bottom" context-field-offset [+] safe-reg MOV + ! call the quotation + arg1 quot-xt-offset [+] CALL + jit-save-context +] \ c-to-factor define-sub-primitive + +[ arg1 ds-reg [] MOV - ! pop stack ds-reg bootstrap-cell SUB - ! load VM pointer - arg2 0 MOV 0 rc-absolute-cell jit-vm ] [ arg1 quot-xt-offset [+] CALL ] [ arg1 quot-xt-offset [+] JMP ] -\ (call) define-sub-primitive* +\ (call) define-combinator-primitive + +[ + ! Clear x87 stack, but preserve rounding mode and exception flags + RSP 2 SUB + RSP [] FNSTCW + FNINIT + RSP [] FLDCW + + ! Unwind stack frames + RSP arg2 MOV + + ! Load ds and rs registers + jit-load-vm + jit-restore-context + + ! Call quotation + arg1 quot-xt-offset [+] JMP +] \ unwind-native-frames define-sub-primitive + +[ + ! Load callstack object + arg4 ds-reg [] MOV + ds-reg bootstrap-cell SUB + ! Get ctx->callstack_bottom + jit-load-vm + jit-load-context + arg1 ctx-reg "callstack-bottom" context-field-offset [+] MOV + ! Get top of callstack object -- 'src' for memcpy + arg2 arg4 callstack-top-offset [+] LEA + ! Get callstack length, in bytes --- 'len' for memcpy + arg3 arg4 callstack-length-offset [+] MOV + arg3 tag-bits get SHR + ! Compute new stack pointer -- 'dst' for memcpy + arg1 arg3 SUB + RSP arg1 MOV + ! Call memcpy; arguments are now in the correct registers + safe-reg 0 MOV "memcpy" f rc-absolute-cell jit-dlsym + safe-reg CALL + ! Return with new callstack + 0 RET +] \ set-callstack define-sub-primitive + +[ + jit-load-vm + jit-save-context + arg2 vm-reg MOV + safe-reg 0 MOV "lazy_jit_compile" f rc-absolute-cell jit-dlsym + safe-reg CALL +] +[ return-reg quot-xt-offset [+] CALL ] +[ return-reg quot-xt-offset [+] JMP ] +\ lazy-jit-compile define-combinator-primitive ! Inline cache miss entry points : jit-load-return-address ( -- ) @@ -90,7 +148,7 @@ IN: bootstrap.x86 jit-load-vm jit-save-context arg1 RBX MOV - arg2 RBP MOV + arg2 vm-reg MOV RAX 0 MOV "inline_cache_miss" f rc-absolute-cell jit-dlsym RAX CALL jit-restore-context ; @@ -98,12 +156,12 @@ IN: bootstrap.x86 [ jit-load-return-address jit-inline-cache-miss ] [ RAX CALL ] [ RAX JMP ] -\ inline-cache-miss define-sub-primitive* +\ inline-cache-miss define-combinator-primitive [ jit-inline-cache-miss ] [ RAX CALL ] [ RAX JMP ] -\ inline-cache-miss-tail define-sub-primitive* +\ inline-cache-miss-tail define-combinator-primitive ! Overflowing fixnum arithmetic : jit-overflow ( insn func -- ) @@ -117,7 +175,7 @@ IN: bootstrap.x86 ds-reg [] arg3 MOV [ JNO ] [ - arg3 RBP MOV + arg3 vm-reg MOV RAX 0 MOV f rc-absolute-cell jit-dlsym RAX CALL ] @@ -142,7 +200,7 @@ IN: bootstrap.x86 arg1 RCX MOV arg1 tag-bits get SAR arg2 RBX MOV - arg3 RBP MOV + arg3 vm-reg MOV RAX 0 MOV "overflow_fixnum_multiply" f rc-absolute-cell jit-dlsym RAX CALL ] diff --git a/basis/cpu/x86/assembler/assembler.factor b/basis/cpu/x86/assembler/assembler.factor index 57738ce4ba..fc000ced23 100644 --- a/basis/cpu/x86/assembler/assembler.factor +++ b/basis/cpu/x86/assembler/assembler.factor @@ -385,6 +385,11 @@ PRIVATE> : FLDS ( operand -- ) { BIN: 000 f HEX: d9 } 1-operand ; : FLDL ( operand -- ) { BIN: 000 f HEX: dd } 1-operand ; +: FNSTCW ( operand -- ) { BIN: 111 f HEX: d9 } 1-operand ; +: FLDCW ( operand -- ) { BIN: 101 f HEX: d9 } 1-operand ; + +: FNINIT ( -- ) HEX: db , HEX: e3 , ; + ! SSE multimedia instructions > cell - [+] LEA - temp1 1 cells [+] temp2 MOV - ! datastack - ds-reg temp1 2 cells [+] MOV - ! retainstack - rs-reg temp1 3 cells [+] MOV ; + temp1 "callstack-bottom" context-field-offset [+] temp2 MOV + ds-reg temp1 "datastack" context-field-offset [+] MOV + rs-reg temp1 "retainstack" context-field-offset [+] MOV ; M:: x86 %save-context ( temp1 temp2 -- ) #! Save Factor stack pointers in case the C code calls a @@ -1429,13 +1426,10 @@ M:: x86 %save-context ( temp1 temp2 -- ) #! all roots. temp1 "ctx" %vm-field-ptr temp1 temp1 [] MOV - ! callstack_top temp2 stack-reg cell neg [+] LEA - temp1 [] temp2 MOV - ! datastack - temp1 2 cells [+] ds-reg MOV - ! retainstack - temp1 3 cells [+] rs-reg MOV ; + temp1 "callstack-top" context-field-offset [+] temp2 MOV + temp1 "datastack" context-field-offset [+] ds-reg MOV + temp1 "retainstack" context-field-offset [+] rs-reg MOV ; M: x86 value-struct? drop t ; diff --git a/basis/prettyprint/prettyprint.factor b/basis/prettyprint/prettyprint.factor index 6cff399201..65d25f1812 100644 --- a/basis/prettyprint/prettyprint.factor +++ b/basis/prettyprint/prettyprint.factor @@ -73,8 +73,8 @@ SYMBOL: -> : remove-breakpoints ( quot pos -- quot' ) over quotation? [ - 1 + cut [ (remove-breakpoints) ] bi@ - [ -> ] glue + 1 + short cut [ (remove-breakpoints) ] bi@ + [ -> ] glue ] [ drop ] if ; diff --git a/basis/vm/vm.factor b/basis/vm/vm.factor index 278296c4d0..20428c40f3 100644 --- a/basis/vm/vm.factor +++ b/basis/vm/vm.factor @@ -9,7 +9,7 @@ STRUCT: context { callstack-top void* } { callstack-bottom void* } { datastack cell } -{ callstack cell } +{ retainstack cell } { magic-frame void* } { datastack-region void* } { retainstack-region void* } diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index ac1f4fad69..a0b278c7a4 100644 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -312,8 +312,36 @@ tuple [ create dup 1quotation ] dip define-declared ; { + { "mega-cache-lookup" "generic.single.private" (( methods index cache -- )) } + { "inline-cache-miss" "generic.single.private" (( generic methods index cache -- )) } + { "inline-cache-miss-tail" "generic.single.private" (( generic methods index cache -- )) } + { "drop" "kernel" (( x -- )) } + { "2drop" "kernel" (( x y -- )) } + { "3drop" "kernel" (( x y z -- )) } + { "dup" "kernel" (( x -- x x )) } + { "2dup" "kernel" (( x y -- x y x y )) } + { "3dup" "kernel" (( x y z -- x y z x y z )) } + { "rot" "kernel" (( x y z -- y z x )) } + { "-rot" "kernel" (( x y z -- z x y )) } + { "dupd" "kernel" (( x y -- x x y )) } + { "swapd" "kernel" (( x y z -- y x z )) } + { "nip" "kernel" (( x y -- y )) } + { "2nip" "kernel" (( x y z -- z )) } + { "over" "kernel" (( x y -- x y x )) } + { "pick" "kernel" (( x y z -- x y z x )) } + { "swap" "kernel" (( x y -- y x )) } + { "eq?" "kernel" (( obj1 obj2 -- ? )) } + { "tag" "kernel.private" (( object -- n )) } { "(execute)" "kernel.private" (( word -- )) } { "(call)" "kernel.private" (( quot -- )) } + { "unwind-native-frames" "kernel.private" (( -- )) } + { "set-callstack" "kernel.private" (( cs -- * )) } + { "lazy-jit-compile" "kernel.private" (( -- )) } + { "c-to-factor" "kernel.private" (( -- )) } + { "slot" "slots.private" (( obj m -- value )) } + { "get-local" "locals.backend" (( n -- obj )) } + { "load-local" "locals.backend" (( obj -- )) } + { "drop-locals" "locals.backend" (( n -- )) } { "both-fixnums?" "math.private" (( x y -- ? )) } { "fixnum+fast" "math.private" (( x y -- z )) } { "fixnum-fast" "math.private" (( x y -- z )) } @@ -333,30 +361,6 @@ tuple { "fixnum<=" "math.private" (( x y -- z )) } { "fixnum>" "math.private" (( x y -- ? )) } { "fixnum>=" "math.private" (( x y -- ? )) } - { "drop" "kernel" (( x -- )) } - { "2drop" "kernel" (( x y -- )) } - { "3drop" "kernel" (( x y z -- )) } - { "dup" "kernel" (( x -- x x )) } - { "2dup" "kernel" (( x y -- x y x y )) } - { "3dup" "kernel" (( x y z -- x y z x y z )) } - { "rot" "kernel" (( x y z -- y z x )) } - { "-rot" "kernel" (( x y z -- z x y )) } - { "dupd" "kernel" (( x y -- x x y )) } - { "swapd" "kernel" (( x y z -- y x z )) } - { "nip" "kernel" (( x y -- y )) } - { "2nip" "kernel" (( x y z -- z )) } - { "over" "kernel" (( x y -- x y x )) } - { "pick" "kernel" (( x y z -- x y z x )) } - { "swap" "kernel" (( x y -- y x )) } - { "eq?" "kernel" (( obj1 obj2 -- ? )) } - { "tag" "kernel.private" (( object -- n )) } - { "slot" "slots.private" (( obj m -- value )) } - { "get-local" "locals.backend" (( n -- obj )) } - { "load-local" "locals.backend" (( obj -- )) } - { "drop-locals" "locals.backend" (( n -- )) } - { "mega-cache-lookup" "generic.single.private" (( methods index cache -- )) } - { "inline-cache-miss" "generic.single.private" (( generic methods index cache -- )) } - { "inline-cache-miss-tail" "generic.single.private" (( generic methods index cache -- )) } } [ first3 make-sub-primitive ] each ! Primitive words @@ -428,9 +432,8 @@ tuple { "datastack" "kernel" (( -- ds )) } { "retainstack" "kernel" (( -- rs )) } { "callstack" "kernel" (( -- cs )) } - { "set-datastack" "kernel" (( ds -- )) } - { "set-retainstack" "kernel" (( rs -- )) } - { "set-callstack" "kernel" (( cs -- * )) } + { "set-datastack" "kernel.private" (( ds -- )) } + { "set-retainstack" "kernel.private" (( rs -- )) } { "(exit)" "system" (( n -- )) } { "data-room" "memory" (( -- data-room )) } { "code-room" "memory" (( -- code-room )) } diff --git a/vm/callstack.cpp b/vm/callstack.cpp index 714a4585c3..b6742534b9 100755 --- a/vm/callstack.cpp +++ b/vm/callstack.cpp @@ -60,20 +60,6 @@ void factor_vm::primitive_callstack() ctx->push(tag(stack)); } -void factor_vm::primitive_set_callstack() -{ - callstack *stack = untag_check(ctx->pop()); - - set_callstack(this, - ctx->callstack_bottom, - stack->top(), - untag_fixnum(stack->length), - memcpy); - - /* We cannot return here ... */ - critical_error("Bug in set_callstack()",0); -} - code_block *factor_vm::frame_code(stack_frame *frame) { check_frame(frame); diff --git a/vm/code_block_visitor.hpp b/vm/code_block_visitor.hpp index 0624adb268..dce82843f8 100644 --- a/vm/code_block_visitor.hpp +++ b/vm/code_block_visitor.hpp @@ -72,8 +72,6 @@ void code_block_visitor::visit_object_code_block(object *obj) quotation *q = (quotation *)obj; if(q->code) parent->set_quot_xt(q,visitor(q->code)); - else - q->xt = (void *)lazy_jit_compile_impl; break; } case CALLSTACK_TYPE: diff --git a/vm/cpu-x86.64.S b/vm/cpu-x86.64.S index 37a6507206..a65b0d67e7 100644 --- a/vm/cpu-x86.64.S +++ b/vm/cpu-x86.64.S @@ -1,180 +1,5 @@ #include "asm.h" -#define DS_REG %r14 -#define RS_REG %r15 -#define RETURN_REG %rax - -#define QUOT_XT_OFFSET 28 - -#ifdef WINDOWS - - #define ARG0 %rcx - #define ARG1 %rdx - #define ARG2 %r8 - #define ARG3 %r9 - - #define PUSH_NONVOLATILE \ - push %r15 ; \ - push %r14 ; \ - 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 ; \ - pop %r14 ; \ - pop %r15 - -#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 %r14 ; \ - push %r15 - - #define POP_NONVOLATILE \ - pop %r15 ; \ - pop %r14 ; \ - pop %r13 ; \ - pop %r12 ; \ - pop %rbp ; \ - pop %rbx - -#endif - -DEF(void,c_to_factor,(cell quot, void *vm)): - PUSH_NONVOLATILE - - /* Save old stack pointer and align */ - mov %rsp,%rbp - and $-16,%rsp - push %rbp - - /* Set up stack frame for the call to the boot quotation */ - push ARG0 - push ARG1 - - /* Create register shadow area (required for Win64 only) */ - sub $40,%rsp - - /* Load context */ - mov (ARG1),ARG2 - - /* Save ctx->callstack_bottom */ - lea -8(%rsp),ARG3 - mov ARG3,8(ARG2) - - /* Load ctx->datastack */ - mov 16(ARG2),DS_REG - - /* Load ctx->retainstack */ - mov 24(ARG2),RS_REG - - /* Call quot-xt */ - call *QUOT_XT_OFFSET(ARG0) - - /* Tear down register shadow area */ - add $40,%rsp - - /* Tear down stack frame for the call to the boot quotation */ - pop ARG1 - pop ARG0 - - /* Undo stack alignment */ - pop %rbp - mov %rbp,%rsp - - /* Load context */ - mov (ARG1),ARG2 - - /* Save ctx->datastack */ - mov DS_REG,16(ARG2) - - /* Save ctx->retainstack */ - mov RS_REG,24(ARG2) - - POP_NONVOLATILE - ret - -DEF(void,set_callstack,(void *vm, stack_frame *to, stack_frame *from, cell length)): - /* save VM pointer in non-volatile register */ - mov ARG0,%rbp - - /* compute new stack pointer */ - sub ARG3,ARG1 - mov ARG1,%rsp - - /* call memcpy */ - mov ARG1,ARG0 - mov ARG2,ARG1 - mov ARG3,ARG2 - call MANGLE(memcpy) - - /* load context */ - mov (%rbp),ARG2 - /* load datastack */ - mov 16(ARG2),DS_REG - /* load retainstack */ - mov 24(ARG2),RS_REG - - /* return with new stack */ - ret - -DEF(void,throw_impl,(cell quot, void *new_stack, void *vm)): - /* clear x87 stack, but preserve rounding mode and exception flags */ - sub $2,%rsp - fnstcw (%rsp) - fninit - fldcw (%rsp) - - /* shuffle args */ - mov ARG1,%rsp - mov ARG2,ARG1 - - /* load context */ - mov (ARG1),ARG2 - /* load datastack */ - mov 16(ARG2),DS_REG - /* load retainstack */ - mov 24(ARG2),RS_REG - - jmp *QUOT_XT_OFFSET(ARG0) - -DEF(void,lazy_jit_compile_impl,(cell quot, void *vm)): - /* load context */ - mov (ARG1),ARG2 - /* save datastack */ - mov DS_REG,16(ARG2) - /* save retainstack */ - mov RS_REG,24(ARG2) - /* save callstack */ - lea -8(%rsp),%rbp - mov %rbp,(ARG2) - - /* compile quotation */ - sub $8,%rsp - call MANGLE(lazy_jit_compile) - add $8,%rsp - - /* call quotation */ - jmp *QUOT_XT_OFFSET(RETURN_REG) - DEF(long long,read_timestamp_counter,(void)): mov $0,%rax rdtsc @@ -199,5 +24,7 @@ DEF(void,set_x87_env,(const void*)): fnclex fldcw 2(%rdi) ret + +#define RETURN_REG %rax #include "cpu-x86.S" diff --git a/vm/cpu-x86.S b/vm/cpu-x86.S index d59d0df7fb..dae775ae3d 100644 --- a/vm/cpu-x86.S +++ b/vm/cpu-x86.S @@ -38,5 +38,4 @@ sse_1: #ifdef WINDOWS .section .drectve .ascii " -export:sse_version" - .ascii " -export:c_to_factor" #endif diff --git a/vm/cpu-x86.hpp b/vm/cpu-x86.hpp index 349548f1ca..c96291b0d7 100644 --- a/vm/cpu-x86.hpp +++ b/vm/cpu-x86.hpp @@ -73,16 +73,4 @@ inline static unsigned int fpu_status(unsigned int status) return r; } -/* Defined in assembly */ -VM_C_API void c_to_factor(cell quot, void *vm); -VM_C_API void throw_impl(cell quot, void *new_stack, void *vm); -VM_C_API void lazy_jit_compile_impl(cell quot, void *vm); - -VM_C_API void set_callstack( - void *vm, - stack_frame *to, - stack_frame *from, - cell length, - void *(*memcpy)(void*,const void*, size_t)); - } diff --git a/vm/entry_points.cpp b/vm/entry_points.cpp new file mode 100644 index 0000000000..87a3c056e2 --- /dev/null +++ b/vm/entry_points.cpp @@ -0,0 +1,22 @@ +#include "master.hpp" + +namespace factor +{ + +void factor_vm::c_to_factor(cell quot) +{ + /* First time this is called, wrap the c-to-factor sub-primitive inside + of a callback stub, which saves and restores non-volatile registers + as per platform ABI conventions, so that the Factor compiler can treat + all registers as volatile */ + if(!c_to_factor_func) + { + tagged c_to_factor_word(special_objects[C_TO_FACTOR_WORD]); + code_block *c_to_factor_block = callbacks->add(c_to_factor_word.value(),0); + c_to_factor_func = (c_to_factor_func_type)c_to_factor_block->xt(); + } + + c_to_factor_func(quot); +} + +} diff --git a/vm/entry_points.hpp b/vm/entry_points.hpp new file mode 100644 index 0000000000..663eb7dbb4 --- /dev/null +++ b/vm/entry_points.hpp @@ -0,0 +1,6 @@ +namespace factor +{ + +typedef void (* c_to_factor_func_type)(cell quot); + +} diff --git a/vm/errors.cpp b/vm/errors.cpp index 2292c27693..2dcb773dd1 100755 --- a/vm/errors.cpp +++ b/vm/errors.cpp @@ -31,7 +31,7 @@ void factor_vm::throw_error(cell error, stack_frame *callstack_top) { /* If the error handler is set, we rewind any C stack frames and pass the error to user-space. */ - if(!current_gc && to_boolean(special_objects[OBJ_BREAK])) + if(!current_gc && to_boolean(special_objects[ERROR_HANDLER_QUOT])) { /* If error was thrown during heap scan, we re-enable the GC */ gc_off = false; @@ -56,7 +56,7 @@ void factor_vm::throw_error(cell error, stack_frame *callstack_top) else callstack_top = ctx->callstack_top; - throw_impl(special_objects[OBJ_BREAK],callstack_top,this); + unwind_native_frames(special_objects[ERROR_HANDLER_QUOT],callstack_top); } /* Error was thrown in early startup before error handler is set, just crash. */ @@ -130,7 +130,7 @@ void factor_vm::fp_trap_error(unsigned int fpu_status, stack_frame *signal_calls void factor_vm::primitive_call_clear() { - throw_impl(ctx->pop(),ctx->callstack_bottom,this); + unwind_native_frames(ctx->pop(),ctx->callstack_bottom); } /* For testing purposes */ diff --git a/vm/factor.cpp b/vm/factor.cpp index d4824fdcd5..46eb2efdfd 100755 --- a/vm/factor.cpp +++ b/vm/factor.cpp @@ -87,6 +87,7 @@ void factor_vm::do_stage1_init() compile_all_words(); update_code_heap_words(); + initialize_all_quotations(); special_objects[OBJ_STAGE2] = true_object; std::cout << "done\n"; diff --git a/vm/master.hpp b/vm/master.hpp index 80c2f1050d..52fe702401 100755 --- a/vm/master.hpp +++ b/vm/master.hpp @@ -74,6 +74,7 @@ namespace factor #include "alien.hpp" #include "callbacks.hpp" #include "dispatch.hpp" +#include "entry_points.hpp" #include "vm.hpp" #include "allot.hpp" #include "tagged.hpp" diff --git a/vm/objects.hpp b/vm/objects.hpp index 368f0f2c19..fdc5758a8d 100644 --- a/vm/objects.hpp +++ b/vm/objects.hpp @@ -11,7 +11,7 @@ enum special_object { OBJ_WALKER_HOOK, /* non-local exit hook, used by library only */ OBJ_CALLCC_1, /* used to pass the value in callcc1 */ - OBJ_BREAK = 5, /* quotation called by throw primitive */ + ERROR_HANDLER_QUOT = 5, /* quotation called when VM throws an error */ OBJ_ERROR, /* a marker consed onto kernel errors */ OBJ_CELL_SIZE = 7, /* sizeof(cell) */ @@ -57,6 +57,11 @@ enum special_object { JIT_EXECUTE, JIT_DECLARE_WORD, + /* External entry points */ + C_TO_FACTOR_WORD, + LAZY_JIT_COMPILE_WORD, + UNWIND_NATIVE_FRAMES_WORD, + /* Incremented on every modify-code-heap call; invalidates call( inline caching */ REDEFINITION_COUNTER = 47, diff --git a/vm/os-genunix.cpp b/vm/os-genunix.cpp index ba23125e80..301b68fb52 100644 --- a/vm/os-genunix.cpp +++ b/vm/os-genunix.cpp @@ -6,7 +6,7 @@ namespace factor void factor_vm::c_to_factor_toplevel(cell quot) { - c_to_factor(quot,this); + c_to_factor(quot); } void init_signals() diff --git a/vm/os-macosx.mm b/vm/os-macosx.mm index 101169be06..92694a4599 100644 --- a/vm/os-macosx.mm +++ b/vm/os-macosx.mm @@ -11,7 +11,7 @@ void factor_vm::c_to_factor_toplevel(cell quot) for(;;) { NS_DURING - c_to_factor(quot,this); + c_to_factor(quot); NS_VOIDRETURN; NS_HANDLER ctx->push(allot_alien(false_object,(cell)localException)); diff --git a/vm/os-windows-nt.cpp b/vm/os-windows-nt.cpp index f0ae9e7a6d..cab30b121e 100755 --- a/vm/os-windows-nt.cpp +++ b/vm/os-windows-nt.cpp @@ -117,16 +117,13 @@ FACTOR_STDCALL LONG exception_handler(PEXCEPTION_POINTERS pe) return tls_vm()->exception_handler(pe); } -bool handler_added = 0; - void factor_vm::c_to_factor_toplevel(cell quot) { - if(!handler_added){ - if(!AddVectoredExceptionHandler(0, (PVECTORED_EXCEPTION_HANDLER)factor::exception_handler)) - fatal_error("AddVectoredExceptionHandler failed", 0); - handler_added = 1; - } - c_to_factor(quot,this); + if(!AddVectoredExceptionHandler(0, (PVECTORED_EXCEPTION_HANDLER)factor::exception_handler)) + fatal_error("AddVectoredExceptionHandler failed", 0); + + c_to_factor(quot); + RemoveVectoredExceptionHandler((void *)factor::exception_handler); } diff --git a/vm/primitives.cpp b/vm/primitives.cpp index 830ae7beb2..5521b26a3f 100644 --- a/vm/primitives.cpp +++ b/vm/primitives.cpp @@ -62,7 +62,6 @@ PRIMITIVE_FORWARD(retainstack) PRIMITIVE_FORWARD(callstack) PRIMITIVE_FORWARD(set_datastack) PRIMITIVE_FORWARD(set_retainstack) -PRIMITIVE_FORWARD(set_callstack) PRIMITIVE_FORWARD(exit) PRIMITIVE_FORWARD(data_room) PRIMITIVE_FORWARD(code_room) @@ -196,7 +195,6 @@ const primitive_type primitives[] = { primitive_callstack, primitive_set_datastack, primitive_set_retainstack, - primitive_set_callstack, primitive_exit, primitive_data_room, primitive_code_room, diff --git a/vm/quotations.cpp b/vm/quotations.cpp index 5af9d95b02..73c28875fa 100755 --- a/vm/quotations.cpp +++ b/vm/quotations.cpp @@ -294,10 +294,11 @@ void factor_vm::jit_compile_quot(cell quot_, bool relocating) { data_root quot(quot_,this); - if(quot->code) return; - - code_block *compiled = jit_compile_quot(quot.value(),quot.value(),relocating); - set_quot_xt(quot.untagged(),compiled); + if(quot->code == NULL || quot->code == lazy_jit_compile_block()) + { + code_block *compiled = jit_compile_quot(quot.value(),quot.value(),relocating); + set_quot_xt(quot.untagged(),compiled); + } } void factor_vm::primitive_jit_compile() @@ -305,15 +306,21 @@ void factor_vm::primitive_jit_compile() jit_compile_quot(ctx->pop(),true); } +code_block *factor_vm::lazy_jit_compile_block() +{ + return untag(special_objects[LAZY_JIT_COMPILE_WORD])->code; +} + /* push a new quotation on the stack */ void factor_vm::primitive_array_to_quotation() { quotation *quot = allot(sizeof(quotation)); + quot->array = ctx->peek(); quot->cached_effect = false_object; quot->cache_counter = false_object; - quot->xt = (void *)lazy_jit_compile_impl; - quot->code = NULL; + set_quot_xt(quot,lazy_jit_compile_block()); + ctx->replace(tag(quot)); } @@ -353,7 +360,25 @@ void factor_vm::primitive_quot_compiled_p() { tagged quot(ctx->pop()); quot.untag_check(this); - ctx->push(tag_boolean(quot->code != NULL)); + ctx->push(tag_boolean(quot->code != lazy_jit_compile_block())); +} + +cell factor_vm::find_all_quotations() +{ + return instances(QUOTATION_TYPE); +} + +void factor_vm::initialize_all_quotations() +{ + data_root quotations(find_all_quotations(),this); + + cell length = array_capacity(quotations.untagged()); + for(cell i = 0; i < length; i++) + { + data_root quot(array_nth(quotations.untagged(),i),this); + if(!quot->code) + set_quot_xt(quot.untagged(),lazy_jit_compile_block()); + } } } diff --git a/vm/vm.cpp b/vm/vm.cpp index d911b80227..623556416a 100755 --- a/vm/vm.cpp +++ b/vm/vm.cpp @@ -5,6 +5,7 @@ namespace factor factor_vm::factor_vm() : nursery(0,0), + c_to_factor_func(NULL), profiling_p(false), gc_off(false), current_gc(NULL), diff --git a/vm/vm.hpp b/vm/vm.hpp index ef2d7e0644..3a87857488 100755 --- a/vm/vm.hpp +++ b/vm/vm.hpp @@ -30,6 +30,9 @@ struct factor_vm /* Canonical truth value. In Factor, 't' */ cell true_object; + /* External entry points */ + c_to_factor_func_type c_to_factor_func; + /* Is call counting enabled? */ bool profiling_p; @@ -562,7 +565,6 @@ struct factor_vm stack_frame *fix_callstack_top(stack_frame *top, stack_frame *bottom); stack_frame *second_from_top_stack_frame(); void primitive_callstack(); - void primitive_set_callstack(); code_block *frame_code(stack_frame *frame); code_block_type frame_type(stack_frame *frame); cell frame_executing(stack_frame *frame); @@ -596,6 +598,7 @@ struct factor_vm //quotations void primitive_jit_compile(); + code_block *lazy_jit_compile_block(); void primitive_array_to_quotation(); void primitive_quotation_xt(); void set_quot_xt(quotation *quot, code_block *code); @@ -604,6 +607,8 @@ struct factor_vm fixnum quot_code_offset_to_scan(cell quot_, cell offset); cell lazy_jit_compile(cell quot); void primitive_quot_compiled_p(); + cell find_all_quotations(); + void initialize_all_quotations(); //dispatch cell search_lookup_alist(cell table, cell klass); @@ -632,9 +637,13 @@ struct factor_vm void update_pic_transitions(cell pic_size); void *inline_cache_miss(cell return_address); + //entry points + void c_to_factor(cell quot); + void unwind_native_frames(cell quot, stack_frame *to); + //factor void default_parameters(vm_parameters *p); - bool factor_arg(const vm_char* str, const vm_char* arg, cell* value); + bool factor_arg(const vm_char *str, const vm_char *arg, cell *value); void init_parameters_from_args(vm_parameters *p, int argc, vm_char **argv); void do_stage1_init(); void init_factor(vm_parameters *p); From 47c619779934d7d7cc86ab09ced9e922d940a8bd Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 6 Jan 2010 17:55:20 +1300 Subject: [PATCH 05/72] Update x86-32 for assembly entry point changes --- basis/compiler/constants/constants.factor | 5 + basis/cpu/x86/32/bootstrap.factor | 120 ++++++++++++++---- basis/cpu/x86/64/bootstrap.factor | 20 +-- vm/cpu-x86.32.S | 141 ---------------------- vm/entry_points.cpp | 7 ++ vm/entry_points.hpp | 1 + vm/factor.cpp | 6 +- vm/vm.hpp | 2 +- 8 files changed, 123 insertions(+), 179 deletions(-) diff --git a/basis/compiler/constants/constants.factor b/basis/compiler/constants/constants.factor index bc7f037b4a..499a1b192f 100644 --- a/basis/compiler/constants/constants.factor +++ b/basis/compiler/constants/constants.factor @@ -27,6 +27,11 @@ CONSTANT: deck-bits 18 : compiled-header-size ( -- n ) 4 bootstrap-cells ; inline : callstack-length-offset ( -- n ) 1 \ callstack type-number slot-offset ; inline : callstack-top-offset ( -- n ) 2 \ callstack type-number slot-offset ; inline +: vm-context-offset ( -- n ) 0 bootstrap-cells ; inline +: context-callstack-top-offset ( -- n ) 0 bootstrap-cells ; inline +: context-callstack-bottom-offset ( -- n ) 1 bootstrap-cells ; inline +: context-datastack-offset ( -- n ) 2 bootstrap-cells ; inline +: context-retainstack-offset ( -- n ) 3 bootstrap-cells ; inline ! Relocation classes CONSTANT: rc-absolute-cell 0 diff --git a/basis/cpu/x86/32/bootstrap.factor b/basis/cpu/x86/32/bootstrap.factor index 9c57804e3a..afcae6d4d9 100644 --- a/basis/cpu/x86/32/bootstrap.factor +++ b/basis/cpu/x86/32/bootstrap.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2007, 2009 Slava Pestov. +! Copyright (C) 2007, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: bootstrap.image.private kernel kernel.private namespaces system cpu.x86.assembler cpu.x86.assembler.operands layouts @@ -19,6 +19,8 @@ IN: bootstrap.x86 : safe-reg ( -- reg ) EAX ; : stack-reg ( -- reg ) ESP ; : frame-reg ( -- reg ) EBP ; +: vm-reg ( -- reg ) EBP ; +: ctx-reg ( -- reg ) ECX ; : nv-regs ( -- seq ) { ESI EDI EBX } ; : ds-reg ( -- reg ) ESI ; : rs-reg ( -- reg ) EDI ; @@ -35,50 +37,120 @@ IN: bootstrap.x86 ] jit-prolog jit-define : jit-load-vm ( -- ) - EBP 0 MOV 0 rc-absolute-cell jit-vm ; + vm-reg 0 MOV 0 rc-absolute-cell jit-vm ; + +: jit-load-context ( -- ) + ! VM pointer must be in vm-reg already + ctx-reg vm-reg vm-context-offset [+] MOV ; : jit-save-context ( -- ) - ! VM pointer must be in EBP already - ECX EBP [] MOV - ! save ctx->callstack_top - EAX ESP -4 [+] LEA - ECX [] EAX MOV - ! save ctx->datastack - ECX 8 [+] ds-reg MOV - ! save ctx->retainstack - ECX 12 [+] rs-reg MOV ; + jit-load-context + EDX RSP -4 [+] LEA + ctx-reg context-callstack-top-offset [+] EDX MOV + ctx-reg context-datastack-offset [+] ds-reg MOV + ctx-reg context-retainstack-offset [+] rs-reg MOV ; : jit-restore-context ( -- ) - ! VM pointer must be in EBP already - ECX EBP [] MOV - ! restore ctx->datastack - ds-reg ECX 8 [+] MOV - ! restore ctx->retainstack - rs-reg ECX 12 [+] MOV ; + jit-load-context + ds-reg ctx-reg context-datastack-offset [+] MOV + rs-reg ctx-reg context-retainstack-offset [+] MOV ; [ jit-load-vm - ! save ds, rs registers jit-save-context ! call the primitive - ESP [] EBP MOV + ESP [] vm-reg MOV 0 CALL rc-relative rt-primitive jit-rel ! restore ds, rs registers jit-restore-context ] jit-primitive jit-define [ - ! load from stack + ! Load quotation + EAX EBP 8 [+] MOV + ! save ctx->callstack_bottom, load ds, rs registers + jit-load-vm + jit-restore-context + EDX stack-reg stack-frame-size 4 - [+] LEA + ctx-reg context-callstack-bottom-offset [+] EDX MOV + ! call the quotation + EAX quot-xt-offset [+] CALL + ! save ds, rs registers + jit-save-context +] \ c-to-factor define-sub-primitive + +[ EAX ds-reg [] MOV - ! pop stack ds-reg bootstrap-cell SUB - ! load VM pointer - EDX 0 MOV 0 rc-absolute-cell jit-vm ] [ EAX quot-xt-offset [+] CALL ] [ EAX quot-xt-offset [+] JMP ] \ (call) define-combinator-primitive +[ + ! Clear x87 stack, but preserve rounding mode and exception flags + ESP 2 SUB + ESP [] FNSTCW + FNINIT + ESP [] FLDCW + ESP 2 ADD + + ! Load arguments + EAX ESP stack-frame-size [+] MOV + EDX ESP stack-frame-size 4 + [+] MOV + + ! Unwind stack frames + ESP EDX MOV + + ! Load ds and rs registers + jit-load-vm + jit-restore-context + + ! Call quotation + EAX quot-xt-offset [+] JMP +] \ unwind-native-frames define-sub-primitive + +[ + ! Load callstack object + EBX 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 + ! Get top of callstack object -- 'src' for memcpy + EBP EBX callstack-top-offset [+] LEA + ! Get callstack length, in bytes --- 'len' for memcpy + EDX EBX callstack-length-offset [+] MOV + EDX tag-bits get SHR + ! Compute new stack pointer -- 'dst' for memcpy + EAX EDX SUB + ! Install new stack pointer + RSP EAX MOV + ! Call memcpy + ESP 8 [+] EDX MOV + ESP 4 [+] EBP MOV + ESP [] EAX MOV + 0 CALL "memcpy" f rc-relative jit-dlsym + ! Return with new callstack + 0 RET +] \ set-callstack define-sub-primitive + +[ + jit-load-vm + jit-save-context + + ! Store arguments + ESP [] EAX MOV + ESP 4 [+] vm-reg MOV + + ! Call VM + 0 CALL "lazy_jit_compile" f rc-relative jit-dlsym +] +[ EAX quot-xt-offset [+] CALL ] +[ EAX quot-xt-offset [+] JMP ] +\ lazy-jit-compile define-combinator-primitive + ! Inline cache miss entry points : jit-load-return-address ( -- ) EBX ESP stack-frame-size bootstrap-cell - [+] MOV ; @@ -88,7 +160,7 @@ IN: bootstrap.x86 : jit-inline-cache-miss ( -- ) jit-load-vm jit-save-context - ESP 4 [+] EBP MOV + ESP 4 [+] vm-reg MOV ESP [] EBX MOV 0 CALL "inline_cache_miss" f rc-relative jit-dlsym jit-restore-context ; diff --git a/basis/cpu/x86/64/bootstrap.factor b/basis/cpu/x86/64/bootstrap.factor index 4c059141af..55dba215d7 100644 --- a/basis/cpu/x86/64/bootstrap.factor +++ b/basis/cpu/x86/64/bootstrap.factor @@ -4,7 +4,6 @@ USING: bootstrap.image.private kernel kernel.private namespaces system layouts vocabs parser compiler.constants math math.private cpu.x86.assembler cpu.x86.assembler.operands sequences generic.single.private ; -FROM: vm => context-field-offset vm-field-offset ; IN: bootstrap.x86 8 \ cell set @@ -43,19 +42,19 @@ IN: bootstrap.x86 : jit-load-context ( -- ) ! VM pointer must be in vm-reg already - ctx-reg vm-reg "ctx" vm-field-offset [+] MOV ; + ctx-reg vm-reg vm-context-offset [+] MOV ; : jit-save-context ( -- ) jit-load-context safe-reg RSP -8 [+] LEA - ctx-reg "callstack-top" context-field-offset [+] safe-reg MOV - ctx-reg "datastack" context-field-offset [+] ds-reg MOV - ctx-reg "retainstack" context-field-offset [+] rs-reg MOV ; + ctx-reg context-callstack-top-offset [+] safe-reg MOV + ctx-reg context-datastack-offset [+] ds-reg MOV + ctx-reg context-retainstack-offset [+] rs-reg MOV ; : jit-restore-context ( -- ) jit-load-context - ds-reg ctx-reg "datastack" context-field-offset [+] MOV - rs-reg ctx-reg "retainstack" context-field-offset [+] MOV ; + ds-reg ctx-reg context-datastack-offset [+] MOV + rs-reg ctx-reg context-retainstack-offset [+] MOV ; [ jit-load-vm @@ -71,8 +70,8 @@ IN: bootstrap.x86 jit-load-vm jit-restore-context ! save ctx->callstack_bottom - safe-reg stack-reg stack-frame-size bootstrap-cell - [+] LEA - ctx-reg "callstack-bottom" context-field-offset [+] safe-reg MOV + safe-reg stack-reg stack-frame-size 8 - [+] LEA + ctx-reg context-callstack-bottom-offset [+] safe-reg MOV ! call the quotation arg1 quot-xt-offset [+] CALL jit-save-context @@ -111,7 +110,7 @@ IN: bootstrap.x86 ! Get ctx->callstack_bottom jit-load-vm jit-load-context - arg1 ctx-reg "callstack-bottom" context-field-offset [+] MOV + arg1 ctx-reg context-callstack-bottom-offset [+] MOV ! Get top of callstack object -- 'src' for memcpy arg2 arg4 callstack-top-offset [+] LEA ! Get callstack length, in bytes --- 'len' for memcpy @@ -119,6 +118,7 @@ IN: bootstrap.x86 arg3 tag-bits get SHR ! Compute new stack pointer -- 'dst' for memcpy arg1 arg3 SUB + ! Install new stack pointer RSP arg1 MOV ! Call memcpy; arguments are now in the correct registers safe-reg 0 MOV "memcpy" f rc-absolute-cell jit-dlsym diff --git a/vm/cpu-x86.32.S b/vm/cpu-x86.32.S index ee3ec25aa3..2ebece637d 100644 --- a/vm/cpu-x86.32.S +++ b/vm/cpu-x86.32.S @@ -1,148 +1,7 @@ #include "asm.h" -#define DS_REG %esi -#define RS_REG %edi #define RETURN_REG %eax -#define QUOT_XT_OFFSET 12 - -DEF(void,c_to_factor,(cell quot, void *vm)): - /* Load parameters */ - mov 4(%esp),%eax - mov 8(%esp),%edx - - /* Save non-volatile registers */ - push %ebx - push %ebp - push %esi - push %edi - - /* Save old stack pointer and align */ - mov %esp,%ebx - and $-16,%esp - push %ebx - - /* Set up stack frame for the call to the boot quotation */ - sub $4,%esp - push %edx - push %eax - - /* Load context */ - mov (%edx),%ecx - - /* Load ctx->datastack */ - mov 8(%ecx),DS_REG - - /* Load ctx->retainstack */ - mov 12(%ecx),RS_REG - - /* Save ctx->callstack_bottom */ - lea -4(%esp),%ebx - mov %ebx,4(%ecx) - - /* Call quot-xt */ - call *QUOT_XT_OFFSET(%eax) - - /* Tear down stack frame for the call to the boot quotation */ - pop %eax - pop %edx - add $4,%esp - - /* Undo stack alignment */ - mov (%esp),%esp - - /* Load context */ - mov (%edx),%ecx - - /* Save ctx->datastack */ - mov DS_REG,8(%ecx) - - /* Save ctx->retainstack */ - mov RS_REG,12(%ecx) - - /* Restore non-volatile registers */ - pop %edi - pop %esi - pop %ebp - pop %ebx - - ret - -DEF(void,set_callstack,(void *vm, stack_frame *to, stack_frame *from, cell length, void *memcpy)): - /* load arguments */ - mov 4(%esp),%ebx /* vm - to non-volatile register */ - mov 8(%esp),%ebp /* to */ - mov 12(%esp),%edx /* from */ - mov 16(%esp),%ecx /* length */ - mov 20(%esp),%eax /* memcpy */ - - /* compute new stack pointer */ - sub %ecx,%ebp - mov %ebp,%esp - - /* call memcpy */ - push %ecx /* pass length */ - push %edx /* pass src */ - push %ebp /* pass dst */ - call *%eax - add $12,%esp - - /* load context */ - mov (%ebx),%ecx - /* load datastack */ - mov 8(%ecx),DS_REG - /* load retainstack */ - mov 12(%ecx),RS_REG - - /* return with new stack */ - ret - -DEF(void,throw_impl,(cell quot, void *new_stack, void *vm)): - /* clear x87 stack, but preserve rounding mode and exception flags */ - sub $2,%esp - fnstcw (%esp) - fninit - fldcw (%esp) - add $2,%esp - - /* load quotation and vm parameters */ - mov 4(%esp),%eax - mov 12(%esp),%edx - - /* load new stack pointer */ - mov 8(%esp),%esp - - /* load context */ - mov (%edx),%ecx - /* load datastack */ - mov 8(%ecx),DS_REG - /* load retainstack */ - mov 12(%ecx),RS_REG - - /* call the error handler */ - jmp *QUOT_XT_OFFSET(%eax) - -DEF(void,lazy_jit_compile_impl,(cell quot, void *vm)): - /* load context */ - mov (%edx),%ecx - /* save datastack */ - mov DS_REG,8(%ecx) - /* save retainstack */ - mov RS_REG,12(%ecx) - /* save callstack */ - lea -4(%esp),%ebp - mov %ebp,(%ecx) - - /* compile quotation */ - sub $4,%esp - push %edx - push %eax - call MANGLE(lazy_jit_compile) - add $12,%esp - - /* call quotation */ - jmp *QUOT_XT_OFFSET(%eax) - DEF(long long,read_timestamp_counter,(void)): rdtsc ret diff --git a/vm/entry_points.cpp b/vm/entry_points.cpp index 87a3c056e2..f5f37ce00e 100644 --- a/vm/entry_points.cpp +++ b/vm/entry_points.cpp @@ -19,4 +19,11 @@ void factor_vm::c_to_factor(cell quot) c_to_factor_func(quot); } +void factor_vm::unwind_native_frames(cell quot, stack_frame *to) +{ + tagged unwind_native_frames_word(special_objects[UNWIND_NATIVE_FRAMES_WORD]); + unwind_native_frames_func_type unwind_native_frames_func = (unwind_native_frames_func_type)unwind_native_frames_word->xt; + unwind_native_frames_func(quot,to); +} + } diff --git a/vm/entry_points.hpp b/vm/entry_points.hpp index 663eb7dbb4..873501f235 100644 --- a/vm/entry_points.hpp +++ b/vm/entry_points.hpp @@ -2,5 +2,6 @@ namespace factor { typedef void (* c_to_factor_func_type)(cell quot); +typedef void (* unwind_native_frames_func_type)(cell quot, stack_frame *to); } diff --git a/vm/factor.cpp b/vm/factor.cpp index 46eb2efdfd..453ec71682 100755 --- a/vm/factor.cpp +++ b/vm/factor.cpp @@ -79,8 +79,8 @@ void factor_vm::init_parameters_from_args(vm_parameters *p, int argc, vm_char ** } } -/* Do some initialization that we do once only */ -void factor_vm::do_stage1_init() +/* Compile code in boot image so that we can execute the startup quotation */ +void factor_vm::prepare_boot_image() { std::cout << "*** Stage 2 early init... "; fflush(stdout); @@ -146,7 +146,7 @@ void factor_vm::init_factor(vm_parameters *p) gc_off = false; if(!to_boolean(special_objects[OBJ_STAGE2])) - do_stage1_init(); + prepare_boot_image(); } /* May allocate memory */ diff --git a/vm/vm.hpp b/vm/vm.hpp index 3a87857488..5f0858dab3 100755 --- a/vm/vm.hpp +++ b/vm/vm.hpp @@ -645,7 +645,7 @@ struct factor_vm void default_parameters(vm_parameters *p); bool factor_arg(const vm_char *str, const vm_char *arg, cell *value); void init_parameters_from_args(vm_parameters *p, int argc, vm_char **argv); - void do_stage1_init(); + void prepare_boot_image(); void init_factor(vm_parameters *p); void pass_args_to_factor(int argc, vm_char **argv); void start_factor(vm_parameters *p); From 9508a5a0838c071a036b8bb19d9c72e18d125ded Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 6 Jan 2010 23:42:00 +1300 Subject: [PATCH 06/72] cpu.x86: don't have to pass VM pointer to quotations anymore --- basis/cpu/x86/32/32.factor | 1 - basis/cpu/x86/64/64.factor | 1 - 2 files changed, 2 deletions(-) diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index e741012bc4..f1cf0211d5 100644 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -237,7 +237,6 @@ M: x86.32 %alien-indirect ( -- ) M: x86.32 %alien-callback ( quot -- ) EAX EDX %restore-context EAX swap %load-reference - EDX %mov-vm-ptr EAX quot-xt-offset [+] CALL EAX EDX %save-context ; diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor index 071f45d127..2248567394 100644 --- a/basis/cpu/x86/64/64.factor +++ b/basis/cpu/x86/64/64.factor @@ -225,7 +225,6 @@ M: x86.64 %alien-indirect ( -- ) M: x86.64 %alien-callback ( quot -- ) param-reg-0 param-reg-1 %restore-context param-reg-0 swap %load-reference - param-reg-1 %mov-vm-ptr param-reg-0 quot-xt-offset [+] CALL param-reg-0 param-reg-1 %save-context ; From c04fef10c7be44a1ce53235a617a81850b5591e5 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 6 Jan 2010 23:49:14 +1300 Subject: [PATCH 07/72] vm: ensure that non-optimized calls to generic words which have not yet been compiled can still work --- core/compiler/units/units-tests.factor | 15 ++++++++++++++- vm/code_blocks.cpp | 2 +- vm/quotations.cpp | 10 +++++++--- vm/vm.hpp | 1 + 4 files changed, 23 insertions(+), 5 deletions(-) diff --git a/core/compiler/units/units-tests.factor b/core/compiler/units/units-tests.factor index eccc292f26..4d308ff545 100644 --- a/core/compiler/units/units-tests.factor +++ b/core/compiler/units/units-tests.factor @@ -1,5 +1,5 @@ USING: compiler definitions compiler.units tools.test arrays sequences words kernel -accessors namespaces fry eval ; +accessors namespaces fry eval quotations math ; IN: compiler.units.tests [ [ [ ] define-temp ] with-compilation-unit ] must-infer @@ -56,3 +56,16 @@ DEFER: nesting-test [ ] [ "IN: compiler.units.tests << : nesting-test ( -- ) ; >>" eval( -- ) ] unit-test observer remove-definition-observer + +! Make sure that non-optimized calls to a generic word which +! hasn't been compiled yet work properly +GENERIC: uncompiled-generic-test ( a -- b ) + +M: integer uncompiled-generic-test 1 + ; + +<< [ uncompiled-generic-test ] [ jit-compile ] [ suffix! ] bi >> +"q" set + +[ 4 ] [ 3 "q" get call ] unit-test + +FORGET: uncompiled-generic-test diff --git a/vm/code_blocks.cpp b/vm/code_blocks.cpp index ec7a0e8998..d72d30cc96 100755 --- a/vm/code_blocks.cpp +++ b/vm/code_blocks.cpp @@ -24,7 +24,7 @@ cell factor_vm::compute_xt_pic_address(word *w, cell tagged_quot) else { quotation *quot = untag(tagged_quot); - if(quot->code) + if(quot_compiled_p(quot)) return (cell)quot->xt; else return (cell)w->xt; diff --git a/vm/quotations.cpp b/vm/quotations.cpp index 73c28875fa..c33f9b5d6f 100755 --- a/vm/quotations.cpp +++ b/vm/quotations.cpp @@ -293,8 +293,7 @@ code_block *factor_vm::jit_compile_quot(cell owner_, cell quot_, bool relocating void factor_vm::jit_compile_quot(cell quot_, bool relocating) { data_root quot(quot_,this); - - if(quot->code == NULL || quot->code == lazy_jit_compile_block()) + if(!quot_compiled_p(quot.untagged())) { code_block *compiled = jit_compile_quot(quot.value(),quot.value(),relocating); set_quot_xt(quot.untagged(),compiled); @@ -356,11 +355,16 @@ VM_C_API cell lazy_jit_compile(cell quot, factor_vm *parent) return parent->lazy_jit_compile(quot); } +bool factor_vm::quot_compiled_p(quotation *quot) +{ + return quot->code != NULL && quot->code != lazy_jit_compile_block(); +} + void factor_vm::primitive_quot_compiled_p() { tagged quot(ctx->pop()); quot.untag_check(this); - ctx->push(tag_boolean(quot->code != lazy_jit_compile_block())); + ctx->push(tag_boolean(quot_compiled_p(quot.untagged()))); } cell factor_vm::find_all_quotations() diff --git a/vm/vm.hpp b/vm/vm.hpp index 5f0858dab3..92e921000b 100755 --- a/vm/vm.hpp +++ b/vm/vm.hpp @@ -606,6 +606,7 @@ struct factor_vm void jit_compile_quot(cell quot_, bool relocating); fixnum quot_code_offset_to_scan(cell quot_, cell offset); cell lazy_jit_compile(cell quot); + bool quot_compiled_p(quotation *quot); void primitive_quot_compiled_p(); cell find_all_quotations(); void initialize_all_quotations(); From 121904086566bab6a651c87074f4daba73b4b417 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 6 Jan 2010 23:52:14 +1300 Subject: [PATCH 08/72] compiler.units: fix faulty unit test --- core/compiler/units/units-tests.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/compiler/units/units-tests.factor b/core/compiler/units/units-tests.factor index 4d308ff545..48c3b6891c 100644 --- a/core/compiler/units/units-tests.factor +++ b/core/compiler/units/units-tests.factor @@ -68,4 +68,4 @@ M: integer uncompiled-generic-test 1 + ; [ 4 ] [ 3 "q" get call ] unit-test -FORGET: uncompiled-generic-test +[ ] [ [ \ uncompiled-generic-test forget ] with-compilation-unit ] unit-test From 587d074c0aa0ebb0b20e2477ed477845fa755524 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 7 Jan 2010 00:02:16 +1300 Subject: [PATCH 09/72] calendar: make code like '0.1 seconds sleep' work (bug discovered by Joe Groff) --- basis/calendar/calendar.factor | 3 ++- basis/threads/threads-tests.factor | 4 +++- 2 files changed, 5 insertions(+), 2 deletions(-) diff --git a/basis/calendar/calendar.factor b/basis/calendar/calendar.factor index 25cf35c062..3940af4856 100644 --- a/basis/calendar/calendar.factor +++ b/basis/calendar/calendar.factor @@ -554,7 +554,8 @@ M: integer end-of-year 12 31 ; : unix-time>timestamp ( seconds -- timestamp ) seconds unix-1970 time+ ; -M: duration sleep duration>nanoseconds nano-count + sleep-until ; +M: duration sleep + duration>nanoseconds >integer nano-count + sleep-until ; { { [ os unix? ] [ "calendar.unix" ] } diff --git a/basis/threads/threads-tests.factor b/basis/threads/threads-tests.factor index 79aad20b85..f9196e2951 100644 --- a/basis/threads/threads-tests.factor +++ b/basis/threads/threads-tests.factor @@ -1,6 +1,6 @@ USING: namespaces io tools.test threads kernel concurrency.combinators concurrency.promises locals math -words ; +words calendar ; IN: threads.tests 3 "x" set @@ -42,3 +42,5 @@ yield [ t ] [ spawn-namespace-test ] unit-test [ "a" [ 1 1 + ] spawn 100 sleep ] must-fail + +[ ] [ 0.1 seconds sleep ] unit-test From 6971df91fe4a7e7104b60988c1794610ed17069a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 7 Jan 2010 13:49:29 +1300 Subject: [PATCH 10/72] vm: remove unnecessary call to compile_all_words() from primitive_become() --- vm/objects.cpp | 7 ------- 1 file changed, 7 deletions(-) diff --git a/vm/objects.cpp b/vm/objects.cpp index 494aca3c5b..21948e5e7a 100644 --- a/vm/objects.cpp +++ b/vm/objects.cpp @@ -145,13 +145,6 @@ void factor_vm::primitive_become() all objects on a minor GC. */ data->mark_all_cards(); primitive_minor_gc(); - - /* If a word's definition quotation was in old_objects and the - quotation in new_objects is not compiled, we might leak memory - by referencing the old quotation unless we recompile all - unoptimized words. */ - compile_all_words(); - update_code_heap_words(); } } From 89e9f77b4426a46d86b98c7a8ca2d8d6d7316be9 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 7 Jan 2010 13:54:22 +1300 Subject: [PATCH 11/72] vm: Remove some dead code --- vm/Config.arm | 2 +- vm/cpu-arm.S | 127 ------------------------------------------------- vm/cpu-arm.hpp | 8 ---- 3 files changed, 1 insertion(+), 136 deletions(-) delete mode 100644 vm/cpu-arm.S diff --git a/vm/Config.arm b/vm/Config.arm index 1d7e6f9cc6..8b13789179 100644 --- a/vm/Config.arm +++ b/vm/Config.arm @@ -1 +1 @@ -PLAF_DLL_OBJS += vmpp/cpu-arm.o + diff --git a/vm/cpu-arm.S b/vm/cpu-arm.S deleted file mode 100644 index 09e3331b99..0000000000 --- a/vm/cpu-arm.S +++ /dev/null @@ -1,127 +0,0 @@ -#include "asm.h" - -/* Note that the XT is passed to the quotation in r12 */ -#define CALL_QUOT \ - ldr r12,[r0, #9] /* load quotation-xt slot */ ; \ - mov lr,pc ; \ - mov pc,r12 - -#define JUMP_QUOT \ - ldr r12,[r0, #9] /* load quotation-xt slot */ ; \ - mov pc,r12 - -#define SAVED_REGS_SIZE 32 - -#define FRAME (RESERVED_SIZE + SAVED_REGS_SIZE + 8) - -#define LR_SAVE [sp, #-4] -#define RESERVED_SIZE 8 - -#define SAVE_LR str lr,LR_SAVE - -#define LOAD_LR ldr lr,LR_SAVE - -#define SAVE_AT(offset) (RESERVED_SIZE + 4 * offset) - -#define SAVE(register,offset) str register,[sp, #SAVE_AT(offset)] - -#define RESTORE(register,offset) ldr register,[sp, #SAVE_AT(offset)] - -#define PROLOGUE \ - SAVE_LR ; \ - sub sp,sp,#FRAME - -#define EPILOGUE \ - add sp,sp,#FRAME ; \ - LOAD_LR - -DEF(void,c_to_factor,(CELL quot)): - PROLOGUE - - SAVE(r4,0) /* save GPRs */ - /* don't save ds pointer */ - /* don't save rs pointer */ - SAVE(r7,3) - SAVE(r8,4) - SAVE(r9,5) - SAVE(r10,6) - SAVE(r11,7) - SAVE(r0,8) /* save quotation since we're about to mangle it */ - - sub r0,sp,#4 /* pass call stack pointer as an argument */ - bl MANGLE(save_callstack_bottom) - - RESTORE(r0,8) /* restore quotation */ - CALL_QUOT - - RESTORE(r11,7) /* restore GPRs */ - RESTORE(r10,6) - RESTORE(r9,5) - RESTORE(r8,4) - RESTORE(r7,3) - /* don't restore rs pointer */ - /* don't restore ds pointer */ - RESTORE(r4,0) - - EPILOGUE - mov pc,lr - -/* The JIT compiles an 'mov r1',sp in front of every primitive call, since a -word which was defined as a primitive will not change its definition for the -lifetime of the image -- adding new primitives requires a bootstrap. However, -an undefined word can certainly become defined, - -DEFER: foo -... -: foo ... ; - -And calls to non-primitives do not have this one-instruction prologue, so we -set the XT of undefined words to this symbol. */ -DEF(void,undefined,(CELL word)): - sub r1,sp,#4 - b MANGLE(undefined_error) - -/* Here we have two entry points. The first one is taken when profiling is -enabled */ -DEF(void,docol_profiling,(CELL word)): - ldr r1,[r0, #25] /* load profile-count slot */ - add r1,r1,#8 /* increment count */ - str r1,[r0, #25] /* store profile-count slot */ -DEF(void,docol,(CELL word)): - ldr r0,[r0, #13] /* load word-def slot */ - JUMP_QUOT - -/* We must pass the XT to the quotation in r12. */ -DEF(void,primitive_call,(void)): - ldr r0,[r5], #-4 /* load quotation from data stack */ - JUMP_QUOT - -/* We must preserve r1 here in case we're calling a primitive */ -DEF(void,primitive_execute,(void)): - ldr r0,[r5], #-4 /* load word from data stack */ - ldr pc,[r0, #29] /* jump to word-xt */ - -DEF(void,set_callstack,(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length)): - sub sp,r0,r2 /* compute new stack pointer */ - mov r0,sp /* start of destination of memcpy() */ - sub sp,sp,#12 /* alignment */ - bl MANGLE(memcpy) /* go */ - add sp,sp,#16 /* point SP at innermost frame */ - ldr pc,LR_SAVE /* return */ - -DEF(void,throw_impl,(CELL quot, F_STACK_FRAME *rewind_to)): - add sp,r1,#4 /* compute new stack pointer */ - ldr lr,LR_SAVE /* we have rewound the stack; load return address */ - JUMP_QUOT /* call the quotation */ - -DEF(void,lazy_jit_compile,(CELL quot)): - mov r1,sp /* save stack pointer */ - PROLOGUE - bl MANGLE(lazy_jit_compile_impl) - EPILOGUE - JUMP_QUOT /* call the quotation */ - -#ifdef WINCE - .section .drectve - .ascii " -export:c_to_factor" -#endif diff --git a/vm/cpu-arm.hpp b/vm/cpu-arm.hpp index b08e76382c..e725c6d596 100644 --- a/vm/cpu-arm.hpp +++ b/vm/cpu-arm.hpp @@ -3,14 +3,6 @@ namespace factor #define FACTOR_CPU_STRING "arm" -register cell ds asm("r5"); -register cell rs asm("r6"); - #define FRAME_RETURN_ADDRESS(frame,vm) *(XT *)(vm->frame_successor(frame) + 1) -void c_to_factor(cell quot); -void set_callstack(stack_frame *to, stack_frame *from, cell length, void *memcpy); -void throw_impl(cell quot, stack_frame *rewind); -void lazy_jit_compile(cell quot); - } From 44a604fdbed3587edf776e55910af9a4de29e97f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 7 Jan 2010 16:06:07 +1300 Subject: [PATCH 12/72] compiler.tree: remove some code duplication concerning #alien nodes --- basis/compiler/tree/checker/checker.factor | 4 +--- basis/compiler/tree/dead-code/simple/simple.factor | 13 +++---------- .../tree/escape-analysis/simple/simple.factor | 7 +------ .../compiler/tree/propagation/simple/simple.factor | 4 +--- basis/compiler/tree/tree.factor | 2 +- .../tree/tuple-unboxing/tuple-unboxing.factor | 4 +--- 6 files changed, 8 insertions(+), 26 deletions(-) diff --git a/basis/compiler/tree/checker/checker.factor b/basis/compiler/tree/checker/checker.factor index 0b3b46fe33..b3f01c8c01 100644 --- a/basis/compiler/tree/checker/checker.factor +++ b/basis/compiler/tree/checker/checker.factor @@ -185,9 +185,7 @@ M: #recursive check-stack-flow* M: #copy check-stack-flow* [ check-in-d ] [ check-out-d ] bi ; -M: #alien-invoke check-stack-flow* [ check-in-d ] [ check-out-d ] bi ; - -M: #alien-indirect check-stack-flow* [ check-in-d ] [ check-out-d ] bi ; +M: #alien-node check-stack-flow* [ check-in-d ] [ check-out-d ] bi ; M: #alien-callback check-stack-flow* drop ; diff --git a/basis/compiler/tree/dead-code/simple/simple.factor b/basis/compiler/tree/dead-code/simple/simple.factor index 67c5cfdc78..bb0025caf4 100644 --- a/basis/compiler/tree/dead-code/simple/simple.factor +++ b/basis/compiler/tree/dead-code/simple/simple.factor @@ -28,9 +28,7 @@ M: method-body flushable? "method-generic" word-prop flushable? ; M: #call mark-live-values* dup flushable-call? [ drop ] [ look-at-inputs ] if ; -M: #alien-invoke mark-live-values* look-at-inputs ; - -M: #alien-indirect mark-live-values* look-at-inputs ; +M: #alien-node mark-live-values* look-at-inputs ; M: #return mark-live-values* look-at-inputs ; @@ -47,9 +45,7 @@ M: #call compute-live-values* nip look-at-inputs ; M: #shuffle compute-live-values* mapping>> at look-at-value ; -M: #alien-invoke compute-live-values* nip look-at-inputs ; - -M: #alien-indirect compute-live-values* nip look-at-inputs ; +M: #alien-node compute-live-values* nip look-at-inputs ; : filter-mapping ( assoc -- assoc' ) live-values get '[ drop _ key? ] assoc-filter ; @@ -127,8 +123,5 @@ M: #terminate remove-dead-code* [ filter-live ] change-in-d [ filter-live ] change-in-r ; -M: #alien-invoke remove-dead-code* - maybe-drop-dead-outputs ; - -M: #alien-indirect remove-dead-code* +M: #alien-node remove-dead-code* maybe-drop-dead-outputs ; diff --git a/basis/compiler/tree/escape-analysis/simple/simple.factor b/basis/compiler/tree/escape-analysis/simple/simple.factor index c053b15f29..50fa7ef0a8 100644 --- a/basis/compiler/tree/escape-analysis/simple/simple.factor +++ b/basis/compiler/tree/escape-analysis/simple/simple.factor @@ -86,12 +86,7 @@ M: #call escape-analysis* M: #return escape-analysis* in-d>> add-escaping-values ; -M: #alien-invoke escape-analysis* - [ in-d>> add-escaping-values ] - [ out-d>> unknown-allocations ] - bi ; - -M: #alien-indirect escape-analysis* +M: #alien-node escape-analysis* [ in-d>> add-escaping-values ] [ out-d>> unknown-allocations ] bi ; diff --git a/basis/compiler/tree/propagation/simple/simple.factor b/basis/compiler/tree/propagation/simple/simple.factor index b4d8b95247..9475b5df4a 100644 --- a/basis/compiler/tree/propagation/simple/simple.factor +++ b/basis/compiler/tree/propagation/simple/simple.factor @@ -153,8 +153,6 @@ M: #call propagate-after [ out-d>> ] [ params>> return>> ] bi [ drop ] [ c-type-class swap first set-value-info ] if-void ; -M: #alien-invoke propagate-before propagate-alien-invoke ; - -M: #alien-indirect propagate-before propagate-alien-invoke ; +M: #alien-node propagate-before propagate-alien-invoke ; M: #return annotate-node dup in-d>> (annotate-node) ; diff --git a/basis/compiler/tree/tree.factor b/basis/compiler/tree/tree.factor index 82b8fbb843..988c7293c3 100644 --- a/basis/compiler/tree/tree.factor +++ b/basis/compiler/tree/tree.factor @@ -149,7 +149,7 @@ TUPLE: #alien-indirect < #alien-node in-d out-d ; : #alien-indirect ( params -- node ) \ #alien-indirect new-alien-node ; -TUPLE: #alien-callback < #alien-node ; +TUPLE: #alien-callback < node params ; : #alien-callback ( params -- node ) \ #alien-callback new diff --git a/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor b/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor index de2848ea78..d4ca3010ce 100644 --- a/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor +++ b/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor @@ -164,9 +164,7 @@ M: #branch unbox-tuples* dup in-d>> assert-not-unboxed ; M: #return unbox-tuples* dup in-d>> assert-not-unboxed ; -M: #alien-invoke unbox-tuples* dup in-d>> assert-not-unboxed ; - -M: #alien-indirect unbox-tuples* dup in-d>> assert-not-unboxed ; +M: #alien-node unbox-tuples* dup in-d>> assert-not-unboxed ; M: #alien-callback unbox-tuples* ; From 235f3238f5f6e8f52ca0c036c65ac1143123bcb4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 7 Jan 2010 17:39:22 +1300 Subject: [PATCH 13/72] Add alien-assembly form for inline assembler, works like alien-invoke except calls a user-supplied quotation instead of generating a subroutine call. Replaces FPU status control, SSE detection and read timestamp routines in vm/cpu-x86.*S --- .../build-stack-frame.factor | 3 +- basis/compiler/cfg/builder/builder.factor | 3 + .../cfg/instructions/instructions.factor | 3 + .../cfg/save-contexts/save-contexts.factor | 3 +- basis/compiler/codegen/codegen.factor | 10 +++ basis/compiler/tests/alien.factor | 5 ++ basis/compiler/tree/debugger/debugger.factor | 4 +- basis/compiler/tree/tree.factor | 8 +- basis/cpu/x86/assembler/assembler.factor | 3 + basis/cpu/x86/features/features.factor | 88 ++++++++++++++++--- basis/math/floats/env/x86/x86.factor | 74 +++++++++++++--- basis/stack-checker/alien/alien.factor | 18 ++++ .../known-words/known-words.factor | 3 +- .../stack-checker/visitor/dummy/dummy.factor | 3 +- basis/stack-checker/visitor/visitor.factor | 3 +- core/alien/alien.factor | 9 +- vm/Config.x86.32 | 3 +- vm/Config.x86.64 | 1 - vm/cpu-x86.32.S | 40 --------- vm/cpu-x86.64.S | 30 ------- vm/cpu-x86.S | 41 --------- 21 files changed, 210 insertions(+), 145 deletions(-) delete mode 100644 vm/cpu-x86.32.S delete mode 100644 vm/cpu-x86.64.S delete mode 100644 vm/cpu-x86.S diff --git a/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor b/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor index 6f45a51f55..670e34e5f9 100644 --- a/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor +++ b/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008, 2009 Slava Pestov. +! Copyright (C) 2008, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: namespaces accessors math.order assocs kernel sequences combinators make classes words cpu.architecture layouts @@ -17,6 +17,7 @@ GENERIC: compute-stack-frame* ( insn -- ) UNION: stack-frame-insn ##alien-invoke ##alien-indirect + ##alien-assembly ##alien-callback ; M: stack-frame-insn compute-stack-frame* diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor index e67b8e3737..529c3b5ae6 100644 --- a/basis/compiler/cfg/builder/builder.factor +++ b/basis/compiler/cfg/builder/builder.factor @@ -236,6 +236,9 @@ M: #alien-invoke emit-node M: #alien-indirect emit-node [ ##alien-indirect ] emit-alien-node ; +M: #alien-assembly emit-node + [ ##alien-assembly ] emit-alien-node ; + M: #alien-callback emit-node dup params>> xt>> dup [ diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor index 20008ea85e..68a8b8ce59 100644 --- a/basis/compiler/cfg/instructions/instructions.factor +++ b/basis/compiler/cfg/instructions/instructions.factor @@ -671,6 +671,9 @@ literal: params stack-frame ; INSN: ##alien-indirect literal: params stack-frame ; +INSN: ##alien-assembly +literal: params stack-frame ; + INSN: ##alien-callback literal: params stack-frame ; diff --git a/basis/compiler/cfg/save-contexts/save-contexts.factor b/basis/compiler/cfg/save-contexts/save-contexts.factor index 4296fb54f9..c7b6db0671 100644 --- a/basis/compiler/cfg/save-contexts/save-contexts.factor +++ b/basis/compiler/cfg/save-contexts/save-contexts.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2009 Slava Pestov. +! Copyright (C) 2009, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors combinators.short-circuit compiler.cfg.instructions compiler.cfg.registers @@ -14,6 +14,7 @@ IN: compiler.cfg.save-contexts [ ##binary-float-function? ] [ ##alien-invoke? ] [ ##alien-indirect? ] + [ ##alien-assembly? ] } 1|| ] any? ; diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index c67048cf0d..cea6527259 100644 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -436,6 +436,16 @@ M: ##alien-invoke generate-insn dup %cleanup box-return* ; +M: ##alien-assembly generate-insn + params>> + ! Unbox parameters + dup objects>registers + %prepare-var-args + ! Generate assembly + dup quot>> call( -- ) + ! Box return value + box-return* ; + ! ##alien-indirect M: ##alien-indirect generate-insn params>> diff --git a/basis/compiler/tests/alien.factor b/basis/compiler/tests/alien.factor index e6abab1267..cb39c0dd16 100644 --- a/basis/compiler/tests/alien.factor +++ b/basis/compiler/tests/alien.factor @@ -591,3 +591,8 @@ FUNCTION: short ffi_test_48 ( bool-field-test x ) ; FUNCTION: void this_does_not_exist ( ) ; [ this_does_not_exist ] [ { "kernel-error" 9 f f } = ] must-fail-with + +! More alien-assembly tests are in cpu.* vocabs +: assembly-test-1 ( -- ) void { } "cdecl" [ ] alien-assembly ; + +[ ] [ assembly-test-1 ] unit-test diff --git a/basis/compiler/tree/debugger/debugger.factor b/basis/compiler/tree/debugger/debugger.factor index 63f145d752..62fc9cdb82 100644 --- a/basis/compiler/tree/debugger/debugger.factor +++ b/basis/compiler/tree/debugger/debugger.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2006, 2009 Slava Pestov. +! Copyright (C) 2006, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel assocs match fry accessors namespaces make effects sequences sequences.private quotations generic macros arrays @@ -126,6 +126,8 @@ M: #alien-invoke node>quot params>> , \ #alien-invoke , ; M: #alien-indirect node>quot params>> , \ #alien-indirect , ; +M: #alien-assembly node>quot params>> , \ #alien-assembly , ; + M: #alien-callback node>quot params>> , \ #alien-callback , ; M: node node>quot drop ; diff --git a/basis/compiler/tree/tree.factor b/basis/compiler/tree/tree.factor index 988c7293c3..a1d1b4db61 100644 --- a/basis/compiler/tree/tree.factor +++ b/basis/compiler/tree/tree.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2004, 2008 Slava Pestov. +! Copyright (C) 2004, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: fry arrays generic assocs kernel math namespaces parser sequences words vectors math.intervals classes @@ -149,6 +149,11 @@ TUPLE: #alien-indirect < #alien-node in-d out-d ; : #alien-indirect ( params -- node ) \ #alien-indirect new-alien-node ; +TUPLE: #alien-assembly < #alien-node in-d out-d ; + +: #alien-assembly ( params -- node ) + \ #alien-assembly new-alien-node ; + TUPLE: #alien-callback < node params ; : #alien-callback ( params -- node ) @@ -187,4 +192,5 @@ M: vector #recursive, #recursive node, ; M: vector #copy, #copy node, ; M: vector #alien-invoke, #alien-invoke node, ; M: vector #alien-indirect, #alien-indirect node, ; +M: vector #alien-assembly, #alien-assembly node, ; M: vector #alien-callback, #alien-callback node, ; diff --git a/basis/cpu/x86/assembler/assembler.factor b/basis/cpu/x86/assembler/assembler.factor index fc000ced23..b075b121a5 100644 --- a/basis/cpu/x86/assembler/assembler.factor +++ b/basis/cpu/x86/assembler/assembler.factor @@ -375,6 +375,7 @@ PRIVATE> : NOP ( -- ) HEX: 90 , ; : PAUSE ( -- ) HEX: f3 , HEX: 90 , ; +: RDTSC ( -- ) HEX: 0f , HEX: 31 , ; : RDPMC ( -- ) HEX: 0f , HEX: 33 , ; ! x87 Floating Point Unit @@ -386,8 +387,10 @@ PRIVATE> : FLDL ( operand -- ) { BIN: 000 f HEX: dd } 1-operand ; : FNSTCW ( operand -- ) { BIN: 111 f HEX: d9 } 1-operand ; +: FNSTSW ( operand -- ) { BIN: 111 f HEX: dd } 1-operand ; : FLDCW ( operand -- ) { BIN: 101 f HEX: d9 } 1-operand ; +: FNCLEX ( -- ) HEX: db , HEX: e2 , ; : FNINIT ( -- ) HEX: db , HEX: e3 , ; ! SSE multimedia instructions diff --git a/basis/cpu/x86/features/features.factor b/basis/cpu/x86/features/features.factor index 38364805eb..30b2ce3b57 100644 --- a/basis/cpu/x86/features/features.factor +++ b/basis/cpu/x86/features/features.factor @@ -1,21 +1,78 @@ -! Copyright (C) 2009 Slava Pestov. +! Copyright (C) 2009, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: system kernel memoize math math.order math.parser -namespaces alien.c-types alien.syntax combinators locals init io -compiler compiler.units accessors ; +USING: accessors alien alien.c-types combinators compiler +compiler.codegen.fixup compiler.units cpu.architecture +cpu.x86.assembler cpu.x86.assembler.operands init io kernel +locals math math.order math.parser memoize namespaces system ; IN: cpu.x86.features MEMO: sse-version ( -- n ) - sse_version - "sse-version" get string>number [ min ] when* ; + (sse-version) "sse-version" get string>number [ min ] when* ; [ \ sse-version reset-memoized ] "cpu.x86.features" add-startup-hook @@ -39,7 +96,18 @@ MEMO: sse-version ( -- n ) HOOK: instruction-count cpu ( -- n ) -M: x86 instruction-count read_timestamp_counter ; +M: x86.32 instruction-count + longlong { } "cdecl" [ + RDTSC + ] alien-assembly ; + +M: x86.64 instruction-count + longlong { } "cdecl" [ + RAX 0 MOV + RDTSC + RDX 32 SHL + RAX RDX OR + ] alien-assembly ; : count-instructions ( quot -- n ) - instruction-count [ call ] dip instruction-count swap - ; inline + instruction-count [ call instruction-count ] dip - ; inline diff --git a/basis/math/floats/env/x86/x86.factor b/basis/math/floats/env/x86/x86.factor index 2b73628b4c..ed8e9b7795 100644 --- a/basis/math/floats/env/x86/x86.factor +++ b/basis/math/floats/env/x86/x86.factor @@ -1,6 +1,7 @@ -USING: accessors alien.c-types alien.syntax arrays assocs -biassocs classes.struct combinators cpu.x86.features kernel -literals math math.bitwise math.floats.env +USING: accessors alien alien.c-types alien.syntax arrays assocs +biassocs classes.struct combinators cpu.x86.64 +cpu.x86.assembler cpu.x86.assembler.operands cpu.x86.features +kernel literals math math.bitwise math.floats.env math.floats.env.private system ; IN: math.floats.env.x86 @@ -11,24 +12,73 @@ STRUCT: x87-env { status ushort } { control ushort } ; -! defined in the vm, cpu-x86*.S -FUNCTION: void get_sse_env ( sse-env* env ) ; -FUNCTION: void set_sse_env ( sse-env* env ) ; +HOOK: get-sse-env cpu ( sse-env -- ) +HOOK: set-sse-env cpu ( sse-env -- ) -FUNCTION: void get_x87_env ( x87-env* env ) ; -FUNCTION: void set_x87_env ( x87-env* env ) ; +HOOK: get-x87-env cpu ( x87-env -- ) +HOOK: set-x87-env cpu ( x87-env -- ) + +! 32-bit +M: x86.32 get-sse-env + void { void* } "cdecl" [ + EAX ESP [] MOV + EAX [] STMXCSR + ] alien-assembly ; + +M: x86.32 set-sse-env + void { void* } "cdecl" [ + EAX ESP [] MOV + EAX [] LDMXCSR + ] alien-assembly ; + +M: x86.32 get-x87-env + void { void* } "cdecl" [ + EAX ESP [] MOV + EAX [] FNSTSW + EAX 2 [+] FNSTCW + ] alien-assembly ; + +M: x86.32 set-x87-env + void { void* } "cdecl" [ + EAX ESP [] MOV + FNCLEX + EAX 2 [+] FLDCW + ] alien-assembly ; + +! 64-bit +M: x86.64 get-sse-env + void { void* } "cdecl" [ + param-reg-0 [] STMXCSR + ] alien-assembly ; + +M: x86.64 set-sse-env + void { void* } "cdecl" [ + param-reg-0 [] LDMXCSR + ] alien-assembly ; + +M: x86.64 get-x87-env + void { void* } "cdecl" [ + param-reg-0 [] FNSTSW + param-reg-0 2 [+] FNSTCW + ] alien-assembly ; + +M: x86.64 set-x87-env + void { void* } "cdecl" [ + FNCLEX + param-reg-0 2 [+] FLDCW + ] alien-assembly ; : ( -- sse-env ) - sse-env (struct) [ get_sse_env ] keep ; + sse-env (struct) [ get-sse-env ] keep ; M: sse-env (set-fp-env-register) - set_sse_env ; + set-sse-env ; : ( -- x87-env ) - x87-env (struct) [ get_x87_env ] keep ; + x87-env (struct) [ get-x87-env ] keep ; M: x87-env (set-fp-env-register) - set_x87_env ; + set-x87-env ; M: x86 (fp-env-registers) sse2? [ 2array ] [ 1array ] if ; diff --git a/basis/stack-checker/alien/alien.factor b/basis/stack-checker/alien/alien.factor index deeada3735..fdfda6dd9e 100644 --- a/basis/stack-checker/alien/alien.factor +++ b/basis/stack-checker/alien/alien.factor @@ -12,6 +12,8 @@ TUPLE: alien-invoke-params < alien-node-params library function ; TUPLE: alien-indirect-params < alien-node-params ; +TUPLE: alien-assembly-params < alien-node-params quot ; + TUPLE: alien-callback-params < alien-node-params quot xt ; : param-prep-quot ( node -- quot ) @@ -58,6 +60,22 @@ TUPLE: alien-callback-params < alien-node-params quot xt ; ! Quotation which coerces return value to required type return-prep-quot infer-quot-here ; +: infer-alien-assembly ( -- ) + alien-assembly-params new + ! Compile-time parameters + pop-literal nip >>quot + pop-literal nip >>abi + pop-literal nip >>parameters + pop-literal nip >>return + ! Quotation which coerces parameters to required types + dup param-prep-quot infer-quot-here + ! Magic #: consume exactly the number of inputs + dup 0 alien-stack + ! Add node to IR + dup #alien-assembly, + ! Quotation which coerces return value to required type + return-prep-quot infer-quot-here ; + : callback-xt ( word return-rewind -- alien ) [ callbacks get ] dip '[ _ ] cache ; diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index 316ae6ca2f..a95d110622 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2004, 2009 Slava Pestov, Daniel Ehrenberg. +! Copyright (C) 2004, 2010 Slava Pestov, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: fry accessors alien alien.accessors arrays byte-arrays classes continuations.private effects generic hashtables @@ -228,6 +228,7 @@ M: bad-executable summary \ alien-invoke [ infer-alien-invoke ] "special" set-word-prop \ alien-indirect [ infer-alien-indirect ] "special" set-word-prop +\ alien-assembly [ infer-alien-assembly ] "special" set-word-prop \ alien-callback [ infer-alien-callback ] "special" set-word-prop : infer-special ( word -- ) diff --git a/basis/stack-checker/visitor/dummy/dummy.factor b/basis/stack-checker/visitor/dummy/dummy.factor index 5f05d97d1a..871f79d320 100644 --- a/basis/stack-checker/visitor/dummy/dummy.factor +++ b/basis/stack-checker/visitor/dummy/dummy.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: stack-checker.visitor kernel ; IN: stack-checker.visitor.dummy @@ -24,4 +24,5 @@ M: f #copy, 2drop ; M: f #drop, drop ; M: f #alien-invoke, drop ; M: f #alien-indirect, drop ; +M: f #alien-assembly, drop ; M: f #alien-callback, drop ; diff --git a/basis/stack-checker/visitor/visitor.factor b/basis/stack-checker/visitor/visitor.factor index 6093cd008a..d4207caf5b 100644 --- a/basis/stack-checker/visitor/visitor.factor +++ b/basis/stack-checker/visitor/visitor.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel arrays namespaces ; IN: stack-checker.visitor @@ -29,4 +29,5 @@ HOOK: #recursive, stack-visitor ( label inputs visitor -- ) HOOK: #copy, stack-visitor ( inputs outputs -- ) HOOK: #alien-invoke, stack-visitor ( params -- ) HOOK: #alien-indirect, stack-visitor ( params -- ) +HOOK: #alien-assembly, stack-visitor ( params -- ) HOOK: #alien-callback, stack-visitor ( params -- ) diff --git a/core/alien/alien.factor b/core/alien/alien.factor index 91dd150e8f..10012ea3d0 100644 --- a/core/alien/alien.factor +++ b/core/alien/alien.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2004, 2009 Slava Pestov. +! Copyright (C) 2004, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs kernel math namespaces sequences system kernel.private byte-arrays arrays init ; @@ -49,7 +49,7 @@ ERROR: alien-callback-error ; ERROR: alien-indirect-error ; -: alien-indirect ( ... funcptr return parameters abi -- ) +: alien-indirect ( ... funcptr return parameters abi -- ... ) alien-indirect-error ; ERROR: alien-invoke-error library symbol ; @@ -57,6 +57,11 @@ ERROR: alien-invoke-error library symbol ; : alien-invoke ( ... return library function parameters -- ... ) 2over alien-invoke-error ; +ERROR: alien-assembly-error code ; + +: alien-assembly ( ... return library parameters abi quot -- ... ) + dup alien-assembly-error ; + ! Callbacks are registered in a global hashtable. Note that they ! are also pinned in a special callback area, so clearing this ! hashtable will not reclaim callbacks. It should only be diff --git a/vm/Config.x86.32 b/vm/Config.x86.32 index b7f8bc65f0..8b13789179 100644 --- a/vm/Config.x86.32 +++ b/vm/Config.x86.32 @@ -1,2 +1 @@ -BOOT_ARCH = x86 -PLAF_DLL_OBJS += vm/cpu-x86.32.o + diff --git a/vm/Config.x86.64 b/vm/Config.x86.64 index 63f06d5a78..314c14fe05 100644 --- a/vm/Config.x86.64 +++ b/vm/Config.x86.64 @@ -1,2 +1 @@ -PLAF_DLL_OBJS += vm/cpu-x86.64.o CFLAGS += -DFACTOR_64 diff --git a/vm/cpu-x86.32.S b/vm/cpu-x86.32.S deleted file mode 100644 index 2ebece637d..0000000000 --- a/vm/cpu-x86.32.S +++ /dev/null @@ -1,40 +0,0 @@ -#include "asm.h" - -#define RETURN_REG %eax - -DEF(long long,read_timestamp_counter,(void)): - rdtsc - ret - -DEF(void,get_sse_env,(void*)): - movl 4(%esp), %eax - stmxcsr (%eax) - ret - -DEF(void,set_sse_env,(const void*)): - movl 4(%esp), %eax - ldmxcsr (%eax) - ret - -DEF(void,get_x87_env,(void*)): - movl 4(%esp), %eax - fnstsw (%eax) - fnstcw 2(%eax) - ret - -DEF(void,set_x87_env,(const void*)): - movl 4(%esp), %eax - fnclex - fldcw 2(%eax) - ret - -#include "cpu-x86.S" - -#ifdef WINDOWS - .section .drectve - .ascii " -export:read_timestamp_counter" - .ascii " -export:get_sse_env" - .ascii " -export:set_sse_env" - .ascii " -export:get_x87_env" - .ascii " -export:set_x87_env" -#endif diff --git a/vm/cpu-x86.64.S b/vm/cpu-x86.64.S deleted file mode 100644 index a65b0d67e7..0000000000 --- a/vm/cpu-x86.64.S +++ /dev/null @@ -1,30 +0,0 @@ -#include "asm.h" - -DEF(long long,read_timestamp_counter,(void)): - mov $0,%rax - rdtsc - shl $32,%rdx - or %rdx,%rax - ret - -DEF(void,get_sse_env,(void*)): - stmxcsr (%rdi) - ret - -DEF(void,set_sse_env,(const void*)): - ldmxcsr (%rdi) - ret - -DEF(void,get_x87_env,(void*)): - fnstsw (%rdi) - fnstcw 2(%rdi) - ret - -DEF(void,set_x87_env,(const void*)): - fnclex - fldcw 2(%rdi) - ret - -#define RETURN_REG %rax - -#include "cpu-x86.S" diff --git a/vm/cpu-x86.S b/vm/cpu-x86.S deleted file mode 100644 index dae775ae3d..0000000000 --- a/vm/cpu-x86.S +++ /dev/null @@ -1,41 +0,0 @@ -/* cpu.x86.features calls this */ -DEF(bool,sse_version,(void)): - mov $0x1,RETURN_REG - cpuid - test $0x100000,%ecx - jnz sse_42 - test $0x80000,%ecx - jnz sse_41 - test $0x200,%ecx - jnz ssse_3 - test $0x1,%ecx - jnz sse_3 - test $0x4000000,%edx - jnz sse_2 - test $0x2000000,%edx - jnz sse_1 - mov $0,%eax - ret -sse_42: - mov $42,RETURN_REG - ret -sse_41: - mov $41,RETURN_REG - ret -ssse_3: - mov $33,RETURN_REG - ret -sse_3: - mov $30,RETURN_REG - ret -sse_2: - mov $20,RETURN_REG - ret -sse_1: - mov $10,RETURN_REG - ret - -#ifdef WINDOWS - .section .drectve - .ascii " -export:sse_version" -#endif From e8892d9cde55c849452ca73d7951ff8ab89c4a33 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 7 Jan 2010 17:40:23 +1300 Subject: [PATCH 14/72] stack-checker: fix unit test --- basis/stack-checker/stack-checker-tests.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/stack-checker/stack-checker-tests.factor b/basis/stack-checker/stack-checker-tests.factor index 6af0ec64e5..6718d31d7a 100644 --- a/basis/stack-checker/stack-checker-tests.factor +++ b/basis/stack-checker/stack-checker-tests.factor @@ -392,5 +392,5 @@ DEFER: eee' [ [ call-effect ] infer ] [ T{ unknown-macro-input f call-effect } = ] must-fail-with [ [ execute-effect ] infer ] [ T{ unknown-macro-input f execute-effect } = ] must-fail-with -[ \ set-callstack def>> infer ] [ T{ unknown-primitive-error } = ] must-fail-with -[ ] [ [ \ set-callstack def>> infer ] try ] unit-test +[ \ set-datastack def>> infer ] [ T{ unknown-primitive-error } = ] must-fail-with +[ ] [ [ \ set-datastack def>> infer ] try ] unit-test From 46a1b1cc46b46e4315612925ddfa0caea85a5db7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 7 Jan 2010 17:57:48 +1300 Subject: [PATCH 15/72] alien: document alien-assembly --- core/alien/alien-docs.factor | 65 +++++++++++++++++++++++++----------- 1 file changed, 46 insertions(+), 19 deletions(-) diff --git a/core/alien/alien-docs.factor b/core/alien/alien-docs.factor index 6787d3714b..98292b8728 100644 --- a/core/alien/alien-docs.factor +++ b/core/alien/alien-docs.factor @@ -1,7 +1,7 @@ USING: byte-arrays arrays help.syntax help.markup alien.syntax compiler definitions math libc eval debugger parser io io.backend system alien.accessors -alien.libraries ; +alien.libraries alien.c-types quotations ; IN: alien HELP: alien @@ -44,17 +44,26 @@ HELP: HELP: c-ptr { $class-description "Class of objects consisting of aliens, byte arrays and " { $link f } ". These objects can convert to pointer C types, which are all aliases of " { $snippet "void*" } "." } ; +HELP: alien-invoke-error +{ $error-description "Thrown if the word calling " { $link alien-invoke } " was not compiled with the optimizing compiler. This may be a result of one of several failure conditions:" + { $list + { "This can happen when experimenting with " { $link alien-invoke } " in this listener. To fix the problem, place the " { $link alien-invoke } " call in a word; word definitions are automatically compiled with the optimizing compiler." } + { "The return type or parameter list references an unknown C type." } + { "The symbol or library could not be found." } + { "One of the four inputs to " { $link alien-invoke } " is not a literal value. To call functions which are not known at compile-time, use " { $link alien-indirect } "." } + } +} ; + HELP: alien-invoke { $values { "..." "zero or more objects passed to the C function" } { "return" "a C return type" } { "library" "a logical library name" } { "function" "a C function name" } { "parameters" "a sequence of C parameter types" } } -{ $description "Calls a C library function with the given name. Input parameters are taken from the data stack, and the return value is pushed on the data stack after the function returns. A return type of " { $snippet "\"void\"" } " indicates that no value is to be expected." } +{ $description "Calls a C library function with the given name. Input parameters are taken from the data stack, and the return value is pushed on the data stack after the function returns. A return type of " { $link void } " indicates that no value is to be expected." } { $notes "C type names are documented in " { $link "c-types-specs" } "." } { $errors "Throws an " { $link alien-invoke-error } " if the word calling " { $link alien-invoke } " was not compiled with the optimizing compiler." } ; HELP: alien-indirect-error -{ $error-description "Thrown if the word calling " { $link alien-indirect } " was not compiled with the optimizing compiler. This may be a result of one of several failure conditions:" +{ $error-description "Thrown if the word calling " { $link alien-indirect } " was not compiled with the optimizing compiler. This may be a result of one of two failure conditions:" { $list { "This can happen when experimenting with " { $link alien-indirect } " in this listener. To fix the problem, place the " { $link alien-indirect } " call in a word; word definitions are automatically compiled with the optimizing compiler." } - { "The return type or parameter list references an unknown C type." } { "One of the three inputs to " { $link alien-indirect } " is not a literal value." } } } ; @@ -62,22 +71,21 @@ HELP: alien-indirect-error HELP: alien-indirect { $values { "..." "zero or more objects passed to the C function" } { "funcptr" "a C function pointer" } { "return" "a C return type" } { "parameters" "a sequence of C parameter types" } { "abi" "one of " { $snippet "\"cdecl\"" } " or " { $snippet "\"stdcall\"" } } } { $description - "Invokes a C function pointer passed on the data stack. Input parameters are taken from the data stack following the function pointer, and the return value is pushed on the data stack after the function returns. A return type of " { $snippet "\"void\"" } " indicates that no value is to be expected." + "Invokes a C function pointer passed on the data stack. Input parameters are taken from the data stack following the function pointer, and the return value is pushed on the data stack after the function returns. A return type of " { $link void } " indicates that no value is to be expected." } { $notes "C type names are documented in " { $link "c-types-specs" } "." } { $errors "Throws an " { $link alien-indirect-error } " if the word calling " { $link alien-indirect } " is not compiled." } ; HELP: alien-callback-error -{ $error-description "Thrown if the word calling " { $link alien-callback } " was not compiled with the optimizing compiler. This may be a result of one of several failure conditions:" +{ $error-description "Thrown if the word calling " { $link alien-callback } " was not compiled with the optimizing compiler. This may be a result of one of two failure conditions:" { $list { "This can happen when experimenting with " { $link alien-callback } " in this listener. To fix the problem, place the " { $link alien-callback } " call in a word; word definitions are automatically compiled with the optimizing compiler." } - { "The return type or parameter list references an unknown C type." } { "One of the four inputs to " { $link alien-callback } " is not a literal value." } } } ; HELP: alien-callback -{ $values { "return" "a C return type" } { "parameters" "a sequence of C parameter types" } { "abi" "one of " { $snippet "\"cdecl\"" } " or " { $snippet "\"stdcall\"" } } { "quot" "a quotation" } { "alien" alien } } +{ $values { "return" "a C return type" } { "parameters" "a sequence of C parameter types" } { "abi" "one of " { $snippet "\"cdecl\"" } " or " { $snippet "\"stdcall\"" } } { "quot" quotation } { "alien" alien } } { $description "Defines a callback from C to Factor which accepts the given set of parameters from the C caller, pushes them on the data stack, calls the quotation, and passes a return value back to the C caller. A return type of " { $snippet "void" } " indicates that no value is to be returned." $nl @@ -95,7 +103,23 @@ HELP: alien-callback } { $errors "Throws an " { $link alien-callback-error } " if the word calling " { $link alien-callback } " is not compiled." } ; -{ alien-invoke alien-indirect alien-callback } related-words +HELP: alien-assembly-error +{ $error-description "Thrown if the word calling " { $link alien-assembly } " was not compiled with the optimizing compiler. This may be a result of one of two failure conditions:" + { $list + { "This can happen when experimenting with " { $link alien-assembly } " in this listener. To fix the problem, place the " { $link alien-assembly } " call in a word; word definitions are automatically compiled with the optimizing compiler." } + { "One of the four inputs to " { $link alien-assembly } " is not a literal value." } + } +} ; + +HELP: alien-assembly +{ $values { "..." "zero or more objects passed to the C function" } { "return" "a C return type" } { "parameters" "a sequence of C parameter types" } { "abi" "one of " { $snippet "\"cdecl\"" } " or " { $snippet "\"stdcall\"" } } { "quot" quotation } } +{ $description + "Invokes arbitrary machine code, generated at compile-time by the quotation. Input parameters are taken from the data stack, and the return value is pushed on the data stack after the function returns. A return type of " { $link void } " indicates that no value is to be expected." +} +{ $notes "C type names are documented in " { $link "c-types-specs" } "." } +{ $errors "Throws an " { $link alien-assembly-error } " if the word calling " { $link alien-assembly } " is not compiled." } ; + +{ alien-invoke alien-indirect alien-assembly alien-callback } related-words ARTICLE: "alien-expiry" "Alien expiry" "When an image is loaded, any alien objects which persisted from the previous session are marked as having expired. This is because the C pointers they contain are almost certainly no longer valid." @@ -165,16 +189,6 @@ ARTICLE: "alien-invoke" "Calling C from Factor" { $subsections alien-indirect } "There are some details concerning the conversion of Factor objects to C values, and vice versa. See " { $link "c-data" } "." ; -HELP: alien-invoke-error -{ $error-description "Thrown if the word calling " { $link alien-invoke } " was not compiled with the optimizing compiler. This may be a result of one of several failure conditions:" - { $list - { "This can happen when experimenting with " { $link alien-invoke } " in this listener. To fix the problem, place the " { $link alien-invoke } " call in a word; word definitions are automatically compiled with the optimizing compiler." } - { "The return type or parameter list references an unknown C type." } - { "The symbol or library could not be found." } - { "One of the four inputs to " { $link alien-invoke } " is not a literal value. To call functions which are not known at compile-time, use " { $link alien-indirect } "." } - } -} ; - ARTICLE: "alien-callback" "Calling Factor from C" "Callbacks can be defined and passed to C code as function pointers; the C code can then invoke the callback and run Factor code:" { $subsections @@ -191,6 +205,18 @@ ARTICLE: "alien-globals" "Accessing C global variables" POSTPONE: &: } ; +ARTICLE: "alien-assembly" "Calling arbitrary assembly code" +"It is possible to write a word whose body consists of arbitrary assembly code. The assembly receives parameters and returns values as per the platform's ABI; marshalling and unmarshalling Factor values is taken care of by the C library interface, as with " { $link alien-invoke } "." +$nl +"Assembler opcodes are defined in CPU-specific vocabularies:" +{ $list + { $vocab-link "cpu.arm.assembler" } + { $vocab-link "cpu.ppc.assembler" } + { $vocab-link "cpu.x86.assembler" } +} +"The combinator for generating arbitrary assembly by calling a quotation at compile time:" +{ $subsection alien-assembly } ; + ARTICLE: "dll.private" "DLL handles" "DLL handles are a built-in class of objects which represent loaded native libraries. DLL handles are instances of the " { $link dll } " class, and have a literal syntax used for debugging prinouts; see " { $link "syntax-aliens" } "." $nl @@ -281,6 +307,7 @@ $nl "c-data" "classes.struct" "alien-globals" + "alien-assembly" "dll.private" "embedding" } ; From 0f29fed1f1f68894b756e13ea49eb2c46a426cbc Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 7 Jan 2010 17:59:17 +1300 Subject: [PATCH 16/72] cpu.x86: add some alien-assembly unit tests --- basis/cpu/x86/32/32-tests.factor | 7 +++++++ basis/cpu/x86/64/64-tests.factor | 15 +++++++++++++++ 2 files changed, 22 insertions(+) create mode 100644 basis/cpu/x86/32/32-tests.factor create mode 100644 basis/cpu/x86/64/64-tests.factor diff --git a/basis/cpu/x86/32/32-tests.factor b/basis/cpu/x86/32/32-tests.factor new file mode 100644 index 0000000000..bc07e3a25b --- /dev/null +++ b/basis/cpu/x86/32/32-tests.factor @@ -0,0 +1,7 @@ +IN: cpu.x86.32.tests +USING: alien alien.c-types tools.test cpu.x86.assembler +cpu.x86.assembler.operands ; + +: assembly-test-1 ( -- x ) int { } "cdecl" [ EAX 3 MOV ] alien-assembly ; + +[ 3 ] [ assembly-test-1 ] unit-test diff --git a/basis/cpu/x86/64/64-tests.factor b/basis/cpu/x86/64/64-tests.factor new file mode 100644 index 0000000000..6d171af7ea --- /dev/null +++ b/basis/cpu/x86/64/64-tests.factor @@ -0,0 +1,15 @@ +USING: alien alien.c-types cpu.architecture cpu.x86.64 +cpu.x86.assembler cpu.x86.assembler.operands tools.test ; +IN: cpu.x86.64.tests + +: assembly-test-1 ( -- x ) int { } "cdecl" [ RAX 3 MOV ] alien-assembly ; + +[ 3 ] [ assembly-test-1 ] unit-test + +: assembly-test-2 ( a b -- x ) + int { int int } "cdecl" [ + param-reg-0 param-reg-1 ADD + int-regs return-reg param-reg-0 MOV + ] alien-assembly ; + +[ 23 ] [ 17 6 assembly-test-2 ] unit-test From 0ad8ba204bedab012bfca219a79ed7f7708c136b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 7 Jan 2010 18:05:31 +1300 Subject: [PATCH 17/72] vm: remove asm.h --- vm/asm.h | 16 ---------------- vm/cpu-ppc.S | 17 ++++++++++++++++- 2 files changed, 16 insertions(+), 17 deletions(-) delete mode 100644 vm/asm.h diff --git a/vm/asm.h b/vm/asm.h deleted file mode 100644 index 9719ae8af0..0000000000 --- a/vm/asm.h +++ /dev/null @@ -1,16 +0,0 @@ -#if defined(__APPLE__) || (defined(WINDOWS) && !defined(__arm__)) - #define MANGLE(sym) _##sym -#else - #define MANGLE(sym) sym -#endif - -/* Apple's PPC assembler is out of date? */ -#if defined(__APPLE__) && defined(__ppc__) - #define XX @ -#else - #define XX ; -#endif - -/* The returns and args are just for documentation */ -#define DEF(returns,symbol,args) .globl MANGLE(symbol) XX \ -MANGLE(symbol) diff --git a/vm/cpu-ppc.S b/vm/cpu-ppc.S index 772f4a24fc..b387bafbbf 100644 --- a/vm/cpu-ppc.S +++ b/vm/cpu-ppc.S @@ -1,6 +1,21 @@ /* Parts of this file were snarfed from SBCL src/runtime/ppc-assem.S, which is in the public domain. */ -#include "asm.h" +#if defined(__APPLE__) || (defined(WINDOWS) && !defined(__arm__)) + #define MANGLE(sym) _##sym +#else + #define MANGLE(sym) sym +#endif + +/* Apple's PPC assembler is out of date? */ +#if defined(__APPLE__) && defined(__ppc__) + #define XX @ +#else + #define XX ; +#endif + +/* The returns and args are just for documentation */ +#define DEF(returns,symbol,args) .globl MANGLE(symbol) XX \ +MANGLE(symbol) #define DS_REG r13 #define RS_REG r14 From ea2bd732142a3feeefb96821e898f1fb837d8489 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 7 Jan 2010 18:12:33 +1300 Subject: [PATCH 18/72] Remove .S support from Makefile --- Makefile | 3 --- vm/Config.ppc | 2 +- 2 files changed, 1 insertion(+), 4 deletions(-) diff --git a/Makefile b/Makefile index 772f3f9875..57b7ef0848 100755 --- a/Makefile +++ b/Makefile @@ -212,9 +212,6 @@ vm/ffi_test.o: vm/ffi_test.c .cpp.o: $(TOOLCHAIN_PREFIX)$(CPP) -c $(CFLAGS) -o $@ $< -.S.o: - $(TOOLCHAIN_PREFIX)$(CC) -x assembler-with-cpp -c $(CFLAGS) -o $@ $< - .mm.o: $(TOOLCHAIN_PREFIX)$(CPP) -c $(CFLAGS) -o $@ $< diff --git a/vm/Config.ppc b/vm/Config.ppc index 1ded04dda1..8b13789179 100644 --- a/vm/Config.ppc +++ b/vm/Config.ppc @@ -1 +1 @@ -PLAF_DLL_OBJS += vm/cpu-ppc.o + From a04b85a45ebb13ffca696e9a6ea8de5fd9e2de3a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 7 Jan 2010 18:30:01 +1300 Subject: [PATCH 19/72] cpu.x86: sse_version was renamed to (sse-version) --- basis/cpu/x86/x86.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index a14e2468ad..46123c9e23 100644 --- a/basis/cpu/x86/x86.factor +++ b/basis/cpu/x86/x86.factor @@ -1469,6 +1469,6 @@ enable-fixnum-log2 ] when ; : check-sse ( -- ) - [ { sse_version } compile ] with-optimizer + [ { (sse-version) } compile ] with-optimizer "Checking for multimedia extensions: " write sse-version [ sse-string write " detected" print ] [ enable-sse2 ] bi ; From 1f88a925b457e6bbb59854823ed89cc71085112e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 7 Jan 2010 19:31:15 +1300 Subject: [PATCH 20/72] Fix set-callstack primitive on Windows --- basis/cpu/x86/32/bootstrap.factor | 11 ++++++----- basis/cpu/x86/64/bootstrap.factor | 6 +++++- vm/utilities.cpp | 7 +++++++ 3 files changed, 18 insertions(+), 6 deletions(-) diff --git a/basis/cpu/x86/32/bootstrap.factor b/basis/cpu/x86/32/bootstrap.factor index afcae6d4d9..8a5e43da31 100644 --- a/basis/cpu/x86/32/bootstrap.factor +++ b/basis/cpu/x86/32/bootstrap.factor @@ -126,12 +126,13 @@ IN: bootstrap.x86 ! Compute new stack pointer -- 'dst' for memcpy EAX EDX SUB ! Install new stack pointer - RSP EAX MOV + ESP EAX MOV ! Call memcpy - ESP 8 [+] EDX MOV - ESP 4 [+] EBP MOV - ESP [] EAX MOV - 0 CALL "memcpy" f rc-relative jit-dlsym + EDX PUSH + EBP PUSH + EAX PUSH + 0 CALL "factor_memcpy" f rc-relative jit-dlsym + ESP 12 ADD ! Return with new callstack 0 RET ] \ set-callstack define-sub-primitive diff --git a/basis/cpu/x86/64/bootstrap.factor b/basis/cpu/x86/64/bootstrap.factor index 55dba215d7..2d0296e159 100644 --- a/basis/cpu/x86/64/bootstrap.factor +++ b/basis/cpu/x86/64/bootstrap.factor @@ -121,8 +121,12 @@ IN: bootstrap.x86 ! Install new stack pointer RSP arg1 MOV ! Call memcpy; arguments are now in the correct registers - safe-reg 0 MOV "memcpy" f rc-absolute-cell jit-dlsym + ! Create register shadow area for Win64 + RSP 32 SUB + safe-reg 0 MOV "factor_memcpy" f rc-absolute-cell jit-dlsym safe-reg CALL + ! Tear down register shadow area + RSP 32 ADD ! Return with new callstack 0 RET ] \ set-callstack define-sub-primitive diff --git a/vm/utilities.cpp b/vm/utilities.cpp index 8f063a9ad4..3e976d0619 100755 --- a/vm/utilities.cpp +++ b/vm/utilities.cpp @@ -18,4 +18,11 @@ cell read_cell_hex() return cell; } +/* On Windows, memcpy() is in a different DLL and the non-optimizing +compiler can't find it */ +VM_C_API void *factor_memcpy(void *dst, void *src, size_t len) +{ + return memcpy(dst,src,len); +} + } From f5cc9ef66d582e5f3303890ff213ad43e186860b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 7 Jan 2010 01:40:20 -0500 Subject: [PATCH 21/72] vm: add VM_C_API declaration for factor_memcpy function --- vm/utilities.hpp | 1 + 1 file changed, 1 insertion(+) diff --git a/vm/utilities.hpp b/vm/utilities.hpp index 94b9de6f48..cea70c0c37 100755 --- a/vm/utilities.hpp +++ b/vm/utilities.hpp @@ -27,5 +27,6 @@ inline static void memset_cell(void *dst, cell pattern, size_t size) vm_char *safe_strdup(const vm_char *str); cell read_cell_hex(); +VM_C_API void *factor_memcpy(void *dst, void *src, size_t len); } From dd5452053ac851e0b797bccf723b6a903e28603a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 7 Jan 2010 20:13:42 +1300 Subject: [PATCH 22/72] math.floats.env: don't load cpu.x86.64 on x86.32 --- basis/math/floats/env/x86/x86.factor | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/basis/math/floats/env/x86/x86.factor b/basis/math/floats/env/x86/x86.factor index ed8e9b7795..9bae382ef6 100644 --- a/basis/math/floats/env/x86/x86.factor +++ b/basis/math/floats/env/x86/x86.factor @@ -1,8 +1,8 @@ USING: accessors alien alien.c-types alien.syntax arrays assocs -biassocs classes.struct combinators cpu.x86.64 +biassocs classes.struct combinators cpu.architecture cpu.x86.assembler cpu.x86.assembler.operands cpu.x86.features kernel literals math math.bitwise math.floats.env -math.floats.env.private system ; +math.floats.env.private sequences system ; IN: math.floats.env.x86 STRUCT: sse-env @@ -48,24 +48,24 @@ M: x86.32 set-x87-env ! 64-bit M: x86.64 get-sse-env void { void* } "cdecl" [ - param-reg-0 [] STMXCSR + int-regs param-regs first [] STMXCSR ] alien-assembly ; M: x86.64 set-sse-env void { void* } "cdecl" [ - param-reg-0 [] LDMXCSR + int-regs param-regs first [] LDMXCSR ] alien-assembly ; M: x86.64 get-x87-env void { void* } "cdecl" [ - param-reg-0 [] FNSTSW - param-reg-0 2 [+] FNSTCW + int-regs param-regs first [] FNSTSW + int-regs param-regs first 2 [+] FNSTCW ] alien-assembly ; M: x86.64 set-x87-env void { void* } "cdecl" [ FNCLEX - param-reg-0 2 [+] FLDCW + int-regs param-regs first 2 [+] FLDCW ] alien-assembly ; : ( -- sse-env ) From d84f1325898738383d41900c1293e7241d6be132 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 7 Jan 2010 20:44:28 +1300 Subject: [PATCH 23/72] math.floats.env.x86: split off 32 and 64-bit code into sub-vocabularies --- basis/math/floats/env/x86/32/32.factor | 29 ++++++++++++ basis/math/floats/env/x86/32/tags.txt | 1 + basis/math/floats/env/x86/64/64.factor | 25 ++++++++++ basis/math/floats/env/x86/64/tags.txt | 1 + basis/math/floats/env/x86/x86.factor | 63 ++++---------------------- 5 files changed, 64 insertions(+), 55 deletions(-) create mode 100644 basis/math/floats/env/x86/32/32.factor create mode 100644 basis/math/floats/env/x86/32/tags.txt create mode 100644 basis/math/floats/env/x86/64/64.factor create mode 100644 basis/math/floats/env/x86/64/tags.txt diff --git a/basis/math/floats/env/x86/32/32.factor b/basis/math/floats/env/x86/32/32.factor new file mode 100644 index 0000000000..ea3bee424f --- /dev/null +++ b/basis/math/floats/env/x86/32/32.factor @@ -0,0 +1,29 @@ +USING: alien alien.c-types cpu.x86.assembler +cpu.x86.assembler.operands math.floats.env.x86 system ; +IN: math.floats.env.x86.32 + +M: x86.32 get-sse-env + void { void* } "cdecl" [ + EAX ESP [] MOV + EAX [] STMXCSR + ] alien-assembly ; + +M: x86.32 set-sse-env + void { void* } "cdecl" [ + EAX ESP [] MOV + EAX [] LDMXCSR + ] alien-assembly ; + +M: x86.32 get-x87-env + void { void* } "cdecl" [ + EAX ESP [] MOV + EAX [] FNSTSW + EAX 2 [+] FNSTCW + ] alien-assembly ; + +M: x86.32 set-x87-env + void { void* } "cdecl" [ + EAX ESP [] MOV + FNCLEX + EAX 2 [+] FLDCW + ] alien-assembly ; diff --git a/basis/math/floats/env/x86/32/tags.txt b/basis/math/floats/env/x86/32/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/math/floats/env/x86/32/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/math/floats/env/x86/64/64.factor b/basis/math/floats/env/x86/64/64.factor new file mode 100644 index 0000000000..b6f8ee151f --- /dev/null +++ b/basis/math/floats/env/x86/64/64.factor @@ -0,0 +1,25 @@ +USING: alien alien.c-types cpu.architecture cpu.x86.assembler +cpu.x86.assembler.operands math.floats.env.x86 sequences system ; +IN: math.floats.env.x86.64 + +M: x86.64 get-sse-env + void { void* } "cdecl" [ + int-regs param-regs first [] STMXCSR + ] alien-assembly ; + +M: x86.64 set-sse-env + void { void* } "cdecl" [ + int-regs param-regs first [] LDMXCSR + ] alien-assembly ; + +M: x86.64 get-x87-env + void { void* } "cdecl" [ + int-regs param-regs first [] FNSTSW + int-regs param-regs first 2 [+] FNSTCW + ] alien-assembly ; + +M: x86.64 set-x87-env + void { void* } "cdecl" [ + FNCLEX + int-regs param-regs first 2 [+] FLDCW + ] alien-assembly ; diff --git a/basis/math/floats/env/x86/64/tags.txt b/basis/math/floats/env/x86/64/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/math/floats/env/x86/64/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/math/floats/env/x86/x86.factor b/basis/math/floats/env/x86/x86.factor index 9bae382ef6..89dd402378 100644 --- a/basis/math/floats/env/x86/x86.factor +++ b/basis/math/floats/env/x86/x86.factor @@ -1,8 +1,7 @@ -USING: accessors alien alien.c-types alien.syntax arrays assocs -biassocs classes.struct combinators cpu.architecture -cpu.x86.assembler cpu.x86.assembler.operands cpu.x86.features -kernel literals math math.bitwise math.floats.env -math.floats.env.private sequences system ; +USING: accessors alien.c-types arrays assocs biassocs +classes.struct combinators cpu.x86.features kernel literals +math math.bitwise math.floats.env math.floats.env.private +system vocabs.loader ; IN: math.floats.env.x86 STRUCT: sse-env @@ -18,56 +17,6 @@ HOOK: set-sse-env cpu ( sse-env -- ) HOOK: get-x87-env cpu ( x87-env -- ) HOOK: set-x87-env cpu ( x87-env -- ) -! 32-bit -M: x86.32 get-sse-env - void { void* } "cdecl" [ - EAX ESP [] MOV - EAX [] STMXCSR - ] alien-assembly ; - -M: x86.32 set-sse-env - void { void* } "cdecl" [ - EAX ESP [] MOV - EAX [] LDMXCSR - ] alien-assembly ; - -M: x86.32 get-x87-env - void { void* } "cdecl" [ - EAX ESP [] MOV - EAX [] FNSTSW - EAX 2 [+] FNSTCW - ] alien-assembly ; - -M: x86.32 set-x87-env - void { void* } "cdecl" [ - EAX ESP [] MOV - FNCLEX - EAX 2 [+] FLDCW - ] alien-assembly ; - -! 64-bit -M: x86.64 get-sse-env - void { void* } "cdecl" [ - int-regs param-regs first [] STMXCSR - ] alien-assembly ; - -M: x86.64 set-sse-env - void { void* } "cdecl" [ - int-regs param-regs first [] LDMXCSR - ] alien-assembly ; - -M: x86.64 get-x87-env - void { void* } "cdecl" [ - int-regs param-regs first [] FNSTSW - int-regs param-regs first 2 [+] FNSTCW - ] alien-assembly ; - -M: x86.64 set-x87-env - void { void* } "cdecl" [ - FNCLEX - int-regs param-regs first 2 [+] FLDCW - ] alien-assembly ; - : ( -- sse-env ) sse-env (struct) [ get-sse-env ] keep ; @@ -178,3 +127,7 @@ M: x87-env (get-denormal-mode) ( register -- mode ) M: x87-env (set-denormal-mode) ( register mode -- register' ) drop ; +cpu { + { x86.32 [ "math.floats.env.x86.32" ] } + { x86.64 [ "math.floats.env.x86.64" ] } +} case require From 9471fd1a332ec2417bc95130812101a28c215533 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 7 Jan 2010 20:54:27 +1300 Subject: [PATCH 24/72] alien: fix help lint --- core/alien/alien.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/alien/alien.factor b/core/alien/alien.factor index 10012ea3d0..16c33fc1c3 100644 --- a/core/alien/alien.factor +++ b/core/alien/alien.factor @@ -59,7 +59,7 @@ ERROR: alien-invoke-error library symbol ; ERROR: alien-assembly-error code ; -: alien-assembly ( ... return library parameters abi quot -- ... ) +: alien-assembly ( ... return parameters abi quot -- ... ) dup alien-assembly-error ; ! Callbacks are registered in a global hashtable. Note that they From 0fd3c78157306b3094d58e89588e2369f51d26b7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 7 Jan 2010 21:33:19 +1300 Subject: [PATCH 25/72] vm: remove some unused #defines --- vm/os-unix.hpp | 10 ---------- vm/os-windows.hpp | 6 ------ 2 files changed, 16 deletions(-) diff --git a/vm/os-unix.hpp b/vm/os-unix.hpp index fa9bc71417..bb784bc93c 100644 --- a/vm/os-unix.hpp +++ b/vm/os-unix.hpp @@ -26,18 +26,8 @@ typedef char symbol_char; #define FTELL ftello #define FSEEK fseeko -#define FIXNUM_FORMAT "%ld" -#define CELL_FORMAT "%lu" #define CELL_HEX_FORMAT "%lx" -#ifdef FACTOR_64 - #define CELL_HEX_PAD_FORMAT "%016lx" -#else - #define CELL_HEX_PAD_FORMAT "%08lx" -#endif - -#define FIXNUM_FORMAT "%ld" - #define OPEN_READ(path) fopen(path,"rb") #define OPEN_WRITE(path) fopen(path,"wb") diff --git a/vm/os-windows.hpp b/vm/os-windows.hpp index eeac2a42dd..a7c69571d9 100644 --- a/vm/os-windows.hpp +++ b/vm/os-windows.hpp @@ -23,15 +23,9 @@ typedef wchar_t vm_char; #define FSEEK fseeko64 #ifdef WIN64 - #define CELL_FORMAT "%Iu" #define CELL_HEX_FORMAT "%Ix" - #define CELL_HEX_PAD_FORMAT "%016Ix" - #define FIXNUM_FORMAT "%Id" #else - #define CELL_FORMAT "%lu" #define CELL_HEX_FORMAT "%lx" - #define CELL_HEX_PAD_FORMAT "%08lx" - #define FIXNUM_FORMAT "%ld" #endif #define OPEN_READ(path) _wfopen(path,L"rb") From 6266b41325574cd90bd1ca842ff8cdc93fec778f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 8 Jan 2010 19:46:27 +1300 Subject: [PATCH 26/72] Starting to update PowerPC backend for recent VM changes (untested) --- Makefile | 3 + basis/cpu/ppc/bootstrap.factor | 173 +++++++++-- basis/cpu/ppc/linux/bootstrap.factor | 8 +- basis/cpu/ppc/macosx/bootstrap.factor | 8 +- vm/Config.ppc | 2 +- vm/cpu-ppc.S | 400 ++++---------------------- 6 files changed, 213 insertions(+), 381 deletions(-) diff --git a/Makefile b/Makefile index 57b7ef0848..772f3f9875 100755 --- a/Makefile +++ b/Makefile @@ -212,6 +212,9 @@ vm/ffi_test.o: vm/ffi_test.c .cpp.o: $(TOOLCHAIN_PREFIX)$(CPP) -c $(CFLAGS) -o $@ $< +.S.o: + $(TOOLCHAIN_PREFIX)$(CC) -x assembler-with-cpp -c $(CFLAGS) -o $@ $< + .mm.o: $(TOOLCHAIN_PREFIX)$(CPP) -c $(CFLAGS) -o $@ $< diff --git a/basis/cpu/ppc/bootstrap.factor b/basis/cpu/ppc/bootstrap.factor index 837acd0ea1..ba2b404a06 100644 --- a/basis/cpu/ppc/bootstrap.factor +++ b/basis/cpu/ppc/bootstrap.factor @@ -1,9 +1,10 @@ -! Copyright (C) 2007, 2009 Slava Pestov. +! Copyright (C) 2007, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: bootstrap.image.private kernel kernel.private namespaces system cpu.ppc.assembler compiler.codegen.fixup compiler.units -compiler.constants math math.private layouts words vocabs -slots.private locals locals.backend generic.single.private fry ; +compiler.constants math math.private math.ranges layouts words vocabs +slots.private locals locals.backend generic.single.private fry +sequences ; FROM: cpu.ppc.assembler => B ; IN: bootstrap.ppc @@ -13,28 +14,88 @@ big-endian on CONSTANT: ds-reg 13 CONSTANT: rs-reg 14 CONSTANT: vm-reg 15 +CONSTANT: ctx-reg 16 -: factor-area-size ( -- n ) 4 bootstrap-cells ; +: factor-area-size ( -- n ) 16 ; : stack-frame ( -- n ) - factor-area-size c-area-size + 4 bootstrap-cells align ; + reserved-size + factor-area-size + + 16 align ; -: next-save ( -- n ) stack-frame bootstrap-cell - ; -: xt-save ( -- n ) stack-frame 2 bootstrap-cells - ; +: next-save ( -- n ) stack-frame 4 - ; +: xt-save ( -- n ) stack-frame 8 - ; + +: param-size ( -- n ) 32 ; + +: save-at ( m -- n ) reserved-size + param-size + ; + +: save-int ( register offset -- ) [ 1 ] dip save-at STW ; +: restore-int ( register offset -- ) [ 1 ] dip save-at LWZ ; + +: save-fp ( register offset -- ) [ 1 ] dip save-at STFD ; +: restore-fp ( register offset -- ) [ 1 ] dip save-at LFD ; + +: save-vec ( register offset -- ) save-at 2 LI 2 1 STVXL ; +: restore-vec ( register offset -- ) save-at 2 LI 2 1 LVXL ; + +: nv-int-regs ( -- seq ) 13 31 [a,b] ; +: nv-fp-regs ( -- seq ) 14 31 [a,b] ; +: nv-vec-regs ( -- seq ) 20 31 [a,b] ; + +: saved-int-regs-size ( -- n ) 96 ; +: saved-fp-regs-size ( -- n ) 144 ; +: saved-vec-regs-size ( -- n ) 208 ; + +: callback-frame-size ( -- n ) + reserved-size + param-size + + saved-int-regs-size + + saved-fp-regs-size + + saved-vec-regs-size + + 16 align ; + +[ + 0 MFLR + 1 1 callback-frame-size neg STWU + 0 1 callback-frame-size lr-save + STW + + nv-int-regs [ cells save-int ] each-index + nv-fp-regs [ 8 * 80 + save-fp ] each-index + nv-vec-regs [ 16 * 224 + save-vec ] each-index + + 0 vm-reg LOAD32 rt-vm rc-absolute-ppc-2/2 jit-rel + + 0 2 LOAD32 rc-absolute-ppc-2/2 rt-xt jit-rel + 2 MTLR + BLRL + + nv-vec-regs [ 16 * 224 + restore-vec ] each-index + nv-fp-regs [ 8 * 80 + restore-fp ] each-index + nv-int-regs [ cells restore-int ] each-index + + 0 1 callback-frame-size lr-save + LWZ + 1 1 0 LWZ + 0 MTLR + BLR +] callback-stub jit-define : jit-conditional* ( test-quot false-quot -- ) - [ '[ bootstrap-cell /i 1 + @ ] ] dip jit-conditional ; inline + [ '[ 4 /i 1 + @ ] ] dip jit-conditional ; inline + +: jit-load-context ( -- ) + ctx-reg vm-reg vm-context-offset LWZ ; : jit-save-context ( -- ) - 4 vm-reg 0 LWZ - 1 4 0 STW - ds-reg 4 8 STW - rs-reg 4 12 STW ; + jit-load-context + 1 2 context-callstack-top-offset STW + ds-reg ctx-reg context-datastack-offset STW + rs-reg ctx-reg context-retainstack-offset STW ; : jit-restore-context ( -- ) - 4 vm-reg 0 LWZ - ds-reg 4 8 LWZ - rs-reg 4 12 LWZ ; + jit-load-context + ds-reg ctx-reg context-datastack-offset LWZ + rs-reg ctx-reg context-retainstack-offset LWZ ; [ 0 3 LOAD32 rc-absolute-ppc-2/2 rt-literal jit-rel @@ -181,7 +242,7 @@ CONSTANT: vm-reg 15 load-tag 0 4 tuple type-number tag-fixnum CMPI [ BNE ] - [ 4 3 tuple type-number neg bootstrap-cell + LWZ ] + [ 4 3 tuple type-number neg 4 + LWZ ] jit-conditional* ] pic-tuple jit-define @@ -230,7 +291,7 @@ CONSTANT: vm-reg 15 ! key = hashcode(class) 5 4 1 SRAWI ! key &= cache.length - 1 - 5 5 mega-cache-size get 1 - bootstrap-cell * ANDI + 5 5 mega-cache-size get 1 - 4 * ANDI ! cache += array-start-offset 3 3 array-start-offset ADDI ! cache += key @@ -245,7 +306,7 @@ CONSTANT: vm-reg 15 5 4 0 LWZ 5 5 1 ADDI 5 4 0 STW - ! ... goto get(cache + bootstrap-cell) + ! ... goto get(cache + 4) 3 3 4 LWZ 3 3 word-xt-offset LWZ 3 MTCTR @@ -255,19 +316,12 @@ CONSTANT: vm-reg 15 ! fall-through on miss ] mega-lookup jit-define -[ - 0 2 LOAD32 rc-absolute-ppc-2/2 rt-xt jit-rel - 2 MTCTR - BCTR -] callback-stub jit-define - ! ! ! Sub-primitives ! Quotations and words [ 3 ds-reg 0 LWZ ds-reg dup 4 SUBI - 4 vm-reg MR 5 3 quot-xt-offset LWZ ] [ 5 MTLR BLRL ] @@ -288,6 +342,75 @@ CONSTANT: vm-reg 15 4 MTCTR BCTR ] jit-execute jit-define +! Special primitives +[ + jit-restore-context + ! Save ctx->callstack_bottom + 1 ctx-reg context-callstack-bottom-offset STW + ! Call quotation + 5 3 quot-xt-offset LWZ + 5 MTLR + BLRL + jit-save-context +] \ c-to-factor define-sub-primitive + +[ + ! Unwind stack frames + 1 4 MR + + ! Load ds and rs registers + jit-restore-context + + ! We have changed the stack; load return address again + 0 1 stack-frame lr-save + LWZ + 0 MTLR + + ! Call quotation + 4 3 quot-xt-offset LWZ + 4 MTCTR + BCTR +] \ unwind-native-frames define-sub-primitive + +[ + ! Load callstack object + 6 ds-reg 0 LWZ + ds-reg ds-reg 4 SUBI + ! Get ctx->callstack_bottom + jit-load-context + 3 ctx-reg context-callstack-bottom-offset LWZ + ! Get top of callstack object -- 'src' for memcpy + 4 6 callstack-top-offset ADDI + ! Get callstack length, in bytes --- 'len' for memcpy + 5 6 callstack-length-offset LWZ + 5 5 tag-bits get SRAWI + ! Compute new stack pointer -- 'dst' for memcpy + 3 3 5 SUBF + ! Install new stack pointer + 1 3 MR + ! Call memcpy; arguments are now in the correct registers + 1 1 -64 STWU + 0 2 LOAD32 "factor_memcpy" f rc-absolute-ppc-2/2 jit-dlsym + 2 MTLR + BLRL + 1 1 0 LWZ + ! Return with new callstack + 0 1 lr-save stack-frame + LWZ + 0 MTLR + BLR +] \ set-callstack define-sub-primitive + +[ + jit-save-context + 4 vm-reg MR + 2 0 LOAD32 "lazy_jit_compile" f rc-absolute-ppc-2/2 jit-dlsym + 2 MTLR + BLRL + 5 3 quot-xt-offset LWZ +] +[ 5 MTLR BLRL ] +[ 5 MTCTR BCTR ] +\ lazy-jit-compile define-combinator-primitive + ! Objects [ 3 ds-reg 0 LWZ diff --git a/basis/cpu/ppc/linux/bootstrap.factor b/basis/cpu/ppc/linux/bootstrap.factor index a5250414ab..2f463dea00 100644 --- a/basis/cpu/ppc/linux/bootstrap.factor +++ b/basis/cpu/ppc/linux/bootstrap.factor @@ -1,10 +1,10 @@ -! Copyright (C) 2007, 2008 Slava Pestov. +! Copyright (C) 2007, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: parser layouts system kernel sequences ; +USING: parser system kernel sequences ; IN: bootstrap.ppc -: c-area-size ( -- n ) 10 bootstrap-cells ; -: lr-save ( -- n ) bootstrap-cell ; +: reserved-size ( -- n ) 24 ; +: lr-save ( -- n ) 4 ; << "vocab:cpu/ppc/bootstrap.factor" parse-file suffix! >> call diff --git a/basis/cpu/ppc/macosx/bootstrap.factor b/basis/cpu/ppc/macosx/bootstrap.factor index 2aa0ddc4a2..0960011c70 100644 --- a/basis/cpu/ppc/macosx/bootstrap.factor +++ b/basis/cpu/ppc/macosx/bootstrap.factor @@ -1,10 +1,10 @@ -! Copyright (C) 2007, 2008 Slava Pestov. +! Copyright (C) 2007, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: parser layouts system kernel sequences ; +USING: parser system kernel sequences ; IN: bootstrap.ppc -: c-area-size ( -- n ) 14 bootstrap-cells ; -: lr-save ( -- n ) 2 bootstrap-cells ; +: reserved-size ( -- n ) 24 ; +: lr-save ( -- n ) 8 ; << "vocab:cpu/ppc/bootstrap.factor" parse-file suffix! >> call diff --git a/vm/Config.ppc b/vm/Config.ppc index 8b13789179..1ded04dda1 100644 --- a/vm/Config.ppc +++ b/vm/Config.ppc @@ -1 +1 @@ - +PLAF_DLL_OBJS += vm/cpu-ppc.o diff --git a/vm/cpu-ppc.S b/vm/cpu-ppc.S index b387bafbbf..835ed14cc2 100644 --- a/vm/cpu-ppc.S +++ b/vm/cpu-ppc.S @@ -1,367 +1,73 @@ -/* Parts of this file were snarfed from SBCL src/runtime/ppc-assem.S, which is -in the public domain. */ -#if defined(__APPLE__) || (defined(WINDOWS) && !defined(__arm__)) - #define MANGLE(sym) _##sym +#if defined(__APPLE__) + #define MANGLE(sym) _##sym + #define XX @ #else - #define MANGLE(sym) sym -#endif - -/* Apple's PPC assembler is out of date? */ -#if defined(__APPLE__) && defined(__ppc__) - #define XX @ -#else - #define XX ; + #define MANGLE(sym) sym + #define XX ; #endif /* The returns and args are just for documentation */ #define DEF(returns,symbol,args) .globl MANGLE(symbol) XX \ MANGLE(symbol) -#define DS_REG r13 -#define RS_REG r14 -#define VM_REG r15 - -#define CALL_OR_JUMP_QUOT \ - lwz r11,12(r3) /* load quotation-xt slot */ XX \ - -#define CALL_QUOT \ - CALL_OR_JUMP_QUOT XX \ - mtlr r11 /* prepare to call XT with quotation in r3 */ XX \ - blrl /* go */ - -#define JUMP_QUOT \ - CALL_OR_JUMP_QUOT XX \ - mtctr r11 /* prepare to call XT with quotation in r3 */ XX \ - bctr /* go */ - -#define PARAM_SIZE 32 - -#define SAVED_INT_REGS_SIZE 96 - -#define SAVED_FP_REGS_SIZE 144 - -#define SAVED_V_REGS_SIZE 208 - -#define FRAME (RESERVED_SIZE + PARAM_SIZE + SAVED_INT_REGS_SIZE + SAVED_FP_REGS_SIZE + SAVED_V_REGS_SIZE + 8) - -#if defined( __APPLE__) - #define LR_SAVE 8 - #define RESERVED_SIZE 24 -#else - #define LR_SAVE 4 - #define RESERVED_SIZE 8 -#endif - -#define SAVE_LR(reg) stw reg,(LR_SAVE + FRAME)(r1) - -#define LOAD_LR(reg) lwz reg,(LR_SAVE + FRAME)(r1) - -#define SAVE_AT(offset) (RESERVED_SIZE + PARAM_SIZE + 4 * offset) - -#define SAVE_INT(register,offset) stw register,SAVE_AT(offset)(r1) -#define RESTORE_INT(register,offset) lwz register,SAVE_AT(offset)(r1) - -#define SAVE_FP(register,offset) stfd register,SAVE_AT(offset)(r1) -#define RESTORE_FP(register,offset) lfd register,SAVE_AT(offset)(r1) - -#define SAVE_V(register,offset) \ - li r2,SAVE_AT(offset) XX \ - stvxl register,r2,r1 - -#define RESTORE_V(register,offset) \ - li r2,SAVE_AT(offset) XX \ - lvxl register,r2,r1 - -#define PROLOGUE \ - mflr r0 XX /* get caller's return address */ \ - stwu r1,-FRAME(r1) XX /* create a stack frame to hold non-volatile registers */ \ - SAVE_LR(r0) - -#define EPILOGUE \ - LOAD_LR(r0) XX \ - lwz r1,0(r1) XX /* destroy the stack frame */ \ - mtlr r0 /* get ready to return */ - -/* We have to save and restore nonvolatile registers because -the Factor compiler treats the entire register file as volatile. */ -DEF(void,c_to_factor,(cell quot, void *vm)): - PROLOGUE - - SAVE_INT(r13,0) - SAVE_INT(r14,1) - SAVE_INT(VM_REG,2) - SAVE_INT(r16,3) - SAVE_INT(r17,4) - SAVE_INT(r18,5) - SAVE_INT(r19,6) - SAVE_INT(r20,7) - SAVE_INT(r21,8) - SAVE_INT(r22,9) - SAVE_INT(r23,10) - SAVE_INT(r24,11) - SAVE_INT(r25,12) - SAVE_INT(r26,13) - SAVE_INT(r27,14) - SAVE_INT(r28,15) - SAVE_INT(r29,16) - SAVE_INT(r30,17) - SAVE_INT(r31,18) - - SAVE_FP(f14,20) - SAVE_FP(f15,22) - SAVE_FP(f16,24) - SAVE_FP(f17,26) - SAVE_FP(f18,28) - SAVE_FP(f19,30) - SAVE_FP(f20,32) - SAVE_FP(f21,34) - SAVE_FP(f22,36) - SAVE_FP(f23,38) - SAVE_FP(f24,40) - SAVE_FP(f25,42) - SAVE_FP(f26,44) - SAVE_FP(f27,46) - SAVE_FP(f28,48) - SAVE_FP(f29,50) - SAVE_FP(f30,52) - SAVE_FP(f31,54) - - SAVE_V(v20,56) - SAVE_V(v21,60) - SAVE_V(v22,64) - SAVE_V(v23,68) - SAVE_V(v24,72) - SAVE_V(v25,76) - SAVE_V(v26,80) - SAVE_V(v27,84) - SAVE_V(v28,88) - SAVE_V(v29,92) - SAVE_V(v30,96) - SAVE_V(v31,100) - - /* r4 vm ptr preserved */ - mfvscr v0 - li r2,SAVE_AT(104) - stvxl v0,r2,r1 - addi r2,r2,0xc - lwzx r5,r2,r1 - lis r6,0x1 - andc r5,r5,r6 - stwx r5,r2,r1 - subi r2,r2,0xc - lvxl v0,r2,r1 - mtvscr v0 - - - /* Load context */ - mr VM_REG,r4 - lwz r16,0(VM_REG) - - /* Load ctx->datastack */ - lwz DS_REG,8(r16) - - /* Load ctx->retainstack */ - lwz RS_REG,12(r16) - - /* Save ctx->callstack_bottom */ - stw r1,4(r16) - - CALL_QUOT - - /* Load context */ - lwz r16,0(VM_REG) - - /* Save ctx->datastack */ - stw DS_REG,8(r16) - - /* Save ctx->retainstack */ - stw RS_REG,12(r16) - - RESTORE_V(v0,104) - mtvscr v0 - - RESTORE_V(v31,100) - RESTORE_V(v30,96) - RESTORE_V(v29,92) - RESTORE_V(v28,88) - RESTORE_V(v27,84) - RESTORE_V(v26,80) - RESTORE_V(v25,76) - RESTORE_V(v24,72) - RESTORE_V(v23,68) - RESTORE_V(v22,64) - RESTORE_V(v21,60) - RESTORE_V(v20,56) - - RESTORE_FP(f31,54) - RESTORE_FP(f30,52) - RESTORE_FP(f29,50) - RESTORE_FP(f28,48) - RESTORE_FP(f27,46) - RESTORE_FP(f26,44) - RESTORE_FP(f25,42) - RESTORE_FP(f24,40) - RESTORE_FP(f23,38) - RESTORE_FP(f22,36) - RESTORE_FP(f21,34) - RESTORE_FP(f20,32) - RESTORE_FP(f19,30) - RESTORE_FP(f18,28) - RESTORE_FP(f17,26) - RESTORE_FP(f16,24) - RESTORE_FP(f15,22) - RESTORE_FP(f14,20) - - RESTORE_INT(r31,18) - RESTORE_INT(r30,17) - RESTORE_INT(r29,16) - RESTORE_INT(r28,15) - RESTORE_INT(r27,14) - RESTORE_INT(r26,13) - RESTORE_INT(r25,12) - RESTORE_INT(r24,11) - RESTORE_INT(r23,10) - RESTORE_INT(r22,9) - RESTORE_INT(r21,8) - RESTORE_INT(r20,7) - RESTORE_INT(r19,6) - RESTORE_INT(r18,5) - RESTORE_INT(r17,4) - RESTORE_INT(r16,3) - RESTORE_INT(VM_REG,2) - RESTORE_INT(r14,1) - RESTORE_INT(r13,0) - - EPILOGUE - blr - -DEF(void,set_callstack,(void *vm, stack_frame *to, stack_frame *from, cell length, void *memcpy)): - /* Save VM pointer in non-volatile register */ - mr VM_REG,r3 - - /* Compute new stack pointer */ - sub r1,r4,r6 - - /* Call memcpy() */ - mr r3,r1 - mr r4,r5 - mr r5,r6 - stwu r1,-64(r1) - mtlr r7 - blrl - lwz r1,0(r1) - - /* Load context */ - lwz r16,0(VM_REG) - - /* Load ctx->datastack */ - lwz DS_REG,8(r16) - - /* Load ctx->retainstack */ - lwz RS_REG,12(r16) - - /* We have changed the stack; load return address again */ - lwz r0,LR_SAVE(r1) - mtlr r0 - blr - -DEF(void,throw_impl,(cell quot, void *new_stack, void *vm)): - /* compute new stack pointer */ - mr r1,r4 - - /* make vm ptr 2nd arg in case quot->xt == lazy_jit_compile */ - mr r4,r5 - - /* Load context */ - mr VM_REG,r5 - lwz r16,0(VM_REG) - - /* Load ctx->datastack */ - lwz DS_REG,8(r16) - - /* Load ctx->retainstack */ - lwz RS_REG,12(r16) - - /* We have changed the stack; load return address again */ - lwz r0,LR_SAVE(r1) - mtlr r0 - - /* Call the quotation */ - JUMP_QUOT - -DEF(void,lazy_jit_compile_impl,(cell quot, void *vm)): - /* Load context */ - mr VM_REG,r4 - lwz r16,0(VM_REG) - - /* Save ctx->datastack */ - stw DS_REG,8(r16) - - /* Save ctx->retainstack */ - stw RS_REG,12(r16) - - /* Save ctx->callstack_top */ - stw r1,0(r16) - - /* Compile quotation */ - PROLOGUE - bl MANGLE(lazy_jit_compile) - EPILOGUE - - /* Call the quotation */ - JUMP_QUOT - /* Thanks to Joshua Grams for this code. On PowerPC processors, we must flush the instruction cache manually after writing to the code heap. */ -DEF(void,flush_icache,(void *start, int len)): - /* compute number of cache lines to flush */ - add r4,r4,r3 - clrrwi r3,r3,5 /* align addr to next lower cache line boundary */ - sub r4,r4,r3 /* then n_lines = (len + 0x1f) / 0x20 */ - addi r4,r4,0x1f - srwi. r4,r4,5 /* note '.' suffix */ - beqlr /* if n_lines == 0, just return. */ - mtctr r4 /* flush cache lines */ -0: dcbf 0,r3 /* for each line... */ - sync - icbi 0,r3 - addi r3,r3,0x20 - bdnz 0b - sync /* finish up */ - isync - blr +DEF(void,flush_icache,(void*, int)): + /* compute number of cache lines to flush */ + add r4,r4,r3 + /* align addr to next lower cache line boundary */ + clrrwi r3,r3,5 + /* then n_lines = (len + 0x1f) / 0x20 */ + sub r4,r4,r3 + addi r4,r4,0x1f + /* note '.' suffix */ + srwi. r4,r4,5 + /* if n_lines == 0, just return. */ + beqlr + /* flush cache lines */ + mtctr r4 + /* for each line... */ +0: dcbf 0,r3 + sync + icbi 0,r3 + addi r3,r3,0x20 + bdnz 0b + /* finish up */ + sync + isync + blr DEF(void,get_ppc_fpu_env,(void*)): - mffs f0 - stfd f0,0(r3) - blr + mffs f0 + stfd f0,0(r3) + blr DEF(void,set_ppc_fpu_env,(const void*)): - lfd f0,0(r3) - mtfsf 0xff,f0 - blr + lfd f0,0(r3) + mtfsf 0xff,f0 + blr DEF(void,get_ppc_vmx_env,(void*)): - mfvscr v0 - subi r4,r1,16 - li r5,0xf - andc r4,r4,r5 - stvxl v0,0,r4 - li r5,0xc - lwzx r6,r5,r4 - stw r6,0(r3) - blr + mfvscr v0 + subi r4,r1,16 + li r5,0xf + andc r4,r4,r5 + stvxl v0,0,r4 + li r5,0xc + lwzx r6,r5,r4 + stw r6,0(r3) + blr DEF(void,set_ppc_vmx_env,(const void*)): - subi r4,r1,16 - li r5,0xf - andc r4,r4,r5 - li r5,0xc - lwz r6,0(r3) - stwx r6,r5,r4 - lvxl v0,0,r4 - mtvscr v0 - blr + subi r4,r1,16 + li r5,0xf + andc r4,r4,r5 + li r5,0xc + lwz r6,0(r3) + stwx r6,r5,r4 + lvxl v0,0,r4 + mtvscr v0 + blr From 90422d8835b8a936c28f8911e2c33c45775df031 Mon Sep 17 00:00:00 2001 From: Alec Berryman Date: Wed, 2 Dec 2009 10:34:37 -0600 Subject: [PATCH 27/72] build-support/factor.sh: allow user to specify NO_UI --- build-support/factor.sh | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/build-support/factor.sh b/build-support/factor.sh index d54f9d8a77..d090433d98 100755 --- a/build-support/factor.sh +++ b/build-support/factor.sh @@ -11,7 +11,7 @@ ECHO=echo OS= ARCH= WORD= -NO_UI= +NO_UI=${NO_UI-} GIT_PROTOCOL=${GIT_PROTOCOL:="git"} GIT_URL=${GIT_URL:=$GIT_PROTOCOL"://factorcode.org/git/factor.git"} SCRIPT_ARGS="$*" @@ -132,9 +132,11 @@ check_library_exists() { } check_X11_libraries() { - check_library_exists GL - check_library_exists X11 - check_library_exists pango-1.0 + if [ -z "$NO_UI" ]; then + check_library_exists GL + check_library_exists X11 + check_library_exists pango-1.0 + fi } check_libraries() { From b85d26759adc03cf92b3f3ffd04297409b6b7837 Mon Sep 17 00:00:00 2001 From: Alec Berryman Date: Mon, 28 Dec 2009 20:05:09 -0600 Subject: [PATCH 28/72] Fix zlib-error-message to include human-readable version The error string is looked up in an array, but because zlib error codes are negative, the error's string was always "f". --- basis/compression/zlib/zlib-tests.factor | 5 ++++- basis/compression/zlib/zlib.factor | 4 +++- 2 files changed, 7 insertions(+), 2 deletions(-) diff --git a/basis/compression/zlib/zlib-tests.factor b/basis/compression/zlib/zlib-tests.factor index 1baeba73d9..b9bc502d46 100644 --- a/basis/compression/zlib/zlib-tests.factor +++ b/basis/compression/zlib/zlib-tests.factor @@ -1,9 +1,12 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel tools.test compression.zlib classes ; +USING: accessors kernel tools.test compression.zlib classes ; +QUALIFIED-WITH: compression.zlib.ffi ffi IN: compression.zlib.tests : compress-me ( -- byte-array ) B{ 1 2 3 4 5 } ; [ t ] [ compress-me [ compress uncompress ] keep = ] unit-test [ t ] [ compress-me compress compressed instance? ] unit-test + +[ ffi:Z_DATA_ERROR zlib-error-message ] [ string>> "data error" = ] must-fail-with diff --git a/basis/compression/zlib/zlib.factor b/basis/compression/zlib/zlib.factor index 7818173498..83c3e4ebb3 100644 --- a/basis/compression/zlib/zlib.factor +++ b/basis/compression/zlib/zlib.factor @@ -19,7 +19,9 @@ ERROR: zlib-failed n string ; dup compression.zlib.ffi:Z_ERRNO = [ drop errno "native libc error" ] [ - dup { + dup + -1 * ! zlib error codes are negative + { "no error" "libc_error" "stream error" "data error" "memory error" "buffer error" "zlib version error" From 39015030a03af5b5e5b73f5d0cf6227780fe3622 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 8 Jan 2010 19:51:38 +1300 Subject: [PATCH 29/72] compression.zlib: -1 * is neg --- basis/compression/zlib/zlib.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/compression/zlib/zlib.factor b/basis/compression/zlib/zlib.factor index 83c3e4ebb3..c662eec049 100644 --- a/basis/compression/zlib/zlib.factor +++ b/basis/compression/zlib/zlib.factor @@ -20,7 +20,7 @@ ERROR: zlib-failed n string ; drop errno "native libc error" ] [ dup - -1 * ! zlib error codes are negative + neg ! zlib error codes are negative { "no error" "libc_error" "stream error" "data error" From 5b58117be1181c52424ee3617d9b5729919c1c44 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 9 Jan 2010 19:09:48 +1300 Subject: [PATCH 30/72] cpu.x86: c-to-factor needs to deal with the fact that vm-reg might have been clobbered --- basis/cpu/x86/32/bootstrap.factor | 1 + basis/cpu/x86/64/bootstrap.factor | 1 + 2 files changed, 2 insertions(+) diff --git a/basis/cpu/x86/32/bootstrap.factor b/basis/cpu/x86/32/bootstrap.factor index 8a5e43da31..2798677c2c 100644 --- a/basis/cpu/x86/32/bootstrap.factor +++ b/basis/cpu/x86/32/bootstrap.factor @@ -76,6 +76,7 @@ IN: bootstrap.x86 ! call the quotation EAX quot-xt-offset [+] CALL ! save ds, rs registers + jit-load-vm jit-save-context ] \ c-to-factor define-sub-primitive diff --git a/basis/cpu/x86/64/bootstrap.factor b/basis/cpu/x86/64/bootstrap.factor index 2d0296e159..f47eb7eb70 100644 --- a/basis/cpu/x86/64/bootstrap.factor +++ b/basis/cpu/x86/64/bootstrap.factor @@ -74,6 +74,7 @@ IN: bootstrap.x86 ctx-reg context-callstack-bottom-offset [+] safe-reg MOV ! call the quotation arg1 quot-xt-offset [+] CALL + jit-load-vm jit-save-context ] \ c-to-factor define-sub-primitive From 8d34a0f3c1f9355e0edaed780660aede7620cda1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 11 Jan 2010 01:20:32 +1300 Subject: [PATCH 31/72] Store VM object in a register on x86-64 --- basis/cpu/x86/32/32.factor | 9 ++++++- basis/cpu/x86/32/bootstrap.factor | 40 +++++++++++++++++-------------- basis/cpu/x86/64/64.factor | 13 ++++++++-- basis/cpu/x86/64/bootstrap.factor | 17 ++----------- basis/cpu/x86/bootstrap.factor | 5 +++- basis/cpu/x86/x86.factor | 8 ++----- vm/callbacks.cpp | 34 ++++++++++++-------------- vm/callbacks.hpp | 3 +++ vm/quotations.cpp | 8 +++---- 9 files changed, 71 insertions(+), 66 deletions(-) diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index f1cf0211d5..0f98170d66 100644 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -8,7 +8,8 @@ compiler.codegen compiler.codegen.fixup compiler.cfg.instructions compiler.cfg.builder compiler.cfg.intrinsics compiler.cfg.stack-frame cpu.x86.assembler cpu.x86.assembler.operands cpu.x86 -cpu.architecture ; +cpu.architecture vm ; +FROM: layouts => cell ; IN: cpu.x86.32 M: x86.32 machine-registers @@ -23,6 +24,12 @@ M: x86.32 stack-reg ESP ; M: x86.32 frame-reg EBP ; M: x86.32 temp-reg ECX ; +M: x86.32 %mov-vm-ptr ( reg -- ) + 0 MOV 0 rc-absolute-cell rel-vm ; + +M: x86.32 %vm-field-ptr ( dst field -- ) + [ 0 MOV ] dip vm-field-offset rc-absolute-cell rel-vm ; + : local@ ( n -- op ) stack-frame get extra-stack-space dup 16 assert= + stack@ ; diff --git a/basis/cpu/x86/32/bootstrap.factor b/basis/cpu/x86/32/bootstrap.factor index 2798677c2c..bcab5a54ee 100644 --- a/basis/cpu/x86/32/bootstrap.factor +++ b/basis/cpu/x86/32/bootstrap.factor @@ -19,8 +19,8 @@ IN: bootstrap.x86 : safe-reg ( -- reg ) EAX ; : stack-reg ( -- reg ) ESP ; : frame-reg ( -- reg ) EBP ; -: vm-reg ( -- reg ) EBP ; -: ctx-reg ( -- reg ) ECX ; +: vm-reg ( -- reg ) ECX ; +: ctx-reg ( -- reg ) EBP ; : nv-regs ( -- seq ) { ESI EDI EBX } ; : ds-reg ( -- reg ) ESI ; : rs-reg ( -- reg ) EDI ; @@ -44,19 +44,18 @@ IN: bootstrap.x86 ctx-reg vm-reg vm-context-offset [+] MOV ; : jit-save-context ( -- ) - jit-load-context EDX RSP -4 [+] LEA ctx-reg context-callstack-top-offset [+] EDX MOV ctx-reg context-datastack-offset [+] ds-reg MOV ctx-reg context-retainstack-offset [+] rs-reg MOV ; : jit-restore-context ( -- ) - jit-load-context ds-reg ctx-reg context-datastack-offset [+] MOV rs-reg ctx-reg context-retainstack-offset [+] MOV ; [ jit-load-vm + jit-load-context jit-save-context ! call the primitive ESP [] vm-reg MOV @@ -70,13 +69,13 @@ IN: bootstrap.x86 EAX EBP 8 [+] MOV ! save ctx->callstack_bottom, load ds, rs registers jit-load-vm + jit-load-context jit-restore-context EDX stack-reg stack-frame-size 4 - [+] LEA ctx-reg context-callstack-bottom-offset [+] EDX MOV ! call the quotation EAX quot-xt-offset [+] CALL ! save ds, rs registers - jit-load-vm jit-save-context ] \ c-to-factor define-sub-primitive @@ -105,6 +104,7 @@ IN: bootstrap.x86 ! Load ds and rs registers jit-load-vm + jit-load-context jit-restore-context ! Call quotation @@ -140,6 +140,7 @@ IN: bootstrap.x86 [ jit-load-vm + jit-load-context jit-save-context ! Store arguments @@ -161,6 +162,7 @@ IN: bootstrap.x86 ! frame, and the stack. The frame setup takes this into account. : jit-inline-cache-miss ( -- ) jit-load-vm + jit-load-context jit-save-context ESP 4 [+] vm-reg MOV ESP [] EBX MOV @@ -181,17 +183,18 @@ IN: bootstrap.x86 : jit-overflow ( insn func -- ) ds-reg 4 SUB jit-load-vm + jit-load-context jit-save-context EAX ds-reg [] MOV EDX ds-reg 4 [+] MOV - ECX EAX MOV - [ [ ECX EDX ] dip call( dst src -- ) ] dip - ds-reg [] ECX MOV + EBX EAX MOV + [ [ EBX EDX ] dip call( dst src -- ) ] dip + ds-reg [] EBX MOV [ JNO ] [ ESP [] EAX MOV ESP 4 [+] EDX MOV - ESP 8 [+] EBP MOV + ESP 8 [+] vm-reg MOV [ 0 CALL ] dip f rc-relative jit-dlsym ] jit-conditional ; @@ -203,19 +206,20 @@ IN: bootstrap.x86 [ ds-reg 4 SUB jit-load-vm + jit-load-context jit-save-context - ECX ds-reg [] MOV - EAX ECX MOV - EBX ds-reg 4 [+] MOV - EBX tag-bits get SAR - EBX IMUL + EBX ds-reg [] MOV + EAX EBX MOV + EBP ds-reg 4 [+] MOV + EBP tag-bits get SAR + EBP IMUL ds-reg [] EAX MOV [ JNO ] [ - ECX tag-bits get SAR - ESP [] ECX MOV - ESP 4 [+] EBX MOV - ESP 8 [+] EBP MOV + EBX tag-bits get SAR + ESP [] EBX MOV + ESP 4 [+] EBP MOV + ESP 8 [+] vm-reg MOV 0 CALL "overflow_fixnum_multiply" f rc-relative jit-dlsym ] jit-conditional diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor index 2248567394..676c96ce50 100644 --- a/basis/cpu/x86/64/64.factor +++ b/basis/cpu/x86/64/64.factor @@ -7,7 +7,8 @@ compiler.codegen compiler.codegen.fixup compiler.cfg.instructions compiler.cfg.builder compiler.cfg.intrinsics compiler.cfg.stack-frame cpu.x86.assembler cpu.x86.assembler.operands cpu.x86 -cpu.architecture ; +cpu.architecture vm ; +FROM: layouts => cell cells ; IN: cpu.x86.64 : param-reg-0 ( -- reg ) 0 int-regs param-reg ; inline @@ -29,13 +30,21 @@ M: x86.64 extra-stack-space drop 0 ; M: x86.64 machine-registers { - { int-regs { RAX RCX RDX RBX RBP RSI RDI R8 R9 R10 R11 R12 R13 } } + { int-regs { RAX RCX RDX RBX RBP RSI RDI R8 R9 R10 R11 R12 } } { float-regs { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 XMM8 XMM9 XMM10 XMM11 XMM12 XMM13 XMM14 XMM15 } } } ; +: vm-reg ( -- reg ) R13 ; inline + +M: x86.64 %mov-vm-ptr ( reg -- ) + vm-reg MOV ; + +M: x86.64 %vm-field-ptr ( dst field -- ) + [ vm-reg ] dip vm-field-offset [+] LEA ; + : param@ ( n -- op ) reserved-stack-space + stack@ ; M: x86.64 %prologue ( n -- ) diff --git a/basis/cpu/x86/64/bootstrap.factor b/basis/cpu/x86/64/bootstrap.factor index f47eb7eb70..3c324ce95d 100644 --- a/basis/cpu/x86/64/bootstrap.factor +++ b/basis/cpu/x86/64/bootstrap.factor @@ -19,8 +19,8 @@ IN: bootstrap.x86 : safe-reg ( -- reg ) RAX ; : stack-reg ( -- reg ) RSP ; : frame-reg ( -- reg ) RBP ; -: vm-reg ( -- reg ) R12 ; -: ctx-reg ( -- reg ) R13 ; +: ctx-reg ( -- reg ) R12 ; +: vm-reg ( -- reg ) R13 ; : ds-reg ( -- reg ) R14 ; : rs-reg ( -- reg ) R15 ; : fixnum>slot@ ( -- ) temp0 1 SAR ; @@ -37,11 +37,7 @@ IN: bootstrap.x86 RSP stack-frame-size 3 bootstrap-cells - SUB ] jit-prolog jit-define -: jit-load-vm ( -- ) - vm-reg 0 MOV 0 rc-absolute-cell jit-vm ; - : jit-load-context ( -- ) - ! VM pointer must be in vm-reg already ctx-reg vm-reg vm-context-offset [+] MOV ; : jit-save-context ( -- ) @@ -57,7 +53,6 @@ IN: bootstrap.x86 rs-reg ctx-reg context-retainstack-offset [+] MOV ; [ - jit-load-vm jit-save-context ! call the primitive arg1 vm-reg MOV @@ -67,14 +62,12 @@ IN: bootstrap.x86 ] jit-primitive jit-define [ - jit-load-vm jit-restore-context ! save ctx->callstack_bottom safe-reg stack-reg stack-frame-size 8 - [+] LEA ctx-reg context-callstack-bottom-offset [+] safe-reg MOV ! call the quotation arg1 quot-xt-offset [+] CALL - jit-load-vm jit-save-context ] \ c-to-factor define-sub-primitive @@ -97,7 +90,6 @@ IN: bootstrap.x86 RSP arg2 MOV ! Load ds and rs registers - jit-load-vm jit-restore-context ! Call quotation @@ -109,7 +101,6 @@ IN: bootstrap.x86 arg4 ds-reg [] MOV ds-reg bootstrap-cell SUB ! Get ctx->callstack_bottom - jit-load-vm jit-load-context arg1 ctx-reg context-callstack-bottom-offset [+] MOV ! Get top of callstack object -- 'src' for memcpy @@ -133,7 +124,6 @@ IN: bootstrap.x86 ] \ set-callstack define-sub-primitive [ - jit-load-vm jit-save-context arg2 vm-reg MOV safe-reg 0 MOV "lazy_jit_compile" f rc-absolute-cell jit-dlsym @@ -150,7 +140,6 @@ IN: bootstrap.x86 ! These are always in tail position with an existing stack ! frame, and the stack. The frame setup takes this into account. : jit-inline-cache-miss ( -- ) - jit-load-vm jit-save-context arg1 RBX MOV arg2 vm-reg MOV @@ -171,7 +160,6 @@ IN: bootstrap.x86 ! Overflowing fixnum arithmetic : jit-overflow ( insn func -- ) ds-reg 8 SUB - jit-load-vm jit-save-context arg1 ds-reg [] MOV arg2 ds-reg 8 [+] MOV @@ -192,7 +180,6 @@ IN: bootstrap.x86 [ ds-reg 8 SUB - jit-load-vm jit-save-context RCX ds-reg [] MOV RBX ds-reg 8 [+] MOV diff --git a/basis/cpu/x86/bootstrap.factor b/basis/cpu/x86/bootstrap.factor index 1373169211..96d21972d5 100644 --- a/basis/cpu/x86/bootstrap.factor +++ b/basis/cpu/x86/bootstrap.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2007, 2009 Slava Pestov. +! Copyright (C) 2007, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: bootstrap.image.private compiler.constants compiler.units cpu.x86.assembler cpu.x86.assembler.operands @@ -30,6 +30,9 @@ big-endian off ! hurt on other platforms stack-reg 32 SUB + ! Load VM into vm-reg + vm-reg 0 MOV rc-absolute-cell rt-vm jit-rel + ! Call into Factor code safe-reg 0 MOV rc-absolute-cell rt-xt jit-rel safe-reg CALL diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index 46123c9e23..f2751b1be2 100644 --- a/basis/cpu/x86/x86.factor +++ b/basis/cpu/x86/x86.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2005, 2009 Slava Pestov. +! Copyright (C) 2005, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs alien alien.c-types arrays strings cpu.x86.assembler cpu.x86.assembler.private cpu.x86.assembler.operands @@ -419,11 +419,7 @@ M: x86 %shl int-rep two-operand [ SHL ] emit-shift ; M: x86 %shr int-rep two-operand [ SHR ] emit-shift ; M: x86 %sar int-rep two-operand [ SAR ] emit-shift ; -: %mov-vm-ptr ( reg -- ) - 0 MOV 0 rc-absolute-cell rel-vm ; - -M: x86 %vm-field-ptr ( dst field -- ) - [ 0 MOV ] dip vm-field-offset rc-absolute-cell rel-vm ; +HOOK: %mov-vm-ptr cpu ( reg -- ) : load-allot-ptr ( nursery-ptr allot-ptr -- ) [ drop "nursery" %vm-field-ptr ] [ swap [] MOV ] 2bi ; diff --git a/vm/callbacks.cpp b/vm/callbacks.cpp index 061c42927d..ebb66bae12 100644 --- a/vm/callbacks.cpp +++ b/vm/callbacks.cpp @@ -19,13 +19,13 @@ void factor_vm::init_callbacks(cell size) callbacks = new callback_heap(size,this); } -void callback_heap::update(code_block *stub) +void callback_heap::store_callback_operand(code_block *stub, cell index, cell value) { tagged code_template(parent->special_objects[CALLBACK_STUB]); - cell rel_class = untag_fixnum(array_nth(code_template.untagged(),1)); - cell rel_type = untag_fixnum(array_nth(code_template.untagged(),2)); - cell offset = untag_fixnum(array_nth(code_template.untagged(),3)); + cell rel_class = untag_fixnum(array_nth(code_template.untagged(),3 * index + 1)); + cell rel_type = untag_fixnum(array_nth(code_template.untagged(),3 * index + 2)); + cell offset = untag_fixnum(array_nth(code_template.untagged(),3 * index + 3)); relocation_entry rel( (relocation_type)rel_type, @@ -33,8 +33,12 @@ void callback_heap::update(code_block *stub) offset); instruction_operand op(rel,stub,0); - op.store_value((cell)callback_xt(stub)); + op.store_value(value); +} +void callback_heap::update(code_block *stub) +{ + store_callback_operand(stub,1,(cell)callback_xt(stub)); stub->flush_icache(); } @@ -58,22 +62,14 @@ code_block *callback_heap::add(cell owner, cell return_rewind) memcpy(stub->xt(),insns->data(),size); + /* Store VM pointer */ + store_callback_operand(stub,0,(cell)parent); + /* On x86, the RET instruction takes an argument which depends on the callback's calling convention */ - if(array_capacity(code_template.untagged()) == 7) - { - cell rel_class = untag_fixnum(array_nth(code_template.untagged(),4)); - cell rel_type = untag_fixnum(array_nth(code_template.untagged(),5)); - cell offset = untag_fixnum(array_nth(code_template.untagged(),6)); - - relocation_entry rel( - (relocation_type)rel_type, - (relocation_class)rel_class, - offset); - - instruction_operand op(rel,stub,0); - op.store_value(return_rewind); - } +#if defined(FACTOR_X86) || defined(FACTOR_AMD64) + store_callback_operand(stub,2,return_rewind); +#endif update(stub); diff --git a/vm/callbacks.hpp b/vm/callbacks.hpp index 136d9b82b4..0bed3f406d 100644 --- a/vm/callbacks.hpp +++ b/vm/callbacks.hpp @@ -38,7 +38,10 @@ struct callback_heap { return w->xt; } + void store_callback_operand(code_block *stub, cell index, cell value); + void update(code_block *stub); + code_block *add(cell owner, cell return_rewind); void update(); diff --git a/vm/quotations.cpp b/vm/quotations.cpp index c33f9b5d6f..e4836fe96b 100755 --- a/vm/quotations.cpp +++ b/vm/quotations.cpp @@ -182,10 +182,10 @@ void quotation_jit::iterate_quotation() /* Primitive calls */ if(primitive_call_p(i,length)) { - /* On PowerPC, the VM pointer is stored as a register; on other - platforms, the RT_VM relocation is used and it needs an offset - parameter */ -#ifndef FACTOR_PPC + /* On x86-64 and PowerPC, the VM pointer is stored in + a register; on other platforms, the RT_VM relocation + is used and it needs an offset parameter */ +#ifdef FACTOR_X86 parameter(tag_fixnum(0)); #endif parameter(obj.value()); From 397dab18da62594a5e36297d068d4014ebee5d29 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Sun, 27 Dec 2009 13:29:24 +0100 Subject: [PATCH 32/72] added filter-fields word which sets the returnfields slot in the current query object --- extra/mongodb/driver/driver.factor | 3 +++ 1 file changed, 3 insertions(+) diff --git a/extra/mongodb/driver/driver.factor b/extra/mongodb/driver/driver.factor index 294672523c..e1bf4f6746 100644 --- a/extra/mongodb/driver/driver.factor +++ b/extra/mongodb/driver/driver.factor @@ -193,6 +193,9 @@ M: mdb-query-msg skip : sort ( mdb-query-msg sort-quot -- mdb-query-msg ) output>array [ 1array >hashtable ] map >>orderby ; inline +: filter-fields ( mdb-query-msg filterseq -- mdb-query-msg ) + [ asc ] map >hashtable >>returnfields ; inline + : key-spec ( spec-quot -- spec-assoc ) output>array >hashtable ; inline From 887126fbf8c085698094c15a45db60def18006d9 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Wed, 25 Nov 2009 09:37:50 +0100 Subject: [PATCH 33/72] fixed result calculation; added ops/s value --- extra/mongodb/benchmark/benchmark.factor | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/extra/mongodb/benchmark/benchmark.factor b/extra/mongodb/benchmark/benchmark.factor index ad8c501605..399b5c4e8c 100644 --- a/extra/mongodb/benchmark/benchmark.factor +++ b/extra/mongodb/benchmark/benchmark.factor @@ -224,15 +224,15 @@ CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" } [ index>> bchar ] keep lasterror>> bchar trial-size ] dip - 1000000 / /i - "%-18s: {batch:%s,index:%s;errchk:%s} %10s docs/s" + 1000000000 / [ /i ] [ result get batch>> [ [ batch-size /i ] dip ] when /i ] 2bi + "%-18s: {batch:%s,index:%s;errchk:%s} %10s docs/s %10s ops/s" sprintf print flush ; : print-separator ( -- ) - "----------------------------------------------------------------" print flush ; inline + "---------------------------------------------------------------------------------" print flush ; inline : print-separator-bold ( -- ) - "================================================================" print flush ; inline + "=================================================================================" print flush ; inline : print-header ( -- ) trial-size From fccaee0fd4ff83d141ede89ca237499304f48eff Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Wed, 6 Jan 2010 15:56:38 +0100 Subject: [PATCH 34/72] removed generic words; added kill-cursor + filter-fields words --- extra/mongodb/driver/driver.factor | 50 ++++++++-------------- extra/mongodb/msg/msg.factor | 2 +- extra/mongodb/operations/operations.factor | 2 +- 3 files changed, 19 insertions(+), 35 deletions(-) diff --git a/extra/mongodb/driver/driver.factor b/extra/mongodb/driver/driver.factor index e1bf4f6746..78d0b62734 100644 --- a/extra/mongodb/driver/driver.factor +++ b/extra/mongodb/driver/driver.factor @@ -165,9 +165,7 @@ M: mdb-collection create-collection : fix-query-collection ( mdb-query -- mdb-query ) [ check-collection ] change-collection ; inline -GENERIC: get-more ( mdb-cursor -- mdb-cursor seq ) - -M: mdb-cursor get-more +: get-more ( mdb-cursor -- mdb-cursor seq ) [ [ query>> dup [ collection>> ] [ return#>> ] bi ] [ id>> ] bi swap >>query send-query ] [ f f ] if* ; @@ -177,21 +175,17 @@ PRIVATE> : ( collection assoc -- mdb-query-msg ) ; inline -GENERIC# limit 1 ( mdb-query-msg limit# -- mdb-query-msg ) - -M: mdb-query-msg limit +: limit ( mdb-query-msg limit# -- mdb-query-msg ) >>return# ; inline -GENERIC# skip 1 ( mdb-query-msg skip# -- mdb-query-msg ) - -M: mdb-query-msg skip +: skip ( mdb-query-msg skip# -- mdb-query-msg ) >>skip# ; inline : asc ( key -- spec ) 1 2array ; inline : desc ( key -- spec ) -1 2array ; inline : sort ( mdb-query-msg sort-quot -- mdb-query-msg ) - output>array [ 1array >hashtable ] map >>orderby ; inline + output>array >hashtable >>orderby ; inline : filter-fields ( mdb-query-msg filterseq -- mdb-query-msg ) [ asc ] map >hashtable >>returnfields ; inline @@ -212,21 +206,15 @@ M: mdb-query-msg find M: mdb-cursor find get-more ; -GENERIC: explain. ( mdb-query-msg -- ) - -M: mdb-query-msg explain. +: explain. ( mdb-query-msg -- ) t >>explain find nip . ; -GENERIC: find-one ( mdb-query-msg -- result/f ) - -M: mdb-query-msg find-one +: find-one ( mdb-query-msg -- result/f ) fix-query-collection 1 >>return# send-query-plain objects>> dup empty? [ drop f ] [ first ] if ; -GENERIC: count ( mdb-query-msg -- result ) - -M: mdb-query-msg count +: count ( mdb-query-msg -- result ) [ collection>> "count" H{ } clone [ set-at ] keep ] keep query>> [ over [ "query" ] dip set-at ] when* [ cmd-collection ] dip find-one @@ -254,18 +242,15 @@ M: mdb-collection validate. PRIVATE> -GENERIC: save ( collection assoc -- ) -M: assoc save +: save ( collection assoc -- ) [ check-collection ] dip send-message-check-error ; -GENERIC: save-unsafe ( collection assoc -- ) -M: assoc save-unsafe +: save-unsafe ( collection assoc -- ) [ check-collection ] dip send-message ; -GENERIC: ensure-index ( index-spec -- ) -M: index-spec ensure-index +: ensure-index ( index-spec -- ) [ [ uuid1 "_id" ] dip set-at ] keep [ { [ [ name>> "name" ] dip set-at ] [ [ ns>> index-ns "ns" ] dip set-at ] @@ -288,24 +273,23 @@ M: index-spec ensure-index : >upsert ( mdb-update-msg -- mdb-update-msg ) 1 >>upsert? ; -GENERIC: update ( mdb-update-msg -- ) -M: mdb-update-msg update +: update ( mdb-update-msg -- ) send-message-check-error ; -GENERIC: update-unsafe ( mdb-update-msg -- ) -M: mdb-update-msg update-unsafe +: update-unsafe ( mdb-update-msg -- ) send-message ; -GENERIC: delete ( collection selector -- ) -M: assoc delete +: delete ( collection selector -- ) [ check-collection ] dip send-message-check-error ; -GENERIC: delete-unsafe ( collection selector -- ) -M: assoc delete-unsafe +: delete-unsafe ( collection selector -- ) [ check-collection ] dip send-message ; +: kill-cursor ( mdb-cursor -- ) + id>> send-message ; + : load-index-list ( -- index-list ) index-collection H{ } clone find nip ; diff --git a/extra/mongodb/msg/msg.factor b/extra/mongodb/msg/msg.factor index c486346795..ada0ab42d0 100644 --- a/extra/mongodb/msg/msg.factor +++ b/extra/mongodb/msg/msg.factor @@ -29,7 +29,7 @@ TUPLE: mdb-query-msg < mdb-msg { return# integer initial: 0 } { query assoc } { returnfields assoc } -{ orderby sequence } +{ orderby assoc } explain hint ; TUPLE: mdb-insert-msg < mdb-msg diff --git a/extra/mongodb/operations/operations.factor b/extra/mongodb/operations/operations.factor index 7e99c52aac..108f610940 100644 --- a/extra/mongodb/operations/operations.factor +++ b/extra/mongodb/operations/operations.factor @@ -107,7 +107,7 @@ USE: tools.walker :: build-query-object ( query -- selector ) H{ } clone :> selector - query { [ orderby>> [ "orderby" selector set-at ] when* ] + query { [ orderby>> [ "$orderby" selector set-at ] when* ] [ explain>> [ "$explain" selector set-at ] when* ] [ hint>> [ "$hint" selector set-at ] when* ] [ query>> "query" selector set-at ] From e7b797af080ea4c1fc0b237849678dd2e74f354a Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Thu, 7 Jan 2010 08:31:32 +0100 Subject: [PATCH 35/72] added mongodb connection pool responder --- extra/furnace/mongodb/mongodb.factor | 12 ++++++++++++ 1 file changed, 12 insertions(+) create mode 100644 extra/furnace/mongodb/mongodb.factor diff --git a/extra/furnace/mongodb/mongodb.factor b/extra/furnace/mongodb/mongodb.factor new file mode 100644 index 0000000000..a3af4191ee --- /dev/null +++ b/extra/furnace/mongodb/mongodb.factor @@ -0,0 +1,12 @@ +USING: accessors http.server http.server.filters io.pools kernel +mongodb.driver mongodb.connection namespaces unix destructors continuations ; + +IN: furnace.mongodb + +TUPLE: mdb-persistence < filter-responder pool ; + +: ( responder mdb -- responder' ) + mdb-persistence boa ; + +M: mdb-persistence call-responder* + dup pool>> [ mdb-connection set call-next-method ] with-pooled-connection ; From 640198329b9403abb4e3360c088ced2284a213ce Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Sun, 10 Jan 2010 12:04:16 +0100 Subject: [PATCH 36/72] some minor bson performance improvements --- extra/bson/reader/reader.factor | 50 +++++++++++++-------------------- extra/bson/writer/writer.factor | 12 ++++---- 2 files changed, 25 insertions(+), 37 deletions(-) diff --git a/extra/bson/reader/reader.factor b/extra/bson/reader/reader.factor index e6ae0060b6..51aa5f3817 100644 --- a/extra/bson/reader/reader.factor +++ b/extra/bson/reader/reader.factor @@ -1,6 +1,6 @@ USING: accessors assocs bson.constants calendar fry io io.binary io.encodings io.encodings.utf8 kernel math math.bitwise namespaces -sequences serialize ; +sequences serialize locals ; FROM: kernel.private => declare ; FROM: io.encodings.private => (read-until) ; @@ -62,22 +62,17 @@ GENERIC: element-binary-read ( length type -- object ) : read-byte ( -- byte ) read-byte-raw first ; inline -: utf8-read-until ( seps stream encoding -- string/f sep/f ) - [ { utf8 } declare decode-char dup [ dup rot member? ] [ 2drop f t ] if ] - 3curry (read-until) ; - : read-cstring ( -- string ) - "\0" input-stream get utf8 utf8-read-until drop ; inline + "\0" read-until drop "" like ; inline : read-sized-string ( length -- string ) - drop read-cstring ; inline + read 1 head-slice* "" like ; inline : read-element-type ( -- type ) read-byte ; inline -: push-element ( type name -- element ) - element boa - [ get-state element>> push ] keep ; inline +: push-element ( type name -- ) + element boa get-state element>> push ; inline : pop-element ( -- element ) get-state element>> pop ; inline @@ -96,8 +91,7 @@ M: bson-object fix-result ( assoc type -- result ) drop ; M: bson-array fix-result ( assoc type -- result ) - drop - values ; + drop values ; GENERIC: end-element ( type -- ) @@ -108,25 +102,20 @@ M: bson-array end-element ( type -- ) drop ; M: object end-element ( type -- ) - drop - pop-element drop ; + pop-element 2drop ; -M: bson-eoo element-read ( type -- cont? ) - drop - get-state scope>> [ pop ] keep swap ! vec assoc - pop-element [ type>> ] keep ! vec assoc element - [ fix-result ] dip - rot length 0 > ! assoc element - [ name>> peek-scope set-at t ] - [ drop [ get-state ] dip >>result drop f ] if ; +M:: bson-eoo element-read ( type -- cont? ) + pop-element :> element + get-state scope>> + [ pop element type>> fix-result ] [ empty? ] bi + [ [ get-state ] dip >>result drop f ] + [ element name>> peek-scope set-at t ] if ; -M: bson-not-eoo element-read ( type -- cont? ) - [ peek-scope ] dip ! scope type - '[ _ read-cstring push-element [ name>> ] [ type>> ] bi - [ element-data-read ] keep - end-element - swap - ] dip set-at t ; +M:: bson-not-eoo element-read ( type -- cont? ) + peek-scope :> scope + type read-cstring [ push-element ] 2keep + [ [ element-data-read ] [ end-element ] bi ] + [ scope set-at t ] bi* ; : [scope-changer] ( state -- state quot ) dup exemplar>> '[ [ [ _ clone ] dip push ] keep ] ; inline @@ -173,8 +162,7 @@ M: bson-regexp element-data-read ( type -- mdbregexp ) read-cstring >>regexp read-cstring >>options ; M: bson-null element-data-read ( type -- bf ) - drop - f ; + drop f ; M: bson-oid element-data-read ( type -- oid ) drop diff --git a/extra/bson/writer/writer.factor b/extra/bson/writer/writer.factor index f9bd0eb392..a070579943 100644 --- a/extra/bson/writer/writer.factor +++ b/extra/bson/writer/writer.factor @@ -73,11 +73,9 @@ M: word bson-type? ( word -- type ) drop T_Binary ; M: quotation bson-type? ( quotation -- type ) drop T_Binary ; M: byte-array bson-type? ( byte-array -- type ) drop T_Binary ; -: write-utf8-string ( string -- ) output-stream get '[ _ swap char>utf8 ] each ; inline - : write-int32 ( int -- ) INT32-SIZE >le write ; inline : write-double ( real -- ) double>bits INT64-SIZE >le write ; inline -: write-cstring ( string -- ) write-utf8-string 0 write1 ; inline +: write-cstring ( string -- ) B{ } like write 0 write1 ; inline : write-longlong ( object -- ) INT64-SIZE >le write ; inline : write-eoo ( -- ) T_EOO write1 ; inline @@ -127,9 +125,11 @@ M: sequence bson-write ( array -- ) { $[ MDB_OID_FIELD MDB_META_FIELD ] } member? ; inline M: assoc bson-write ( assoc -- ) - '[ _ [ write-oid ] keep - [ over skip-field? [ 2drop ] [ write-pair ] if ] assoc-each - write-eoo ] with-length-prefix ; + '[ + _ [ write-oid ] keep + [ over skip-field? [ 2drop ] [ write-pair ] if ] assoc-each + write-eoo + ] with-length-prefix ; : (serialize-code) ( code -- ) object>bytes [ length write-int32 ] keep From 87f6efc8ec02e91e4d82be01a2a26f3df01fe2fc Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 11 Jan 2010 14:15:41 +1300 Subject: [PATCH 37/72] cpu.ppc: fix some typos in non-optimizing backend --- basis/cpu/ppc/bootstrap.factor | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/basis/cpu/ppc/bootstrap.factor b/basis/cpu/ppc/bootstrap.factor index ba2b404a06..a40df575ea 100644 --- a/basis/cpu/ppc/bootstrap.factor +++ b/basis/cpu/ppc/bootstrap.factor @@ -64,7 +64,7 @@ CONSTANT: ctx-reg 16 nv-fp-regs [ 8 * 80 + save-fp ] each-index nv-vec-regs [ 16 * 224 + save-vec ] each-index - 0 vm-reg LOAD32 rt-vm rc-absolute-ppc-2/2 jit-rel + 0 vm-reg LOAD32 rc-absolute-ppc-2/2 rt-vm jit-rel 0 2 LOAD32 rc-absolute-ppc-2/2 rt-xt jit-rel 2 MTLR @@ -88,7 +88,7 @@ CONSTANT: ctx-reg 16 : jit-save-context ( -- ) jit-load-context - 1 2 context-callstack-top-offset STW + 1 ctx-reg context-callstack-top-offset STW ds-reg ctx-reg context-datastack-offset STW rs-reg ctx-reg context-retainstack-offset STW ; @@ -109,12 +109,12 @@ CONSTANT: ctx-reg 16 ] jit-profiling jit-define [ - 0 3 LOAD32 rc-absolute-ppc-2/2 rt-this jit-rel + 0 2 LOAD32 rc-absolute-ppc-2/2 rt-this jit-rel 0 MFLR 1 1 stack-frame SUBI - 3 1 xt-save STW - stack-frame 3 LI - 3 1 next-save STW + 2 1 xt-save STW + stack-frame 2 LI + 2 1 next-save STW 0 1 lr-save stack-frame + STW ] jit-prolog jit-define @@ -384,7 +384,7 @@ CONSTANT: ctx-reg 16 5 6 callstack-length-offset LWZ 5 5 tag-bits get SRAWI ! Compute new stack pointer -- 'dst' for memcpy - 3 3 5 SUBF + 3 5 3 SUBF ! Install new stack pointer 1 3 MR ! Call memcpy; arguments are now in the correct registers @@ -394,7 +394,7 @@ CONSTANT: ctx-reg 16 BLRL 1 1 0 LWZ ! Return with new callstack - 0 1 lr-save stack-frame + LWZ + 0 1 lr-save LWZ 0 MTLR BLR ] \ set-callstack define-sub-primitive @@ -402,7 +402,7 @@ CONSTANT: ctx-reg 16 [ jit-save-context 4 vm-reg MR - 2 0 LOAD32 "lazy_jit_compile" f rc-absolute-ppc-2/2 jit-dlsym + 0 2 LOAD32 "lazy_jit_compile" f rc-absolute-ppc-2/2 jit-dlsym 2 MTLR BLRL 5 3 quot-xt-offset LWZ From 782d91f927c5738aac52fb6337f3e4409997cd9a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 10 Jan 2010 22:42:26 -0600 Subject: [PATCH 38/72] Use the bash path instead of /bin/sh for running a bash script --- build-support/factor.sh | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/build-support/factor.sh b/build-support/factor.sh index d090433d98..2f8745aeef 100755 --- a/build-support/factor.sh +++ b/build-support/factor.sh @@ -347,8 +347,8 @@ update_script_name() { update_script() { update_script=`update_script_name` - - echo "#!/bin/sh" >"$update_script" + bash_path=`which bash` + echo "#!$bash_path" >"$update_script" echo "git pull \"$GIT_URL\" master" >>"$update_script" echo "if [[ \$? -eq 0 ]]; then exec \"$0\" $SCRIPT_ARGS; else echo \"git pull failed\"; exit 2; fi" \ >>"$update_script" From 85a45d63d97affa399c4afcd1dea75b37e221282 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 12 Jan 2010 16:31:10 +1300 Subject: [PATCH 39/72] unwind-stack-frames didn't load VM pointer into the VM register on PowerPC and x86-64, and so if C code had clobbered this register it would crash --- basis/cpu/ppc/bootstrap.factor | 4 ++++ basis/cpu/x86/64/bootstrap.factor | 4 ++++ 2 files changed, 8 insertions(+) diff --git a/basis/cpu/ppc/bootstrap.factor b/basis/cpu/ppc/bootstrap.factor index a40df575ea..69b6939cda 100644 --- a/basis/cpu/ppc/bootstrap.factor +++ b/basis/cpu/ppc/bootstrap.factor @@ -358,6 +358,10 @@ CONSTANT: ctx-reg 16 ! Unwind stack frames 1 4 MR + ! Load VM pointer into vm-reg, since we're entering from + ! C code + 0 vm-reg LOAD32 0 rc-absolute-ppc-2/2 jit-vm + ! Load ds and rs registers jit-restore-context diff --git a/basis/cpu/x86/64/bootstrap.factor b/basis/cpu/x86/64/bootstrap.factor index 3c324ce95d..74943a94bb 100644 --- a/basis/cpu/x86/64/bootstrap.factor +++ b/basis/cpu/x86/64/bootstrap.factor @@ -89,6 +89,10 @@ IN: bootstrap.x86 ! Unwind stack frames RSP arg2 MOV + ! Load VM pointer into vm-reg, since we're entering from + ! C code + vm-reg 0 MOV 0 rc-absolute-cell jit-vm + ! Load ds and rs registers jit-restore-context From 988c8d06016f703e99e932701532614df4d8c0d5 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 13 Jan 2010 03:09:43 +1300 Subject: [PATCH 40/72] More PowerPC non-optimizing compiler backend fixes --- basis/compiler/tests/alien.factor | 4 +--- basis/cpu/ppc/bootstrap.factor | 6 +++--- 2 files changed, 4 insertions(+), 6 deletions(-) diff --git a/basis/compiler/tests/alien.factor b/basis/compiler/tests/alien.factor index cb39c0dd16..5e49e2d28d 100644 --- a/basis/compiler/tests/alien.factor +++ b/basis/compiler/tests/alien.factor @@ -377,9 +377,7 @@ FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ; [ f ] [ namespace global eq? ] unit-test : callback-8 ( -- callback ) - void { } "cdecl" [ - [ continue ] callcc0 - ] alien-callback ; + void { } "cdecl" [ [ ] in-thread yield ] alien-callback ; [ ] [ callback-8 callback_test_1 ] unit-test diff --git a/basis/cpu/ppc/bootstrap.factor b/basis/cpu/ppc/bootstrap.factor index 69b6939cda..e3c212bd48 100644 --- a/basis/cpu/ppc/bootstrap.factor +++ b/basis/cpu/ppc/bootstrap.factor @@ -60,7 +60,7 @@ CONSTANT: ctx-reg 16 1 1 callback-frame-size neg STWU 0 1 callback-frame-size lr-save + STW - nv-int-regs [ cells save-int ] each-index + nv-int-regs [ 4 * save-int ] each-index nv-fp-regs [ 8 * 80 + save-fp ] each-index nv-vec-regs [ 16 * 224 + save-vec ] each-index @@ -72,7 +72,7 @@ CONSTANT: ctx-reg 16 nv-vec-regs [ 16 * 224 + restore-vec ] each-index nv-fp-regs [ 8 * 80 + restore-fp ] each-index - nv-int-regs [ cells restore-int ] each-index + nv-int-regs [ 4 * restore-int ] each-index 0 1 callback-frame-size lr-save + LWZ 1 1 0 LWZ @@ -366,7 +366,7 @@ CONSTANT: ctx-reg 16 jit-restore-context ! We have changed the stack; load return address again - 0 1 stack-frame lr-save + LWZ + 0 1 lr-save LWZ 0 MTLR ! Call quotation From 7bf76b9f139fbd09445d7cfba37cbbee137ff4e4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 12 Jan 2010 08:02:10 -0600 Subject: [PATCH 41/72] PowerPC optimizing compiler backend fixes --- basis/cpu/ppc/ppc.factor | 43 ++++++++++++++++++++++--------------- vm/cpu-ppc.hpp | 14 ++---------- vm/instruction_operands.cpp | 8 +++---- 3 files changed, 32 insertions(+), 33 deletions(-) diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index d641ed7039..4842327973 100644 --- a/basis/cpu/ppc/ppc.factor +++ b/basis/cpu/ppc/ppc.factor @@ -83,8 +83,8 @@ HOOK: reserved-area-size os ( -- n ) ! The start of the stack frame contains the size of this frame ! as well as the currently executing XT : factor-area-size ( -- n ) 2 cells ; foldable -: next-save ( n -- i ) cell - ; -: xt-save ( n -- i ) 2 cells - ; +: next-save ( n -- i ) cell - ; foldable +: xt-save ( n -- i ) 2 cells - ; foldable ! Next, we have the spill area as well as the FFI parameter area. ! It is safe for them to overlap, since basic blocks with FFI calls @@ -126,7 +126,7 @@ M: ppc stack-frame-size ( stack-frame -- i ) M: ppc %call ( word -- ) 0 BL rc-relative-ppc-3 rel-word-pic ; M: ppc %jump ( word -- ) - 0 6 LOAD32 8 rc-absolute-ppc-2/2 rel-here + 0 6 LOAD32 4 rc-absolute-ppc-2/2 rel-here 0 B rc-relative-ppc-3 rel-word-pic-tail ; M: ppc %jump-label ( label -- ) B ; @@ -134,7 +134,7 @@ M: ppc %return ( -- ) BLR ; M:: ppc %dispatch ( src temp -- ) 0 temp LOAD32 - 4 cells rc-absolute-ppc-2/2 rel-here + 3 cells rc-absolute-ppc-2/2 rel-here temp temp src LWZX temp MTCTR BCTR ; @@ -564,14 +564,16 @@ M:: ppc %compare-float-unordered-branch ( label src1 src2 cc -- ) { stack-params [ [ 0 1 ] dip LWZ [ 0 1 ] dip param@ STW ] } } case ; -: next-param@ ( n -- x ) param@ stack-frame get total-size>> + ; +: next-param@ ( n -- reg x ) + 2 1 stack-frame get total-size>> LWZ + [ 2 ] dip param@ ; : store-to-frame ( src n rep -- ) { { int-rep [ [ 1 ] dip STW ] } { float-rep [ [ 1 ] dip STFS ] } { double-rep [ [ 1 ] dip STFD ] } - { stack-params [ [ [ 0 1 ] dip next-param@ LWZ 0 1 ] dip STW ] } + { stack-params [ [ [ 0 ] dip next-param@ LWZ 0 1 ] dip STW ] } } case ; M: ppc %spill ( src rep dst -- ) @@ -679,10 +681,15 @@ M: ppc %box-large-struct ( n c-type -- ) ! Call the function "from_value_struct" f %alien-invoke ; +M:: ppc %restore-context ( temp1 temp2 -- ) + temp1 "ctx" %load-vm-field-addr + temp1 temp1 0 LWZ + temp2 1 stack-frame get total-size>> ADDI + temp2 temp1 "callstack-bottom" context-field-offset STW + ds-reg temp1 8 LWZ + rs-reg temp1 12 LWZ ; + M:: ppc %save-context ( temp1 temp2 -- ) - #! Save Factor stack pointers in case the C code calls a - #! callback which does a GC, which must reliably trace - #! all roots. temp1 "ctx" %load-vm-field-addr temp1 temp1 0 LWZ 1 temp1 0 STW @@ -693,13 +700,18 @@ M: ppc %alien-invoke ( symbol dll -- ) [ 11 ] 2dip %alien-global 11 MTLR BLRL ; M: ppc %alien-callback ( quot -- ) + 3 4 %restore-context 3 swap %load-reference - 4 %load-vm-addr - "c_to_factor" f %alien-invoke ; + 4 3 quot-xt-offset LWZ + 4 MTLR + BLRL + 3 4 %save-context ; M: ppc %prepare-alien-indirect ( -- ) - 3 %load-vm-addr - "from_alien" f %alien-invoke + 3 ds-reg 0 LWZ + ds-reg ds-reg 4 SUBI + 4 %load-vm-addr + "pinned_alien_offset" f %alien-invoke 16 3 MR ; M: ppc %alien-indirect ( -- ) @@ -753,9 +765,7 @@ M: ppc %box-small-struct ( c-type -- ) 3 3 0 LWZ ; M: ppc %nest-stacks ( -- ) - ! Save current frame. See comment in vm/contexts.hpp - 3 1 stack-frame get total-size>> 2 cells - ADDI - 4 %load-vm-addr + 3 %load-vm-addr "nest_stacks" f %alien-invoke ; M: ppc %unnest-stacks ( -- ) @@ -763,7 +773,6 @@ M: ppc %unnest-stacks ( -- ) "unnest_stacks" f %alien-invoke ; M: ppc %unbox-small-struct ( size -- ) - #! Alien must be in EAX. heap-size cell align cell /i { { 1 [ %unbox-struct-1 ] } { 2 [ %unbox-struct-2 ] } diff --git a/vm/cpu-ppc.hpp b/vm/cpu-ppc.hpp index f0f6f80ae3..cd98d6a6ab 100644 --- a/vm/cpu-ppc.hpp +++ b/vm/cpu-ppc.hpp @@ -9,8 +9,8 @@ namespace factor B blah the offset from the immediate operand to LOAD32 to the instruction after - the branch is two instructions. */ -static const fixnum xt_tail_pic_offset = 4 * 2; + the branch is one instruction. */ +static const fixnum xt_tail_pic_offset = 4; inline static void check_call_site(cell return_address) { @@ -77,16 +77,6 @@ inline static unsigned int fpu_status(unsigned int status) } /* Defined in assembly */ -VM_C_API void c_to_factor(cell quot, void *vm); -VM_C_API void throw_impl(cell quot, void *new_stack, void *vm); -VM_C_API void lazy_jit_compile_impl(cell quot, void *vm); VM_C_API void flush_icache(cell start, cell len); -VM_C_API void set_callstack( - void *vm, - stack_frame *to, - stack_frame *from, - cell length, - void *(*memcpy)(void*,const void*, size_t)); - } diff --git a/vm/instruction_operands.cpp b/vm/instruction_operands.cpp index e815fc9619..69b82b1435 100644 --- a/vm/instruction_operands.cpp +++ b/vm/instruction_operands.cpp @@ -38,9 +38,9 @@ fixnum instruction_operand::load_value(cell relative_to) case RC_ABSOLUTE_PPC_2: return load_value_masked(rel_absolute_ppc_2_mask,16,0); case RC_RELATIVE_PPC_2: - return load_value_masked(rel_relative_ppc_2_mask,16,0) + relative_to; + return load_value_masked(rel_relative_ppc_2_mask,16,0) + relative_to - sizeof(cell); case RC_RELATIVE_PPC_3: - return load_value_masked(rel_relative_ppc_3_mask,6,0) + relative_to; + return load_value_masked(rel_relative_ppc_3_mask,6,0) + relative_to - sizeof(cell); case RC_RELATIVE_ARM_3: return load_value_masked(rel_relative_arm_3_mask,6,2) + relative_to + sizeof(cell); case RC_INDIRECT_ARM: @@ -107,10 +107,10 @@ void instruction_operand::store_value(fixnum absolute_value) store_value_masked(absolute_value,rel_absolute_ppc_2_mask,0); break; case RC_RELATIVE_PPC_2: - store_value_masked(relative_value,rel_relative_ppc_2_mask,0); + store_value_masked(relative_value + sizeof(cell),rel_relative_ppc_2_mask,0); break; case RC_RELATIVE_PPC_3: - store_value_masked(relative_value,rel_relative_ppc_3_mask,0); + store_value_masked(relative_value + sizeof(cell),rel_relative_ppc_3_mask,0); break; case RC_RELATIVE_ARM_3: store_value_masked(relative_value - sizeof(cell),rel_relative_arm_3_mask,2); From 1c10196c43f7872601a0607a7db9883f71839780 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 13 Jan 2010 18:08:18 +1300 Subject: [PATCH 42/72] Rename kernel.private:getenv/setenv to special-object/set-special-object to mirror recent renaming on the VM side --- .../remote-control/remote-control.factor | 6 +- basis/bootstrap/image/image.factor | 98 +++++++++---------- basis/bootstrap/image/syntax/syntax.factor | 10 +- basis/cocoa/application/application.factor | 2 +- basis/command-line/command-line.factor | 3 +- .../compiler/cfg/intrinsics/intrinsics.factor | 2 +- .../compiler/cfg/intrinsics/misc/misc.factor | 4 +- basis/compiler/codegen/codegen.factor | 4 +- basis/compiler/tests/intrinsics.factor | 4 +- .../known-words/known-words.factor | 6 +- basis/threads/threads.factor | 16 +-- basis/tools/deploy/shaker/shaker.factor | 4 +- basis/tools/deploy/shaker/strip-cocoa.factor | 2 +- basis/vm/vm.factor | 4 +- core/alien/strings/strings.factor | 4 +- core/bootstrap/primitives.factor | 4 +- core/combinators/combinators.factor | 4 +- core/compiler/units/units.factor | 8 +- core/continuations/continuations.factor | 16 +-- core/init/init.factor | 8 +- core/io/files/files.factor | 4 +- core/io/streams/c/c.factor | 6 +- core/kernel/kernel-docs.factor | 8 +- core/layouts/layouts.factor | 2 +- core/namespaces/namespaces.factor | 6 +- core/system/system.factor | 2 +- 26 files changed, 122 insertions(+), 115 deletions(-) diff --git a/basis/alien/remote-control/remote-control.factor b/basis/alien/remote-control/remote-control.factor index 6a5644cceb..ae694bed9c 100644 --- a/basis/alien/remote-control/remote-control.factor +++ b/basis/alien/remote-control/remote-control.factor @@ -19,8 +19,8 @@ IN: alien.remote-control dup optimized? [ execute ] [ drop f ] if ; inline : init-remote-control ( -- ) - \ eval-callback ?callback 16 setenv - \ yield-callback ?callback 17 setenv - \ sleep-callback ?callback 18 setenv ; + \ eval-callback ?callback 16 set-special-object + \ yield-callback ?callback 17 set-special-object + \ sleep-callback ?callback 18 set-special-object ; MAIN: init-remote-control diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor index 1565373cab..90b4c3ae6f 100644 --- a/basis/bootstrap/image/image.factor +++ b/basis/bootstrap/image/image.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2004, 2009 Slava Pestov. +! Copyright (C) 2004, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.strings arrays byte-arrays generic hashtables hashtables.private io io.binary io.files io.encodings.binary @@ -93,7 +93,7 @@ CONSTANT: image-version 4 CONSTANT: data-base 1024 -CONSTANT: userenv-size 70 +CONSTANT: special-objects-size 70 CONSTANT: header-size 10 @@ -176,58 +176,58 @@ SYMBOL: architecture RESET ! Boot quotation, set in stage1.factor -USERENV: bootstrap-startup-quot 20 +SPECIAL-OBJECT: bootstrap-startup-quot 20 ! Bootstrap global namesapce -USERENV: bootstrap-global 21 +SPECIAL-OBJECT: bootstrap-global 21 ! JIT parameters -USERENV: jit-prolog 23 -USERENV: jit-primitive-word 24 -USERENV: jit-primitive 25 -USERENV: jit-word-jump 26 -USERENV: jit-word-call 27 -USERENV: jit-if-word 28 -USERENV: jit-if 29 -USERENV: jit-epilog 30 -USERENV: jit-return 31 -USERENV: jit-profiling 32 -USERENV: jit-push 33 -USERENV: jit-dip-word 34 -USERENV: jit-dip 35 -USERENV: jit-2dip-word 36 -USERENV: jit-2dip 37 -USERENV: jit-3dip-word 38 -USERENV: jit-3dip 39 -USERENV: jit-execute 40 -USERENV: jit-declare-word 41 +SPECIAL-OBJECT: jit-prolog 23 +SPECIAL-OBJECT: jit-primitive-word 24 +SPECIAL-OBJECT: jit-primitive 25 +SPECIAL-OBJECT: jit-word-jump 26 +SPECIAL-OBJECT: jit-word-call 27 +SPECIAL-OBJECT: jit-if-word 28 +SPECIAL-OBJECT: jit-if 29 +SPECIAL-OBJECT: jit-epilog 30 +SPECIAL-OBJECT: jit-return 31 +SPECIAL-OBJECT: jit-profiling 32 +SPECIAL-OBJECT: jit-push 33 +SPECIAL-OBJECT: jit-dip-word 34 +SPECIAL-OBJECT: jit-dip 35 +SPECIAL-OBJECT: jit-2dip-word 36 +SPECIAL-OBJECT: jit-2dip 37 +SPECIAL-OBJECT: jit-3dip-word 38 +SPECIAL-OBJECT: jit-3dip 39 +SPECIAL-OBJECT: jit-execute 40 +SPECIAL-OBJECT: jit-declare-word 41 -USERENV: c-to-factor-word 42 -USERENV: lazy-jit-compile-word 43 -USERENV: unwind-native-frames-word 44 +SPECIAL-OBJECT: c-to-factor-word 42 +SPECIAL-OBJECT: lazy-jit-compile-word 43 +SPECIAL-OBJECT: unwind-native-frames-word 44 -USERENV: callback-stub 48 +SPECIAL-OBJECT: callback-stub 48 ! PIC stubs -USERENV: pic-load 49 -USERENV: pic-tag 50 -USERENV: pic-tuple 51 -USERENV: pic-check-tag 52 -USERENV: pic-check-tuple 53 -USERENV: pic-hit 54 -USERENV: pic-miss-word 55 -USERENV: pic-miss-tail-word 56 +SPECIAL-OBJECT: pic-load 49 +SPECIAL-OBJECT: pic-tag 50 +SPECIAL-OBJECT: pic-tuple 51 +SPECIAL-OBJECT: pic-check-tag 52 +SPECIAL-OBJECT: pic-check-tuple 53 +SPECIAL-OBJECT: pic-hit 54 +SPECIAL-OBJECT: pic-miss-word 55 +SPECIAL-OBJECT: pic-miss-tail-word 56 ! Megamorphic dispatch -USERENV: mega-lookup 57 -USERENV: mega-lookup-word 58 -USERENV: mega-miss-word 59 +SPECIAL-OBJECT: mega-lookup 57 +SPECIAL-OBJECT: mega-lookup-word 58 +SPECIAL-OBJECT: mega-miss-word 59 ! Default definition for undefined words -USERENV: undefined-quot 60 +SPECIAL-OBJECT: undefined-quot 60 -: userenv-offset ( symbol -- n ) - userenvs get at header-size + ; +: special-object-offset ( symbol -- n ) + special-objects get at header-size + ; : emit ( cell -- ) image get push ; @@ -243,7 +243,7 @@ USERENV: undefined-quot 60 : fixup ( value offset -- ) image get set-nth ; : heap-size ( -- size ) - image get length header-size - userenv-size - + image get length header-size - special-objects-size - bootstrap-cells ; : here ( -- size ) heap-size data-base + ; @@ -282,10 +282,10 @@ GENERIC: ' ( obj -- ptr ) 0 emit ! pointer to bignum 0 0 emit ! pointer to bignum 1 0 emit ! pointer to bignum -1 - userenv-size [ f ' emit ] times ; + special-objects-size [ f ' emit ] times ; -: emit-userenv ( symbol -- ) - [ get ' ] [ userenv-offset ] bi fixup ; +: emit-special-object ( symbol -- ) + [ get ' ] [ special-object-offset ] bi fixup ; ! Bignums @@ -548,8 +548,8 @@ M: quotation ' \ unwind-native-frames unwind-native-frames-word set [ undefined ] undefined-quot set ; -: emit-userenvs ( -- ) - userenvs get keys [ emit-userenv ] each ; +: emit-special-objects ( -- ) + special-objects get keys [ emit-special-object ] each ; : fixup-header ( -- ) heap-size data-heap-size-offset fixup ; @@ -566,8 +566,8 @@ M: quotation ' emit-jit-data "Serializing global namespace..." print flush emit-global - "Serializing user environment..." print flush - emit-userenvs + "Serializing special object table..." print flush + emit-special-objects "Performing word fixups..." print flush fixup-words "Performing header fixups..." print flush diff --git a/basis/bootstrap/image/syntax/syntax.factor b/basis/bootstrap/image/syntax/syntax.factor index 29dc09717a..7025cd61e1 100644 --- a/basis/bootstrap/image/syntax/syntax.factor +++ b/basis/bootstrap/image/syntax/syntax.factor @@ -1,14 +1,14 @@ -! Copyright (C) 2009 Slava Pestov. +! Copyright (C) 2009, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: parser kernel namespaces assocs words.symbol ; IN: bootstrap.image.syntax -SYMBOL: userenvs +SYMBOL: special-objects -SYNTAX: RESET H{ } clone userenvs set-global ; +SYNTAX: RESET H{ } clone special-objects set-global ; -SYNTAX: USERENV: +SYNTAX: SPECIAL-OBJECT: CREATE-WORD scan-word - [ swap userenvs get set-at ] + [ swap special-objects get set-at ] [ drop define-symbol ] 2bi ; \ No newline at end of file diff --git a/basis/cocoa/application/application.factor b/basis/cocoa/application/application.factor index 83213b47ba..df56ce5c4c 100644 --- a/basis/cocoa/application/application.factor +++ b/basis/cocoa/application/application.factor @@ -49,7 +49,7 @@ TUPLE: objc-error alien reason ; M: objc-error summary ( error -- ) drop "Objective C exception" ; -[ [ objc-error ] 19 setenv ] "cocoa.application" add-startup-hook +[ [ objc-error ] 19 set-special-object ] "cocoa.application" add-startup-hook : running.app? ( -- ? ) #! Test if we're running a .app. diff --git a/basis/command-line/command-line.factor b/basis/command-line/command-line.factor index f1748d3708..939fb82f00 100644 --- a/basis/command-line/command-line.factor +++ b/basis/command-line/command-line.factor @@ -8,7 +8,8 @@ IN: command-line SYMBOL: script SYMBOL: command-line -: (command-line) ( -- args ) 10 getenv sift [ alien>native-string ] map ; +: (command-line) ( -- args ) + 10 special-object sift [ alien>native-string ] map ; : rc-path ( name -- path ) os windows? [ "." prepend ] unless diff --git a/basis/compiler/cfg/intrinsics/intrinsics.factor b/basis/compiler/cfg/intrinsics/intrinsics.factor index e8c93899cb..d753a4c1b4 100644 --- a/basis/compiler/cfg/intrinsics/intrinsics.factor +++ b/basis/compiler/cfg/intrinsics/intrinsics.factor @@ -30,7 +30,7 @@ IN: compiler.cfg.intrinsics { { kernel.private:tag [ drop emit-tag ] } - { kernel.private:getenv [ emit-getenv ] } + { kernel.private:special-object [ emit-special-object ] } { kernel.private:(identity-hashcode) [ drop emit-identity-hashcode ] } { math.private:both-fixnums? [ drop emit-both-fixnums? ] } { math.private:fixnum+ [ drop emit-fixnum+ ] } diff --git a/basis/compiler/cfg/intrinsics/misc/misc.factor b/basis/compiler/cfg/intrinsics/misc/misc.factor index a477ef4b95..fed5492220 100644 --- a/basis/compiler/cfg/intrinsics/misc/misc.factor +++ b/basis/compiler/cfg/intrinsics/misc/misc.factor @@ -9,8 +9,8 @@ IN: compiler.cfg.intrinsics.misc : emit-tag ( -- ) ds-pop tag-mask get ^^and-imm ^^tag-fixnum ds-push ; -: emit-getenv ( node -- ) - "userenv" ^^vm-field-ptr +: emit-special-object ( node -- ) + "special-objects" ^^vm-field-ptr swap node-input-infos first literal>> [ ds-drop 0 ^^slot-imm ] [ ds-pop ^^offset>slot ^^slot ] if* ds-push ; diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index cea6527259..d408c722ff 100644 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -474,7 +474,7 @@ M: ##alien-indirect generate-insn TUPLE: callback-context ; -: current-callback ( -- id ) 2 getenv ; +: current-callback ( -- id ) 2 special-object ; : wait-to-return ( token -- ) dup current-callback eq? [ @@ -485,7 +485,7 @@ TUPLE: callback-context ; : do-callback ( quot token -- ) init-catchstack - [ 2 setenv call ] keep + [ 2 set-special-object call ] keep wait-to-return ; inline : callback-return-quot ( ctype -- quot ) diff --git a/basis/compiler/tests/intrinsics.factor b/basis/compiler/tests/intrinsics.factor index 7fe5e2b601..37b3a75071 100644 --- a/basis/compiler/tests/intrinsics.factor +++ b/basis/compiler/tests/intrinsics.factor @@ -54,8 +54,8 @@ IN: compiler.tests.intrinsics [ HEX: 123456 ] [ 1 [ "a\u123456c" string-nth ] compile-call ] unit-test [ HEX: 123456 ] [ [ 1 "a\u123456c" string-nth ] compile-call ] unit-test -[ ] [ [ 0 getenv ] compile-call drop ] unit-test -[ ] [ 1 getenv [ 1 setenv ] compile-call ] unit-test +[ ] [ [ 0 special-object ] compile-call drop ] unit-test +[ ] [ 1 special-object [ 1 set-special-object ] compile-call ] unit-test [ ] [ 1 [ drop ] compile-call ] unit-test [ ] [ [ 1 drop ] compile-call ] unit-test diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index a95d110622..bbd8ecc407 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -489,10 +489,10 @@ M: bad-executable summary \ word-xt { word } { integer integer } define-primitive \ word-xt make-flushable -\ getenv { fixnum } { object } define-primitive -\ getenv make-flushable +\ special-object { fixnum } { object } define-primitive +\ special-object make-flushable -\ setenv { object fixnum } { } define-primitive +\ set-special-object { object fixnum } { } define-primitive \ (exists?) { string } { object } define-primitive diff --git a/basis/threads/threads.factor b/basis/threads/threads.factor index 9d1cd29337..952652d801 100644 --- a/basis/threads/threads.factor +++ b/basis/threads/threads.factor @@ -21,7 +21,7 @@ mailbox variables sleep-entry ; -: self ( -- thread ) 63 getenv ; inline +: self ( -- thread ) 63 special-object ; inline ! Thread-local storage : tnamespace ( -- assoc ) @@ -36,7 +36,7 @@ sleep-entry ; : tchange ( key quot -- ) tnamespace swap change-at ; inline -: threads ( -- assoc ) 64 getenv ; +: threads ( -- assoc ) 64 special-object ; : thread ( id -- thread ) threads at ; @@ -61,7 +61,7 @@ ERROR: not-running thread ; : unregister-thread ( thread -- ) check-registered id>> threads delete-at ; -: set-self ( thread -- ) 63 setenv ; inline +: set-self ( thread -- ) 63 set-special-object ; inline PRIVATE> @@ -75,9 +75,9 @@ PRIVATE> : ( quot name -- thread ) \ thread new-thread ; -: run-queue ( -- dlist ) 65 getenv ; +: run-queue ( -- dlist ) 65 special-object ; -: sleep-queue ( -- heap ) 66 getenv ; +: sleep-queue ( -- heap ) 66 special-object ; : resume ( thread -- ) f >>state @@ -216,9 +216,9 @@ GENERIC: error-in-thread ( error thread -- ) 65 setenv - 66 setenv + H{ } clone 64 set-special-object + 65 set-special-object + 66 set-special-object initial-thread global [ drop [ ] "Initial" ] cache >>continuation diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index ea02aa03c9..06009992ad 100644 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -393,7 +393,7 @@ IN: tools.deploy.shaker '[ drop _ member? not ] assoc-filter [ drop string? not ] assoc-filter ! strip CLI args sift-assoc - 21 setenv + 21 set-special-object ] [ drop ] if ; : strip-c-io ( -- ) @@ -518,7 +518,7 @@ SYMBOL: deploy-vocab strip-c-io strip-default-methods strip-compiler-classes - f 5 setenv ! we can't use the Factor debugger or Factor I/O anymore + f 5 set-special-object ! we can't use the Factor debugger or Factor I/O anymore deploy-vocab get vocab-main deploy-startup-quot find-megamorphic-caches stripped-word-props diff --git a/basis/tools/deploy/shaker/strip-cocoa.factor b/basis/tools/deploy/shaker/strip-cocoa.factor index d5c5bd54da..7bb2f651dc 100644 --- a/basis/tools/deploy/shaker/strip-cocoa.factor +++ b/basis/tools/deploy/shaker/strip-cocoa.factor @@ -17,7 +17,7 @@ IN: cocoa.application : objc-error ( error -- ) die ; -[ [ die ] 19 setenv ] "cocoa.application" add-startup-hook +[ [ die ] 19 set-special-object ] "cocoa.application" add-startup-hook H{ } clone \ pool [ global [ diff --git a/basis/vm/vm.factor b/basis/vm/vm.factor index 20428c40f3..cc4a291a8b 100644 --- a/basis/vm/vm.factor +++ b/basis/vm/vm.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2009 Phil Dawes. +! Copyright (C) 2009, 2010 Phil Dawes, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: classes.struct alien.c-types alien.syntax ; IN: vm @@ -30,7 +30,7 @@ STRUCT: vm { nursery zone } { cards-offset cell } { decks-offset cell } -{ userenv cell[70] } ; +{ special-objects cell[70] } ; : vm-field-offset ( field -- offset ) vm offset-of ; inline diff --git a/core/alien/strings/strings.factor b/core/alien/strings/strings.factor index 8e09fa8c2c..15e0370ba0 100644 --- a/core/alien/strings/strings.factor +++ b/core/alien/strings/strings.factor @@ -67,6 +67,6 @@ M: string string>symbol string>symbol* ; M: sequence string>symbol [ string>symbol* ] map ; [ - 8 getenv utf8 alien>string string>cpu \ cpu set-global - 9 getenv utf8 alien>string string>os \ os set-global + 8 special-object utf8 alien>string string>cpu \ cpu set-global + 9 special-object utf8 alien>string string>os \ os set-global ] "alien.strings" add-startup-hook diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index a0b278c7a4..2a791bf42d 100644 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -421,8 +421,8 @@ tuple { "float-u>=" "math.private" (( x y -- ? )) } { "(word)" "words.private" (( name vocab -- word )) } { "word-xt" "words" (( word -- start end )) } - { "getenv" "kernel.private" (( n -- obj )) } - { "setenv" "kernel.private" (( obj n -- )) } + { "special-object" "kernel.private" (( n -- obj )) } + { "set-special-object" "kernel.private" (( obj n -- )) } { "(exists?)" "io.files.private" (( path -- ? )) } { "minor-gc" "memory" (( -- )) } { "gc" "memory" (( -- )) } diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor index 2bef1a568a..55cc55c334 100644 --- a/core/combinators/combinators.factor +++ b/core/combinators/combinators.factor @@ -11,7 +11,9 @@ IN: combinators : execute-effect-unsafe ( word effect -- ) drop execute ; -M: object throw 5 getenv [ die ] or (( error -- * )) call-effect-unsafe ; +M: object throw + 5 special-object [ die ] or + (( error -- * )) call-effect-unsafe ; PRIVATE> diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor index 996a6e9bd4..a64080e510 100644 --- a/core/compiler/units/units.factor +++ b/core/compiler/units/units.factor @@ -100,7 +100,7 @@ GENERIC: definitions-changed ( assoc obj -- ) ! Incremented each time stack effects potentially changed, used ! by compiler.tree.propagation.call-effect for call( and execute( ! inline caching -: effect-counter ( -- n ) 47 getenv ; inline +: effect-counter ( -- n ) 47 special-object ; inline GENERIC: bump-effect-counter* ( defspec -- ? ) @@ -132,7 +132,11 @@ M: object bump-effect-counter* drop f ; or ; : bump-effect-counter ( -- ) - bump-effect-counter? [ 47 getenv 0 or 1 + 47 setenv ] when ; + bump-effect-counter? [ + 47 special-object 0 or + 1 + + 47 set-special-object + ] when ; : notify-observers ( -- ) updated-definitions dup assoc-empty? diff --git a/core/continuations/continuations.factor b/core/continuations/continuations.factor index 02c129aefe..d63acae883 100644 --- a/core/continuations/continuations.factor +++ b/core/continuations/continuations.factor @@ -13,7 +13,7 @@ SYMBOL: restarts c ( continuation -- ) catchstack* push ; @@ -23,13 +23,13 @@ SYMBOL: restarts : dummy-1 ( -- obj ) f ; : dummy-2 ( obj -- obj ) dup drop ; -: init-catchstack ( -- ) V{ } clone 1 setenv ; +: init-catchstack ( -- ) V{ } clone 1 set-special-object ; PRIVATE> : catchstack ( -- catchstack ) catchstack* clone ; inline -: set-catchstack ( catchstack -- ) >vector 1 setenv ; inline +: set-catchstack ( catchstack -- ) >vector 1 set-special-object ; inline TUPLE: continuation data call retain name catch ; @@ -71,12 +71,12 @@ PRIVATE> : continue-with ( obj continuation -- * ) [ - swap 4 setenv + swap 4 set-special-object >continuation< set-catchstack set-namestack set-retainstack - [ set-datastack drop 4 getenv f 4 setenv f ] dip + [ set-datastack drop 4 special-object f 4 set-special-object f ] dip set-callstack ] (( obj continuation -- * )) call-effect-unsafe ; @@ -173,12 +173,12 @@ M: condition compute-restarts ! VM calls on error [ ! 63 = self - 63 getenv error-thread set-global + 63 special-object error-thread set-global continuation error-continuation set-global rethrow - ] 5 setenv + ] 5 set-special-object ! VM adds this to kernel errors, so that user-space ! can identify them - "kernel-error" 6 setenv ; + "kernel-error" 6 set-special-object ; PRIVATE> diff --git a/core/init/init.factor b/core/init/init.factor index 40e5806fd5..4e2d4b16a1 100644 --- a/core/init/init.factor +++ b/core/init/init.factor @@ -27,12 +27,12 @@ shutdown-hooks global [ drop V{ } clone ] cache drop : boot ( -- ) init-namespaces init-catchstack init-error-handler ; -: startup-quot ( -- quot ) 20 getenv ; +: startup-quot ( -- quot ) 20 special-object ; -: set-startup-quot ( quot -- ) 20 setenv ; +: set-startup-quot ( quot -- ) 20 set-special-object ; -: shutdown-quot ( -- quot ) 22 getenv ; +: shutdown-quot ( -- quot ) 22 special-object ; -: set-shutdown-quot ( quot -- ) 22 setenv ; +: set-shutdown-quot ( quot -- ) 22 set-special-object ; [ do-shutdown-hooks ] set-shutdown-quot diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 9824fba18c..86d02acdd1 100644 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -57,7 +57,7 @@ PRIVATE> [ cwd current-directory set-global - 13 getenv alien>native-string cwd prepend-path \ image set-global - 14 getenv alien>native-string cwd prepend-path \ vm set-global + 13 special-object alien>native-string cwd prepend-path \ image set-global + 14 special-object alien>native-string cwd prepend-path \ vm set-global image parent-directory "resource-path" set-global ] "io.files" add-startup-hook diff --git a/core/io/streams/c/c.factor b/core/io/streams/c/c.factor index cb978d5deb..d26f03aa5e 100644 --- a/core/io/streams/c/c.factor +++ b/core/io/streams/c/c.factor @@ -61,9 +61,9 @@ M: c-reader stream-read-until M: c-io-backend init-io ; -: stdin-handle ( -- alien ) 11 getenv ; -: stdout-handle ( -- alien ) 12 getenv ; -: stderr-handle ( -- alien ) 61 getenv ; +: stdin-handle ( -- alien ) 11 special-object ; +: stdout-handle ( -- alien ) 12 special-object ; +: stderr-handle ( -- alien ) 61 special-object ; : init-c-stdio ( -- ) stdin-handle diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index 89ac1c9a05..7c80990d7a 100644 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -655,13 +655,13 @@ HELP: tag ( object -- n ) { $values { "object" object } { "n" "a tag number" } } { $description "Outputs an object's tag number, between zero and one less than " { $link num-types } ". This is implementation detail and user code should call " { $link class } " instead." } ; -HELP: getenv ( n -- obj ) +HELP: special-object ( n -- obj ) { $values { "n" "a non-negative integer" } { "obj" object } } -{ $description "Reads an object from the Factor VM's environment table. User code never has to read the environment table directly; instead, use one of the callers of this word." } ; +{ $description "Reads an object from the Factor VM's special object table. User code never has to read the special object table directly; instead, use one of the callers of this word." } ; -HELP: setenv ( obj n -- ) +HELP: set-special-object ( obj n -- ) { $values { "obj" object } { "n" "a non-negative integer" } } -{ $description "Writes an object to the Factor VM's environment table. User code never has to write to the environment table directly; instead, use one of the callers of this word." } ; +{ $description "Writes an object to the Factor VM's special object table. User code never has to write to the special object table directly; instead, use one of the callers of this word." } ; HELP: object { $class-description diff --git a/core/layouts/layouts.factor b/core/layouts/layouts.factor index 05fe03315c..5edb5d1d72 100644 --- a/core/layouts/layouts.factor +++ b/core/layouts/layouts.factor @@ -36,7 +36,7 @@ SYMBOL: header-bits ! We do this in its own compilation unit so that they can be ! folded below << -: cell ( -- n ) 7 getenv ; foldable +: cell ( -- n ) 7 special-object ; foldable : (first-bignum) ( m -- n ) tag-bits get - 1 - 2^ ; foldable >> diff --git a/core/namespaces/namespaces.factor b/core/namespaces/namespaces.factor index 9428445d26..40b1db8a3f 100644 --- a/core/namespaces/namespaces.factor +++ b/core/namespaces/namespaces.factor @@ -6,7 +6,7 @@ IN: namespaces n ( namespace -- ) namestack* push ; : ndrop ( -- ) namestack* pop* ; @@ -14,8 +14,8 @@ PRIVATE> : namespace ( -- namespace ) namestack* last ; inline : namestack ( -- namestack ) namestack* clone ; -: set-namestack ( namestack -- ) >vector 0 setenv ; -: global ( -- g ) 21 getenv { hashtable } declare ; inline +: set-namestack ( namestack -- ) >vector 0 set-special-object ; +: global ( -- g ) 21 special-object { hashtable } declare ; inline : init-namespaces ( -- ) global 1array set-namestack ; : get ( variable -- value ) namestack* assoc-stack ; inline : set ( value variable -- ) namespace set-at ; diff --git a/core/system/system.factor b/core/system/system.factor index 59f2a030ce..715564c64d 100644 --- a/core/system/system.factor +++ b/core/system/system.factor @@ -53,6 +53,6 @@ PRIVATE> : vm ( -- path ) \ vm get-global ; -: embedded? ( -- ? ) 15 getenv ; +: embedded? ( -- ? ) 15 special-object ; : exit ( n -- ) do-shutdown-hooks (exit) ; From 47a5e9654796e1511d8dd95661eb55e65f2c182d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 13 Jan 2010 22:20:16 +1300 Subject: [PATCH 43/72] Rework min and max so that behavior with floats and NaNs is consistent between generic arithmetic and open-coded float intrinsics --- basis/compiler/tests/float.factor | 27 ++++++++++++++---- .../tree/propagation/propagation-tests.factor | 28 +++++++++++++------ .../propagation/transforms/transforms.factor | 20 ------------- basis/math/vectors/vectors.factor | 11 ++------ core/math/floats/floats-tests.factor | 5 +++- core/math/floats/floats.factor | 7 +++-- core/math/integers/integers-tests.factor | 8 ++++-- core/math/integers/integers.factor | 9 ++++-- core/math/order/order-docs.factor | 6 ++-- core/math/order/order.factor | 10 +++++-- 10 files changed, 73 insertions(+), 58 deletions(-) diff --git a/basis/compiler/tests/float.factor b/basis/compiler/tests/float.factor index 14b347008c..632a560c0d 100644 --- a/basis/compiler/tests/float.factor +++ b/basis/compiler/tests/float.factor @@ -1,5 +1,5 @@ USING: compiler.units compiler kernel kernel.private memory math -math.private tools.test math.floats.private ; +math.private tools.test math.floats.private math.order fry ; IN: compiler.tests.float [ 5.0 ] [ [ 5.0 ] compile-call gc gc gc ] unit-test @@ -84,11 +84,6 @@ IN: compiler.tests.float [ 315 315.0 ] [ 313 [ 2 fixnum+fast dup fixnum>float ] compile-call ] unit-test -[ 17.5 ] [ -11.3 17.5 [ float-max ] compile-call ] unit-test -[ 17.5 ] [ 17.5 -11.3 [ float-max ] compile-call ] unit-test -[ -11.3 ] [ -11.3 17.5 [ float-min ] compile-call ] unit-test -[ -11.3 ] [ 17.5 -11.3 [ float-min ] compile-call ] unit-test - [ t ] [ 0/0. 0/0. [ float-unordered? ] compile-call ] unit-test [ t ] [ 0/0. 1.0 [ float-unordered? ] compile-call ] unit-test [ t ] [ 1.0 0/0. [ float-unordered? ] compile-call ] unit-test @@ -100,3 +95,23 @@ IN: compiler.tests.float [ 1 ] [ 1.0 0/0. [ float-unordered? [ 1 ] [ 2 ] if ] compile-call ] unit-test [ 2 ] [ 3.0 1.0 [ float-unordered? [ 1 ] [ 2 ] if ] compile-call ] unit-test [ 2 ] [ 1.0 3.0 [ float-unordered? [ 1 ] [ 2 ] if ] compile-call ] unit-test + +! Ensure that float-min and min, and float-max and max, have +! consistent behavior with respect to NaNs + +: two-floats ( a b -- a b ) { float float } declare ; inline + +[ -11.3 ] [ -11.3 17.5 [ two-floats min ] compile-call ] unit-test +[ -11.3 ] [ 17.5 -11.3 [ two-floats min ] compile-call ] unit-test +[ 17.5 ] [ -11.3 17.5 [ two-floats max ] compile-call ] unit-test +[ 17.5 ] [ 17.5 -11.3 [ two-floats max ] compile-call ] unit-test + +: check-compiled-binary-op ( a b word -- ) + [ '[ [ [ two-floats _ execute ] compile-call ] call( a b -- c ) ] ] + [ '[ _ execute ] ] + bi 2bi fp-bitwise= ; inline + +[ t ] [ 0/0. 3.0 \ min check-compiled-binary-op ] unit-test +[ t ] [ 3.0 0/0. \ min check-compiled-binary-op ] unit-test +[ t ] [ 0/0. 3.0 \ max check-compiled-binary-op ] unit-test +[ t ] [ 3.0 0/0. \ max check-compiled-binary-op ] unit-test diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor index c7e02aef4c..f8a53b3287 100644 --- a/basis/compiler/tree/propagation/propagation-tests.factor +++ b/basis/compiler/tree/propagation/propagation-tests.factor @@ -1,14 +1,13 @@ USING: kernel compiler.tree.builder compiler.tree compiler.tree.propagation compiler.tree.recursive -compiler.tree.normalization tools.test math math.order -accessors sequences arrays kernel.private vectors -alien.accessors alien.c-types sequences.private -byte-arrays classes.algebra classes.tuple.private -math.functions math.private strings layouts -compiler.tree.propagation.info compiler.tree.def-use -compiler.tree.debugger compiler.tree.checker -slots.private words hashtables classes assocs locals -specialized-arrays system sorting math.libm +compiler.tree.normalization tools.test math math.order accessors +sequences arrays kernel.private vectors alien.accessors +alien.c-types sequences.private byte-arrays classes.algebra +classes.tuple.private math.functions math.private strings +layouts compiler.tree.propagation.info compiler.tree.def-use +compiler.tree.debugger compiler.tree.checker slots.private words +hashtables classes assocs locals specialized-arrays system +sorting math.libm math.floats.private math.integers.private math.intervals quotations effects alien alien.data ; FROM: math => float ; SPECIALIZED-ARRAY: double @@ -942,3 +941,14 @@ M: tuple-with-read-only-slot clone ! Could be bignum not integer but who cares [ V{ integer } ] [ [ 10 >bignum bitand ] final-classes ] unit-test +[ t ] [ [ { fixnum fixnum } declare min ] { min } inlined? ] unit-test +[ f ] [ [ { fixnum fixnum } declare min ] { fixnum-min } inlined? ] unit-test + +[ t ] [ [ { float float } declare min ] { min } inlined? ] unit-test +[ f ] [ [ { float float } declare min ] { float-min } inlined? ] unit-test + +[ t ] [ [ { fixnum fixnum } declare max ] { max } inlined? ] unit-test +[ f ] [ [ { fixnum fixnum } declare max ] { fixnum-max } inlined? ] unit-test + +[ t ] [ [ { float float } declare max ] { max } inlined? ] unit-test +[ f ] [ [ { float float } declare max ] { float-max } inlined? ] unit-test diff --git a/basis/compiler/tree/propagation/transforms/transforms.factor b/basis/compiler/tree/propagation/transforms/transforms.factor index 809b51c6ef..f88b60d338 100644 --- a/basis/compiler/tree/propagation/transforms/transforms.factor +++ b/basis/compiler/tree/propagation/transforms/transforms.factor @@ -132,26 +132,6 @@ IN: compiler.tree.propagation.transforms ] "custom-inlining" set-word-prop ] each -! Integrate this with generic arithmetic optimization instead? -: both-inputs? ( #call class -- ? ) - [ in-d>> first2 ] dip '[ value-info class>> _ class<= ] both? ; - -\ min [ - { - { [ dup fixnum both-inputs? ] [ [ fixnum-min ] ] } - { [ dup float both-inputs? ] [ [ float-min ] ] } - [ f ] - } cond nip -] "custom-inlining" set-word-prop - -\ max [ - { - { [ dup fixnum both-inputs? ] [ [ fixnum-max ] ] } - { [ dup float both-inputs? ] [ [ float-max ] ] } - [ f ] - } cond nip -] "custom-inlining" set-word-prop - ! Generate more efficient code for common idiom \ clone [ in-d>> first value-info literal>> { diff --git a/basis/math/vectors/vectors.factor b/basis/math/vectors/vectors.factor index 311abf50af..69d8929c65 100644 --- a/basis/math/vectors/vectors.factor +++ b/basis/math/vectors/vectors.factor @@ -58,21 +58,14 @@ M: object v*hs+ [ * ] 2map (h+) ; GENERIC: v/ ( u v -- w ) M: object v/ [ / ] 2map ; - - GENERIC: vavg ( u v -- w ) M: object vavg [ + 2 / ] 2map ; GENERIC: vmax ( u v -- w ) -M: object vmax [ [ float-max ] [ max ] if-both-floats ] 2map ; +M: object vmax [ max ] 2map ; GENERIC: vmin ( u v -- w ) -M: object vmin [ [ float-min ] [ min ] if-both-floats ] 2map ; +M: object vmin [ min ] 2map ; GENERIC: v+- ( u v -- w ) M: object v+- diff --git a/core/math/floats/floats-tests.factor b/core/math/floats/floats-tests.factor index 220eb33960..2c0884c8b1 100644 --- a/core/math/floats/floats-tests.factor +++ b/core/math/floats/floats-tests.factor @@ -1,4 +1,4 @@ -USING: kernel math math.constants tools.test sequences +USING: kernel math math.constants math.order tools.test sequences grouping ; IN: math.floats.tests @@ -75,3 +75,6 @@ unit-test [ t ] [ -0.0 abs 0.0 fp-bitwise= ] unit-test [ 1.5 ] [ -1.5 abs ] unit-test [ 1.5 ] [ 1.5 abs ] unit-test + +[ 5.0 ] [ 3 5.0 max ] unit-test +[ 3 ] [ 3 5.0 min ] unit-test diff --git a/core/math/floats/floats.factor b/core/math/floats/floats.factor index bc419b94c5..97c6f7fc87 100644 --- a/core/math/floats/floats.factor +++ b/core/math/floats/floats.factor @@ -1,6 +1,6 @@ -! Copyright (C) 2004, 2009 Slava Pestov, Joe Groff. +! Copyright (C) 2004, 2010 Slava Pestov, Joe Groff. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math math.private ; +USING: kernel math math.private math.order ; IN: math.floats.private : float-unordered? ( x y -- ? ) [ fp-nan? ] bi@ or ; @@ -29,6 +29,9 @@ M: float u<= float-u<= ; inline M: float u> float-u> ; inline M: float u>= float-u>= ; inline +M: float min over float? [ float-min ] [ call-next-method ] if ; inline +M: float max over float? [ float-max ] [ call-next-method ] if ; inline + M: float + float+ ; inline M: float - float- ; inline M: float * float* ; inline diff --git a/core/math/integers/integers-tests.factor b/core/math/integers/integers-tests.factor index 30d1254082..3f9384e02d 100644 --- a/core/math/integers/integers-tests.factor +++ b/core/math/integers/integers-tests.factor @@ -1,5 +1,6 @@ -USING: kernel math math.functions namespaces prettyprint -math.private continuations tools.test sequences random ; +USING: kernel math math.functions math.order namespaces +prettyprint math.private continuations tools.test sequences +random ; IN: math.integers.tests [ "-8" ] [ -8 unparse ] unit-test @@ -230,3 +231,6 @@ unit-test ! Ensure that /f is accurate for fixnums > 2^53 on 64-bit platforms [ HEX: 1.758bec11492f9p-54 ] [ 1 12345678901234567 /f ] unit-test [ HEX: -1.758bec11492f9p-54 ] [ 1 -12345678901234567 /f ] unit-test + +[ 17 ] [ 17 >bignum 5 max ] unit-test +[ 5 ] [ 17 >bignum 5 min ] unit-test diff --git a/core/math/integers/integers.factor b/core/math/integers/integers.factor index eb94597160..e95c6d832b 100644 --- a/core/math/integers/integers.factor +++ b/core/math/integers/integers.factor @@ -1,8 +1,8 @@ -! Copyright (C) 2004, 2009 Slava Pestov. +! Copyright (C) 2004, 2010 Slava Pestov. ! Copyright (C) 2008, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel kernel.private sequences -sequences.private math math.private combinators ; +USING: kernel kernel.private sequences sequences.private math +math.private math.order combinators ; IN: math.integers.private : fixnum-min ( x y -- z ) [ fixnum< ] most ; foldable @@ -29,6 +29,9 @@ M: fixnum u<= fixnum<= ; inline M: fixnum u> fixnum> ; inline M: fixnum u>= fixnum>= ; inline +M: fixnum min over fixnum? [ fixnum-min ] [ call-next-method ] if ; inline +M: fixnum max over fixnum? [ fixnum-max ] [ call-next-method ] if ; inline + M: fixnum + fixnum+ ; inline M: fixnum - fixnum- ; inline M: fixnum * fixnum* ; inline diff --git a/core/math/order/order-docs.factor b/core/math/order/order-docs.factor index 5d294c1f6f..418107fcd1 100644 --- a/core/math/order/order-docs.factor +++ b/core/math/order/order-docs.factor @@ -44,18 +44,18 @@ HELP: compare } ; HELP: max -{ $values { "x" object } { "y" object } { "z" object } } +{ $values { "obj1" object } { "obj2" object } { "obj" object } } { $description "Outputs the greatest of two ordered values." } { $notes "If one value is a floating point positive zero and the other is a negative zero, the result is undefined." } ; HELP: min -{ $values { "x" object } { "y" object } { "z" object } } +{ $values { "obj1" object } { "obj2" object } { "obj" object } } { $description "Outputs the smallest of two ordered values." } { $notes "If one value is a floating point positive zero and the other is a negative zero, the result is undefined." } ; HELP: clamp { $values { "x" object } { "min" object } { "max" object } { "y" object } } -{ $description "Outputs " { $snippet "x" } " if contained in the interval " { $snippet "[min,max]" } " or outputs one of the endpoints." } ; +{ $description "Outputs " { $snippet "x" } " if contained in the interval " { $snippet "[min,max]" } " or else outputs one of the endpoints." } ; HELP: between? { $values { "x" object } { "y" object } { "z" real } { "?" "a boolean" } } diff --git a/core/math/order/order.factor b/core/math/order/order.factor index fe1454d1d8..499cf06e9a 100644 --- a/core/math/order/order.factor +++ b/core/math/order/order.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008 Slava Pestov, Doug Coleman. +! Copyright (C) 2008, 2010 Slava Pestov, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: kernel math ; IN: math.order @@ -32,8 +32,12 @@ M: real after? ( obj1 obj2 -- ? ) > ; inline M: real before=? ( obj1 obj2 -- ? ) <= ; inline M: real after=? ( obj1 obj2 -- ? ) >= ; inline -: min ( x y -- z ) [ before? ] most ; -: max ( x y -- z ) [ after? ] most ; +GENERIC: min ( obj1 obj2 -- obj ) +GENERIC: max ( obj1 obj2 -- obj ) + +M: object min [ before? ] most ; inline +M: object max [ after? ] most ; inline + : clamp ( x min max -- y ) [ max ] dip min ; inline : between? ( x y z -- ? ) From 2922e08ed949ce76b6e75ea86021efb762341775 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 13 Jan 2010 23:06:45 +1300 Subject: [PATCH 44/72] vm: rework platform.hpp so that it is no longer necessary to pass -DFACTOR_64 and -DWINDOWS when compiling VM --- vm/Config.windows | 2 +- vm/Config.x86.64 | 2 +- vm/os-windows.hpp | 1 - vm/platform.hpp | 6 ++++++ 4 files changed, 8 insertions(+), 3 deletions(-) diff --git a/vm/Config.windows b/vm/Config.windows index b0b1352cb2..11df403541 100644 --- a/vm/Config.windows +++ b/vm/Config.windows @@ -1,4 +1,4 @@ -CFLAGS += -DWINDOWS -mno-cygwin +CFLAGS += -mno-cygwin LIBS = -lm PLAF_DLL_OBJS += vm/os-windows.o SHARED_FLAG = -shared diff --git a/vm/Config.x86.64 b/vm/Config.x86.64 index 314c14fe05..8b13789179 100644 --- a/vm/Config.x86.64 +++ b/vm/Config.x86.64 @@ -1 +1 @@ -CFLAGS += -DFACTOR_64 + diff --git a/vm/os-windows.hpp b/vm/os-windows.hpp index a7c69571d9..6a280ea580 100644 --- a/vm/os-windows.hpp +++ b/vm/os-windows.hpp @@ -18,7 +18,6 @@ typedef wchar_t vm_char; #define STRCMP wcscmp #define STRNCMP wcsncmp #define STRDUP _wcsdup -#define MIN(a,b) ((a)>(b)?(b):(a)) #define FTELL ftello64 #define FSEEK fseeko64 diff --git a/vm/platform.hpp b/vm/platform.hpp index 7b4356af56..a3434e2ad0 100644 --- a/vm/platform.hpp +++ b/vm/platform.hpp @@ -2,6 +2,7 @@ #define FACTOR_ARM #elif defined(__amd64__) || defined(__x86_64__) #define FACTOR_AMD64 + #define FACTOR_64 #elif defined(i386) || defined(__i386) || defined(__i386__) || defined(WIN32) #define FACTOR_X86 #elif defined(__POWERPC__) || defined(__ppc__) || defined(_ARCH_PPC) @@ -10,6 +11,10 @@ #error "Unsupported architecture" #endif +#ifdef WIN32 + #define WINDOWS +#endif + #if defined(WINDOWS) #if defined(WINCE) #include "os-windows-ce.hpp" @@ -18,6 +23,7 @@ #endif #include "os-windows.hpp" + #if defined(FACTOR_AMD64) #include "os-windows-nt.64.hpp" #elif defined(FACTOR_X86) From ce2487e6c0aa40ab8f4c6b871f13c9593ed7ec2b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 13 Jan 2010 23:18:43 +1300 Subject: [PATCH 45/72] compiler.codegen.fixup: cache symbol names, reducing image size by ~200Kb --- basis/compiler/codegen/fixup/fixup.factor | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/basis/compiler/codegen/fixup/fixup.factor b/basis/compiler/codegen/fixup/fixup.factor index dbe7c864a5..efdc02cc1f 100644 --- a/basis/compiler/codegen/fixup/fixup.factor +++ b/basis/compiler/codegen/fixup/fixup.factor @@ -1,10 +1,10 @@ -! Copyright (C) 2007, 2009 Slava Pestov. +! Copyright (C) 2007, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays byte-arrays byte-vectors generic assocs hashtables io.binary kernel kernel.private math namespaces make sequences words quotations strings alien.accessors alien.strings layouts system combinators math.bitwise math.order generalizations -accessors growable fry compiler.constants ; +accessors growable fry compiler.constants memoize ; IN: compiler.codegen.fixup ! Owner @@ -52,8 +52,11 @@ SYMBOL: relocation-table : rel-fixup ( class type -- ) swap compiled-offset add-relocation-entry ; +! Caching common symbol names reduces image size a bit +MEMO: cached-string>symbol ( symbol -- obj ) string>symbol ; + : add-dlsym-parameters ( symbol dll -- ) - [ string>symbol add-parameter ] [ add-parameter ] bi* ; + [ cached-string>symbol add-parameter ] [ add-parameter ] bi* ; : rel-dlsym ( name dll class -- ) [ add-dlsym-parameters ] dip rt-dlsym rel-fixup ; From 2aa4d3d4325f591a152d695a104a592466b7bdb3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 14 Jan 2010 02:18:49 +1300 Subject: [PATCH 46/72] vm: fix compilation on 64-bit platforms --- vm/master.hpp | 18 ++++++++++++++++++ vm/platform.hpp | 17 ----------------- 2 files changed, 18 insertions(+), 17 deletions(-) diff --git a/vm/master.hpp b/vm/master.hpp index 52fe702401..9a920efce7 100755 --- a/vm/master.hpp +++ b/vm/master.hpp @@ -30,6 +30,24 @@ #include #include +/* Detect target CPU type */ +#if defined(__arm__) + #define FACTOR_ARM +#elif defined(__amd64__) || defined(__x86_64__) + #define FACTOR_AMD64 + #define FACTOR_64 +#elif defined(i386) || defined(__i386) || defined(__i386__) || defined(WIN32) + #define FACTOR_X86 +#elif defined(__POWERPC__) || defined(__ppc__) || defined(_ARCH_PPC) + #define FACTOR_PPC +#else + #error "Unsupported architecture" +#endif + +#ifdef WIN32 + #define WINDOWS +#endif + /* Forward-declare this since it comes up in function prototypes */ namespace factor { diff --git a/vm/platform.hpp b/vm/platform.hpp index a3434e2ad0..96e19ad7f4 100644 --- a/vm/platform.hpp +++ b/vm/platform.hpp @@ -1,20 +1,3 @@ -#if defined(__arm__) - #define FACTOR_ARM -#elif defined(__amd64__) || defined(__x86_64__) - #define FACTOR_AMD64 - #define FACTOR_64 -#elif defined(i386) || defined(__i386) || defined(__i386__) || defined(WIN32) - #define FACTOR_X86 -#elif defined(__POWERPC__) || defined(__ppc__) || defined(_ARCH_PPC) - #define FACTOR_PPC -#else - #error "Unsupported architecture" -#endif - -#ifdef WIN32 - #define WINDOWS -#endif - #if defined(WINDOWS) #if defined(WINCE) #include "os-windows-ce.hpp" From 50d68c1b10cc42d7def89fae601a30e050da8028 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 14 Jan 2010 18:15:47 +1300 Subject: [PATCH 47/72] Fix input-classes of /i and mod, and add some regression tests with various reductions of the original test-case from the terrain demo --- basis/compiler/tests/optimizer.factor | 18 +++++++++++++--- .../known-words/known-words.factor | 7 +++---- .../tree/propagation/propagation-tests.factor | 2 ++ extra/alien/data/map/map-tests.factor | 10 ++++++++- extra/grid-meshes/grid-meshes-tests.factor | 21 +++++++++++++++++++ 5 files changed, 50 insertions(+), 8 deletions(-) create mode 100644 extra/grid-meshes/grid-meshes-tests.factor diff --git a/basis/compiler/tests/optimizer.factor b/basis/compiler/tests/optimizer.factor index 0831d6e8dd..04064e4427 100644 --- a/basis/compiler/tests/optimizer.factor +++ b/basis/compiler/tests/optimizer.factor @@ -4,7 +4,7 @@ sbufs strings tools.test vectors words sequences.private quotations classes classes.algebra classes.tuple.private continuations growable namespaces hints alien.accessors compiler.tree.builder compiler.tree.optimizer sequences.deep -compiler definitions generic.single shuffle ; +compiler definitions generic.single shuffle math.order ; IN: compiler.tests.optimizer GENERIC: xyz ( obj -- obj ) @@ -445,5 +445,17 @@ M: object bad-dispatch-position-test* ; [ 1024 bignum ] [ 10 [ 1 >bignum swap >fixnum shift ] compile-call dup class ] unit-test -! Not sure if I want to fix this... -! [ t [ [ f ] [ 3 ] if >fixnum ] compile-call ] [ no-method? ] must-fail-with +TUPLE: grid-mesh-tuple { length read-only } { step read-only } ; + +: grid-mesh-test-case ( -- vertices ) + 1.0 1.0 { 2 } first /f [ /i 1 + ] keep grid-mesh-tuple boa + 1 f + [ + [ drop length>> >fixnum 2 min ] 2keep + [ + [ step>> 1 * ] dip + 0 swap set-nth-unsafe + ] 2curry times + ] keep ; + +[ { 0.5 } ] [ grid-mesh-test-case ] unit-test diff --git a/basis/compiler/tree/propagation/known-words/known-words.factor b/basis/compiler/tree/propagation/known-words/known-words.factor index 0fde7ffa86..6aacbc57da 100644 --- a/basis/compiler/tree/propagation/known-words/known-words.factor +++ b/basis/compiler/tree/propagation/known-words/known-words.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008, 2009 Slava Pestov. +! Copyright (C) 2008, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel effects accessors math math.private math.integers.private math.floats.private math.partial-dispatch @@ -23,11 +23,10 @@ IN: compiler.tree.propagation.known-words { + - * / } [ { number number } "input-classes" set-word-prop ] each -{ /f < > <= >= u< u> u<= u>= } +{ /f /i mod < > <= >= u< u> u<= u>= } [ { real real } "input-classes" set-word-prop ] each -{ /i mod /mod } -[ { rational rational } "input-classes" set-word-prop ] each +\ /mod { rational rational } "input-classes" set-word-prop { bitand bitor bitxor bitnot shift } [ { integer integer } "input-classes" set-word-prop ] each diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor index f8a53b3287..9be76ba0d0 100644 --- a/basis/compiler/tree/propagation/propagation-tests.factor +++ b/basis/compiler/tree/propagation/propagation-tests.factor @@ -90,6 +90,8 @@ IN: compiler.tree.propagation.tests [ float ] [ [ { float float } declare mod ] final-math-class ] unit-test +[ V{ integer float } ] [ [ { float float } declare [ /i ] keep ] final-classes ] unit-test + [ V{ fixnum } ] [ [ 255 bitand ] final-classes ] unit-test [ V{ fixnum } ] [ diff --git a/extra/alien/data/map/map-tests.factor b/extra/alien/data/map/map-tests.factor index b97a356e6e..305ae6bdf2 100644 --- a/extra/alien/data/map/map-tests.factor +++ b/extra/alien/data/map/map-tests.factor @@ -1,6 +1,6 @@ ! (c)Joe Groff bsd license USING: alien.data.map fry generalizations kernel locals math.vectors -math.vectors.conversion math math.vectors.simd sequences +math.vectors.conversion math math.vectors.simd math.ranges sequences specialized-arrays tools.test ; FROM: alien.c-types => uchar short int float ; SPECIALIZED-ARRAYS: int float float-4 uchar-16 ; @@ -145,3 +145,11 @@ CONSTANT: plane-count 4 B{ 15 25 35 45 55 65 75 85 95 105 115 125 135 145 155 165 } fold-rgba-planes ] unit-test + +: data-map-compiler-bug-test ( n -- byte-array ) + [ 0.0 1.0 1.0 ] dip /f + [ ] data-map( object -- float ) ; + +[ float-array{ 0.0 0.5 1.0 } ] +[ 2 data-map-compiler-bug-test byte-array>float-array ] +unit-test diff --git a/extra/grid-meshes/grid-meshes-tests.factor b/extra/grid-meshes/grid-meshes-tests.factor new file mode 100644 index 0000000000..ef71a669ed --- /dev/null +++ b/extra/grid-meshes/grid-meshes-tests.factor @@ -0,0 +1,21 @@ +IN: grid-meshes.tests +USING: alien.c-types grid-meshes grid-meshes.private +specialized-arrays tools.test ; +SPECIALIZED-ARRAY: float + +[ + float-array{ + 0.0 0.0 0.0 1.0 + 0.0 0.0 0.5 1.0 + 0.5 0.0 0.0 1.0 + 0.5 0.0 0.5 1.0 + 1.0 0.0 0.0 1.0 + 1.0 0.0 0.5 1.0 + 0.0 0.0 0.5 1.0 + 0.0 0.0 1.0 1.0 + 0.5 0.0 0.5 1.0 + 0.5 0.0 1.0 1.0 + 1.0 0.0 0.5 1.0 + 1.0 0.0 1.0 1.0 + } +] [ { 2 2 } vertex-array byte-array>float-array ] unit-test From f7f67c57a3f20020490f87a520e05236465a742d Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 14 Jan 2010 11:18:10 -0600 Subject: [PATCH 48/72] use clamp --- basis/images/processing/processing.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/images/processing/processing.factor b/basis/images/processing/processing.factor index cd6754550d..463337e653 100644 --- a/basis/images/processing/processing.factor +++ b/basis/images/processing/processing.factor @@ -16,7 +16,7 @@ IN: images.processing : matrix>image ( m -- image ) over matrix-dim >>dim swap flip flatten - [ 128 * 128 + 0 max 255 min >fixnum ] map + [ 128 * 128 + 0 255 clamp >fixnum ] map >byte-array >>bitmap L >>component-order ubyte-components >>component-type ; :: matrix-zoom ( m f -- m' ) @@ -30,7 +30,7 @@ IN: images.processing :: draw-grey ( value x,y image -- ) x,y image image-offset 3 * { 0 1 2 } [ - + value 128 + >fixnum 0 max 255 min swap image bitmap>> set-nth + + value 128 + >fixnum 0 255 clamp swap image bitmap>> set-nth ] with each ; :: draw-color ( value x,y color-id image -- ) From df4fb4a3ee836aac0f41e3ea026d64517bdcc3ec Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 15 Jan 2010 04:10:13 +1300 Subject: [PATCH 49/72] Removing integers-as-sequences --- basis/base64/base64.factor | 5 ++- .../binary-search/binary-search-tests.factor | 4 +- basis/bit-arrays/bit-arrays-tests.factor | 4 +- basis/bit-arrays/bit-arrays.factor | 6 +-- basis/bit-vectors/bit-vectors-tests.factor | 2 +- basis/calendar/calendar-tests.factor | 2 +- basis/calendar/format/format.factor | 6 +-- basis/checksums/sha/sha.factor | 4 +- .../bit-accessors/bit-accessors-tests.factor | 7 +-- basis/cocoa/messages/messages.factor | 4 +- basis/columns/columns-tests.factor | 2 + basis/columns/columns.factor | 4 +- basis/combinators/smart/smart.factor | 28 +++++++----- .../cfg/instructions/syntax/syntax.factor | 6 +-- .../cfg/intrinsics/allot/allot.factor | 4 +- basis/compiler/cfg/stacks/stacks.factor | 4 +- .../stacks/uninitialized/uninitialized.factor | 4 +- basis/compiler/codegen/codegen.factor | 2 +- basis/compiler/tests/alien.factor | 6 +-- basis/compiler/tests/codegen.factor | 4 +- basis/compiler/tests/intrinsics.factor | 2 +- basis/compiler/tests/optimizer.factor | 6 +-- .../tree/cleanup/cleanup-tests.factor | 15 +++---- .../tree/dead-code/branches/branches.factor | 4 +- .../tree/dead-code/recursive/recursive.factor | 6 +-- .../tree/dead-code/simple/simple.factor | 4 +- basis/compiler/tree/debugger/debugger.factor | 2 +- .../recursive/recursive-tests.factor | 4 +- .../modular-arithmetic-tests.factor | 4 +- .../tree/normalization/normalization.factor | 9 ++-- .../call-effect/call-effect.factor | 10 ++--- .../tree/propagation/info/info-tests.factor | 7 --- .../tree/propagation/propagation-tests.factor | 10 +---- .../tree/propagation/simple/simple.factor | 2 +- .../propagation/transforms/transforms.factor | 6 +-- basis/compression/inflate/inflate.factor | 12 +++--- .../combinators/combinators-tests.factor | 8 ++-- basis/db/db.factor | 4 +- basis/db/queries/queries.factor | 2 +- basis/db/tester/tester.factor | 6 +-- basis/farkup/farkup-tests.factor | 4 +- basis/fry/fry-tests.factor | 2 +- .../generalizations-tests.factor | 2 +- basis/heaps/heaps-tests.factor | 10 ++--- basis/hints/hints.factor | 4 +- basis/inspector/inspector.factor | 6 +-- basis/inverse/inverse.factor | 6 +-- basis/io/encodings/iso2022/iso2022.factor | 2 +- basis/io/files/links/unix/unix-tests.factor | 2 +- basis/io/files/unique/unique.factor | 8 ++-- basis/lcs/diff2html/diff2html-tests.factor | 2 +- basis/lcs/diff2html/diff2html.factor | 2 +- basis/lcs/lcs.factor | 8 ++-- basis/macros/expander/expander.factor | 2 +- .../combinatorics/combinatorics-tests.factor | 2 +- basis/math/combinatorics/combinatorics.factor | 8 ++-- basis/math/intervals/intervals-tests.factor | 14 +++--- .../matrices/elimination/elimination.factor | 8 ++-- basis/math/matrices/matrices.factor | 4 +- basis/math/polynomials/polynomials.factor | 2 +- .../miller-rabin/miller-rabin-tests.factor | 2 +- .../primes/miller-rabin/miller-rabin.factor | 2 +- basis/math/primes/primes.factor | 2 +- basis/math/vectors/simd/cords/cords.factor | 2 +- .../vectors/simd/intrinsics/intrinsics.factor | 2 +- basis/math/vectors/simd/simd-tests.factor | 23 +++++----- basis/math/vectors/simd/simd.factor | 2 +- basis/models/arrow/smart/smart.factor | 7 +-- .../nibble-arrays/nibble-arrays-tests.factor | 2 +- basis/peg/ebnf/ebnf.factor | 4 +- .../hashtables/hashtables-tests.factor | 2 +- basis/persistent/vectors/vectors-tests.factor | 14 +++--- basis/porter-stemmer/porter-stemmer.factor | 4 +- basis/prettyprint/sections/sections.factor | 4 +- .../mersenne-twister-tests.factor | 10 ++--- .../mersenne-twister/mersenne-twister.factor | 6 +-- basis/random/random-tests.factor | 8 ++-- basis/regexp/disambiguate/disambiguate.factor | 4 +- basis/roman/roman.factor | 5 +-- basis/serialize/serialize-tests.factor | 12 +++--- basis/serialize/serialize.factor | 2 +- basis/shuffle/shuffle.factor | 2 +- basis/sorting/insertion/insertion.factor | 2 +- basis/splitting/monotonic/monotonic.factor | 2 +- .../errors/prettyprint/prettyprint.factor | 6 +-- basis/stack-checker/inlining/inlining.factor | 4 +- .../known-words/known-words.factor | 2 +- .../stack-checker/stack-checker-tests.factor | 8 ++-- basis/stack-checker/state/state.factor | 6 ++- basis/strings/tables/tables.factor | 4 +- basis/suffix-arrays/suffix-arrays.factor | 2 +- basis/threads/threads-tests.factor | 4 +- basis/tr/tr.factor | 4 +- basis/tuple-arrays/tuple-arrays.factor | 4 +- basis/ui/gadgets/gadgets-tests.factor | 2 +- basis/ui/gadgets/packs/packs-tests.factor | 4 +- basis/ui/gadgets/panes/panes-tests.factor | 2 +- .../gadgets/scrollers/scrollers-tests.factor | 2 +- basis/ui/gadgets/slots/slots-tests.factor | 2 +- basis/unicode/breaks/breaks-tests.factor | 9 +++- basis/unicode/breaks/breaks.factor | 16 +++---- basis/unicode/collation/collation.factor | 2 +- basis/unicode/data/data.factor | 3 +- basis/unix/unix.factor | 15 ++++--- .../unrolled-lists-tests.factor | 14 +++--- basis/xml/tests/xmltest.factor | 16 +++---- basis/xml/tokenize/tokenize.factor | 2 +- core/assocs/assocs.factor | 4 +- core/byte-vectors/byte-vectors-tests.factor | 4 +- core/classes/algebra/algebra-tests.factor | 5 +-- core/continuations/continuations-tests.factor | 2 +- core/effects/effects-docs.factor | 2 +- core/effects/effects-tests.factor | 10 ++--- core/effects/effects.factor | 43 +++++++++---------- core/hashtables/hashtables-tests.factor | 10 ++--- core/io/encodings/utf8/utf8-tests.factor | 2 +- core/math/floats/floats-tests.factor | 2 +- core/math/integers/integers-tests.factor | 6 +-- core/sbufs/sbufs-tests.factor | 2 +- core/sequences/sequences-docs.factor | 9 ++-- core/sequences/sequences-tests.factor | 28 ++++++------ core/sequences/sequences.factor | 18 +++----- core/sorting/sorting-tests.factor | 6 +-- core/source-files/errors/errors.factor | 2 +- core/strings/strings-tests.factor | 2 +- core/vectors/vectors-tests.factor | 6 +-- extra/benchmark/iteration/iteration.factor | 2 +- .../bloom-filters/bloom-filters-tests.factor | 6 +-- extra/crypto/aes/aes.factor | 6 +-- extra/decimals/decimals-tests.factor | 10 ++--- extra/html/parser/analyzer/analyzer.factor | 4 +- extra/id3/id3-tests.factor | 2 +- extra/jamshred/tunnel/tunnel.factor | 2 +- extra/koszul/koszul.factor | 14 +++--- extra/math/analysis/analysis.factor | 2 +- extra/math/text/english/english.factor | 2 +- extra/memory/pools/pools.factor | 6 +-- extra/multi-methods/multi-methods.factor | 4 +- .../partial-continuations-tests.factor | 2 +- extra/project-euler/011/011.factor | 4 +- extra/project-euler/014/014.factor | 4 +- extra/project-euler/024/024.factor | 5 ++- extra/project-euler/032/032.factor | 2 +- extra/project-euler/043/043.factor | 16 +++---- extra/project-euler/052/052.factor | 2 +- extra/project-euler/053/053.factor | 2 +- extra/project-euler/150/150.factor | 6 +-- extra/project-euler/151/151.factor | 2 +- extra/project-euler/164/164.factor | 2 +- extra/project-euler/common/common.factor | 2 +- extra/slides/slides.factor | 4 +- .../smalltalk/compiler/compiler-tests.factor | 2 +- extra/smalltalk/selectors/selectors.factor | 10 ++--- extra/tetris/board/board.factor | 6 +-- extra/trees/splay/splay-tests.factor | 4 +- 155 files changed, 435 insertions(+), 450 deletions(-) diff --git a/basis/base64/base64.factor b/basis/base64/base64.factor index eb2c9193a3..1a0648cef8 100644 --- a/basis/base64/base64.factor +++ b/basis/base64/base64.factor @@ -13,7 +13,8 @@ ERROR: malformed-base64 ; read1 2dup swap member? [ drop read1-ignoring ] [ nip ] if ; : read-ignoring ( ignoring n -- str ) - [ drop read1-ignoring ] with map harvest + [ drop read1-ignoring ] with { } map-integers + [ { f 0 } member? not ] filter [ f ] [ >string ] if-empty ; : ch>base64 ( ch -- ch ) @@ -42,7 +43,7 @@ SYMBOL: column [ write1-lines ] each ; : encode3 ( seq -- ) - be> 4 [ + be> 4 iota [ -6 * shift HEX: 3f bitand ch>base64 write1-lines ] with each ; inline diff --git a/basis/binary-search/binary-search-tests.factor b/basis/binary-search/binary-search-tests.factor index f2ea7503f4..a797219a01 100644 --- a/basis/binary-search/binary-search-tests.factor +++ b/basis/binary-search/binary-search-tests.factor @@ -1,4 +1,4 @@ -USING: binary-search math.order vectors kernel tools.test ; +USING: binary-search math.order sequences kernel tools.test ; IN: binary-search.tests [ f ] [ 3 { } [ <=> ] with search drop ] unit-test @@ -7,7 +7,7 @@ IN: binary-search.tests [ 3 ] [ 4 { 1 2 3 4 5 6 } [ <=> ] with search drop ] unit-test [ 2 ] [ 3.5 { 1 2 3 4 5 6 7 8 } [ <=> ] with search drop ] unit-test [ 4 ] [ 5.5 { 1 2 3 4 5 6 7 8 } [ <=> ] with search drop ] unit-test -[ 10 ] [ 10 20 >vector [ <=> ] with search drop ] unit-test +[ 10 ] [ 10 20 iota [ <=> ] with search drop ] unit-test [ t ] [ "hello" { "alligator" "cat" "fish" "hello" "ikarus" "java" } sorted-member? ] unit-test [ 3 ] [ "hey" { "alligator" "cat" "fish" "hello" "ikarus" "java" } sorted-index ] unit-test diff --git a/basis/bit-arrays/bit-arrays-tests.factor b/basis/bit-arrays/bit-arrays-tests.factor index 7397791ab5..fbf0d4b639 100644 --- a/basis/bit-arrays/bit-arrays-tests.factor +++ b/basis/bit-arrays/bit-arrays-tests.factor @@ -38,9 +38,9 @@ IN: bit-arrays.tests [ t ] [ 100 [ - drop 100 [ 2 random zero? ] replicate + drop 100 [ 2 iota random zero? ] replicate dup >bit-array >array = - ] all? + ] all-integers? ] unit-test [ ?{ f } ] [ diff --git a/basis/bit-arrays/bit-arrays.factor b/basis/bit-arrays/bit-arrays.factor index f5613da6b5..4fafc528fd 100644 --- a/basis/bit-arrays/bit-arrays.factor +++ b/basis/bit-arrays/bit-arrays.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2007, 2008 Slava Pestov. +! Copyright (C) 2007, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: alien.c-types alien.data accessors math alien.accessors kernel kernel.private sequences sequences.private byte-arrays @@ -25,7 +25,7 @@ TUPLE: bit-array : (set-bits) ( bit-array n -- ) [ [ length bits>cells ] keep ] dip swap underlying>> - '[ 2 shift [ _ _ ] dip set-alien-unsigned-4 ] each ; inline + '[ 2 shift [ _ _ ] dip set-alien-unsigned-4 ] each-integer ; inline : clean-up ( bit-array -- ) ! Zero bits after the end. @@ -99,7 +99,7 @@ SYNTAX: ?{ \ } [ >bit-array ] parse-literal ; ] if ; : bit-array>integer ( bit-array -- n ) - 0 swap underlying>> dup length [ + 0 swap underlying>> dup length iota [ alien-unsigned-1 swap 8 shift bitor ] with each ; diff --git a/basis/bit-vectors/bit-vectors-tests.factor b/basis/bit-vectors/bit-vectors-tests.factor index 5af44b59f7..a8a856ffd0 100644 --- a/basis/bit-vectors/bit-vectors-tests.factor +++ b/basis/bit-vectors/bit-vectors-tests.factor @@ -4,7 +4,7 @@ IN: bit-vectors.tests [ 0 ] [ 123 length ] unit-test : do-it ( seq -- ) - 1234 swap [ [ even? ] dip push ] curry each ; + 1234 swap [ [ even? ] dip push ] curry each-integer ; [ t ] [ 3 dup do-it diff --git a/basis/calendar/calendar-tests.factor b/basis/calendar/calendar-tests.factor index 2490b87c37..eb565a18d4 100644 --- a/basis/calendar/calendar-tests.factor +++ b/basis/calendar/calendar-tests.factor @@ -175,4 +175,4 @@ IN: calendar.tests [ t ] [ 1325376000 unix-time>timestamp 2012 = ] unit-test [ t ] [ 1356998399 unix-time>timestamp 2013 1 seconds time- = ] unit-test -[ t ] [ 1500000000 random [ unix-time>timestamp timestamp>unix-time ] keep = ] unit-test +[ t ] [ 1500000000 iota random [ unix-time>timestamp timestamp>unix-time ] keep = ] unit-test diff --git a/basis/calendar/format/format.factor b/basis/calendar/format/format.factor index d07d74722a..96d76d0ce8 100644 --- a/basis/calendar/format/format.factor +++ b/basis/calendar/format/format.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2010 Slava Pestov, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: math math.order math.parser math.functions kernel sequences io accessors arrays io.streams.string splitting @@ -70,7 +70,7 @@ M: array month. ( pair -- ) [ [ 1 + day. ] keep 1 + + 7 mod zero? [ nl ] [ bl ] if - ] with each nl ; + ] with each-integer nl ; M: timestamp month. ( timestamp -- ) [ year>> ] [ month>> ] bi 2array month. ; @@ -78,7 +78,7 @@ M: timestamp month. ( timestamp -- ) GENERIC: year. ( obj -- ) M: integer year. ( n -- ) - 12 [ 1 + 2array month. nl ] with each ; + 12 [ 1 + 2array month. nl ] with each-integer ; M: timestamp year. ( timestamp -- ) year>> year. ; diff --git a/basis/checksums/sha/sha.factor b/basis/checksums/sha/sha.factor index 35262bb0b0..ba85add03c 100644 --- a/basis/checksums/sha/sha.factor +++ b/basis/checksums/sha/sha.factor @@ -301,7 +301,7 @@ GENERIC: pad-initial-bytes ( string sha2 -- padded-string ) M cloned-H sha2 T1-256 cloned-H T2-256 cloned-H update-H - ] each + ] each-integer sha2 [ cloned-H [ w+ ] 2map ] change-H drop ; inline M: sha2-short checksum-block @@ -391,7 +391,7 @@ M: sha-256 checksum-stream ( stream checksum -- byte-array ) b H nth-unsafe 30 bitroll-32 c H set-nth-unsafe a H nth-unsafe b H set-nth-unsafe a H set-nth-unsafe - ] each + ] each-integer state [ H [ w+ ] 2map ] change-H drop ; inline M:: sha1-state checksum-block ( bytes state -- ) diff --git a/basis/classes/struct/bit-accessors/bit-accessors-tests.factor b/basis/classes/struct/bit-accessors/bit-accessors-tests.factor index e2ff6dbd9c..037b316363 100644 --- a/basis/classes/struct/bit-accessors/bit-accessors-tests.factor +++ b/basis/classes/struct/bit-accessors/bit-accessors-tests.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2009 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. -USING: classes.struct.bit-accessors tools.test effects kernel random stack-checker ; +USING: classes.struct.bit-accessors tools.test effects kernel +sequences random stack-checker ; IN: classes.struct.bit-accessors.test -[ t ] [ 20 random 20 random bit-reader infer (( alien -- n )) effect= ] unit-test -[ t ] [ 20 random 20 random bit-writer infer (( n alien -- )) effect= ] unit-test +[ t ] [ 20 iota random 20 iota random bit-reader infer (( alien -- n )) effect= ] unit-test +[ t ] [ 20 iota random 20 iota random bit-writer infer (( n alien -- )) effect= ] unit-test diff --git a/basis/cocoa/messages/messages.factor b/basis/cocoa/messages/messages.factor index 4cc9554d3c..02e6335c54 100644 --- a/basis/cocoa/messages/messages.factor +++ b/basis/cocoa/messages/messages.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2006, 2009 Slava Pestov. +! Copyright (C) 2006, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors alien alien.c-types alien.strings arrays assocs classes.struct continuations combinators compiler compiler.alien @@ -202,7 +202,7 @@ ERROR: no-objc-type name ; (free) ; : method-arg-types ( method -- args ) - dup method_getNumberOfArguments + dup method_getNumberOfArguments iota [ method-arg-type ] with map ; : method-return-type ( method -- ctype ) diff --git a/basis/columns/columns-tests.factor b/basis/columns/columns-tests.factor index 434c233936..c0e0956709 100644 --- a/basis/columns/columns-tests.factor +++ b/basis/columns/columns-tests.factor @@ -7,3 +7,5 @@ IN: columns.tests [ { 1 4 7 } ] [ "seq" get 0 >array ] unit-test [ ] [ "seq" get 1 [ sq ] map! drop ] unit-test [ { 4 25 64 } ] [ "seq" get 1 >array ] unit-test + +[ { { 1 3 } { 2 4 } } ] [ { { 1 2 } { 3 4 } } [ >array ] map ] unit-test diff --git a/basis/columns/columns.factor b/basis/columns/columns.factor index 8674217655..c36505ab6d 100644 --- a/basis/columns/columns.factor +++ b/basis/columns/columns.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2005, 2008 Slava Pestov, Daniel Ehrenberg. +! Copyright (C) 2005, 2010 Slava Pestov, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: sequences kernel accessors ; IN: columns @@ -15,4 +15,4 @@ M: column length seq>> length ; INSTANCE: column virtual-sequence : ( seq -- seq' ) - dup empty? [ dup first length [ ] with map ] unless ; + dup empty? [ dup first length [ ] with { } map-integers ] unless ; diff --git a/basis/combinators/smart/smart.factor b/basis/combinators/smart/smart.factor index 91987e0dfa..e423bf84f8 100644 --- a/basis/combinators/smart/smart.factor +++ b/basis/combinators/smart/smart.factor @@ -4,50 +4,58 @@ USING: accessors fry generalizations kernel macros math.order stack-checker math sequences ; IN: combinators.smart +> length ; + +: outputs ( quot -- n ) infer out>> length ; + +PRIVATE> + MACRO: drop-outputs ( quot -- quot' ) - dup infer out>> '[ @ _ ndrop ] ; + dup outputs '[ @ _ ndrop ] ; MACRO: keep-inputs ( quot -- quot' ) - dup infer in>> '[ _ _ nkeep ] ; + dup inputs '[ _ _ nkeep ] ; MACRO: output>sequence ( quot exemplar -- newquot ) - [ dup infer out>> ] dip + [ dup outputs ] dip '[ @ _ _ nsequence ] ; MACRO: output>array ( quot -- newquot ) '[ _ { } output>sequence ] ; MACRO: input> ] keep + [ inputs ] keep '[ _ firstn @ ] ; MACRO: input> ] keep + [ inputs ] keep '[ _ firstn-unsafe @ ] ; MACRO: reduce-outputs ( quot operation -- newquot ) - [ dup infer out>> 1 [-] ] dip n*quot compose ; + [ dup outputs 1 [-] ] dip n*quot compose ; MACRO: sum-outputs ( quot -- n ) '[ _ [ + ] reduce-outputs ] ; MACRO: map-reduce-outputs ( quot mapper reducer -- newquot ) - [ dup infer out>> ] 2dip + [ dup outputs ] 2dip [ swap '[ _ _ napply ] ] [ [ 1 [-] ] dip n*quot ] bi-curry* bi '[ @ @ @ ] ; MACRO: append-outputs-as ( quot exemplar -- newquot ) - [ dup infer out>> ] dip '[ @ _ _ nappend-as ] ; + [ dup outputs ] dip '[ @ _ _ nappend-as ] ; MACRO: append-outputs ( quot -- seq ) '[ _ { } append-outputs-as ] ; MACRO: preserving ( quot -- ) - [ infer in>> length ] keep '[ _ ndup @ ] ; + [ inputs ] keep '[ _ ndup @ ] ; MACRO: nullary ( quot -- quot' ) - dup infer out>> length '[ @ _ ndrop ] ; + dup outputs '[ @ _ ndrop ] ; MACRO: smart-if ( pred true false -- ) '[ _ preserving _ _ if ] ; inline diff --git a/basis/compiler/cfg/instructions/syntax/syntax.factor b/basis/compiler/cfg/instructions/syntax/syntax.factor index bca5e1ee64..cd76652d06 100644 --- a/basis/compiler/cfg/instructions/syntax/syntax.factor +++ b/basis/compiler/cfg/instructions/syntax/syntax.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008, 2009 Slava Pestov. +! Copyright (C) 2008, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: classes.tuple classes.tuple.parser kernel words make fry sequences parser accessors effects namespaces @@ -61,14 +61,14 @@ TUPLE: insn-slot-spec type name rep ; "pure-insn" "compiler.cfg.instructions" lookup ; : insn-effect ( word -- effect ) - boa-effect in>> but-last f ; + boa-effect in>> but-last { } ; : define-insn-tuple ( class superclass specs -- ) [ name>> ] map "insn#" suffix define-tuple-class ; : define-insn-ctor ( class specs -- ) [ dup '[ _ ] [ f ] [ boa , ] surround ] dip - [ name>> ] map f define-declared ; + [ name>> ] map { } define-declared ; : define-insn ( class superclass specs -- ) parse-insn-slot-specs { diff --git a/basis/compiler/cfg/intrinsics/allot/allot.factor b/basis/compiler/cfg/intrinsics/allot/allot.factor index 9804244ecb..31a8a898bc 100644 --- a/basis/compiler/cfg/intrinsics/allot/allot.factor +++ b/basis/compiler/cfg/intrinsics/allot/allot.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008, 2009 Slava Pestov. +! Copyright (C) 2008, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel math math.order sequences accessors arrays byte-arrays layouts classes.tuple.private fry locals @@ -34,7 +34,7 @@ IN: compiler.cfg.intrinsics.allot [ [ ^^load-literal ] dip 1 ] dip type-number ##set-slot-imm ; :: store-initial-element ( len reg elt class -- ) - len [ [ elt reg ] dip 2 + class type-number ##set-slot-imm ] each ; + len [ [ elt reg ] dip 2 + class type-number ##set-slot-imm ] each-integer ; : expand-? ( obj -- ? ) dup integer? [ 0 8 between? ] [ drop f ] if ; diff --git a/basis/compiler/cfg/stacks/stacks.factor b/basis/compiler/cfg/stacks/stacks.factor index ce673ba5bb..6cf362c230 100644 --- a/basis/compiler/cfg/stacks/stacks.factor +++ b/basis/compiler/cfg/stacks/stacks.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008, 2009 Slava Pestov. +! Copyright (C) 2008, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: math sequences kernel namespaces accessors biassocs compiler.cfg compiler.cfg.instructions compiler.cfg.registers compiler.cfg.hats @@ -33,7 +33,7 @@ IN: compiler.cfg.stacks : ds-load ( n -- vregs ) dup 0 = [ drop f ] - [ [ [ peek-loc ] map ] [ neg inc-d ] bi ] if ; + [ [ iota [ peek-loc ] map ] [ neg inc-d ] bi ] if ; : ds-store ( vregs -- ) [ diff --git a/basis/compiler/cfg/stacks/uninitialized/uninitialized.factor b/basis/compiler/cfg/stacks/uninitialized/uninitialized.factor index 0bed759e52..e5fbfa6c40 100644 --- a/basis/compiler/cfg/stacks/uninitialized/uninitialized.factor +++ b/basis/compiler/cfg/stacks/uninitialized/uninitialized.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2009 Slava Pestov. +! Copyright (C) 2009, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences byte-arrays namespaces accessors classes math math.order fry arrays combinators compiler.cfg.registers @@ -55,7 +55,7 @@ M: insn visit-insn drop ; 2dup [ length ] bi@ max '[ _ 1 pad-tail ] bi@ [ bitand ] 2map ; : (uninitialized-locs) ( seq quot -- seq' ) - [ dup length [ drop 0 = ] pusher [ 2each ] dip ] dip map ; inline + [ [ drop 0 = ] pusher [ each-index ] dip ] dip map ; inline PRIVATE> diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index d408c722ff..ef6794e9fa 100644 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -380,7 +380,7 @@ M: c-type-name flatten-value-type c-type flatten-value-type ; [ [ parameter-offsets nip ] keep ] dip 2reverse-each ; inline : prepare-unbox-parameters ( parameters -- offsets types indices ) - [ parameter-offsets nip ] [ ] [ length iota reverse ] tri ; + [ parameter-offsets nip ] [ ] [ length iota ] tri ; : unbox-parameters ( offset node -- ) parameters>> swap diff --git a/basis/compiler/tests/alien.factor b/basis/compiler/tests/alien.factor index 5e49e2d28d..4cfbe8f6fa 100644 --- a/basis/compiler/tests/alien.factor +++ b/basis/compiler/tests/alien.factor @@ -164,7 +164,7 @@ FUNCTION: void ffi_test_20 double x1, double x2, double x3, { int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int } alien-invoke gc 3 ; -[ 861 3 ] [ 42 [ ] each ffi_test_31 ] unit-test +[ 861 3 ] [ 42 [ ] each-integer ffi_test_31 ] unit-test : ffi_test_31_point_5 ( a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a -- result ) float @@ -172,7 +172,7 @@ FUNCTION: void ffi_test_20 double x1, double x2, double x3, { float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float } alien-invoke ; -[ 861.0 ] [ 42 [ >float ] each ffi_test_31_point_5 ] unit-test +[ 861.0 ] [ 42 [ >float ] each-integer ffi_test_31_point_5 ] unit-test FUNCTION: longlong ffi_test_21 long x long y ; @@ -316,7 +316,7 @@ FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ; : callback-1 ( -- callback ) void { } "cdecl" [ ] alien-callback ; -[ 0 1 ] [ [ callback-1 ] infer [ in>> ] [ out>> ] bi ] unit-test +[ 0 1 ] [ [ callback-1 ] infer [ in>> length ] [ out>> length ] bi ] unit-test [ t ] [ callback-1 alien? ] unit-test diff --git a/basis/compiler/tests/codegen.factor b/basis/compiler/tests/codegen.factor index eba6580574..cff685eaf6 100644 --- a/basis/compiler/tests/codegen.factor +++ b/basis/compiler/tests/codegen.factor @@ -116,7 +116,7 @@ unit-test 1 1.0 2.5 try-breaking-dispatch "bye" = [ 3.5 = ] dip and ; [ t ] [ - 10000000 [ drop try-breaking-dispatch-2 ] all? + 10000000 [ drop try-breaking-dispatch-2 ] all-integers? ] unit-test ! Regression @@ -314,7 +314,7 @@ cell 4 = [ ! Bug with ##return node construction : return-recursive-bug ( nodes -- ? ) - { fixnum } declare [ + { fixnum } declare iota [ dup 3 bitand 1 = [ drop t ] [ dup 3 bitand 2 = [ return-recursive-bug diff --git a/basis/compiler/tests/intrinsics.factor b/basis/compiler/tests/intrinsics.factor index 37b3a75071..0ec84eb991 100644 --- a/basis/compiler/tests/intrinsics.factor +++ b/basis/compiler/tests/intrinsics.factor @@ -337,7 +337,7 @@ ERROR: bug-in-fixnum* x y a b ; [ ] [ 10000 [ - 5 random [ drop 32 random-bits ] map product >bignum + 5 iota random iota [ drop 32 random-bits ] map product >bignum dup [ bignum>fixnum ] keep compiled-bignum>fixnum = [ drop ] [ "Oops" throw ] if ] times diff --git a/basis/compiler/tests/optimizer.factor b/basis/compiler/tests/optimizer.factor index 04064e4427..865cd639a3 100644 --- a/basis/compiler/tests/optimizer.factor +++ b/basis/compiler/tests/optimizer.factor @@ -90,7 +90,7 @@ TUPLE: pred-test ; : double-label-2 ( a -- b ) dup array? [ ] [ ] if 0 t double-label-1 ; -[ 0 ] [ 10 double-label-2 ] unit-test +[ 0 ] [ 10 iota double-label-2 ] unit-test ! regression GENERIC: void-generic ( obj -- * ) @@ -208,7 +208,7 @@ USE: binary-search.private ] if ; inline recursive [ 10 ] [ - 10 20 >vector + 10 20 iota [ [ - ] swap old-binsearch ] compile-call 2nip ] unit-test @@ -349,7 +349,7 @@ TUPLE: some-tuple x ; [ 5 ] [ { 1 2 { 3 { 4 5 } } } deep-find-test ] unit-test [ f ] [ { 1 2 { 3 { 4 } } } deep-find-test ] unit-test -[ B{ 0 1 2 3 4 5 6 7 } ] [ [ 8 [ ] B{ } map-as ] compile-call ] unit-test +[ B{ 0 1 2 3 4 5 6 7 } ] [ [ 8 iota [ ] B{ } map-as ] compile-call ] unit-test [ 0 ] [ 1234 [ { fixnum } declare -64 shift ] compile-call ] unit-test diff --git a/basis/compiler/tree/cleanup/cleanup-tests.factor b/basis/compiler/tree/cleanup/cleanup-tests.factor index db96086371..05f9092ee1 100644 --- a/basis/compiler/tree/cleanup/cleanup-tests.factor +++ b/basis/compiler/tree/cleanup/cleanup-tests.factor @@ -339,28 +339,23 @@ cell-bits 32 = [ ] unit-test [ t ] [ - [ { fixnum } declare length [ drop ] each-integer ] + [ { fixnum } declare iota [ drop ] each ] { < <-integer-fixnum +-integer-fixnum + } inlined? ] unit-test [ t ] [ - [ { fixnum } declare [ drop ] each ] - { < <-integer-fixnum +-integer-fixnum + } inlined? -] unit-test - -[ t ] [ - [ { fixnum } declare 0 [ + ] reduce ] + [ { fixnum } declare iota 0 [ + ] reduce ] { < <-integer-fixnum nth-unsafe } inlined? ] unit-test [ f ] [ - [ { fixnum } declare 0 [ + ] reduce ] + [ { fixnum } declare iota 0 [ + ] reduce ] \ +-integer-fixnum inlined? ] unit-test [ f ] [ [ - { integer } declare [ ] map + { integer } declare iota [ ] map ] \ >fixnum inlined? ] unit-test @@ -403,7 +398,7 @@ cell-bits 32 = [ [ t ] [ [ - { integer } declare [ 0 >= ] map + { integer } declare iota [ 0 >= ] map ] { >= fixnum>= } inlined? ] unit-test diff --git a/basis/compiler/tree/dead-code/branches/branches.factor b/basis/compiler/tree/dead-code/branches/branches.factor index 6cef45a9c9..d1fdf6359a 100644 --- a/basis/compiler/tree/dead-code/branches/branches.factor +++ b/basis/compiler/tree/dead-code/branches/branches.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: sequences namespaces kernel accessors assocs sets fry arrays combinators columns stack-checker.backend @@ -36,7 +36,7 @@ M: #branch remove-dead-code* : drop-indexed-values ( values indices -- node ) [ drop filter-live ] [ swap nths ] 2bi - [ make-values ] keep + [ length make-values ] keep [ drop ] [ zip ] 2bi #data-shuffle ; diff --git a/basis/compiler/tree/dead-code/recursive/recursive.factor b/basis/compiler/tree/dead-code/recursive/recursive.factor index 482d370947..0c9464374a 100644 --- a/basis/compiler/tree/dead-code/recursive/recursive.factor +++ b/basis/compiler/tree/dead-code/recursive/recursive.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays assocs sequences kernel locals fry combinators stack-checker.backend @@ -24,7 +24,7 @@ M: #call-recursive compute-live-values* :: drop-dead-inputs ( inputs outputs -- #shuffle ) inputs filter-live - outputs inputs filter-corresponding make-values + outputs inputs filter-corresponding length make-values outputs inputs drop-values ; @@ -39,7 +39,7 @@ M: #enter-recursive remove-dead-code* 2bi ; :: (drop-call-recursive-outputs) ( inputs outputs -- #shuffle ) - inputs outputs filter-corresponding make-values :> new-live-outputs + inputs outputs filter-corresponding length make-values :> new-live-outputs outputs filter-live :> live-outputs new-live-outputs live-outputs diff --git a/basis/compiler/tree/dead-code/simple/simple.factor b/basis/compiler/tree/dead-code/simple/simple.factor index bb0025caf4..77523568d7 100644 --- a/basis/compiler/tree/dead-code/simple/simple.factor +++ b/basis/compiler/tree/dead-code/simple/simple.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel accessors words assocs sequences arrays namespaces fry locals definitions classes classes.algebra generic @@ -67,7 +67,7 @@ M: #alien-node compute-live-values* nip look-at-inputs ; filter-corresponding zip #data-shuffle ; inline :: drop-dead-values ( outputs -- #shuffle ) - outputs make-values :> new-outputs + outputs length make-values :> new-outputs outputs filter-live :> live-outputs new-outputs live-outputs diff --git a/basis/compiler/tree/debugger/debugger.factor b/basis/compiler/tree/debugger/debugger.factor index 62fc9cdb82..47ec13e809 100644 --- a/basis/compiler/tree/debugger/debugger.factor +++ b/basis/compiler/tree/debugger/debugger.factor @@ -64,7 +64,7 @@ TUPLE: shuffle-node { effect effect } ; M: shuffle-node pprint* effect>> effect>string text ; : (shuffle-effect) ( in out #shuffle -- effect ) - mapping>> '[ _ at ] map ; + mapping>> '[ _ at ] map [ >array ] bi@ ; : shuffle-effect ( #shuffle -- effect ) [ in-d>> ] [ out-d>> ] [ ] tri (shuffle-effect) ; diff --git a/basis/compiler/tree/escape-analysis/recursive/recursive-tests.factor b/basis/compiler/tree/escape-analysis/recursive/recursive-tests.factor index c26f3ddefc..bb32e6e23b 100644 --- a/basis/compiler/tree/escape-analysis/recursive/recursive-tests.factor +++ b/basis/compiler/tree/escape-analysis/recursive/recursive-tests.factor @@ -1,4 +1,4 @@ -USING: kernel tools.test namespaces sequences +USING: kernel tools.test namespaces sequences math compiler.tree.escape-analysis.recursive compiler.tree.escape-analysis.allocations ; IN: compiler.tree.escape-analysis.recursive.tests @@ -6,7 +6,7 @@ IN: compiler.tree.escape-analysis.recursive.tests H{ } clone allocations set escaping-values set -[ ] [ 8 [ introduce-value ] each ] unit-test +[ ] [ 8 [ introduce-value ] each-integer ] unit-test [ ] [ { 1 2 } 3 record-allocation ] unit-test diff --git a/basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor b/basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor index 42e7f421bf..7366a83ee1 100644 --- a/basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor +++ b/basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor @@ -73,7 +73,7 @@ TUPLE: declared-fixnum { x fixnum } ; [ t ] [ [ - { fixnum } declare 0 swap + { fixnum } declare iota 0 swap [ drop 615949 * 797807 + 20 2^ rem dup 19 2^ - ] map @@ -94,7 +94,7 @@ TUPLE: declared-fixnum { x fixnum } ; [ t ] [ [ - { integer } declare [ 256 mod ] map + { integer } declare iota [ 256 mod ] map ] { mod fixnum-mod } inlined? ] unit-test diff --git a/basis/compiler/tree/normalization/normalization.factor b/basis/compiler/tree/normalization/normalization.factor index fcfa42c70b..7912fce1f6 100644 --- a/basis/compiler/tree/normalization/normalization.factor +++ b/basis/compiler/tree/normalization/normalization.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: fry namespaces sequences math math.order accessors kernel arrays combinators assocs @@ -75,10 +75,9 @@ M: #phi normalize* ] with-variable ; M: #recursive normalize* - dup label>> introductions>> - [ drop [ child>> first ] [ in-d>> ] bi >>in-d drop ] - [ make-values '[ _ (normalize) ] change-child ] - 2bi ; + [ [ child>> first ] [ in-d>> ] bi >>in-d drop ] + [ dup label>> introductions>> make-values '[ _ (normalize) ] change-child ] + bi ; M: #enter-recursive normalize* [ introduction-stack get prepend ] change-out-d diff --git a/basis/compiler/tree/propagation/call-effect/call-effect.factor b/basis/compiler/tree/propagation/call-effect/call-effect.factor index ff4886d1c7..439b428784 100644 --- a/basis/compiler/tree/propagation/call-effect/call-effect.factor +++ b/basis/compiler/tree/propagation/call-effect/call-effect.factor @@ -1,8 +1,8 @@ -! Copyright (C) 2009 Slava Pestov, Daniel Ehrenberg. +! Copyright (C) 2009, 2010 Slava Pestov, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors combinators combinators.private effects fry -kernel kernel.private make sequences continuations quotations -words math stack-checker combinators.short-circuit +USING: accessors arrays combinators combinators.private effects +fry kernel kernel.private make sequences continuations +quotations words math stack-checker combinators.short-circuit stack-checker.transforms compiler.tree.propagation.info compiler.tree.propagation.inlining compiler.units ; IN: compiler.tree.propagation.call-effect @@ -43,7 +43,7 @@ M: +unknown+ curry-effect ; M: effect curry-effect [ in>> length ] [ out>> length ] [ terminated?>> ] tri pick 0 = [ [ 1 + ] dip ] [ [ 1 - ] 2dip ] if - effect boa ; + [ [ "x" ] bi@ ] dip effect boa ; M: curry cached-effect quot>> cached-effect curry-effect ; diff --git a/basis/compiler/tree/propagation/info/info-tests.factor b/basis/compiler/tree/propagation/info/info-tests.factor index 826131ab61..446aad89e5 100644 --- a/basis/compiler/tree/propagation/info/info-tests.factor +++ b/basis/compiler/tree/propagation/info/info-tests.factor @@ -4,13 +4,6 @@ IN: compiler.tree.propagation.info.tests [ f ] [ 0.0 -0.0 eql? ] unit-test -[ t ] [ - number - sequence - value-info-intersect - class>> integer class= -] unit-test - [ t t ] [ 0 10 [a,b] 5 20 [a,b] diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor index 9be76ba0d0..2c80b87e76 100644 --- a/basis/compiler/tree/propagation/propagation-tests.factor +++ b/basis/compiler/tree/propagation/propagation-tests.factor @@ -406,14 +406,6 @@ IN: compiler.tree.propagation.tests ] final-literals ] unit-test -[ V{ 27 } ] [ - [ - dup number? over sequence? and [ - dup 10 < over 8 <= not and [ 3 * ] [ "A" throw ] if - ] [ "B" throw ] if - ] final-literals -] unit-test - [ V{ string string } ] [ [ 2dup [ dup string? [ "Oops" throw ] unless ] bi@ 2drop @@ -681,7 +673,7 @@ M: array iterate first t ; inline ] unit-test [ V{ fixnum } ] [ - [ { fixnum fixnum } declare [ nth-unsafe ] curry call ] final-classes + [ { fixnum fixnum } declare iota [ nth-unsafe ] curry call ] final-classes ] unit-test [ V{ f } ] [ diff --git a/basis/compiler/tree/propagation/simple/simple.factor b/basis/compiler/tree/propagation/simple/simple.factor index 9475b5df4a..225f10d342 100644 --- a/basis/compiler/tree/propagation/simple/simple.factor +++ b/basis/compiler/tree/propagation/simple/simple.factor @@ -80,7 +80,7 @@ M: #declare propagate-before : (fold-call) ( #call word -- info ) [ [ out-d>> ] [ in-d>> [ value-info literal>> ] map ] bi ] [ '[ _ execute ] ] bi* '[ _ _ with-datastack [ ] map nip ] - [ drop [ object-info ] replicate ] + [ drop length [ object-info ] replicate ] recover ; : fold-call ( #call word -- ) diff --git a/basis/compiler/tree/propagation/transforms/transforms.factor b/basis/compiler/tree/propagation/transforms/transforms.factor index f88b60d338..63c0aea13e 100644 --- a/basis/compiler/tree/propagation/transforms/transforms.factor +++ b/basis/compiler/tree/propagation/transforms/transforms.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg. +! Copyright (C) 2008, 2010 Slava Pestov, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: alien.c-types kernel sequences words fry generic accessors classes.tuple classes classes.algebra definitions @@ -189,7 +189,7 @@ ERROR: bad-partial-eval quot word ; \ index [ dup sequence? [ dup length 4 >= [ - dup length zip >hashtable '[ _ at ] + dup length iota zip >hashtable '[ _ at ] ] [ drop f ] if ] [ drop f ] if ] 1 define-partial-eval @@ -228,7 +228,7 @@ CONSTANT: lookup-table-at-max 256 } 1&& ; : lookup-table-seq ( assoc -- table ) - [ keys supremum 1 + ] keep '[ _ at ] { } map-as ; + [ keys supremum 1 + iota ] keep '[ _ at ] { } map-as ; : lookup-table-quot ( seq -- newquot ) lookup-table-seq diff --git a/basis/compression/inflate/inflate.factor b/basis/compression/inflate/inflate.factor index 567c435c2e..d0bc9d61dc 100644 --- a/basis/compression/inflate/inflate.factor +++ b/basis/compression/inflate/inflate.factor @@ -36,7 +36,7 @@ CONSTANT: clen-shuffle { 16 17 18 0 8 7 9 6 10 5 11 4 12 3 13 2 14 1 15 } 5 bitstream bs:read 1 + 4 bitstream bs:read 4 + clen-shuffle swap head - dup length iota [ 3 bitstream bs:read ] replicate + dup length [ 3 bitstream bs:read ] replicate get-table bitstream swap [ 2dup + ] dip swap :> k! @@ -64,12 +64,12 @@ CONSTANT: clen-shuffle { 16 17 18 0 8 7 9 6 10 5 11 4 12 3 13 2 14 1 15 } MEMO: static-huffman-tables ( -- obj ) [ - 0 143 [a,b] [ 8 ] replicate - 144 255 [a,b] [ 9 ] replicate append - 256 279 [a,b] [ 7 ] replicate append - 280 287 [a,b] [ 8 ] replicate append + 0 143 [a,b] length [ 8 ] replicate + 144 255 [a,b] length [ 9 ] replicate append + 256 279 [a,b] length [ 7 ] replicate append + 280 287 [a,b] length [ 8 ] replicate append ] append-outputs - 0 31 [a,b] [ 5 ] replicate 2array + 0 31 [a,b] length [ 5 ] replicate 2array [ [ length>> [0,b) ] [ ] bi get-table ] map ; CONSTANT: length-table diff --git a/basis/concurrency/combinators/combinators-tests.factor b/basis/concurrency/combinators/combinators-tests.factor index d3f3229171..57a679f240 100644 --- a/basis/concurrency/combinators/combinators-tests.factor +++ b/basis/concurrency/combinators/combinators-tests.factor @@ -11,18 +11,18 @@ IN: concurrency.combinators.tests [ { 1 4 9 } ] [ { 1 2 3 } [ sq ] parallel-map ] unit-test -[ { 1 4 9 } ] [ { 1 2 3 } [ 1000000 random sleep sq ] parallel-map ] unit-test +[ { 1 4 9 } ] [ { 1 2 3 } [ 1000000 iota random sleep sq ] parallel-map ] unit-test [ { 1 2 3 } [ dup 2 mod 0 = [ "Even" throw ] when ] parallel-map ] [ error>> "Even" = ] must-fail-with [ V{ 0 3 6 9 } ] -[ 10 [ 3 mod zero? ] parallel-filter ] unit-test +[ 10 iota [ 3 mod zero? ] parallel-filter ] unit-test [ 10 ] [ V{ } clone - 10 over [ push ] curry parallel-each + 10 iota over [ push ] curry parallel-each length ] unit-test @@ -41,7 +41,7 @@ IN: concurrency.combinators.tests [ 20 ] [ V{ } clone - 10 10 pick [ [ push ] [ push ] bi ] curry 2parallel-each + 10 iota 10 iota pick [ [ push ] [ push ] bi ] curry 2parallel-each length ] unit-test diff --git a/basis/db/db.factor b/basis/db/db.factor index bd523b38e6..f26729f8ea 100644 --- a/basis/db/db.factor +++ b/basis/db/db.factor @@ -100,10 +100,10 @@ M: object execute-statement* ( statement type -- ) t >>bound? drop ; : sql-row ( result-set -- seq ) - dup #columns [ row-column ] with map ; + dup #columns [ row-column ] with { } map-integers ; : sql-row-typed ( result-set -- seq ) - dup #columns [ row-column-typed ] with map ; + dup #columns [ row-column-typed ] with { } map-integers ; : query-each ( statement quot: ( statement -- ) -- ) over more-rows? [ diff --git a/basis/db/queries/queries.factor b/basis/db/queries/queries.factor index e9aa01feb4..3ff93f49c6 100644 --- a/basis/db/queries/queries.factor +++ b/basis/db/queries/queries.factor @@ -34,7 +34,7 @@ SINGLETON: retryable ] 2map >>bind-params ; M: retryable execute-statement* ( statement type -- ) - drop [ retries>> ] [ + drop [ retries>> iota ] [ [ nip [ query-results dispose t ] diff --git a/basis/db/tester/tester.factor b/basis/db/tester/tester.factor index 19140259bf..1949ab42cc 100644 --- a/basis/db/tester/tester.factor +++ b/basis/db/tester/tester.factor @@ -57,7 +57,7 @@ test-2 "TEST2" { } define-persistent : test-1-tuple ( -- tuple ) - f 100 random 100 random 100 random [ number>string ] tri@ + f 100 iota random 100 iota random 100 iota random [ number>string ] tri@ test-1 boa ; : db-tester ( test-db -- ) @@ -67,7 +67,7 @@ test-2 "TEST2" { test-2 ensure-table ] with-db ] [ - 10 [ + 10 iota [ drop 10 [ dup [ @@ -85,7 +85,7 @@ test-2 "TEST2" { ] with-db ] [ [ - 10 [ + 10 iota [ 10 [ test-1-tuple insert-tuple yield ] times diff --git a/basis/farkup/farkup-tests.factor b/basis/farkup/farkup-tests.factor index 863dc522b2..e967250b23 100644 --- a/basis/farkup/farkup-tests.factor +++ b/basis/farkup/farkup-tests.factor @@ -186,7 +186,7 @@ link-no-follow? off : random-markup ( -- string ) 10 [ - 2 random 1 = [ + 2 iota random 1 = [ { "[[" "*" @@ -205,7 +205,7 @@ link-no-follow? off 100 [ drop random-markup [ convert-farkup drop t ] [ drop print f ] recover - ] all? + ] all-integers? ] unit-test [ "

http://foo.com/~foo

" ] [ "[[http://foo.com/~foo]]" convert-farkup ] unit-test diff --git a/basis/fry/fry-tests.factor b/basis/fry/fry-tests.factor index f33eb276a0..b341c462be 100644 --- a/basis/fry/fry-tests.factor +++ b/basis/fry/fry-tests.factor @@ -64,7 +64,7 @@ SYMBOLS: a b c d e f g h ; [ "hi" 3 ] [ "h" "i" 3 [ append ] funny-dip ] unit-test [ { 1 2 3 } ] [ - 3 1 '[ _ [ _ + ] map ] call + 3 1 '[ _ iota [ _ + ] map ] call ] unit-test [ { 1 { 2 { 3 } } } ] [ diff --git a/basis/generalizations/generalizations-tests.factor b/basis/generalizations/generalizations-tests.factor index 546413447e..0c35f15714 100644 --- a/basis/generalizations/generalizations-tests.factor +++ b/basis/generalizations/generalizations-tests.factor @@ -64,7 +64,7 @@ IN: generalizations.tests { 3 5 } [ 2 nweave ] must-infer-as [ { 0 1 2 } { 3 5 4 } { 7 8 6 } ] -[ 9 [ ] each { [ 3array ] [ swap 3array ] [ rot 3array ] } 3 nspread ] unit-test +[ 9 [ ] each-integer { [ 3array ] [ swap 3array ] [ rot 3array ] } 3 nspread ] unit-test [ 1 2 3 4 1 2 3 ] [ 1 2 3 4 3 nover ] unit-test diff --git a/basis/heaps/heaps-tests.factor b/basis/heaps/heaps-tests.factor index c1985c516f..703cf53080 100644 --- a/basis/heaps/heaps-tests.factor +++ b/basis/heaps/heaps-tests.factor @@ -31,7 +31,7 @@ IN: heaps.tests [ heap-push-all ] keep heap-pop-all ; : random-alist ( n -- alist ) - [ + iota [ drop 32 random-bits dup number>string ] H{ } map>assoc ; @@ -40,16 +40,16 @@ IN: heaps.tests 14 [ [ t ] swap [ 2^ test-heap-sort ] curry unit-test -] each +] each-integer : test-entry-indices ( n -- ? ) random-alist [ heap-push-all ] keep - data>> dup length swap [ index>> ] map sequence= ; + data>> dup length iota swap [ index>> ] map sequence= ; 14 [ [ t ] swap [ 2^ test-entry-indices ] curry unit-test -] each +] each-integer : sort-entries ( entries -- entries' ) [ key>> ] sort-with ; @@ -66,4 +66,4 @@ IN: heaps.tests 11 [ [ t ] swap [ 2^ delete-test sequence= ] curry unit-test -] each +] each-integer diff --git a/basis/hints/hints.factor b/basis/hints/hints.factor index 1ca5bf1bc5..e4bbb3459e 100644 --- a/basis/hints/hints.factor +++ b/basis/hints/hints.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008, 2009 Slava Pestov. +! Copyright (C) 2008, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays assocs byte-arrays byte-vectors classes combinators definitions effects fry generic generic.single @@ -24,7 +24,7 @@ M: object specializer-declaration class ; "specializer" word-prop ; : make-specializer ( specs -- quot ) - dup length + dup length iota [ (picker) 2array ] 2map [ drop object eq? not ] assoc-filter [ [ t ] ] [ diff --git a/basis/inspector/inspector.factor b/basis/inspector/inspector.factor index 82c2487f67..2aa7cd218e 100644 --- a/basis/inspector/inspector.factor +++ b/basis/inspector/inspector.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2005, 2009 Slava Pestov. +! Copyright (C) 2005, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays generic hashtables io kernel assocs math namespaces prettyprint prettyprint.custom prettyprint.sections @@ -23,9 +23,7 @@ GENERIC: add-numbers ( alist -- table' ) M: enum add-numbers ; M: assoc add-numbers - +number-rows+ get [ - dup length [ prefix ] 2map - ] when ; + +number-rows+ get [ [ prefix ] map-index ] when ; TUPLE: slot-name name ; diff --git a/basis/inverse/inverse.factor b/basis/inverse/inverse.factor index 4ecb1e12a8..383a4aca9b 100644 --- a/basis/inverse/inverse.factor +++ b/basis/inverse/inverse.factor @@ -68,7 +68,7 @@ UNION: explicit-inverse normal-inverse math-inverse pop-inverse ; : enough? ( stack word -- ? ) dup deferred? [ 2drop f ] [ - [ [ length ] [ 1quotation infer in>> ] bi* >= ] + [ [ length ] [ 1quotation infer in>> length ] bi* >= ] [ 3drop f ] recover ] if ; @@ -273,10 +273,10 @@ DEFER: __ ] recover ; inline : true-out ( quot effect -- quot' ) - out>> '[ @ _ ndrop t ] ; + out>> length '[ @ _ ndrop t ] ; : false-recover ( effect -- quot ) - in>> [ ndrop f ] curry [ recover-fail ] curry ; + in>> length [ ndrop f ] curry [ recover-fail ] curry ; : [matches?] ( quot -- undoes?-quot ) [undo] dup infer [ true-out ] [ false-recover ] bi curry ; diff --git a/basis/io/encodings/iso2022/iso2022.factor b/basis/io/encodings/iso2022/iso2022.factor index 1726426777..7d4d7f1215 100644 --- a/basis/io/encodings/iso2022/iso2022.factor +++ b/basis/io/encodings/iso2022/iso2022.factor @@ -18,7 +18,7 @@ VALUE: jis212 "vocab:io/encodings/iso2022/212.txt" flat-file>biassoc to: jis212 VALUE: ascii -128 unique >biassoc to: ascii +128 iota unique >biassoc to: ascii TUPLE: iso2022-state type ; diff --git a/basis/io/files/links/unix/unix-tests.factor b/basis/io/files/links/unix/unix-tests.factor index ef7d778abe..23de95f519 100644 --- a/basis/io/files/links/unix/unix-tests.factor +++ b/basis/io/files/links/unix/unix-tests.factor @@ -4,7 +4,7 @@ io.pathnames namespaces ; IN: io.files.links.unix.tests : make-test-links ( n path -- ) - [ '[ [ 1 + ] keep [ number>string _ prepend ] bi@ make-link ] each ] + [ '[ [ 1 + ] keep [ number>string _ prepend ] bi@ make-link ] each-integer ] [ [ number>string ] dip prepend touch-file ] 2bi ; inline [ t ] [ diff --git a/basis/io/files/unique/unique.factor b/basis/io/files/unique/unique.factor index f167b1e99b..6a00ee523b 100644 --- a/basis/io/files/unique/unique.factor +++ b/basis/io/files/unique/unique.factor @@ -26,17 +26,17 @@ SYMBOL: unique-retries string drop ] unit-test +[ ] [ "hello" "heyo" [ [ 1string ] { } map-as ] bi@ diff htmlize-diff xml>string drop ] unit-test diff --git a/basis/lcs/diff2html/diff2html.factor b/basis/lcs/diff2html/diff2html.factor index ca9e48eb05..545610a0ea 100644 --- a/basis/lcs/diff2html/diff2html.factor +++ b/basis/lcs/diff2html/diff2html.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008 Slava Pestov +! Copyright (C) 2008, 2010 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: lcs xml.syntax xml.writer kernel strings ; FROM: accessors => item>> ; diff --git a/basis/lcs/lcs.factor b/basis/lcs/lcs.factor index 38920f5764..5861d90dc3 100644 --- a/basis/lcs/lcs.factor +++ b/basis/lcs/lcs.factor @@ -19,15 +19,15 @@ IN: lcs i 1 + j 1 + matrix nth set-nth ; inline : lcs-initialize ( |str1| |str2| -- matrix ) - [ drop 0 ] with map ; + iota [ drop 0 ] with map ; : levenshtein-initialize ( |str1| |str2| -- matrix ) - [ [ + ] curry map ] with map ; + [ iota ] bi@ [ [ + ] curry map ] with map ; :: run-lcs ( old new init step -- matrix ) old length 1 + new length 1 + init call :> matrix - old length [| i | - new length + old length iota [| i | + new length iota [| j | i j matrix old new step loop-step ] each ] each matrix ; inline PRIVATE> diff --git a/basis/macros/expander/expander.factor b/basis/macros/expander/expander.factor index 25f754e92a..3dab0c3cdb 100644 --- a/basis/macros/expander/expander.factor +++ b/basis/macros/expander/expander.factor @@ -49,7 +49,7 @@ M: wrapper expand-macros* wrapped>> literal ; stack get pop end [ [ expand-macros ] [ ] map-as '[ _ dip ] % ] [ - length [ ] keep + length iota [ ] keep [ '[ _ ndrop _ nnip call ] [ ] like ] 2map , \ dispatch , ] bi ; diff --git a/basis/math/combinatorics/combinatorics-tests.factor b/basis/math/combinatorics/combinatorics-tests.factor index ca6ec9cb53..bbf5a1cb85 100644 --- a/basis/math/combinatorics/combinatorics-tests.factor +++ b/basis/math/combinatorics/combinatorics-tests.factor @@ -56,7 +56,7 @@ IN: math.combinatorics.tests [ 0 ] [ 9 5 iota 3 dual-index ] unit-test [ 179 ] [ 72 10 iota 5 dual-index ] unit-test -[ { 5 3 2 1 } ] [ 7 4 8 combinadic ] unit-test +[ { 5 3 2 1 } ] [ 7 iota 4 8 combinadic ] unit-test [ { 4 3 2 1 0 } ] [ 10 iota 5 0 combinadic ] unit-test [ { 8 6 3 1 0 } ] [ 10 iota 5 72 combinadic ] unit-test [ { 9 8 7 6 5 } ] [ 10 iota 5 251 combinadic ] unit-test diff --git a/basis/math/combinatorics/combinatorics.factor b/basis/math/combinatorics/combinatorics.factor index 36b62ddcc0..32f9ae1db3 100644 --- a/basis/math/combinatorics/combinatorics.factor +++ b/basis/math/combinatorics/combinatorics.factor @@ -1,4 +1,4 @@ -! Copyright (c) 2007-2009 Slava Pestov, Doug Coleman, Aaron Schaefer. +! Copyright (c) 2007-2010 Slava Pestov, Doug Coleman, Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs binary-search fry kernel locals math math.order math.ranges namespaces sequences sorting ; @@ -15,7 +15,7 @@ IN: math.combinatorics PRIVATE> : factorial ( n -- n! ) - 1 [ 1 + * ] reduce ; + iota 1 [ 1 + * ] reduce ; : nPk ( n k -- nPk ) 2dup possible? [ dupd - [a,b) product ] [ 2drop 0 ] if ; @@ -46,11 +46,11 @@ PRIVATE> [ permutation-indices ] keep nths ; : all-permutations ( seq -- seq ) - [ length factorial ] keep + [ length factorial iota ] keep '[ _ permutation ] map ; : each-permutation ( seq quot -- ) - [ [ length factorial ] keep ] dip + [ [ length factorial iota ] keep ] dip '[ _ permutation @ ] each ; inline : reduce-permutations ( seq identity quot -- result ) diff --git a/basis/math/intervals/intervals-tests.factor b/basis/math/intervals/intervals-tests.factor index a569b4af7b..e38182bf9d 100644 --- a/basis/math/intervals/intervals-tests.factor +++ b/basis/math/intervals/intervals-tests.factor @@ -250,7 +250,7 @@ IN: math.intervals.tests dup full-interval eq? [ drop 32 random-bits 31 2^ - ] [ - [ ] [ from>> first ] [ to>> first ] tri over - random + + [ ] [ from>> first ] [ to>> first ] tri over - iota random + 2dup swap interval-contains? [ nip ] [ @@ -259,10 +259,10 @@ IN: math.intervals.tests ] if ; : random-interval ( -- interval ) - 10 random 0 = [ full-interval ] [ - 2000 random 1000 - dup 2 1000 random + + - 1 random zero? [ [ neg ] bi@ swap ] when - 4 random { + 10 iota random 0 = [ full-interval ] [ + 2000 iota random 1000 - dup 2 1000 iota random + + + 1 iota random zero? [ [ neg ] bi@ swap ] when + 4 iota random { { 0 [ [a,b] ] } { 1 [ [a,b) ] } { 2 [ (a,b) ] } @@ -291,7 +291,7 @@ IN: math.intervals.tests ] if ; unary-ops [ - [ [ t ] ] dip '[ 8000 iota [ drop _ unary-test ] all? ] unit-test + [ [ t ] ] dip '[ 8000 [ drop _ unary-test ] all-integers? ] unit-test ] each : binary-ops ( -- alist ) @@ -366,7 +366,7 @@ comparison-ops [ ! Test that commutative interval ops really are : random-interval-or-empty ( -- obj ) - 10 random 0 = [ empty-interval ] [ random-interval ] if ; + 10 iota random 0 = [ empty-interval ] [ random-interval ] if ; : commutative-ops ( -- seq ) { diff --git a/basis/math/matrices/elimination/elimination.factor b/basis/math/matrices/elimination/elimination.factor index 371eb8a36c..c8d5bb7338 100644 --- a/basis/math/matrices/elimination/elimination.factor +++ b/basis/math/matrices/elimination/elimination.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2006, 2008 Slava Pestov. +! Copyright (C) 2006, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel locals math math.vectors math.matrices namespaces sequences fry sorting ; @@ -42,7 +42,7 @@ SYMBOL: matrix [ [ clear-scale ] 2keep [ n*v ] dip v+ ] change-row ; : rows-from ( row# -- slice ) - rows dup ; + rows dup iota ; : clear-col ( col# row# rows -- ) [ nth-row ] dip [ [ 2dup ] dip (clear-col) ] each 2drop ; @@ -79,9 +79,9 @@ SYMBOL: matrix : reduced ( matrix' -- matrix'' ) [ - rows [ + rows iota [ dup nth-row leading drop - dup [ swap dup clear-col ] [ 2drop ] if + dup [ swap dup iota clear-col ] [ 2drop ] if ] each ] with-matrix ; diff --git a/basis/math/matrices/matrices.factor b/basis/math/matrices/matrices.factor index 75b9be5cae..bf14d7ba13 100644 --- a/basis/math/matrices/matrices.factor +++ b/basis/math/matrices/matrices.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2005, 2009 Slava Pestov. +! Copyright (C) 2005, 2010 Slava Pestov, Joe Groff. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays columns kernel locals math math.bits math.functions math.order math.vectors sequences @@ -11,7 +11,7 @@ IN: math.matrices : identity-matrix ( n -- matrix ) #! Make a nxn identity matrix. - dup [ [ = 1 0 ? ] with map ] curry map ; + iota dup [ [ = 1 0 ? ] with map ] curry map ; :: rotation-matrix3 ( axis theta -- matrix ) theta cos :> c diff --git a/basis/math/polynomials/polynomials.factor b/basis/math/polynomials/polynomials.factor index 0de18b6feb..99d77d0ce2 100644 --- a/basis/math/polynomials/polynomials.factor +++ b/basis/math/polynomials/polynomials.factor @@ -32,7 +32,7 @@ PRIVATE> 2dup [ length ] bi@ + 1 - 2pad-tail [ >vector ] bi@ ; : p* ( p q -- r ) - 2unempty pextend-conv dup length + 2unempty pextend-conv dup length iota [ over length pick pick [ * ] 2map sum ] map 2nip reverse ; : p-sq ( p -- p^2 ) diff --git a/basis/math/primes/miller-rabin/miller-rabin-tests.factor b/basis/math/primes/miller-rabin/miller-rabin-tests.factor index d201abfef8..f803b7db01 100644 --- a/basis/math/primes/miller-rabin/miller-rabin-tests.factor +++ b/basis/math/primes/miller-rabin/miller-rabin-tests.factor @@ -8,4 +8,4 @@ IN: math.primes.miller-rabin.tests [ t ] [ 37 miller-rabin ] unit-test [ t ] [ 2135623355842621559 miller-rabin ] unit-test -[ f ] [ 1000 [ drop 15 miller-rabin ] any? ] unit-test +[ f ] [ 1000 iota [ drop 15 miller-rabin ] any? ] unit-test diff --git a/basis/math/primes/miller-rabin/miller-rabin.factor b/basis/math/primes/miller-rabin/miller-rabin.factor index 04b1330cc2..ac5c2df705 100644 --- a/basis/math/primes/miller-rabin/miller-rabin.factor +++ b/basis/math/primes/miller-rabin/miller-rabin.factor @@ -10,7 +10,7 @@ IN: math.primes.miller-rabin n 1 - :> n-1 n-1 factor-2s :> ( r s ) 0 :> a! - trials [ + trials iota [ drop 2 n 2 - [a,b] random a! a s n ^mod 1 = [ diff --git a/basis/math/primes/primes.factor b/basis/math/primes/primes.factor index 81193af400..19dcc6aeaf 100644 --- a/basis/math/primes/primes.factor +++ b/basis/math/primes/primes.factor @@ -78,7 +78,7 @@ PRIVATE> >odd (find-relative-prime) ; : find-relative-prime ( n -- p ) - dup random find-relative-prime* ; + dup iota random find-relative-prime* ; ERROR: too-few-primes n numbits ; diff --git a/basis/math/vectors/simd/cords/cords.factor b/basis/math/vectors/simd/cords/cords.factor index e099f6e830..815b34a90d 100644 --- a/basis/math/vectors/simd/cords/cords.factor +++ b/basis/math/vectors/simd/cords/cords.factor @@ -22,7 +22,7 @@ A-cast DEFINES ${A}-cast A{ DEFINES ${A}{ N [ A-rep rep-length ] -BOA-EFFECT [ N 2 * "n" >array { "v" } ] +BOA-EFFECT [ N 2 * "n" { "v" } ] WHERE diff --git a/basis/math/vectors/simd/intrinsics/intrinsics.factor b/basis/math/vectors/simd/intrinsics/intrinsics.factor index 658d9b270c..d80755a6a5 100644 --- a/basis/math/vectors/simd/intrinsics/intrinsics.factor +++ b/basis/math/vectors/simd/intrinsics/intrinsics.factor @@ -238,7 +238,7 @@ PRIVATE> [ >rep-array ] [ widen-vector-rep [ rep-length ] [ [>rep-array] ] bi ] bi [ tail-slice ] dip call( a' -- c' ) underlying>> ; : (simd-with) ( n rep -- v ) - [ rep-length iota swap '[ _ ] ] [ ] bi replicate-as + [ rep-length swap '[ _ ] ] [ ] bi replicate-as underlying>> ; : (simd-gather-2) ( m n rep -- v ) [ 2 set-firstn ] keep underlying>> ; : (simd-gather-4) ( m n o p rep -- v ) [ 4 set-firstn ] keep underlying>> ; diff --git a/basis/math/vectors/simd/simd-tests.factor b/basis/math/vectors/simd/simd-tests.factor index aaa5507864..d32ee5d443 100644 --- a/basis/math/vectors/simd/simd-tests.factor +++ b/basis/math/vectors/simd/simd-tests.factor @@ -151,7 +151,7 @@ CONSTANT: vector-words [ { } ] [ with-ctors [ - [ 1000 random '[ _ ] ] dip '[ _ execute ] + [ 1000 iota random '[ _ ] ] dip '[ _ execute ] ] [ = ] check-optimizer ] unit-test @@ -165,7 +165,7 @@ CONSTANT: vector-words [ { } ] [ boa-ctors [ - [ stack-effect in>> length [ 1000 random ] [ ] replicate-as ] keep + [ stack-effect in>> length [ 1000 iota random ] [ ] replicate-as ] keep '[ _ execute ] ] [ = ] check-optimizer ] unit-test @@ -175,11 +175,12 @@ CONSTANT: vector-words "== Checking vector operations" print : random-int-vector ( class -- vec ) - new [ drop 1,000 random ] map ; + new [ drop 1000 iota random ] map ; + : random-float-vector ( class -- vec ) new [ drop - 1000 random + 1000 iota random 10 swap 0/0. suffix random ] map ; @@ -192,7 +193,7 @@ CONSTANT: vector-words inputs [ { { +vector+ [ class elt-class random-vector ] } - { +scalar+ [ 1000 random elt-class float = [ >float ] when ] } + { +scalar+ [ 1000 iota random elt-class float = [ >float ] when ] } } case ] [ ] map-as word '[ _ execute ] ; @@ -254,13 +255,13 @@ simd-classes&reps [ "== Checking boolean operations" print : random-boolean-vector ( class -- vec ) - new [ drop 2 random zero? ] map ; + new [ drop 2 iota random zero? ] map ; :: check-boolean-op ( word inputs class elt-class -- inputs quot ) inputs [ { { +vector+ [ class random-boolean-vector ] } - { +scalar+ [ 1000 random elt-class float = [ >float ] when ] } + { +scalar+ [ 1000 iota random elt-class float = [ >float ] when ] } } case ] [ ] map-as word '[ _ execute ] ; @@ -371,7 +372,7 @@ simd-classes&reps [ [ [ 4 + ] map ] map [ append ] 2map ] } - [ dup '[ _ random ] replicate 1array ] + [ dup '[ _ iota random ] replicate 1array ] } case ; simd-classes [ @@ -386,7 +387,7 @@ simd-classes [ "== Checking variable shuffles" print : random-shift-vector ( class -- vec ) - new [ drop 16 random ] map ; + new [ drop 16 iota random ] map ; :: test-shift-vector ( class -- ? ) [ @@ -463,7 +464,7 @@ TUPLE: inconsistent-vector-test bool branch ; ! Test element access -- it should box bignums for int-4 on x86 : test-accesses ( seq -- failures ) - [ length >array ] keep + [ length iota >array ] keep '[ [ _ 1quotation ] dip '[ _ swap nth ] ] [ = ] check-optimizer ; inline [ { } ] [ float-4{ 1.0 2.0 3.0 4.0 } test-accesses ] unit-test @@ -480,7 +481,7 @@ TUPLE: inconsistent-vector-test bool branch ; "== Checking broadcast" print : test-broadcast ( seq -- failures ) - [ length >array ] keep + [ length iota >array ] keep '[ [ _ 1quotation ] dip '[ _ vbroadcast ] ] [ = ] check-optimizer ; [ { } ] [ float-4{ 1.0 2.0 3.0 4.0 } test-broadcast ] unit-test diff --git a/basis/math/vectors/simd/simd.factor b/basis/math/vectors/simd/simd.factor index 905737c266..acf13599c1 100644 --- a/basis/math/vectors/simd/simd.factor +++ b/basis/math/vectors/simd/simd.factor @@ -247,7 +247,7 @@ COERCER [ ELT c-type-class "coercer" word-prop [ ] or ] SET-NTH [ ELT dup c:c-setter c:array-accessor ] -BOA-EFFECT [ N "n" >array { "v" } ] +BOA-EFFECT [ N "n" { "v" } ] WHERE diff --git a/basis/models/arrow/smart/smart.factor b/basis/models/arrow/smart/smart.factor index 257a2bb1ea..c4ad01e52e 100644 --- a/basis/models/arrow/smart/smart.factor +++ b/basis/models/arrow/smart/smart.factor @@ -1,9 +1,10 @@ -! Copyright (C) 2009 Slava Pestov. +! Copyright (C) 2009, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: models.arrow models.product stack-checker accessors fry -generalizations macros kernel ; +generalizations combinators.smart combinators.smart.private +macros kernel ; IN: models.arrow.smart MACRO: ( quot -- quot' ) - [ infer in>> dup ] keep + [ inputs dup ] keep '[ _ narray [ _ firstn @ ] ] ; \ No newline at end of file diff --git a/basis/nibble-arrays/nibble-arrays-tests.factor b/basis/nibble-arrays/nibble-arrays-tests.factor index 2a0eef7227..363f30678d 100644 --- a/basis/nibble-arrays/nibble-arrays-tests.factor +++ b/basis/nibble-arrays/nibble-arrays-tests.factor @@ -1,6 +1,6 @@ USING: nibble-arrays tools.test sequences kernel math ; IN: nibble-arrays.tests -[ t ] [ 16 dup >nibble-array sequence= ] unit-test +[ t ] [ 16 iota dup >nibble-array sequence= ] unit-test [ N{ 4 2 1 3 } ] [ N{ 3 1 2 4 } reverse ] unit-test [ N{ 1 4 9 0 9 4 } ] [ N{ 1 2 3 4 5 6 } [ sq ] map ] unit-test diff --git a/basis/peg/ebnf/ebnf.factor b/basis/peg/ebnf/ebnf.factor index 5ddd5f9bf0..ffc4cb91ad 100644 --- a/basis/peg/ebnf/ebnf.factor +++ b/basis/peg/ebnf/ebnf.factor @@ -446,14 +446,14 @@ M: ebnf-sequence build-locals ( code ast -- code ) ] [ [ "FROM: locals => [let :> ; FROM: sequences => nth ; [let " % - dup length [ + [ over ebnf-var? [ " " % # " over nth :> " % name>> % ] [ 2drop ] if - ] 2each + ] each-index " " % % " nip ]" % diff --git a/basis/persistent/hashtables/hashtables-tests.factor b/basis/persistent/hashtables/hashtables-tests.factor index d66fdd0c08..da2dd5f2c2 100644 --- a/basis/persistent/hashtables/hashtables-tests.factor +++ b/basis/persistent/hashtables/hashtables-tests.factor @@ -81,7 +81,7 @@ M: hash-0-b hashcode* 2drop 0 ; ] unit-test : random-string ( -- str ) - 1000000 random ; ! [ CHAR: a CHAR: z [a,b] random ] "" replicate-as ; + 1000000 iota random ; ! [ CHAR: a CHAR: z [a,b] random ] "" replicate-as ; : random-assocs ( n -- hash phash ) [ random-string ] replicate diff --git a/basis/persistent/vectors/vectors-tests.factor b/basis/persistent/vectors/vectors-tests.factor index 95fa70558d..fe3365d322 100644 --- a/basis/persistent/vectors/vectors-tests.factor +++ b/basis/persistent/vectors/vectors-tests.factor @@ -18,16 +18,16 @@ vectors math math.order ; ] unit-test { 100 1060 2000 10000 100000 1000000 } [ - [ t ] swap [ dup >persistent-vector sequence= ] curry unit-test + [ t ] swap [ iota dup >persistent-vector sequence= ] curry unit-test ] each [ ] [ 10000 [ 16 random-bits ] PV{ } replicate-as "1" set ] unit-test [ ] [ "1" get >vector "2" set ] unit-test [ t ] [ - 3000 [ + 3000 iota [ drop - 16 random-bits 10000 random + 16 random-bits 10000 iota random [ "1" [ new-nth ] change ] [ "2" [ new-nth ] change ] 2bi "1" get "2" get sequence= @@ -56,16 +56,16 @@ vectors math math.order ; ] unit-test [ t ] [ - 10000 >persistent-vector 752 [ ppop ] times dup length sequence= + 10000 iota >persistent-vector 752 [ ppop ] times dup length iota sequence= ] unit-test [ t ] [ - 100 [ + 100 iota [ drop - 100 random [ + 100 iota random [ 16 random-bits [ "1" [ ppush ] change ] [ "2" get push ] bi ] times - 100 random "1" get length min [ + 100 iota random "1" get length min [ "1" [ ppop ] change "2" get pop* ] times diff --git a/basis/porter-stemmer/porter-stemmer.factor b/basis/porter-stemmer/porter-stemmer.factor index 2e1a47b951..e3cb186bf8 100644 --- a/basis/porter-stemmer/porter-stemmer.factor +++ b/basis/porter-stemmer/porter-stemmer.factor @@ -33,10 +33,10 @@ IN: porter-stemmer ] if ; : consonant-seq ( str -- n ) - 0 0 rot skip-consonants (consonant-seq) ; + [ 0 0 ] dip skip-consonants (consonant-seq) ; : stem-vowel? ( str -- ? ) - [ length ] keep [ consonant? ] curry all? not ; + [ length iota ] keep [ consonant? ] curry all? not ; : double-consonant? ( i str -- ? ) over 1 < [ diff --git a/basis/prettyprint/sections/sections.factor b/basis/prettyprint/sections/sections.factor index 040b6d8f7c..6f5f61f688 100644 --- a/basis/prettyprint/sections/sections.factor +++ b/basis/prettyprint/sections/sections.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2003, 2009 Slava Pestov. +! Copyright (C) 2003, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays generic hashtables io kernel math assocs namespaces make sequences strings io.styles vectors words @@ -309,7 +309,7 @@ SYMBOL: next : group-flow ( seq -- newseq ) [ - dup length [ + dup length iota [ 2dup 1 - swap ?nth prev set 2dup 1 + swap ?nth next set swap nth dup split-before dup , split-after diff --git a/basis/random/mersenne-twister/mersenne-twister-tests.factor b/basis/random/mersenne-twister/mersenne-twister-tests.factor index b877af6f79..343baeebf4 100644 --- a/basis/random/mersenne-twister/mersenne-twister-tests.factor +++ b/basis/random/mersenne-twister/mersenne-twister-tests.factor @@ -3,12 +3,12 @@ random.mersenne-twister sequences tools.test math.order ; IN: random.mersenne-twister.tests : check-random ( max -- ? ) - [ random 0 ] keep between? ; + [ iota random 0 ] keep between? ; -[ t ] [ 100 [ drop 674 check-random ] all? ] unit-test +[ t ] [ 100 [ drop 674 check-random ] all-integers? ] unit-test : randoms ( -- seq ) - 100 [ 100 random ] replicate ; + 100 [ 100 iota random ] replicate ; : test-rng ( seed quot -- ) [ ] dip with-random ; inline @@ -16,11 +16,11 @@ IN: random.mersenne-twister.tests [ f ] [ 1234 [ randoms randoms = ] test-rng ] unit-test [ 1333075495 ] [ - 0 [ 1000 [ drop random-generator get random-32* drop ] each random-generator get random-32* ] test-rng + 0 [ 1000 [ drop random-generator get random-32* drop ] each-integer random-generator get random-32* ] test-rng ] unit-test [ 1575309035 ] [ - 0 [ 10000 [ drop random-generator get random-32* drop ] each random-generator get random-32* ] test-rng + 0 [ 10000 [ drop random-generator get random-32* drop ] each-integer random-generator get random-32* ] test-rng ] unit-test diff --git a/basis/random/mersenne-twister/mersenne-twister.factor b/basis/random/mersenne-twister/mersenne-twister.factor index 90489d3052..9fd82a3062 100644 --- a/basis/random/mersenne-twister/mersenne-twister.factor +++ b/basis/random/mersenne-twister/mersenne-twister.factor @@ -30,8 +30,8 @@ CONSTANT: a uint-array{ 0 HEX: 9908b0df } : mt-generate ( mt -- ) [ seq>> - [ [ n m - ] dip '[ [ m ] dip _ mt[k] ] each ] - [ [ m 1 - ] dip '[ [ m n - ] [ n m - + ] bi* _ mt[k] ] each ] + [ [ n m - ] dip '[ [ m ] dip _ mt[k] ] each-integer ] + [ [ m 1 - ] dip '[ [ m n - ] [ n m - + ] bi* _ mt[k] ] each-integer ] bi ] [ 0 >>i drop ] bi ; inline @@ -41,7 +41,7 @@ CONSTANT: a uint-array{ 0 HEX: 9908b0df } : init-mt-rest ( seq -- ) n 1 - swap '[ _ [ init-mt-formula ] [ [ 1 + ] dip set-nth ] 2bi - ] each ; inline + ] each-integer ; inline : init-mt-seq ( seed -- seq ) 32 bits n diff --git a/basis/random/random-tests.factor b/basis/random/random-tests.factor index 96dc8cc783..3854996f33 100644 --- a/basis/random/random-tests.factor +++ b/basis/random/random-tests.factor @@ -11,12 +11,12 @@ IN: random.tests [ 2 ] [ V{ 10 20 30 } [ delete-random drop ] keep length ] unit-test [ V{ } [ delete-random drop ] keep length ] must-fail -[ t ] [ 10000 [ 0 [ drop 187 random + ] reduce ] keep / 2 * 187 10 ~ ] unit-test -[ t ] [ 10000 [ 0 [ drop 400 random + ] reduce ] keep / 2 * 400 10 ~ ] unit-test +[ t ] [ 10000 [ iota 0 [ drop 187 iota random + ] reduce ] keep / 2 * 187 10 ~ ] unit-test +[ t ] [ 10000 [ iota 0 [ drop 400 iota random + ] reduce ] keep / 2 * 400 10 ~ ] unit-test -[ t ] [ 1000 [ 400 random ] replicate prune length 256 > ] unit-test +[ t ] [ 1000 [ 400 iota random ] replicate prune length 256 > ] unit-test -[ f ] [ 0 random ] unit-test +[ f ] [ 0 iota random ] unit-test [ { } ] [ { } randomize ] unit-test [ { 1 } ] [ { 1 } randomize ] unit-test diff --git a/basis/regexp/disambiguate/disambiguate.factor b/basis/regexp/disambiguate/disambiguate.factor index fcde135cf8..33b2ded448 100644 --- a/basis/regexp/disambiguate/disambiguate.factor +++ b/basis/regexp/disambiguate/disambiguate.factor @@ -11,9 +11,7 @@ TUPLE: parts in out ; zip [ first ] partition [ values ] bi@ parts boa ; : powerset-partition ( sequence -- partitions ) - [ length [ 2^ ] keep ] keep '[ - _ _ make-partition - ] map rest ; + [ length [ 2^ iota ] keep ] keep '[ _ _ make-partition ] map rest ; : partition>class ( parts -- class ) [ out>> [ ] map ] diff --git a/basis/roman/roman.factor b/basis/roman/roman.factor index a645898c03..b3c0181ad2 100644 --- a/basis/roman/roman.factor +++ b/basis/roman/roman.factor @@ -48,7 +48,7 @@ PRIVATE> > ] [ ] [ infer out>> ] tri + [ infer in>> length ] [ ] [ infer out>> length ] tri '[ [ roman> ] _ napply @ [ >roman ] _ napply ] ; PRIVATE> @@ -58,8 +58,7 @@ PRIVATE> SYNTAX: ROMAN-OP: scan-word [ name>> "roman" prepend create-in ] keep 1quotation '[ _ binary-roman-op ] - dup infer [ in>> ] [ out>> ] bi - [ "string" ] bi@ define-declared ; + dup infer define-declared ; >> diff --git a/basis/serialize/serialize-tests.factor b/basis/serialize/serialize-tests.factor index 6dbc76386d..316eab6e5f 100644 --- a/basis/serialize/serialize-tests.factor +++ b/basis/serialize/serialize-tests.factor @@ -9,19 +9,19 @@ SPECIALIZED-ARRAY: double IN: serialize.tests : test-serialize-cell ( a -- ? ) - 2^ random dup + 2^ iota random dup binary [ serialize-cell ] with-byte-writer binary [ deserialize-cell ] with-byte-reader = ; [ t ] [ 100 [ drop - 40 [ test-serialize-cell ] all? - 4 [ 40 * test-serialize-cell ] all? - 4 [ 400 * test-serialize-cell ] all? - 4 [ 4000 * test-serialize-cell ] all? + 40 [ test-serialize-cell ] all-integers? + 4 [ 40 * test-serialize-cell ] all-integers? + 4 [ 400 * test-serialize-cell ] all-integers? + 4 [ 4000 * test-serialize-cell ] all-integers? and and and - ] all? + ] all-integers? ] unit-test TUPLE: serialize-test a b ; diff --git a/basis/serialize/serialize.factor b/basis/serialize/serialize.factor index 9b4b0ac46b..0840c778d7 100644 --- a/basis/serialize/serialize.factor +++ b/basis/serialize/serialize.factor @@ -240,7 +240,7 @@ SYMBOL: deserialized [ ] tri ; : copy-seq-to-tuple ( seq tuple -- ) - [ dup length ] dip [ set-array-nth ] curry 2each ; + [ set-array-nth ] curry each-index ; : deserialize-tuple ( -- array ) #! Ugly because we have to intern the tuple before reading diff --git a/basis/shuffle/shuffle.factor b/basis/shuffle/shuffle.factor index 0ff41edec6..b826606df5 100644 --- a/basis/shuffle/shuffle.factor +++ b/basis/shuffle/shuffle.factor @@ -8,7 +8,7 @@ IN: shuffle index-assoc ( sequence -- assoc ) - dup length zip >hashtable ; + dup length iota zip >hashtable ; PRIVATE> diff --git a/basis/sorting/insertion/insertion.factor b/basis/sorting/insertion/insertion.factor index 78b1493920..b7fefcad63 100644 --- a/basis/sorting/insertion/insertion.factor +++ b/basis/sorting/insertion/insertion.factor @@ -13,4 +13,4 @@ PRIVATE> : insertion-sort ( seq quot -- ) ! quot is a transformation on elements - over length [ insert ] with with each ; inline + over length [ insert ] with with each-integer ; inline diff --git a/basis/splitting/monotonic/monotonic.factor b/basis/splitting/monotonic/monotonic.factor index 3641345a3e..32bb8b46c6 100644 --- a/basis/splitting/monotonic/monotonic.factor +++ b/basis/splitting/monotonic/monotonic.factor @@ -26,7 +26,7 @@ PRIVATE> : (monotonic-slice) ( seq quot class -- slices ) [ dupd '[ - [ length ] [ ] [ 1 over change-circular-start ] tri + [ length iota ] [ ] [ 1 over change-circular-start ] tri [ @ not [ , ] [ drop ] if ] 3each ] { } make dup empty? [ over length 1 - prefix ] when -1 prefix 2 clump diff --git a/basis/stack-checker/errors/prettyprint/prettyprint.factor b/basis/stack-checker/errors/prettyprint/prettyprint.factor index d008c4921d..e577f0fe69 100644 --- a/basis/stack-checker/errors/prettyprint/prettyprint.factor +++ b/basis/stack-checker/errors/prettyprint/prettyprint.factor @@ -1,6 +1,6 @@ -! Copyright (C) 2008, 2009 Slava Pestov. +! Copyright (C) 2008, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel prettyprint io debugger +USING: accessors arrays kernel prettyprint io debugger sequences assocs stack-checker.errors summary effects ; IN: stack-checker.errors.prettyprint @@ -15,7 +15,7 @@ M: unbalanced-branches-error summary M: unbalanced-branches-error error. dup summary print - [ quots>> ] [ branches>> [ length ] { } assoc>map ] bi zip + [ quots>> ] [ branches>> [ length "x" ] { } assoc>map ] bi zip [ [ first pprint-short bl ] [ second effect>string print ] bi ] each ; M: too-many->r summary diff --git a/basis/stack-checker/inlining/inlining.factor b/basis/stack-checker/inlining/inlining.factor index 38ac2b0e71..20d61b9c37 100644 --- a/basis/stack-checker/inlining/inlining.factor +++ b/basis/stack-checker/inlining/inlining.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: fry namespaces assocs kernel sequences words accessors definitions math math.order effects classes arrays combinators @@ -42,7 +42,7 @@ loop? ; : make-copies ( values effect-in -- values' ) [ length cut* ] keep [ quotation-param? [ copy-value ] [ drop ] if ] 2map - [ make-values ] dip append ; + [ length make-values ] dip append ; SYMBOL: enter-in SYMBOL: enter-out diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index bbd8ecc407..b217f4d659 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -153,7 +153,7 @@ M: bad-executable summary : infer- ( -- ) \ - peek-d literal value>> second 1 + { tuple } + peek-d literal value>> second 1 + "obj" { tuple } apply-word/effect ; \ [ infer- ] "special" set-word-prop diff --git a/basis/stack-checker/stack-checker-tests.factor b/basis/stack-checker/stack-checker-tests.factor index 6718d31d7a..8a0724556e 100644 --- a/basis/stack-checker/stack-checker-tests.factor +++ b/basis/stack-checker/stack-checker-tests.factor @@ -289,21 +289,21 @@ DEFER: an-inline-word ERROR: custom-error ; -[ T{ effect f 0 0 t } ] [ +[ T{ effect f { } { } t } ] [ [ custom-error ] infer ] unit-test : funny-throw ( a -- * ) throw ; inline -[ T{ effect f 0 0 t } ] [ +[ T{ effect f { } { } t } ] [ [ 3 funny-throw ] infer ] unit-test -[ T{ effect f 0 0 t } ] [ +[ T{ effect f { } { } t } ] [ [ custom-error inference-error ] infer ] unit-test -[ T{ effect f 1 2 t } ] [ +[ T{ effect f { "x" } { "x" "x" } t } ] [ [ dup [ 3 throw ] dip ] infer ] unit-test diff --git a/basis/stack-checker/state/state.factor b/basis/stack-checker/state/state.factor index 1c527abfe4..f0b595ebe5 100644 --- a/basis/stack-checker/state/state.factor +++ b/basis/stack-checker/state/state.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: assocs arrays namespaces sequences kernel definitions math effects accessors words fry classes.algebra @@ -38,7 +38,9 @@ SYMBOL: literals : current-stack-height ( -- n ) meta-d length input-count get - ; : current-effect ( -- effect ) - input-count get meta-d length terminated? get effect boa ; + input-count get "x" + meta-d length "x" + terminated? get effect boa ; : init-inference ( -- ) terminated? off diff --git a/basis/strings/tables/tables.factor b/basis/strings/tables/tables.factor index 51032264c7..19d0051d17 100644 --- a/basis/strings/tables/tables.factor +++ b/basis/strings/tables/tables.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2009 Slava Pestov. +! Copyright (C) 2009, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences fry math.order splitting ; IN: strings.tables @@ -6,7 +6,7 @@ IN: strings.tables ] dip '[ 0 = @ ] 2map ; inline + [ dup length iota ] dip '[ 0 = @ ] 2map ; inline : max-length ( seq -- n ) [ length ] [ max ] map-reduce ; diff --git a/basis/suffix-arrays/suffix-arrays.factor b/basis/suffix-arrays/suffix-arrays.factor index f486adcb32..134c144fda 100644 --- a/basis/suffix-arrays/suffix-arrays.factor +++ b/basis/suffix-arrays/suffix-arrays.factor @@ -7,7 +7,7 @@ IN: suffix-arrays ( begin seq -- <=> ) [ <=> ] [ swap head? ] 2bi [ drop +eq+ ] when ; diff --git a/basis/threads/threads-tests.factor b/basis/threads/threads-tests.factor index f9196e2951..4568b7c491 100644 --- a/basis/threads/threads-tests.factor +++ b/basis/threads/threads-tests.factor @@ -1,6 +1,6 @@ USING: namespaces io tools.test threads kernel concurrency.combinators concurrency.promises locals math -words calendar ; +words calendar sequences ; IN: threads.tests 3 "x" set @@ -20,7 +20,7 @@ yield [ f ] [ f get-global ] unit-test { { 0 3 6 9 12 15 18 21 24 27 } } [ - 10 [ + 10 iota [ 0 "i" tset [ "i" [ yield 3 + ] tchange diff --git a/basis/tr/tr.factor b/basis/tr/tr.factor index f75adcbf04..690103edf5 100644 --- a/basis/tr/tr.factor +++ b/basis/tr/tr.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: byte-arrays strings sequences sequences.private ascii fry kernel words parser lexer assocs math math.order summary ; @@ -17,7 +17,7 @@ M: bad-tr summary [ [ ascii? ] all? ] both? [ bad-tr ] unless ; : compute-tr ( quot from to -- mapping ) - [ 128 ] 3dip zip + [ 128 iota ] 3dip zip '[ [ _ call( x -- y ) _ at ] keep or ] B{ } map-as ; inline : tr-hints ( word -- ) diff --git a/basis/tuple-arrays/tuple-arrays.factor b/basis/tuple-arrays/tuple-arrays.factor index 92e7541616..ce69388ca2 100644 --- a/basis/tuple-arrays/tuple-arrays.factor +++ b/basis/tuple-arrays/tuple-arrays.factor @@ -10,7 +10,7 @@ IN: tuple-arrays MACRO: boa-unsafe ( class -- quot ) tuple-layout '[ _ ] ; -MACRO: infer-in ( class -- quot ) infer in>> '[ _ ] ; +MACRO: infer-in ( class -- quot ) infer in>> length '[ _ ] ; : tuple-arity ( class -- quot ) '[ _ boa ] infer-in ; inline @@ -28,7 +28,7 @@ MACRO: infer-in ( class -- quot ) infer in>> '[ _ ] ; MACRO: write-tuple ( class -- quot ) [ '[ [ _ boa ] undo ] ] - [ tuple-arity [ '[ [ _ ] dip set-nth-unsafe ] ] map '[ _ cleave ] ] + [ tuple-arity iota [ '[ [ _ ] dip set-nth-unsafe ] ] map '[ _ cleave ] ] bi '[ _ dip @ ] ; PRIVATE> diff --git a/basis/ui/gadgets/gadgets-tests.factor b/basis/ui/gadgets/gadgets-tests.factor index d7f77d9e54..ea16abb9ba 100644 --- a/basis/ui/gadgets/gadgets-tests.factor +++ b/basis/ui/gadgets/gadgets-tests.factor @@ -123,7 +123,7 @@ M: mock-gadget ungraft* over >>model "g" get over add-gadget drop swap 1 + number>string set - ] each ; + ] each-integer ; : status-flags ( -- seq ) { "g" "1" "2" "3" } [ get graft-state>> ] map prune ; diff --git a/basis/ui/gadgets/packs/packs-tests.factor b/basis/ui/gadgets/packs/packs-tests.factor index b49f46c05a..7ca83ce465 100644 --- a/basis/ui/gadgets/packs/packs-tests.factor +++ b/basis/ui/gadgets/packs/packs-tests.factor @@ -1,14 +1,14 @@ USING: ui.gadgets.packs ui.gadgets.packs.private ui.gadgets.labels ui.gadgets ui.gadgets.debug ui.render ui.baseline-alignment kernel namespaces tools.test math.parser -sequences math.rectangles accessors ; +sequences math.rectangles accessors math ; IN: ui.gadgets.packs.tests [ t ] [ { 0 0 } { 100 100 } clip set - 100 [ number>string