Merge branch 'master' of git://factorcode.org/git/factor
commit
70469af0e2
|
@ -88,7 +88,7 @@ M: ##call generate-insn
|
|||
word>> dup sub-primitive>>
|
||||
[ first % ] [ [ add-call ] [ %call ] bi ] ?if ;
|
||||
|
||||
M: ##jump generate-insn word>> [ add-call ] [ %jump-label ] bi ;
|
||||
M: ##jump generate-insn word>> [ add-call ] [ %jump ] bi ;
|
||||
|
||||
M: ##return generate-insn drop %return ;
|
||||
|
||||
|
|
|
@ -56,8 +56,8 @@ 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-primitive ( word class -- )
|
||||
[ def>> first add-literal ] dip rt-primitive rel-fixup ;
|
||||
|
|
|
@ -42,7 +42,7 @@ CONSTANT: rt-primitive 0
|
|||
CONSTANT: rt-dlsym 1
|
||||
CONSTANT: rt-dispatch 2
|
||||
CONSTANT: rt-xt 3
|
||||
CONSTANT: rt-xt-direct 4
|
||||
CONSTANT: rt-xt-pic 4
|
||||
CONSTANT: rt-here 5
|
||||
CONSTANT: rt-this 6
|
||||
CONSTANT: rt-immediate 7
|
||||
|
|
|
@ -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 ( -- )
|
||||
|
||||
|
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: compiler.codegen.fixup kernel namespaces words
|
||||
io.binary math math.order cpu.ppc.assembler.backend ;
|
||||
USING: kernel namespaces words io.binary math math.order
|
||||
cpu.ppc.assembler.backend ;
|
||||
IN: cpu.ppc.assembler
|
||||
|
||||
! See the Motorola or IBM documentation for details. The opcode
|
||||
|
|
|
@ -1,8 +1,7 @@
|
|||
! 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 4 >be % ;
|
||||
|
@ -74,21 +73,16 @@ SYNTAX: XO1: (XO) (1) (( a s -- )) define-declared ;
|
|||
|
||||
GENERIC# (B) 2 ( dest aa lk -- )
|
||||
M: integer (B) 18 i-insn ;
|
||||
M: word (B) [ 0 ] 2dip (B) rc-relative-ppc-3 rel-word ;
|
||||
M: label (B) [ 0 ] 2dip (B) rc-relative-ppc-3 label-fixup ;
|
||||
|
||||
GENERIC: BC ( a b c -- )
|
||||
M: integer BC 0 0 16 b-insn ;
|
||||
M: word BC [ 0 BC ] dip rc-relative-ppc-2 rel-word ;
|
||||
M: label BC [ 0 BC ] dip rc-relative-ppc-2 label-fixup ;
|
||||
|
||||
: CREATE-B ( -- word ) scan "B" prepend create-in ;
|
||||
|
||||
SYNTAX: BC:
|
||||
CREATE-B scan-word scan-word
|
||||
[ rot BC ] 2curry (( c -- )) define-declared ;
|
||||
'[ [ _ _ ] dip BC ] (( c -- )) define-declared ;
|
||||
|
||||
SYNTAX: B:
|
||||
CREATE-B scan-word scan-word scan-word scan-word scan-word
|
||||
[ b-insn ] curry curry curry curry curry
|
||||
(( bo -- )) define-declared ;
|
||||
'[ _ _ _ _ _ b-insn ] (( bo -- )) define-declared ;
|
||||
|
|
|
@ -9,8 +9,8 @@ IN: bootstrap.ppc
|
|||
4 \ cell set
|
||||
big-endian on
|
||||
|
||||
CONSTANT: ds-reg 29
|
||||
CONSTANT: rs-reg 30
|
||||
CONSTANT: ds-reg 13
|
||||
CONSTANT: rs-reg 14
|
||||
|
||||
: factor-area-size ( -- n ) 4 bootstrap-cells ;
|
||||
|
||||
|
@ -58,7 +58,7 @@ CONSTANT: rs-reg 30
|
|||
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
|
||||
|
||||
|
@ -138,6 +138,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 +156,91 @@ 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
|
||||
! ... 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 +251,6 @@ CONSTANT: rs-reg 30
|
|||
BCTR
|
||||
] \ (call) define-sub-primitive
|
||||
|
||||
[
|
||||
3 ds-reg 0 LWZ
|
||||
ds-reg dup 4 SUBI
|
||||
4 3 word-xt-offset LWZ
|
||||
4 MTCTR
|
||||
BCTR
|
||||
] \ (execute) define-sub-primitive
|
||||
|
||||
! Objects
|
||||
[
|
||||
3 ds-reg 0 LWZ
|
||||
|
|
|
@ -1,33 +1,38 @@
|
|||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! Copyright (C) 2005, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors assocs sequences kernel combinators make math
|
||||
math.order math.ranges system namespaces locals layouts words
|
||||
alien alien.c-types cpu.architecture cpu.ppc.assembler
|
||||
compiler.cfg.registers compiler.cfg.instructions
|
||||
alien alien.c-types literals cpu.architecture cpu.ppc.assembler
|
||||
literals compiler.cfg.registers compiler.cfg.instructions
|
||||
compiler.constants compiler.codegen compiler.codegen.fixup
|
||||
compiler.cfg.intrinsics compiler.cfg.stack-frame ;
|
||||
IN: cpu.ppc
|
||||
|
||||
! PowerPC register assignments:
|
||||
! r2-r27: integer vregs
|
||||
! r28: integer scratch
|
||||
! r29: data stack
|
||||
! r30: retain stack
|
||||
! r2-r12: integer vregs
|
||||
! r15-r29
|
||||
! r30: integer scratch
|
||||
! f0-f29: float vregs
|
||||
! f30, f31: float scratch
|
||||
! f30: float scratch
|
||||
|
||||
! Add some methods to the assembler that are useful to us
|
||||
M: label (B) [ 0 ] 2dip (B) rc-relative-ppc-3 label-fixup ;
|
||||
M: label BC [ 0 BC ] dip rc-relative-ppc-2 label-fixup ;
|
||||
|
||||
enable-float-intrinsics
|
||||
|
||||
<< \ ##integer>float t frame-required? set-word-prop
|
||||
\ ##float>integer t frame-required? set-word-prop >>
|
||||
<<
|
||||
\ ##integer>float t frame-required? set-word-prop
|
||||
\ ##float>integer t frame-required? set-word-prop
|
||||
>>
|
||||
|
||||
M: ppc machine-registers
|
||||
{
|
||||
{ int-regs T{ range f 2 26 1 } }
|
||||
{ double-float-regs T{ range f 0 29 1 } }
|
||||
{ int-regs $[ 2 12 [a,b] 15 29 [a,b] append ] }
|
||||
{ double-float-regs $[ 0 29 [a,b] ] }
|
||||
} ;
|
||||
|
||||
CONSTANT: scratch-reg 28
|
||||
CONSTANT: scratch-reg 30
|
||||
CONSTANT: fp-scratch-reg 30
|
||||
|
||||
M: ppc two-operand? f ;
|
||||
|
@ -40,8 +45,8 @@ M: ppc %load-reference ( reg obj -- )
|
|||
M: ppc %alien-global ( register symbol dll -- )
|
||||
[ 0 swap LOAD32 ] 2dip rc-absolute-ppc-2/2 rel-dlsym ;
|
||||
|
||||
CONSTANT: ds-reg 29
|
||||
CONSTANT: rs-reg 30
|
||||
CONSTANT: ds-reg 13
|
||||
CONSTANT: rs-reg 14
|
||||
|
||||
GENERIC: loc-reg ( loc -- reg )
|
||||
|
||||
|
@ -108,7 +113,8 @@ 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 B rc-relative-ppc-3 rel-word ;
|
||||
M: ppc %jump-label ( label -- ) B ;
|
||||
M: ppc %return ( -- ) BLR ;
|
||||
|
||||
|
|
|
@ -44,9 +44,9 @@ M: x86.32 param-reg-2 EDX ;
|
|||
|
||||
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
|
||||
|
|
|
@ -29,7 +29,7 @@ IN: bootstrap.x86
|
|||
] jit-save-stack jit-define
|
||||
|
||||
[
|
||||
(JMP) drop rc-relative rt-primitive jit-rel
|
||||
0 JMP rc-relative rt-primitive jit-rel
|
||||
] jit-primitive jit-define
|
||||
|
||||
<< "vocab:cpu/x86/bootstrap.factor" parse-file parsed >>
|
||||
|
|
|
@ -1,12 +1,11 @@
|
|||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! Copyright (C) 2005, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays cpu.architecture compiler.constants
|
||||
compiler.codegen.fixup io.binary kernel combinators
|
||||
kernel.private math namespaces make sequences words system
|
||||
layouts math.order accessors cpu.x86.assembler.syntax ;
|
||||
USING: arrays io.binary kernel combinators
|
||||
kernel.private math namespaces make sequences words system layouts
|
||||
math.order accessors cpu.x86.assembler.syntax ;
|
||||
IN: cpu.x86.assembler
|
||||
|
||||
! A postfix assembler for x86 and AMD64.
|
||||
! A postfix assembler for x86-32 and x86-64.
|
||||
|
||||
! In 32-bit mode, { 1234 } is absolute indirect addressing.
|
||||
! In 64-bit mode, { 1234 } is RIP-relative.
|
||||
|
@ -296,36 +295,23 @@ M: operand (MOV-I)
|
|||
{ BIN: 000 t HEX: c6 }
|
||||
pick byte? [ immediate-1 ] [ immediate-4 ] if ;
|
||||
|
||||
PREDICATE: callable < word register? not ;
|
||||
|
||||
GENERIC: MOV ( dst src -- )
|
||||
M: immediate MOV swap (MOV-I) ;
|
||||
M: callable MOV [ 0 ] 2dip (MOV-I) rc-absolute-cell rel-word ;
|
||||
M: operand MOV HEX: 88 2-operand ;
|
||||
|
||||
: LEA ( dst src -- ) swap HEX: 8d 2-operand ;
|
||||
|
||||
! Control flow
|
||||
GENERIC: JMP ( op -- )
|
||||
: (JMP) ( -- rel-class ) HEX: e9 , 0 4, rc-relative ;
|
||||
M: f JMP (JMP) 2drop ;
|
||||
M: callable JMP (JMP) rel-word ;
|
||||
M: label JMP (JMP) label-fixup ;
|
||||
M: integer JMP HEX: e9 , 4, ;
|
||||
M: operand JMP { BIN: 100 t HEX: ff } 1-operand ;
|
||||
|
||||
GENERIC: CALL ( op -- )
|
||||
: (CALL) ( -- rel-class ) HEX: e8 , 0 4, rc-relative ;
|
||||
M: f CALL (CALL) 2drop ;
|
||||
M: callable CALL (CALL) rel-word-direct ;
|
||||
M: label CALL (CALL) label-fixup ;
|
||||
M: integer CALL HEX: e8 , 4, ;
|
||||
M: operand CALL { BIN: 010 t HEX: ff } 1-operand ;
|
||||
|
||||
GENERIC# JUMPcc 1 ( addr opcode -- )
|
||||
: (JUMPcc) ( addr n -- rel-class ) extended-opcode, 4, rc-relative ;
|
||||
M: f JUMPcc [ 0 ] dip (JUMPcc) 2drop ;
|
||||
M: integer JUMPcc (JUMPcc) drop ;
|
||||
M: callable JUMPcc [ 0 ] dip (JUMPcc) rel-word ;
|
||||
M: label JUMPcc [ 0 ] dip (JUMPcc) label-fixup ;
|
||||
M: integer JUMPcc extended-opcode, 4, ;
|
||||
|
||||
: JO ( dst -- ) HEX: 80 JUMPcc ;
|
||||
: JNO ( dst -- ) HEX: 81 JUMPcc ;
|
||||
|
|
|
@ -42,11 +42,11 @@ big-endian off
|
|||
] jit-push-immediate jit-define
|
||||
|
||||
[
|
||||
f JMP rc-relative rt-xt jit-rel
|
||||
0 JMP rc-relative rt-xt 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
|
||||
|
||||
[
|
||||
|
@ -57,12 +57,12 @@ 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
|
||||
0 JNE rc-relative rt-xt jit-rel
|
||||
] jit-if-1 jit-define
|
||||
|
||||
[
|
||||
! jump to false branch if equal
|
||||
f JMP rc-relative rt-xt jit-rel
|
||||
0 JMP rc-relative rt-xt jit-rel
|
||||
] jit-if-2 jit-define
|
||||
|
||||
: jit->r ( -- )
|
||||
|
@ -115,19 +115,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
|
||||
|
||||
|
@ -194,7 +194,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
|
||||
|
@ -211,7 +211,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
|
||||
|
||||
|
|
|
@ -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 )
|
||||
|
@ -53,8 +57,9 @@ 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 ;
|
||||
M: x86 %jump ( word -- ) 0 JMP rc-relative rel-word ;
|
||||
M: x86 %jump-label ( label -- ) 0 JMP rc-relative label-fixup ;
|
||||
M: x86 %return ( -- ) 0 RET ;
|
||||
|
||||
: code-alignment ( align -- n )
|
||||
|
|
|
@ -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.constants math.functions ;
|
||||
math.ranges math.constants math.functions accessors ;
|
||||
IN: random
|
||||
|
||||
SYMBOL: system-random-generator
|
||||
|
@ -70,8 +70,11 @@ PRIVATE>
|
|||
secure-random-generator get swap with-random ; inline
|
||||
|
||||
: uniform-random-float ( min max -- n )
|
||||
64 random-bits >float [ over - 2.0 -64 ^ * ] dip
|
||||
* + ;
|
||||
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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -1,11 +1,14 @@
|
|||
USING: byte-arrays combinators images kernel locals math math.affine-transforms
|
||||
math.functions math.polynomials math.vectors random sequences
|
||||
sequences.product ;
|
||||
IN: perlin-noise
|
||||
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
|
||||
|
||||
: <noise-table> ( -- table )
|
||||
: <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 ;
|
||||
|
||||
|
@ -51,7 +54,18 @@ IN: perlin-noise
|
|||
v w quot call
|
||||
; inline
|
||||
|
||||
:: noise ( table point -- value )
|
||||
: 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
|
||||
|
@ -70,14 +84,38 @@ IN: perlin-noise
|
|||
[ faded second lerp ] 2bi@
|
||||
faded third lerp ;
|
||||
|
||||
: noise-map ( table transform dim -- map )
|
||||
[ iota ] map [ a.v 0.0 suffix noise ] with with product-map ;
|
||||
|
||||
: normalize-0-1 ( sequence -- sequence' )
|
||||
[ supremum ] [ infimum [ - ] keep ] [ ] tri
|
||||
[ swap - ] with map [ swap / ] with map ;
|
||||
|
||||
: noise-image ( table transform dim -- image )
|
||||
[ noise-map normalize-0-1 [ 255.0 * >fixnum ] B{ } map-as ]
|
||||
[ swap [ L f ] dip image boa ] bi ;
|
||||
: 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 ;
|
76
vm/cpu-ppc.S
76
vm/cpu-ppc.S
|
@ -2,7 +2,7 @@
|
|||
in the public domain. */
|
||||
#include "asm.h"
|
||||
|
||||
#define DS_REG r29
|
||||
#define DS_REG r13
|
||||
|
||||
DEF(void,primitive_fixnum_add,(void)):
|
||||
lwz r3,0(DS_REG)
|
||||
|
@ -45,7 +45,7 @@ multiply_overflow:
|
|||
|
||||
/* Note that the XT is passed to the quotation in r11 */
|
||||
#define CALL_OR_JUMP_QUOT \
|
||||
lwz r11,14(r3) /* load quotation-xt slot */ XX \
|
||||
lwz r11,16(r3) /* load quotation-xt slot */ XX \
|
||||
|
||||
#define CALL_QUOT \
|
||||
CALL_OR_JUMP_QUOT XX \
|
||||
|
@ -100,22 +100,22 @@ the Factor compiler treats the entire register file as volatile. */
|
|||
DEF(void,c_to_factor,(CELL quot)):
|
||||
PROLOGUE
|
||||
|
||||
SAVE_INT(r13,0) /* save GPRs */
|
||||
SAVE_INT(r14,1)
|
||||
SAVE_INT(r15,2)
|
||||
SAVE_INT(r16,3)
|
||||
SAVE_INT(r17,4)
|
||||
SAVE_INT(r18,5)
|
||||
SAVE_INT(r19,6)
|
||||
SAVE_INT(r20,7)
|
||||
SAVE_INT(r21,8)
|
||||
SAVE_INT(r22,9)
|
||||
SAVE_INT(r23,10)
|
||||
SAVE_INT(r24,11)
|
||||
SAVE_INT(r25,12)
|
||||
SAVE_INT(r26,13)
|
||||
SAVE_INT(r27,14)
|
||||
SAVE_INT(r28,15)
|
||||
SAVE_INT(r15,0) /* save GPRs */
|
||||
SAVE_INT(r16,1)
|
||||
SAVE_INT(r17,2)
|
||||
SAVE_INT(r18,3)
|
||||
SAVE_INT(r19,4)
|
||||
SAVE_INT(r20,5)
|
||||
SAVE_INT(r21,6)
|
||||
SAVE_INT(r22,7)
|
||||
SAVE_INT(r23,8)
|
||||
SAVE_INT(r24,9)
|
||||
SAVE_INT(r25,10)
|
||||
SAVE_INT(r26,11)
|
||||
SAVE_INT(r27,12)
|
||||
SAVE_INT(r28,13)
|
||||
SAVE_INT(r29,14)
|
||||
SAVE_INT(r30,15)
|
||||
SAVE_INT(r31,16)
|
||||
|
||||
SAVE_FP(f14,20) /* save FPRs */
|
||||
|
@ -165,22 +165,22 @@ DEF(void,c_to_factor,(CELL quot)):
|
|||
RESTORE_FP(f14,20) /* save FPRs */
|
||||
|
||||
RESTORE_INT(r31,16) /* restore GPRs */
|
||||
RESTORE_INT(r28,15)
|
||||
RESTORE_INT(r27,14)
|
||||
RESTORE_INT(r26,13)
|
||||
RESTORE_INT(r25,12)
|
||||
RESTORE_INT(r24,11)
|
||||
RESTORE_INT(r23,10)
|
||||
RESTORE_INT(r22,9)
|
||||
RESTORE_INT(r21,8)
|
||||
RESTORE_INT(r20,7)
|
||||
RESTORE_INT(r19,6)
|
||||
RESTORE_INT(r18,5)
|
||||
RESTORE_INT(r17,4)
|
||||
RESTORE_INT(r16,3)
|
||||
RESTORE_INT(r15,2)
|
||||
RESTORE_INT(r14,1)
|
||||
RESTORE_INT(r13,0)
|
||||
RESTORE_INT(r30,15)
|
||||
RESTORE_INT(r29,14)
|
||||
RESTORE_INT(r28,13)
|
||||
RESTORE_INT(r27,12)
|
||||
RESTORE_INT(r26,11)
|
||||
RESTORE_INT(r25,10)
|
||||
RESTORE_INT(r24,9)
|
||||
RESTORE_INT(r23,8)
|
||||
RESTORE_INT(r22,7)
|
||||
RESTORE_INT(r21,6)
|
||||
RESTORE_INT(r20,5)
|
||||
RESTORE_INT(r19,4)
|
||||
RESTORE_INT(r18,3)
|
||||
RESTORE_INT(r17,2)
|
||||
RESTORE_INT(r16,1)
|
||||
RESTORE_INT(r15,0)
|
||||
|
||||
EPILOGUE
|
||||
blr
|
||||
|
@ -234,3 +234,11 @@ DEF(void,flush_icache,(void *start, int len)):
|
|||
sync /* finish up */
|
||||
isync
|
||||
blr
|
||||
|
||||
DEF(void,primitive_inline_cache_miss,(void)):
|
||||
mflr r3
|
||||
PROLOGUE
|
||||
bl MANGLE(inline_cache_miss)
|
||||
EPILOGUE
|
||||
mtctr r3
|
||||
bctr
|
||||
|
|
|
@ -2,16 +2,58 @@ namespace factor
|
|||
{
|
||||
|
||||
#define FACTOR_CPU_STRING "ppc"
|
||||
#define VM_ASM_API
|
||||
#define VM_ASM_API VM_C_API
|
||||
|
||||
register cell ds asm("r29");
|
||||
register cell rs asm("r30");
|
||||
register cell ds asm("r13");
|
||||
register cell rs asm("r14");
|
||||
|
||||
void c_to_factor(cell quot);
|
||||
void undefined(cell word);
|
||||
void set_callstack(stack_frame *to, stack_frame *from, cell length, void *memcpy);
|
||||
void throw_impl(cell quot, stack_frame *rewind);
|
||||
void lazy_jit_compile(cell quot);
|
||||
void flush_icache(cell start, cell len);
|
||||
inline static void check_call_site(cell return_address)
|
||||
{
|
||||
#ifdef FACTOR_DEBUG
|
||||
cell insn = *(cell *)return_address;
|
||||
assert((insn & 0x3) == 0x1);
|
||||
assert((insn >> 26) == 0x12);
|
||||
#endif
|
||||
}
|
||||
|
||||
#define B_MASK 0x3fffffc
|
||||
|
||||
inline static void *get_call_target(cell return_address)
|
||||
{
|
||||
return_address -= sizeof(cell);
|
||||
|
||||
check_call_site(return_address);
|
||||
cell insn = *(cell *)return_address;
|
||||
cell unsigned_addr = (insn & B_MASK);
|
||||
fixnum signed_addr = (fixnum)(unsigned_addr << 6) >> 6;
|
||||
return (void *)(signed_addr + return_address);
|
||||
}
|
||||
|
||||
inline static void set_call_target(cell return_address, void *target)
|
||||
{
|
||||
return_address -= sizeof(cell);
|
||||
|
||||
#ifdef FACTOR_DEBUG
|
||||
assert((return_address & ~B_MASK) == 0);
|
||||
check_call_site(return_address);
|
||||
#endif
|
||||
cell insn = *(cell *)return_address;
|
||||
insn = ((insn & ~B_MASK) | (((cell)target - return_address) & B_MASK));
|
||||
*(cell *)return_address = insn;
|
||||
|
||||
/* Flush the cache line containing the call we just patched */
|
||||
__asm__ __volatile__ ("icbi 0, %0\n" "sync\n"::"r" (return_address):);
|
||||
}
|
||||
|
||||
/* Defined in assembly */
|
||||
VM_ASM_API void c_to_factor(cell quot);
|
||||
VM_ASM_API void throw_impl(cell quot, stack_frame *rewind);
|
||||
VM_ASM_API void lazy_jit_compile(cell quot);
|
||||
VM_ASM_API void flush_icache(cell start, cell len);
|
||||
|
||||
VM_ASM_API void set_callstack(stack_frame *to,
|
||||
stack_frame *from,
|
||||
cell length,
|
||||
void *(*memcpy)(void*,const void*, size_t));
|
||||
|
||||
}
|
||||
|
|
|
@ -30,7 +30,6 @@ and the callstack top is passed in EDX */
|
|||
pop %ebx
|
||||
|
||||
#define QUOT_XT_OFFSET 16
|
||||
#define WORD_XT_OFFSET 30
|
||||
|
||||
/* We pass a function pointer to memcpy to work around a Mac OS X
|
||||
ABI limitation which would otherwise require us to do a bizzaro PC-relative
|
||||
|
|
|
@ -62,7 +62,6 @@
|
|||
#endif
|
||||
|
||||
#define QUOT_XT_OFFSET 36
|
||||
#define WORD_XT_OFFSET 66
|
||||
|
||||
/* We pass a function pointer to memcpy to work around a Mac OS X
|
||||
ABI limitation which would otherwise require us to do a bizzaro PC-relative
|
||||
|
|
|
@ -21,6 +21,8 @@ void deallocate_inline_cache(cell return_address)
|
|||
{
|
||||
/* Find the call target. */
|
||||
void *old_xt = get_call_target(return_address);
|
||||
check_code_pointer((cell)old_xt);
|
||||
|
||||
code_block *old_block = (code_block *)old_xt - 1;
|
||||
cell old_type = old_block->type;
|
||||
|
||||
|
|
Loading…
Reference in New Issue