steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'master' of git://factorcode.org/git/factor

db4
Aaron Schaefer 2009-05-07 16:44:15 -04:00
parent 766eb8b47e d0c34345b1
commit f0ceb33906
168 changed files with 1888 additions and 1004 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
README.txt
View File

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

8
basis/alien/c-types/c-types.factor
View File

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

2
basis/alien/libraries/libraries.factor Normal file → Executable file
View File

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

2
basis/bootstrap/compiler/compiler.factor Normal file → Executable file
View File

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

198
basis/bootstrap/image/image.factor
View File

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

1
basis/bootstrap/image/syntax/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

14
basis/bootstrap/image/syntax/syntax.factor Normal file
View File

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

2
basis/compiler/codegen/codegen.factor
View File

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

7
basis/compiler/codegen/fixup/fixup.factor
View File

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

54
basis/compiler/constants/constants.factor
View File

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

13
basis/compiler/tests/alien.factor
View File

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

8
basis/compiler/tests/optimizer.factor
View File

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

10
basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor
View File

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

8
basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor
View File

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

19
basis/compiler/tree/propagation/known-words/known-words.factor
View File

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

5
basis/compiler/tree/propagation/propagation-tests.factor
View File

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

1
basis/cpu/architecture/architecture.factor
View File

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

220
basis/cpu/ppc/assembler/assembler-tests.factor
View File

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

4
basis/cpu/ppc/assembler/assembler.factor
View File

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

18
basis/cpu/ppc/assembler/backend/backend.factor
View File

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

123
basis/cpu/ppc/bootstrap.factor
View File

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

42
basis/cpu/ppc/ppc.factor
View File

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

6
basis/cpu/x86/32/32.factor
View File

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

8
basis/cpu/x86/32/bootstrap.factor
View File

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

2
basis/cpu/x86/64/64.factor
View File

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

5
basis/cpu/x86/64/bootstrap.factor
View File

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

30
basis/cpu/x86/assembler/assembler.factor
View File

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

44
basis/cpu/x86/bootstrap.factor
View File

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

20
basis/cpu/x86/x86.factor
View File

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

69
basis/images/tiff/tiff.factor
View File

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

24
basis/literals/literals-docs.factor
View File

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

6
basis/literals/literals-tests.factor Normal file → Executable file
View File

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

19
basis/literals/literals.factor Normal file → Executable file
View File

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

2
basis/math/bits/bits.factor
View File

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

12
basis/math/bitwise/bitwise.factor
View File

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

2
basis/math/blas/vectors/vectors.factor
View File

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

1
basis/math/constants/constants.factor
View File

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

5
basis/math/functions/functions-tests.factor
View File

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

15
basis/math/functions/functions.factor
View File

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

12
basis/math/intervals/intervals.factor
View File

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

100
basis/math/miller-rabin/miller-rabin-docs.factor Normal file
View File

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

22
basis/math/miller-rabin/miller-rabin-tests.factor
View File

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

84
basis/math/miller-rabin/miller-rabin.factor
View File

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

6
basis/math/polynomials/polynomials.factor
View File

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

2
basis/math/ranges/ranges.factor
View File

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

6
basis/math/statistics/statistics.factor
View File

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

5
basis/math/vectors/vectors-tests.factor
View File

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

18
basis/math/vectors/vectors.factor
View File

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

16
basis/random/random.factor
View File

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

4
basis/specialized-arrays/specialized-arrays-tests.factor
View File

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

9
basis/tools/disassembler/udis/udis-tests.factor Normal file
View File

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

52
basis/tools/disassembler/udis/udis.factor
View File

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

2
basis/tools/time/time.factor
View File

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

30
basis/tools/trace/trace-tests.factor
View File

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

35
basis/tools/trace/trace.factor
View File

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

4
basis/ui/ui.factor
View File

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

12
basis/windows/dinput/dinput.factor
View File

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

21
core/alien/strings/strings.factor
View File

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

4
core/bootstrap/primitives.factor
View File

@ -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" (( -- )) }

2
core/continuations/continuations-tests.factor
View File

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

2
core/generic/hook/hook.factor
View File

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

2
core/generic/single/single-tests.factor
View File

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

8
core/generic/single/single.factor
View File

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

13
core/generic/standard/standard.factor
View File

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

4
core/hashtables/hashtables.factor
View File

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

5
core/io/io-docs.factor
View File

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

3
core/words/words.factor
View File

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

69
extra/game-input/dinput/dinput.factor
View File

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

29
extra/game-input/game-input-docs.factor
View File

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

9
extra/game-input/game-input.factor
View File

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

77
extra/game-input/iokit/iokit.factor
View File

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

27
extra/images/viewer/viewer.factor
View File

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

121
extra/noise/noise.factor Normal file
View File

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

0
extra/modules/remote-loading/authors.txt → unmaintained/modules/remote-loading/authors.txt
View File

0
extra/modules/remote-loading/remote-loading.factor → unmaintained/modules/remote-loading/remote-loading.factor
View File

0
extra/modules/remote-loading/summary.txt → unmaintained/modules/remote-loading/summary.txt
View File

0
extra/modules/rpc-server/authors.txt → unmaintained/modules/rpc-server/authors.txt
View File

0
extra/modules/rpc-server/rpc-server.factor → unmaintained/modules/rpc-server/rpc-server.factor
View File

0
extra/modules/rpc-server/summary.txt → unmaintained/modules/rpc-server/summary.txt
View File

0
extra/modules/rpc/authors.txt → unmaintained/modules/rpc/authors.txt
View File

0
extra/modules/rpc/rpc-docs.factor → unmaintained/modules/rpc/rpc-docs.factor
View File

0
extra/modules/rpc/rpc.factor → unmaintained/modules/rpc/rpc.factor
View File

0
extra/modules/rpc/summary.txt → unmaintained/modules/rpc/summary.txt
View File

0
extra/modules/uploads/authors.txt → unmaintained/modules/uploads/authors.txt
View File

0
extra/modules/uploads/summary.txt → unmaintained/modules/uploads/summary.txt
View File

0
extra/modules/uploads/uploads.factor → unmaintained/modules/uploads/uploads.factor
View File

0
extra/modules/using/authors.txt → unmaintained/modules/using/authors.txt
View File

0
extra/modules/using/summary.txt → unmaintained/modules/using/summary.txt
View File

0
extra/modules/using/tests/tags.txt → unmaintained/modules/using/tests/tags.txt
View File

0
extra/modules/using/tests/test-server.factor → unmaintained/modules/using/tests/test-server.factor
View File

0
extra/modules/using/tests/tests.factor → unmaintained/modules/using/tests/tests.factor
View File

0
extra/modules/using/using-docs.factor → unmaintained/modules/using/using-docs.factor
View File

0
extra/modules/using/using.factor → unmaintained/modules/using/using.factor
View File

2
vm/Config.windows
View File

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

6
vm/alien.cpp
View File

@ -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());
}

2
vm/alien.hpp
View File

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

2
vm/callstack.cpp
View File

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

331
vm/code_block.cpp Normal file → Executable file
View File

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

17
vm/code_block.hpp
View File

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

4
vm/code_gc.cpp
View File

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