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

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*

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
     [

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 ;
 

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? ;
 

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>>

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

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 ;

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, ;

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

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
+USING: accessors alien alien.c-types combinators compiler
-namespaces alien.c-types alien.syntax combinators locals init io
+compiler.codegen.fixup compiler.units cpu.architecture
-compiler compiler.units accessors ;
+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) "sse-version" get string>number [ min ] when* ;
-    "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

basis/math/floats/env/x86/x86.factor

@@ -1,6 +1,7 @@
-USING: accessors alien.c-types alien.syntax arrays assocs
+USING: accessors alien alien.c-types alien.syntax arrays assocs
-biassocs classes.struct combinators cpu.x86.features kernel
+biassocs classes.struct combinators cpu.x86.64
-literals math math.bitwise math.floats.env
+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
+HOOK: get-sse-env cpu ( sse-env -- )
-FUNCTION: void get_sse_env ( sse-env* env ) ;
+HOOK: set-sse-env cpu ( sse-env -- )
-FUNCTION: void set_sse_env ( sse-env* env ) ;
 
-FUNCTION: void get_x87_env ( x87-env* env ) ;
+HOOK: get-x87-env cpu ( x87-env -- )
-FUNCTION: void set_x87_env ( x87-env* 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 ;

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 '[ _ <callback> ] cache ;
 

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 -- )

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 ;

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 -- )

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

vm/Config.x86.32

@@ -1,2 +1 @@
-BOOT_ARCH = x86
+
-PLAF_DLL_OBJS += vm/cpu-x86.32.o

vm/Config.x86.64

@@ -1,2 +1 @@
-PLAF_DLL_OBJS += vm/cpu-x86.64.o
 CFLAGS += -DFACTOR_64

vm/cpu-x86.32.S

@@ -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

vm/cpu-x86.64.S

@@ -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"

vm/cpu-x86.S

@@ -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