-! 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
UNION: stack-frame-insn
##alien-invoke
##alien-indirect
+ ##alien-assembly
##alien-callback ;
M: stack-frame-insn compute-stack-frame*
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
[
INSN: ##alien-indirect
literal: params stack-frame ;
+INSN: ##alien-assembly
+literal: params stack-frame ;
+
INSN: ##alien-callback
literal: params stack-frame ;
-! 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
[ ##binary-float-function? ]
[ ##alien-invoke? ]
[ ##alien-indirect? ]
+ [ ##alien-assembly? ]
} 1||
] any? ;
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>>
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
-! 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
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 ;
-! 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
: #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 )
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, ;
: NOP ( -- ) HEX: 90 , ;
: PAUSE ( -- ) HEX: f3 , HEX: 90 , ;
+: RDTSC ( -- ) HEX: 0f , HEX: 31 , ;
: RDPMC ( -- ) HEX: 0f , HEX: 33 , ;
! x87 Floating Point Unit
: 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
-! 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
<PRIVATE
-FUNCTION: int sse_version ( ) ;
+: (sse-version) ( -- n )
+ int { } "cdecl" [
+ "sse-42" define-label
+ "sse-41" define-label
+ "ssse-3" define-label
+ "sse-3" define-label
+ "sse-2" define-label
+ "sse-1" define-label
+ "end" define-label
-FUNCTION: longlong read_timestamp_counter ( ) ;
+ int-regs return-reg 1 MOV
+
+ CPUID
+
+ ECX HEX: 100000 TEST
+ "sse-42" get JNE
+
+ ECX HEX: 80000 TEST
+ "sse-41" get JNE
+
+ ECX HEX: 200 TEST
+ "ssse-3" get JNE
+
+ ECX HEX: 1 TEST
+ "sse-3" get JNE
+
+ EDX HEX: 4000000 TEST
+ "sse-2" get JNE
+
+ EDX HEX: 2000000 TEST
+ "sse-1" get JNE
+
+ int-regs return-reg 0 MOV
+ "end" get JMP
+
+ "sse-42" resolve-label
+ int-regs return-reg 42 MOV
+ "end" get JMP
+
+ "sse-41" resolve-label
+ int-regs return-reg 41 MOV
+ "end" get JMP
+
+ "ssse-3" resolve-label
+ int-regs return-reg 33 MOV
+ "end" get JMP
+
+ "sse-3" resolve-label
+ int-regs return-reg 30 MOV
+ "end" get JMP
+
+ "sse-2" resolve-label
+ int-regs return-reg 20 MOV
+ "end" get JMP
+
+ "sse-1" resolve-label
+ int-regs return-reg 10 MOV
+
+ "end" resolve-label
+ ] alien-assembly ;
PRIVATE>
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
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
-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
{ 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 ) ;
-
-FUNCTION: void get_x87_env ( x87-env* env ) ;
-FUNCTION: void set_x87_env ( x87-env* env ) ;
+HOOK: get-sse-env cpu ( sse-env -- )
+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" [
+ 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 )
- 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 )
- 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? [ <sse-env> <x87-env> 2array ] [ <x87-env> 1array ] if ;
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 )
! 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 '[ _ <callback> ] cache ;
-! 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
\ 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 -- )
-! 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
M: f #drop, drop ;
M: f #alien-invoke, drop ;
M: f #alien-indirect, drop ;
+M: f #alien-assembly, drop ;
M: f #alien-callback, drop ;
-! 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
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 -- )
-! 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 ;
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 ;
: 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
-BOOT_ARCH = x86
-PLAF_DLL_OBJS += vm/cpu-x86.32.o
+
-PLAF_DLL_OBJS += vm/cpu-x86.64.o
CFLAGS += -DFACTOR_64
+++ /dev/null
-#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
+++ /dev/null
-#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"
+++ /dev/null
-/* 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