Merge branch 'master' of git://factorcode.org/git/factor
Joe Groff
commit
5e5bddbe54
|
|
@ -55,10 +55,13 @@ For X11 support, you need recent development libraries for libc,
|
|||
Pango, X11, and OpenGL. On a Debian-derived Linux distribution
|
||||
(like Ubuntu), you can use the following line to grab everything:
|
||||
|
||||
sudo apt-get install libc6-dev libpango-1.0-dev libx11-dev
|
||||
sudo apt-get install libc6-dev libpango1.0-dev libx11-dev libgl1-mesa-dev
|
||||
|
||||
Note that if you are using a proprietary OpenGL driver, you should
|
||||
probably leave out the last package in the list.
|
||||
|
||||
If your DISPLAY environment variable is set, the UI will start
|
||||
automatically:
|
||||
automatically when you run Factor:
|
||||
|
||||
./factor
|
||||
|
||||
|
|
|
|||
|
|
@ -29,5 +29,6 @@ M: library dispose dll>> [ dispose ] when* ;
|
|||
: remove-library ( name -- )
|
||||
libraries get delete-at* [ dispose ] [ drop ] if ;
|
||||
|
||||
: add-library ( name path abi -- )
|
||||
<library> swap libraries get [ delete-at ] [ set-at ] 2bi ;
|
||||
: add-library ( name path abi -- )
|
||||
[ 2drop remove-library ]
|
||||
[ <library> swap libraries get set-at ] 3bi ;
|
||||
|
|
@ -10,6 +10,10 @@ math.order quotations quotations.private assocs.private ;
|
|||
FROM: compiler => enable-optimizer ;
|
||||
IN: bootstrap.compiler
|
||||
|
||||
"profile-compiler" get [
|
||||
"bootstrap.compiler.timing" require
|
||||
] when
|
||||
|
||||
! Don't bring this in when deploying, since it will store a
|
||||
! reference to 'eval' in a global variable
|
||||
"deploy-vocab" get "staging" get or [
|
||||
|
|
|
|||
|
|
@ -0,0 +1,38 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors compiler.cfg.builder compiler.cfg.linear-scan
|
||||
compiler.cfg.liveness compiler.cfg.mr compiler.cfg.optimizer
|
||||
compiler.cfg.stacks.finalize compiler.cfg.stacks.global
|
||||
compiler.codegen compiler.tree.builder compiler.tree.optimizer
|
||||
kernel make sequences tools.annotations tools.crossref ;
|
||||
IN: bootstrap.compiler.timing
|
||||
|
||||
: passes ( word -- seq )
|
||||
def>> uses [ vocabulary>> "compiler." head? ] filter ;
|
||||
|
||||
: high-level-passes ( -- seq ) \ optimize-tree passes ;
|
||||
|
||||
: low-level-passes ( -- seq ) \ optimize-cfg passes ;
|
||||
|
||||
: machine-passes ( -- seq ) \ build-mr passes ;
|
||||
|
||||
: linear-scan-passes ( -- seq ) \ (linear-scan) passes ;
|
||||
|
||||
: all-passes ( -- seq )
|
||||
[
|
||||
\ build-tree ,
|
||||
\ optimize-tree ,
|
||||
high-level-passes %
|
||||
\ build-cfg ,
|
||||
\ compute-global-sets ,
|
||||
\ finalize-stack-shuffling ,
|
||||
\ optimize-cfg ,
|
||||
low-level-passes %
|
||||
\ compute-live-sets ,
|
||||
\ build-mr ,
|
||||
machine-passes %
|
||||
linear-scan-passes %
|
||||
\ generate ,
|
||||
] { } make ;
|
||||
|
||||
all-passes [ [ reset ] [ add-timing ] bi ] each
|
||||
|
|
@ -0,0 +1,26 @@
|
|||
IN: compiler.cfg.gc-checks.tests
|
||||
USING: compiler.cfg.gc-checks compiler.cfg.debugger
|
||||
compiler.cfg.registers compiler.cfg.instructions compiler.cfg
|
||||
compiler.cfg.predecessors cpu.architecture tools.test kernel vectors
|
||||
namespaces accessors sequences ;
|
||||
|
||||
: test-gc-checks ( -- )
|
||||
cfg new 0 get >>entry
|
||||
compute-predecessors
|
||||
insert-gc-checks
|
||||
drop ;
|
||||
|
||||
V{
|
||||
T{ ##inc-d f 3 }
|
||||
T{ ##replace f V int-regs 0 D 1 }
|
||||
} 0 test-bb
|
||||
|
||||
V{
|
||||
T{ ##box-float f V int-regs 0 V int-regs 1 }
|
||||
} 1 test-bb
|
||||
|
||||
0 get 1 get 1vector >>successors drop
|
||||
|
||||
[ ] [ test-gc-checks ] unit-test
|
||||
|
||||
[ V{ D 0 D 2 } ] [ 1 get instructions>> first uninitialized-locs>> ] unit-test
|
||||
|
|
@ -1,17 +1,27 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel sequences assocs
|
||||
compiler.cfg.rpo compiler.cfg.instructions
|
||||
compiler.cfg.hats ;
|
||||
USING: accessors kernel sequences assocs fry
|
||||
compiler.cfg.rpo
|
||||
compiler.cfg.hats
|
||||
compiler.cfg.registers
|
||||
compiler.cfg.instructions
|
||||
compiler.cfg.stacks.uninitialized ;
|
||||
IN: compiler.cfg.gc-checks
|
||||
|
||||
: gc? ( bb -- ? )
|
||||
: insert-gc-check? ( bb -- ? )
|
||||
instructions>> [ ##allocation? ] any? ;
|
||||
|
||||
: insert-gc-check ( basic-block -- )
|
||||
dup gc? [
|
||||
[ i i f \ ##gc new-insn prefix ] change-instructions drop
|
||||
] [ drop ] if ;
|
||||
: blocks-with-gc ( cfg -- bbs )
|
||||
post-order [ insert-gc-check? ] filter ;
|
||||
|
||||
: insert-gc-check ( bb -- )
|
||||
dup '[
|
||||
i i f _ uninitialized-locs \ ##gc new-insn
|
||||
prefix
|
||||
] change-instructions drop ;
|
||||
|
||||
: insert-gc-checks ( cfg -- cfg' )
|
||||
dup [ insert-gc-check ] each-basic-block ;
|
||||
dup blocks-with-gc [
|
||||
over compute-uninitialized-sets
|
||||
[ insert-gc-check ] each
|
||||
] unless-empty ;
|
||||
|
|
@ -190,7 +190,7 @@ INSN: ##fixnum-add < ##fixnum-overflow ;
|
|||
INSN: ##fixnum-sub < ##fixnum-overflow ;
|
||||
INSN: ##fixnum-mul < ##fixnum-overflow ;
|
||||
|
||||
INSN: ##gc temp1 temp2 live-values ;
|
||||
INSN: ##gc temp1 temp2 live-values uninitialized-locs ;
|
||||
|
||||
! Instructions used by machine IR only.
|
||||
INSN: _prologue stack-frame ;
|
||||
|
|
@ -219,7 +219,7 @@ INSN: _fixnum-mul < _fixnum-overflow ;
|
|||
|
||||
TUPLE: spill-slot n ; C: <spill-slot> spill-slot
|
||||
|
||||
INSN: _gc temp1 temp2 gc-roots gc-root-count gc-root-size ;
|
||||
INSN: _gc temp1 temp2 gc-roots gc-root-count gc-root-size uninitialized-locs ;
|
||||
|
||||
! These instructions operate on machine registers and not
|
||||
! virtual registers
|
||||
|
|
|
|||
|
|
@ -48,11 +48,11 @@ IN: compiler.cfg.intrinsics
|
|||
slots.private:set-slot
|
||||
strings.private:string-nth
|
||||
strings.private:set-string-nth-fast
|
||||
! classes.tuple.private:<tuple-boa>
|
||||
! arrays:<array>
|
||||
! byte-arrays:<byte-array>
|
||||
! byte-arrays:(byte-array)
|
||||
! kernel:<wrapper>
|
||||
classes.tuple.private:<tuple-boa>
|
||||
arrays:<array>
|
||||
byte-arrays:<byte-array>
|
||||
byte-arrays:(byte-array)
|
||||
kernel:<wrapper>
|
||||
alien.accessors:alien-unsigned-1
|
||||
alien.accessors:set-alien-unsigned-1
|
||||
alien.accessors:alien-signed-1
|
||||
|
|
@ -61,7 +61,7 @@ IN: compiler.cfg.intrinsics
|
|||
alien.accessors:set-alien-unsigned-2
|
||||
alien.accessors:alien-signed-2
|
||||
alien.accessors:set-alien-signed-2
|
||||
! alien.accessors:alien-cell
|
||||
alien.accessors:alien-cell
|
||||
alien.accessors:set-alien-cell
|
||||
} [ t "intrinsic" set-word-prop ] each
|
||||
|
||||
|
|
@ -90,7 +90,7 @@ IN: compiler.cfg.intrinsics
|
|||
alien.accessors:set-alien-float
|
||||
alien.accessors:alien-double
|
||||
alien.accessors:set-alien-double
|
||||
} drop f [ t "intrinsic" set-word-prop ] each ;
|
||||
} [ t "intrinsic" set-word-prop ] each ;
|
||||
|
||||
: enable-fixnum-log2 ( -- )
|
||||
\ math.integers.private:fixnum-log2 t "intrinsic" set-word-prop ;
|
||||
|
|
|
|||
|
|
@ -98,15 +98,18 @@ M: ##dispatch linearize-insn
|
|||
|
||||
M: ##gc linearize-insn
|
||||
nip
|
||||
[ temp1>> ]
|
||||
[ temp2>> ]
|
||||
[
|
||||
live-values>>
|
||||
[ compute-gc-roots ]
|
||||
[ count-gc-roots ]
|
||||
[ gc-roots-size ]
|
||||
tri
|
||||
] tri
|
||||
{
|
||||
[ temp1>> ]
|
||||
[ temp2>> ]
|
||||
[
|
||||
live-values>>
|
||||
[ compute-gc-roots ]
|
||||
[ count-gc-roots ]
|
||||
[ gc-roots-size ]
|
||||
tri
|
||||
]
|
||||
[ uninitialized-locs>> ]
|
||||
} cleave
|
||||
_gc ;
|
||||
|
||||
: linearize-basic-blocks ( cfg -- insns )
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors assocs hashtables fry kernel make namespaces
|
||||
USING: accessors assocs hashtables fry kernel make namespaces sets
|
||||
sequences compiler.cfg.ssa.destruction.state compiler.cfg.parallel-copy ;
|
||||
IN: compiler.cfg.ssa.destruction.copies
|
||||
|
||||
|
|
@ -9,7 +9,7 @@ ERROR: bad-copy ;
|
|||
: compute-copies ( assoc -- assoc' )
|
||||
dup assoc-size <hashtable> [
|
||||
'[
|
||||
[
|
||||
prune [
|
||||
2dup eq? [ 2drop ] [
|
||||
_ 2dup key?
|
||||
[ bad-copy ] [ set-at ] if
|
||||
|
|
|
|||
|
|
@ -29,7 +29,7 @@ SYMBOL: seen
|
|||
|
||||
:: visit-renaming ( dst assoc src bb -- )
|
||||
src seen get key? [
|
||||
src dst bb waiting-for push-at
|
||||
src dst bb add-waiting
|
||||
src assoc delete-at
|
||||
] [ src seen get conjoin ] if ;
|
||||
|
||||
|
|
|
|||
|
|
@ -46,7 +46,7 @@ SYMBOLS: phi-union unioned-blocks ;
|
|||
2nip processed-name ;
|
||||
|
||||
:: trivial-interference ( bb src dst -- )
|
||||
dst src bb waiting-for push-at
|
||||
dst src bb add-waiting
|
||||
src used-by-another get push ;
|
||||
|
||||
:: add-to-renaming-set ( bb src dst -- )
|
||||
|
|
|
|||
|
|
@ -14,3 +14,5 @@ SYMBOLS: processed-names waiting used-by-another renaming-sets ;
|
|||
: processed-name ( vreg -- ) processed-names get conjoin ;
|
||||
|
||||
: waiting-for ( bb -- assoc ) waiting get [ drop H{ } clone ] cache ;
|
||||
|
||||
: add-waiting ( dst src bb -- ) waiting-for push-at ;
|
||||
|
|
@ -0,0 +1,61 @@
|
|||
IN: compiler.cfg.stacks.uninitialized.tests
|
||||
USING: compiler.cfg.stacks.uninitialized compiler.cfg.debugger
|
||||
compiler.cfg.registers compiler.cfg.instructions compiler.cfg
|
||||
compiler.cfg.predecessors cpu.architecture tools.test kernel vectors
|
||||
namespaces accessors sequences ;
|
||||
|
||||
: test-uninitialized ( -- )
|
||||
cfg new 0 get >>entry
|
||||
compute-predecessors
|
||||
compute-uninitialized-sets ;
|
||||
|
||||
V{
|
||||
T{ ##inc-d f 3 }
|
||||
} 0 test-bb
|
||||
|
||||
V{
|
||||
T{ ##replace f V int-regs 0 D 0 }
|
||||
T{ ##replace f V int-regs 0 D 1 }
|
||||
T{ ##replace f V int-regs 0 D 2 }
|
||||
T{ ##inc-r f 1 }
|
||||
} 1 test-bb
|
||||
|
||||
V{
|
||||
T{ ##peek f V int-regs 0 D 0 }
|
||||
T{ ##inc-d f 1 }
|
||||
} 2 test-bb
|
||||
|
||||
0 get 1 get 1vector >>successors drop
|
||||
1 get 2 get 1vector >>successors drop
|
||||
|
||||
[ ] [ test-uninitialized ] unit-test
|
||||
|
||||
[ V{ D 0 D 1 D 2 } ] [ 1 get uninitialized-locs ] unit-test
|
||||
[ V{ R 0 } ] [ 2 get uninitialized-locs ] unit-test
|
||||
|
||||
! When merging, if a location is uninitialized in one branch and
|
||||
! initialized in another, we have to consider it uninitialized,
|
||||
! since it cannot be safely read from by a ##peek, or traced by GC.
|
||||
|
||||
V{ } 0 test-bb
|
||||
|
||||
V{
|
||||
T{ ##inc-d f 1 }
|
||||
} 1 test-bb
|
||||
|
||||
V{
|
||||
T{ ##call f namestack }
|
||||
T{ ##branch }
|
||||
} 2 test-bb
|
||||
|
||||
V{
|
||||
T{ ##return }
|
||||
} 3 test-bb
|
||||
|
||||
0 get 1 get 2 get V{ } 2sequence >>successors drop
|
||||
1 get 3 get 1vector >>successors drop
|
||||
2 get 3 get 1vector >>successors drop
|
||||
|
||||
[ ] [ test-uninitialized ] unit-test
|
||||
|
||||
[ V{ D 0 } ] [ 3 get uninitialized-locs ] unit-test
|
||||
|
|
@ -0,0 +1,76 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel sequences byte-arrays namespaces accessors classes math
|
||||
math.order fry arrays combinators compiler.cfg.registers
|
||||
compiler.cfg.instructions compiler.cfg.dataflow-analysis ;
|
||||
IN: compiler.cfg.stacks.uninitialized
|
||||
|
||||
! Uninitialized stack location analysis.
|
||||
|
||||
! Consider the following sequence of instructions:
|
||||
! ##inc-d 2
|
||||
! _gc
|
||||
! ##replace ... D 0
|
||||
! ##replace ... D 1
|
||||
! The GC check runs before stack locations 0 and 1 have been initialized,
|
||||
! and it needs to zero them out so that GC doesn't try to trace them.
|
||||
|
||||
<PRIVATE
|
||||
|
||||
GENERIC: visit-insn ( insn -- )
|
||||
|
||||
: handle-inc ( n symbol -- )
|
||||
[
|
||||
swap {
|
||||
{ [ dup 0 < ] [ neg short tail ] }
|
||||
{ [ dup 0 > ] [ <byte-array> prepend ] }
|
||||
} cond
|
||||
] change ;
|
||||
|
||||
M: ##inc-d visit-insn n>> ds-loc handle-inc ;
|
||||
|
||||
M: ##inc-r visit-insn n>> rs-loc handle-inc ;
|
||||
|
||||
ERROR: uninitialized-peek insn ;
|
||||
|
||||
M: ##peek visit-insn
|
||||
dup loc>> [ n>> ] [ class get ] bi ?nth 0 =
|
||||
[ uninitialized-peek ] [ drop ] if ;
|
||||
|
||||
M: ##replace visit-insn
|
||||
loc>> [ n>> ] [ class get ] bi
|
||||
2dup length < [ [ 1 ] 2dip set-nth ] [ 2drop ] if ;
|
||||
|
||||
M: insn visit-insn drop ;
|
||||
|
||||
: prepare ( pair -- )
|
||||
[ first2 [ [ clone ] [ B{ } ] if* ] bi@ ] [ B{ } B{ } ] if*
|
||||
[ ds-loc set ] [ rs-loc set ] bi* ;
|
||||
|
||||
: visit-block ( bb -- ) instructions>> [ visit-insn ] each ;
|
||||
|
||||
: finish ( -- pair ) ds-loc get rs-loc get 2array ;
|
||||
|
||||
: (join-sets) ( seq1 seq2 -- seq )
|
||||
2dup [ length ] bi@ max '[ _ 1 pad-tail ] bi@ [ min ] 2map ;
|
||||
|
||||
: (uninitialized-locs) ( seq quot -- seq' )
|
||||
[ dup length [ drop 0 = ] pusher [ 2each ] dip ] dip map ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
FORWARD-ANALYSIS: uninitialized
|
||||
|
||||
M: uninitialized-analysis transfer-set ( pair bb analysis -- pair' )
|
||||
drop [ prepare ] dip visit-block finish ;
|
||||
|
||||
M: uninitialized-analysis join-sets ( sets analysis -- pair )
|
||||
drop sift [ f ] [ [ ] [ [ (join-sets) ] 2map ] map-reduce ] if-empty ;
|
||||
|
||||
: uninitialized-locs ( bb -- locs )
|
||||
uninitialized-in dup [
|
||||
first2
|
||||
[ [ <ds-loc> ] (uninitialized-locs) ]
|
||||
[ [ <rs-loc> ] (uninitialized-locs) ]
|
||||
bi* append
|
||||
] when ;
|
||||
|
|
@ -4,7 +4,7 @@ USING: namespaces make math math.order math.parser sequences accessors
|
|||
kernel kernel.private layouts assocs words summary arrays
|
||||
combinators classes.algebra alien alien.c-types alien.structs
|
||||
alien.strings alien.arrays alien.complex alien.libraries sets libc
|
||||
continuations.private fry cpu.architecture classes
|
||||
continuations.private fry cpu.architecture classes locals
|
||||
source-files.errors
|
||||
compiler.errors
|
||||
compiler.alien
|
||||
|
|
@ -215,13 +215,44 @@ M: ##write-barrier generate-insn
|
|||
[ table>> ]
|
||||
tri %write-barrier ;
|
||||
|
||||
! GC checks
|
||||
: wipe-locs ( locs temp -- )
|
||||
'[
|
||||
_
|
||||
[ 0 %load-immediate ]
|
||||
[ swap [ %replace ] with each ] bi
|
||||
] unless-empty ;
|
||||
|
||||
GENERIC# save-gc-root 1 ( gc-root operand temp -- )
|
||||
|
||||
M:: spill-slot save-gc-root ( gc-root operand temp -- )
|
||||
temp operand n>> %reload-integer
|
||||
gc-root temp %save-gc-root ;
|
||||
|
||||
M: object save-gc-root drop %save-gc-root ;
|
||||
|
||||
: save-gc-roots ( gc-roots temp -- ) '[ _ save-gc-root ] assoc-each ;
|
||||
|
||||
GENERIC# load-gc-root 1 ( gc-root operand temp -- )
|
||||
|
||||
M:: spill-slot load-gc-root ( gc-root operand temp -- )
|
||||
gc-root temp %load-gc-root
|
||||
temp operand n>> %spill-integer ;
|
||||
|
||||
M: object load-gc-root drop %load-gc-root ;
|
||||
|
||||
: load-gc-roots ( gc-roots temp -- ) '[ _ load-gc-root ] assoc-each ;
|
||||
|
||||
M: _gc generate-insn
|
||||
"no-gc" define-label
|
||||
{
|
||||
[ temp1>> ]
|
||||
[ temp2>> ]
|
||||
[ gc-roots>> ]
|
||||
[ gc-root-count>> ]
|
||||
} cleave %gc ;
|
||||
[ [ "no-gc" get ] dip [ temp1>> ] [ temp2>> ] bi %check-nursery ]
|
||||
[ [ uninitialized-locs>> ] [ temp1>> ] bi wipe-locs ]
|
||||
[ [ gc-roots>> ] [ temp1>> ] bi save-gc-roots ]
|
||||
[ gc-root-count>> %call-gc ]
|
||||
[ [ gc-roots>> ] [ temp1>> ] bi load-gc-roots ]
|
||||
} cleave
|
||||
"no-gc" resolve-label ;
|
||||
|
||||
M: _loop-entry generate-insn drop %loop-entry ;
|
||||
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@ USING: generalizations accessors arrays compiler kernel kernel.private
|
|||
math hashtables.private math.private namespaces sequences tools.test
|
||||
namespaces.private slots.private sequences.private byte-arrays alien
|
||||
alien.accessors layouts words definitions compiler.units io
|
||||
combinators vectors grouping make alien.c-types ;
|
||||
combinators vectors grouping make alien.c-types combinators.short-circuit ;
|
||||
QUALIFIED: namespaces.private
|
||||
IN: compiler.tests.codegen
|
||||
|
||||
|
|
@ -345,4 +345,17 @@ cell 4 = [
|
|||
dup [ \ vector eq? ] [ drop f ] if
|
||||
over rot [ drop ] [ nip ] if
|
||||
] compile-call
|
||||
] unit-test
|
||||
] unit-test
|
||||
|
||||
! Coalesing bug reduced from sequence-parser:take-sequence
|
||||
: coalescing-bug-1 ( str a b c -- a b c d )
|
||||
3dup {
|
||||
[ 2drop 0 < ]
|
||||
[ [ drop ] 2dip length > ]
|
||||
[ drop > ]
|
||||
} 3|| [ 3drop f ] [ slice boa ] if swap [ [ length ] bi@ ] 2keep ;
|
||||
|
||||
[ 0 3 f { 1 2 3 } ] [ { 1 2 3 } -10 3 "hello" coalescing-bug-1 ] unit-test
|
||||
[ 0 3 f { 1 2 3 } ] [ { 1 2 3 } 0 5 "hello" coalescing-bug-1 ] unit-test
|
||||
[ 0 3 f { 1 2 3 } ] [ { 1 2 3 } 3 2 "hello" coalescing-bug-1 ] unit-test
|
||||
[ 2 3 T{ slice f "hello" 1 3 } { 1 2 3 } ] [ { 1 2 3 } 1 3 "hello" coalescing-bug-1 ] unit-test
|
||||
|
|
@ -128,7 +128,12 @@ HOOK: %alien-global cpu ( dst symbol library -- )
|
|||
|
||||
HOOK: %allot cpu ( dst size class temp -- )
|
||||
HOOK: %write-barrier cpu ( src card# table -- )
|
||||
HOOK: %gc cpu ( temp1 temp2 live-registers live-spill-slots -- )
|
||||
|
||||
! GC checks
|
||||
HOOK: %check-nursery cpu ( label temp1 temp2 -- )
|
||||
HOOK: %save-gc-root cpu ( gc-root register -- )
|
||||
HOOK: %load-gc-root cpu ( gc-root register -- )
|
||||
HOOK: %call-gc cpu ( gc-root-count -- )
|
||||
|
||||
HOOK: %prologue cpu ( n -- )
|
||||
HOOK: %epilogue cpu ( n -- )
|
||||
|
|
|
|||
|
|
@ -4,10 +4,10 @@ USING: accessors assocs sequences kernel combinators make math
|
|||
math.order math.ranges system namespaces locals layouts words
|
||||
alien alien.accessors alien.c-types literals cpu.architecture
|
||||
cpu.ppc.assembler cpu.ppc.assembler.backend compiler.cfg.registers
|
||||
compiler.cfg.instructions compiler.constants compiler.codegen
|
||||
compiler.cfg.instructions compiler.cfg.comparisons
|
||||
compiler.codegen.fixup compiler.cfg.intrinsics
|
||||
compiler.cfg.stack-frame compiler.cfg.build-stack-frame
|
||||
compiler.units ;
|
||||
compiler.units compiler.constants compiler.codegen ;
|
||||
FROM: cpu.ppc.assembler => B ;
|
||||
IN: cpu.ppc
|
||||
|
||||
|
|
@ -76,8 +76,12 @@ HOOK: reserved-area-size os ( -- n )
|
|||
: xt-save ( n -- i ) 2 cells - ;
|
||||
|
||||
! Next, we have the spill area as well as the FFI parameter area.
|
||||
! They overlap, since basic blocks with FFI calls will never
|
||||
! spill.
|
||||
! It is safe for them to overlap, since basic blocks with FFI calls
|
||||
! will never spill -- indeed, basic blocks with FFI calls do not
|
||||
! use vregs at all, and the FFI call is a stack analysis sync point.
|
||||
! In the future this will change and the stack frame logic will
|
||||
! need to be untangled somewhat.
|
||||
|
||||
: param@ ( n -- x ) reserved-area-size + ; inline
|
||||
|
||||
: param-save-size ( -- n ) 8 cells ; foldable
|
||||
|
|
@ -85,32 +89,30 @@ HOOK: reserved-area-size os ( -- n )
|
|||
: local@ ( n -- x )
|
||||
reserved-area-size param-save-size + + ; inline
|
||||
|
||||
: spill-integer-base ( -- n )
|
||||
stack-frame get spill-counts>> double-float-regs swap at
|
||||
double-float-regs reg-size * ;
|
||||
|
||||
: spill-integer@ ( n -- offset )
|
||||
cells spill-integer-base + param@ ;
|
||||
spill-integer-offset param@ ;
|
||||
|
||||
: spill-float@ ( n -- offset )
|
||||
double-float-regs reg-size * param@ ;
|
||||
spill-float-offset param@ ;
|
||||
|
||||
! Some FP intrinsics need a temporary scratch area in the stack
|
||||
! frame, 8 bytes in size
|
||||
! frame, 8 bytes in size. This is in the param-save area so it
|
||||
! should not overlap with spill slots.
|
||||
: scratch@ ( n -- offset )
|
||||
stack-frame get total-size>>
|
||||
factor-area-size -
|
||||
param-save-size -
|
||||
+ ;
|
||||
|
||||
! GC root area
|
||||
: gc-root@ ( n -- offset )
|
||||
gc-root-offset param@ ;
|
||||
|
||||
! Finally we have the linkage area
|
||||
HOOK: lr-save os ( -- n )
|
||||
|
||||
M: ppc stack-frame-size ( stack-frame -- i )
|
||||
[ spill-counts>> [ swap reg-size * ] { } assoc>map sum ]
|
||||
[ params>> ]
|
||||
[ return>> ]
|
||||
tri + +
|
||||
(stack-frame-size)
|
||||
param-save-size +
|
||||
reserved-area-size +
|
||||
factor-area-size +
|
||||
|
|
@ -176,95 +178,28 @@ M: ppc %or OR ;
|
|||
M: ppc %or-imm ORI ;
|
||||
M: ppc %xor XOR ;
|
||||
M: ppc %xor-imm XORI ;
|
||||
M: ppc %shl SLW ;
|
||||
M: ppc %shl-imm swapd SLWI ;
|
||||
M: ppc %shr SRW ;
|
||||
M: ppc %shr-imm swapd SRWI ;
|
||||
M: ppc %sar SRAW ;
|
||||
M: ppc %sar-imm SRAWI ;
|
||||
M: ppc %not NOT ;
|
||||
|
||||
: %alien-invoke-tail ( func dll -- )
|
||||
[ scratch-reg ] 2dip %alien-global scratch-reg MTCTR BCTR ;
|
||||
|
||||
:: exchange-regs ( r1 r2 -- )
|
||||
scratch-reg r1 MR
|
||||
r1 r2 MR
|
||||
r2 scratch-reg MR ;
|
||||
|
||||
: ?MR ( r1 r2 -- ) 2dup = [ 2drop ] [ MR ] if ;
|
||||
|
||||
:: move>args ( src1 src2 -- )
|
||||
{
|
||||
{ [ src1 4 = ] [ 3 src2 ?MR 3 4 exchange-regs ] }
|
||||
{ [ src1 3 = ] [ 4 src2 ?MR ] }
|
||||
{ [ src2 3 = ] [ 4 src1 ?MR 3 4 exchange-regs ] }
|
||||
{ [ src2 4 = ] [ 3 src1 ?MR ] }
|
||||
[ 3 src1 MR 4 src2 MR ]
|
||||
} cond ;
|
||||
|
||||
: clear-xer ( -- )
|
||||
:: overflow-template ( label dst src1 src2 insn -- )
|
||||
0 0 LI
|
||||
0 MTXER ; inline
|
||||
0 MTXER
|
||||
dst src2 src1 insn call
|
||||
label BO ; inline
|
||||
|
||||
:: overflow-template ( src1 src2 insn func -- )
|
||||
"no-overflow" define-label
|
||||
clear-xer
|
||||
scratch-reg src2 src1 insn call
|
||||
scratch-reg ds-reg 0 STW
|
||||
"no-overflow" get BNO
|
||||
src1 src2 move>args
|
||||
%prepare-alien-invoke
|
||||
func f %alien-invoke
|
||||
"no-overflow" resolve-label ; inline
|
||||
M: ppc %fixnum-add ( label dst src1 src2 -- )
|
||||
[ ADDO. ] overflow-template ;
|
||||
|
||||
:: overflow-template-tail ( src1 src2 insn func -- )
|
||||
"overflow" define-label
|
||||
clear-xer
|
||||
scratch-reg src2 src1 insn call
|
||||
"overflow" get BO
|
||||
scratch-reg ds-reg 0 STW
|
||||
BLR
|
||||
"overflow" resolve-label
|
||||
src1 src2 move>args
|
||||
%prepare-alien-invoke
|
||||
func f %alien-invoke-tail ; inline
|
||||
M: ppc %fixnum-sub ( label dst src1 src2 -- )
|
||||
[ SUBFO. ] overflow-template ;
|
||||
|
||||
M: ppc %fixnum-add ( src1 src2 -- )
|
||||
[ ADDO. ] "overflow_fixnum_add" overflow-template ;
|
||||
|
||||
M: ppc %fixnum-add-tail ( src1 src2 -- )
|
||||
[ ADDO. ] "overflow_fixnum_add" overflow-template-tail ;
|
||||
|
||||
M: ppc %fixnum-sub ( src1 src2 -- )
|
||||
[ SUBFO. ] "overflow_fixnum_subtract" overflow-template ;
|
||||
|
||||
M: ppc %fixnum-sub-tail ( src1 src2 -- )
|
||||
[ SUBFO. ] "overflow_fixnum_subtract" overflow-template-tail ;
|
||||
|
||||
M:: ppc %fixnum-mul ( src1 src2 temp1 temp2 -- )
|
||||
"no-overflow" define-label
|
||||
clear-xer
|
||||
temp1 src1 tag-bits get SRAWI
|
||||
temp2 temp1 src2 MULLWO.
|
||||
temp2 ds-reg 0 STW
|
||||
"no-overflow" get BNO
|
||||
src2 src2 tag-bits get SRAWI
|
||||
temp1 src2 move>args
|
||||
%prepare-alien-invoke
|
||||
"overflow_fixnum_multiply" f %alien-invoke
|
||||
"no-overflow" resolve-label ;
|
||||
|
||||
M:: ppc %fixnum-mul-tail ( src1 src2 temp1 temp2 -- )
|
||||
"overflow" define-label
|
||||
clear-xer
|
||||
temp1 src1 tag-bits get SRAWI
|
||||
temp2 temp1 src2 MULLWO.
|
||||
"overflow" get BO
|
||||
temp2 ds-reg 0 STW
|
||||
BLR
|
||||
"overflow" resolve-label
|
||||
src2 src2 tag-bits get SRAWI
|
||||
temp1 src2 move>args
|
||||
%prepare-alien-invoke
|
||||
"overflow_fixnum_multiply" f %alien-invoke-tail ;
|
||||
M: ppc %fixnum-mul ( label dst src1 src2 -- )
|
||||
[ MULLWO. ] overflow-template ;
|
||||
|
||||
: bignum@ ( n -- offset ) cells bignum tag-number - ; inline
|
||||
|
||||
|
|
@ -462,19 +397,27 @@ M:: ppc %write-barrier ( src card# table -- )
|
|||
src card# deck-bits SRWI
|
||||
table scratch-reg card# STBX ;
|
||||
|
||||
M:: ppc %gc ( temp1 temp2 gc-roots gc-root-count -- )
|
||||
"end" define-label
|
||||
M:: ppc %check-nursery ( label temp1 temp2 -- )
|
||||
temp2 load-zone-ptr
|
||||
temp1 temp2 cell LWZ
|
||||
temp2 temp2 3 cells LWZ
|
||||
temp1 temp1 1024 ADDI ! add ALLOT_BUFFER_ZONE to here
|
||||
temp1 0 temp2 CMP ! is here >= end?
|
||||
"end" get BLE
|
||||
! add ALLOT_BUFFER_ZONE to here
|
||||
temp1 temp1 1024 ADDI
|
||||
! is here >= end?
|
||||
temp1 0 temp2 CMP
|
||||
label BLE ;
|
||||
|
||||
M:: ppc %save-gc-root ( gc-root register -- )
|
||||
register 1 gc-root gc-root@ STW ;
|
||||
|
||||
M:: ppc %load-gc-root ( gc-root register -- )
|
||||
register 1 gc-root gc-root@ LWZ ;
|
||||
|
||||
M:: ppc %call-gc ( gc-root-count -- )
|
||||
%prepare-alien-invoke
|
||||
0 3 LI
|
||||
0 4 LI
|
||||
"inline_gc" f %alien-invoke
|
||||
"end" resolve-label ;
|
||||
3 1 gc-root-base param@ ADDI
|
||||
gc-root-count 4 LI
|
||||
"inline_gc" f %alien-invoke ;
|
||||
|
||||
M: ppc %prologue ( n -- )
|
||||
0 11 LOAD32 rc-absolute-ppc-2/2 rel-this
|
||||
|
|
|
|||
|
|
@ -1,7 +1,8 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel layouts system math alien.c-types sequences
|
||||
compiler.cfg.registers cpu.architecture cpu.x86.assembler cpu.x86 ;
|
||||
compiler.cfg.registers cpu.architecture cpu.x86.assembler cpu.x86
|
||||
cpu.x86.assembler.operands ;
|
||||
IN: cpu.x86.64.winnt
|
||||
|
||||
M: int-regs param-regs drop { RCX RDX R8 R9 } ;
|
||||
|
|
|
|||
|
|
@ -435,38 +435,19 @@ M:: x86 %write-barrier ( src card# table -- )
|
|||
table table [] MOV
|
||||
table card# [+] card-mark <byte> MOV ;
|
||||
|
||||
:: check-nursery ( temp1 temp2 -- )
|
||||
M:: x86 %check-nursery ( label temp1 temp2 -- )
|
||||
temp1 load-zone-ptr
|
||||
temp2 temp1 cell [+] MOV
|
||||
temp2 1024 ADD
|
||||
temp1 temp1 3 cells [+] MOV
|
||||
temp2 temp1 CMP ;
|
||||
temp2 temp1 CMP
|
||||
label JLE ;
|
||||
|
||||
GENERIC# save-gc-root 1 ( gc-root operand temp -- )
|
||||
M: x86 %save-gc-root ( gc-root register -- ) [ gc-root@ ] dip MOV ;
|
||||
|
||||
M:: spill-slot save-gc-root ( gc-root spill-slot temp -- )
|
||||
temp spill-slot n>> spill-integer@ MOV
|
||||
gc-root gc-root@ temp MOV ;
|
||||
M: x86 %load-gc-root ( gc-root register -- ) swap gc-root@ MOV ;
|
||||
|
||||
M:: word save-gc-root ( gc-root register temp -- )
|
||||
gc-root gc-root@ register MOV ;
|
||||
|
||||
: save-gc-roots ( gc-roots temp -- )
|
||||
'[ _ save-gc-root ] assoc-each ;
|
||||
|
||||
GENERIC# load-gc-root 1 ( gc-root operand temp -- )
|
||||
|
||||
M:: spill-slot load-gc-root ( gc-root spill-slot temp -- )
|
||||
temp gc-root gc-root@ MOV
|
||||
spill-slot n>> spill-integer@ temp MOV ;
|
||||
|
||||
M:: word load-gc-root ( gc-root register temp -- )
|
||||
register gc-root gc-root@ MOV ;
|
||||
|
||||
: load-gc-roots ( gc-roots temp -- )
|
||||
'[ _ load-gc-root ] assoc-each ;
|
||||
|
||||
:: call-gc ( gc-root-count -- )
|
||||
M:: x86 %call-gc ( gc-root-count -- )
|
||||
! Pass pointer to start of GC roots as first parameter
|
||||
param-reg-1 gc-root-base param@ LEA
|
||||
! Pass number of roots as second parameter
|
||||
|
|
@ -475,15 +456,6 @@ M:: word load-gc-root ( gc-root register temp -- )
|
|||
%prepare-alien-invoke
|
||||
"inline_gc" f %alien-invoke ;
|
||||
|
||||
M:: x86 %gc ( temp1 temp2 gc-roots gc-root-count -- )
|
||||
"end" define-label
|
||||
temp1 temp2 check-nursery
|
||||
"end" get JLE
|
||||
gc-roots temp1 save-gc-roots
|
||||
gc-root-count call-gc
|
||||
gc-roots temp1 load-gc-roots
|
||||
"end" resolve-label ;
|
||||
|
||||
M: x86 %alien-global
|
||||
[ 0 MOV ] 2dip rc-absolute-cell rel-dlsym ;
|
||||
|
||||
|
|
|
|||
|
|
@ -18,6 +18,7 @@ HELP: CM-FUNCTION:
|
|||
"C-LIBRARY: exlib"
|
||||
""
|
||||
"C-INCLUDE: <stdio.h>"
|
||||
"C-INCLUDE: <stdlib.h>"
|
||||
"CM-FUNCTION: char* sum_diff ( const-int a, const-int b, int* x, int* y )"
|
||||
" *x = a + b;"
|
||||
" *y = a - b;"
|
||||
|
|
|
|||
|
|
@ -54,6 +54,6 @@ IN: benchmark.pidigits
|
|||
[ 1 { { 1 0 } { 0 1 } } ] dip 0 0 (pidigits) ;
|
||||
|
||||
: pidigits-main ( -- )
|
||||
10000 pidigits ;
|
||||
2000 pidigits ;
|
||||
|
||||
MAIN: pidigits-main
|
||||
|
|
|
|||
Loading…
Reference in New Issue