Merge branch 'master' of git://factorcode.org/git/factor
commit
f0ceb33906
19
README.txt
19
README.txt
|
@ -20,25 +20,18 @@ implementation. It is not an introduction to the language itself.
|
|||
|
||||
* Compiling the Factor VM
|
||||
|
||||
The Factor runtime is written in GNU C++, and is built with GNU make and
|
||||
gcc.
|
||||
|
||||
Factor supports various platforms. For an up-to-date list, see
|
||||
<http://factorcode.org>.
|
||||
|
||||
Factor requires gcc 3.4 or later.
|
||||
|
||||
On x86, Factor /will not/ build using gcc 3.3 or earlier.
|
||||
|
||||
If you are using gcc 4.3, you might get an unusable Factor binary unless
|
||||
you add 'SITE_CFLAGS=-fno-forward-propagate' to the command-line
|
||||
arguments for make.
|
||||
The Factor VM is written in C++ and uses GNU extensions. When compiling
|
||||
with GCC 3.x, boost::unordered_map must be installed. On GCC 4.x, Factor
|
||||
uses std::tr1::unordered_map which is shipped as part of GCC.
|
||||
|
||||
Run 'make' ('gmake' on *BSD) with no parameters to build the Factor VM.
|
||||
|
||||
* Bootstrapping the Factor image
|
||||
|
||||
Once you have compiled the Factor runtime, you must bootstrap the Factor
|
||||
Once you have compiled the Factor VM, you must bootstrap the Factor
|
||||
system using the image that corresponds to your CPU architecture.
|
||||
|
||||
Boot images can be obtained from <http://factorcode.org/images/latest/>.
|
||||
|
@ -97,7 +90,7 @@ When compiling Factor, pass the X11=1 parameter:
|
|||
|
||||
Then bootstrap with the following switches:
|
||||
|
||||
./factor -i=boot.<cpu>.image -ui-backend=x11 -ui-text-backend=pango
|
||||
./factor -i=boot.<cpu>.image -ui-backend=x11
|
||||
|
||||
Now if $DISPLAY is set, running ./factor will start the UI.
|
||||
|
||||
|
@ -138,7 +131,7 @@ usage documentation, enter the following in the UI listener:
|
|||
The Factor source tree is organized as follows:
|
||||
|
||||
build-support/ - scripts used for compiling Factor
|
||||
vm/ - sources for the Factor VM, written in C++
|
||||
vm/ - Factor VM
|
||||
core/ - Factor core library
|
||||
basis/ - Factor basis library, compiler, tools
|
||||
extra/ - more libraries and applications
|
||||
|
|
|
@ -409,10 +409,10 @@ CONSTANT: primitive-types
|
|||
"uchar" define-primitive-type
|
||||
|
||||
<c-type>
|
||||
[ alien-unsigned-4 zero? not ] >>getter
|
||||
[ [ 1 0 ? ] 2dip set-alien-unsigned-4 ] >>setter
|
||||
4 >>size
|
||||
4 >>align
|
||||
[ alien-unsigned-1 zero? not ] >>getter
|
||||
[ [ 1 0 ? ] 2dip set-alien-unsigned-1 ] >>setter
|
||||
1 >>size
|
||||
1 >>align
|
||||
"box_boolean" >>boxer
|
||||
"to_boolean" >>unboxer
|
||||
"bool" define-primitive-type
|
||||
|
|
|
@ -5,7 +5,7 @@ IN: alien.libraries
|
|||
|
||||
: dlopen ( path -- dll ) native-string>alien (dlopen) ;
|
||||
|
||||
: dlsym ( name dll -- alien ) [ native-string>alien ] dip (dlsym) ;
|
||||
: dlsym ( name dll -- alien ) [ string>symbol ] dip (dlsym) ;
|
||||
|
||||
SYMBOL: libraries
|
||||
|
||||
|
|
|
@ -41,7 +41,7 @@ nl
|
|||
! which are also quick to compile are replaced by
|
||||
! compiled definitions as soon as possible.
|
||||
{
|
||||
roll -roll declare not
|
||||
not
|
||||
|
||||
array? hashtable? vector?
|
||||
tuple? sbuf? tombstone?
|
||||
|
|
|
@ -9,7 +9,7 @@ classes.builtin classes.tuple classes.tuple.private vocabs
|
|||
vocabs.loader source-files definitions debugger quotations.private
|
||||
sequences.private combinators math.order math.private accessors
|
||||
slots.private generic.single.private compiler.units compiler.constants
|
||||
fry ;
|
||||
fry bootstrap.image.syntax ;
|
||||
IN: bootstrap.image
|
||||
|
||||
: arch ( os cpu -- arch )
|
||||
|
@ -93,24 +93,19 @@ CONSTANT: -1-offset 9
|
|||
|
||||
SYMBOL: sub-primitives
|
||||
|
||||
SYMBOL: jit-define-rc
|
||||
SYMBOL: jit-define-rt
|
||||
SYMBOL: jit-define-offset
|
||||
SYMBOL: jit-relocations
|
||||
|
||||
: compute-offset ( -- offset )
|
||||
building get length jit-define-rc get rc-absolute-cell = bootstrap-cell 4 ? - ;
|
||||
: compute-offset ( rc -- offset )
|
||||
[ building get length ] dip rc-absolute-cell = bootstrap-cell 4 ? - ;
|
||||
|
||||
: jit-rel ( rc rt -- )
|
||||
jit-define-rt set
|
||||
jit-define-rc set
|
||||
compute-offset jit-define-offset set ;
|
||||
over compute-offset 3array jit-relocations get push-all ;
|
||||
|
||||
: make-jit ( quot -- quad )
|
||||
: make-jit ( quot -- jit-data )
|
||||
[
|
||||
V{ } clone jit-relocations set
|
||||
call( -- )
|
||||
jit-define-rc get
|
||||
jit-define-rt get
|
||||
jit-define-offset get 3array
|
||||
jit-relocations get >array
|
||||
] B{ } make prefix ;
|
||||
|
||||
: jit-define ( quot name -- )
|
||||
|
@ -128,98 +123,59 @@ SYMBOL: big-endian
|
|||
! Bootstrap architecture name
|
||||
SYMBOL: architecture
|
||||
|
||||
! Bootstrap global namesapce
|
||||
SYMBOL: bootstrap-global
|
||||
RESET
|
||||
|
||||
! Boot quotation, set in stage1.factor
|
||||
SYMBOL: bootstrap-boot-quot
|
||||
USERENV: bootstrap-boot-quot 20
|
||||
|
||||
! Bootstrap global namesapce
|
||||
USERENV: bootstrap-global 21
|
||||
|
||||
! JIT parameters
|
||||
SYMBOL: jit-prolog
|
||||
SYMBOL: jit-primitive-word
|
||||
SYMBOL: jit-primitive
|
||||
SYMBOL: jit-word-jump
|
||||
SYMBOL: jit-word-call
|
||||
SYMBOL: jit-push-immediate
|
||||
SYMBOL: jit-if-word
|
||||
SYMBOL: jit-if-1
|
||||
SYMBOL: jit-if-2
|
||||
SYMBOL: jit-dip-word
|
||||
SYMBOL: jit-dip
|
||||
SYMBOL: jit-2dip-word
|
||||
SYMBOL: jit-2dip
|
||||
SYMBOL: jit-3dip-word
|
||||
SYMBOL: jit-3dip
|
||||
SYMBOL: jit-execute-word
|
||||
SYMBOL: jit-execute-jump
|
||||
SYMBOL: jit-execute-call
|
||||
SYMBOL: jit-epilog
|
||||
SYMBOL: jit-return
|
||||
SYMBOL: jit-profiling
|
||||
SYMBOL: jit-save-stack
|
||||
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-word-special 28
|
||||
USERENV: jit-if-word 29
|
||||
USERENV: jit-if 30
|
||||
USERENV: jit-epilog 31
|
||||
USERENV: jit-return 32
|
||||
USERENV: jit-profiling 33
|
||||
USERENV: jit-push-immediate 34
|
||||
USERENV: jit-dip-word 35
|
||||
USERENV: jit-dip 36
|
||||
USERENV: jit-2dip-word 37
|
||||
USERENV: jit-2dip 38
|
||||
USERENV: jit-3dip-word 39
|
||||
USERENV: jit-3dip 40
|
||||
USERENV: jit-execute-word 41
|
||||
USERENV: jit-execute-jump 42
|
||||
USERENV: jit-execute-call 43
|
||||
|
||||
! PIC stubs
|
||||
SYMBOL: pic-load
|
||||
SYMBOL: pic-tag
|
||||
SYMBOL: pic-hi-tag
|
||||
SYMBOL: pic-tuple
|
||||
SYMBOL: pic-hi-tag-tuple
|
||||
SYMBOL: pic-check-tag
|
||||
SYMBOL: pic-check
|
||||
SYMBOL: pic-hit
|
||||
SYMBOL: pic-miss-word
|
||||
USERENV: pic-load 47
|
||||
USERENV: pic-tag 48
|
||||
USERENV: pic-hi-tag 49
|
||||
USERENV: pic-tuple 50
|
||||
USERENV: pic-hi-tag-tuple 51
|
||||
USERENV: pic-check-tag 52
|
||||
USERENV: pic-check 53
|
||||
USERENV: pic-hit 54
|
||||
USERENV: pic-miss-word 55
|
||||
USERENV: pic-miss-tail-word 56
|
||||
|
||||
! Megamorphic dispatch
|
||||
SYMBOL: mega-lookup
|
||||
SYMBOL: mega-lookup-word
|
||||
SYMBOL: mega-miss-word
|
||||
USERENV: mega-lookup 57
|
||||
USERENV: mega-lookup-word 58
|
||||
USERENV: mega-miss-word 59
|
||||
|
||||
! Default definition for undefined words
|
||||
SYMBOL: undefined-quot
|
||||
|
||||
: userenvs ( -- assoc )
|
||||
H{
|
||||
{ bootstrap-boot-quot 20 }
|
||||
{ bootstrap-global 21 }
|
||||
{ jit-prolog 23 }
|
||||
{ jit-primitive-word 24 }
|
||||
{ jit-primitive 25 }
|
||||
{ jit-word-jump 26 }
|
||||
{ jit-word-call 27 }
|
||||
{ jit-if-word 28 }
|
||||
{ jit-if-1 29 }
|
||||
{ jit-if-2 30 }
|
||||
{ jit-epilog 33 }
|
||||
{ jit-return 34 }
|
||||
{ jit-profiling 35 }
|
||||
{ jit-push-immediate 36 }
|
||||
{ jit-save-stack 38 }
|
||||
{ jit-dip-word 39 }
|
||||
{ jit-dip 40 }
|
||||
{ jit-2dip-word 41 }
|
||||
{ jit-2dip 42 }
|
||||
{ jit-3dip-word 43 }
|
||||
{ jit-3dip 44 }
|
||||
{ jit-execute-word 45 }
|
||||
{ jit-execute-jump 46 }
|
||||
{ jit-execute-call 47 }
|
||||
{ pic-load 48 }
|
||||
{ pic-tag 49 }
|
||||
{ pic-hi-tag 50 }
|
||||
{ pic-tuple 51 }
|
||||
{ pic-hi-tag-tuple 52 }
|
||||
{ pic-check-tag 53 }
|
||||
{ pic-check 54 }
|
||||
{ pic-hit 55 }
|
||||
{ pic-miss-word 56 }
|
||||
{ mega-lookup 57 }
|
||||
{ mega-lookup-word 58 }
|
||||
{ mega-miss-word 59 }
|
||||
{ undefined-quot 60 }
|
||||
} ; inline
|
||||
USERENV: undefined-quot 60
|
||||
|
||||
: userenv-offset ( symbol -- n )
|
||||
userenvs at header-size + ;
|
||||
userenvs get at header-size + ;
|
||||
|
||||
: emit ( cell -- ) image get push ;
|
||||
|
||||
|
@ -351,7 +307,8 @@ M: f '
|
|||
[ vocabulary>> , ]
|
||||
[ def>> , ]
|
||||
[ props>> , ]
|
||||
[ direct-entry-def>> , ] ! direct-entry-def
|
||||
[ pic-def>> , ]
|
||||
[ pic-tail-def>> , ]
|
||||
[ drop 0 , ] ! count
|
||||
[ word-sub-primitive , ]
|
||||
[ drop 0 , ] ! xt
|
||||
|
@ -510,11 +467,7 @@ M: quotation '
|
|||
class<=-cache class-not-cache classes-intersect-cache
|
||||
class-and-cache class-or-cache next-method-quot-cache
|
||||
} [ H{ } clone ] H{ } map>assoc assoc-union
|
||||
bootstrap-global set
|
||||
bootstrap-global emit-userenv ;
|
||||
|
||||
: emit-boot-quot ( -- )
|
||||
bootstrap-boot-quot emit-userenv ;
|
||||
bootstrap-global set ;
|
||||
|
||||
: emit-jit-data ( -- )
|
||||
\ if jit-if-word set
|
||||
|
@ -524,46 +477,13 @@ M: quotation '
|
|||
\ 3dip jit-3dip-word set
|
||||
\ (execute) jit-execute-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
|
||||
[ undefined ] undefined-quot set
|
||||
{
|
||||
jit-prolog
|
||||
jit-primitive-word
|
||||
jit-primitive
|
||||
jit-word-jump
|
||||
jit-word-call
|
||||
jit-push-immediate
|
||||
jit-if-word
|
||||
jit-if-1
|
||||
jit-if-2
|
||||
jit-dip-word
|
||||
jit-dip
|
||||
jit-2dip-word
|
||||
jit-2dip
|
||||
jit-3dip-word
|
||||
jit-3dip
|
||||
jit-execute-word
|
||||
jit-execute-jump
|
||||
jit-execute-call
|
||||
jit-epilog
|
||||
jit-return
|
||||
jit-profiling
|
||||
jit-save-stack
|
||||
pic-load
|
||||
pic-tag
|
||||
pic-hi-tag
|
||||
pic-tuple
|
||||
pic-hi-tag-tuple
|
||||
pic-check-tag
|
||||
pic-check
|
||||
pic-hit
|
||||
pic-miss-word
|
||||
mega-lookup
|
||||
mega-lookup-word
|
||||
mega-miss-word
|
||||
undefined-quot
|
||||
} [ emit-userenv ] each ;
|
||||
[ undefined ] undefined-quot set ;
|
||||
|
||||
: emit-userenvs ( -- )
|
||||
userenvs get keys [ emit-userenv ] each ;
|
||||
|
||||
: fixup-header ( -- )
|
||||
heap-size data-heap-size-offset fixup ;
|
||||
|
@ -580,8 +500,8 @@ M: quotation '
|
|||
emit-jit-data
|
||||
"Serializing global namespace..." print flush
|
||||
emit-global
|
||||
"Serializing boot quotation..." print flush
|
||||
emit-boot-quot
|
||||
"Serializing user environment..." print flush
|
||||
emit-userenvs
|
||||
"Performing word fixups..." print flush
|
||||
fixup-words
|
||||
"Performing header fixups..." print flush
|
||||
|
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
|
@ -0,0 +1,14 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: parser kernel namespaces assocs words.symbol ;
|
||||
IN: bootstrap.image.syntax
|
||||
|
||||
SYMBOL: userenvs
|
||||
|
||||
SYNTAX: RESET H{ } clone userenvs set-global ;
|
||||
|
||||
SYNTAX: USERENV:
|
||||
CREATE-WORD scan-word
|
||||
[ swap userenvs get set-at ]
|
||||
[ drop define-symbol ]
|
||||
2bi ;
|
|
@ -88,7 +88,7 @@ M: ##call generate-insn
|
|||
word>> dup sub-primitive>>
|
||||
[ first % ] [ [ add-call ] [ %call ] bi ] ?if ;
|
||||
|
||||
M: ##jump generate-insn word>> [ add-call ] [ %jump-label ] bi ;
|
||||
M: ##jump generate-insn word>> [ add-call ] [ %jump ] bi ;
|
||||
|
||||
M: ##return generate-insn drop %return ;
|
||||
|
||||
|
|
|
@ -56,8 +56,11 @@ SYMBOL: literal-table
|
|||
: rel-word ( word class -- )
|
||||
[ add-literal ] dip rt-xt rel-fixup ;
|
||||
|
||||
: rel-word-direct ( word class -- )
|
||||
[ add-literal ] dip rt-xt-direct rel-fixup ;
|
||||
: rel-word-pic ( word class -- )
|
||||
[ add-literal ] dip rt-xt-pic rel-fixup ;
|
||||
|
||||
: rel-word-pic-tail ( word class -- )
|
||||
[ add-literal ] dip rt-xt-pic-tail rel-fixup ;
|
||||
|
||||
: rel-primitive ( word class -- )
|
||||
[ def>> first add-literal ] dip rt-primitive rel-fixup ;
|
||||
|
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: math kernel layouts system strings words quotations byte-arrays
|
||||
alien arrays ;
|
||||
alien arrays literals sequences ;
|
||||
IN: compiler.constants
|
||||
|
||||
! These constants must match vm/memory.h
|
||||
|
@ -14,42 +14,42 @@ CONSTANT: deck-bits 18
|
|||
: float-offset ( -- n ) 8 float tag-number - ; inline
|
||||
: string-offset ( -- n ) 4 bootstrap-cells string tag-number - ; inline
|
||||
: string-aux-offset ( -- n ) 2 bootstrap-cells string tag-number - ; inline
|
||||
: profile-count-offset ( -- n ) 7 bootstrap-cells \ word tag-number - ; inline
|
||||
: profile-count-offset ( -- n ) 8 bootstrap-cells \ word tag-number - ; inline
|
||||
: byte-array-offset ( -- n ) 2 bootstrap-cells byte-array tag-number - ; inline
|
||||
: alien-offset ( -- n ) 3 bootstrap-cells alien tag-number - ; inline
|
||||
: underlying-alien-offset ( -- n ) bootstrap-cell alien tag-number - ; inline
|
||||
: tuple-class-offset ( -- n ) bootstrap-cell tuple tag-number - ; inline
|
||||
: word-xt-offset ( -- n ) 9 bootstrap-cells \ word tag-number - ; inline
|
||||
: word-xt-offset ( -- n ) 10 bootstrap-cells \ word tag-number - ; inline
|
||||
: quot-xt-offset ( -- n ) 5 bootstrap-cells quotation tag-number - ; inline
|
||||
: word-code-offset ( -- n ) 10 bootstrap-cells \ word tag-number - ; inline
|
||||
: word-code-offset ( -- n ) 11 bootstrap-cells \ word tag-number - ; inline
|
||||
: array-start-offset ( -- n ) 2 bootstrap-cells array tag-number - ; inline
|
||||
: compiled-header-size ( -- n ) 5 bootstrap-cells ; inline
|
||||
: compiled-header-size ( -- n ) 4 bootstrap-cells ; inline
|
||||
|
||||
! Relocation classes
|
||||
CONSTANT: rc-absolute-cell 0
|
||||
CONSTANT: rc-absolute 1
|
||||
CONSTANT: rc-relative 2
|
||||
CONSTANT: rc-absolute-cell 0
|
||||
CONSTANT: rc-absolute 1
|
||||
CONSTANT: rc-relative 2
|
||||
CONSTANT: rc-absolute-ppc-2/2 3
|
||||
CONSTANT: rc-relative-ppc-2 4
|
||||
CONSTANT: rc-relative-ppc-3 5
|
||||
CONSTANT: rc-relative-arm-3 6
|
||||
CONSTANT: rc-indirect-arm 7
|
||||
CONSTANT: rc-indirect-arm-pc 8
|
||||
CONSTANT: rc-absolute-ppc-2 4
|
||||
CONSTANT: rc-relative-ppc-2 5
|
||||
CONSTANT: rc-relative-ppc-3 6
|
||||
CONSTANT: rc-relative-arm-3 7
|
||||
CONSTANT: rc-indirect-arm 8
|
||||
CONSTANT: rc-indirect-arm-pc 9
|
||||
|
||||
! Relocation types
|
||||
CONSTANT: rt-primitive 0
|
||||
CONSTANT: rt-dlsym 1
|
||||
CONSTANT: rt-dispatch 2
|
||||
CONSTANT: rt-xt 3
|
||||
CONSTANT: rt-xt-direct 4
|
||||
CONSTANT: rt-here 5
|
||||
CONSTANT: rt-this 6
|
||||
CONSTANT: rt-immediate 7
|
||||
CONSTANT: rt-stack-chain 8
|
||||
CONSTANT: rt-untagged 9
|
||||
CONSTANT: rt-primitive 0
|
||||
CONSTANT: rt-dlsym 1
|
||||
CONSTANT: rt-dispatch 2
|
||||
CONSTANT: rt-xt 3
|
||||
CONSTANT: rt-xt-pic 4
|
||||
CONSTANT: rt-xt-pic-tail 5
|
||||
CONSTANT: rt-here 6
|
||||
CONSTANT: rt-this 7
|
||||
CONSTANT: rt-immediate 8
|
||||
CONSTANT: rt-stack-chain 9
|
||||
CONSTANT: rt-untagged 10
|
||||
CONSTANT: rt-megamorphic-cache-hits 11
|
||||
|
||||
: rc-absolute? ( n -- ? )
|
||||
[ rc-absolute-ppc-2/2 = ]
|
||||
[ rc-absolute-cell = ]
|
||||
[ rc-absolute = ]
|
||||
tri or or ;
|
||||
${ rc-absolute-ppc-2/2 rc-absolute-cell rc-absolute } member? ;
|
||||
|
|
|
@ -588,3 +588,16 @@ FUNCTION: complex-float ffi_test_47 ( complex-float x, complex-double y ) ;
|
|||
C{ 1.0 2.0 }
|
||||
C{ 1.5 1.0 } ffi_test_47
|
||||
] unit-test
|
||||
|
||||
! Reported by jedahu
|
||||
C-STRUCT: bool-field-test
|
||||
{ "char*" "name" }
|
||||
{ "bool" "on" }
|
||||
{ "short" "parents" } ;
|
||||
|
||||
FUNCTION: short ffi_test_48 ( bool-field-test x ) ;
|
||||
|
||||
[ 123 ] [
|
||||
"bool-field-test" <c-object> 123 over set-bool-field-test-parents
|
||||
ffi_test_48
|
||||
] unit-test
|
|
@ -389,4 +389,10 @@ DEFER: loop-bbb
|
|||
|
||||
[ f ] [ \ broken-declaration optimized? ] unit-test
|
||||
|
||||
[ ] [ [ \ broken-declaration forget ] with-compilation-unit ] unit-test
|
||||
[ ] [ [ \ broken-declaration forget ] with-compilation-unit ] unit-test
|
||||
|
||||
! Modular arithmetic bug
|
||||
: modular-arithmetic-bug ( a -- b ) >integer 256 mod ;
|
||||
|
||||
[ 1 ] [ 257 modular-arithmetic-bug ] unit-test
|
||||
[ -10 ] [ -10 modular-arithmetic-bug ] unit-test
|
|
@ -98,13 +98,18 @@ TUPLE: declared-fixnum { x fixnum } ;
|
|||
] { mod fixnum-mod } inlined?
|
||||
] unit-test
|
||||
|
||||
|
||||
[ f ] [
|
||||
[
|
||||
256 mod
|
||||
] { mod fixnum-mod } inlined?
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
[
|
||||
>fixnum 256 mod
|
||||
] { mod fixnum-mod } inlined?
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
[
|
||||
dup 0 >= [ 256 mod ] when
|
||||
|
@ -128,3 +133,6 @@ TUPLE: declared-fixnum { x fixnum } ;
|
|||
{ integer } declare [ 256 rem ] map
|
||||
] { mod fixnum-mod rem } inlined?
|
||||
] unit-test
|
||||
|
||||
[ [ >fixnum 255 fixnum-bitand ] ]
|
||||
[ [ >integer 256 rem ] test-modular-arithmetic ] unit-test
|
|
@ -2,6 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: math math.partial-dispatch namespaces sequences sets
|
||||
accessors assocs words kernel memoize fry combinators
|
||||
combinators.short-circuit
|
||||
compiler.tree
|
||||
compiler.tree.combinators
|
||||
compiler.tree.def-use
|
||||
|
@ -69,6 +70,12 @@ GENERIC: optimize-modular-arithmetic* ( node -- nodes )
|
|||
: optimize->fixnum ( #call -- nodes )
|
||||
dup redundant->fixnum? [ drop f ] when ;
|
||||
|
||||
: optimize->integer ( #call -- nodes )
|
||||
dup out-d>> first actually-used-by dup length 1 = [
|
||||
first node>> { [ #call? ] [ word>> \ >fixnum eq? ] } 1&&
|
||||
[ drop { } ] when
|
||||
] [ drop ] if ;
|
||||
|
||||
MEMO: fixnum-coercion ( flags -- nodes )
|
||||
[ [ ] [ >fixnum ] ? ] map '[ _ spread ] splice-quot ;
|
||||
|
||||
|
@ -87,6 +94,7 @@ MEMO: fixnum-coercion ( flags -- nodes )
|
|||
M: #call optimize-modular-arithmetic*
|
||||
dup word>> {
|
||||
{ [ dup \ >fixnum eq? ] [ drop optimize->fixnum ] }
|
||||
{ [ dup \ >integer eq? ] [ drop optimize->integer ] }
|
||||
{ [ dup "modular-arithmetic" word-prop ] [ drop optimize-modular-op ] }
|
||||
[ drop ]
|
||||
} cond ;
|
||||
|
|
|
@ -148,10 +148,6 @@ most-negative-fixnum most-positive-fixnum [a,b]
|
|||
comparison-ops
|
||||
[ dup '[ _ define-comparison-constraints ] each-derived-op ] each
|
||||
|
||||
! generic-comparison-ops [
|
||||
! dup specific-comparison define-comparison-constraints
|
||||
! ] each
|
||||
|
||||
! Remove redundant comparisons
|
||||
: fold-comparison ( info1 info2 word -- info )
|
||||
[ [ interval>> ] bi@ ] dip interval-comparison {
|
||||
|
@ -217,6 +213,8 @@ generic-comparison-ops [
|
|||
{ >float float }
|
||||
{ fixnum>float float }
|
||||
{ bignum>float float }
|
||||
|
||||
{ >integer integer }
|
||||
} [
|
||||
'[
|
||||
_
|
||||
|
@ -228,19 +226,26 @@ generic-comparison-ops [
|
|||
] "outputs" set-word-prop
|
||||
] assoc-each
|
||||
|
||||
: rem-custom-inlining ( #call -- quot/f )
|
||||
second value-info literal>> dup integer?
|
||||
[ power-of-2? [ 1- bitand ] f ? ] [ drop f ] if ;
|
||||
|
||||
{
|
||||
mod-integer-integer
|
||||
mod-integer-fixnum
|
||||
mod-fixnum-integer
|
||||
fixnum-mod
|
||||
rem
|
||||
} [
|
||||
[
|
||||
in-d>> second value-info >literal<
|
||||
[ dup integer? [ power-of-2? [ 1- bitand ] f ? ] [ drop f ] if ] when
|
||||
in-d>> dup first value-info interval>> [0,inf] interval-subset?
|
||||
[ rem-custom-inlining ] [ drop f ] if
|
||||
] "custom-inlining" set-word-prop
|
||||
] each
|
||||
|
||||
\ rem [
|
||||
in-d>> rem-custom-inlining
|
||||
] "custom-inlining" set-word-prop
|
||||
|
||||
{
|
||||
bitand-integer-integer
|
||||
bitand-integer-fixnum
|
||||
|
|
|
@ -690,4 +690,7 @@ TUPLE: littledan-2 { from read-only } { to read-only } ;
|
|||
! Mutable tuples with circularity should not cause problems
|
||||
TUPLE: circle me ;
|
||||
|
||||
[ ] [ circle new dup >>me 1quotation final-info drop ] unit-test
|
||||
[ ] [ circle new dup >>me 1quotation final-info drop ] unit-test
|
||||
|
||||
! Joe found an oversight
|
||||
[ V{ integer } ] [ [ >integer ] final-classes ] unit-test
|
|
@ -47,6 +47,7 @@ HOOK: %inc-r cpu ( n -- )
|
|||
|
||||
HOOK: stack-frame-size cpu ( stack-frame -- n )
|
||||
HOOK: %call cpu ( word -- )
|
||||
HOOK: %jump cpu ( word -- )
|
||||
HOOK: %jump-label cpu ( label -- )
|
||||
HOOK: %return cpu ( -- )
|
||||
|
||||
|
|
|
@ -3,114 +3,114 @@ USING: cpu.ppc.assembler tools.test arrays kernel namespaces
|
|||
make vocabs sequences ;
|
||||
|
||||
: test-assembler ( expected quot -- )
|
||||
[ 1array ] [ [ { } make ] curry ] bi* unit-test ;
|
||||
[ 1array ] [ [ B{ } make ] curry ] bi* unit-test ;
|
||||
|
||||
{ HEX: 38220003 } [ 1 2 3 ADDI ] test-assembler
|
||||
{ HEX: 3c220003 } [ 1 2 3 ADDIS ] test-assembler
|
||||
{ HEX: 30220003 } [ 1 2 3 ADDIC ] test-assembler
|
||||
{ HEX: 34220003 } [ 1 2 3 ADDIC. ] test-assembler
|
||||
{ HEX: 38400001 } [ 1 2 LI ] test-assembler
|
||||
{ HEX: 3c400001 } [ 1 2 LIS ] test-assembler
|
||||
{ HEX: 3822fffd } [ 1 2 3 SUBI ] test-assembler
|
||||
{ HEX: 1c220003 } [ 1 2 3 MULI ] test-assembler
|
||||
{ HEX: 7c221a14 } [ 1 2 3 ADD ] test-assembler
|
||||
{ HEX: 7c221a15 } [ 1 2 3 ADD. ] test-assembler
|
||||
{ HEX: 7c221e14 } [ 1 2 3 ADDO ] test-assembler
|
||||
{ HEX: 7c221e15 } [ 1 2 3 ADDO. ] test-assembler
|
||||
{ HEX: 7c221814 } [ 1 2 3 ADDC ] test-assembler
|
||||
{ HEX: 7c221815 } [ 1 2 3 ADDC. ] test-assembler
|
||||
{ HEX: 7c221e14 } [ 1 2 3 ADDO ] test-assembler
|
||||
{ HEX: 7c221c15 } [ 1 2 3 ADDCO. ] test-assembler
|
||||
{ HEX: 7c221914 } [ 1 2 3 ADDE ] test-assembler
|
||||
{ HEX: 7c411838 } [ 1 2 3 AND ] test-assembler
|
||||
{ HEX: 7c411839 } [ 1 2 3 AND. ] test-assembler
|
||||
{ HEX: 7c221bd6 } [ 1 2 3 DIVW ] test-assembler
|
||||
{ HEX: 7c221b96 } [ 1 2 3 DIVWU ] test-assembler
|
||||
{ HEX: 7c411a38 } [ 1 2 3 EQV ] test-assembler
|
||||
{ HEX: 7c411bb8 } [ 1 2 3 NAND ] test-assembler
|
||||
{ HEX: 7c4118f8 } [ 1 2 3 NOR ] test-assembler
|
||||
{ HEX: 7c4110f8 } [ 1 2 NOT ] test-assembler
|
||||
{ HEX: 60410003 } [ 1 2 3 ORI ] test-assembler
|
||||
{ HEX: 64410003 } [ 1 2 3 ORIS ] test-assembler
|
||||
{ HEX: 7c411b78 } [ 1 2 3 OR ] test-assembler
|
||||
{ HEX: 7c411378 } [ 1 2 MR ] test-assembler
|
||||
{ HEX: 7c221896 } [ 1 2 3 MULHW ] test-assembler
|
||||
{ HEX: 1c220003 } [ 1 2 3 MULLI ] test-assembler
|
||||
{ HEX: 7c221816 } [ 1 2 3 MULHWU ] test-assembler
|
||||
{ HEX: 7c2219d6 } [ 1 2 3 MULLW ] test-assembler
|
||||
{ HEX: 7c411830 } [ 1 2 3 SLW ] test-assembler
|
||||
{ HEX: 7c411e30 } [ 1 2 3 SRAW ] test-assembler
|
||||
{ HEX: 7c411c30 } [ 1 2 3 SRW ] test-assembler
|
||||
{ HEX: 7c411e70 } [ 1 2 3 SRAWI ] test-assembler
|
||||
{ HEX: 7c221850 } [ 1 2 3 SUBF ] test-assembler
|
||||
{ HEX: 7c221810 } [ 1 2 3 SUBFC ] test-assembler
|
||||
{ HEX: 7c221910 } [ 1 2 3 SUBFE ] test-assembler
|
||||
{ HEX: 7c410774 } [ 1 2 EXTSB ] test-assembler
|
||||
{ HEX: 68410003 } [ 1 2 3 XORI ] test-assembler
|
||||
{ HEX: 7c411a78 } [ 1 2 3 XOR ] test-assembler
|
||||
{ HEX: 7c2200d0 } [ 1 2 NEG ] test-assembler
|
||||
{ HEX: 2c220003 } [ 1 2 3 CMPI ] test-assembler
|
||||
{ HEX: 28220003 } [ 1 2 3 CMPLI ] test-assembler
|
||||
{ HEX: 7c411800 } [ 1 2 3 CMP ] test-assembler
|
||||
{ HEX: 5422190a } [ 1 2 3 4 5 RLWINM ] test-assembler
|
||||
{ HEX: 54221838 } [ 1 2 3 SLWI ] test-assembler
|
||||
{ HEX: 5422e8fe } [ 1 2 3 SRWI ] test-assembler
|
||||
{ HEX: 88220003 } [ 1 2 3 LBZ ] test-assembler
|
||||
{ HEX: 8c220003 } [ 1 2 3 LBZU ] test-assembler
|
||||
{ HEX: a8220003 } [ 1 2 3 LHA ] test-assembler
|
||||
{ HEX: ac220003 } [ 1 2 3 LHAU ] test-assembler
|
||||
{ HEX: a0220003 } [ 1 2 3 LHZ ] test-assembler
|
||||
{ HEX: a4220003 } [ 1 2 3 LHZU ] test-assembler
|
||||
{ HEX: 80220003 } [ 1 2 3 LWZ ] test-assembler
|
||||
{ HEX: 84220003 } [ 1 2 3 LWZU ] test-assembler
|
||||
{ HEX: 7c4118ae } [ 1 2 3 LBZX ] test-assembler
|
||||
{ HEX: 7c4118ee } [ 1 2 3 LBZUX ] test-assembler
|
||||
{ HEX: 7c411aae } [ 1 2 3 LHAX ] test-assembler
|
||||
{ HEX: 7c411aee } [ 1 2 3 LHAUX ] test-assembler
|
||||
{ HEX: 7c411a2e } [ 1 2 3 LHZX ] test-assembler
|
||||
{ HEX: 7c411a6e } [ 1 2 3 LHZUX ] test-assembler
|
||||
{ HEX: 7c41182e } [ 1 2 3 LWZX ] test-assembler
|
||||
{ HEX: 7c41186e } [ 1 2 3 LWZUX ] test-assembler
|
||||
{ HEX: 48000001 } [ 1 B ] test-assembler
|
||||
{ HEX: 48000001 } [ 1 BL ] test-assembler
|
||||
{ HEX: 41800004 } [ 1 BLT ] test-assembler
|
||||
{ HEX: 41810004 } [ 1 BGT ] test-assembler
|
||||
{ HEX: 40810004 } [ 1 BLE ] test-assembler
|
||||
{ HEX: 40800004 } [ 1 BGE ] test-assembler
|
||||
{ HEX: 41800004 } [ 1 BLT ] test-assembler
|
||||
{ HEX: 40820004 } [ 1 BNE ] test-assembler
|
||||
{ HEX: 41820004 } [ 1 BEQ ] test-assembler
|
||||
{ HEX: 41830004 } [ 1 BO ] test-assembler
|
||||
{ HEX: 40830004 } [ 1 BNO ] test-assembler
|
||||
{ HEX: 4c200020 } [ 1 BCLR ] test-assembler
|
||||
{ HEX: 4e800020 } [ BLR ] test-assembler
|
||||
{ HEX: 4e800021 } [ BLRL ] test-assembler
|
||||
{ HEX: 4c200420 } [ 1 BCCTR ] test-assembler
|
||||
{ HEX: 4e800420 } [ BCTR ] test-assembler
|
||||
{ HEX: 7c6102a6 } [ 3 MFXER ] test-assembler
|
||||
{ HEX: 7c6802a6 } [ 3 MFLR ] test-assembler
|
||||
{ HEX: 7c6902a6 } [ 3 MFCTR ] test-assembler
|
||||
{ HEX: 7c6103a6 } [ 3 MTXER ] test-assembler
|
||||
{ HEX: 7c6803a6 } [ 3 MTLR ] test-assembler
|
||||
{ HEX: 7c6903a6 } [ 3 MTCTR ] test-assembler
|
||||
{ HEX: 7c6102a6 } [ 3 MFXER ] test-assembler
|
||||
{ HEX: 7c6802a6 } [ 3 MFLR ] test-assembler
|
||||
{ HEX: c0220003 } [ 1 2 3 LFS ] test-assembler
|
||||
{ HEX: c4220003 } [ 1 2 3 LFSU ] test-assembler
|
||||
{ HEX: c8220003 } [ 1 2 3 LFD ] test-assembler
|
||||
{ HEX: cc220003 } [ 1 2 3 LFDU ] test-assembler
|
||||
{ HEX: d0220003 } [ 1 2 3 STFS ] test-assembler
|
||||
{ HEX: d4220003 } [ 1 2 3 STFSU ] test-assembler
|
||||
{ HEX: d8220003 } [ 1 2 3 STFD ] test-assembler
|
||||
{ HEX: dc220003 } [ 1 2 3 STFDU ] test-assembler
|
||||
{ HEX: fc201048 } [ 1 2 FMR ] test-assembler
|
||||
{ HEX: fc20101e } [ 1 2 FCTIWZ ] test-assembler
|
||||
{ HEX: fc22182a } [ 1 2 3 FADD ] test-assembler
|
||||
{ HEX: fc22182b } [ 1 2 3 FADD. ] test-assembler
|
||||
{ HEX: fc221828 } [ 1 2 3 FSUB ] test-assembler
|
||||
{ HEX: fc2200f2 } [ 1 2 3 FMUL ] test-assembler
|
||||
{ HEX: fc221824 } [ 1 2 3 FDIV ] test-assembler
|
||||
{ HEX: fc20102c } [ 1 2 FSQRT ] test-assembler
|
||||
{ HEX: fc411800 } [ 1 2 3 FCMPU ] test-assembler
|
||||
{ HEX: fc411840 } [ 1 2 3 FCMPO ] test-assembler
|
||||
{ HEX: 3c601234 HEX: 60635678 } [ HEX: 12345678 3 LOAD ] test-assembler
|
||||
B{ HEX: 38 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 ADDI ] test-assembler
|
||||
B{ HEX: 3c HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 ADDIS ] test-assembler
|
||||
B{ HEX: 30 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 ADDIC ] test-assembler
|
||||
B{ HEX: 34 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 ADDIC. ] test-assembler
|
||||
B{ HEX: 38 HEX: 40 HEX: 00 HEX: 01 } [ 1 2 LI ] test-assembler
|
||||
B{ HEX: 3c HEX: 40 HEX: 00 HEX: 01 } [ 1 2 LIS ] test-assembler
|
||||
B{ HEX: 38 HEX: 22 HEX: ff HEX: fd } [ 1 2 3 SUBI ] test-assembler
|
||||
B{ HEX: 1c HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 MULI ] test-assembler
|
||||
B{ HEX: 7c HEX: 22 HEX: 1a HEX: 14 } [ 1 2 3 ADD ] test-assembler
|
||||
B{ HEX: 7c HEX: 22 HEX: 1a HEX: 15 } [ 1 2 3 ADD. ] test-assembler
|
||||
B{ HEX: 7c HEX: 22 HEX: 1e HEX: 14 } [ 1 2 3 ADDO ] test-assembler
|
||||
B{ HEX: 7c HEX: 22 HEX: 1e HEX: 15 } [ 1 2 3 ADDO. ] test-assembler
|
||||
B{ HEX: 7c HEX: 22 HEX: 18 HEX: 14 } [ 1 2 3 ADDC ] test-assembler
|
||||
B{ HEX: 7c HEX: 22 HEX: 18 HEX: 15 } [ 1 2 3 ADDC. ] test-assembler
|
||||
B{ HEX: 7c HEX: 22 HEX: 1e HEX: 14 } [ 1 2 3 ADDO ] test-assembler
|
||||
B{ HEX: 7c HEX: 22 HEX: 1c HEX: 15 } [ 1 2 3 ADDCO. ] test-assembler
|
||||
B{ HEX: 7c HEX: 22 HEX: 19 HEX: 14 } [ 1 2 3 ADDE ] test-assembler
|
||||
B{ HEX: 7c HEX: 41 HEX: 18 HEX: 38 } [ 1 2 3 AND ] test-assembler
|
||||
B{ HEX: 7c HEX: 41 HEX: 18 HEX: 39 } [ 1 2 3 AND. ] test-assembler
|
||||
B{ HEX: 7c HEX: 22 HEX: 1b HEX: d6 } [ 1 2 3 DIVW ] test-assembler
|
||||
B{ HEX: 7c HEX: 22 HEX: 1b HEX: 96 } [ 1 2 3 DIVWU ] test-assembler
|
||||
B{ HEX: 7c HEX: 41 HEX: 1a HEX: 38 } [ 1 2 3 EQV ] test-assembler
|
||||
B{ HEX: 7c HEX: 41 HEX: 1b HEX: b8 } [ 1 2 3 NAND ] test-assembler
|
||||
B{ HEX: 7c HEX: 41 HEX: 18 HEX: f8 } [ 1 2 3 NOR ] test-assembler
|
||||
B{ HEX: 7c HEX: 41 HEX: 10 HEX: f8 } [ 1 2 NOT ] test-assembler
|
||||
B{ HEX: 60 HEX: 41 HEX: 00 HEX: 03 } [ 1 2 3 ORI ] test-assembler
|
||||
B{ HEX: 64 HEX: 41 HEX: 00 HEX: 03 } [ 1 2 3 ORIS ] test-assembler
|
||||
B{ HEX: 7c HEX: 41 HEX: 1b HEX: 78 } [ 1 2 3 OR ] test-assembler
|
||||
B{ HEX: 7c HEX: 41 HEX: 13 HEX: 78 } [ 1 2 MR ] test-assembler
|
||||
B{ HEX: 7c HEX: 22 HEX: 18 HEX: 96 } [ 1 2 3 MULHW ] test-assembler
|
||||
B{ HEX: 1c HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 MULLI ] test-assembler
|
||||
B{ HEX: 7c HEX: 22 HEX: 18 HEX: 16 } [ 1 2 3 MULHWU ] test-assembler
|
||||
B{ HEX: 7c HEX: 22 HEX: 19 HEX: d6 } [ 1 2 3 MULLW ] test-assembler
|
||||
B{ HEX: 7c HEX: 41 HEX: 18 HEX: 30 } [ 1 2 3 SLW ] test-assembler
|
||||
B{ HEX: 7c HEX: 41 HEX: 1e HEX: 30 } [ 1 2 3 SRAW ] test-assembler
|
||||
B{ HEX: 7c HEX: 41 HEX: 1c HEX: 30 } [ 1 2 3 SRW ] test-assembler
|
||||
B{ HEX: 7c HEX: 41 HEX: 1e HEX: 70 } [ 1 2 3 SRAWI ] test-assembler
|
||||
B{ HEX: 7c HEX: 22 HEX: 18 HEX: 50 } [ 1 2 3 SUBF ] test-assembler
|
||||
B{ HEX: 7c HEX: 22 HEX: 18 HEX: 10 } [ 1 2 3 SUBFC ] test-assembler
|
||||
B{ HEX: 7c HEX: 22 HEX: 19 HEX: 10 } [ 1 2 3 SUBFE ] test-assembler
|
||||
B{ HEX: 7c HEX: 41 HEX: 07 HEX: 74 } [ 1 2 EXTSB ] test-assembler
|
||||
B{ HEX: 68 HEX: 41 HEX: 00 HEX: 03 } [ 1 2 3 XORI ] test-assembler
|
||||
B{ HEX: 7c HEX: 41 HEX: 1a HEX: 78 } [ 1 2 3 XOR ] test-assembler
|
||||
B{ HEX: 7c HEX: 22 HEX: 00 HEX: d0 } [ 1 2 NEG ] test-assembler
|
||||
B{ HEX: 2c HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 CMPI ] test-assembler
|
||||
B{ HEX: 28 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 CMPLI ] test-assembler
|
||||
B{ HEX: 7c HEX: 41 HEX: 18 HEX: 00 } [ 1 2 3 CMP ] test-assembler
|
||||
B{ HEX: 54 HEX: 22 HEX: 19 HEX: 0a } [ 1 2 3 4 5 RLWINM ] test-assembler
|
||||
B{ HEX: 54 HEX: 22 HEX: 18 HEX: 38 } [ 1 2 3 SLWI ] test-assembler
|
||||
B{ HEX: 54 HEX: 22 HEX: e8 HEX: fe } [ 1 2 3 SRWI ] test-assembler
|
||||
B{ HEX: 88 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LBZ ] test-assembler
|
||||
B{ HEX: 8c HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LBZU ] test-assembler
|
||||
B{ HEX: a8 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LHA ] test-assembler
|
||||
B{ HEX: ac HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LHAU ] test-assembler
|
||||
B{ HEX: a0 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LHZ ] test-assembler
|
||||
B{ HEX: a4 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LHZU ] test-assembler
|
||||
B{ HEX: 80 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LWZ ] test-assembler
|
||||
B{ HEX: 84 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LWZU ] test-assembler
|
||||
B{ HEX: 7c HEX: 41 HEX: 18 HEX: ae } [ 1 2 3 LBZX ] test-assembler
|
||||
B{ HEX: 7c HEX: 41 HEX: 18 HEX: ee } [ 1 2 3 LBZUX ] test-assembler
|
||||
B{ HEX: 7c HEX: 41 HEX: 1a HEX: ae } [ 1 2 3 LHAX ] test-assembler
|
||||
B{ HEX: 7c HEX: 41 HEX: 1a HEX: ee } [ 1 2 3 LHAUX ] test-assembler
|
||||
B{ HEX: 7c HEX: 41 HEX: 1a HEX: 2e } [ 1 2 3 LHZX ] test-assembler
|
||||
B{ HEX: 7c HEX: 41 HEX: 1a HEX: 6e } [ 1 2 3 LHZUX ] test-assembler
|
||||
B{ HEX: 7c HEX: 41 HEX: 18 HEX: 2e } [ 1 2 3 LWZX ] test-assembler
|
||||
B{ HEX: 7c HEX: 41 HEX: 18 HEX: 6e } [ 1 2 3 LWZUX ] test-assembler
|
||||
B{ HEX: 48 HEX: 00 HEX: 00 HEX: 01 } [ 1 B ] test-assembler
|
||||
B{ HEX: 48 HEX: 00 HEX: 00 HEX: 01 } [ 1 BL ] test-assembler
|
||||
B{ HEX: 41 HEX: 80 HEX: 00 HEX: 04 } [ 1 BLT ] test-assembler
|
||||
B{ HEX: 41 HEX: 81 HEX: 00 HEX: 04 } [ 1 BGT ] test-assembler
|
||||
B{ HEX: 40 HEX: 81 HEX: 00 HEX: 04 } [ 1 BLE ] test-assembler
|
||||
B{ HEX: 40 HEX: 80 HEX: 00 HEX: 04 } [ 1 BGE ] test-assembler
|
||||
B{ HEX: 41 HEX: 80 HEX: 00 HEX: 04 } [ 1 BLT ] test-assembler
|
||||
B{ HEX: 40 HEX: 82 HEX: 00 HEX: 04 } [ 1 BNE ] test-assembler
|
||||
B{ HEX: 41 HEX: 82 HEX: 00 HEX: 04 } [ 1 BEQ ] test-assembler
|
||||
B{ HEX: 41 HEX: 83 HEX: 00 HEX: 04 } [ 1 BO ] test-assembler
|
||||
B{ HEX: 40 HEX: 83 HEX: 00 HEX: 04 } [ 1 BNO ] test-assembler
|
||||
B{ HEX: 4c HEX: 20 HEX: 00 HEX: 20 } [ 1 BCLR ] test-assembler
|
||||
B{ HEX: 4e HEX: 80 HEX: 00 HEX: 20 } [ BLR ] test-assembler
|
||||
B{ HEX: 4e HEX: 80 HEX: 00 HEX: 21 } [ BLRL ] test-assembler
|
||||
B{ HEX: 4c HEX: 20 HEX: 04 HEX: 20 } [ 1 BCCTR ] test-assembler
|
||||
B{ HEX: 4e HEX: 80 HEX: 04 HEX: 20 } [ BCTR ] test-assembler
|
||||
B{ HEX: 7c HEX: 61 HEX: 02 HEX: a6 } [ 3 MFXER ] test-assembler
|
||||
B{ HEX: 7c HEX: 68 HEX: 02 HEX: a6 } [ 3 MFLR ] test-assembler
|
||||
B{ HEX: 7c HEX: 69 HEX: 02 HEX: a6 } [ 3 MFCTR ] test-assembler
|
||||
B{ HEX: 7c HEX: 61 HEX: 03 HEX: a6 } [ 3 MTXER ] test-assembler
|
||||
B{ HEX: 7c HEX: 68 HEX: 03 HEX: a6 } [ 3 MTLR ] test-assembler
|
||||
B{ HEX: 7c HEX: 69 HEX: 03 HEX: a6 } [ 3 MTCTR ] test-assembler
|
||||
B{ HEX: 7c HEX: 61 HEX: 02 HEX: a6 } [ 3 MFXER ] test-assembler
|
||||
B{ HEX: 7c HEX: 68 HEX: 02 HEX: a6 } [ 3 MFLR ] test-assembler
|
||||
B{ HEX: c0 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LFS ] test-assembler
|
||||
B{ HEX: c4 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LFSU ] test-assembler
|
||||
B{ HEX: c8 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LFD ] test-assembler
|
||||
B{ HEX: cc HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LFDU ] test-assembler
|
||||
B{ HEX: d0 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 STFS ] test-assembler
|
||||
B{ HEX: d4 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 STFSU ] test-assembler
|
||||
B{ HEX: d8 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 STFD ] test-assembler
|
||||
B{ HEX: dc HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 STFDU ] test-assembler
|
||||
B{ HEX: fc HEX: 20 HEX: 10 HEX: 48 } [ 1 2 FMR ] test-assembler
|
||||
B{ HEX: fc HEX: 20 HEX: 10 HEX: 1e } [ 1 2 FCTIWZ ] test-assembler
|
||||
B{ HEX: fc HEX: 22 HEX: 18 HEX: 2a } [ 1 2 3 FADD ] test-assembler
|
||||
B{ HEX: fc HEX: 22 HEX: 18 HEX: 2b } [ 1 2 3 FADD. ] test-assembler
|
||||
B{ HEX: fc HEX: 22 HEX: 18 HEX: 28 } [ 1 2 3 FSUB ] test-assembler
|
||||
B{ HEX: fc HEX: 22 HEX: 00 HEX: f2 } [ 1 2 3 FMUL ] test-assembler
|
||||
B{ HEX: fc HEX: 22 HEX: 18 HEX: 24 } [ 1 2 3 FDIV ] test-assembler
|
||||
B{ HEX: fc HEX: 20 HEX: 10 HEX: 2c } [ 1 2 FSQRT ] test-assembler
|
||||
B{ HEX: fc HEX: 41 HEX: 18 HEX: 00 } [ 1 2 3 FCMPU ] test-assembler
|
||||
B{ HEX: fc HEX: 41 HEX: 18 HEX: 40 } [ 1 2 3 FCMPO ] test-assembler
|
||||
B{ HEX: 3c HEX: 60 HEX: 12 HEX: 34 HEX: 60 HEX: 63 HEX: 56 HEX: 78 } [ HEX: 12345678 3 LOAD ] test-assembler
|
||||
|
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: compiler.codegen.fixup kernel namespaces words
|
||||
io.binary math math.order cpu.ppc.assembler.backend ;
|
||||
USING: kernel namespaces words io.binary math math.order
|
||||
cpu.ppc.assembler.backend ;
|
||||
IN: cpu.ppc.assembler
|
||||
|
||||
! See the Motorola or IBM documentation for details. The opcode
|
||||
|
|
|
@ -1,11 +1,10 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: compiler.codegen.fixup cpu.architecture
|
||||
compiler.constants kernel namespaces make sequences words math
|
||||
math.bitwise io.binary parser lexer ;
|
||||
USING: kernel namespaces make sequences words math
|
||||
math.bitwise io.binary parser lexer fry ;
|
||||
IN: cpu.ppc.assembler.backend
|
||||
|
||||
: insn ( operand opcode -- ) { 26 0 } bitfield , ;
|
||||
: insn ( operand opcode -- ) { 26 0 } bitfield 4 >be % ;
|
||||
|
||||
: a-insn ( d a b c xo rc opcode -- )
|
||||
[ { 0 1 6 11 16 21 } bitfield ] dip insn ;
|
||||
|
@ -74,21 +73,16 @@ SYNTAX: XO1: (XO) (1) (( a s -- )) define-declared ;
|
|||
|
||||
GENERIC# (B) 2 ( dest aa lk -- )
|
||||
M: integer (B) 18 i-insn ;
|
||||
M: word (B) [ 0 ] 2dip (B) rc-relative-ppc-3 rel-word ;
|
||||
M: label (B) [ 0 ] 2dip (B) rc-relative-ppc-3 label-fixup ;
|
||||
|
||||
GENERIC: BC ( a b c -- )
|
||||
M: integer BC 0 0 16 b-insn ;
|
||||
M: word BC [ 0 BC ] dip rc-relative-ppc-2 rel-word ;
|
||||
M: label BC [ 0 BC ] dip rc-relative-ppc-2 label-fixup ;
|
||||
|
||||
: CREATE-B ( -- word ) scan "B" prepend create-in ;
|
||||
|
||||
SYNTAX: BC:
|
||||
CREATE-B scan-word scan-word
|
||||
[ rot BC ] 2curry (( c -- )) define-declared ;
|
||||
'[ [ _ _ ] dip BC ] (( c -- )) define-declared ;
|
||||
|
||||
SYNTAX: B:
|
||||
CREATE-B scan-word scan-word scan-word scan-word scan-word
|
||||
[ b-insn ] curry curry curry curry curry
|
||||
(( bo -- )) define-declared ;
|
||||
'[ _ _ _ _ _ b-insn ] (( bo -- )) define-declared ;
|
||||
|
|
|
@ -9,8 +9,8 @@ IN: bootstrap.ppc
|
|||
4 \ cell set
|
||||
big-endian on
|
||||
|
||||
CONSTANT: ds-reg 29
|
||||
CONSTANT: rs-reg 30
|
||||
CONSTANT: ds-reg 13
|
||||
CONSTANT: rs-reg 14
|
||||
|
||||
: factor-area-size ( -- n ) 4 bootstrap-cells ;
|
||||
|
||||
|
@ -50,15 +50,12 @@ CONSTANT: rs-reg 30
|
|||
0 6 LOAD32 rc-absolute-ppc-2/2 rt-stack-chain jit-rel
|
||||
7 6 0 LWZ
|
||||
1 7 0 STW
|
||||
] jit-save-stack jit-define
|
||||
|
||||
[
|
||||
0 6 LOAD32 rc-absolute-ppc-2/2 rt-primitive jit-rel
|
||||
6 MTCTR
|
||||
BCTR
|
||||
] jit-primitive jit-define
|
||||
|
||||
[ 0 BL rc-relative-ppc-3 rt-xt-direct jit-rel ] jit-word-call jit-define
|
||||
[ 0 BL rc-relative-ppc-3 rt-xt-pic jit-rel ] jit-word-call jit-define
|
||||
|
||||
[ 0 B rc-relative-ppc-3 rt-xt jit-rel ] jit-word-jump jit-define
|
||||
|
||||
|
@ -68,11 +65,8 @@ CONSTANT: rs-reg 30
|
|||
0 3 \ f tag-number CMPI
|
||||
2 BEQ
|
||||
0 B rc-relative-ppc-3 rt-xt jit-rel
|
||||
] jit-if-1 jit-define
|
||||
|
||||
[
|
||||
0 B rc-relative-ppc-3 rt-xt jit-rel
|
||||
] jit-if-2 jit-define
|
||||
] jit-if jit-define
|
||||
|
||||
: jit->r ( -- )
|
||||
4 ds-reg 0 LWZ
|
||||
|
@ -138,6 +132,16 @@ CONSTANT: rs-reg 30
|
|||
jit-3r>
|
||||
] jit-3dip jit-define
|
||||
|
||||
: prepare-(execute) ( -- operand )
|
||||
3 ds-reg 0 LWZ
|
||||
ds-reg dup 4 SUBI
|
||||
4 3 word-xt-offset LWZ
|
||||
4 ;
|
||||
|
||||
[ prepare-(execute) MTCTR BCTR ] jit-execute-jump jit-define
|
||||
|
||||
[ prepare-(execute) MTLR BLRL ] jit-execute-call jit-define
|
||||
|
||||
[
|
||||
0 1 lr-save stack-frame + LWZ
|
||||
1 1 stack-frame ADDI
|
||||
|
@ -146,7 +150,96 @@ CONSTANT: rs-reg 30
|
|||
|
||||
[ BLR ] jit-return jit-define
|
||||
|
||||
! Sub-primitives
|
||||
! ! ! Polymorphic inline caches
|
||||
|
||||
! Load a value from a stack position
|
||||
[
|
||||
4 ds-reg 0 LWZ rc-absolute-ppc-2 rt-untagged jit-rel
|
||||
] pic-load jit-define
|
||||
|
||||
! Tag
|
||||
: load-tag ( -- )
|
||||
4 4 tag-mask get ANDI
|
||||
4 4 tag-bits get SLWI ;
|
||||
|
||||
[ load-tag ] pic-tag jit-define
|
||||
|
||||
! Hi-tag
|
||||
[
|
||||
3 4 MR
|
||||
load-tag
|
||||
0 4 object tag-number tag-fixnum CMPI
|
||||
2 BNE
|
||||
4 3 object tag-number neg LWZ
|
||||
] pic-hi-tag jit-define
|
||||
|
||||
! Tuple
|
||||
[
|
||||
3 4 MR
|
||||
load-tag
|
||||
0 4 tuple tag-number tag-fixnum CMPI
|
||||
2 BNE
|
||||
4 3 tuple tag-number neg bootstrap-cell + LWZ
|
||||
] pic-tuple jit-define
|
||||
|
||||
! Hi-tag and tuple
|
||||
[
|
||||
3 4 MR
|
||||
load-tag
|
||||
! If bits 2 and 3 are set, the tag is either 6 (object) or 7 (tuple)
|
||||
0 4 BIN: 110 tag-fixnum CMPI
|
||||
5 BLT
|
||||
! Untag r3
|
||||
3 3 0 0 31 tag-bits get - RLWINM
|
||||
! Set r4 to 0 for objects, and bootstrap-cell for tuples
|
||||
4 4 1 tag-fixnum ANDI
|
||||
4 4 1 SRAWI
|
||||
! Load header cell or tuple layout cell
|
||||
4 4 3 LWZX
|
||||
] pic-hi-tag-tuple jit-define
|
||||
|
||||
[
|
||||
0 4 0 CMPI rc-absolute-ppc-2 rt-immediate jit-rel
|
||||
] pic-check-tag jit-define
|
||||
|
||||
[
|
||||
0 5 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel
|
||||
4 0 5 CMP
|
||||
] pic-check jit-define
|
||||
|
||||
[ 2 BNE 0 B rc-relative-ppc-3 rt-xt jit-rel ] pic-hit jit-define
|
||||
|
||||
! ! ! Megamorphic caches
|
||||
|
||||
[
|
||||
! cache = ...
|
||||
0 3 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel
|
||||
! key = class
|
||||
5 4 MR
|
||||
! key &= cache.length - 1
|
||||
5 5 mega-cache-size get 1- bootstrap-cell * ANDI
|
||||
! cache += array-start-offset
|
||||
3 3 array-start-offset ADDI
|
||||
! cache += key
|
||||
3 3 5 ADD
|
||||
! if(get(cache) == class)
|
||||
6 3 0 LWZ
|
||||
6 0 4 CMP
|
||||
5 BNE
|
||||
! megamorphic_cache_hits++
|
||||
0 4 LOAD32 rc-absolute-ppc-2/2 rt-megamorphic-cache-hits jit-rel
|
||||
5 4 0 LWZ
|
||||
5 5 1 ADDI
|
||||
5 4 0 STW
|
||||
! ... goto get(cache + bootstrap-cell)
|
||||
3 3 4 LWZ
|
||||
3 3 word-xt-offset LWZ
|
||||
3 MTCTR
|
||||
BCTR
|
||||
! fall-through on miss
|
||||
] mega-lookup jit-define
|
||||
|
||||
! ! ! Sub-primitives
|
||||
|
||||
! Quotations and words
|
||||
[
|
||||
|
@ -157,14 +250,6 @@ CONSTANT: rs-reg 30
|
|||
BCTR
|
||||
] \ (call) define-sub-primitive
|
||||
|
||||
[
|
||||
3 ds-reg 0 LWZ
|
||||
ds-reg dup 4 SUBI
|
||||
4 3 word-xt-offset LWZ
|
||||
4 MTCTR
|
||||
BCTR
|
||||
] \ (execute) define-sub-primitive
|
||||
|
||||
! Objects
|
||||
[
|
||||
3 ds-reg 0 LWZ
|
||||
|
|
|
@ -1,33 +1,38 @@
|
|||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! Copyright (C) 2005, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors assocs sequences kernel combinators make math
|
||||
math.order math.ranges system namespaces locals layouts words
|
||||
alien alien.c-types cpu.architecture cpu.ppc.assembler
|
||||
compiler.cfg.registers compiler.cfg.instructions
|
||||
alien alien.c-types literals cpu.architecture cpu.ppc.assembler
|
||||
literals compiler.cfg.registers compiler.cfg.instructions
|
||||
compiler.constants compiler.codegen compiler.codegen.fixup
|
||||
compiler.cfg.intrinsics compiler.cfg.stack-frame ;
|
||||
IN: cpu.ppc
|
||||
|
||||
! PowerPC register assignments:
|
||||
! r2-r27: integer vregs
|
||||
! r28: integer scratch
|
||||
! r29: data stack
|
||||
! r30: retain stack
|
||||
! r2-r12: integer vregs
|
||||
! r15-r29
|
||||
! r30: integer scratch
|
||||
! f0-f29: float vregs
|
||||
! f30, f31: float scratch
|
||||
! f30: float scratch
|
||||
|
||||
! Add some methods to the assembler that are useful to us
|
||||
M: label (B) [ 0 ] 2dip (B) rc-relative-ppc-3 label-fixup ;
|
||||
M: label BC [ 0 BC ] dip rc-relative-ppc-2 label-fixup ;
|
||||
|
||||
enable-float-intrinsics
|
||||
|
||||
<< \ ##integer>float t frame-required? set-word-prop
|
||||
\ ##float>integer t frame-required? set-word-prop >>
|
||||
<<
|
||||
\ ##integer>float t frame-required? set-word-prop
|
||||
\ ##float>integer t frame-required? set-word-prop
|
||||
>>
|
||||
|
||||
M: ppc machine-registers
|
||||
{
|
||||
{ int-regs T{ range f 2 26 1 } }
|
||||
{ double-float-regs T{ range f 0 29 1 } }
|
||||
{ int-regs $[ 2 12 [a,b] 15 29 [a,b] append ] }
|
||||
{ double-float-regs $[ 0 29 [a,b] ] }
|
||||
} ;
|
||||
|
||||
CONSTANT: scratch-reg 28
|
||||
CONSTANT: scratch-reg 30
|
||||
CONSTANT: fp-scratch-reg 30
|
||||
|
||||
M: ppc two-operand? f ;
|
||||
|
@ -40,8 +45,8 @@ M: ppc %load-reference ( reg obj -- )
|
|||
M: ppc %alien-global ( register symbol dll -- )
|
||||
[ 0 swap LOAD32 ] 2dip rc-absolute-ppc-2/2 rel-dlsym ;
|
||||
|
||||
CONSTANT: ds-reg 29
|
||||
CONSTANT: rs-reg 30
|
||||
CONSTANT: ds-reg 13
|
||||
CONSTANT: rs-reg 14
|
||||
|
||||
GENERIC: loc-reg ( loc -- reg )
|
||||
|
||||
|
@ -108,7 +113,12 @@ M: ppc stack-frame-size ( stack-frame -- i )
|
|||
factor-area-size +
|
||||
4 cells align ;
|
||||
|
||||
M: ppc %call ( label -- ) BL ;
|
||||
M: ppc %call ( word -- ) 0 BL rc-relative-ppc-3 rel-word-pic ;
|
||||
|
||||
M: ppc %jump ( word -- )
|
||||
0 3 LOAD32 rc-absolute-ppc-2/2 rel-here
|
||||
0 B rc-relative-ppc-3 rel-word-pic-tail ;
|
||||
|
||||
M: ppc %jump-label ( label -- ) B ;
|
||||
M: ppc %return ( -- ) BLR ;
|
||||
|
||||
|
|
|
@ -42,11 +42,13 @@ M:: x86.32 %dispatch ( src temp offset -- )
|
|||
M: x86.32 param-reg-1 EAX ;
|
||||
M: x86.32 param-reg-2 EDX ;
|
||||
|
||||
M: x86.32 pic-tail-reg EBX ;
|
||||
|
||||
M: x86.32 reserved-area-size 0 ;
|
||||
|
||||
M: x86.32 %alien-invoke (CALL) rel-dlsym ;
|
||||
M: x86.32 %alien-invoke 0 CALL rc-relative rel-dlsym ;
|
||||
|
||||
M: x86.32 %alien-invoke-tail (JMP) rel-dlsym ;
|
||||
M: x86.32 %alien-invoke-tail 0 JMP rc-relative rel-dlsym ;
|
||||
|
||||
M: x86.32 return-struct-in-registers? ( c-type -- ? )
|
||||
c-type
|
||||
|
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2007 Slava Pestov.
|
||||
! Copyright (C) 2007, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: bootstrap.image.private kernel namespaces system
|
||||
cpu.x86.assembler layouts vocabs parser compiler.constants ;
|
||||
|
@ -26,10 +26,8 @@ IN: bootstrap.x86
|
|||
temp0 0 [] MOV rc-absolute-cell rt-stack-chain jit-rel
|
||||
! save stack pointer
|
||||
temp0 [] stack-reg MOV
|
||||
] jit-save-stack jit-define
|
||||
|
||||
[
|
||||
(JMP) drop rc-relative rt-primitive jit-rel
|
||||
! call the primitive
|
||||
0 JMP rc-relative rt-primitive jit-rel
|
||||
] jit-primitive jit-define
|
||||
|
||||
<< "vocab:cpu/x86/bootstrap.factor" parse-file parsed >>
|
||||
|
|
|
@ -39,6 +39,8 @@ M: x86.64 param-reg-1 int-regs param-regs first ;
|
|||
M: x86.64 param-reg-2 int-regs param-regs second ;
|
||||
: param-reg-3 ( -- reg ) int-regs param-regs third ; inline
|
||||
|
||||
M: x86.64 pic-tail-reg RBX ;
|
||||
|
||||
M: int-regs return-reg drop RAX ;
|
||||
M: float-regs return-reg drop XMM0 ;
|
||||
|
||||
|
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2007 Slava Pestov.
|
||||
! Copyright (C) 2007, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: bootstrap.image.private kernel namespaces system
|
||||
cpu.x86.assembler layouts vocabs parser compiler.constants math ;
|
||||
|
@ -25,9 +25,6 @@ IN: bootstrap.x86
|
|||
temp0 temp0 [] MOV
|
||||
! save stack pointer
|
||||
temp0 [] stack-reg MOV
|
||||
] jit-save-stack jit-define
|
||||
|
||||
[
|
||||
! load XT
|
||||
temp1 0 MOV rc-absolute-cell rt-primitive jit-rel
|
||||
! go
|
||||
|
|
|
@ -1,12 +1,11 @@
|
|||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! Copyright (C) 2005, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays cpu.architecture compiler.constants
|
||||
compiler.codegen.fixup io.binary kernel combinators
|
||||
kernel.private math namespaces make sequences words system
|
||||
layouts math.order accessors cpu.x86.assembler.syntax ;
|
||||
USING: arrays io.binary kernel combinators
|
||||
kernel.private math namespaces make sequences words system layouts
|
||||
math.order accessors cpu.x86.assembler.syntax ;
|
||||
IN: cpu.x86.assembler
|
||||
|
||||
! A postfix assembler for x86 and AMD64.
|
||||
! A postfix assembler for x86-32 and x86-64.
|
||||
|
||||
! In 32-bit mode, { 1234 } is absolute indirect addressing.
|
||||
! In 64-bit mode, { 1234 } is RIP-relative.
|
||||
|
@ -296,36 +295,23 @@ M: operand (MOV-I)
|
|||
{ BIN: 000 t HEX: c6 }
|
||||
pick byte? [ immediate-1 ] [ immediate-4 ] if ;
|
||||
|
||||
PREDICATE: callable < word register? not ;
|
||||
|
||||
GENERIC: MOV ( dst src -- )
|
||||
M: immediate MOV swap (MOV-I) ;
|
||||
M: callable MOV [ 0 ] 2dip (MOV-I) rc-absolute-cell rel-word ;
|
||||
M: operand MOV HEX: 88 2-operand ;
|
||||
|
||||
: LEA ( dst src -- ) swap HEX: 8d 2-operand ;
|
||||
|
||||
! Control flow
|
||||
GENERIC: JMP ( op -- )
|
||||
: (JMP) ( -- rel-class ) HEX: e9 , 0 4, rc-relative ;
|
||||
M: f JMP (JMP) 2drop ;
|
||||
M: callable JMP (JMP) rel-word ;
|
||||
M: label JMP (JMP) label-fixup ;
|
||||
M: integer JMP HEX: e9 , 4, ;
|
||||
M: operand JMP { BIN: 100 t HEX: ff } 1-operand ;
|
||||
|
||||
GENERIC: CALL ( op -- )
|
||||
: (CALL) ( -- rel-class ) HEX: e8 , 0 4, rc-relative ;
|
||||
M: f CALL (CALL) 2drop ;
|
||||
M: callable CALL (CALL) rel-word-direct ;
|
||||
M: label CALL (CALL) label-fixup ;
|
||||
M: integer CALL HEX: e8 , 4, ;
|
||||
M: operand CALL { BIN: 010 t HEX: ff } 1-operand ;
|
||||
|
||||
GENERIC# JUMPcc 1 ( addr opcode -- )
|
||||
: (JUMPcc) ( addr n -- rel-class ) extended-opcode, 4, rc-relative ;
|
||||
M: f JUMPcc [ 0 ] dip (JUMPcc) 2drop ;
|
||||
M: integer JUMPcc (JUMPcc) drop ;
|
||||
M: callable JUMPcc [ 0 ] dip (JUMPcc) rel-word ;
|
||||
M: label JUMPcc [ 0 ] dip (JUMPcc) label-fixup ;
|
||||
M: integer JUMPcc extended-opcode, 4, ;
|
||||
|
||||
: JO ( dst -- ) HEX: 80 JUMPcc ;
|
||||
: JNO ( dst -- ) HEX: 81 JUMPcc ;
|
||||
|
|
|
@ -42,13 +42,18 @@ big-endian off
|
|||
] jit-push-immediate jit-define
|
||||
|
||||
[
|
||||
f JMP rc-relative rt-xt jit-rel
|
||||
temp3 0 MOV rc-absolute-cell rt-here jit-rel
|
||||
0 JMP rc-relative rt-xt-pic-tail jit-rel
|
||||
] jit-word-jump jit-define
|
||||
|
||||
[
|
||||
f CALL rc-relative rt-xt-direct jit-rel
|
||||
0 CALL rc-relative rt-xt-pic jit-rel
|
||||
] jit-word-call jit-define
|
||||
|
||||
[
|
||||
0 JMP rc-relative rt-xt jit-rel
|
||||
] jit-word-special jit-define
|
||||
|
||||
[
|
||||
! load boolean
|
||||
temp0 ds-reg [] MOV
|
||||
|
@ -57,13 +62,10 @@ big-endian off
|
|||
! compare boolean with f
|
||||
temp0 \ f tag-number CMP
|
||||
! jump to true branch if not equal
|
||||
f JNE rc-relative rt-xt jit-rel
|
||||
] jit-if-1 jit-define
|
||||
|
||||
[
|
||||
0 JNE rc-relative rt-xt jit-rel
|
||||
! jump to false branch if equal
|
||||
f JMP rc-relative rt-xt jit-rel
|
||||
] jit-if-2 jit-define
|
||||
0 JMP rc-relative rt-xt jit-rel
|
||||
] jit-if jit-define
|
||||
|
||||
: jit->r ( -- )
|
||||
rs-reg bootstrap-cell ADD
|
||||
|
@ -115,19 +117,19 @@ big-endian off
|
|||
|
||||
[
|
||||
jit->r
|
||||
f CALL rc-relative rt-xt jit-rel
|
||||
0 CALL rc-relative rt-xt jit-rel
|
||||
jit-r>
|
||||
] jit-dip jit-define
|
||||
|
||||
[
|
||||
jit-2>r
|
||||
f CALL rc-relative rt-xt jit-rel
|
||||
0 CALL rc-relative rt-xt jit-rel
|
||||
jit-2r>
|
||||
] jit-2dip jit-define
|
||||
|
||||
[
|
||||
jit-3>r
|
||||
f CALL rc-relative rt-xt jit-rel
|
||||
0 CALL rc-relative rt-xt jit-rel
|
||||
jit-3r>
|
||||
] jit-3dip jit-define
|
||||
|
||||
|
@ -152,8 +154,7 @@ big-endian off
|
|||
|
||||
! ! ! Polymorphic inline caches
|
||||
|
||||
! temp0 contains the object being dispatched on
|
||||
! temp1 contains its class
|
||||
! The PIC and megamorphic code stubs are not permitted to touch temp3.
|
||||
|
||||
! Load a value from a stack position
|
||||
[
|
||||
|
@ -197,7 +198,7 @@ big-endian off
|
|||
[
|
||||
! Untag temp0
|
||||
temp0 tag-mask get bitnot AND
|
||||
! Set temp1 to 0 for objects, and 8 for tuples
|
||||
! Set temp1 to 0 for objects, and bootstrap-cell for tuples
|
||||
temp1 1 tag-fixnum AND
|
||||
bootstrap-cell 4 = [ temp1 1 SHR ] when
|
||||
! Load header cell or tuple layout cell
|
||||
|
@ -214,7 +215,7 @@ big-endian off
|
|||
temp1 temp2 CMP
|
||||
] pic-check jit-define
|
||||
|
||||
[ f JE rc-relative rt-xt jit-rel ] pic-hit jit-define
|
||||
[ 0 JE rc-relative rt-xt jit-rel ] pic-hit jit-define
|
||||
|
||||
! ! ! Megamorphic caches
|
||||
|
||||
|
@ -232,12 +233,13 @@ big-endian off
|
|||
temp0 temp2 ADD
|
||||
! if(get(cache) == class)
|
||||
temp0 [] temp1 CMP
|
||||
! ... goto get(cache + bootstrap-cell)
|
||||
[
|
||||
temp0 temp0 bootstrap-cell [+] MOV
|
||||
temp0 word-xt-offset [+] JMP
|
||||
] [ ] make
|
||||
[ length JNE ] [ % ] bi
|
||||
bootstrap-cell 4 = 14 18 ? JNE ! Yuck!
|
||||
! megamorphic_cache_hits++
|
||||
temp1 0 MOV rc-absolute-cell rt-megamorphic-cache-hits jit-rel
|
||||
temp1 [] 1 ADD
|
||||
! goto get(cache + bootstrap-cell)
|
||||
temp0 temp0 bootstrap-cell [+] MOV
|
||||
temp0 word-xt-offset [+] JMP
|
||||
! fall-through on miss
|
||||
] mega-lookup jit-define
|
||||
|
||||
|
|
|
@ -11,6 +11,10 @@ IN: cpu.x86
|
|||
|
||||
<< enable-fixnum-log2 >>
|
||||
|
||||
! Add some methods to the assembler to be more useful to the backend
|
||||
M: label JMP 0 JMP rc-relative label-fixup ;
|
||||
M: label JUMPcc [ 0 ] dip JUMPcc rc-relative label-fixup ;
|
||||
|
||||
M: x86 two-operand? t ;
|
||||
|
||||
HOOK: temp-reg-1 cpu ( -- reg )
|
||||
|
@ -19,6 +23,8 @@ HOOK: temp-reg-2 cpu ( -- reg )
|
|||
HOOK: param-reg-1 cpu ( -- reg )
|
||||
HOOK: param-reg-2 cpu ( -- reg )
|
||||
|
||||
HOOK: pic-tail-reg cpu ( -- reg )
|
||||
|
||||
M: x86 %load-immediate MOV ;
|
||||
|
||||
M: x86 %load-reference swap 0 MOV rc-absolute-cell rel-immediate ;
|
||||
|
@ -53,8 +59,18 @@ M: x86 stack-frame-size ( stack-frame -- i )
|
|||
reserved-area-size +
|
||||
align-stack ;
|
||||
|
||||
M: x86 %call ( label -- ) CALL ;
|
||||
M: x86 %jump-label ( label -- ) JMP ;
|
||||
M: x86 %call ( word -- ) 0 CALL rc-relative rel-word-pic ;
|
||||
|
||||
: xt-tail-pic-offset ( -- n )
|
||||
#! See the comment in vm/cpu-x86.hpp
|
||||
cell 4 + 1 + ; inline
|
||||
|
||||
M: x86 %jump ( word -- )
|
||||
pic-tail-reg 0 MOV xt-tail-pic-offset rc-absolute-cell rel-here
|
||||
0 JMP rc-relative rel-word-pic-tail ;
|
||||
|
||||
M: x86 %jump-label ( label -- ) 0 JMP rc-relative label-fixup ;
|
||||
|
||||
M: x86 %return ( -- ) 0 RET ;
|
||||
|
||||
: code-alignment ( align -- n )
|
||||
|
|
|
@ -5,7 +5,7 @@ compression.lzw constructors endian fry grouping images io
|
|||
io.binary io.encodings.ascii io.encodings.binary
|
||||
io.encodings.string io.encodings.utf8 io.files kernel math
|
||||
math.bitwise math.order math.parser pack prettyprint sequences
|
||||
strings math.vectors specialized-arrays.float ;
|
||||
strings math.vectors specialized-arrays.float locals ;
|
||||
IN: images.tiff
|
||||
|
||||
TUPLE: tiff-image < image ;
|
||||
|
@ -184,7 +184,7 @@ samples-per-pixel new-subfile-type subfile-type orientation
|
|||
software date-time photoshop exif-ifd sub-ifd inter-color-profile
|
||||
xmp iptc fill-order document-name page-number page-name
|
||||
x-position y-position host-computer copyright artist
|
||||
min-sample-value max-sample-value make model cell-width cell-length
|
||||
min-sample-value max-sample-value tiff-make tiff-model cell-width cell-length
|
||||
gray-response-unit gray-response-curve color-map threshholding
|
||||
image-description free-offsets free-byte-counts tile-width tile-length
|
||||
matteing data-type image-depth tile-depth
|
||||
|
@ -243,10 +243,13 @@ ERROR: bad-tiff-magic bytes ;
|
|||
|
||||
ERROR: no-tag class ;
|
||||
|
||||
: find-tag ( idf class -- tag )
|
||||
swap processed-tags>> ?at [ no-tag ] unless ;
|
||||
: find-tag* ( ifd class -- tag/class ? )
|
||||
swap processed-tags>> ?at ;
|
||||
|
||||
: tag? ( idf class -- tag )
|
||||
: find-tag ( ifd class -- tag )
|
||||
find-tag* [ no-tag ] unless ;
|
||||
|
||||
: tag? ( ifd class -- tag )
|
||||
swap processed-tags>> key? ;
|
||||
|
||||
: read-strips ( ifd -- ifd )
|
||||
|
@ -339,8 +342,8 @@ ERROR: bad-small-ifd-type n ;
|
|||
{ 266 [ fill-order ] }
|
||||
{ 269 [ ascii decode document-name ] }
|
||||
{ 270 [ ascii decode image-description ] }
|
||||
{ 271 [ ascii decode make ] }
|
||||
{ 272 [ ascii decode model ] }
|
||||
{ 271 [ ascii decode tiff-make ] }
|
||||
{ 272 [ ascii decode tiff-model ] }
|
||||
{ 273 [ strip-offsets ] }
|
||||
{ 274 [ orientation ] }
|
||||
{ 277 [ samples-per-pixel ] }
|
||||
|
@ -350,7 +353,7 @@ ERROR: bad-small-ifd-type n ;
|
|||
{ 281 [ max-sample-value ] }
|
||||
{ 282 [ first x-resolution ] }
|
||||
{ 283 [ first y-resolution ] }
|
||||
{ 284 [ planar-configuration ] }
|
||||
{ 284 [ lookup-planar-configuration planar-configuration ] }
|
||||
{ 285 [ page-name ] }
|
||||
{ 286 [ x-position ] }
|
||||
{ 287 [ y-position ] }
|
||||
|
@ -437,8 +440,8 @@ ERROR: unhandled-compression compression ;
|
|||
[ samples-per-pixel find-tag ] tri
|
||||
[ * ] keep
|
||||
'[
|
||||
_ group [ _ group [ rest ] [ first ] bi
|
||||
[ v+ ] accumulate swap suffix concat ] map
|
||||
_ group
|
||||
[ _ group unclip [ v+ ] accumulate swap suffix concat ] map
|
||||
concat >byte-array
|
||||
] change-bitmap ;
|
||||
|
||||
|
@ -521,23 +524,39 @@ ERROR: unknown-component-order ifd ;
|
|||
] with-tiff-endianness
|
||||
] with-file-reader ;
|
||||
|
||||
: process-tif-ifds ( parsed-tiff -- parsed-tiff )
|
||||
dup ifds>> [
|
||||
read-strips
|
||||
uncompress-strips
|
||||
strips>bitmap
|
||||
fix-bitmap-endianness
|
||||
strips-predictor
|
||||
dup extra-samples tag? [ handle-alpha-data ] when
|
||||
drop
|
||||
] each ;
|
||||
: process-chunky-ifd ( ifd -- )
|
||||
read-strips
|
||||
uncompress-strips
|
||||
strips>bitmap
|
||||
fix-bitmap-endianness
|
||||
strips-predictor
|
||||
dup extra-samples tag? [ handle-alpha-data ] when
|
||||
drop ;
|
||||
|
||||
: process-planar-ifd ( ifd -- )
|
||||
"planar ifd not supported" throw ;
|
||||
|
||||
: dispatch-planar-configuration ( ifd planar-configuration -- )
|
||||
{
|
||||
{ planar-configuration-chunky [ process-chunky-ifd ] }
|
||||
{ planar-configuration-planar [ process-planar-ifd ] }
|
||||
} case ;
|
||||
|
||||
: process-ifd ( ifd -- )
|
||||
dup planar-configuration find-tag* [
|
||||
dispatch-planar-configuration
|
||||
] [
|
||||
drop "no planar configuration" throw
|
||||
] if ;
|
||||
|
||||
: process-tif-ifds ( parsed-tiff -- )
|
||||
ifds>> [ process-ifd ] each ;
|
||||
|
||||
: load-tiff ( path -- parsed-tiff )
|
||||
[ load-tiff-ifds ] [
|
||||
binary [
|
||||
[ process-tif-ifds ] with-tiff-endianness
|
||||
] with-file-reader
|
||||
] bi ;
|
||||
[ load-tiff-ifds dup ] keep
|
||||
binary [
|
||||
[ process-tif-ifds ] with-tiff-endianness
|
||||
] with-file-reader ;
|
||||
|
||||
! tiff files can store several images -- we just take the first for now
|
||||
M: tiff-image load-image* ( path tiff-image -- image )
|
||||
|
|
|
@ -21,7 +21,7 @@ CONSTANT: five 5
|
|||
USING: kernel literals prettyprint ;
|
||||
IN: scratchpad
|
||||
|
||||
<< : seven-eleven ( -- a b ) 7 11 ; >>
|
||||
: seven-eleven ( -- a b ) 7 11 ;
|
||||
{ $ seven-eleven } .
|
||||
"> "{ 7 11 }" }
|
||||
|
||||
|
@ -43,7 +43,24 @@ IN: scratchpad
|
|||
|
||||
} ;
|
||||
|
||||
{ POSTPONE: $ POSTPONE: $[ } related-words
|
||||
HELP: ${
|
||||
{ $syntax "${ code }" }
|
||||
{ $description "Outputs an array containing the results of executing " { $snippet "code" } " at parse time." }
|
||||
{ $notes { $snippet "code" } "'s definition is looked up and " { $link call } "ed at parse time, so words that reference words in the current compilation unit cannot be used with " { $snippet "$" } "." }
|
||||
{ $examples
|
||||
|
||||
{ $example <"
|
||||
USING: kernel literals math prettyprint ;
|
||||
IN: scratchpad
|
||||
|
||||
CONSTANT: five 5
|
||||
CONSTANT: six 6
|
||||
${ five six 7 } .
|
||||
"> "{ 5 6 7 }"
|
||||
}
|
||||
} ;
|
||||
|
||||
{ POSTPONE: $ POSTPONE: $[ POSTPONE: ${ } related-words
|
||||
|
||||
ARTICLE: "literals" "Interpolating code results into literal values"
|
||||
"The " { $vocab-link "literals" } " vocabulary contains words to run code at parse time and insert the results into more complex literal values."
|
||||
|
@ -51,11 +68,12 @@ ARTICLE: "literals" "Interpolating code results into literal values"
|
|||
USING: kernel literals math prettyprint ;
|
||||
IN: scratchpad
|
||||
|
||||
<< CONSTANT: five 5 >>
|
||||
CONSTANT: five 5
|
||||
{ $ five $[ five dup 1+ dup 2 + ] } .
|
||||
"> "{ 5 5 6 8 }" }
|
||||
{ $subsection POSTPONE: $ }
|
||||
{ $subsection POSTPONE: $[ }
|
||||
{ $subsection POSTPONE: ${ }
|
||||
;
|
||||
|
||||
ABOUT: "literals"
|
||||
|
|
|
@ -20,8 +20,10 @@ IN: literals.tests
|
|||
|
||||
[ { 1.0 { 0.5 1.5 } 4.0 } ] [ { 1.0 { $[ 1.0 2.0 / ] 1.5 } $[ 2.0 2.0 * ] } ] unit-test
|
||||
|
||||
<<
|
||||
CONSTANT: constant-a 3
|
||||
>>
|
||||
|
||||
[ { 3 10 "ftw" } ] [ ${ constant-a 10 "ftw" } ] unit-test
|
||||
|
||||
: sixty-nine ( -- a b ) 6 9 ;
|
||||
|
||||
[ { 6 9 } ] [ ${ sixty-nine } ] unit-test
|
||||
|
|
|
@ -1,8 +1,21 @@
|
|||
! (c) Joe Groff, see license for details
|
||||
USING: accessors continuations kernel parser words quotations
|
||||
combinators.smart vectors sequences ;
|
||||
combinators.smart vectors sequences fry ;
|
||||
IN: literals
|
||||
|
||||
SYNTAX: $ scan-word [ def>> call ] curry with-datastack >vector ;
|
||||
<PRIVATE
|
||||
|
||||
! Use def>> call so that CONSTANT:s defined in the same file can
|
||||
! be called
|
||||
|
||||
: expand-literal ( seq obj -- seq' )
|
||||
'[ _ dup word? [ def>> call ] when ] with-datastack ;
|
||||
|
||||
: expand-literals ( seq -- seq' )
|
||||
[ [ { } ] dip expand-literal ] map concat ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
SYNTAX: $ scan-word expand-literal >vector ;
|
||||
SYNTAX: $[ parse-quotation with-datastack >vector ;
|
||||
SYNTAX: ${ \ } [ [ ?execute ] { } map-as ] parse-literal ;
|
||||
SYNTAX: ${ \ } [ expand-literals ] parse-literal ;
|
||||
|
|
|
@ -7,7 +7,7 @@ TUPLE: bits { number read-only } { length read-only } ;
|
|||
C: <bits> bits
|
||||
|
||||
: make-bits ( number -- bits )
|
||||
dup zero? [ drop T{ bits f 0 0 } ] [ dup abs log2 1+ <bits> ] if ; inline
|
||||
dup zero? [ drop T{ bits f 0 0 } ] [ dup abs log2 1 + <bits> ] if ; inline
|
||||
|
||||
M: bits length length>> ;
|
||||
|
||||
|
|
|
@ -13,10 +13,10 @@ IN: math.bitwise
|
|||
: unmask? ( x n -- ? ) unmask 0 > ; inline
|
||||
: mask ( x n -- ? ) bitand ; inline
|
||||
: mask? ( x n -- ? ) mask 0 > ; inline
|
||||
: wrap ( m n -- m' ) 1- bitand ; inline
|
||||
: wrap ( m n -- m' ) 1 - bitand ; inline
|
||||
: bits ( m n -- m' ) 2^ wrap ; inline
|
||||
: mask-bit ( m n -- m' ) 2^ mask ; inline
|
||||
: on-bits ( n -- m ) 2^ 1- ; inline
|
||||
: on-bits ( n -- m ) 2^ 1 - ; inline
|
||||
: toggle-bit ( m n -- m' ) 2^ bitxor ; inline
|
||||
|
||||
: shift-mod ( n s w -- n )
|
||||
|
@ -64,8 +64,8 @@ DEFER: byte-bit-count
|
|||
<<
|
||||
|
||||
\ byte-bit-count
|
||||
256 [
|
||||
8 <bits> 0 [ [ 1+ ] when ] reduce
|
||||
256 iota [
|
||||
8 <bits> 0 [ [ 1 + ] when ] reduce
|
||||
] B{ } map-as '[ HEX: ff bitand _ nth-unsafe ]
|
||||
(( byte -- table )) define-declared
|
||||
|
||||
|
@ -97,12 +97,12 @@ PRIVATE>
|
|||
|
||||
! Signed byte array to integer conversion
|
||||
: signed-le> ( bytes -- x )
|
||||
[ le> ] [ length 8 * 1- on-bits ] bi
|
||||
[ le> ] [ length 8 * 1 - on-bits ] bi
|
||||
2dup > [ bitnot bitor ] [ drop ] if ;
|
||||
|
||||
: signed-be> ( bytes -- x )
|
||||
<reversed> signed-le> ;
|
||||
|
||||
: >signed ( x n -- y )
|
||||
2dup neg 1+ shift 1 = [ 2^ - ] [ drop ] if ;
|
||||
2dup neg 1 + shift 1 = [ 2^ - ] [ drop ] if ;
|
||||
|
||||
|
|
|
@ -164,7 +164,7 @@ M: VECTOR element-type
|
|||
M: VECTOR Vswap
|
||||
(prepare-swap) [ XSWAP ] 2dip ;
|
||||
M: VECTOR Viamax
|
||||
(prepare-nrm2) IXAMAX 1- ;
|
||||
(prepare-nrm2) IXAMAX 1 - ;
|
||||
|
||||
M: VECTOR (blas-vector-like)
|
||||
drop <VECTOR> ;
|
||||
|
|
|
@ -7,6 +7,7 @@ IN: math.constants
|
|||
: euler ( -- gamma ) 0.57721566490153286060 ; inline
|
||||
: phi ( -- phi ) 1.61803398874989484820 ; inline
|
||||
: pi ( -- pi ) 3.14159265358979323846 ; inline
|
||||
: 2pi ( -- pi ) 2 pi * ; inline
|
||||
: epsilon ( -- epsilon ) 2.2204460492503131e-16 ; inline
|
||||
: smallest-float ( -- x ) HEX: 1 bits>double ; foldable
|
||||
: largest-float ( -- x ) HEX: 7fefffffffffffff bits>double ; foldable
|
||||
|
|
|
@ -157,3 +157,8 @@ IN: math.functions.tests
|
|||
2135623355842621559
|
||||
[ >bignum ] tri@ ^mod
|
||||
] unit-test
|
||||
|
||||
[ 1.0 ] [ 1.0 2.5 0.0 lerp ] unit-test
|
||||
[ 2.5 ] [ 1.0 2.5 1.0 lerp ] unit-test
|
||||
[ 1.75 ] [ 1.0 2.5 0.5 lerp ] unit-test
|
||||
|
||||
|
|
|
@ -18,12 +18,12 @@ M: real sqrt
|
|||
: factor-2s ( n -- r s )
|
||||
#! factor an integer into 2^r * s
|
||||
dup 0 = [ 1 ] [
|
||||
0 swap [ dup even? ] [ [ 1+ ] [ 2/ ] bi* ] while
|
||||
0 swap [ dup even? ] [ [ 1 + ] [ 2/ ] bi* ] while
|
||||
] if ; inline
|
||||
|
||||
<PRIVATE
|
||||
|
||||
GENERIC# ^n 1 ( z w -- z^w )
|
||||
GENERIC# ^n 1 ( z w -- z^w ) foldable
|
||||
|
||||
: (^n) ( z w -- z^w )
|
||||
make-bits 1 [ [ dupd * ] when [ sq ] dip ] reduce nip ; inline
|
||||
|
@ -216,17 +216,17 @@ M: real tanh ftanh ;
|
|||
: coth ( x -- y ) tanh recip ; inline
|
||||
|
||||
: acosh ( x -- y )
|
||||
dup sq 1- sqrt + log ; inline
|
||||
dup sq 1 - sqrt + log ; inline
|
||||
|
||||
: asech ( x -- y ) recip acosh ; inline
|
||||
|
||||
: asinh ( x -- y )
|
||||
dup sq 1+ sqrt + log ; inline
|
||||
dup sq 1 + sqrt + log ; inline
|
||||
|
||||
: acosech ( x -- y ) recip asinh ; inline
|
||||
|
||||
: atanh ( x -- y )
|
||||
[ 1+ ] [ 1- neg ] bi / log 2 / ; inline
|
||||
[ 1 + ] [ 1 - neg ] bi / log 2 / ; inline
|
||||
|
||||
: acoth ( x -- y ) recip atanh ; inline
|
||||
|
||||
|
@ -259,6 +259,9 @@ M: real atan fatan ;
|
|||
|
||||
: floor ( x -- y )
|
||||
dup 1 mod dup zero?
|
||||
[ drop ] [ dup 0 < [ - 1- ] [ - ] if ] if ; foldable
|
||||
[ drop ] [ dup 0 < [ - 1 - ] [ - ] if ] if ; foldable
|
||||
|
||||
: ceiling ( x -- y ) neg floor neg ; foldable
|
||||
|
||||
: lerp ( a b t -- a_t ) [ over - ] dip * + ; inline
|
||||
|
||||
|
|
|
@ -48,6 +48,8 @@ TUPLE: interval { from read-only } { to read-only } ;
|
|||
|
||||
: (a,inf] ( a -- interval ) 1/0. (a,b] ; inline
|
||||
|
||||
: [0,inf] ( -- interval ) 0 [a,inf] ; foldable
|
||||
|
||||
: [-inf,inf] ( -- interval ) full-interval ; inline
|
||||
|
||||
: compare-endpoints ( p1 p2 quot -- ? )
|
||||
|
@ -262,7 +264,7 @@ TUPLE: interval { from read-only } { to read-only } ;
|
|||
: interval-abs ( i1 -- i2 )
|
||||
{
|
||||
{ [ dup empty-interval eq? ] [ ] }
|
||||
{ [ dup full-interval eq? ] [ drop 0 [a,inf] ] }
|
||||
{ [ dup full-interval eq? ] [ drop [0,inf] ] }
|
||||
{ [ 0 over interval-contains? ] [ (interval-abs) { 0 t } suffix points>interval ] }
|
||||
[ (interval-abs) points>interval ]
|
||||
} cond ;
|
||||
|
@ -376,11 +378,11 @@ SYMBOL: incomparable
|
|||
: interval-log2 ( i1 -- i2 )
|
||||
{
|
||||
{ empty-interval [ empty-interval ] }
|
||||
{ full-interval [ 0 [a,inf] ] }
|
||||
{ full-interval [ [0,inf] ] }
|
||||
[
|
||||
to>> first 1 max dup most-positive-fixnum >
|
||||
[ drop full-interval interval-log2 ]
|
||||
[ 1+ >integer log2 0 swap [a,b] ]
|
||||
[ 1 + >integer log2 0 swap [a,b] ]
|
||||
if
|
||||
]
|
||||
} case ;
|
||||
|
@ -407,7 +409,7 @@ SYMBOL: incomparable
|
|||
|
||||
: integral-closure ( i1 -- i2 )
|
||||
dup special-interval? [
|
||||
[ from>> first2 [ 1+ ] unless ]
|
||||
[ to>> first2 [ 1- ] unless ]
|
||||
[ from>> first2 [ 1 + ] unless ]
|
||||
[ to>> first2 [ 1 - ] unless ]
|
||||
bi [a,b]
|
||||
] unless ;
|
||||
|
|
|
@ -0,0 +1,100 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: help.markup help.syntax kernel sequences math ;
|
||||
IN: math.miller-rabin
|
||||
|
||||
HELP: find-relative-prime
|
||||
{ $values
|
||||
{ "n" integer }
|
||||
{ "p" integer }
|
||||
}
|
||||
{ $description "Returns a number that is relatively prime to " { $snippet "n" } "." } ;
|
||||
|
||||
HELP: find-relative-prime*
|
||||
{ $values
|
||||
{ "n" integer } { "guess" integer }
|
||||
{ "p" integer }
|
||||
}
|
||||
{ $description "Returns a number that is relatively prime to " { $snippet "n" } ", starting by trying " { $snippet "guess" } "." } ;
|
||||
|
||||
HELP: miller-rabin
|
||||
{ $values
|
||||
{ "n" integer }
|
||||
{ "?" "a boolean" }
|
||||
}
|
||||
{ $description "Returns true if the number is a prime. Calls " { $link miller-rabin* } " with a default of 10 Miller-Rabin tests." } ;
|
||||
|
||||
{ miller-rabin miller-rabin* } related-words
|
||||
|
||||
HELP: miller-rabin*
|
||||
{ $values
|
||||
{ "n" integer } { "numtrials" integer }
|
||||
{ "?" "a boolean" }
|
||||
}
|
||||
{ $description "Performs " { $snippet "numtrials" } " trials of the Miller-Rabin probabilistic primality test algorithm and returns true if prime." } ;
|
||||
|
||||
HELP: next-prime
|
||||
{ $values
|
||||
{ "n" integer }
|
||||
{ "p" integer }
|
||||
}
|
||||
{ $description "Tests consecutive numbers for primality with " { $link miller-rabin } " and returns the next prime." } ;
|
||||
|
||||
HELP: next-safe-prime
|
||||
{ $values
|
||||
{ "n" integer }
|
||||
{ "q" integer }
|
||||
}
|
||||
{ $description "Tests consecutive numbers and returns the next safe prime. A safe prime is desirable in cryptography applications such as Diffie-Hellman and SRP6." } ;
|
||||
|
||||
HELP: random-bits*
|
||||
{ $values
|
||||
{ "numbits" integer }
|
||||
{ "n" integer }
|
||||
}
|
||||
{ $description "Returns an integer exactly " { $snippet "numbits" } " in length, with the topmost bit set to one." } ;
|
||||
|
||||
HELP: random-prime
|
||||
{ $values
|
||||
{ "numbits" integer }
|
||||
{ "p" integer }
|
||||
}
|
||||
{ $description "Returns a prime number exactly " { $snippet "numbits" } " bits in length, with the topmost bit set to one." } ;
|
||||
|
||||
HELP: random-safe-prime
|
||||
{ $values
|
||||
{ "numbits" integer }
|
||||
{ "p" integer }
|
||||
}
|
||||
{ $description "Returns a safe prime number " { $snippet "numbits" } " bits in length, with the topmost bit set to one." } ;
|
||||
|
||||
HELP: safe-prime?
|
||||
{ $values
|
||||
{ "q" integer }
|
||||
{ "?" "a boolean" }
|
||||
}
|
||||
{ $description "Tests whether the number is a safe prime. A safe prime " { $snippet "p" } " must be prime, as must " { $snippet "(p - 1) / 2" } "." } ;
|
||||
|
||||
HELP: unique-primes
|
||||
{ $values
|
||||
{ "numbits" integer } { "n" integer }
|
||||
{ "seq" sequence }
|
||||
}
|
||||
{ $description "Generates a sequence of " { $snippet "n" } " unique prime numbers with exactly " { $snippet "numbits" } " bits." } ;
|
||||
|
||||
ARTICLE: "math.miller-rabin" "Miller-Rabin probabilistic primality test"
|
||||
"The " { $vocab-link "math.miller-rabin" } " vocabulary implements the Miller-Rabin probabilistic primality test and utility words that use it in order to generate random prime numbers." $nl
|
||||
"The Miller-Rabin probabilistic primality test:"
|
||||
{ $subsection miller-rabin }
|
||||
{ $subsection miller-rabin* }
|
||||
"Generating relative prime numbers:"
|
||||
{ $subsection find-relative-prime }
|
||||
{ $subsection find-relative-prime* }
|
||||
"Generating prime numbers:"
|
||||
{ $subsection next-prime }
|
||||
{ $subsection random-prime }
|
||||
"Generating safe prime numbers:"
|
||||
{ $subsection next-safe-prime }
|
||||
{ $subsection random-safe-prime } ;
|
||||
|
||||
ABOUT: "math.miller-rabin"
|
|
@ -1,4 +1,5 @@
|
|||
USING: math.miller-rabin tools.test ;
|
||||
USING: math.miller-rabin tools.test kernel sequences
|
||||
math.miller-rabin.private math ;
|
||||
IN: math.miller-rabin.tests
|
||||
|
||||
[ f ] [ 473155932665450549999756893736999469773678960651272093993257221235459777950185377130233556540099119926369437865330559863 miller-rabin ] unit-test
|
||||
|
@ -6,6 +7,23 @@ IN: math.miller-rabin.tests
|
|||
[ t ] [ 3 miller-rabin ] unit-test
|
||||
[ f ] [ 36 miller-rabin ] unit-test
|
||||
[ t ] [ 37 miller-rabin ] unit-test
|
||||
[ 2 ] [ 1 next-prime ] unit-test
|
||||
[ 3 ] [ 2 next-prime ] unit-test
|
||||
[ 5 ] [ 3 next-prime ] unit-test
|
||||
[ 101 ] [ 100 next-prime ] unit-test
|
||||
[ t ] [ 2135623355842621559 miller-rabin ] unit-test
|
||||
[ 100000000000031 ] [ 100000000000000 next-prime ] unit-test
|
||||
[ 100000000000031 ] [ 100000000000000 next-prime ] unit-test
|
||||
|
||||
[ 863 ] [ 862 next-safe-prime ] unit-test
|
||||
[ f ] [ 862 safe-prime? ] unit-test
|
||||
[ t ] [ 7 safe-prime? ] unit-test
|
||||
[ f ] [ 31 safe-prime? ] unit-test
|
||||
[ t ] [ 47 safe-prime-candidate? ] unit-test
|
||||
[ t ] [ 47 safe-prime? ] unit-test
|
||||
[ t ] [ 863 safe-prime? ] unit-test
|
||||
|
||||
[ f ] [ 1000 [ drop 15 miller-rabin ] any? ] unit-test
|
||||
|
||||
[ 47 ] [ 31 next-safe-prime ] unit-test
|
||||
[ 49 ] [ 50 random-prime log2 ] unit-test
|
||||
[ 49 ] [ 50 random-bits* log2 ] unit-test
|
||||
|
|
|
@ -1,37 +1,40 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: combinators kernel locals math math.functions math.ranges
|
||||
random sequences sets ;
|
||||
random sequences sets combinators.short-circuit math.bitwise
|
||||
math math.order ;
|
||||
IN: math.miller-rabin
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: >odd ( n -- int ) dup even? [ 1+ ] when ; foldable
|
||||
: >odd ( n -- int ) 0 set-bit ; foldable
|
||||
|
||||
: >even ( n -- int ) 0 clear-bit ; foldable
|
||||
|
||||
: next-even ( m -- n ) >even 2 + ;
|
||||
|
||||
: next-odd ( m -- n ) dup even? [ 1 + ] [ 2 + ] if ;
|
||||
|
||||
TUPLE: positive-even-expected n ;
|
||||
|
||||
:: (miller-rabin) ( n trials -- ? )
|
||||
[let | r [ n 1- factor-2s drop ]
|
||||
s [ n 1- factor-2s nip ]
|
||||
prime?! [ t ]
|
||||
a! [ 0 ]
|
||||
count! [ 0 ] |
|
||||
trials [
|
||||
n 1- [1,b] random a!
|
||||
a s n ^mod 1 = [
|
||||
0 count!
|
||||
r [
|
||||
2^ s * a swap n ^mod n - -1 =
|
||||
[ count 1+ count! r + ] when
|
||||
] each
|
||||
count zero? [ f prime?! trials + ] when
|
||||
] unless drop
|
||||
] each prime? ] ;
|
||||
n 1 - :> n-1
|
||||
n-1 factor-2s :> s :> r
|
||||
0 :> a!
|
||||
trials [
|
||||
drop
|
||||
2 n 2 - [a,b] random a!
|
||||
a s n ^mod 1 = [
|
||||
f
|
||||
] [
|
||||
r iota [
|
||||
2^ s * a swap n ^mod n - -1 =
|
||||
] any? not
|
||||
] if
|
||||
] any? not ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: next-odd ( m -- n ) dup even? [ 1+ ] [ 2 + ] if ;
|
||||
|
||||
: miller-rabin* ( n numtrials -- ? )
|
||||
over {
|
||||
{ [ dup 1 <= ] [ 3drop f ] }
|
||||
|
@ -42,11 +45,21 @@ PRIVATE>
|
|||
|
||||
: miller-rabin ( n -- ? ) 10 miller-rabin* ;
|
||||
|
||||
ERROR: prime-range-error n ;
|
||||
|
||||
: next-prime ( n -- p )
|
||||
next-odd dup miller-rabin [ next-prime ] unless ;
|
||||
dup 1 < [ prime-range-error ] when
|
||||
dup 1 = [
|
||||
drop 2
|
||||
] [
|
||||
next-odd dup miller-rabin [ next-prime ] unless
|
||||
] if ;
|
||||
|
||||
: random-bits* ( numbits -- n )
|
||||
1 - [ random-bits ] keep set-bit ;
|
||||
|
||||
: random-prime ( numbits -- p )
|
||||
random-bits next-prime ;
|
||||
random-bits* next-prime ;
|
||||
|
||||
ERROR: no-relative-prime n ;
|
||||
|
||||
|
@ -74,3 +87,30 @@ ERROR: too-few-primes ;
|
|||
dup 5 < [ too-few-primes ] when
|
||||
2dup [ random-prime ] curry replicate
|
||||
dup all-unique? [ 2nip ] [ drop unique-primes ] if ;
|
||||
|
||||
! Safe primes are of the form p = 2q + 1, p,q are prime
|
||||
! See http://en.wikipedia.org/wiki/Safe_prime
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: safe-prime-candidate? ( n -- ? )
|
||||
1 + 6 divisor? ;
|
||||
|
||||
: next-safe-prime-candidate ( n -- candidate )
|
||||
next-prime dup safe-prime-candidate?
|
||||
[ next-safe-prime-candidate ] unless ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: safe-prime? ( q -- ? )
|
||||
{
|
||||
[ 1 - 2 / dup integer? [ miller-rabin ] [ drop f ] if ]
|
||||
[ miller-rabin ]
|
||||
} 1&& ;
|
||||
|
||||
: next-safe-prime ( n -- q )
|
||||
next-safe-prime-candidate
|
||||
dup safe-prime? [ next-safe-prime ] unless ;
|
||||
|
||||
: random-safe-prime ( numbits -- p )
|
||||
random-bits* next-safe-prime ;
|
||||
|
|
|
@ -16,7 +16,7 @@ IN: math.polynomials
|
|||
PRIVATE>
|
||||
|
||||
: powers ( n x -- seq )
|
||||
<array> 1 [ * ] accumulate nip ;
|
||||
<repetition> 1 [ * ] accumulate nip ;
|
||||
|
||||
: p= ( p q -- ? ) pextend = ;
|
||||
|
||||
|
@ -29,7 +29,7 @@ PRIVATE>
|
|||
: n*p ( n p -- n*p ) n*v ;
|
||||
|
||||
: pextend-conv ( p q -- p q )
|
||||
2dup [ length ] bi@ + 1- 2pad-tail [ >vector ] bi@ ;
|
||||
2dup [ length ] bi@ + 1 - 2pad-tail [ >vector ] bi@ ;
|
||||
|
||||
: p* ( p q -- r )
|
||||
2unempty pextend-conv <reversed> dup length
|
||||
|
@ -44,7 +44,7 @@ PRIVATE>
|
|||
2ptrim
|
||||
2dup [ length ] bi@ -
|
||||
dup 1 < [ drop 1 ] when
|
||||
[ over length + 0 pad-head pextend ] keep 1+ ;
|
||||
[ over length + 0 pad-head pextend ] keep 1 + ;
|
||||
|
||||
: /-last ( seq seq -- a )
|
||||
#! divide the last two numbers in the sequences
|
||||
|
|
|
@ -10,7 +10,7 @@ TUPLE: range
|
|||
{ step read-only } ;
|
||||
|
||||
: <range> ( a b step -- range )
|
||||
[ over - ] dip [ /i 1+ 0 max ] keep range boa ; inline
|
||||
[ over - ] dip [ /i 1 + 0 max ] keep range boa ; inline
|
||||
|
||||
M: range length ( seq -- n )
|
||||
length>> ;
|
||||
|
|
|
@ -15,7 +15,7 @@ IN: math.statistics
|
|||
|
||||
: median ( seq -- n )
|
||||
natural-sort dup length even? [
|
||||
[ midpoint@ dup 1- 2array ] keep nths mean
|
||||
[ midpoint@ dup 1 - 2array ] keep nths mean
|
||||
] [
|
||||
[ midpoint@ ] keep nth
|
||||
] if ;
|
||||
|
@ -33,7 +33,7 @@ IN: math.statistics
|
|||
drop 0
|
||||
] [
|
||||
[ [ mean ] keep [ - sq ] with sigma ] keep
|
||||
length 1- /
|
||||
length 1 - /
|
||||
] if ;
|
||||
|
||||
: std ( seq -- x )
|
||||
|
@ -47,7 +47,7 @@ IN: math.statistics
|
|||
0 [ [ [ pick ] dip swap - ] bi@ * + ] 2reduce 2nip ;
|
||||
|
||||
: (r) ( mean(x) mean(y) {x} {y} sx sy -- r )
|
||||
* recip [ [ ((r)) ] keep length 1- / ] dip * ;
|
||||
* recip [ [ ((r)) ] keep length 1 - / ] dip * ;
|
||||
|
||||
: [r] ( {{x,y}...} -- mean(x) mean(y) {x} {y} sx sy )
|
||||
first2 [ [ [ mean ] bi@ ] 2keep ] 2keep [ std ] bi@ ;
|
||||
|
|
|
@ -9,3 +9,8 @@ USING: math.vectors tools.test ;
|
|||
[ 5 ] [ { 1 2 } norm-sq ] unit-test
|
||||
[ 13 ] [ { 2 3 } norm-sq ] unit-test
|
||||
|
||||
[ { 1.0 2.5 } ] [ { 1.0 2.5 } { 2.5 1.0 } 0.0 vnlerp ] unit-test
|
||||
[ { 2.5 1.0 } ] [ { 1.0 2.5 } { 2.5 1.0 } 1.0 vnlerp ] unit-test
|
||||
[ { 1.75 1.75 } ] [ { 1.0 2.5 } { 2.5 1.0 } 0.5 vnlerp ] unit-test
|
||||
|
||||
[ { 1.75 2.125 } ] [ { 1.0 2.5 } { 2.5 1.0 } { 0.5 0.25 } vlerp ] unit-test
|
||||
|
|
|
@ -6,6 +6,11 @@ IN: math.vectors
|
|||
|
||||
: vneg ( u -- v ) [ neg ] map ;
|
||||
|
||||
: v+n ( u n -- v ) [ + ] curry map ;
|
||||
: n+v ( n u -- v ) [ + ] with map ;
|
||||
: v-n ( u n -- v ) [ - ] curry map ;
|
||||
: n-v ( n u -- v ) [ - ] with map ;
|
||||
|
||||
: v*n ( u n -- v ) [ * ] curry map ;
|
||||
: n*v ( n u -- v ) [ * ] with map ;
|
||||
: v/n ( u n -- v ) [ / ] curry map ;
|
||||
|
@ -19,6 +24,10 @@ IN: math.vectors
|
|||
: vmax ( u v -- w ) [ max ] 2map ;
|
||||
: vmin ( u v -- w ) [ min ] 2map ;
|
||||
|
||||
: vfloor ( v -- _v_ ) [ floor ] map ;
|
||||
: vceiling ( v -- ^v^ ) [ ceiling ] map ;
|
||||
: vtruncate ( v -- -v- ) [ truncate ] map ;
|
||||
|
||||
: vsupremum ( seq -- vmax ) [ ] [ vmax ] map-reduce ;
|
||||
: vinfimum ( seq -- vmin ) [ ] [ vmin ] map-reduce ;
|
||||
|
||||
|
@ -32,6 +41,12 @@ IN: math.vectors
|
|||
: set-axis ( u v axis -- w )
|
||||
[ [ zero? 2over ? ] dip swap nth ] map-index 2nip ;
|
||||
|
||||
: vlerp ( a b t -- a_t )
|
||||
[ lerp ] 3map ;
|
||||
|
||||
: vnlerp ( a b t -- a_t )
|
||||
[ lerp ] curry 2map ;
|
||||
|
||||
HINTS: vneg { array } ;
|
||||
HINTS: norm-sq { array } ;
|
||||
HINTS: norm { array } ;
|
||||
|
@ -50,3 +65,6 @@ HINTS: v/ { array array } ;
|
|||
HINTS: vmax { array array } ;
|
||||
HINTS: vmin { array array } ;
|
||||
HINTS: v. { array array } ;
|
||||
|
||||
HINTS: vlerp { array array array } ;
|
||||
HINTS: vnlerp { array array object } ;
|
||||
|
|
|
@ -3,7 +3,7 @@
|
|||
USING: alien.c-types kernel math namespaces sequences
|
||||
io.backend io.binary combinators system vocabs.loader
|
||||
summary math.bitwise byte-vectors fry byte-arrays
|
||||
math.ranges ;
|
||||
math.ranges math.constants math.functions accessors ;
|
||||
IN: random
|
||||
|
||||
SYMBOL: system-random-generator
|
||||
|
@ -69,6 +69,20 @@ PRIVATE>
|
|||
: with-secure-random ( quot -- )
|
||||
secure-random-generator get swap with-random ; inline
|
||||
|
||||
: uniform-random-float ( min max -- n )
|
||||
4 random-bytes underlying>> *uint >float
|
||||
4 random-bytes underlying>> *uint >float
|
||||
2.0 32 ^ * +
|
||||
[ over - 2.0 -64 ^ * ] dip
|
||||
* + ; inline
|
||||
|
||||
: normal-random-float ( mean sigma -- n )
|
||||
0.0 1.0 uniform-random-float
|
||||
0.0 1.0 uniform-random-float
|
||||
[ 2 pi * * cos ]
|
||||
[ 1.0 swap - log -2.0 * sqrt ]
|
||||
bi* * * + ;
|
||||
|
||||
USE: vocabs.loader
|
||||
|
||||
{
|
||||
|
|
|
@ -2,7 +2,7 @@ IN: specialized-arrays.tests
|
|||
USING: tools.test specialized-arrays sequences
|
||||
specialized-arrays.int specialized-arrays.bool
|
||||
specialized-arrays.ushort alien.c-types accessors kernel
|
||||
specialized-arrays.direct.int arrays ;
|
||||
specialized-arrays.direct.int specialized-arrays.char arrays ;
|
||||
|
||||
[ t ] [ { 1 2 3 } >int-array int-array? ] unit-test
|
||||
|
||||
|
@ -10,7 +10,7 @@ specialized-arrays.direct.int arrays ;
|
|||
|
||||
[ 2 ] [ int-array{ 1 2 3 } second ] unit-test
|
||||
|
||||
[ t ] [ { t f t } >bool-array underlying>> { 1 0 1 } >int-array underlying>> = ] unit-test
|
||||
[ t ] [ { t f t } >bool-array underlying>> { 1 0 1 } >char-array underlying>> = ] unit-test
|
||||
|
||||
[ ushort-array{ 1234 } ] [
|
||||
little-endian? B{ 210 4 } B{ 4 210 } ? byte-array>ushort-array
|
||||
|
|
|
@ -0,0 +1,9 @@
|
|||
IN: tools.disassembler.udis.tests
|
||||
USING: tools.disassembler.udis tools.test alien.c-types system combinators kernel ;
|
||||
|
||||
{
|
||||
{ [ os linux? cpu x86.64? and ] [ [ 656 ] [ "ud" heap-size ] unit-test ] }
|
||||
{ [ os macosx? cpu x86.32? and ] [ [ 592 ] [ "ud" heap-size ] unit-test ] }
|
||||
{ [ os macosx? cpu x86.64? and ] [ [ 656 ] [ "ud" heap-size ] unit-test ] }
|
||||
[ ]
|
||||
} cond
|
|
@ -16,7 +16,57 @@ IN: tools.disassembler.udis
|
|||
|
||||
LIBRARY: libudis86
|
||||
|
||||
TYPEDEF: char[592] ud
|
||||
C-STRUCT: ud_operand
|
||||
{ "int" "type" }
|
||||
{ "uchar" "size" }
|
||||
{ "ulonglong" "lval" }
|
||||
{ "int" "base" }
|
||||
{ "int" "index" }
|
||||
{ "uchar" "offset" }
|
||||
{ "uchar" "scale" } ;
|
||||
|
||||
C-STRUCT: ud
|
||||
{ "void*" "inp_hook" }
|
||||
{ "uchar" "inp_curr" }
|
||||
{ "uchar" "inp_fill" }
|
||||
{ "FILE*" "inp_file" }
|
||||
{ "uchar" "inp_ctr" }
|
||||
{ "uchar*" "inp_buff" }
|
||||
{ "uchar*" "inp_buff_end" }
|
||||
{ "uchar" "inp_end" }
|
||||
{ "void*" "translator" }
|
||||
{ "ulonglong" "insn_offset" }
|
||||
{ "char[32]" "insn_hexcode" }
|
||||
{ "char[64]" "insn_buffer" }
|
||||
{ "uint" "insn_fill" }
|
||||
{ "uchar" "dis_mode" }
|
||||
{ "ulonglong" "pc" }
|
||||
{ "uchar" "vendor" }
|
||||
{ "struct map_entry*" "mapen" }
|
||||
{ "int" "mnemonic" }
|
||||
{ "ud_operand[3]" "operand" }
|
||||
{ "uchar" "error" }
|
||||
{ "uchar" "pfx_rex" }
|
||||
{ "uchar" "pfx_seg" }
|
||||
{ "uchar" "pfx_opr" }
|
||||
{ "uchar" "pfx_adr" }
|
||||
{ "uchar" "pfx_lock" }
|
||||
{ "uchar" "pfx_rep" }
|
||||
{ "uchar" "pfx_repe" }
|
||||
{ "uchar" "pfx_repne" }
|
||||
{ "uchar" "pfx_insn" }
|
||||
{ "uchar" "default64" }
|
||||
{ "uchar" "opr_mode" }
|
||||
{ "uchar" "adr_mode" }
|
||||
{ "uchar" "br_far" }
|
||||
{ "uchar" "br_near" }
|
||||
{ "uchar" "implicit_addr" }
|
||||
{ "uchar" "c1" }
|
||||
{ "uchar" "c2" }
|
||||
{ "uchar" "c3" }
|
||||
{ "uchar[256]" "inp_cache" }
|
||||
{ "uchar[64]" "inp_sess" }
|
||||
{ "ud_itab_entry*" "itab_entry" } ;
|
||||
|
||||
FUNCTION: void ud_translate_intel ( ud* u ) ;
|
||||
FUNCTION: void ud_translate_att ( ud* u ) ;
|
||||
|
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2003, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel math math.vectors memory io io.styles prettyprint
|
||||
USING: kernel math memory io io.styles prettyprint
|
||||
namespaces system sequences splitting grouping assocs strings
|
||||
generic.single combinators ;
|
||||
IN: tools.time
|
||||
|
|
|
@ -1,4 +1,30 @@
|
|||
IN: tools.trace.tests
|
||||
USING: tools.trace tools.test sequences ;
|
||||
USING: tools.trace tools.test tools.continuations kernel math combinators
|
||||
sequences ;
|
||||
|
||||
[ { 3 2 1 } ] [ { 1 2 3 } [ reverse ] trace ] unit-test
|
||||
[ { 3 2 1 } ] [ { 1 2 3 } [ reverse ] trace ] unit-test
|
||||
|
||||
GENERIC: method-breakpoint-test ( x -- y )
|
||||
|
||||
TUPLE: method-breakpoint-tuple ;
|
||||
|
||||
M: method-breakpoint-tuple method-breakpoint-test break drop 1 2 + ;
|
||||
|
||||
\ method-breakpoint-test don't-step-into
|
||||
|
||||
[ 3 ]
|
||||
[ [ T{ method-breakpoint-tuple } method-breakpoint-test ] trace ] unit-test
|
||||
|
||||
: case-breakpoint-test ( -- x )
|
||||
5 { [ break 1 + ] } case ;
|
||||
|
||||
\ case-breakpoint-test don't-step-into
|
||||
|
||||
[ 6 ] [ [ case-breakpoint-test ] trace ] unit-test
|
||||
|
||||
: call(-breakpoint-test ( -- x )
|
||||
[ break 1 ] call( -- x ) 2 + ;
|
||||
|
||||
\ call(-breakpoint-test don't-step-into
|
||||
|
||||
[ 3 ] [ [ call(-breakpoint-test ] trace ] unit-test
|
||||
|
|
|
@ -4,19 +4,21 @@ USING: concurrency.promises models tools.continuations kernel
|
|||
sequences concurrency.messaging locals continuations threads
|
||||
namespaces namespaces.private make assocs accessors io strings
|
||||
prettyprint math math.parser words effects summary io.styles classes
|
||||
generic.math combinators.short-circuit ;
|
||||
generic.math combinators.short-circuit kernel.private quotations ;
|
||||
IN: tools.trace
|
||||
|
||||
: callstack-depth ( callstack -- n )
|
||||
callstack>array length 2/ ;
|
||||
|
||||
SYMBOL: end
|
||||
|
||||
SYMBOL: exclude-vocabs
|
||||
SYMBOL: include-vocabs
|
||||
|
||||
exclude-vocabs { "math" "accessors" } swap set-global
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: callstack-depth ( callstack -- n )
|
||||
callstack>array length 2/ ;
|
||||
|
||||
SYMBOL: end
|
||||
|
||||
: include? ( vocab -- ? )
|
||||
include-vocabs get dup [ member? ] [ 2drop t ] if ;
|
||||
|
||||
|
@ -65,15 +67,20 @@ M: trace-step summary
|
|||
[ CHAR: \s <string> write ]
|
||||
[ number>string write ": " write ] bi ;
|
||||
|
||||
: trace-into? ( continuation -- ? )
|
||||
continuation-current into? ;
|
||||
|
||||
: trace-step ( continuation -- continuation' )
|
||||
dup continuation-current end eq? [
|
||||
[ print-depth ]
|
||||
[ print-step ]
|
||||
[
|
||||
dup continuation-current into?
|
||||
[ continuation-step-into ] [ continuation-step ] if
|
||||
] tri
|
||||
] unless ;
|
||||
dup call>> innermost-frame-executing quotation? [
|
||||
dup continuation-current end eq? [
|
||||
[ print-depth ]
|
||||
[ print-step ]
|
||||
[ dup trace-into? [ continuation-step-into ] [ continuation-step ] if ]
|
||||
tri
|
||||
] unless
|
||||
] when ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: trace ( quot -- data )
|
||||
[ [ trace-step ] break-hook ] dip
|
||||
|
|
|
@ -145,7 +145,9 @@ SYMBOL: ui-thread
|
|||
PRIVATE>
|
||||
|
||||
: find-window ( quot -- world )
|
||||
[ windows get values ] dip '[ gadget-child @ ] find-last nip ; inline
|
||||
[ windows get values ] dip
|
||||
'[ dup children>> [ ] [ nip first ] if-empty @ ]
|
||||
find-last nip ; inline
|
||||
|
||||
: ui-running? ( -- ? )
|
||||
\ ui-running get-global ;
|
||||
|
|
|
@ -444,6 +444,18 @@ CONSTANT: DISCL_FOREGROUND HEX: 00000004
|
|||
CONSTANT: DISCL_BACKGROUND HEX: 00000008
|
||||
CONSTANT: DISCL_NOWINKEY HEX: 00000010
|
||||
|
||||
CONSTANT: DIMOFS_X 0
|
||||
CONSTANT: DIMOFS_Y 4
|
||||
CONSTANT: DIMOFS_Z 8
|
||||
CONSTANT: DIMOFS_BUTTON0 12
|
||||
CONSTANT: DIMOFS_BUTTON1 13
|
||||
CONSTANT: DIMOFS_BUTTON2 14
|
||||
CONSTANT: DIMOFS_BUTTON3 15
|
||||
CONSTANT: DIMOFS_BUTTON4 16
|
||||
CONSTANT: DIMOFS_BUTTON5 17
|
||||
CONSTANT: DIMOFS_BUTTON6 18
|
||||
CONSTANT: DIMOFS_BUTTON7 19
|
||||
|
||||
CONSTANT: DIK_ESCAPE HEX: 01
|
||||
CONSTANT: DIK_1 HEX: 02
|
||||
CONSTANT: DIK_2 HEX: 03
|
||||
|
|
|
@ -40,19 +40,26 @@ M: unix alien>native-string utf8 alien>string ;
|
|||
|
||||
HOOK: native-string>alien os ( string -- alien )
|
||||
|
||||
M: wince native-string>alien utf16n string>alien ;
|
||||
|
||||
M: winnt native-string>alien utf8 string>alien ;
|
||||
M: windows native-string>alien utf16n string>alien ;
|
||||
|
||||
M: unix native-string>alien utf8 string>alien ;
|
||||
|
||||
: dll-path ( dll -- string )
|
||||
path>> alien>native-string ;
|
||||
|
||||
: string>symbol ( str -- alien )
|
||||
dup string?
|
||||
[ native-string>alien ]
|
||||
[ [ native-string>alien ] map ] if ;
|
||||
HOOK: string>symbol* os ( str/seq -- alien )
|
||||
|
||||
M: winnt string>symbol* utf8 string>alien ;
|
||||
|
||||
M: wince string>symbol* utf16n string>alien ;
|
||||
|
||||
M: unix string>symbol* utf8 string>alien ;
|
||||
|
||||
GENERIC: string>symbol ( str -- alien )
|
||||
|
||||
M: string string>symbol string>symbol* ;
|
||||
|
||||
M: sequence string>symbol [ string>symbol* ] map ;
|
||||
|
||||
[
|
||||
8 getenv utf8 alien>string string>cpu \ cpu set-global
|
||||
|
|
|
@ -231,7 +231,8 @@ bi
|
|||
"vocabulary"
|
||||
{ "def" { "quotation" "quotations" } initial: [ ] }
|
||||
"props"
|
||||
{ "direct-entry-def" }
|
||||
"pic-def"
|
||||
"pic-tail-def"
|
||||
{ "counter" { "fixnum" "math" } }
|
||||
{ "sub-primitive" read-only }
|
||||
} define-builtin
|
||||
|
@ -505,6 +506,7 @@ tuple
|
|||
{ "load-locals" "locals.backend" (( ... n -- )) }
|
||||
{ "check-datastack" "kernel.private" (( array in# out# -- ? )) }
|
||||
{ "inline-cache-miss" "generic.single.private" (( generic methods index cache -- )) }
|
||||
{ "inline-cache-miss-tail" "generic.single.private" (( generic methods index cache -- )) }
|
||||
{ "mega-cache-miss" "generic.single.private" (( methods index cache -- method )) }
|
||||
{ "lookup-method" "generic.single.private" (( object methods -- method )) }
|
||||
{ "reset-dispatch-stats" "generic.single" (( -- )) }
|
||||
|
|
|
@ -64,7 +64,7 @@ IN: continuations.tests
|
|||
|
||||
[ 1 2 ] [ bar ] unit-test
|
||||
|
||||
[ t ] [ \ bar def>> "c" get innermost-frame-quot = ] unit-test
|
||||
[ t ] [ \ bar def>> "c" get innermost-frame-executing = ] unit-test
|
||||
|
||||
[ 1 ] [ "c" get innermost-frame-scan ] unit-test
|
||||
|
||||
|
|
|
@ -17,8 +17,6 @@ M: hook-combination picker
|
|||
|
||||
M: hook-combination dispatch# drop 0 ;
|
||||
|
||||
M: hook-combination inline-cache-quot 2drop f ;
|
||||
|
||||
M: hook-combination mega-cache-quot
|
||||
1quotation picker [ lookup-method (execute) ] surround ;
|
||||
|
||||
|
|
|
@ -273,5 +273,5 @@ M: growable call-next-hooker call-next-method "growable " prepend ;
|
|||
[ ] [ "IN: generic.single.tests GENERIC: xyz ( a -- b )" eval( -- ) ] unit-test
|
||||
[ ] [ "IN: generic.single.tests MATH: xyz ( a b -- c )" eval( -- ) ] unit-test
|
||||
|
||||
[ f ] [ "xyz" "generic.single.tests" lookup direct-entry-def>> ] unit-test
|
||||
[ f ] [ "xyz" "generic.single.tests" lookup pic-def>> ] unit-test
|
||||
[ f ] [ "xyz" "generic.single.tests" lookup "decision-tree" word-prop ] unit-test
|
|
@ -238,10 +238,14 @@ M: f compile-engine ;
|
|||
[ <engine> compile-engine ] bi
|
||||
] tri ;
|
||||
|
||||
HOOK: inline-cache-quot combination ( word methods -- quot/f )
|
||||
HOOK: inline-cache-quots combination ( word methods -- pic-quot/f pic-tail-quot/f )
|
||||
|
||||
M: single-combination inline-cache-quots 2drop f f ;
|
||||
|
||||
: define-inline-cache-quot ( word methods -- )
|
||||
[ drop ] [ inline-cache-quot ] 2bi >>direct-entry-def drop ;
|
||||
[ drop ] [ inline-cache-quots ] 2bi
|
||||
[ >>pic-def ] [ >>pic-tail-def ] bi*
|
||||
drop ;
|
||||
|
||||
HOOK: mega-cache-quot combination ( methods -- quot/f )
|
||||
|
||||
|
|
|
@ -3,7 +3,7 @@
|
|||
USING: accessors definitions generic generic.single kernel
|
||||
namespaces words math math.order combinators sequences
|
||||
generic.single.private quotations kernel.private
|
||||
assocs arrays layouts ;
|
||||
assocs arrays layouts make ;
|
||||
IN: generic.standard
|
||||
|
||||
TUPLE: standard-combination < single-combination # ;
|
||||
|
@ -38,17 +38,22 @@ M: standard-generic effective-method
|
|||
[ datastack ] dip [ "combination" word-prop #>> swap <reversed> nth ] keep
|
||||
(effective-method) ;
|
||||
|
||||
M: standard-combination inline-cache-quot ( word methods -- )
|
||||
: inline-cache-quot ( word methods miss-word -- quot )
|
||||
[ [ literalize , ] [ , ] [ combination get #>> , { } , , ] tri* ] [ ] make ;
|
||||
|
||||
M: standard-combination inline-cache-quots
|
||||
#! Direct calls to the generic word (not tail calls or indirect calls)
|
||||
#! will jump to the inline cache entry point instead of the megamorphic
|
||||
#! dispatch entry point.
|
||||
combination get #>> [ { } inline-cache-miss ] 3curry [ ] like ;
|
||||
[ \ inline-cache-miss inline-cache-quot ]
|
||||
[ \ inline-cache-miss-tail inline-cache-quot ]
|
||||
2bi ;
|
||||
|
||||
: make-empty-cache ( -- array )
|
||||
mega-cache-size get f <array> ;
|
||||
|
||||
M: standard-combination mega-cache-quot
|
||||
combination get #>> make-empty-cache [ mega-cache-lookup ] 3curry [ ] like ;
|
||||
combination get #>> make-empty-cache \ mega-cache-lookup [ ] 4sequence ;
|
||||
|
||||
M: standard-generic definer drop \ GENERIC# f ;
|
||||
|
||||
|
|
|
@ -139,14 +139,14 @@ M: hashtable set-at ( value key hash -- )
|
|||
PRIVATE>
|
||||
|
||||
M: hashtable >alist
|
||||
[ array>> [ length 2/ iota ] keep ] [ assoc-size <vector> ] bi [
|
||||
[ array>> [ length 2/ ] keep ] [ assoc-size <vector> ] bi [
|
||||
[
|
||||
[
|
||||
[ 1 fixnum-shift-fast ] dip
|
||||
[ array-nth ] [ [ 1 fixnum+fast ] dip array-nth ] 2bi
|
||||
] dip
|
||||
pick tombstone? [ 3drop ] [ [ 2array ] dip push-unsafe ] if
|
||||
] 2curry each
|
||||
] 2curry each-integer
|
||||
] keep { } like ;
|
||||
|
||||
M: hashtable clone
|
||||
|
|
|
@ -117,6 +117,7 @@ HELP: seek-relative
|
|||
}
|
||||
{ $description "Seeks to an offset from the current position of the stream pointer." } ;
|
||||
|
||||
{ seek-absolute seek-relative seek-end } related-words
|
||||
|
||||
HELP: seek-input
|
||||
{ $values
|
||||
|
@ -343,6 +344,10 @@ $nl
|
|||
{ $subsection bl }
|
||||
"Seeking on the default output stream:"
|
||||
{ $subsection seek-output }
|
||||
"Seeking descriptors:"
|
||||
{ $subsection seek-absolute }
|
||||
{ $subsection seek-relative }
|
||||
{ $subsection seek-end }
|
||||
"A pair of combinators for rebinding the " { $link output-stream } " variable:"
|
||||
{ $subsection with-output-stream }
|
||||
{ $subsection with-output-stream* }
|
||||
|
|
|
@ -155,7 +155,8 @@ M: word reset-word
|
|||
[ subwords forget-all ]
|
||||
[ reset-word ]
|
||||
[
|
||||
f >>direct-entry-def
|
||||
f >>pic-def
|
||||
f >>pic-tail-def
|
||||
{
|
||||
"methods"
|
||||
"combination"
|
||||
|
|
|
@ -5,16 +5,20 @@ windows.user32 windows.messages sequences combinators locals
|
|||
math.rectangles accessors math alien alien.strings
|
||||
io.encodings.utf16 io.encodings.utf16n continuations
|
||||
byte-arrays game-input.dinput.keys-array game-input
|
||||
ui.backend.windows windows.errors ;
|
||||
ui.backend.windows windows.errors struct-arrays
|
||||
math.bitwise ;
|
||||
IN: game-input.dinput
|
||||
|
||||
CONSTANT: MOUSE-BUFFER-SIZE 16
|
||||
|
||||
SINGLETON: dinput-game-input-backend
|
||||
|
||||
dinput-game-input-backend game-input-backend set-global
|
||||
|
||||
SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+
|
||||
+controller-devices+ +controller-guids+
|
||||
+device-change-window+ +device-change-handle+ ;
|
||||
+device-change-window+ +device-change-handle+
|
||||
+mouse-device+ +mouse-state+ +mouse-buffer+ ;
|
||||
|
||||
: create-dinput ( -- )
|
||||
f GetModuleHandle DIRECTINPUT_VERSION IDirectInput8W-iid
|
||||
|
@ -35,8 +39,24 @@ SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+
|
|||
: set-data-format ( device format-symbol -- )
|
||||
get IDirectInputDevice8W::SetDataFormat ole32-error ;
|
||||
|
||||
: <buffer-size-diprop> ( size -- DIPROPDWORD )
|
||||
"DIPROPDWORD" <c-object>
|
||||
"DIPROPDWORD" heap-size over set-DIPROPHEADER-dwSize
|
||||
"DIPROPHEADER" heap-size over set-DIPROPHEADER-dwHeaderSize
|
||||
0 over set-DIPROPHEADER-dwObj
|
||||
DIPH_DEVICE over set-DIPROPHEADER-dwHow
|
||||
swap over set-DIPROPDWORD-dwData ;
|
||||
|
||||
: set-buffer-size ( device size -- )
|
||||
DIPROP_BUFFERSIZE swap <buffer-size-diprop>
|
||||
IDirectInputDevice8W::SetProperty ole32-error ;
|
||||
|
||||
: configure-keyboard ( keyboard -- )
|
||||
[ c_dfDIKeyboard_HID set-data-format ] [ set-coop-level ] bi ;
|
||||
: configure-mouse ( mouse -- )
|
||||
[ c_dfDIMouse2 set-data-format ]
|
||||
[ MOUSE-BUFFER-SIZE set-buffer-size ]
|
||||
[ set-coop-level ] tri ;
|
||||
: configure-controller ( controller -- )
|
||||
[ c_dfDIJoystick2 set-data-format ] [ set-coop-level ] bi ;
|
||||
|
||||
|
@ -47,6 +67,15 @@ SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+
|
|||
256 <byte-array> <keys-array> keyboard-state boa
|
||||
+keyboard-state+ set-global ;
|
||||
|
||||
: find-mouse ( -- )
|
||||
GUID_SysMouse device-for-guid
|
||||
[ configure-mouse ]
|
||||
[ +mouse-device+ set-global ] bi
|
||||
0 0 0 0 8 f <array> mouse-state boa
|
||||
+mouse-state+ set-global
|
||||
MOUSE-BUFFER-SIZE "DIDEVICEOBJECTDATA" <c-array>
|
||||
+mouse-buffer+ set-global ;
|
||||
|
||||
: device-info ( device -- DIDEVICEIMAGEINFOW )
|
||||
"DIDEVICEINSTANCEW" <c-object>
|
||||
"DIDEVICEINSTANCEW" heap-size over set-DIDEVICEINSTANCEW-dwSize
|
||||
|
@ -190,16 +219,22 @@ TUPLE: window-rect < rect window-loc ;
|
|||
+keyboard-device+ [ com-release f ] change-global
|
||||
f +keyboard-state+ set-global ;
|
||||
|
||||
: release-mouse ( -- )
|
||||
+mouse-device+ [ com-release f ] change-global
|
||||
f +mouse-state+ set-global ;
|
||||
|
||||
M: dinput-game-input-backend (open-game-input)
|
||||
create-dinput
|
||||
create-device-change-window
|
||||
find-keyboard
|
||||
find-mouse
|
||||
set-up-controllers
|
||||
add-wm-devicechange ;
|
||||
|
||||
M: dinput-game-input-backend (close-game-input)
|
||||
remove-wm-devicechange
|
||||
release-controllers
|
||||
release-mouse
|
||||
release-keyboard
|
||||
close-device-change-window
|
||||
delete-dinput ;
|
||||
|
@ -263,6 +298,22 @@ CONSTANT: pov-values
|
|||
[ DIJOYSTATE2-rgbButtons over buttons>> length >buttons >>buttons ]
|
||||
} 2cleave ;
|
||||
|
||||
: read-device-buffer ( device buffer count -- buffer count' )
|
||||
[ "DIDEVICEOBJECTDATA" heap-size ] 2dip <uint>
|
||||
[ 0 IDirectInputDevice8W::GetDeviceData ole32-error ] 2keep *uint ;
|
||||
|
||||
: (fill-mouse-state) ( state DIDEVICEOBJECTDATA -- state )
|
||||
[ DIDEVICEOBJECTDATA-dwData 32 >signed ] [ DIDEVICEOBJECTDATA-dwOfs ] bi {
|
||||
{ DIMOFS_X [ [ + ] curry change-dx ] }
|
||||
{ DIMOFS_Y [ [ + ] curry change-dy ] }
|
||||
{ DIMOFS_Z [ [ + ] curry change-scroll-dy ] }
|
||||
[ [ c-bool> ] [ DIMOFS_BUTTON0 - ] bi* rot [ buttons>> set-nth ] keep ]
|
||||
} case ;
|
||||
|
||||
: fill-mouse-state ( buffer count -- state )
|
||||
[ +mouse-state+ get ] 2dip swap
|
||||
[ "DIDEVICEOBJECTDATA" byte-array>struct-array nth (fill-mouse-state) ] curry each ;
|
||||
|
||||
: get-device-state ( device byte-array -- )
|
||||
[ dup IDirectInputDevice8W::Poll ole32-error ] dip
|
||||
[ length ] keep
|
||||
|
@ -283,3 +334,17 @@ M: dinput-game-input-backend read-keyboard
|
|||
+keyboard-device+ get
|
||||
[ +keyboard-state+ get [ keys>> underlying>> get-device-state ] keep ]
|
||||
[ ] [ f ] with-acquisition ;
|
||||
|
||||
M: dinput-game-input-backend read-mouse
|
||||
+mouse-device+ get [ +mouse-buffer+ get MOUSE-BUFFER-SIZE read-device-buffer ]
|
||||
[ fill-mouse-state ] [ f ] with-acquisition ;
|
||||
|
||||
M: dinput-game-input-backend reset-mouse
|
||||
+mouse-device+ get [ f MOUSE-BUFFER-SIZE read-device-buffer ]
|
||||
[ 2drop ] [ ] with-acquisition
|
||||
+mouse-state+ get
|
||||
0 >>dx
|
||||
0 >>dy
|
||||
0 >>scroll-dx
|
||||
0 >>scroll-dy
|
||||
drop ;
|
||||
|
|
|
@ -3,7 +3,7 @@ sequences strings math ;
|
|||
IN: game-input
|
||||
|
||||
ARTICLE: "game-input" "Game controller input"
|
||||
"The " { $vocab-link "game-input" } " vocabulary provides cross-platform access to game controller devices such as joysticks and gamepads. It also provides an interface for polling raw keyboard input." $nl
|
||||
"The " { $vocab-link "game-input" } " vocabulary provides cross-platform access to game controller devices such as joysticks and gamepads. It also provides an interface for polling raw keyboard and mouse input." $nl
|
||||
"The game input interface must be initialized before being used:"
|
||||
{ $subsection open-game-input }
|
||||
{ $subsection close-game-input }
|
||||
|
@ -18,11 +18,13 @@ ARTICLE: "game-input" "Game controller input"
|
|||
{ $subsection instance-id }
|
||||
"A hook is provided for invoking the system calibration tool:"
|
||||
{ $subsection calibrate-controller }
|
||||
"The current state of a controller or the keyboard can be read:"
|
||||
"The current state of a controller, the keyboard, and the mouse can be read:"
|
||||
{ $subsection read-controller }
|
||||
{ $subsection read-keyboard }
|
||||
{ $subsection read-mouse }
|
||||
{ $subsection controller-state }
|
||||
{ $subsection keyboard-state } ;
|
||||
{ $subsection keyboard-state }
|
||||
{ $subsection mouse-state } ;
|
||||
|
||||
HELP: open-game-input
|
||||
{ $description "Initializes the game input interface. An exception will be thrown if the initialization fails. If the game input interface is already opened, nothing happens." } ;
|
||||
|
@ -86,6 +88,14 @@ HELP: read-keyboard
|
|||
{ $warning "For efficiency, the implementation may reuse the returned " { $snippet "keyboard-state" } " object next time " { $snippet "read-keyboard" } " is called. You should " { $link clone } " any values from the returned tuple you need to preserve."
|
||||
$nl "The keyboard state returned by this word is unprocessed by any keymaps, modifier keys, key repeat settings, or other operating environment postprocessing. Because of this, " { $snippet "read-keyboard" } " should not be used for text entry purposes. The Factor UI's standard gesture mechanism should be used in cases where the logical meaning of keypresses is needed; see " { $link "keyboard-gestures" } "." } ;
|
||||
|
||||
HELP: read-mouse
|
||||
{ $values { "mouse-state" mouse-state } }
|
||||
{ $description "Reads the current mouse state relative to either when the game input interface was opened with " { $link open-game-input } " or when the mouse state was reset with " { $link reset-mouse } "." }
|
||||
{ $warning "For efficiency, the implementation may reuse the returned " { $snippet "mouse-state" } " object for future " { $snippet "read-mouse" } " or " { $snippet "reset-mouse" } " calls. You should " { $link clone } " the " { $snippet "mouse-state" } " object if you need to preserve it." } ;
|
||||
|
||||
HELP: reset-mouse
|
||||
{ $description "Resets the mouse state. Future " { $link read-mouse } " values will be relative to the time this word is called." } ;
|
||||
|
||||
HELP: controller-state
|
||||
{ $class-description "The " { $link read-controller } " word returns objects of this class. " { $snippet "controller-state" } " objects have the following slots:"
|
||||
{ $list
|
||||
|
@ -121,6 +131,19 @@ HELP: keyboard-state
|
|||
{ $class-description "The " { $link read-keyboard } " word returns objects of this class. The " { $snippet "keys" } " slot of a " { $snippet "keyboard-state" } " object contains a " { $link sequence } " of 256 members representing the state of the keys on the keyboard. Each element is a boolean value indicating whether the corresponding key is pressed. The sequence is indexed by scancode as defined under usage page 7 of the USB HID standard. Named scancode constants are provided in the " { $vocab-link "game-input.scancodes" } " vocabulary." }
|
||||
{ $warning "The scancodes used to index " { $snippet "keyboard-state" } " objects correspond to physical key positions on the keyboard--they are unaffected by keymaps, modifier keys, or other operating environment postprocessing. The face value of the constants in " { $vocab-link "game-input.scancodes" } " do not necessarily correspond to what the user expects the key to type. Because of this, " { $link read-keyboard } " should not be used for text entry purposes. The Factor UI's standard gesture mechanism should be used in cases where the logical meaning of keypresses is needed; see " { $link "keyboard-gestures" } "." } ;
|
||||
|
||||
HELP: mouse-state
|
||||
{ $class-description "The " { $link read-mouse } " word returns objects of this class. " { $snippet "mouse-state" } " objects have the following slots:"
|
||||
{ $list
|
||||
{ { $snippet "dx" } " contains the mouse's X axis movement." }
|
||||
{ { $snippet "dy" } " contains the mouse's Y axis movement." }
|
||||
{ { $snippet "scroll-dx" } " contains the scroller's X axis movement." }
|
||||
{ { $snippet "scroll-dy" } " contains the scroller's Y axis movement." }
|
||||
{ { $snippet "buttons" } " contains a sequence of boolean values indicate the state of the mouse's buttons." }
|
||||
}
|
||||
"Mouse movement is recorded relative to when the game input interface was opened with " { $link open-game-input } " or the mouse state is reset with " { $link reset-mouse } "."
|
||||
} ;
|
||||
|
||||
|
||||
{ keyboard-state read-keyboard } related-words
|
||||
|
||||
ABOUT: "game-input"
|
||||
|
|
|
@ -73,6 +73,15 @@ M: keyboard-state clone
|
|||
|
||||
HOOK: read-keyboard game-input-backend ( -- keyboard-state )
|
||||
|
||||
TUPLE: mouse-state dx dy scroll-dx scroll-dy buttons ;
|
||||
|
||||
M: mouse-state clone
|
||||
call-next-method dup buttons>> clone >>buttons ;
|
||||
|
||||
HOOK: read-mouse game-input-backend ( -- mouse-state )
|
||||
|
||||
HOOK: reset-mouse game-input-backend ( -- )
|
||||
|
||||
{
|
||||
{ [ os windows? ] [ "game-input.dinput" require ] }
|
||||
{ [ os macosx? ] [ "game-input.iokit" require ] }
|
||||
|
|
|
@ -3,7 +3,7 @@ kernel cocoa.enumeration destructors math.parser cocoa.application
|
|||
sequences locals combinators.short-circuit threads
|
||||
namespaces assocs vectors arrays combinators
|
||||
core-foundation.run-loop accessors sequences.private
|
||||
alien.c-types math parser game-input ;
|
||||
alien.c-types math parser game-input vectors ;
|
||||
IN: game-input.iokit
|
||||
|
||||
SINGLETON: iokit-game-input-backend
|
||||
|
@ -23,9 +23,13 @@ iokit-game-input-backend game-input-backend set-global
|
|||
|
||||
CONSTANT: game-devices-matching-seq
|
||||
{
|
||||
H{ { "DeviceUsage" 1 } { "DeviceUsagePage" 1 } } ! pointers
|
||||
H{ { "DeviceUsage" 2 } { "DeviceUsagePage" 1 } } ! mouses
|
||||
H{ { "DeviceUsage" 4 } { "DeviceUsagePage" 1 } } ! joysticks
|
||||
H{ { "DeviceUsage" 5 } { "DeviceUsagePage" 1 } } ! gamepads
|
||||
H{ { "DeviceUsage" 6 } { "DeviceUsagePage" 1 } } ! keyboards
|
||||
H{ { "DeviceUsage" 7 } { "DeviceUsagePage" 1 } } ! keypads
|
||||
H{ { "DeviceUsage" 8 } { "DeviceUsagePage" 1 } } ! multiaxis controllers
|
||||
}
|
||||
|
||||
CONSTANT: buttons-matching-hash
|
||||
|
@ -46,6 +50,8 @@ CONSTANT: rz-axis-matching-hash
|
|||
H{ { "UsagePage" 1 } { "Usage" HEX: 35 } { "Type" 1 } }
|
||||
CONSTANT: slider-matching-hash
|
||||
H{ { "UsagePage" 1 } { "Usage" HEX: 36 } { "Type" 1 } }
|
||||
CONSTANT: wheel-matching-hash
|
||||
H{ { "UsagePage" 1 } { "Usage" HEX: 38 } { "Type" 1 } }
|
||||
CONSTANT: hat-switch-matching-hash
|
||||
H{ { "UsagePage" 1 } { "Usage" HEX: 39 } { "Type" 1 } }
|
||||
|
||||
|
@ -90,10 +96,17 @@ CONSTANT: hat-switch-matching-hash
|
|||
: transfer-element-property ( element from-key to-key -- )
|
||||
[ dupd element-property ] dip swap set-element-property ;
|
||||
|
||||
: mouse-device? ( device -- ? )
|
||||
{
|
||||
[ 1 1 IOHIDDeviceConformsTo ]
|
||||
[ 1 2 IOHIDDeviceConformsTo ]
|
||||
} 1|| ;
|
||||
|
||||
: controller-device? ( device -- ? )
|
||||
{
|
||||
[ 1 4 IOHIDDeviceConformsTo ]
|
||||
[ 1 5 IOHIDDeviceConformsTo ]
|
||||
[ 1 8 IOHIDDeviceConformsTo ]
|
||||
} 1|| ;
|
||||
|
||||
: element-usage ( element -- {usage-page,usage} )
|
||||
|
@ -118,6 +131,8 @@ CONSTANT: hat-switch-matching-hash
|
|||
{ 1 HEX: 35 } = ; inline
|
||||
: slider? ( {usage-page,usage} -- ? )
|
||||
{ 1 HEX: 36 } = ; inline
|
||||
: wheel? ( {usage-page,usage} -- ? )
|
||||
{ 1 HEX: 38 } = ; inline
|
||||
: hat-switch? ( {usage-page,usage} -- ? )
|
||||
{ 1 HEX: 39 } = ; inline
|
||||
|
||||
|
@ -132,12 +147,17 @@ CONSTANT: pov-values
|
|||
IOHIDValueGetIntegerValue dup zero? [ drop f ] when ;
|
||||
: axis-value ( value -- [-1,1] )
|
||||
kIOHIDValueScaleTypeCalibrated IOHIDValueGetScaledValue ;
|
||||
: mouse-axis-value ( value -- n )
|
||||
IOHIDValueGetIntegerValue ;
|
||||
: pov-value ( value -- pov-direction )
|
||||
IOHIDValueGetIntegerValue pov-values ?nth [ pov-neutral ] unless* ;
|
||||
|
||||
: record-button ( hid-value usage state -- )
|
||||
[ button-value ] [ second 1- ] [ buttons>> ] tri* set-nth ;
|
||||
|
||||
: record-controller ( controller-state value -- )
|
||||
dup IOHIDValueGetElement element-usage {
|
||||
{ [ dup button? ] [ [ button-value ] [ second 1- ] bi* rot buttons>> set-nth ] }
|
||||
{ [ dup button? ] [ rot record-button ] }
|
||||
{ [ dup x-axis? ] [ drop axis-value >>x drop ] }
|
||||
{ [ dup y-axis? ] [ drop axis-value >>y drop ] }
|
||||
{ [ dup z-axis? ] [ drop axis-value >>z drop ] }
|
||||
|
@ -149,7 +169,7 @@ CONSTANT: pov-values
|
|||
[ 3drop ]
|
||||
} cond ;
|
||||
|
||||
SYMBOLS: +hid-manager+ +keyboard-state+ +controller-states+ ;
|
||||
SYMBOLS: +hid-manager+ +keyboard-state+ +mouse-state+ +controller-states+ ;
|
||||
|
||||
: ?set-nth ( value nth seq -- )
|
||||
2dup bounds-check? [ set-nth-unsafe ] [ 3drop ] if ;
|
||||
|
@ -161,6 +181,27 @@ SYMBOLS: +hid-manager+ +keyboard-state+ +controller-states+ ;
|
|||
+keyboard-state+ get ?set-nth
|
||||
] [ drop ] if ;
|
||||
|
||||
: record-mouse ( value -- )
|
||||
dup IOHIDValueGetElement element-usage {
|
||||
{ [ dup button? ] [ +mouse-state+ get record-button ] }
|
||||
{ [ dup x-axis? ] [ drop mouse-axis-value +mouse-state+ get [ + ] change-dx drop ] }
|
||||
{ [ dup y-axis? ] [ drop mouse-axis-value +mouse-state+ get [ + ] change-dy drop ] }
|
||||
{ [ dup wheel? ] [ drop mouse-axis-value +mouse-state+ get [ + ] change-scroll-dx drop ] }
|
||||
{ [ dup z-axis? ] [ drop mouse-axis-value +mouse-state+ get [ + ] change-scroll-dy drop ] }
|
||||
[ 2drop ]
|
||||
} cond ;
|
||||
|
||||
M: iokit-game-input-backend read-mouse
|
||||
+mouse-state+ get ;
|
||||
|
||||
M: iokit-game-input-backend reset-mouse
|
||||
+mouse-state+ get
|
||||
0 >>dx
|
||||
0 >>dy
|
||||
0 >>scroll-dx
|
||||
0 >>scroll-dy
|
||||
drop ;
|
||||
|
||||
: default-calibrate-saturation ( element -- )
|
||||
[ kIOHIDElementMinKey kIOHIDElementCalibrationSaturationMinKey transfer-element-property ]
|
||||
[ kIOHIDElementMaxKey kIOHIDElementCalibrationSaturationMaxKey transfer-element-property ]
|
||||
|
@ -194,12 +235,21 @@ SYMBOLS: +hid-manager+ +keyboard-state+ +controller-states+ ;
|
|||
[ button-count f <array> ]
|
||||
} cleave controller-state boa ;
|
||||
|
||||
: ?add-mouse-buttons ( device -- )
|
||||
button-count +mouse-state+ get buttons>>
|
||||
2dup length >
|
||||
[ set-length ] [ 2drop ] if ;
|
||||
|
||||
: device-matched-callback ( -- alien )
|
||||
[| context result sender device |
|
||||
device controller-device? [
|
||||
device <device-controller-state>
|
||||
device +controller-states+ get set-at
|
||||
] when
|
||||
{
|
||||
{ [ device controller-device? ] [
|
||||
device <device-controller-state>
|
||||
device +controller-states+ get set-at
|
||||
] }
|
||||
{ [ device mouse-device? ] [ device ?add-mouse-buttons ] }
|
||||
[ ]
|
||||
} cond
|
||||
] IOHIDDeviceCallback ;
|
||||
|
||||
: device-removed-callback ( -- alien )
|
||||
|
@ -209,15 +259,20 @@ SYMBOLS: +hid-manager+ +keyboard-state+ +controller-states+ ;
|
|||
|
||||
: device-input-callback ( -- alien )
|
||||
[| context result sender value |
|
||||
sender controller-device?
|
||||
[ sender +controller-states+ get at value record-controller ]
|
||||
[ value record-keyboard ]
|
||||
if
|
||||
{
|
||||
{ [ sender controller-device? ] [
|
||||
sender +controller-states+ get at value record-controller
|
||||
] }
|
||||
{ [ sender mouse-device? ] [ value record-mouse ] }
|
||||
[ value record-keyboard ]
|
||||
} cond
|
||||
] IOHIDValueCallback ;
|
||||
|
||||
: initialize-variables ( manager -- )
|
||||
+hid-manager+ set-global
|
||||
4 <vector> +controller-states+ set-global
|
||||
0 0 0 0 2 <vector> mouse-state boa
|
||||
+mouse-state+ set-global
|
||||
256 f <array> +keyboard-state+ set-global ;
|
||||
|
||||
M: iokit-game-input-backend (open-game-input)
|
||||
|
|
|
@ -5,23 +5,28 @@ opengl opengl.gl opengl.textures sequences strings ui ui.gadgets
|
|||
ui.gadgets.panes ui.render ui.images ;
|
||||
IN: images.viewer
|
||||
|
||||
TUPLE: image-gadget < gadget image-name ;
|
||||
TUPLE: image-gadget < gadget image texture ;
|
||||
|
||||
M: image-gadget pref-dim*
|
||||
image-name>> image-dim ;
|
||||
M: image-gadget pref-dim* image>> dim>> ;
|
||||
|
||||
: image-gadget-texture ( gadget -- texture )
|
||||
dup texture>> [ ] [ dup image>> { 0 0 } <texture> >>texture texture>> ] ?if ;
|
||||
|
||||
M: image-gadget draw-gadget* ( gadget -- )
|
||||
image-name>> draw-image ;
|
||||
[ dim>> ] [ image-gadget-texture ] bi draw-scaled-texture ;
|
||||
|
||||
: <image-gadget> ( image-name -- gadget )
|
||||
! Todo: delete texture on ungraft
|
||||
|
||||
GENERIC: <image-gadget> ( object -- gadget )
|
||||
|
||||
M: image <image-gadget>
|
||||
\ image-gadget new
|
||||
swap >>image-name ;
|
||||
swap >>image ;
|
||||
|
||||
: image-window ( path -- gadget )
|
||||
[ <image-name> <image-gadget> dup ] [ open-window ] bi ;
|
||||
M: string <image-gadget> load-image <image-gadget> ;
|
||||
|
||||
GENERIC: image. ( object -- )
|
||||
M: pathname <image-gadget> load-image <image-gadget> ;
|
||||
|
||||
M: string image. ( image -- ) <image-name> <image-gadget> gadget. ;
|
||||
: image-window ( object -- ) <image-gadget> "Image" open-window ;
|
||||
|
||||
M: pathname image. ( image -- ) <image-name> <image-gadget> gadget. ;
|
||||
: image. ( object -- ) <image-gadget> gadget. ;
|
||||
|
|
|
@ -0,0 +1,121 @@
|
|||
USING: byte-arrays combinators fry images kernel locals math
|
||||
math.affine-transforms math.functions math.order
|
||||
math.polynomials math.vectors random random.mersenne-twister
|
||||
sequences sequences.product ;
|
||||
IN: noise
|
||||
|
||||
: <perlin-noise-table> ( -- table )
|
||||
256 iota >byte-array randomize dup append ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: fade ( point -- point' )
|
||||
{ 0.0 0.0 0.0 10.0 -15.0 6.0 } swap [ polyval ] with map ;
|
||||
|
||||
:: grad ( hash gradients -- gradient )
|
||||
hash 8 bitand zero? [ gradients first ] [ gradients second ] if
|
||||
:> u
|
||||
hash 12 bitand zero?
|
||||
[ gradients second ]
|
||||
[ hash 13 bitand 12 = [ gradients first ] [ gradients third ] if ] if
|
||||
:> v
|
||||
|
||||
hash 1 bitand zero? [ u ] [ u neg ] if
|
||||
hash 2 bitand zero? [ v ] [ v neg ] if + ;
|
||||
|
||||
: unit-cube ( point -- cube )
|
||||
[ floor >fixnum 256 mod ] map ;
|
||||
|
||||
:: hashes ( table cube -- aaa baa aba bba aab bab abb bbb )
|
||||
cube first :> x
|
||||
cube second :> y
|
||||
cube third :> z
|
||||
x table nth y + :> a
|
||||
x 1 + table nth y + :> b
|
||||
|
||||
a table nth z + :> aa
|
||||
b table nth z + :> ba
|
||||
a 1 + table nth z + :> ab
|
||||
b 1 + table nth z + :> bb
|
||||
|
||||
aa table nth
|
||||
ba table nth
|
||||
ab table nth
|
||||
bb table nth
|
||||
aa 1 + table nth
|
||||
ba 1 + table nth
|
||||
ab 1 + table nth
|
||||
bb 1 + table nth ;
|
||||
|
||||
:: 2tetra@ ( p q r s t u v w quot -- )
|
||||
p q quot call
|
||||
r s quot call
|
||||
t u quot call
|
||||
v w quot call
|
||||
; inline
|
||||
|
||||
: with-seed ( seed quot -- )
|
||||
[ <mersenne-twister> ] dip with-random ; inline
|
||||
|
||||
: >byte-map ( floats -- bytes )
|
||||
[ 255.0 * >fixnum ] B{ } map-as ;
|
||||
|
||||
: >image ( bytes dim -- image )
|
||||
swap [ L f ] dip image boa ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
:: perlin-noise ( table point -- value )
|
||||
point unit-cube :> cube
|
||||
point dup vfloor v- :> gradients
|
||||
gradients fade :> faded
|
||||
|
||||
table cube hashes {
|
||||
[ gradients grad ]
|
||||
[ gradients { -1.0 0.0 0.0 } v+ grad ]
|
||||
[ gradients { 0.0 -1.0 0.0 } v+ grad ]
|
||||
[ gradients { -1.0 -1.0 0.0 } v+ grad ]
|
||||
[ gradients { 0.0 0.0 -1.0 } v+ grad ]
|
||||
[ gradients { -1.0 0.0 -1.0 } v+ grad ]
|
||||
[ gradients { 0.0 -1.0 -1.0 } v+ grad ]
|
||||
[ gradients { -1.0 -1.0 -1.0 } v+ grad ]
|
||||
} spread
|
||||
[ faded first lerp ] 2tetra@
|
||||
[ faded second lerp ] 2bi@
|
||||
faded third lerp ;
|
||||
|
||||
: normalize-0-1 ( sequence -- sequence' )
|
||||
[ supremum ] [ infimum [ - ] keep ] [ ] tri
|
||||
[ swap - ] with map [ swap / ] with map ;
|
||||
|
||||
: clamp-0-1 ( sequence -- sequence' )
|
||||
[ 0.0 max 1.0 min ] map ;
|
||||
|
||||
: perlin-noise-map ( table transform dim -- map )
|
||||
[ iota ] map [ a.v 0.0 suffix perlin-noise ] with with product-map ;
|
||||
|
||||
: perlin-noise-byte-map ( table transform dim -- map )
|
||||
perlin-noise-map normalize-0-1 >byte-map ;
|
||||
|
||||
: perlin-noise-image ( table transform dim -- image )
|
||||
[ perlin-noise-byte-map ] [ >image ] bi ;
|
||||
|
||||
: uniform-noise-map ( seed dim -- map )
|
||||
[ product [ 0.0 1.0 uniform-random-float ] replicate ]
|
||||
curry with-seed ;
|
||||
|
||||
: uniform-noise-byte-map ( seed dim -- map )
|
||||
uniform-noise-map >byte-map ;
|
||||
|
||||
: uniform-noise-image ( seed dim -- image )
|
||||
[ uniform-noise-byte-map ] [ >image ] bi ;
|
||||
|
||||
: normal-noise-map ( seed sigma dim -- map )
|
||||
swap '[ _ product [ 0.5 _ normal-random-float ] replicate ]
|
||||
with-seed ;
|
||||
|
||||
: normal-noise-byte-map ( seed sigma dim -- map )
|
||||
normal-noise-map clamp-0-1 >byte-map ;
|
||||
|
||||
: normal-noise-image ( seed sigma dim -- image )
|
||||
[ normal-noise-byte-map ] [ >image ] bi ;
|
|
@ -6,5 +6,5 @@ EXE_EXTENSION=.exe
|
|||
CONSOLE_EXTENSION=.com
|
||||
DLL_EXTENSION=.dll
|
||||
SHARED_DLL_EXTENSION=.dll
|
||||
LINKER = $(CC) -shared -mno-cygwin -o
|
||||
LINKER = $(CPP) -shared -mno-cygwin -o
|
||||
LINK_WITH_ENGINE = -l$(DLL_PREFIX)factor$(DLL_SUFFIX)
|
||||
|
|
|
@ -77,7 +77,7 @@ PRIMITIVE(alien_address)
|
|||
}
|
||||
|
||||
/* pop ( alien n ) from datastack, return alien's address plus n */
|
||||
static void *alien_pointer(void)
|
||||
static void *alien_pointer()
|
||||
{
|
||||
fixnum offset = to_fixnum(dpop());
|
||||
return unbox_alien() + offset;
|
||||
|
@ -128,7 +128,7 @@ PRIMITIVE(dlsym)
|
|||
gc_root<byte_array> name(dpop());
|
||||
name.untag_check();
|
||||
|
||||
vm_char *sym = (vm_char *)(name.untagged() + 1);
|
||||
symbol_char *sym = name->data<symbol_char>();
|
||||
|
||||
if(library.value() == F)
|
||||
box_alien(ffi_dlsym(NULL,sym));
|
||||
|
@ -182,7 +182,7 @@ VM_C_API char *alien_offset(cell obj)
|
|||
}
|
||||
|
||||
/* pop an object representing a C pointer */
|
||||
VM_C_API char *unbox_alien(void)
|
||||
VM_C_API char *unbox_alien()
|
||||
{
|
||||
return alien_offset(dpop());
|
||||
}
|
||||
|
|
|
@ -39,7 +39,7 @@ PRIMITIVE(dlclose);
|
|||
PRIMITIVE(dll_validp);
|
||||
|
||||
VM_C_API char *alien_offset(cell object);
|
||||
VM_C_API char *unbox_alien(void);
|
||||
VM_C_API char *unbox_alien();
|
||||
VM_C_API void box_alien(void *ptr);
|
||||
VM_C_API void to_value_struct(cell src, void *dest, cell size);
|
||||
VM_C_API void box_value_struct(void *src, cell size);
|
||||
|
|
|
@ -54,7 +54,7 @@ This means that if 'callstack' is called in tail position, we
|
|||
will have popped a necessary frame... however this word is only
|
||||
called by continuation implementation, and user code shouldn't
|
||||
be calling it at all, so we leave it as it is for now. */
|
||||
stack_frame *capture_start(void)
|
||||
stack_frame *capture_start()
|
||||
{
|
||||
stack_frame *frame = stack_chain->callstack_bottom - 1;
|
||||
while(frame >= stack_chain->callstack_top
|
||||
|
|
|
@ -8,6 +8,159 @@ void flush_icache_for(code_block *block)
|
|||
flush_icache((cell)block,block->size);
|
||||
}
|
||||
|
||||
static int number_of_parameters(relocation_type type)
|
||||
{
|
||||
switch(type)
|
||||
{
|
||||
case RT_PRIMITIVE:
|
||||
case RT_XT:
|
||||
case RT_XT_PIC:
|
||||
case RT_XT_PIC_TAIL:
|
||||
case RT_IMMEDIATE:
|
||||
case RT_HERE:
|
||||
case RT_UNTAGGED:
|
||||
return 1;
|
||||
case RT_DLSYM:
|
||||
return 2;
|
||||
case RT_THIS:
|
||||
case RT_STACK_CHAIN:
|
||||
case RT_MEGAMORPHIC_CACHE_HITS:
|
||||
return 0;
|
||||
default:
|
||||
critical_error("Bad rel type",type);
|
||||
return -1; /* Can't happen */
|
||||
}
|
||||
}
|
||||
|
||||
void *object_xt(cell obj)
|
||||
{
|
||||
switch(tagged<object>(obj).type())
|
||||
{
|
||||
case WORD_TYPE:
|
||||
return untag<word>(obj)->xt;
|
||||
case QUOTATION_TYPE:
|
||||
return untag<quotation>(obj)->xt;
|
||||
default:
|
||||
critical_error("Expected word or quotation",obj);
|
||||
return NULL;
|
||||
}
|
||||
}
|
||||
|
||||
static void *xt_pic(word *w, cell tagged_quot)
|
||||
{
|
||||
if(tagged_quot == F || max_pic_size == 0)
|
||||
return w->xt;
|
||||
else
|
||||
{
|
||||
quotation *quot = untag<quotation>(tagged_quot);
|
||||
if(quot->compiledp == F)
|
||||
return w->xt;
|
||||
else
|
||||
return quot->xt;
|
||||
}
|
||||
}
|
||||
|
||||
void *word_xt_pic(word *w)
|
||||
{
|
||||
return xt_pic(w,w->pic_def);
|
||||
}
|
||||
|
||||
void *word_xt_pic_tail(word *w)
|
||||
{
|
||||
return xt_pic(w,w->pic_tail_def);
|
||||
}
|
||||
|
||||
/* References to undefined symbols are patched up to call this function on
|
||||
image load */
|
||||
void undefined_symbol()
|
||||
{
|
||||
general_error(ERROR_UNDEFINED_SYMBOL,F,F,NULL);
|
||||
}
|
||||
|
||||
/* Look up an external library symbol referenced by a compiled code block */
|
||||
void *get_rel_symbol(array *literals, cell index)
|
||||
{
|
||||
cell symbol = array_nth(literals,index);
|
||||
cell library = array_nth(literals,index + 1);
|
||||
|
||||
dll *d = (library == F ? NULL : untag<dll>(library));
|
||||
|
||||
if(d != NULL && !d->dll)
|
||||
return (void *)undefined_symbol;
|
||||
|
||||
switch(tagged<object>(symbol).type())
|
||||
{
|
||||
case BYTE_ARRAY_TYPE:
|
||||
{
|
||||
symbol_char *name = alien_offset(symbol);
|
||||
void *sym = ffi_dlsym(d,name);
|
||||
|
||||
if(sym)
|
||||
return sym;
|
||||
else
|
||||
{
|
||||
return (void *)undefined_symbol;
|
||||
}
|
||||
}
|
||||
case ARRAY_TYPE:
|
||||
{
|
||||
cell i;
|
||||
array *names = untag<array>(symbol);
|
||||
for(i = 0; i < array_capacity(names); i++)
|
||||
{
|
||||
symbol_char *name = alien_offset(array_nth(names,i));
|
||||
void *sym = ffi_dlsym(d,name);
|
||||
|
||||
if(sym)
|
||||
return sym;
|
||||
}
|
||||
return (void *)undefined_symbol;
|
||||
}
|
||||
default:
|
||||
critical_error("Bad symbol specifier",symbol);
|
||||
return (void *)undefined_symbol;
|
||||
}
|
||||
}
|
||||
|
||||
cell compute_relocation(relocation_entry rel, cell index, code_block *compiled)
|
||||
{
|
||||
array *literals = untag<array>(compiled->literals);
|
||||
cell offset = REL_OFFSET(rel) + (cell)compiled->xt();
|
||||
|
||||
#define ARG array_nth(literals,index)
|
||||
|
||||
switch(REL_TYPE(rel))
|
||||
{
|
||||
case RT_PRIMITIVE:
|
||||
return (cell)primitives[untag_fixnum(ARG)];
|
||||
case RT_DLSYM:
|
||||
return (cell)get_rel_symbol(literals,index);
|
||||
case RT_IMMEDIATE:
|
||||
return ARG;
|
||||
case RT_XT:
|
||||
return (cell)object_xt(ARG);
|
||||
case RT_XT_PIC:
|
||||
return (cell)word_xt_pic(untag<word>(ARG));
|
||||
case RT_XT_PIC_TAIL:
|
||||
return (cell)word_xt_pic_tail(untag<word>(ARG));
|
||||
case RT_HERE:
|
||||
return offset + (short)untag_fixnum(ARG);
|
||||
case RT_THIS:
|
||||
return (cell)(compiled + 1);
|
||||
case RT_STACK_CHAIN:
|
||||
return (cell)&stack_chain;
|
||||
case RT_UNTAGGED:
|
||||
return untag_fixnum(ARG);
|
||||
case RT_MEGAMORPHIC_CACHE_HITS:
|
||||
return (cell)&megamorphic_cache_hits;
|
||||
default:
|
||||
critical_error("Bad rel type",rel);
|
||||
return 0; /* Can't happen */
|
||||
}
|
||||
|
||||
#undef ARG
|
||||
}
|
||||
|
||||
void iterate_relocations(code_block *compiled, relocation_iterator iter)
|
||||
{
|
||||
if(compiled->relocation != F)
|
||||
|
@ -20,29 +173,8 @@ void iterate_relocations(code_block *compiled, relocation_iterator iter)
|
|||
for(cell i = 0; i < length; i++)
|
||||
{
|
||||
relocation_entry rel = relocation->data<relocation_entry>()[i];
|
||||
|
||||
iter(rel,index,compiled);
|
||||
|
||||
switch(REL_TYPE(rel))
|
||||
{
|
||||
case RT_PRIMITIVE:
|
||||
case RT_XT:
|
||||
case RT_XT_DIRECT:
|
||||
case RT_IMMEDIATE:
|
||||
case RT_HERE:
|
||||
case RT_UNTAGGED:
|
||||
index++;
|
||||
break;
|
||||
case RT_DLSYM:
|
||||
index += 2;
|
||||
break;
|
||||
case RT_THIS:
|
||||
case RT_STACK_CHAIN:
|
||||
break;
|
||||
default:
|
||||
critical_error("Bad rel type",rel);
|
||||
return; /* Can't happen */
|
||||
}
|
||||
index += number_of_parameters(REL_TYPE(rel));
|
||||
}
|
||||
}
|
||||
}
|
||||
|
@ -84,6 +216,9 @@ void store_address_in_code_block(cell klass, cell offset, fixnum absolute_value)
|
|||
case RC_ABSOLUTE_PPC_2_2:
|
||||
store_address_2_2((cell *)offset,absolute_value);
|
||||
break;
|
||||
case RC_ABSOLUTE_PPC_2:
|
||||
store_address_masked((cell *)offset,absolute_value,REL_ABSOLUTE_PPC_2_MASK,0);
|
||||
break;
|
||||
case RC_RELATIVE_PPC_2:
|
||||
store_address_masked((cell *)offset,relative_value,REL_RELATIVE_PPC_2_MASK,0);
|
||||
break;
|
||||
|
@ -154,52 +289,24 @@ void copy_literal_references(code_block *compiled)
|
|||
}
|
||||
}
|
||||
|
||||
void *object_xt(cell obj)
|
||||
/* Compute an address to store at a relocation */
|
||||
void relocate_code_block_step(relocation_entry rel, cell index, code_block *compiled)
|
||||
{
|
||||
switch(tagged<object>(obj).type())
|
||||
{
|
||||
case WORD_TYPE:
|
||||
return untag<word>(obj)->xt;
|
||||
case QUOTATION_TYPE:
|
||||
return untag<quotation>(obj)->xt;
|
||||
default:
|
||||
critical_error("Expected word or quotation",obj);
|
||||
return NULL;
|
||||
}
|
||||
}
|
||||
#ifdef FACTOR_DEBUG
|
||||
tagged<array>(compiled->literals).untag_check();
|
||||
tagged<byte_array>(compiled->relocation).untag_check();
|
||||
#endif
|
||||
|
||||
void *word_direct_xt(word *w)
|
||||
{
|
||||
cell tagged_quot = w->direct_entry_def;
|
||||
if(tagged_quot == F || max_pic_size == 0)
|
||||
return w->xt;
|
||||
else
|
||||
{
|
||||
quotation *quot = untag<quotation>(tagged_quot);
|
||||
if(quot->compiledp == F)
|
||||
return w->xt;
|
||||
else
|
||||
return quot->xt;
|
||||
}
|
||||
store_address_in_code_block(REL_CLASS(rel),
|
||||
REL_OFFSET(rel) + (cell)compiled->xt(),
|
||||
compute_relocation(rel,index,compiled));
|
||||
}
|
||||
|
||||
void update_word_references_step(relocation_entry rel, cell index, code_block *compiled)
|
||||
{
|
||||
relocation_type type = REL_TYPE(rel);
|
||||
if(type == RT_XT || type == RT_XT_DIRECT)
|
||||
{
|
||||
cell offset = REL_OFFSET(rel) + (cell)(compiled + 1);
|
||||
array *literals = untag<array>(compiled->literals);
|
||||
cell obj = array_nth(literals,index);
|
||||
|
||||
void *xt;
|
||||
if(type == RT_XT)
|
||||
xt = object_xt(obj);
|
||||
else
|
||||
xt = word_direct_xt(untag<word>(obj));
|
||||
|
||||
store_address_in_code_block(REL_CLASS(rel),offset,(cell)xt);
|
||||
}
|
||||
if(type == RT_XT || type == RT_XT_PIC || type == RT_XT_PIC_TAIL)
|
||||
relocate_code_block_step(rel,index,compiled);
|
||||
}
|
||||
|
||||
/* Relocate new code blocks completely; updating references to literals,
|
||||
|
@ -300,108 +407,6 @@ void mark_object_code_block(object *object)
|
|||
}
|
||||
}
|
||||
|
||||
/* References to undefined symbols are patched up to call this function on
|
||||
image load */
|
||||
void undefined_symbol(void)
|
||||
{
|
||||
general_error(ERROR_UNDEFINED_SYMBOL,F,F,NULL);
|
||||
}
|
||||
|
||||
/* Look up an external library symbol referenced by a compiled code block */
|
||||
void *get_rel_symbol(array *literals, cell index)
|
||||
{
|
||||
cell symbol = array_nth(literals,index);
|
||||
cell library = array_nth(literals,index + 1);
|
||||
|
||||
dll *d = (library == F ? NULL : untag<dll>(library));
|
||||
|
||||
if(d != NULL && !d->dll)
|
||||
return (void *)undefined_symbol;
|
||||
|
||||
switch(tagged<object>(symbol).type())
|
||||
{
|
||||
case BYTE_ARRAY_TYPE:
|
||||
{
|
||||
symbol_char *name = alien_offset(symbol);
|
||||
void *sym = ffi_dlsym(d,name);
|
||||
|
||||
if(sym)
|
||||
return sym;
|
||||
else
|
||||
{
|
||||
printf("%s\n",name);
|
||||
return (void *)undefined_symbol;
|
||||
}
|
||||
}
|
||||
case ARRAY_TYPE:
|
||||
{
|
||||
cell i;
|
||||
array *names = untag<array>(symbol);
|
||||
for(i = 0; i < array_capacity(names); i++)
|
||||
{
|
||||
symbol_char *name = alien_offset(array_nth(names,i));
|
||||
void *sym = ffi_dlsym(d,name);
|
||||
|
||||
if(sym)
|
||||
return sym;
|
||||
}
|
||||
return (void *)undefined_symbol;
|
||||
}
|
||||
default:
|
||||
critical_error("Bad symbol specifier",symbol);
|
||||
return (void *)undefined_symbol;
|
||||
}
|
||||
}
|
||||
|
||||
/* Compute an address to store at a relocation */
|
||||
void relocate_code_block_step(relocation_entry rel, cell index, code_block *compiled)
|
||||
{
|
||||
#ifdef FACTOR_DEBUG
|
||||
tagged<array>(compiled->literals).untag_check();
|
||||
tagged<byte_array>(compiled->relocation).untag_check();
|
||||
#endif
|
||||
|
||||
cell offset = REL_OFFSET(rel) + (cell)(compiled + 1);
|
||||
array *literals = untag<array>(compiled->literals);
|
||||
fixnum absolute_value;
|
||||
|
||||
switch(REL_TYPE(rel))
|
||||
{
|
||||
case RT_PRIMITIVE:
|
||||
absolute_value = (cell)primitives[untag_fixnum(array_nth(literals,index))];
|
||||
break;
|
||||
case RT_DLSYM:
|
||||
absolute_value = (cell)get_rel_symbol(literals,index);
|
||||
break;
|
||||
case RT_IMMEDIATE:
|
||||
absolute_value = array_nth(literals,index);
|
||||
break;
|
||||
case RT_XT:
|
||||
absolute_value = (cell)object_xt(array_nth(literals,index));
|
||||
break;
|
||||
case RT_XT_DIRECT:
|
||||
absolute_value = (cell)word_direct_xt(untag<word>(array_nth(literals,index)));
|
||||
break;
|
||||
case RT_HERE:
|
||||
absolute_value = offset + (short)untag_fixnum(array_nth(literals,index));
|
||||
break;
|
||||
case RT_THIS:
|
||||
absolute_value = (cell)(compiled + 1);
|
||||
break;
|
||||
case RT_STACK_CHAIN:
|
||||
absolute_value = (cell)&stack_chain;
|
||||
break;
|
||||
case RT_UNTAGGED:
|
||||
absolute_value = untag_fixnum(array_nth(literals,index));
|
||||
break;
|
||||
default:
|
||||
critical_error("Bad rel type",rel);
|
||||
return; /* Can't happen */
|
||||
}
|
||||
|
||||
store_address_in_code_block(REL_CLASS(rel),offset,absolute_value);
|
||||
}
|
||||
|
||||
/* Perform all fixups on a code block */
|
||||
void relocate_code_block(code_block *compiled)
|
||||
{
|
||||
|
|
|
@ -8,10 +8,12 @@ enum relocation_type {
|
|||
RT_DLSYM,
|
||||
/* a pointer to a compiled word reference */
|
||||
RT_DISPATCH,
|
||||
/* a word's general entry point XT */
|
||||
/* a word or quotation's general entry point */
|
||||
RT_XT,
|
||||
/* a word's direct entry point XT */
|
||||
RT_XT_DIRECT,
|
||||
/* a word's PIC entry point */
|
||||
RT_XT_PIC,
|
||||
/* a word's tail-call PIC entry point */
|
||||
RT_XT_PIC_TAIL,
|
||||
/* current offset */
|
||||
RT_HERE,
|
||||
/* current code block */
|
||||
|
@ -22,6 +24,8 @@ enum relocation_type {
|
|||
RT_STACK_CHAIN,
|
||||
/* untagged fixnum literal */
|
||||
RT_UNTAGGED,
|
||||
/* address of megamorphic_cache_hits var */
|
||||
RT_MEGAMORPHIC_CACHE_HITS,
|
||||
};
|
||||
|
||||
enum relocation_class {
|
||||
|
@ -31,8 +35,10 @@ enum relocation_class {
|
|||
RC_ABSOLUTE,
|
||||
/* relative address in a 32-bit location */
|
||||
RC_RELATIVE,
|
||||
/* relative address in a PowerPC LIS/ORI sequence */
|
||||
/* absolute address in a PowerPC LIS/ORI sequence */
|
||||
RC_ABSOLUTE_PPC_2_2,
|
||||
/* absolute address in a PowerPC LWZ instruction */
|
||||
RC_ABSOLUTE_PPC_2,
|
||||
/* relative address in a PowerPC LWZ/STW/BC instruction */
|
||||
RC_RELATIVE_PPC_2,
|
||||
/* relative address in a PowerPC B/BL instruction */
|
||||
|
@ -45,6 +51,7 @@ enum relocation_class {
|
|||
RC_INDIRECT_ARM_PC
|
||||
};
|
||||
|
||||
#define REL_ABSOLUTE_PPC_2_MASK 0xffff
|
||||
#define REL_RELATIVE_PPC_2_MASK 0xfffc
|
||||
#define REL_RELATIVE_PPC_3_MASK 0x3fffffc
|
||||
#define REL_INDIRECT_ARM_MASK 0xfff
|
||||
|
@ -82,7 +89,7 @@ void mark_object_code_block(object *scan);
|
|||
|
||||
void relocate_code_block(code_block *relocating);
|
||||
|
||||
inline static bool stack_traces_p(void)
|
||||
inline static bool stack_traces_p()
|
||||
{
|
||||
return userenv[STACK_TRACES_ENV] != F;
|
||||
}
|
||||
|
|
|
@ -303,7 +303,7 @@ cell heap_size(heap *heap)
|
|||
}
|
||||
|
||||
/* Compute where each block is going to go, after compaction */
|
||||
cell compute_heap_forwarding(heap *heap, std::tr1::unordered_map<heap_block *,char *> &forwarding)
|
||||
cell compute_heap_forwarding(heap *heap, unordered_map<heap_block *,char *> &forwarding)
|
||||
{
|
||||
heap_block *scan = first_block(heap);
|
||||
char *address = (char *)first_block(heap);
|
||||
|
@ -324,7 +324,7 @@ cell heap_size(heap *heap)
|
|||
return (cell)address - heap->seg->start;
|
||||
}
|
||||
|
||||
void compact_heap(heap *heap, std::tr1::unordered_map<heap_block *,char *> &forwarding)
|
||||
void compact_heap(heap *heap, unordered_map<heap_block *,char *> &forwarding)
|
||||
{
|
||||
heap_block *scan = first_block(heap);
|
||||
|
||||
|
|
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue