! Copyright (C) 2005, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
- USING: locals alien.c-types alien.libraries alien.syntax arrays
- kernel fry math namespaces sequences system layouts io
- vocabs.loader accessors init combinators command-line make
- compiler compiler.units compiler.constants compiler.alien
+ USING: locals alien alien.c-types alien.libraries alien.syntax
+ arrays kernel fry math namespaces sequences system layouts io
+ vocabs.loader accessors init classes.struct combinators command-line
+ make compiler compiler.units compiler.constants compiler.alien
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 vm ;
FROM: layouts => cell ;
+ FROM: alien.private => fastcall ;
IN: cpu.x86.32
M: x86.32 machine-registers
[ align-code ]
bi ;
-M: x86.32 pic-tail-reg EBX ;
+M: x86.32 pic-tail-reg EDX ;
- M: x86.32 reserved-stack-space 4 cells ;
+ M: x86.32 reserved-stack-space 0 ;
M: x86.32 %alien-invoke 0 CALL rc-relative rel-dlsym ;
: struct-return@ ( n -- operand )
[ next-stack@ ] [ stack-frame get params>> local@ ] if* ;
- ! On x86, parameters are never passed in registers.
+ ! On x86, parameters are usually never passed in registers, except with Microsoft's
+ ! "thiscall" and "fastcall" abis
M: int-regs return-reg drop EAX ;
- M: int-regs param-regs drop { } ;
- M: float-regs param-regs drop { } ;
+ M: float-regs param-regs 2drop { } ;
+
+ M: int-regs param-regs
+ nip {
+ { thiscall [ { ECX } ] }
+ { fastcall [ { ECX EDX } ] }
+ [ drop { } ]
+ } case ;
GENERIC: load-return-reg ( src rep -- )
GENERIC: store-return-reg ( dst rep -- )
+ M: stack-params load-return-reg drop EAX swap MOV ;
+ M: stack-params store-return-reg drop EAX MOV ;
+
M: int-rep load-return-reg drop EAX swap MOV ;
M: int-rep store-return-reg drop EAX MOV ;
M: x86.32 %prepare-jump
pic-tail-reg 0 MOV xt-tail-pic-offset rc-absolute-cell rel-here ;
- M: x86.32 %load-param-reg
- stack-params assert=
- [ [ EAX ] dip local@ MOV ] dip
- stack@ EAX MOV ;
+ M: stack-params copy-register*
+ drop
+ {
+ { [ dup integer? ] [ EAX swap next-stack@ MOV EAX MOV ] }
+ { [ over integer? ] [ EAX swap MOV param@ EAX MOV ] }
+ } cond ;
+
+ M: x86.32 %save-param-reg
+ dup stack-params? [ 3drop ] [ [ param@ ] 2dip %copy ] if ;
- M: x86.32 %save-param-reg 3drop ;
+ M: x86.32 %load-param-reg [ swap local@ ] dip %copy ;
: (%box) ( n rep -- )
#! If n is f, push the return register onto the stack; we
func "libm" load-library %alien-invoke
dst float-function-return ;
- : stdcall? ( params -- ? )
- abi>> "stdcall" = ;
-
: funny-large-struct-return? ( params -- ? )
#! MINGW ABI incompatibility disaster
[ return>> large-struct? ]
- [ abi>> "mingw" = os windows? not or ]
+ [ abi>> mingw = os windows? not or ]
bi and ;
+ : callee-cleanup? ( abi -- ? )
+ { stdcall fastcall thiscall } member? ;
+
+ : stack-arg-size ( params -- n )
+ dup abi>> '[
+ alien-parameters flatten-value-types
+ [ _ alloc-parameter 2drop ] each
+ stack-params get
+ ] with-param-regs ;
+
M: x86.32 %cleanup ( params -- )
- #! a) If we just called an stdcall function in Windows, it
+ #! a) If we just called a stdcall function in Windows, it
#! cleaned up the stack frame for us. But we don't want that
#! so we 'undo' the cleanup since we do that in %epilogue.
#! b) If we just called a function returning a struct, we
#! have to fix ESP.
{
- { [ dup stdcall? ] [ drop ESP stack-frame get params>> SUB ] }
+ { [ dup abi>> callee-cleanup? ] [ stack-arg-size ESP swap SUB ] }
{ [ dup funny-large-struct-return? ] [ drop EAX PUSH ] }
[ drop ]
} cond ;
} cond ;
! Dreadful
- M: object flatten-value-type (flatten-int-type) ;
+ M: object flatten-value-type (flatten-stack-type) ;
+ M: struct-c-type flatten-value-type (flatten-stack-type) ;
+ M: long-long-type flatten-value-type (flatten-stack-type) ;
+ M: c-type flatten-value-type
+ dup rep>> int-rep? [ (flatten-int-type) ] [ (flatten-stack-type) ] if ;
+
+ M: x86.32 struct-return-pointer-type (stack-value) ;
check-sse
! (c)2010 Joe Groff bsd license
- USING: accessors cursors make math sequences sorting tools.test ;
+ USING: accessors cursors kernel make math sequences sorting tools.test ;
FROM: cursors => each map assoc-each assoc>map ;
IN: cursors.tests
T{ linear-cursor f 1 1 } T{ linear-cursor f 5 1 } [ value>> 3 mod zero? ] -find
] unit-test
+ [ T{ linear-cursor f 5 1 } ] [
+ T{ linear-cursor f 1 1 } T{ linear-cursor f 5 1 } [ value>> 6 = ] -find
+ ] unit-test
+
[ { 1 3 } ] [
[ T{ linear-cursor f 1 2 } T{ linear-cursor f 5 2 } [ value>> , ] -each ]
{ } make
[ B{ } ] [ [ { } [ , ] each ] B{ } make ] unit-test
[ { 2 4 6 8 10 } ] [ { 1 2 3 4 5 } [ 2 * ] map ] unit-test
-[ { "roses: lutefisk" "tulips: lox" } ]
-[
- [
- { { "roses" "lutefisk" } { "tulips" "lox" } }
- [ ": " glue , ] assoc-each
- ] { } make
-] unit-test
-
-[ { "roses: lutefisk" "tulips: lox" } ]
-[
- { { "roses" "lutefisk" } { "tulips" "lox" } }
- [ ": " glue ] { } assoc>map
-] unit-test
-
[ { "roses: lutefisk" "tulips: lox" } ]
[
[
[ { 2 4 6 8 10 } ] [ { 1 2 3 4 5 } compile-test-map ] unit-test
[ { "roses: lutefisk" "tulips: lox" } ]
-[ [ { { "roses" "lutefisk" } { "tulips" "lox" } } compile-test-assoc-each ] { } make ] unit-test
+[
+ [ H{ { "roses" "lutefisk" } { "tulips" "lox" } } compile-test-assoc-each ]
+ { } make natural-sort
+] unit-test
[ { "roses: lutefisk" "tulips: lox" } ]
-[ { { "roses" "lutefisk" } { "tulips" "lox" } } compile-test-assoc>map ] unit-test
+[
+ H{ { "roses" "lutefisk" } { "tulips" "lox" } } compile-test-assoc>map
+ natural-sort
+] unit-test
projects / factor.git / commitdiff