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