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 2008-11-03 16:22:44 -05:00
parent 92e2ee3509 dc85ed3d56
commit b13b120244
200 changed files with 5725 additions and 7839 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
basis/bootstrap/compiler/compiler.factor
View File

@ -7,7 +7,7 @@ hashtables.private sequences.private math classes.tuple.private
growable namespaces.private assocs words command-line vocabs io
io.encodings.string prettyprint libc splitting math.parser
compiler.units math.order compiler.tree.builder
compiler.tree.optimizer ;
compiler.tree.optimizer compiler.cfg.optimizer ;
IN: bootstrap.compiler
! Don't bring this in when deploying, since it will store a
@ -93,6 +93,10 @@ nl
{ optimize-tree } compile-uncompiled
{ optimize-cfg } compile-uncompiled
{ (compile) } compile-uncompiled
vocabs [ words compile-uncompiled "." write flush ] each
" done" print flush

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

@ -8,7 +8,8 @@ grouping growable classes classes.builtin classes.tuple
classes.tuple.private words.private io.binary io.files vocabs
vocabs.loader source-files definitions debugger
quotations.private sequences.private combinators
io.encodings.binary math.order math.private accessors slots.private ;
io.encodings.binary math.order math.private accessors
slots.private compiler.units ;
IN: bootstrap.image
: my-arch ( -- arch )
@ -458,6 +459,8 @@ M: quotation '
800000 <vector> image set
20000 <hashtable> objects set
emit-header t, 0, 1, -1,
"Building generic words..." print flush
call-remake-generics-hook
"Serializing words..." print flush
emit-words
"Serializing JIT data..." print flush

9
basis/cocoa/messages/messages.factor
View File

@ -1,10 +1,11 @@
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.c-types alien.strings arrays assocs
combinators compiler kernel math namespaces make parser
prettyprint prettyprint.sections quotations sequences strings
words cocoa.runtime io macros memoize debugger fry
io.encodings.ascii effects compiler.generator libc libc.private ;
combinators compiler compiler.alien kernel math namespaces make
parser prettyprint prettyprint.sections quotations sequences
strings words cocoa.runtime io macros memoize debugger
io.encodings.ascii effects libc libc.private parser lexer init
core-foundation fry ;
IN: cocoa.messages
: make-sender ( method function -- quot )

0
unfinished/compiler/alien/alien.factor → basis/compiler/alien/alien.factor
View File

56
basis/compiler/cfg/alias-analysis/alias-analysis-tests.factor Normal file
View File

@ -0,0 +1,56 @@
USING: compiler.cfg.instructions compiler.cfg.registers
compiler.cfg.alias-analysis cpu.architecture tools.test
kernel ;
IN: compiler.cfg.alias-analysis.tests
[ ] [
{
T{ ##peek f V int-regs 2 D 1 f }
T{ ##box-alien f V int-regs 1 V int-regs 2 }
T{ ##slot-imm f V int-regs 3 V int-regs 1 0 3 }
} alias-analysis drop
] unit-test
[ ] [
{
T{ ##load-indirect f V int-regs 1 "hello" }
T{ ##slot-imm f V int-regs 0 V int-regs 1 0 3 }
} alias-analysis drop
] unit-test
[
{
T{ ##peek f V int-regs 1 D 1 f }
T{ ##peek f V int-regs 2 D 2 f }
T{ ##replace f V int-regs 1 D 0 f }
}
] [
{
T{ ##peek f V int-regs 1 D 1 f }
T{ ##peek f V int-regs 2 D 2 f }
T{ ##replace f V int-regs 2 D 0 f }
T{ ##replace f V int-regs 1 D 0 f }
} alias-analysis
] unit-test
[
{
T{ ##peek f V int-regs 1 D 1 f }
T{ ##peek f V int-regs 2 D 0 f }
T{ ##copy f V int-regs 3 V int-regs 2 f }
T{ ##copy f V int-regs 4 V int-regs 1 f }
T{ ##replace f V int-regs 3 D 0 f }
T{ ##replace f V int-regs 4 D 1 f }
}
] [
{
T{ ##peek f V int-regs 1 D 1 f }
T{ ##peek f V int-regs 2 D 0 f }
T{ ##replace f V int-regs 1 D 0 f }
T{ ##replace f V int-regs 2 D 1 f }
T{ ##peek f V int-regs 3 D 1 f }
T{ ##peek f V int-regs 4 D 0 f }
T{ ##replace f V int-regs 3 D 0 f }
T{ ##replace f V int-regs 4 D 1 f }
} alias-analysis
] unit-test

118
unfinished/compiler/cfg.bluesky/alias/alias.factor → basis/compiler/cfg/alias-analysis/alias-analysis.factor
View File

@ -1,10 +1,12 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math namespaces assocs hashtables sequences
accessors vectors combinators sets compiler.vops compiler.cfg ;
IN: compiler.cfg.alias
accessors vectors combinators sets classes compiler.cfg
compiler.cfg.registers compiler.cfg.instructions
compiler.cfg.copy-prop ;
IN: compiler.cfg.alias-analysis
! Alias analysis -- must be run after compiler.cfg.stack.
! Alias analysis -- assumes compiler.cfg.height has already run.
!
! We try to eliminate redundant slot and stack
! traffic using some simple heuristics.
@ -69,8 +71,8 @@ SYMBOL: vregs>acs
: check [ "BUG: static type error detected" throw ] unless* ; inline
: vreg>ac ( vreg -- ac )
#! Only vregs produced by %%allot, %peek and %%slot can
#! ever be used as valid inputs to %%slot and %%set-slot,
#! Only vregs produced by ##allot, ##peek and ##slot can
#! ever be used as valid inputs to ##slot and ##set-slot,
#! so we assert this fact by not giving alias classes to
#! other vregs.
vregs>acs get at check ;
@ -175,31 +177,30 @@ SYMBOL: heap-ac
[ kill-constant-set-slot ] 2bi
] [ nip kill-computed-set-slot ] if ;
SYMBOL: copies
: resolve ( vreg -- vreg )
dup copies get at swap or ;
SYMBOL: constants
: constant ( vreg -- n/f )
#! Return an %iconst value, or f if the vreg was not
#! assigned by an %iconst.
#! Return a ##load-immediate value, or f if the vreg was not
#! assigned by an ##load-immediate.
resolve constants get at ;
! We treat slot accessors and stack traffic alike
GENERIC: insn-slot# ( insn -- slot#/f )
GENERIC: insn-object ( insn -- vreg )
M: %peek insn-slot# n>> ;
M: %replace insn-slot# n>> ;
M: %%slot insn-slot# slot>> constant ;
M: %%set-slot insn-slot# slot>> constant ;
M: ##peek insn-slot# loc>> n>> ;
M: ##replace insn-slot# loc>> n>> ;
M: ##slot insn-slot# slot>> constant ;
M: ##slot-imm insn-slot# slot>> ;
M: ##set-slot insn-slot# slot>> constant ;
M: ##set-slot-imm insn-slot# slot>> ;
M: %peek insn-object stack>> ;
M: %replace insn-object stack>> ;
M: %%slot insn-object obj>> resolve ;
M: %%set-slot insn-object obj>> resolve ;
M: ##peek insn-object loc>> class ;
M: ##replace insn-object loc>> class ;
M: ##slot insn-object obj>> resolve ;
M: ##slot-imm insn-object obj>> resolve ;
M: ##set-slot insn-object obj>> resolve ;
M: ##set-slot-imm insn-object obj>> resolve ;
: init-alias-analysis ( -- )
H{ } clone histories set
@ -212,24 +213,37 @@ M: %%set-slot insn-object obj>> resolve ;
0 ac-counter set
next-ac heap-ac set
%data next-ac set-ac
%retain next-ac set-ac ;
ds-loc next-ac set-ac
rs-loc next-ac set-ac ;
GENERIC: analyze-aliases ( insn -- insn' )
GENERIC: analyze-aliases* ( insn -- insn' )
M: %iconst analyze-aliases
dup [ value>> ] [ out>> ] bi constants get set-at ;
M: ##load-immediate analyze-aliases*
dup [ val>> ] [ dst>> ] bi constants get set-at ;
M: %%allot analyze-aliases
M: ##load-indirect analyze-aliases*
dup dst>> set-heap-ac ;
M: ##allot analyze-aliases*
#! A freshly allocated object is distinct from any other
#! object.
dup out>> set-new-ac ;
dup dst>> set-new-ac ;
M: read-op analyze-aliases
dup out>> set-heap-ac
dup [ out>> ] [ insn-slot# ] [ insn-object ] tri
M: ##box-float analyze-aliases*
#! A freshly allocated object is distinct from any other
#! object.
dup dst>> set-new-ac ;
M: ##box-alien analyze-aliases*
#! A freshly allocated object is distinct from any other
#! object.
dup dst>> set-new-ac ;
M: ##read analyze-aliases*
dup dst>> set-heap-ac
dup [ dst>> ] [ insn-slot# ] [ insn-object ] tri
2dup live-slot dup [
2nip %copy boa analyze-aliases nip
2nip f \ ##copy boa analyze-aliases* nip
] [
drop remember-slot
] if ;
@ -239,21 +253,20 @@ M: read-op analyze-aliases
#! from?
live-slot = ;
M: write-op analyze-aliases
M: ##write analyze-aliases*
dup
[ in>> resolve ] [ insn-slot# ] [ insn-object ] tri
3dup idempotent? [
2drop 2drop nop
] [
[ remember-set-slot drop ] [ load-slot ] 3bi
] if ;
[ src>> resolve ] [ insn-slot# ] [ insn-object ] tri
[ remember-set-slot drop ] [ load-slot ] 3bi ;
M: %copy analyze-aliases
M: ##copy analyze-aliases*
#! The output vreg gets the same alias class as the input
#! vreg, since they both contain the same value.
dup [ in>> resolve ] [ out>> ] bi copies get set-at ;
dup record-copy ;
M: vop analyze-aliases ;
M: insn analyze-aliases* ;
: analyze-aliases ( insns -- insns' )
[ insn# set analyze-aliases* ] map-index sift ;
SYMBOL: live-stores
@ -264,30 +277,35 @@ SYMBOL: live-stores
] map concat unique
live-stores set ;
GENERIC: eliminate-dead-store ( insn -- insn' )
GENERIC: eliminate-dead-stores* ( insn -- insn' )
: (eliminate-dead-store) ( insn -- insn' )
: (eliminate-dead-stores) ( insn -- insn' )
dup insn-slot# [
insn# get live-stores get key? [
drop nop
drop f
] unless
] when ;
M: %replace eliminate-dead-store
M: ##replace eliminate-dead-stores*
#! Writes to above the top of the stack can be pruned also.
#! This is sound since any such writes are not observable
#! after the basic block, and any reads of those locations
#! will have been converted to copies by analyze-slot,
#! and the final stack height of the basic block is set at
#! the beginning by compiler.cfg.stack.
dup n>> 0 < [ drop nop ] [ (eliminate-dead-store) ] if ;
dup loc>> n>> 0 < [ drop f ] [ (eliminate-dead-stores) ] if ;
M: %%set-slot eliminate-dead-store (eliminate-dead-store) ;
M: ##set-slot eliminate-dead-stores* (eliminate-dead-stores) ;
M: vop eliminate-dead-store ;
M: ##set-slot-imm eliminate-dead-stores* (eliminate-dead-stores) ;
M: insn eliminate-dead-stores* ;
: eliminate-dead-stores ( insns -- insns' )
[ insn# set eliminate-dead-stores* ] map-index sift ;
: alias-analysis ( insns -- insns' )
init-alias-analysis
[ insn# set analyze-aliases ] map-index
analyze-aliases
compute-live-stores
[ insn# set eliminate-dead-store ] map-index ;
eliminate-dead-stores ;

0
basis/compiler/generator/authors.txt → basis/compiler/cfg/builder/authors.txt
View File

105
basis/compiler/cfg/builder/builder-tests.factor Normal file
View File

@ -0,0 +1,105 @@
IN: compiler.cfg.builder.tests
USING: tools.test kernel sequences
words sequences.private fry prettyprint alien alien.accessors
math.private compiler.tree.builder compiler.tree.optimizer
compiler.cfg.builder compiler.cfg.debugger arrays locals byte-arrays
kernel.private math ;
\ build-cfg must-infer
! Just ensure that various CFGs build correctly.
: unit-test-cfg ( quot -- ) '[ _ test-cfg drop ] [ ] swap unit-test ;
{
[ ]
[ dup ]
[ swap ]
[ >r r> ]
[ fixnum+ ]
[ fixnum+fast ]
[ 3 fixnum+fast ]
[ fixnum*fast ]
[ 3 fixnum*fast ]
[ fixnum-shift-fast ]
[ 10 fixnum-shift-fast ]
[ -10 fixnum-shift-fast ]
[ 0 fixnum-shift-fast ]
[ fixnum-bitnot ]
[ eq? ]
[ "hi" eq? ]
[ fixnum< ]
[ 5 fixnum< ]
[ float+ ]
[ 3.0 float+ ]
[ float<= ]
[ fixnum>bignum ]
[ bignum>fixnum ]
[ fixnum>float ]
[ float>fixnum ]
[ 3 f <array> ]
[ [ 1 ] [ 2 ] if ]
[ fixnum< [ 1 ] [ 2 ] if ]
[ float+ [ 2.0 float* ] [ 3.0 float* ] bi float/f ]
[ { [ 1 ] [ 2 ] [ 3 ] } dispatch ]
[ [ t ] loop ]
[ [ dup ] loop ]
[ [ 2 ] [ 3 throw ] if 4 ]
[ "int" f "malloc" { "int" } alien-invoke ]
[ "int" { "int" } "cdecl" alien-indirect ]
[ "int" { "int" } "cdecl" [ ] alien-callback ]
} [
unit-test-cfg
] each
: test-1 ( -- ) test-1 ;
: test-2 ( -- ) 3 . test-2 ;
: test-3 ( a -- b ) dup [ test-3 ] when ;
{
test-1
test-2
test-3
} [ unit-test-cfg ] each
{
byte-array
simple-alien
alien
POSTPONE: f
} [| class |
{
alien-signed-1
alien-signed-2
alien-signed-4
alien-unsigned-1
alien-unsigned-2
alien-unsigned-4
alien-cell
alien-float
alien-double
} [| word |
{ class } word '[ _ declare 10 _ execute ] unit-test-cfg
{ class fixnum } word '[ _ declare _ execute ] unit-test-cfg
] each
{
set-alien-signed-1
set-alien-signed-2
set-alien-signed-4
set-alien-unsigned-1
set-alien-unsigned-2
set-alien-unsigned-4
} [| word |
{ fixnum class } word '[ _ declare 10 _ execute ] unit-test-cfg
{ fixnum class fixnum } word '[ _ declare _ execute ] unit-test-cfg
] each
{ float class } \ set-alien-float '[ _ declare 10 _ execute ] unit-test-cfg
{ float class fixnum } \ set-alien-float '[ _ declare _ execute ] unit-test-cfg
{ float class } \ set-alien-double '[ _ declare 10 _ execute ] unit-test-cfg
{ float class fixnum } \ set-alien-double '[ _ declare _ execute ] unit-test-cfg
{ pinned-c-ptr class } \ set-alien-cell '[ _ declare 10 _ execute ] unit-test-cfg
{ pinned-c-ptr class fixnum } \ set-alien-cell '[ _ declare _ execute ] unit-test-cfg
] each

258
basis/compiler/cfg/builder/builder.factor Executable file
View File

@ -0,0 +1,258 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs combinators hashtables kernel
math fry namespaces make sequences words byte-arrays
layouts alien.c-types alien.structs
stack-checker.inlining cpu.architecture
compiler.tree
compiler.tree.builder
compiler.tree.combinators
compiler.tree.propagation.info
compiler.cfg
compiler.cfg.hats
compiler.cfg.stacks
compiler.cfg.iterator
compiler.cfg.utilities
compiler.cfg.registers
compiler.cfg.intrinsics
compiler.cfg.instructions
compiler.alien ;
IN: compiler.cfg.builder
! Convert tree SSA IR to CFG SSA IR.
: stop-iterating ( -- next ) end-basic-block f ;
SYMBOL: procedures
SYMBOL: current-word
SYMBOL: current-label
SYMBOL: loops
SYMBOL: first-basic-block
! Basic block after prologue, makes recursion faster
SYMBOL: current-label-start
: add-procedure ( -- )
basic-block get current-word get current-label get
<cfg> procedures get push ;
: begin-procedure ( word label -- )
end-basic-block
begin-basic-block
H{ } clone loops set
current-label set
current-word set
add-procedure ;
: with-cfg-builder ( nodes word label quot -- )
'[ begin-procedure @ ] with-scope ; inline
GENERIC: emit-node ( node -- next )
: check-basic-block ( node -- node' )
basic-block get [ drop f ] unless ; inline
: emit-nodes ( nodes -- )
[ current-node emit-node check-basic-block ] iterate-nodes ;
: begin-word ( -- )
#! We store the basic block after the prologue as a loop
#! labelled by the current word, so that self-recursive
#! calls can skip an epilogue/prologue.
##prologue
##branch
begin-basic-block
basic-block get first-basic-block set ;
: (build-cfg) ( nodes word label -- )
[
begin-word
V{ } clone node-stack set
emit-nodes
] with-cfg-builder ;
: build-cfg ( nodes word -- procedures )
V{ } clone [
procedures [
dup (build-cfg)
] with-variable
] keep ;
: local-recursive-call ( basic-block -- next )
##branch
basic-block get successors>> push
stop-iterating ;
: emit-call ( word -- next )
{
{ [ dup loops get key? ] [ loops get at local-recursive-call ] }
{ [ tail-call? not ] [ ##call ##branch begin-basic-block iterate-next ] }
{ [ dup current-label get eq? ] [ drop first-basic-block get local-recursive-call ] }
[ ##epilogue ##jump stop-iterating ]
} cond ;
! #recursive
: compile-recursive ( node -- next )
[ label>> id>> emit-call ]
[ [ child>> ] [ label>> word>> ] [ label>> id>> ] tri (build-cfg) ] bi ;
: remember-loop ( label -- )
basic-block get swap loops get set-at ;
: compile-loop ( node -- next )
##loop-entry
begin-basic-block
[ label>> id>> remember-loop ] [ child>> emit-nodes ] bi
iterate-next ;
M: #recursive emit-node
dup label>> loop?>> [ compile-loop ] [ compile-recursive ] if ;
! #if
: emit-branch ( obj -- final-bb )
[
begin-basic-block
emit-nodes
basic-block get dup [ ##branch ] when
] with-scope ;
: emit-if ( node -- )
children>> [ emit-branch ] map
end-basic-block
begin-basic-block
basic-block get '[ [ _ swap successors>> push ] when* ] each ;
: ##branch-t ( vreg -- )
\ f tag-number cc/= ##compare-imm-branch ;
M: #if emit-node
ds-pop ##branch-t emit-if iterate-next ;
! #dispatch
: dispatch-branch ( nodes word -- label )
gensym [
[
V{ } clone node-stack set
##prologue
emit-nodes
basic-block get [
##epilogue
##return
end-basic-block
] when
] with-cfg-builder
] keep ;
: dispatch-branches ( node -- )
children>> [
current-word get dispatch-branch
##dispatch-label
] each ;
: emit-dispatch ( node -- )
##epilogue
ds-pop ^^offset>slot i ##dispatch
dispatch-branches ;
: <dispatch-block> ( -- word )
gensym dup t "inlined-block" set-word-prop ;
M: #dispatch emit-node
tail-call? [
emit-dispatch stop-iterating
] [
current-word get <dispatch-block> [
[
begin-word
emit-dispatch
] with-cfg-builder
] keep emit-call
] if ;
! #call
M: #call emit-node
dup word>> dup "intrinsic" word-prop
[ emit-intrinsic iterate-next ] [ nip emit-call ] if ;
! #call-recursive
M: #call-recursive emit-node label>> id>> emit-call ;
! #push
M: #push emit-node
literal>> ^^load-literal ds-push iterate-next ;
! #shuffle
: emit-shuffle ( effect -- )
[ out>> ] [ in>> dup length ds-load zip ] bi
'[ _ at ] map ds-store ;
M: #shuffle emit-node
shuffle-effect emit-shuffle iterate-next ;
M: #>r emit-node
[ in-d>> length ] [ out-r>> empty? ] bi
[ neg ##inc-d ] [ ds-load rs-store ] if
iterate-next ;
M: #r> emit-node
[ in-r>> length ] [ out-d>> empty? ] bi
[ neg ##inc-r ] [ rs-load ds-store ] if
iterate-next ;
! #return
M: #return emit-node
drop ##epilogue ##return stop-iterating ;
M: #return-recursive emit-node
label>> id>> loops get key?
[ iterate-next ] [ ##epilogue ##return stop-iterating ] if ;
! #terminate
M: #terminate emit-node drop stop-iterating ;
! FFI
: return-size ( ctype -- n )
#! Amount of space we reserve for a return value.
{
{ [ dup c-struct? not ] [ drop 0 ] }
{ [ dup large-struct? not ] [ drop 2 cells ] }
[ heap-size ]
} cond ;
: <alien-stack-frame> ( params -- stack-frame )
stack-frame new
swap
[ return>> return-size >>return ]
[ alien-parameters parameter-sizes drop >>params ] bi ;
: alien-stack-frame ( params -- )
<alien-stack-frame> ##stack-frame ;
: emit-alien-node ( node quot -- next )
[ params>> ] dip [ drop alien-stack-frame ] [ call ] 2bi
begin-basic-block iterate-next ; inline
M: #alien-invoke emit-node
[ ##alien-invoke ] emit-alien-node ;
M: #alien-indirect emit-node
[ ##alien-indirect ] emit-alien-node ;
M: #alien-callback emit-node
dup params>> xt>> dup
[
##prologue
dup [ ##alien-callback ] emit-alien-node drop
##epilogue
params>> ##callback-return
] with-cfg-builder
iterate-next ;
! No-op nodes
M: #introduce emit-node drop iterate-next ;
M: #copy emit-node drop iterate-next ;
M: #enter-recursive emit-node drop iterate-next ;
M: #phi emit-node drop iterate-next ;

0
basis/compiler/generator/summary.txt → basis/compiler/cfg/builder/summary.txt
View File

0
basis/compiler/generator/tags.txt → basis/compiler/cfg/builder/tags.txt
View File

24
unfinished/compiler/cfg/cfg.factor → basis/compiler/cfg/cfg.factor
View File

@ -1,25 +1,27 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors namespaces assocs sequences sets fry ;
USING: kernel arrays vectors accessors namespaces ;
IN: compiler.cfg
TUPLE: cfg entry word label ;
C: <cfg> cfg
! - "number" and "visited" is used by linearization.
TUPLE: basic-block < identity-tuple
visited
id
number
instructions
successors ;
{ instructions vector }
{ successors vector }
{ predecessors vector } ;
: <basic-block> ( -- basic-block )
basic-block new
V{ } clone >>instructions
V{ } clone >>successors ;
V{ } clone >>successors
V{ } clone >>predecessors
\ basic-block counter >>id ;
TUPLE: mr instructions word label ;
TUPLE: cfg { entry basic-block } word label ;
C: <cfg> cfg
TUPLE: mr { instructions array } word label spill-counts ;
: <mr> ( instructions word label -- mr )
mr new

12
basis/compiler/cfg/copy-prop/copy-prop.factor Normal file
View File

@ -0,0 +1,12 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces assocs accessors ;
IN: compiler.cfg.copy-prop
SYMBOL: copies
: resolve ( vreg -- vreg )
dup copies get at swap or ;
: record-copy ( insn -- )
[ src>> resolve ] [ dst>> ] bi copies get set-at ; inline

8
basis/compiler/cfg/dead-code/dead-code-tests.factor Normal file
View File

@ -0,0 +1,8 @@
USING: compiler.cfg.dead-code compiler.cfg.instructions
compiler.cfg.registers cpu.architecture tools.test ;
IN: compiler.cfg.dead-code.tests
[ { } ] [
{ T{ ##load-immediate f V int-regs 134 16 } }
eliminate-dead-code
] unit-test

61
basis/compiler/cfg/dead-code/dead-code.factor Normal file
View File

@ -0,0 +1,61 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs sets kernel namespaces sequences
compiler.cfg.instructions compiler.cfg.def-use ;
IN: compiler.cfg.dead-code
! Dead code elimination -- assumes compiler.cfg.alias-analysis
! has already run.
! Maps vregs to sequences of vregs
SYMBOL: liveness-graph
! vregs which participate in side effects and thus are always live
SYMBOL: live-vregs
! mapping vregs to stack locations
SYMBOL: vregs>locs
: init-dead-code ( -- )
H{ } clone liveness-graph set
H{ } clone live-vregs set
H{ } clone vregs>locs set ;
GENERIC: compute-liveness ( insn -- )
M: ##flushable compute-liveness
[ uses-vregs ] [ dst>> ] bi liveness-graph get set-at ;
M: ##peek compute-liveness
[ [ loc>> ] [ dst>> ] bi vregs>locs get set-at ]
[ call-next-method ]
bi ;
: live-replace? ( ##replace -- ? )
[ src>> vregs>locs get at ] [ loc>> ] bi = not ;
M: ##replace compute-liveness
dup live-replace? [ call-next-method ] [ drop ] if ;
: record-live ( vregs -- )
[
dup live-vregs get key? [ drop ] [
[ live-vregs get conjoin ]
[ liveness-graph get at record-live ]
bi
] if
] each ;
M: insn compute-liveness uses-vregs record-live ;
GENERIC: live-insn? ( insn -- ? )
M: ##flushable live-insn? dst>> live-vregs get key? ;
M: ##replace live-insn? live-replace? ;
M: insn live-insn? drop t ;
: eliminate-dead-code ( insns -- insns' )
init-dead-code
[ [ compute-liveness ] each ] [ [ live-insn? ] filter ] bi ;

42
basis/compiler/cfg/debugger/debugger.factor Normal file
View File

@ -0,0 +1,42 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel words sequences quotations namespaces io
classes.tuple accessors prettyprint prettyprint.config
compiler.tree.builder compiler.tree.optimizer
compiler.cfg.builder compiler.cfg.linearization
compiler.cfg.stack-frame compiler.cfg.linear-scan
compiler.cfg.two-operand compiler.cfg.optimizer ;
IN: compiler.cfg.debugger
GENERIC: test-cfg ( quot -- cfgs )
M: callable test-cfg
build-tree optimize-tree gensym build-cfg ;
M: word test-cfg
[ build-tree-from-word nip optimize-tree ] keep build-cfg ;
SYMBOL: allocate-registers?
: test-mr ( quot -- mrs )
test-cfg [
optimize-cfg
build-mr
convert-two-operand
allocate-registers? get
[ linear-scan build-stack-frame ] when
] map ;
: insn. ( insn -- )
tuple>array allocate-registers? get [ but-last ] unless
[ pprint bl ] each nl ;
: mr. ( mrs -- )
[
"=== word: " write
dup word>> pprint
", label: " write
dup label>> pprint nl nl
instructions>> [ insn. ] each
nl
] each ;

44
basis/compiler/cfg/def-use/def-use.factor Normal file
View File

@ -0,0 +1,44 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays kernel compiler.cfg.instructions ;
IN: compiler.cfg.def-use
GENERIC: defs-vregs ( insn -- seq )
GENERIC: uses-vregs ( insn -- seq )
: dst/tmp-vregs ( insn -- seq ) [ dst>> ] [ temp>> ] bi 2array ;
M: ##flushable defs-vregs dst>> 1array ;
M: ##write-barrier defs-vregs [ card#>> ] [ table>> ] bi 2array ;
M: ##unary/temp defs-vregs dst/tmp-vregs ;
M: ##allot defs-vregs dst/tmp-vregs ;
M: ##dispatch defs-vregs temp>> 1array ;
M: ##slot defs-vregs [ dst>> ] [ temp>> ] bi 2array ;
M: ##set-slot defs-vregs temp>> 1array ;
M: insn defs-vregs drop f ;
M: ##unary uses-vregs src>> 1array ;
M: ##binary uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
M: ##binary-imm uses-vregs src1>> 1array ;
M: ##effect uses-vregs src>> 1array ;
M: ##slot uses-vregs [ obj>> ] [ slot>> ] bi 2array ;
M: ##slot-imm uses-vregs obj>> 1array ;
M: ##set-slot uses-vregs [ src>> ] [ obj>> ] [ slot>> ] tri 3array ;
M: ##set-slot-imm uses-vregs [ src>> ] [ obj>> ] bi 2array ;
M: ##conditional-branch uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
M: ##compare-imm-branch uses-vregs src1>> 1array ;
M: ##dispatch uses-vregs src>> 1array ;
M: ##alien-getter uses-vregs src>> 1array ;
M: ##alien-setter uses-vregs [ src>> ] [ value>> ] bi 2array ;
M: _conditional-branch uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
M: _compare-imm-branch uses-vregs src1>> 1array ;
M: insn uses-vregs drop f ;
UNION: vreg-insn
##flushable
##write-barrier
##dispatch
##effect
##conditional-branch
##compare-imm-branch
_conditional-branch
_compare-imm-branch ;

72
basis/compiler/cfg/hats/hats.factor Normal file
View File

@ -0,0 +1,72 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays byte-arrays kernel layouts math namespaces
sequences classes.tuple cpu.architecture compiler.cfg.registers
compiler.cfg.instructions ;
IN: compiler.cfg.hats
: i int-regs next-vreg ; inline
: ^^i i dup ; inline
: ^^i1 [ ^^i ] dip ; inline
: ^^i2 [ ^^i ] 2dip ; inline
: ^^i3 [ ^^i ] 3dip ; inline
: d double-float-regs next-vreg ; inline
: ^^d d dup ; inline
: ^^d1 [ ^^d ] dip ; inline
: ^^d2 [ ^^d ] 2dip ; inline
: ^^d3 [ ^^d ] 3dip ; inline
: ^^load-literal ( obj -- dst ) ^^i1 ##load-literal ; inline
: ^^peek ( loc -- dst ) ^^i1 ##peek ; inline
: ^^slot ( obj slot tag -- dst ) ^^i3 i ##slot ; inline
: ^^slot-imm ( obj slot tag -- dst ) ^^i3 ##slot-imm ; inline
: ^^set-slot ( src obj slot tag -- ) i ##set-slot ; inline
: ^^add ( src1 src2 -- dst ) ^^i2 ##add ; inline
: ^^add-imm ( src1 src2 -- dst ) ^^i2 ##add-imm ; inline
: ^^sub ( src1 src2 -- dst ) ^^i2 ##sub ; inline
: ^^sub-imm ( src1 src2 -- dst ) ^^i2 ##sub-imm ; inline
: ^^mul ( src1 src2 -- dst ) ^^i2 ##mul ; inline
: ^^mul-imm ( src1 src2 -- dst ) ^^i2 ##mul-imm ; inline
: ^^and ( input mask -- output ) ^^i2 ##and ; inline
: ^^and-imm ( input mask -- output ) ^^i2 ##and-imm ; inline
: ^^or ( src1 src2 -- dst ) ^^i2 ##or ; inline
: ^^or-imm ( src1 src2 -- dst ) ^^i2 ##or-imm ; inline
: ^^xor ( src1 src2 -- dst ) ^^i2 ##xor ; inline
: ^^xor-imm ( src1 src2 -- dst ) ^^i2 ##xor-imm ; inline
: ^^shl-imm ( src1 src2 -- dst ) ^^i2 ##shl-imm ; inline
: ^^shr-imm ( src1 src2 -- dst ) ^^i2 ##shr-imm ; inline
: ^^sar-imm ( src1 src2 -- dst ) ^^i2 ##sar-imm ; inline
: ^^not ( src -- dst ) ^^i1 ##not ; inline
: ^^bignum>integer ( src -- dst ) ^^i1 i ##bignum>integer ; inline
: ^^integer>bignum ( src -- dst ) ^^i1 i ##integer>bignum ; inline
: ^^add-float ( src1 src2 -- dst ) ^^d2 ##add-float ; inline
: ^^sub-float ( src1 src2 -- dst ) ^^d2 ##sub-float ; inline
: ^^mul-float ( src1 src2 -- dst ) ^^d2 ##mul-float ; inline
: ^^div-float ( src1 src2 -- dst ) ^^d2 ##div-float ; inline
: ^^float>integer ( src -- dst ) ^^i1 ##float>integer ; inline
: ^^integer>float ( src -- dst ) ^^d1 ##integer>float ; inline
: ^^allot ( size class -- dst ) ^^i2 i ##allot ; inline
: ^^allot-tuple ( n -- dst ) 2 + cells tuple ^^allot ; inline
: ^^allot-array ( n -- dst ) 2 + cells array ^^allot ; inline
: ^^allot-byte-array ( n -- dst ) 2 cells + byte-array ^^allot ; inline
: ^^box-float ( src -- dst ) ^^i1 i ##box-float ; inline
: ^^unbox-float ( src -- dst ) ^^d1 ##unbox-float ; inline
: ^^box-alien ( src -- dst ) ^^i1 i ##box-alien ; inline
: ^^unbox-alien ( src -- dst ) ^^i1 ##unbox-alien ; inline
: ^^unbox-c-ptr ( src class -- dst ) ^^i2 i ##unbox-c-ptr ;
: ^^alien-unsigned-1 ( src -- dst ) ^^i1 ##alien-unsigned-1 ; inline
: ^^alien-unsigned-2 ( src -- dst ) ^^i1 ##alien-unsigned-2 ; inline
: ^^alien-unsigned-4 ( src -- dst ) ^^i1 ##alien-unsigned-4 ; inline
: ^^alien-signed-1 ( src -- dst ) ^^i1 ##alien-signed-1 ; inline
: ^^alien-signed-2 ( src -- dst ) ^^i1 ##alien-signed-2 ; inline
: ^^alien-signed-4 ( src -- dst ) ^^i1 ##alien-signed-4 ; inline
: ^^alien-cell ( src -- dst ) ^^i1 ##alien-cell ; inline
: ^^alien-float ( src -- dst ) ^^d1 ##alien-float ; inline
: ^^alien-double ( src -- dst ) ^^d1 ##alien-double ; inline
: ^^compare ( src1 src2 cc -- dst ) ^^i3 ##compare ; inline
: ^^compare-imm ( src1 src2 cc -- dst ) ^^i3 ##compare-imm ; inline
: ^^compare-float ( src1 src2 cc -- dst ) ^^i3 ##compare-float ; inline
: ^^offset>slot ( vreg -- vreg' ) cell 4 = [ 1 ^^shr-imm ] when ; inline
: ^^tag-fixnum ( src -- dst ) ^^i1 ##tag-fixnum ; inline
: ^^untag-fixnum ( src -- dst ) ^^i1 ##untag-fixnum ; inline

51
basis/compiler/cfg/height/height.factor Normal file
View File

@ -0,0 +1,51 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors math namespaces sequences kernel fry
compiler.cfg compiler.cfg.registers compiler.cfg.instructions ;
IN: compiler.cfg.height
! Combine multiple stack height changes into one at the
! start of the basic block.
SYMBOL: ds-height
SYMBOL: rs-height
GENERIC: compute-heights ( insn -- )
M: ##inc-d compute-heights n>> ds-height [ + ] change ;
M: ##inc-r compute-heights n>> rs-height [ + ] change ;
M: insn compute-heights drop ;
GENERIC: normalize-height* ( insn -- insn' )
: normalize-inc-d/r ( insn stack -- insn' )
swap n>> '[ _ - ] change f ; inline
M: ##inc-d normalize-height* ds-height normalize-inc-d/r ;
M: ##inc-r normalize-height* rs-height normalize-inc-d/r ;
GENERIC: loc-stack ( loc -- stack )
M: ds-loc loc-stack drop ds-height ;
M: rs-loc loc-stack drop rs-height ;
GENERIC: <loc> ( n stack -- loc )
M: ds-loc <loc> drop <ds-loc> ;
M: rs-loc <loc> drop <rs-loc> ;
: normalize-peek/replace ( insn -- insn' )
[ [ [ n>> ] [ loc-stack get ] bi + ] keep <loc> ] change-loc ; inline
M: ##peek normalize-height* normalize-peek/replace ;
M: ##replace normalize-height* normalize-peek/replace ;
M: insn normalize-height* ;
: normalize-height ( insns -- insns' )
0 ds-height set
0 rs-height set
[ [ compute-heights ] each ]
[ [ [ normalize-height* ] map sift ] with-scope ] bi
ds-height get dup zero? [ drop ] [ f \ ##inc-d boa prefix ] if
rs-height get dup zero? [ drop ] [ f \ ##inc-r boa prefix ] if ;

225
basis/compiler/cfg/instructions/instructions.factor Normal file
View File

@ -0,0 +1,225 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs accessors arrays kernel sequences namespaces words
math math.order layouts classes.algebra alien byte-arrays
compiler.constants combinators compiler.cfg.registers
compiler.cfg.instructions.syntax ;
IN: compiler.cfg.instructions
! Virtual CPU instructions, used by CFG and machine IRs
TUPLE: insn ;
! Instruction with no side effects; if 'out' is never read, we
! can eliminate it.
TUPLE: ##flushable < insn { dst vreg } ;
! Instruction which is referentially transparent; we can replace
! repeated computation with a reference to a previous value
TUPLE: ##pure < ##flushable ;
TUPLE: ##unary < ##pure { src vreg } ;
TUPLE: ##unary/temp < ##unary { temp vreg } ;
TUPLE: ##binary < ##pure { src1 vreg } { src2 vreg } ;
TUPLE: ##binary-imm < ##pure { src1 vreg } { src2 integer } ;
TUPLE: ##commutative < ##binary ;
TUPLE: ##commutative-imm < ##binary-imm ;
! Instruction only used for its side effect, produces no values
TUPLE: ##effect < insn { src vreg } ;
! Read/write ops: candidates for alias analysis
TUPLE: ##read < ##flushable ;
TUPLE: ##write < ##effect ;
TUPLE: ##alien-getter < ##flushable { src vreg } ;
TUPLE: ##alien-setter < ##effect { value vreg } ;
! Stack operations
INSN: ##load-immediate < ##pure { val integer } ;
INSN: ##load-indirect < ##pure obj ;
GENERIC: ##load-literal ( dst value -- )
M: fixnum ##load-literal tag-fixnum ##load-immediate ;
M: f ##load-literal drop \ f tag-number ##load-immediate ;
M: object ##load-literal ##load-indirect ;
INSN: ##peek < ##read { loc loc } ;
INSN: ##replace < ##write { loc loc } ;
INSN: ##inc-d { n integer } ;
INSN: ##inc-r { n integer } ;
! Subroutine calls
TUPLE: stack-frame
{ params integer }
{ return integer }
{ total-size integer }
spill-counts ;
INSN: ##stack-frame stack-frame ;
INSN: ##call word ;
INSN: ##jump word ;
INSN: ##return ;
! Jump tables
INSN: ##dispatch src temp ;
INSN: ##dispatch-label label ;
! Slot access
INSN: ##slot < ##read { obj vreg } { slot vreg } { tag integer } { temp vreg } ;
INSN: ##slot-imm < ##read { obj vreg } { slot integer } { tag integer } ;
INSN: ##set-slot < ##write { obj vreg } { slot vreg } { tag integer } { temp vreg } ;
INSN: ##set-slot-imm < ##write { obj vreg } { slot integer } { tag integer } ;
! Integer arithmetic
INSN: ##add < ##commutative ;
INSN: ##add-imm < ##commutative-imm ;
INSN: ##sub < ##binary ;
INSN: ##sub-imm < ##binary-imm ;
INSN: ##mul < ##commutative ;
INSN: ##mul-imm < ##commutative-imm ;
INSN: ##and < ##commutative ;
INSN: ##and-imm < ##commutative-imm ;
INSN: ##or < ##commutative ;
INSN: ##or-imm < ##commutative-imm ;
INSN: ##xor < ##commutative ;
INSN: ##xor-imm < ##commutative-imm ;
INSN: ##shl-imm < ##binary-imm ;
INSN: ##shr-imm < ##binary-imm ;
INSN: ##sar-imm < ##binary-imm ;
INSN: ##not < ##unary ;
: ##tag-fixnum ( dst src -- ) tag-bits get ##shl-imm ; inline
: ##untag-fixnum ( dst src -- ) tag-bits get ##sar-imm ; inline
! Bignum/integer conversion
INSN: ##integer>bignum < ##unary/temp ;
INSN: ##bignum>integer < ##unary/temp ;
! Float arithmetic
INSN: ##add-float < ##commutative ;
INSN: ##sub-float < ##binary ;
INSN: ##mul-float < ##commutative ;
INSN: ##div-float < ##binary ;
! Float/integer conversion
INSN: ##float>integer < ##unary ;
INSN: ##integer>float < ##unary ;
! Boxing and unboxing
INSN: ##copy < ##unary ;
INSN: ##copy-float < ##unary ;
INSN: ##unbox-float < ##unary ;
INSN: ##unbox-any-c-ptr < ##unary/temp ;
INSN: ##box-float < ##unary/temp ;
INSN: ##box-alien < ##unary/temp ;
: ##unbox-f ( dst src -- ) drop 0 ##load-immediate ;
: ##unbox-byte-array ( dst src -- ) byte-array-offset ##add-imm ;
: ##unbox-alien ( dst src -- ) 3 object tag-number ##slot-imm ;
: ##unbox-c-ptr ( dst src class temp -- )
{
{ [ over \ f class<= ] [ 2drop ##unbox-f ] }
{ [ over simple-alien class<= ] [ 2drop ##unbox-alien ] }
{ [ over byte-array class<= ] [ 2drop ##unbox-byte-array ] }
[ nip ##unbox-any-c-ptr ]
} cond ;
! Alien accessors
INSN: ##alien-unsigned-1 < ##alien-getter ;
INSN: ##alien-unsigned-2 < ##alien-getter ;
INSN: ##alien-unsigned-4 < ##alien-getter ;
INSN: ##alien-signed-1 < ##alien-getter ;
INSN: ##alien-signed-2 < ##alien-getter ;
INSN: ##alien-signed-4 < ##alien-getter ;
INSN: ##alien-cell < ##alien-getter ;
INSN: ##alien-float < ##alien-getter ;
INSN: ##alien-double < ##alien-getter ;
INSN: ##set-alien-integer-1 < ##alien-setter ;
INSN: ##set-alien-integer-2 < ##alien-setter ;
INSN: ##set-alien-integer-4 < ##alien-setter ;
INSN: ##set-alien-cell < ##alien-setter ;
INSN: ##set-alien-float < ##alien-setter ;
INSN: ##set-alien-double < ##alien-setter ;
! Memory allocation
INSN: ##allot < ##flushable size class { temp vreg } ;
INSN: ##write-barrier < ##effect card# table ;
! FFI
INSN: ##alien-invoke params ;
INSN: ##alien-indirect params ;
INSN: ##alien-callback params ;
INSN: ##callback-return params ;
! Instructions used by CFG IR only.
INSN: ##prologue ;
INSN: ##epilogue ;
INSN: ##branch ;
INSN: ##loop-entry ;
! Condition codes
SYMBOL: cc<
SYMBOL: cc<=
SYMBOL: cc=
SYMBOL: cc>
SYMBOL: cc>=
SYMBOL: cc/=
: negate-cc ( cc -- cc' )
H{
{ cc< cc>= }
{ cc<= cc> }
{ cc> cc<= }
{ cc>= cc< }
{ cc= cc/= }
{ cc/= cc= }
} at ;
: evaluate-cc ( result cc -- ? )
H{
{ cc< { +lt+ } }
{ cc<= { +lt+ +eq+ } }
{ cc= { +eq+ } }
{ cc>= { +eq+ +gt+ } }
{ cc> { +gt+ } }
{ cc/= { +lt+ +gt+ } }
} at memq? ;
TUPLE: ##conditional-branch < insn { src1 vreg } { src2 vreg } cc ;
INSN: ##compare-branch < ##conditional-branch ;
INSN: ##compare-imm-branch { src1 vreg } { src2 integer } cc ;
INSN: ##compare < ##binary cc ;
INSN: ##compare-imm < ##binary-imm cc ;
INSN: ##compare-float-branch < ##conditional-branch ;
INSN: ##compare-float < ##binary cc ;
! Instructions used by machine IR only.
INSN: _prologue stack-frame ;
INSN: _epilogue stack-frame ;
INSN: _label id ;
INSN: _gc ;
INSN: _branch label ;
TUPLE: _conditional-branch < insn label { src1 vreg } { src2 vreg } cc ;
INSN: _compare-branch < _conditional-branch ;
INSN: _compare-imm-branch label { src1 vreg } { src2 integer } cc ;
INSN: _compare-float-branch < _conditional-branch ;
! These instructions operate on machine registers and not
! virtual registers
INSN: _spill src class n ;
INSN: _reload dst class n ;
INSN: _spill-counts counts ;

8
unfinished/compiler/cfg/instructions/syntax/syntax.factor → basis/compiler/cfg/instructions/syntax/syntax.factor
View File

@ -4,11 +4,15 @@ USING: classes.tuple classes.tuple.parser kernel words
make fry sequences parser ;
IN: compiler.cfg.instructions.syntax
TUPLE: insn ;
: insn-word ( -- word )
#! We want to put the insn tuple in compiler.cfg.instructions,
#! but we cannot have circularity between that vocabulary and
#! this one.
"insn" "compiler.cfg.instructions" lookup ;
: INSN:
parse-tuple-definition "regs" suffix
[ dup tuple eq? [ drop insn ] when ] dip
[ dup tuple eq? [ drop insn-word ] when ] dip
[ define-tuple-class ]
[ 2drop save-location ]
[ 2drop dup '[ f _ boa , ] define-inline ]

108
basis/compiler/cfg/intrinsics/alien/alien.factor Normal file
View File

@ -0,0 +1,108 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel sequences alien math classes.algebra
fry locals combinators cpu.architecture
compiler.tree.propagation.info
compiler.cfg.hats compiler.cfg.stacks compiler.cfg.instructions
compiler.cfg.utilities ;
IN: compiler.cfg.intrinsics.alien
: (prepare-alien-accessor-imm) ( class offset -- offset-vreg )
ds-drop [ ds-pop swap ^^unbox-c-ptr ] dip ^^add-imm ;
: (prepare-alien-accessor) ( class -- offset-vreg )
[ 2inputs ^^untag-fixnum swap ] dip ^^unbox-c-ptr ^^add ;
: prepare-alien-accessor ( infos -- offset-vreg )
<reversed> [ second class>> ] [ first ] bi
dup value-info-small-tagged? [
literal>> (prepare-alien-accessor-imm)
] [ drop (prepare-alien-accessor) ] if ;
:: inline-alien ( node quot test -- )
[let | infos [ node node-input-infos ] |
infos test call
[ infos prepare-alien-accessor quot call ]
[ node emit-primitive ]
if
] ; inline
: inline-alien-getter? ( infos -- ? )
[ first class>> c-ptr class<= ]
[ second class>> fixnum class<= ]
bi and ;
: inline-alien-getter ( node quot -- )
'[ @ ds-push ]
[ inline-alien-getter? ] inline-alien ; inline
: inline-alien-setter? ( infos class -- ? )
'[ first class>> _ class<= ]
[ second class>> c-ptr class<= ]
[ third class>> fixnum class<= ]
tri and and ;
: inline-alien-integer-setter ( node quot -- )
'[ ds-pop ^^untag-fixnum @ ]
[ fixnum inline-alien-setter? ]
inline-alien ; inline
: inline-alien-cell-setter ( node quot -- )
[ dup node-input-infos first class>> ] dip
'[ ds-pop _ ^^unbox-c-ptr @ ]
[ pinned-c-ptr inline-alien-setter? ]
inline-alien ; inline
: inline-alien-float-setter ( node quot -- )
'[ ds-pop ^^unbox-float @ ]
[ float inline-alien-setter? ]
inline-alien ; inline
: emit-alien-unsigned-getter ( node n -- )
'[
_ {
{ 1 [ ^^alien-unsigned-1 ] }
{ 2 [ ^^alien-unsigned-2 ] }
{ 4 [ ^^alien-unsigned-4 ] }
} case ^^tag-fixnum
] inline-alien-getter ;
: emit-alien-signed-getter ( node n -- )
'[
_ {
{ 1 [ ^^alien-signed-1 ] }
{ 2 [ ^^alien-signed-2 ] }
{ 4 [ ^^alien-signed-4 ] }
} case ^^tag-fixnum
] inline-alien-getter ;
: emit-alien-integer-setter ( node n -- )
'[
_ {
{ 1 [ ##set-alien-integer-1 ] }
{ 2 [ ##set-alien-integer-2 ] }
{ 4 [ ##set-alien-integer-4 ] }
} case
] inline-alien-integer-setter ;
: emit-alien-cell-getter ( node -- )
[ ^^alien-cell ^^box-alien ] inline-alien-getter ;
: emit-alien-cell-setter ( node -- )
[ ##set-alien-cell ] inline-alien-cell-setter ;
: emit-alien-float-getter ( node reg-class -- )
'[
_ {
{ single-float-regs [ ^^alien-float ] }
{ double-float-regs [ ^^alien-double ] }
} case ^^box-float
] inline-alien-getter ;
: emit-alien-float-setter ( node reg-class -- )
'[
_ {
{ single-float-regs [ ##set-alien-float ] }
{ double-float-regs [ ##set-alien-double ] }
} case
] inline-alien-float-setter ;

68
basis/compiler/cfg/intrinsics/allot/allot.factor Normal file
View File

@ -0,0 +1,68 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.order sequences accessors arrays
byte-arrays layouts classes.tuple.private fry locals
compiler.tree.propagation.info compiler.cfg.hats
compiler.cfg.instructions compiler.cfg.stacks
compiler.cfg.utilities ;
IN: compiler.cfg.intrinsics.allot
: ##set-slots ( regs obj class -- )
'[ _ swap 1+ _ tag-number ##set-slot-imm ] each-index ;
: emit-simple-allot ( node -- )
[ in-d>> length ] [ node-output-infos first class>> ] bi
[ drop ds-load ] [ [ 1+ cells ] dip ^^allot ] [ nip ] 2tri
[ ##set-slots ] [ [ drop ] [ ds-push ] [ drop ] tri* ] 3bi ;
: tuple-slot-regs ( layout -- vregs )
[ size>> ds-load ] [ ^^load-literal ] bi prefix ;
: emit-<tuple-boa> ( node -- )
dup node-input-infos peek literal>>
dup tuple-layout? [
nip
ds-drop
[ tuple-slot-regs ] [ size>> ^^allot-tuple ] bi
[ tuple ##set-slots ] [ ds-push drop ] 2bi
] [ drop emit-primitive ] if ;
: store-length ( len reg -- )
[ ^^load-literal ] dip 1 object tag-number ##set-slot-imm ;
: store-initial-element ( elt reg len -- )
[ 2 + object tag-number ##set-slot-imm ] with with each ;
: expand-<array>? ( obj -- ? )
dup integer? [ 0 8 between? ] [ drop f ] if ;
:: emit-<array> ( node -- )
[let | len [ node node-input-infos first literal>> ] |
len expand-<array>? [
[let | elt [ ds-pop ]
reg [ len ^^allot-array ] |
ds-drop
len reg store-length
elt reg len store-initial-element
reg ds-push
]
] [ node emit-primitive ] if
] ;
: expand-<byte-array>? ( obj -- ? )
dup integer? [ 0 32 between? ] [ drop f ] if ;
: bytes>cells ( m -- n ) cell align cell /i ;
:: emit-<byte-array> ( node -- )
[let | len [ node node-input-infos first literal>> ] |
len expand-<byte-array>? [
[let | elt [ 0 ^^load-literal ]
reg [ len ^^allot-byte-array ] |
ds-drop
len reg store-length
elt reg len bytes>cells store-initial-element
reg ds-push
]
] [ node emit-primitive ] if
] ;

63
basis/compiler/cfg/intrinsics/fixnum/fixnum.factor Normal file
View File

@ -0,0 +1,63 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: sequences accessors layouts kernel math namespaces
combinators fry locals
compiler.tree.propagation.info
compiler.cfg.stacks compiler.cfg.hats compiler.cfg.instructions
compiler.cfg.utilities ;
IN: compiler.cfg.intrinsics.fixnum
: (emit-fixnum-imm-op) ( infos insn -- dst )
ds-drop
[ ds-pop ] [ second literal>> tag-fixnum ] [ ] tri*
call ; inline
: (emit-fixnum-op) ( insn -- dst )
[ 2inputs ] dip call ; inline
:: emit-fixnum-op ( node insn imm-insn -- )
[let | infos [ node node-input-infos ] |
infos second value-info-small-tagged?
[ infos imm-insn (emit-fixnum-imm-op) ]
[ insn (emit-fixnum-op) ]
if
ds-push
] ; inline
: emit-fixnum-shift-fast ( node -- )
dup node-input-infos dup second value-info-small-tagged? [
nip
[ ds-drop ds-pop ] dip
second literal>> dup sgn {
{ -1 [ neg tag-bits get + ^^sar-imm ^^tag-fixnum ] }
{ 0 [ drop ] }
{ 1 [ ^^shl-imm ] }
} case
ds-push
] [ drop emit-primitive ] if ;
: emit-fixnum-bitnot ( -- )
ds-pop ^^not tag-mask get ^^xor-imm ds-push ;
: (emit-fixnum*fast) ( -- dst )
2inputs ^^untag-fixnum ^^mul ;
: (emit-fixnum*fast-imm) ( infos -- dst )
ds-drop
[ ds-pop ] [ second literal>> ] bi* ^^mul-imm ;
: emit-fixnum*fast ( node -- )
node-input-infos
dup second value-info-small-tagged?
[ (emit-fixnum*fast-imm) ] [ drop (emit-fixnum*fast) ] if
ds-push ;
: emit-fixnum-comparison ( node cc -- )
[ '[ _ ^^compare ] ] [ '[ _ ^^compare-imm ] ] bi
emit-fixnum-op ;
: emit-bignum>fixnum ( -- )
ds-pop ^^bignum>integer ^^tag-fixnum ds-push ;
: emit-fixnum>bignum ( -- )
ds-pop ^^untag-fixnum ^^integer>bignum ds-push ;

19
basis/compiler/cfg/intrinsics/float/float.factor Normal file
View File

@ -0,0 +1,19 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel compiler.cfg.stacks compiler.cfg.hats
compiler.cfg.instructions compiler.cfg.utilities ;
IN: compiler.cfg.intrinsics.float
: emit-float-op ( insn -- )
[ 2inputs [ ^^unbox-float ] bi@ ] dip call ^^box-float
ds-push ; inline
: emit-float-comparison ( cc -- )
[ 2inputs [ ^^unbox-float ] bi@ ] dip ^^compare-float
ds-push ; inline
: emit-float>fixnum ( -- )
ds-pop ^^unbox-float ^^float>integer ^^tag-fixnum ds-push ;
: emit-fixnum>float ( -- )
ds-pop ^^untag-fixnum ^^integer>float ^^box-float ds-push ;

141
basis/compiler/cfg/intrinsics/intrinsics.factor Normal file
View File

@ -0,0 +1,141 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: qualified words sequences kernel combinators
cpu.architecture
compiler.cfg.hats
compiler.cfg.instructions
compiler.cfg.intrinsics.alien
compiler.cfg.intrinsics.allot
compiler.cfg.intrinsics.fixnum
compiler.cfg.intrinsics.float
compiler.cfg.intrinsics.slots ;
QUALIFIED: kernel
QUALIFIED: arrays
QUALIFIED: byte-arrays
QUALIFIED: kernel.private
QUALIFIED: slots.private
QUALIFIED: classes.tuple.private
QUALIFIED: math.private
QUALIFIED: alien.accessors
IN: compiler.cfg.intrinsics
{
kernel.private:tag
math.private:fixnum+fast
math.private:fixnum-fast
math.private:fixnum-bitand
math.private:fixnum-bitor
math.private:fixnum-bitxor
math.private:fixnum-shift-fast
math.private:fixnum-bitnot
math.private:fixnum*fast
math.private:fixnum<
math.private:fixnum<=
math.private:fixnum>=
math.private:fixnum>
math.private:bignum>fixnum
math.private:fixnum>bignum
kernel:eq?
slots.private:slot
slots.private:set-slot
classes.tuple.private:<tuple-boa>
arrays:<array>
byte-arrays:<byte-array>
math.private:<complex>
math.private:<ratio>
kernel:<wrapper>
alien.accessors:alien-unsigned-1
alien.accessors:set-alien-unsigned-1
alien.accessors:alien-signed-1
alien.accessors:set-alien-signed-1
alien.accessors:alien-unsigned-2
alien.accessors:set-alien-unsigned-2
alien.accessors:alien-signed-2
alien.accessors:set-alien-signed-2
alien.accessors:alien-cell
alien.accessors:set-alien-cell
} [ t "intrinsic" set-word-prop ] each
: enable-alien-4-intrinsics ( -- )
{
alien.accessors:alien-unsigned-4
alien.accessors:set-alien-unsigned-4
alien.accessors:alien-signed-4
alien.accessors:set-alien-signed-4
} [ t "intrinsic" set-word-prop ] each ;
: enable-float-intrinsics ( -- )
{
math.private:float+
math.private:float-
math.private:float*
math.private:float/f
math.private:fixnum>float
math.private:float>fixnum
math.private:float<
math.private:float<=
math.private:float>
math.private:float>=
math.private:float=
alien.accessors:alien-float
alien.accessors:set-alien-float
alien.accessors:alien-double
alien.accessors:set-alien-double
} [ t "intrinsic" set-word-prop ] each ;
: emit-intrinsic ( node word -- )
{
{ \ kernel.private:tag [ drop emit-tag ] }
{ \ math.private:fixnum+fast [ [ ^^add ] [ ^^add-imm ] emit-fixnum-op ] }
{ \ math.private:fixnum-fast [ [ ^^sub ] [ ^^sub-imm ] emit-fixnum-op ] }
{ \ math.private:fixnum-bitand [ [ ^^and ] [ ^^and-imm ] emit-fixnum-op ] }
{ \ math.private:fixnum-bitor [ [ ^^or ] [ ^^or-imm ] emit-fixnum-op ] }
{ \ math.private:fixnum-bitxor [ [ ^^xor ] [ ^^xor-imm ] emit-fixnum-op ] }
{ \ math.private:fixnum-shift-fast [ emit-fixnum-shift-fast ] }
{ \ math.private:fixnum-bitnot [ drop emit-fixnum-bitnot ] }
{ \ math.private:fixnum*fast [ emit-fixnum*fast ] }
{ \ math.private:fixnum< [ cc< emit-fixnum-comparison ] }
{ \ math.private:fixnum<= [ cc<= emit-fixnum-comparison ] }
{ \ math.private:fixnum>= [ cc>= emit-fixnum-comparison ] }
{ \ math.private:fixnum> [ cc> emit-fixnum-comparison ] }
{ \ kernel:eq? [ cc= emit-fixnum-comparison ] }
{ \ math.private:bignum>fixnum [ drop emit-bignum>fixnum ] }
{ \ math.private:fixnum>bignum [ drop emit-fixnum>bignum ] }
{ \ math.private:float+ [ drop [ ^^add-float ] emit-float-op ] }
{ \ math.private:float- [ drop [ ^^sub-float ] emit-float-op ] }
{ \ math.private:float* [ drop [ ^^mul-float ] emit-float-op ] }
{ \ math.private:float/f [ drop [ ^^div-float ] emit-float-op ] }
{ \ math.private:float< [ drop cc< emit-float-comparison ] }
{ \ math.private:float<= [ drop cc<= emit-float-comparison ] }
{ \ math.private:float>= [ drop cc>= emit-float-comparison ] }
{ \ math.private:float> [ drop cc> emit-float-comparison ] }
{ \ math.private:float= [ drop cc= emit-float-comparison ] }
{ \ math.private:float>fixnum [ drop emit-float>fixnum ] }
{ \ math.private:fixnum>float [ drop emit-fixnum>float ] }
{ \ slots.private:slot [ emit-slot ] }
{ \ slots.private:set-slot [ emit-set-slot ] }
{ \ classes.tuple.private:<tuple-boa> [ emit-<tuple-boa> ] }
{ \ arrays:<array> [ emit-<array> ] }
{ \ byte-arrays:<byte-array> [ emit-<byte-array> ] }
{ \ math.private:<complex> [ emit-simple-allot ] }
{ \ math.private:<ratio> [ emit-simple-allot ] }
{ \ kernel:<wrapper> [ emit-simple-allot ] }
{ \ alien.accessors:alien-unsigned-1 [ 1 emit-alien-unsigned-getter ] }
{ \ alien.accessors:set-alien-unsigned-1 [ 1 emit-alien-integer-setter ] }
{ \ alien.accessors:alien-signed-1 [ 1 emit-alien-signed-getter ] }
{ \ alien.accessors:set-alien-signed-1 [ 1 emit-alien-integer-setter ] }
{ \ alien.accessors:alien-unsigned-2 [ 2 emit-alien-unsigned-getter ] }
{ \ alien.accessors:set-alien-unsigned-2 [ 2 emit-alien-integer-setter ] }
{ \ alien.accessors:alien-signed-2 [ 2 emit-alien-signed-getter ] }
{ \ alien.accessors:set-alien-signed-2 [ 2 emit-alien-integer-setter ] }
{ \ alien.accessors:alien-unsigned-4 [ 4 emit-alien-unsigned-getter ] }
{ \ alien.accessors:set-alien-unsigned-4 [ 4 emit-alien-integer-setter ] }
{ \ alien.accessors:alien-signed-4 [ 4 emit-alien-signed-getter ] }
{ \ alien.accessors:set-alien-signed-4 [ 4 emit-alien-integer-setter ] }
{ \ alien.accessors:alien-cell [ emit-alien-cell-getter ] }
{ \ alien.accessors:set-alien-cell [ emit-alien-cell-setter ] }
{ \ alien.accessors:alien-float [ single-float-regs emit-alien-float-getter ] }
{ \ alien.accessors:set-alien-float [ single-float-regs emit-alien-float-setter ] }
{ \ alien.accessors:alien-double [ double-float-regs emit-alien-float-getter ] }
{ \ alien.accessors:set-alien-double [ double-float-regs emit-alien-float-setter ] }
} case ;

53
basis/compiler/cfg/intrinsics/slots/slots.factor Normal file
View File

@ -0,0 +1,53 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: layouts namespaces kernel accessors sequences
classes.algebra compiler.tree.propagation.info
compiler.cfg.stacks compiler.cfg.hats compiler.cfg.instructions
compiler.cfg.utilities ;
IN: compiler.cfg.intrinsics.slots
: emit-tag ( -- )
ds-pop tag-mask get ^^and-imm ^^tag-fixnum ds-push ;
: value-tag ( info -- n ) class>> class-tag ; inline
: (emit-slot) ( infos -- dst )
[ 2inputs ^^offset>slot ] [ first value-tag ] bi*
^^slot ;
: (emit-slot-imm) ( infos -- dst )
ds-drop
[ ds-pop ]
[ [ second literal>> ] [ first value-tag ] bi ] bi*
^^slot-imm ;
: emit-slot ( node -- )
dup node-input-infos
dup first value-tag [
nip
dup second value-info-small-tagged?
[ (emit-slot-imm) ] [ (emit-slot) ] if
ds-push
] [ drop emit-primitive ] if ;
: (emit-set-slot) ( infos -- obj-reg )
[ 3inputs [ tuck ] dip ^^offset>slot ]
[ second value-tag ]
bi* ^^set-slot ;
: (emit-set-slot-imm) ( infos -- obj-reg )
ds-drop
[ 2inputs tuck ]
[ [ third literal>> ] [ second value-tag ] bi ] bi*
##set-slot-imm ;
: emit-set-slot ( node -- )
dup node-input-infos
dup second value-tag [
nip
[
dup third value-info-small-tagged?
[ (emit-set-slot-imm) ] [ (emit-set-slot) ] if
] [ first class>> immediate class<= ] bi
[ drop ] [ i i ##write-barrier ] if
] [ drop emit-primitive ] if ;

3
unfinished/compiler/cfg/iterator/iterator.factor → basis/compiler/cfg/iterator/iterator.factor
View File

@ -19,9 +19,6 @@ SYMBOL: node-stack
[ swap >node call node> drop ] keep iterate-nodes
] if ; inline recursive
: with-node-iterator ( quot -- )
>r V{ } clone node-stack r> with-variable ; inline
DEFER: (tail-call?)
: tail-phi? ( cursor -- ? )

145
unfinished/compiler/cfg/linear-scan/allocation/allocation.factor → basis/compiler/cfg/linear-scan/allocation/allocation.factor
View File

@ -1,10 +1,9 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces sequences math math.order kernel assocs
accessors vectors fry heaps
accessors vectors fry heaps cpu.architecture combinators
compiler.cfg.registers
compiler.cfg.linear-scan.live-intervals
compiler.backend ;
compiler.cfg.linear-scan.live-intervals ;
IN: compiler.cfg.linear-scan.allocation
! Mapping from register classes to sequences of machine registers
@ -19,24 +18,22 @@ SYMBOL: free-registers
! Vector of active live intervals
SYMBOL: active-intervals
: active-intervals-for ( vreg -- seq )
reg-class>> active-intervals get at ;
: add-active ( live-interval -- )
active-intervals get push ;
dup vreg>> active-intervals-for push ;
: delete-active ( live-interval -- )
active-intervals get delete ;
dup vreg>> active-intervals-for delq ;
: expire-old-intervals ( n -- )
active-intervals get
swap '[ end>> _ < ] partition
active-intervals set
[ deallocate-register ] each ;
: expire-old-uses ( n -- )
active-intervals get
swap '[ uses>> dup peek _ < [ pop* ] [ drop ] if ] each ;
: update-state ( live-interval -- )
start>> [ expire-old-intervals ] [ expire-old-uses ] bi ;
active-intervals swap '[
[
[ end>> _ < ] partition
[ [ deallocate-register ] each ] dip
] assoc-map
] change ;
! Minheap of live intervals which still need a register allocation
SYMBOL: unhandled-intervals
@ -59,14 +56,39 @@ SYMBOL: progress
[ [ start>> ] keep ] { } map>assoc
unhandled-intervals get heap-push-all ;
: assign-free-register ( live-interval registers -- )
#! If the live interval does not have any uses, it means it
#! will be spilled immediately, so it still needs a register
#! to compute the new value, but we don't add the interval
#! to the active set and we don't remove the register from
#! the free list.
over uses>> empty?
[ peek >>reg drop ] [ pop >>reg add-active ] if ;
! Coalescing
: active-interval ( vreg -- live-interval )
dup active-intervals-for [ vreg>> = ] with find nip ;
: coalesce? ( live-interval -- ? )
[ start>> ] [ copy-from>> ] bi
dup [ active-interval end>> = ] [ 2drop f ] if ;
: coalesce ( live-interval -- )
dup copy-from>> active-interval
[ [ add-active ] [ delete-active ] bi* ]
[ reg>> >>reg drop ]
2bi ;
! Splitting
: find-use ( live-interval n quot -- i elt )
[ uses>> ] 2dip curry find ; inline
: split-before ( live-interval i -- before )
[ clone dup uses>> ] dip
[ head >>uses ] [ 1- swap nth >>end ] 2bi ;
: split-after ( live-interval i -- after )
[ clone dup uses>> ] dip
[ tail >>uses ] [ swap nth >>start ] 2bi
f >>reg f >>copy-from ;
: split-interval ( live-interval n -- before after )
[ drop ] [ [ > ] find-use drop ] 2bi
[ split-before ] [ split-after ] 2bi ;
: record-split ( live-interval before after -- )
[ >>split-before ] [ >>split-after ] bi* drop ;
! Spilling
SYMBOL: spill-counts
@ -74,37 +96,23 @@ SYMBOL: spill-counts
: next-spill-location ( reg-class -- n )
spill-counts get [ dup 1+ ] change-at ;
: interval-to-spill ( -- live-interval )
: interval-to-spill ( active-intervals current -- live-interval )
#! We spill the interval with the most distant use location.
active-intervals get unclip-slice [
[ [ uses>> peek ] bi@ > ] most
] reduce ;
: check-split ( live-interval -- )
[ start>> ] [ end>> ] bi = [ "Cannot split any further" throw ] when ;
: split-interval ( live-interval -- before after )
#! Split the live interval at the location of its first use.
#! 'Before' now starts and ends on the same instruction.
[ check-split ]
[ clone [ uses>> delete-all ] [ dup start>> >>end ] bi ]
[ clone f >>reg dup uses>> peek >>start ]
tri ;
: record-split ( live-interval before after -- )
[ >>split-before ] [ >>split-after ] bi* drop ;
start>> '[ dup _ [ >= ] find-use nip ] { } map>assoc
unclip-slice [ [ [ second ] bi@ > ] most ] reduce first ;
: assign-spill ( before after -- before after )
#! If it has been spilled already, reuse spill location.
over reload-from>> [ next-spill-location ] unless*
over reload-from>>
[ over vreg>> reg-class>> next-spill-location ] unless*
tuck [ >>spill-to ] [ >>reload-from ] 2bi* ;
: split-and-spill ( live-interval -- before after )
dup split-interval [ record-split ] [ assign-spill ] 2bi ;
: split-and-spill ( new existing -- before after )
dup rot start>> split-interval
[ record-split ] [ assign-spill ] 2bi ;
: reuse-register ( new existing -- )
reg>> >>reg
dup uses>> empty? [ deallocate-register ] [ add-active ] if ;
reg>> >>reg add-active ;
: spill-existing ( new existing -- )
#! Our new interval will be used before the active interval
@ -112,41 +120,52 @@ SYMBOL: spill-counts
#! interval, then process the new interval and the tail end
#! of the existing interval again.
[ reuse-register ]
[ delete-active ]
[ split-and-spill [ drop ] [ add-unhandled ] bi* ] tri ;
[ nip delete-active ]
[ split-and-spill [ drop ] [ add-unhandled ] bi* ] 2tri ;
: spill-new ( new existing -- )
#! Our new interval will be used after the active interval
#! with the most distant use location. Split the new
#! interval, then process both parts of the new interval
#! again.
[ split-and-spill add-unhandled ] dip spill-existing ;
[ dup split-and-spill add-unhandled ] dip spill-existing ;
: spill-existing? ( new existing -- ? )
over uses>> empty? [ 2drop t ] [ [ uses>> peek ] bi@ < ] if ;
#! Test if 'new' will be used before 'existing'.
over start>> '[ _ [ > ] find-use nip -1 or ] bi@ < ;
: assign-blocked-register ( live-interval -- )
interval-to-spill
2dup spill-existing?
[ spill-existing ] [ spill-new ] if ;
: assign-blocked-register ( new -- )
[ dup vreg>> active-intervals-for ] keep interval-to-spill
2dup spill-existing? [ spill-existing ] [ spill-new ] if ;
: assign-register ( live-interval -- )
dup vreg>> free-registers-for [
assign-blocked-register
: assign-free-register ( new registers -- )
pop >>reg add-active ;
: assign-register ( new -- )
dup coalesce? [
coalesce
] [
assign-free-register
] if-empty ;
dup vreg>> free-registers-for
[ assign-blocked-register ]
[ assign-free-register ]
if-empty
] if ;
! Main loop
: reg-classes ( -- seq ) { int-regs double-float-regs } ; inline
: init-allocator ( registers -- )
V{ } clone active-intervals set
<min-heap> unhandled-intervals set
[ reverse >vector ] assoc-map free-registers set
H{ { int-regs 0 } { double-float-regs 0 } } clone spill-counts set
reg-classes [ 0 ] { } map>assoc spill-counts set
reg-classes [ V{ } clone ] { } map>assoc active-intervals set
-1 progress set ;
: handle-interval ( live-interval -- )
[ start>> progress set ] [ update-state ] [ assign-register ] tri ;
[ start>> progress set ]
[ start>> expire-old-intervals ]
[ assign-register ]
tri ;
: (allocate-registers) ( -- )
unhandled-intervals get [ handle-interval ] slurp-heap ;

0
unfinished/compiler/cfg/linear-scan/assignment/assignment-tests.factor → basis/compiler/cfg/linear-scan/assignment/assignment-tests.factor
View File

26
unfinished/compiler/cfg/linear-scan/assignment/assignment.factor → basis/compiler/cfg/linear-scan/assignment/assignment.factor
View File

@ -2,6 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel math assocs namespaces sequences heaps
fry make combinators
cpu.architecture
compiler.cfg.def-use
compiler.cfg.registers
compiler.cfg.instructions
compiler.cfg.linear-scan.live-intervals ;
@ -34,13 +36,8 @@ SYMBOL: unhandled-intervals
[ add-unhandled ] each ;
: insert-spill ( live-interval -- )
[ reg>> ] [ spill-to>> ] [ vreg>> reg-class>> ] tri
over [
{
{ int-regs [ _spill-integer ] }
{ double-float-regs [ _spill-float ] }
} case
] [ 3drop ] if ;
[ reg>> ] [ vreg>> reg-class>> ] [ spill-to>> ] tri
dup [ _spill ] [ 3drop ] if ;
: expire-old-intervals ( n -- )
active-intervals get
@ -49,13 +46,8 @@ SYMBOL: unhandled-intervals
[ insert-spill ] each ;
: insert-reload ( live-interval -- )
[ reg>> ] [ reload-from>> ] [ vreg>> reg-class>> ] tri
over [
{
{ int-regs [ _reload-integer ] }
{ double-float-regs [ _reload-float ] }
} case
] [ 3drop ] if ;
[ reg>> ] [ vreg>> reg-class>> ] [ reload-from>> ] tri
dup [ _reload ] [ 3drop ] if ;
: activate-new-intervals ( n -- )
#! Any live intervals which start on the current instruction
@ -67,13 +59,17 @@ SYMBOL: unhandled-intervals
] [ 2drop ] if
] if ;
: (assign-registers) ( insn -- )
GENERIC: (assign-registers) ( insn -- )
M: vreg-insn (assign-registers)
dup
[ defs-vregs ] [ uses-vregs ] bi append
active-intervals get swap '[ vreg>> _ member? ] filter
[ [ vreg>> ] [ reg>> ] bi ] { } map>assoc
>>regs drop ;
M: insn (assign-registers) drop ;
: init-assignment ( live-intervals -- )
V{ } clone active-intervals set
<min-heap> unhandled-intervals set

0
unfinished/compiler/cfg/linear-scan/debugger/debugger.factor → basis/compiler/cfg/linear-scan/debugger/debugger.factor
View File

357
basis/compiler/cfg/linear-scan/linear-scan-tests.factor Normal file
View File

@ -0,0 +1,357 @@
IN: compiler.cfg.linear-scan.tests
USING: tools.test random sorting sequences sets hashtables assocs
kernel fry arrays splitting namespaces math accessors vectors
math.order
cpu.architecture
compiler.cfg.instructions
compiler.cfg.registers
compiler.cfg.linear-scan
compiler.cfg.linear-scan.live-intervals
compiler.cfg.linear-scan.allocation
compiler.cfg.linear-scan.debugger ;
[ 7 ] [
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 2 } } }
{ start 0 }
{ end 10 }
{ uses V{ 0 1 3 7 10 } }
}
4 [ >= ] find-use nip
] unit-test
[ 4 ] [
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 2 } } }
{ start 0 }
{ end 10 }
{ uses V{ 0 1 3 4 10 } }
}
4 [ >= ] find-use nip
] unit-test
[ f ] [
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 2 } } }
{ start 0 }
{ end 10 }
{ uses V{ 0 1 3 4 10 } }
}
100 [ >= ] find-use nip
] unit-test
[
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 0 }
{ end 1 }
{ uses V{ 0 1 } }
}
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 5 }
{ end 5 }
{ uses V{ 5 } }
}
] [
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 0 }
{ end 5 }
{ uses V{ 0 1 5 } }
} 2 split-interval
] unit-test
[
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 0 }
{ end 0 }
{ uses V{ 0 } }
}
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 1 }
{ end 5 }
{ uses V{ 1 5 } }
}
] [
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 0 }
{ end 5 }
{ uses V{ 0 1 5 } }
} 0 split-interval
] unit-test
[
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 3 }
{ end 10 }
{ uses V{ 3 10 } }
}
] [
{
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 1 }
{ end 15 }
{ uses V{ 1 3 7 10 15 } }
}
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 3 }
{ end 8 }
{ uses V{ 3 4 8 } }
}
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 3 }
{ end 10 }
{ uses V{ 3 10 } }
}
}
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 5 }
{ end 5 }
{ uses V{ 5 } }
}
interval-to-spill
] unit-test
[ t ] [
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 5 }
{ end 15 }
{ uses V{ 5 10 15 } }
}
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 1 }
{ end 20 }
{ uses V{ 1 20 } }
}
spill-existing?
] unit-test
[ f ] [
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 5 }
{ end 15 }
{ uses V{ 5 10 15 } }
}
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 1 }
{ end 20 }
{ uses V{ 1 7 20 } }
}
spill-existing?
] unit-test
[ t ] [
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 5 }
{ end 5 }
{ uses V{ 5 } }
}
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 1 }
{ end 20 }
{ uses V{ 1 7 20 } }
}
spill-existing?
] unit-test
[ ] [
{
T{ live-interval { vreg T{ vreg { n 1 } { reg-class int-regs } } } { start 0 } { end 100 } { uses V{ 0 100 } } }
}
H{ { int-regs { "A" } } }
check-linear-scan
] unit-test
[ ] [
{
T{ live-interval { vreg T{ vreg { n 1 } { reg-class int-regs } } } { start 0 } { end 10 } { uses V{ 0 10 } } }
T{ live-interval { vreg T{ vreg { n 2 } { reg-class int-regs } } } { start 11 } { end 20 } { uses V{ 11 20 } } }
}
H{ { int-regs { "A" } } }
check-linear-scan
] unit-test
[ ] [
{
T{ live-interval { vreg T{ vreg { n 1 } { reg-class int-regs } } } { start 0 } { end 100 } { uses V{ 0 100 } } }
T{ live-interval { vreg T{ vreg { n 2 } { reg-class int-regs } } } { start 30 } { end 60 } { uses V{ 30 60 } } }
}
H{ { int-regs { "A" } } }
check-linear-scan
] unit-test
[ ] [
{
T{ live-interval { vreg T{ vreg { n 1 } { reg-class int-regs } } } { start 0 } { end 100 } { uses V{ 0 100 } } }
T{ live-interval { vreg T{ vreg { n 2 } { reg-class int-regs } } } { start 30 } { end 200 } { uses V{ 30 200 } } }
}
H{ { int-regs { "A" } } }
check-linear-scan
] unit-test
[
{
T{ live-interval { vreg T{ vreg { n 1 } { reg-class int-regs } } } { start 0 } { end 100 } { uses V{ 0 100 } } }
T{ live-interval { vreg T{ vreg { n 2 } { reg-class int-regs } } } { start 30 } { end 100 } { uses V{ 30 100 } } }
}
H{ { int-regs { "A" } } }
check-linear-scan
] must-fail
SYMBOL: available
SYMBOL: taken
SYMBOL: max-registers
SYMBOL: max-insns
SYMBOL: max-uses
: not-taken ( -- n )
available get keys dup empty? [ "Oops" throw ] when
random
dup taken get nth 1 + max-registers get = [
dup available get delete-at
] [
dup taken get [ 1 + ] change-nth
] if ;
: random-live-intervals ( num-intervals max-uses max-registers max-insns -- seq )
[
max-insns set
max-registers set
max-uses set
max-insns get [ 0 ] replicate taken set
max-insns get [ dup ] H{ } map>assoc available set
[
live-interval new
swap int-regs swap vreg boa >>vreg
max-uses get random 2 max [ not-taken ] replicate natural-sort
[ >>uses ] [ first >>start ] bi
dup uses>> peek >>end
] map
] with-scope ;
: random-test ( num-intervals max-uses max-registers max-insns -- )
over >r random-live-intervals r> int-regs associate check-linear-scan ;
[ ] [ 30 2 1 60 random-test ] unit-test
[ ] [ 60 2 2 60 random-test ] unit-test
[ ] [ 80 2 3 200 random-test ] unit-test
[ ] [ 70 2 5 30 random-test ] unit-test
[ ] [ 60 2 6 30 random-test ] unit-test
[ ] [ 1 2 10 10 random-test ] unit-test
[ ] [ 10 4 2 60 random-test ] unit-test
[ ] [ 10 20 2 400 random-test ] unit-test
[ ] [ 10 20 4 300 random-test ] unit-test
USING: math.private compiler.cfg.debugger ;
[ ] [ [ float+ float>fixnum 3 fixnum*fast ] test-mr first linear-scan drop ] unit-test
[ f ] [
T{ ##allot
f
T{ vreg f int-regs 1 }
40
array
T{ vreg f int-regs 2 }
f
} clone
1array (linear-scan) first regs>> values all-equal?
] unit-test
[ 0 1 ] [
{
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 0 }
{ end 5 }
{ uses V{ 0 1 5 } }
}
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 2 } } }
{ start 3 }
{ end 4 }
{ uses V{ 3 4 } }
}
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 3 } } }
{ start 2 }
{ end 6 }
{ uses V{ 2 4 6 } }
}
} [ clone ] map
H{ { int-regs { "A" "B" } } }
allocate-registers
first split-before>> [ start>> ] [ end>> ] bi
] unit-test
! Coalescing interacted badly with splitting
[ ] [
{
T{ live-interval
{ vreg V int-regs 70 }
{ start 14 }
{ end 17 }
{ uses V{ 14 15 16 17 } }
{ copy-from V int-regs 67 }
}
T{ live-interval
{ vreg V int-regs 67 }
{ start 13 }
{ end 14 }
{ uses V{ 13 14 } }
}
T{ live-interval
{ vreg V int-regs 30 }
{ start 4 }
{ end 18 }
{ uses V{ 4 12 16 17 18 } }
}
T{ live-interval
{ vreg V int-regs 27 }
{ start 3 }
{ end 13 }
{ uses V{ 3 7 13 } }
}
T{ live-interval
{ vreg V int-regs 59 }
{ start 10 }
{ end 18 }
{ uses V{ 10 11 12 18 } }
{ copy-from V int-regs 56 }
}
T{ live-interval
{ vreg V int-regs 60 }
{ start 12 }
{ end 17 }
{ uses V{ 12 17 } }
}
T{ live-interval
{ vreg V int-regs 56 }
{ start 9 }
{ end 10 }
{ uses V{ 9 10 } }
}
}
{ { int-regs { 0 1 2 3 } } }
allocate-registers drop
] unit-test

17
unfinished/compiler/cfg/linear-scan/linear-scan.factor → basis/compiler/cfg/linear-scan/linear-scan.factor
View File

@ -1,8 +1,9 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors namespaces
compiler.backend
USING: kernel accessors namespaces make
cpu.architecture
compiler.cfg
compiler.cfg.instructions
compiler.cfg.linear-scan.live-intervals
compiler.cfg.linear-scan.allocation
compiler.cfg.linear-scan.assignment ;
@ -22,12 +23,16 @@ IN: compiler.cfg.linear-scan
! by Omri Traub, Glenn Holloway, Michael D. Smith
! http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.34.8435
: (linear-scan) ( insns -- insns' )
dup compute-live-intervals
machine-registers allocate-registers assign-registers ;
: linear-scan ( mr -- mr' )
[
[
dup compute-live-intervals
machine-registers allocate-registers
assign-registers
[
(linear-scan) %
spill-counts get _spill-counts
] { } make
] change-instructions
spill-counts get >>spill-counts
] with-scope ;

64
basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor Normal file
View File

@ -0,0 +1,64 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces kernel assocs accessors sequences math fry
compiler.cfg.instructions compiler.cfg.registers
compiler.cfg.def-use ;
IN: compiler.cfg.linear-scan.live-intervals
TUPLE: live-interval
vreg
reg spill-to reload-from split-before split-after
start end uses
copy-from ;
: add-use ( n live-interval -- )
dup live-interval? [ "No def" throw ] unless
[ (>>end) ] [ uses>> push ] 2bi ;
: <live-interval> ( start vreg -- live-interval )
live-interval new
V{ } clone >>uses
swap >>vreg
over >>start
[ add-use ] keep ;
M: live-interval hashcode*
nip [ start>> ] [ end>> 1000 * ] bi + ;
M: live-interval clone
call-next-method [ clone ] change-uses ;
! Mapping from vreg to live-interval
SYMBOL: live-intervals
: new-live-interval ( n vreg live-intervals -- )
2dup key? [
at add-use
] [
[ [ <live-interval> ] keep ] dip set-at
] if ;
GENERIC# compute-live-intervals* 1 ( insn n -- )
M: insn compute-live-intervals* 2drop ;
M: vreg-insn compute-live-intervals*
live-intervals get
[ [ uses-vregs ] 2dip '[ _ swap _ at add-use ] each ]
[ [ defs-vregs ] 2dip '[ _ swap _ new-live-interval ] each ]
3bi ;
: record-copy ( insn -- )
[ dst>> live-intervals get at ] [ src>> ] bi >>copy-from drop ;
M: ##copy compute-live-intervals*
[ call-next-method ] [ drop record-copy ] 2bi ;
M: ##copy-float compute-live-intervals*
[ call-next-method ] [ drop record-copy ] 2bi ;
: compute-live-intervals ( instructions -- live-intervals )
H{ } clone [
live-intervals set
[ compute-live-intervals* ] each-index
] keep values ;

4
basis/compiler/cfg/linearization/linearization-tests.factor Normal file
View File

@ -0,0 +1,4 @@
IN: compiler.cfg.linearization.tests
USING: compiler.cfg.linearization tools.test ;
\ build-mr must-infer

47
unfinished/compiler/cfg/linearization/linearization.factor → basis/compiler/cfg/linearization/linearization.factor
View File

@ -1,11 +1,10 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math accessors sequences namespaces make
combinators
combinators classes
compiler.cfg
compiler.cfg.rpo
compiler.cfg.instructions
compiler.cfg.instructions.syntax ;
compiler.cfg.instructions ;
IN: compiler.cfg.linearization
! Convert CFG IR to machine IR.
@ -19,7 +18,7 @@ M: insn linearize-insn , drop ;
: useless-branch? ( basic-block successor -- ? )
#! If our successor immediately follows us in RPO, then we
#! don't need to branch.
[ number>> 1+ ] [ number>> ] bi* = ; inline
[ number>> ] bi@ 1- = ; inline
: branch-to-return? ( successor -- ? )
#! A branch to a block containing just a return is cloned.
@ -37,27 +36,39 @@ M: insn linearize-insn , drop ;
M: ##branch linearize-insn
drop dup successors>> first emit-branch ;
: conditional ( basic-block -- basic-block successor1 label2 )
dup successors>> first2 swap number>> ; inline
: (binary-conditional)
[ dup successors>> first2 ]
[ [ src1>> ] [ src2>> ] [ cc>> ] tri ] bi* ; inline
: boolean-conditional ( basic-block insn -- basic-block successor vreg label2 )
[ conditional ] [ src>> ] bi* swap ; inline
: binary-conditional ( basic-block insn -- basic-block successor label2 src1 src2 cc )
[ (binary-conditional) ]
[ drop dup successors>> first useless-branch? ] 2bi
[ [ number>> ] 3dip negate-cc ] [ [ swap number>> ] 3dip ] if ;
M: ##branch-f linearize-insn
boolean-conditional _branch-f emit-branch ;
M: ##compare-branch linearize-insn
binary-conditional _compare-branch emit-branch ;
M: ##branch-t linearize-insn
boolean-conditional _branch-t emit-branch ;
M: ##compare-imm-branch linearize-insn
binary-conditional _compare-imm-branch emit-branch ;
: >intrinsic< ( insn -- quot defs uses )
[ quot>> ] [ defs-vregs>> ] [ uses-vregs>> ] tri ;
M: ##compare-float-branch linearize-insn
binary-conditional _compare-float-branch emit-branch ;
M: ##if-intrinsic linearize-insn
[ conditional ] [ >intrinsic< ] bi*
_if-intrinsic emit-branch ;
: gc? ( bb -- ? )
instructions>> [
class {
##allot
##integer>bignum
##box-float
##box-alien
} memq?
] contains? ;
: linearize-basic-block ( bb -- )
[ number>> _label ] [ linearize-insns ] bi ;
[ number>> _label ]
[ gc? [ _gc ] when ]
[ linearize-insns ]
tri ;
: linearize-basic-blocks ( rpo -- insns )
[ [ linearize-basic-block ] each ] { } make ;

29
basis/compiler/cfg/optimizer/optimizer.factor Normal file
View File

@ -0,0 +1,29 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences compiler.cfg.rpo
compiler.cfg.instructions
compiler.cfg.predecessors
compiler.cfg.useless-blocks
compiler.cfg.height
compiler.cfg.alias-analysis
compiler.cfg.value-numbering
compiler.cfg.dead-code
compiler.cfg.write-barrier ;
IN: compiler.cfg.optimizer
: trivial? ( insns -- ? )
dup length 2 = [ first ##call? ] [ drop f ] if ;
: optimize-cfg ( cfg -- cfg' )
compute-predecessors
delete-useless-blocks
delete-useless-conditionals
[
dup trivial? [
normalize-height
alias-analysis
value-numbering
eliminate-dead-code
eliminate-write-barriers
] unless
] change-basic-blocks ;

10
basis/compiler/cfg/predecessors/predecessors.factor Normal file
View File

@ -0,0 +1,10 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors sequences compiler.cfg.rpo ;
IN: compiler.cfg.predecessors
: (compute-predecessors) ( bb -- )
dup successors>> [ predecessors>> push ] with each ;
: compute-predecessors ( cfg -- cfg' )
dup [ (compute-predecessors) ] each-basic-block ;

37
basis/compiler/cfg/registers/registers.factor Normal file
View File

@ -0,0 +1,37 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors namespaces kernel arrays
parser prettyprint.backend prettyprint.sections ;
IN: compiler.cfg.registers
! Virtual registers, used by CFG and machine IRs
TUPLE: vreg { reg-class read-only } { n read-only } ;
SYMBOL: vreg-counter
: next-vreg ( reg-class -- vreg ) \ vreg-counter counter vreg boa ;
! Stack locations
TUPLE: loc { n read-only } ;
TUPLE: ds-loc < loc ;
C: <ds-loc> ds-loc
TUPLE: rs-loc < loc ;
C: <rs-loc> rs-loc
! Prettyprinting
: V scan-word scan-word vreg boa parsed ; parsing
M: vreg pprint*
<block
\ V pprint-word [ reg-class>> pprint* ] [ n>> pprint* ] bi
block> ;
: pprint-loc ( loc word -- ) <block pprint-word n>> pprint* block> ;
: D scan-word <ds-loc> parsed ; parsing
M: ds-loc pprint* \ D pprint-loc ;
: R scan-word <rs-loc> parsed ; parsing
M: rs-loc pprint* \ R pprint-loc ;

32
basis/compiler/cfg/rpo/rpo.factor Normal file
View File

@ -0,0 +1,32 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors namespaces make math sequences sets
assocs fry compiler.cfg.instructions ;
IN: compiler.cfg.rpo
SYMBOL: visited
: post-order-traversal ( bb -- )
dup id>> visited get key? [ drop ] [
dup id>> visited get conjoin
[ successors>> [ post-order-traversal ] each ] [ , ] bi
] if ;
: post-order ( bb -- blocks )
[ post-order-traversal ] { } make ;
: number-blocks ( blocks -- )
[ >>number drop ] each-index ;
: reverse-post-order ( bb -- blocks )
H{ } clone visited [
post-order <reversed> dup number-blocks
] with-variable ; inline
: each-basic-block ( cfg quot -- )
[ entry>> reverse-post-order ] dip each ; inline
: change-basic-blocks ( cfg quot -- cfg' )
[ '[ _ change-instructions drop ] each-basic-block ]
[ drop ]
2bi ; inline

33
unfinished/compiler/cfg/stack-frame/stack-frame.factor → basis/compiler/cfg/stack-frame/stack-frame.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces accessors math.order assocs kernel sequences
make compiler.cfg.instructions compiler.cfg.instructions.syntax
combinators make cpu.architecture compiler.cfg.instructions
compiler.cfg.registers ;
IN: compiler.cfg.stack-frame
@ -9,35 +9,37 @@ SYMBOL: frame-required?
SYMBOL: spill-counts
: init-stack-frame-builder ( -- )
frame-required? off
T{ stack-frame } clone stack-frame set ;
GENERIC: compute-stack-frame* ( insn -- )
: max-stack-frame ( frame1 frame2 -- frame3 )
{
[ [ size>> ] bi@ max ]
[ [ params>> ] bi@ max ]
[ [ return>> ] bi@ max ]
[ [ total-size>> ] bi@ max ]
} cleave
stack-frame boa ;
[ stack-frame new ] 2dip
[ [ params>> ] bi@ max >>params ]
[ [ return>> ] bi@ max >>return ]
2bi ;
M: ##stack-frame compute-stack-frame*
frame-required? on
stack-frame>> stack-frame [ max-stack-frame ] change ;
M: _spill-integer compute-stack-frame*
M: ##call compute-stack-frame*
word>> sub-primitive>> [ frame-required? on ] unless ;
M: _gc compute-stack-frame*
drop frame-required? on ;
M: _spill-float compute-stack-frame*
M: _spill compute-stack-frame*
drop frame-required? on ;
M: _spill-counts compute-stack-frame*
counts>> stack-frame get (>>spill-counts) ;
M: insn compute-stack-frame* drop ;
: compute-stack-frame ( insns -- )
[ compute-stack-frame* ] each ;
frame-required? off
T{ stack-frame } clone stack-frame set
[ compute-stack-frame* ] each
stack-frame get dup stack-frame-size >>total-size drop ;
GENERIC: insert-pro/epilogues* ( insn -- )
@ -56,7 +58,6 @@ M: insn insert-pro/epilogues* , ;
: build-stack-frame ( mr -- mr )
[
init-stack-frame-builder
[
[ compute-stack-frame ]
[ insert-pro/epilogues ]

0
basis/compiler/generator/fixup/authors.txt → basis/compiler/cfg/stacks/authors.txt
View File

33
basis/compiler/cfg/stacks/stacks.factor Executable file
View File

@ -0,0 +1,33 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: math sequences kernel cpu.architecture
compiler.cfg.instructions compiler.cfg.registers
compiler.cfg.hats ;
IN: compiler.cfg.stacks
: ds-drop ( -- )
-1 ##inc-d ;
: ds-pop ( -- vreg )
D 0 ^^peek -1 ##inc-d ;
: ds-push ( vreg -- )
1 ##inc-d D 0 ##replace ;
: ds-load ( n -- vregs )
[ <reversed> [ <ds-loc> ^^peek ] map ] [ neg ##inc-d ] bi ;
: ds-store ( vregs -- )
<reversed> [ length ##inc-d ] [ [ <ds-loc> ##replace ] each-index ] bi ;
: rs-load ( n -- vregs )
[ <reversed> [ <rs-loc> ^^peek ] map ] [ neg ##inc-r ] bi ;
: rs-store ( vregs -- )
<reversed> [ length ##inc-r ] [ [ <rs-loc> ##replace ] each-index ] bi ;
: 2inputs ( -- vreg1 vreg2 )
D 1 ^^peek D 0 ^^peek -2 ##inc-d ;
: 3inputs ( -- vreg1 vreg2 vreg3 )
D 2 ^^peek D 1 ^^peek D 0 ^^peek -3 ##inc-d ;

60
basis/compiler/cfg/two-operand/two-operand.factor Normal file
View File

@ -0,0 +1,60 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays kernel sequences sequences.deep
compiler.cfg.instructions cpu.architecture ;
IN: compiler.cfg.two-operand
! On x86, instructions take the form x = x op y
! Our SSA IR is x = y op z
! We don't bother with ##add, ##add-imm or ##sub-imm since x86
! has a LEA instruction which is effectively a three-operand
! addition
: make-copy ( dst src -- insn ) f \ ##copy boa ; inline
: make-copy/float ( dst src -- insn ) f \ ##copy-float boa ; inline
: convert-two-operand/integer ( insn -- insns )
[ [ dst>> ] [ src1>> ] bi make-copy ]
[ dup dst>> >>src1 ]
bi 2array ; inline
: convert-two-operand/float ( insn -- insns )
[ [ dst>> ] [ src1>> ] bi make-copy/float ]
[ dup dst>> >>src1 ]
bi 2array ; inline
GENERIC: convert-two-operand* ( insn -- insns )
M: ##not convert-two-operand*
[ [ dst>> ] [ src>> ] bi make-copy ]
[ dup dst>> >>src ]
bi 2array ;
M: ##sub convert-two-operand* convert-two-operand/integer ;
M: ##mul convert-two-operand* convert-two-operand/integer ;
M: ##mul-imm convert-two-operand* convert-two-operand/integer ;
M: ##and convert-two-operand* convert-two-operand/integer ;
M: ##and-imm convert-two-operand* convert-two-operand/integer ;
M: ##or convert-two-operand* convert-two-operand/integer ;
M: ##or-imm convert-two-operand* convert-two-operand/integer ;
M: ##xor convert-two-operand* convert-two-operand/integer ;
M: ##xor-imm convert-two-operand* convert-two-operand/integer ;
M: ##shl-imm convert-two-operand* convert-two-operand/integer ;
M: ##shr-imm convert-two-operand* convert-two-operand/integer ;
M: ##sar-imm convert-two-operand* convert-two-operand/integer ;
M: ##add-float convert-two-operand* convert-two-operand/float ;
M: ##sub-float convert-two-operand* convert-two-operand/float ;
M: ##mul-float convert-two-operand* convert-two-operand/float ;
M: ##div-float convert-two-operand* convert-two-operand/float ;
M: insn convert-two-operand* ;
: convert-two-operand ( mr -- mr' )
[
two-operand? [
[ convert-two-operand* ] map flatten
] when
] change-instructions ;

55
basis/compiler/cfg/useless-blocks/useless-blocks.factor Normal file
View File

@ -0,0 +1,55 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors sequences combinators classes vectors
compiler.cfg compiler.cfg.rpo compiler.cfg.instructions ;
IN: compiler.cfg.useless-blocks
: update-predecessor-for-delete ( bb -- )
dup predecessors>> first [
[
2dup eq? [ drop successors>> first ] [ nip ] if
] with map
] change-successors drop ;
: update-successor-for-delete ( bb -- )
[ predecessors>> first ]
[ successors>> first predecessors>> ]
bi set-first ;
: delete-basic-block ( bb -- )
[ update-predecessor-for-delete ]
[ update-successor-for-delete ]
bi ;
: delete-basic-block? ( bb -- ? )
{
{ [ dup instructions>> length 1 = not ] [ f ] }
{ [ dup predecessors>> length 1 = not ] [ f ] }
{ [ dup successors>> length 1 = not ] [ f ] }
{ [ dup instructions>> first ##branch? not ] [ f ] }
[ t ]
} cond nip ;
: delete-useless-blocks ( cfg -- cfg' )
dup [
dup delete-basic-block? [ delete-basic-block ] [ drop ] if
] each-basic-block ;
: delete-conditional? ( bb -- ? )
dup instructions>> [ drop f ] [
peek class {
##compare-branch
##compare-imm-branch
##compare-float-branch
} memq? [ successors>> first2 eq? ] [ drop f ] if
] if-empty ;
: delete-conditional ( bb -- )
dup successors>> first 1vector >>successors
[ but-last f \ ##branch boa suffix ] change-instructions
drop ;
: delete-useless-conditionals ( cfg -- cfg' )
dup [
dup delete-conditional? [ delete-conditional ] [ drop ] if
] each-basic-block ;

25
basis/compiler/cfg/utilities/utilities.factor Normal file
View File

@ -0,0 +1,25 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel math layouts make sequences
cpu.architecture namespaces compiler.cfg
compiler.cfg.instructions ;
IN: compiler.cfg.utilities
: value-info-small-tagged? ( value-info -- ? )
literal>> dup fixnum? [ tag-fixnum small-enough? ] [ drop f ] if ;
: set-basic-block ( basic-block -- )
[ basic-block set ] [ instructions>> building set ] bi ;
: begin-basic-block ( -- )
<basic-block> basic-block get [
dupd successors>> push
] when*
set-basic-block ;
: end-basic-block ( -- )
building off
basic-block off ;
: emit-primitive ( node -- )
word>> ##call ##branch begin-basic-block ;

88
basis/compiler/cfg/value-numbering/expressions/expressions.factor Normal file
View File

@ -0,0 +1,88 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors classes kernel math namespaces combinators
compiler.cfg.instructions compiler.cfg.value-numbering.graph ;
IN: compiler.cfg.value-numbering.expressions
! Referentially-transparent expressions
TUPLE: expr op ;
TUPLE: unary-expr < expr in ;
TUPLE: binary-expr < expr in1 in2 ;
TUPLE: commutative-expr < binary-expr ;
TUPLE: compare-expr < binary-expr cc ;
TUPLE: constant-expr < expr value ;
: <constant> ( constant -- expr )
f swap constant-expr boa ; inline
M: constant-expr equal?
over constant-expr? [
[ [ value>> ] bi@ = ]
[ [ value>> class ] bi@ = ] 2bi
and
] [ 2drop f ] if ;
SYMBOL: input-expr-counter
: next-input-expr ( -- n )
input-expr-counter [ dup 1 + ] change ;
! Expressions whose values are inputs to the basic block. We
! can eliminate a second computation having the same 'n' as
! the first one; we can also eliminate input-exprs whose
! result is not used.
TUPLE: input-expr < expr n ;
: constant>vn ( constant -- vn ) <constant> expr>vn ; inline
GENERIC: >expr ( insn -- expr )
M: ##load-immediate >expr val>> <constant> ;
M: ##load-indirect >expr obj>> <constant> ;
M: ##unary >expr
[ class ] [ src>> vreg>vn ] bi unary-expr boa ;
M: ##binary >expr
[ class ] [ src1>> vreg>vn ] [ src2>> vreg>vn ] tri
binary-expr boa ;
M: ##binary-imm >expr
[ class ] [ src1>> vreg>vn ] [ src2>> constant>vn ] tri
binary-expr boa ;
M: ##commutative >expr
[ class ] [ src1>> vreg>vn ] [ src2>> vreg>vn ] tri
commutative-expr boa ;
M: ##commutative-imm >expr
[ class ] [ src1>> vreg>vn ] [ src2>> constant>vn ] tri
commutative-expr boa ;
: compare>expr ( insn -- expr )
{
[ class ]
[ src1>> vreg>vn ]
[ src2>> vreg>vn ]
[ cc>> ]
} cleave compare-expr boa ; inline
M: ##compare >expr compare>expr ;
: compare-imm>expr ( insn -- expr )
{
[ class ]
[ src1>> vreg>vn ]
[ src2>> constant>vn ]
[ cc>> ]
} cleave compare-expr boa ; inline
M: ##compare-imm >expr compare-imm>expr ;
M: ##compare-float >expr compare>expr ;
M: ##flushable >expr class next-input-expr input-expr boa ;
: init-expressions ( -- )
0 input-expr-counter set ;

19
unfinished/compiler/cfg.bluesky/vn/graph/graph.factor → basis/compiler/cfg/value-numbering/graph/graph.factor
View File

@ -1,20 +1,11 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math namespaces assocs biassocs accessors
math.order prettyprint.backend parser ;
IN: compiler.cfg.vn.graph
TUPLE: vn n ;
USING: accessors kernel math namespaces assocs biassocs ;
IN: compiler.cfg.value-numbering.graph
SYMBOL: vn-counter
: next-vn ( -- vn ) vn-counter [ dup 1 + ] change vn boa ;
: VN: scan-word vn boa parsed ; parsing
M: vn <=> [ n>> ] compare ;
M: vn pprint* \ VN: pprint-word n>> pprint* ;
: next-vn ( -- vn ) vn-counter [ dup 1 + ] change ;
! biassoc mapping expressions to value numbers
SYMBOL: exprs>vns
@ -31,6 +22,10 @@ SYMBOL: vregs>vns
: set-vn ( vn vreg -- ) vregs>vns get set-at ;
: vreg>expr ( vreg -- expr ) vreg>vn vn>expr ; inline
: vn>constant ( vn -- constant ) vn>expr value>> ; inline
: init-value-graph ( -- )
0 vn-counter set
<bihash> exprs>vns set

61
basis/compiler/cfg/value-numbering/propagate/propagate.factor Normal file
View File

@ -0,0 +1,61 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces assocs sequences kernel accessors
compiler.cfg.instructions compiler.cfg.value-numbering.graph ;
IN: compiler.cfg.value-numbering.propagate
! If two vregs compute the same value, replace references to
! the latter with the former.
: resolve ( vreg -- vreg' ) vreg>vn vn>vreg ; inline
GENERIC: propagate ( insn -- insn )
M: ##effect propagate
[ resolve ] change-src ;
M: ##unary propagate
[ resolve ] change-src ;
M: ##binary propagate
[ resolve ] change-src1
[ resolve ] change-src2 ;
M: ##binary-imm propagate
[ resolve ] change-src1 ;
M: ##slot propagate
[ resolve ] change-obj
[ resolve ] change-slot ;
M: ##slot-imm propagate
[ resolve ] change-obj ;
M: ##set-slot propagate
call-next-method
[ resolve ] change-obj
[ resolve ] change-slot ;
M: ##set-slot-imm propagate
call-next-method
[ resolve ] change-obj ;
M: ##alien-getter propagate
call-next-method
[ resolve ] change-src ;
M: ##alien-setter propagate
call-next-method
[ resolve ] change-value ;
M: ##conditional-branch propagate
[ resolve ] change-src1
[ resolve ] change-src2 ;
M: ##compare-imm-branch propagate
[ resolve ] change-src1 ;
M: ##dispatch propagate
[ resolve ] change-src ;
M: insn propagate ;

66
basis/compiler/cfg/value-numbering/rewrite/rewrite.factor Normal file
View File

@ -0,0 +1,66 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences layouts accessors combinators namespaces
math
compiler.cfg.instructions
compiler.cfg.value-numbering.graph
compiler.cfg.value-numbering.simplify
compiler.cfg.value-numbering.expressions ;
IN: compiler.cfg.value-numbering.rewrite
GENERIC: rewrite ( insn -- insn' )
M: ##mul-imm rewrite
dup src2>> dup power-of-2? [
[ [ dst>> ] [ src1>> ] bi ] [ log2 ] bi* f \ ##shl-imm boa
dup number-values
] [ drop ] if ;
: ##branch-t? ( insn -- ? )
dup ##compare-imm-branch? [
[ cc>> cc/= eq? ]
[ src2>> \ f tag-number eq? ] bi and
] [ drop f ] if ; inline
: rewrite-boolean-comparison? ( insn -- ? )
dup ##branch-t? [
src1>> vreg>expr compare-expr?
] [ drop f ] if ; inline
: >compare-expr< ( expr -- in1 in2 cc )
[ in1>> vn>vreg ] [ in2>> vn>vreg ] [ cc>> ] tri ; inline
: >compare-imm-expr< ( expr -- in1 in2 cc )
[ in1>> vn>vreg ] [ in2>> vn>constant ] [ cc>> ] tri ; inline
: rewrite-boolean-comparison ( expr -- insn )
src1>> vreg>expr dup op>> {
{ \ ##compare [ >compare-expr< f \ ##compare-branch boa ] }
{ \ ##compare-imm [ >compare-imm-expr< f \ ##compare-imm-branch boa ] }
{ \ ##compare-float [ >compare-expr< f \ ##compare-float-branch boa ] }
} case ;
: tag-fixnum-expr? ( expr -- ? )
dup op>> \ ##shl-imm eq?
[ in2>> vn>expr value>> tag-bits get = ] [ drop f ] if ;
: rewrite-tagged-comparison? ( insn -- ? )
#! Are we comparing two tagged fixnums? Then untag them.
dup ##compare-imm-branch? [
[ src1>> vreg>expr tag-fixnum-expr? ]
[ src2>> tag-mask get bitand 0 = ]
bi and
] [ drop f ] if ; inline
: rewrite-tagged-comparison ( insn -- insn' )
[ src1>> vreg>expr in1>> vn>vreg ]
[ src2>> tag-bits get neg shift ]
[ cc>> ]
tri
f \ ##compare-imm-branch boa ;
M: ##compare-imm-branch rewrite
dup rewrite-boolean-comparison? [ rewrite-boolean-comparison ] when
dup rewrite-tagged-comparison? [ rewrite-tagged-comparison ] when ;
M: insn rewrite ;

74
basis/compiler/cfg/value-numbering/simplify/simplify.factor Normal file
View File

@ -0,0 +1,74 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors combinators classes math layouts
compiler.cfg.instructions
compiler.cfg.value-numbering.graph
compiler.cfg.value-numbering.expressions ;
IN: compiler.cfg.value-numbering.simplify
! Return value of f means we didn't simplify.
GENERIC: simplify* ( expr -- vn/expr/f )
: simplify-unbox ( in boxer -- vn/expr/f )
over op>> eq? [ in>> ] [ drop f ] if ; inline
: simplify-unbox-float ( in -- vn/expr/f )
\ ##box-float simplify-unbox ; inline
: simplify-unbox-alien ( in -- vn/expr/f )
\ ##box-alien simplify-unbox ; inline
M: unary-expr simplify*
#! Note the copy propagation: a copy always simplifies to
#! its source VN.
[ in>> vn>expr ] [ op>> ] bi {
{ \ ##copy [ ] }
{ \ ##copy-float [ ] }
{ \ ##unbox-float [ simplify-unbox-float ] }
{ \ ##unbox-alien [ simplify-unbox-alien ] }
{ \ ##unbox-any-c-ptr [ simplify-unbox-alien ] }
[ 2drop f ]
} case ;
: expr-zero? ( expr -- ? ) T{ constant-expr f f 0 } = ; inline
: >binary-expr< ( expr -- in1 in2 )
[ in1>> vn>expr ] [ in2>> vn>expr ] bi ; inline
: simplify-add ( expr -- vn/expr/f )
>binary-expr< {
{ [ over expr-zero? ] [ nip ] }
{ [ dup expr-zero? ] [ drop ] }
[ 2drop f ]
} cond ; inline
: useless-shift? ( in1 in2 -- ? )
over op>> \ ##shl-imm eq?
[ [ in2>> ] [ expr>vn ] bi* = ] [ 2drop f ] if ; inline
: simplify-shift ( expr -- vn/expr/f )
>binary-expr<
2dup useless-shift? [ drop in1>> ] [ 2drop f ] if ; inline
M: binary-expr simplify*
dup op>> {
{ \ ##add [ simplify-add ] }
{ \ ##add-imm [ simplify-add ] }
{ \ ##shr-imm [ simplify-shift ] }
{ \ ##sar-imm [ simplify-shift ] }
[ 2drop f ]
} case ;
M: expr simplify* drop f ;
: simplify ( expr -- vn )
dup simplify* {
{ [ dup not ] [ drop expr>vn ] }
{ [ dup expr? ] [ expr>vn nip ] }
{ [ dup integer? ] [ nip ] }
} cond ;
GENERIC: number-values ( insn -- )
M: ##flushable number-values [ >expr simplify ] [ dst>> ] bi set-vn ;
M: insn number-values drop ;

68
basis/compiler/cfg/value-numbering/value-numbering-tests.factor Normal file
View File

@ -0,0 +1,68 @@
IN: compiler.cfg.value-numbering.tests
USING: compiler.cfg.value-numbering compiler.cfg.instructions
compiler.cfg.registers cpu.architecture tools.test kernel ;
[
{
T{ ##peek f V int-regs 45 D 1 }
T{ ##copy f V int-regs 48 V int-regs 45 }
T{ ##compare-imm-branch f V int-regs 45 7 cc/= }
}
] [
{
T{ ##peek f V int-regs 45 D 1 }
T{ ##copy f V int-regs 48 V int-regs 45 }
T{ ##compare-imm-branch f V int-regs 48 7 cc/= }
} value-numbering
] unit-test
[
{
T{ ##load-immediate f V int-regs 2 8 }
T{ ##peek f V int-regs 3 D 0 }
T{ ##slot-imm f V int-regs 4 V int-regs 3 1 3 }
T{ ##replace f V int-regs 4 D 0 }
}
] [
{
T{ ##load-immediate f V int-regs 2 8 }
T{ ##peek f V int-regs 3 D 0 }
T{ ##slot-imm f V int-regs 4 V int-regs 3 1 3 }
T{ ##replace f V int-regs 4 D 0 }
} value-numbering
] unit-test
[ t ] [
{
T{ ##peek f V int-regs 1 D 0 }
T{ ##dispatch f V int-regs 1 V int-regs 2 }
} dup value-numbering =
] unit-test
[ t ] [
{
T{ ##peek f V int-regs 16 D 0 }
T{ ##peek f V int-regs 17 D -1 }
T{ ##sar-imm f V int-regs 18 V int-regs 17 3 }
T{ ##add-imm f V int-regs 19 V int-regs 16 13 }
T{ ##add f V int-regs 21 V int-regs 18 V int-regs 19 }
T{ ##alien-unsigned-1 f V int-regs 22 V int-regs 21 }
T{ ##shl-imm f V int-regs 23 V int-regs 22 3 }
T{ ##replace f V int-regs 23 D 0 }
} dup value-numbering =
] unit-test
[
{
T{ ##peek f V int-regs 1 D 0 }
T{ ##shl-imm f V int-regs 2 V int-regs 1 3 }
T{ ##shr-imm f V int-regs 3 V int-regs 2 3 }
T{ ##replace f V int-regs 1 D 0 }
}
] [
{
T{ ##peek f V int-regs 1 D 0 }
T{ ##mul-imm f V int-regs 2 V int-regs 1 8 }
T{ ##shr-imm f V int-regs 3 V int-regs 2 3 }
T{ ##replace f V int-regs 3 D 0 }
} value-numbering
] unit-test

15
basis/compiler/cfg/value-numbering/value-numbering.factor Normal file
View File

@ -0,0 +1,15 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces assocs biassocs classes kernel math accessors
sorting sets sequences
compiler.cfg.value-numbering.graph
compiler.cfg.value-numbering.expressions
compiler.cfg.value-numbering.propagate
compiler.cfg.value-numbering.simplify
compiler.cfg.value-numbering.rewrite ;
IN: compiler.cfg.value-numbering
: value-numbering ( insns -- insns' )
init-value-graph
init-expressions
[ [ number-values ] [ rewrite propagate ] bi ] map ;

72
basis/compiler/cfg/write-barrier/write-barrier-tests.factor Normal file
View File

@ -0,0 +1,72 @@
USING: compiler.cfg.write-barrier compiler.cfg.instructions
compiler.cfg.registers cpu.architecture arrays tools.test ;
IN: compiler.cfg.write-barrier.tests
[
{
T{ ##peek f V int-regs 4 D 0 f }
T{ ##copy f V int-regs 6 V int-regs 4 f }
T{ ##allot f V int-regs 7 24 array V int-regs 8 f }
T{ ##load-immediate f V int-regs 9 8 f }
T{ ##set-slot-imm f V int-regs 9 V int-regs 7 1 3 f }
T{ ##set-slot-imm f V int-regs 6 V int-regs 7 2 3 f }
T{ ##replace f V int-regs 7 D 0 f }
}
] [
{
T{ ##peek f V int-regs 4 D 0 }
T{ ##copy f V int-regs 6 V int-regs 4 }
T{ ##allot f V int-regs 7 24 array V int-regs 8 }
T{ ##load-immediate f V int-regs 9 8 }
T{ ##set-slot-imm f V int-regs 9 V int-regs 7 1 3 }
T{ ##write-barrier f V int-regs 7 V int-regs 10 V int-regs 11 }
T{ ##set-slot-imm f V int-regs 6 V int-regs 7 2 3 }
T{ ##write-barrier f V int-regs 7 V int-regs 12 V int-regs 13 }
T{ ##replace f V int-regs 7 D 0 }
} eliminate-write-barriers
] unit-test
[
{
T{ ##load-immediate f V int-regs 4 24 }
T{ ##peek f V int-regs 5 D -1 }
T{ ##peek f V int-regs 6 D -2 }
T{ ##set-slot-imm f V int-regs 5 V int-regs 6 3 2 }
T{ ##write-barrier f V int-regs 6 V int-regs 7 V int-regs 8 }
}
] [
{
T{ ##load-immediate f V int-regs 4 24 }
T{ ##peek f V int-regs 5 D -1 }
T{ ##peek f V int-regs 6 D -2 }
T{ ##set-slot-imm f V int-regs 5 V int-regs 6 3 2 }
T{ ##write-barrier f V int-regs 6 V int-regs 7 V int-regs 8 }
} eliminate-write-barriers
] unit-test
[
{
T{ ##peek f V int-regs 19 D -3 }
T{ ##peek f V int-regs 22 D -2 }
T{ ##copy f V int-regs 23 V int-regs 19 }
T{ ##set-slot-imm f V int-regs 22 V int-regs 23 3 2 }
T{ ##write-barrier f V int-regs 23 V int-regs 24 V int-regs 25 }
T{ ##copy f V int-regs 26 V int-regs 19 }
T{ ##peek f V int-regs 28 D -1 }
T{ ##copy f V int-regs 29 V int-regs 19 }
T{ ##set-slot-imm f V int-regs 28 V int-regs 29 4 2 }
}
] [
{
T{ ##peek f V int-regs 19 D -3 }
T{ ##peek f V int-regs 22 D -2 }
T{ ##copy f V int-regs 23 V int-regs 19 }
T{ ##set-slot-imm f V int-regs 22 V int-regs 23 3 2 }
T{ ##write-barrier f V int-regs 23 V int-regs 24 V int-regs 25 }
T{ ##copy f V int-regs 26 V int-regs 19 }
T{ ##peek f V int-regs 28 D -1 }
T{ ##copy f V int-regs 29 V int-regs 19 }
T{ ##set-slot-imm f V int-regs 28 V int-regs 29 4 2 }
T{ ##write-barrier f V int-regs 29 V int-regs 30 V int-regs 3 }
} eliminate-write-barriers
] unit-test

42
basis/compiler/cfg/write-barrier/write-barrier.factor Normal file
View File

@ -0,0 +1,42 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors namespaces assocs sets sequences locals
compiler.cfg compiler.cfg.instructions compiler.cfg.copy-prop ;
IN: compiler.cfg.write-barrier
! Eliminate redundant write barrier hits.
! Objects which have already been marked, as well as
! freshly-allocated objects
SYMBOL: safe
! Objects which have been mutated
SYMBOL: mutated
GENERIC: eliminate-write-barrier ( insn -- insn' )
M: ##allot eliminate-write-barrier
dup dst>> safe get conjoin ;
M: ##write-barrier eliminate-write-barrier
dup src>> resolve dup
[ safe get key? not ]
[ mutated get key? ] bi and
[ safe get conjoin ] [ 2drop f ] if ;
M: ##copy eliminate-write-barrier
dup record-copy ;
M: ##set-slot eliminate-write-barrier
dup obj>> resolve mutated get conjoin ;
M: ##set-slot-imm eliminate-write-barrier
dup obj>> resolve mutated get conjoin ;
M: insn eliminate-write-barrier ;
: eliminate-write-barriers ( insns -- insns' )
H{ } clone safe set
H{ } clone mutated set
H{ } clone copies set
[ eliminate-write-barrier ] map sift ;

276
unfinished/compiler/codegen/codegen.factor → basis/compiler/codegen/codegen.factor
View File

@ -3,28 +3,26 @@
USING: namespaces make math math.parser sequences accessors
kernel kernel.private layouts assocs words summary arrays
combinators classes.algebra alien alien.c-types alien.structs
alien.strings sets threads libc continuations.private
alien.strings alien.arrays sets threads libc continuations.private
fry cpu.architecture
compiler.errors
compiler.alien
compiler.backend
compiler.codegen.fixup
compiler.cfg
compiler.cfg.instructions
compiler.cfg.registers
compiler.cfg.builder ;
compiler.cfg.builder
compiler.codegen.fixup ;
IN: compiler.codegen
GENERIC: generate-insn ( insn -- )
GENERIC: v>operand ( obj -- operand )
SYMBOL: registers
M: constant v>operand
value>> [ tag-fixnum ] [ \ f tag-number ] if* ;
: register ( vreg -- operand )
registers get at [ "Bad value" throw ] unless* ;
M: value v>operand
>vreg [ registers get at ] [ "Bad value" throw ] if* ;
: ?register ( obj -- operand )
dup vreg? [ register ] when ;
: generate-insns ( insns -- code )
[
@ -68,118 +66,148 @@ SYMBOL: labels
: lookup-label ( id -- label )
labels get [ drop <label> ] cache ;
M: _label generate-insn
id>> lookup-label , ;
M: ##load-immediate generate-insn
[ dst>> register ] [ val>> ] bi %load-immediate ;
M: _prologue generate-insn
stack-frame>>
[ stack-frame set ]
[ dup size>> stack-frame-size >>total-size drop ]
[ total-size>> %prologue ]
tri ;
M: _epilogue generate-insn
stack-frame>> total-size>> %epilogue ;
M: ##load-literal generate-insn
[ obj>> ] [ dst>> v>operand ] bi load-literal ;
M: ##load-indirect generate-insn
[ dst>> register ] [ obj>> ] bi %load-indirect ;
M: ##peek generate-insn
[ dst>> v>operand ] [ loc>> ] bi %peek ;
[ dst>> register ] [ loc>> ] bi %peek ;
M: ##replace generate-insn
[ src>> ] [ loc>> ] bi %replace ;
[ src>> register ] [ loc>> ] bi %replace ;
M: ##inc-d generate-insn n>> %inc-d ;
M: ##inc-r generate-insn n>> %inc-r ;
M: ##return generate-insn drop %return ;
M: ##call generate-insn word>> [ add-call ] [ %call ] bi ;
M: ##call generate-insn
word>> dup sub-primitive>>
[ first % ] [ [ add-call ] [ %call ] bi ] ?if ;
M: ##jump generate-insn word>> [ add-call ] [ %jump-label ] bi ;
SYMBOL: operands
: init-intrinsic ( insn -- )
[ defs-vregs>> ] [ uses-vregs>> ] bi append operands set ;
M: ##intrinsic generate-insn
[ init-intrinsic ] [ quot>> call ] bi ;
: (operand) ( name -- operand )
operands get at* [ "Bad operand name" throw ] unless ;
: operand ( name -- operand )
(operand) v>operand ;
: operand-class ( var -- class )
(operand) value-class ;
: operand-tag ( operand -- tag/f )
operand-class dup [ class-tag ] when ;
: operand-immediate? ( operand -- ? )
operand-class immediate class<= ;
: unique-operands ( operands quot -- )
>r [ operand ] map prune r> each ; inline
M: _if-intrinsic generate-insn
[ init-intrinsic ]
[ [ label>> lookup-label ] [ quot>> ] bi call ] bi ;
M: _branch generate-insn
label>> lookup-label %jump-label ;
M: _branch-f generate-insn
[ src>> v>operand ] [ label>> lookup-label ] bi %jump-f ;
M: _branch-t generate-insn
[ src>> v>operand ] [ label>> lookup-label ] bi %jump-t ;
M: ##return generate-insn drop %return ;
M: ##dispatch-label generate-insn label>> %dispatch-label ;
M: ##dispatch generate-insn drop %dispatch ;
M: ##dispatch generate-insn
[ src>> register ] [ temp>> register ] bi %dispatch ;
: >slot<
{
[ dst>> register ]
[ obj>> register ]
[ slot>> ?register ]
[ tag>> ]
} cleave ; inline
M: ##slot generate-insn
[ >slot< ] [ temp>> register ] bi %slot ;
M: ##slot-imm generate-insn
>slot< %slot-imm ;
: >set-slot<
{
[ src>> register ]
[ obj>> register ]
[ slot>> ?register ]
[ tag>> ]
} cleave ; inline
M: ##set-slot generate-insn
[ >set-slot< ] [ temp>> register ] bi %set-slot ;
M: ##set-slot-imm generate-insn
>set-slot< %set-slot-imm ;
: dst/src ( insn -- dst src )
[ dst>> v>operand ] [ src>> v>operand ] bi ;
[ dst>> register ] [ src>> register ] bi ; inline
M: ##copy generate-insn dst/src %copy ;
: dst/src1/src2 ( insn -- dst src1 src2 )
[ dst>> register ]
[ src1>> register ]
[ src2>> ?register ] tri ; inline
M: ##copy-float generate-insn dst/src %copy-float ;
M: ##add generate-insn dst/src1/src2 %add ;
M: ##add-imm generate-insn dst/src1/src2 %add-imm ;
M: ##sub generate-insn dst/src1/src2 %sub ;
M: ##sub-imm generate-insn dst/src1/src2 %sub-imm ;
M: ##mul generate-insn dst/src1/src2 %mul ;
M: ##mul-imm generate-insn dst/src1/src2 %mul-imm ;
M: ##and generate-insn dst/src1/src2 %and ;
M: ##and-imm generate-insn dst/src1/src2 %and-imm ;
M: ##or generate-insn dst/src1/src2 %or ;
M: ##or-imm generate-insn dst/src1/src2 %or-imm ;
M: ##xor generate-insn dst/src1/src2 %xor ;
M: ##xor-imm generate-insn dst/src1/src2 %xor-imm ;
M: ##shl-imm generate-insn dst/src1/src2 %shl-imm ;
M: ##shr-imm generate-insn dst/src1/src2 %shr-imm ;
M: ##sar-imm generate-insn dst/src1/src2 %sar-imm ;
M: ##not generate-insn dst/src %not ;
M: ##unbox-float generate-insn dst/src %unbox-float ;
: dst/src/temp ( insn -- dst src temp )
[ dst/src ] [ temp>> register ] bi ; inline
M: ##unbox-f generate-insn dst/src %unbox-f ;
M: ##integer>bignum generate-insn dst/src/temp %integer>bignum ;
M: ##bignum>integer generate-insn dst/src %bignum>integer ;
M: ##unbox-alien generate-insn dst/src %unbox-alien ;
M: ##add-float generate-insn dst/src1/src2 %add-float ;
M: ##sub-float generate-insn dst/src1/src2 %sub-float ;
M: ##mul-float generate-insn dst/src1/src2 %mul-float ;
M: ##div-float generate-insn dst/src1/src2 %div-float ;
M: ##unbox-byte-array generate-insn dst/src %unbox-byte-array ;
M: ##integer>float generate-insn dst/src %integer>float ;
M: ##float>integer generate-insn dst/src %float>integer ;
M: ##unbox-any-c-ptr generate-insn dst/src %unbox-any-c-ptr ;
M: ##copy generate-insn dst/src %copy ;
M: ##copy-float generate-insn dst/src %copy-float ;
M: ##unbox-float generate-insn dst/src %unbox-float ;
M: ##unbox-any-c-ptr generate-insn dst/src/temp %unbox-any-c-ptr ;
M: ##box-float generate-insn dst/src/temp %box-float ;
M: ##box-alien generate-insn dst/src/temp %box-alien ;
M: ##box-float generate-insn dst/src %box-float ;
M: ##alien-unsigned-1 generate-insn dst/src %alien-unsigned-1 ;
M: ##alien-unsigned-2 generate-insn dst/src %alien-unsigned-2 ;
M: ##alien-unsigned-4 generate-insn dst/src %alien-unsigned-4 ;
M: ##alien-signed-1 generate-insn dst/src %alien-signed-1 ;
M: ##alien-signed-2 generate-insn dst/src %alien-signed-2 ;
M: ##alien-signed-4 generate-insn dst/src %alien-signed-4 ;
M: ##alien-cell generate-insn dst/src %alien-cell ;
M: ##alien-float generate-insn dst/src %alien-float ;
M: ##alien-double generate-insn dst/src %alien-double ;
M: ##box-alien generate-insn dst/src %box-alien ;
: >alien-setter< [ src>> register ] [ value>> register ] bi ; inline
M: ##set-alien-integer-1 generate-insn >alien-setter< %set-alien-integer-1 ;
M: ##set-alien-integer-2 generate-insn >alien-setter< %set-alien-integer-2 ;
M: ##set-alien-integer-4 generate-insn >alien-setter< %set-alien-integer-4 ;
M: ##set-alien-cell generate-insn >alien-setter< %set-alien-cell ;
M: ##set-alien-float generate-insn >alien-setter< %set-alien-float ;
M: ##set-alien-double generate-insn >alien-setter< %set-alien-double ;
M: ##allot generate-insn
{
[ dst>> v>operand ]
[ dst>> register ]
[ size>> ]
[ type>> ]
[ tag>> ]
[ temp>> v>operand ]
[ class>> ]
[ temp>> register ]
} cleave
%allot ;
M: ##write-barrier generate-insn
[ src>> v>operand ] [ temp>> v>operand ] bi %write-barrier ;
[ src>> register ]
[ card#>> register ]
[ table>> register ]
tri %write-barrier ;
M: ##gc generate-insn drop %gc ;
M: _gc generate-insn drop %gc ;
! #alien-invoke
M: ##loop-entry generate-insn drop %loop-entry ;
! ##alien-invoke
GENERIC: reg-size ( register-class -- n )
M: int-regs reg-size drop cell ;
@ -188,6 +216,8 @@ M: single-float-regs reg-size drop 4 ;
M: double-float-regs reg-size drop 8 ;
M: stack-params reg-size drop "void*" heap-size ;
GENERIC: reg-class-variable ( register-class -- symbol )
M: reg-class reg-class-variable ;
@ -268,7 +298,7 @@ M: long-long-type flatten-value-type ( type -- types )
>r
alien-parameters
flatten-value-types
r> [ >r alloc-parameter r> execute ] curry each-parameter ;
r> '[ alloc-parameter _ execute ] each-parameter ;
inline
: unbox-parameters ( offset node -- )
@ -323,7 +353,7 @@ M: no-such-symbol compiler-error-type
: check-dlsym ( symbols dll -- )
dup dll-valid? [
dupd [ dlsym ] curry contains?
dupd '[ _ dlsym ] contains?
[ drop ] [ no-such-symbol ] if
] [
dll-path no-such-library drop
@ -399,7 +429,7 @@ TUPLE: callback-context ;
: callback-return-quot ( ctype -- quot )
return>> {
{ [ dup "void" = ] [ drop [ ] ] }
{ [ dup large-struct? ] [ heap-size [ memcpy ] curry ] }
{ [ dup large-struct? ] [ heap-size '[ _ memcpy ] ] }
[ c-type c-type-unboxer-quot ]
} cond ;
@ -416,23 +446,69 @@ TUPLE: callback-context ;
: %unnest-stacks ( -- ) "unnest_stacks" f %alien-invoke ;
: callback-unwind ( params -- n )
{
{ [ dup abi>> "stdcall" = ] [ <alien-stack-frame> size>> ] }
{ [ dup return>> large-struct? ] [ drop 4 ] }
[ drop 0 ]
} cond ;
: %callback-return ( params -- )
M: ##callback-return generate-insn
#! All the extra book-keeping for %unwind is only for x86.
#! On other platforms its an alias for %return.
dup alien-return
[ %unnest-stacks ] [ %callback-value ] if-void
callback-unwind %unwind ;
params>> %callback-return ;
M: ##alien-callback generate-insn
params>>
[ registers>objects ]
[ wrap-callback-quot %alien-callback ]
[ %callback-return ]
[ alien-return [ %unnest-stacks ] [ %callback-value ] if-void ]
tri ;
M: _prologue generate-insn
stack-frame>> [ stack-frame set ] [ total-size>> %prologue ] bi ;
M: _epilogue generate-insn
stack-frame>> total-size>> %epilogue ;
M: _label generate-insn
id>> lookup-label , ;
M: _branch generate-insn
label>> lookup-label %jump-label ;
: >compare< ( insn -- label cc src1 src2 )
{
[ dst>> register ]
[ cc>> ]
[ src1>> register ]
[ src2>> ?register ]
} cleave ; inline
M: ##compare generate-insn >compare< %compare ;
M: ##compare-imm generate-insn >compare< %compare-imm ;
M: ##compare-float generate-insn >compare< %compare-float ;
: >binary-branch< ( insn -- label cc src1 src2 )
{
[ label>> lookup-label ]
[ cc>> ]
[ src1>> register ]
[ src2>> ?register ]
} cleave ; inline
M: _compare-branch generate-insn
>binary-branch< %compare-branch ;
M: _compare-imm-branch generate-insn
>binary-branch< %compare-imm-branch ;
M: _compare-float-branch generate-insn
>binary-branch< %compare-float-branch ;
M: _spill generate-insn
[ src>> ] [ n>> ] [ class>> ] tri {
{ int-regs [ %spill-integer ] }
{ double-float-regs [ %spill-float ] }
} case ;
M: _reload generate-insn
[ dst>> ] [ n>> ] [ class>> ] tri {
{ int-regs [ %reload-integer ] }
{ double-float-regs [ %reload-float ] }
} case ;
M: _spill-counts generate-insn drop ;

0
basis/compiler/generator/registers/authors.txt → basis/compiler/codegen/fixup/authors.txt
View File

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

@ -4,7 +4,7 @@ USING: arrays byte-arrays generic assocs hashtables io.binary
kernel kernel.private math namespaces make sequences words
quotations strings alien.accessors alien.strings layouts system
combinators math.bitwise words.private math.order accessors
growable compiler.constants compiler.backend ;
growable cpu.architecture compiler.constants ;
IN: compiler.codegen.fixup
GENERIC: fixup* ( obj -- )
@ -43,9 +43,10 @@ M: rel-fixup fixup*
M: integer fixup* , ;
: indq ( elt seq -- n ) [ eq? ] with find drop ;
: adjoin* ( obj table -- n )
2dup swap [ eq? ] curry find drop
[ 2nip ] [ dup length >r push r> ] if* ;
2dup indq [ 2nip ] [ dup length >r push r> ] if* ;
SYMBOL: literal-table

0
basis/compiler/generator/fixup/summary.txt → basis/compiler/codegen/fixup/summary.txt
View File

5
basis/compiler/compiler-docs.factor
View File

@ -1,4 +1,4 @@
USING: compiler.generator help.markup help.syntax words io parser
USING: help.markup help.syntax words io parser
assocs words.private sequences compiler.units ;
IN: compiler
@ -27,8 +27,7 @@ ARTICLE: "compiler" "Optimizing compiler"
"The optimizing compiler only compiles words which have a static stack effect. This means that methods defined on fundamental generic words such as " { $link nth } " should have a static stack effect; for otherwise, most of the system would be compiled with the non-optimizing compiler. See " { $link "inference" } " and " { $link "cookbook-pitfalls" } "."
{ $subsection "compiler-usage" }
{ $subsection "compiler-errors" }
{ $subsection "hints" }
{ $subsection "generator" } ;
{ $subsection "hints" } ;
ABOUT: "compiler"

80
basis/compiler/compiler.factor
View File

@ -1,12 +1,32 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces arrays sequences io debugger words fry
compiler.units continuations vocabs assocs dlists definitions
math threads graphs generic combinators deques search-deques
stack-checker stack-checker.state compiler.generator
compiler.errors compiler.tree.builder compiler.tree.optimizer ;
USING: accessors kernel namespaces arrays sequences io debugger
words fry continuations vocabs assocs dlists definitions math
threads graphs generic combinators deques search-deques
prettyprint io stack-checker stack-checker.state
stack-checker.inlining compiler.errors compiler.units
compiler.tree.builder compiler.tree.optimizer
compiler.cfg.builder compiler.cfg.optimizer
compiler.cfg.linearization compiler.cfg.two-operand
compiler.cfg.linear-scan compiler.cfg.stack-frame
compiler.codegen ;
IN: compiler
SYMBOL: compile-queue
SYMBOL: compiled
: queue-compile ( word -- )
{
{ [ dup "forgotten" word-prop ] [ ] }
{ [ dup compiled get key? ] [ ] }
{ [ dup inlined-block? ] [ ] }
{ [ dup primitive? ] [ ] }
[ dup compile-queue get push-front ]
} cond drop ;
: maybe-compile ( word -- )
dup compiled>> [ drop ] [ queue-compile ] if ;
SYMBOL: +failed+
: ripple-up ( words -- )
@ -24,10 +44,13 @@ SYMBOL: +failed+
[ "compiled-effect" set-word-prop ]
2bi ;
: compile-begins ( word -- )
: start ( word -- )
"trace-compilation" get [ dup . flush ] when
H{ } clone dependencies set
H{ } clone generic-dependencies set
f swap compiler-error ;
: compile-failed ( word error -- )
: fail ( word error -- )
[ swap compiler-error ]
[
drop
@ -35,9 +58,34 @@ SYMBOL: +failed+
[ f swap compiled get set-at ]
[ +failed+ save-effect ]
tri
] 2bi ;
] 2bi
return ;
: compile-succeeded ( effect word -- )
: frontend ( word -- effect nodes )
[ build-tree-from-word ] [ fail ] recover optimize-tree ;
! Only switch this off for debugging.
SYMBOL: compile-dependencies?
t compile-dependencies? set-global
: save-asm ( asm -- )
[ [ code>> ] [ label>> ] bi compiled get set-at ]
[ compile-dependencies? get [ calls>> [ maybe-compile ] each ] [ drop ] if ]
bi ;
: backend ( nodes word -- )
build-cfg [
optimize-cfg
build-mr
convert-two-operand
linear-scan
build-stack-frame
generate
save-asm
] each ;
: finish ( effect word -- )
[ swap save-effect ]
[ compiled-unxref ]
[
@ -51,17 +99,11 @@ SYMBOL: +failed+
: (compile) ( word -- )
'[
H{ } clone dependencies set
H{ } clone generic-dependencies set
_ {
[ compile-begins ]
[
[ build-tree-from-word ] [ compile-failed return ] recover
optimize-tree
]
[ dup generate ]
[ compile-succeeded ]
[ start ]
[ frontend ]
[ backend ]
[ finish ]
} cleave
] with-return ;

19
basis/compiler/generator/fixup/fixup-docs.factor
View File

@ -1,19 +0,0 @@
USING: help.syntax help.markup math kernel
words strings alien compiler.generator ;
IN: compiler.generator.fixup
HELP: frame-required
{ $values { "n" "a non-negative integer" } }
{ $description "Notify the code generator that the currently compiling code block needs a stack frame with room for at least " { $snippet "n" } " parameters." } ;
HELP: add-literal
{ $values { "obj" object } { "n" integer } }
{ $description "Adds a literal to the " { $link literal-table } ", if it is not already there, and outputs the index of the literal in the table. This literal can then be used as an argument for a " { $link rt-literal } " relocation with " { $link rel-fixup } "." } ;
HELP: rel-dlsym
{ $values { "name" string } { "dll" "a " { $link dll } " or " { $link f } } { "class" "a relocation class" } }
{ $description "Records that the most recently assembled instruction contains a reference to the " { $snippet "name" } " symbol from " { $snippet "dll" } ". The correct " { $snippet "class" } " to use depends on instruction formats."
} ;
HELP: literal-table
{ $var-description "Holds a vector of literal objects referenced from the currently compiling word. If " { $link compiled-stack-traces? } " is on, " { $link begin-compiling } " ensures that the first entry is the word being compiled." } ;

154
basis/compiler/generator/fixup/fixup.factor
View File

@ -1,154 +0,0 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays byte-arrays generic assocs hashtables io.binary
kernel kernel.private math namespaces make sequences words
quotations strings alien.accessors alien.strings layouts system
combinators math.bitwise words.private cpu.architecture
math.order accessors growable ;
IN: compiler.generator.fixup
: no-stack-frame -1 ; inline
TUPLE: frame-required n ;
: frame-required ( n -- ) \ frame-required boa , ;
: compute-stack-frame-size ( code -- n )
no-stack-frame [
dup frame-required? [ n>> max ] [ drop ] if
] reduce ;
GENERIC: fixup* ( frame-size obj -- frame-size )
: code-format 22 getenv ;
: compiled-offset ( -- n ) building get length code-format * ;
TUPLE: label offset ;
: <label> ( -- label ) label new ;
M: label fixup*
compiled-offset >>offset drop ;
: define-label ( name -- ) <label> swap set ;
: resolve-label ( label/name -- ) dup label? [ get ] unless , ;
: if-stack-frame ( frame-size quot -- )
swap dup no-stack-frame =
[ 2drop ] [ stack-frame-size swap call ] if ; inline
M: word fixup*
{
{ \ %prologue-later [ dup [ %prologue ] if-stack-frame ] }
{ \ %epilogue-later [ dup [ %epilogue ] if-stack-frame ] }
} case ;
SYMBOL: relocation-table
SYMBOL: label-table
! Relocation classes
: rc-absolute-cell 0 ;
: rc-absolute 1 ;
: rc-relative 2 ;
: rc-absolute-ppc-2/2 3 ;
: rc-relative-ppc-2 4 ;
: rc-relative-ppc-3 5 ;
: rc-relative-arm-3 6 ;
: rc-indirect-arm 7 ;
: rc-indirect-arm-pc 8 ;
: rc-absolute? ( n -- ? )
dup rc-absolute-cell =
over rc-absolute =
rot rc-absolute-ppc-2/2 = or or ;
! Relocation types
: rt-primitive 0 ;
: rt-dlsym 1 ;
: rt-literal 2 ;
: rt-dispatch 3 ;
: rt-xt 4 ;
: rt-here 5 ;
: rt-label 6 ;
: rt-immediate 7 ;
TUPLE: label-fixup label class ;
: label-fixup ( label class -- ) \ label-fixup boa , ;
M: label-fixup fixup*
dup class>> rc-absolute?
[ "Absolute labels not supported" throw ] when
dup label>> swap class>> compiled-offset 4 - rot
3array label-table get push ;
TUPLE: rel-fixup arg class type ;
: rel-fixup ( arg class type -- ) \ rel-fixup boa , ;
: push-4 ( value vector -- )
[ length ] [ B{ 0 0 0 0 } swap push-all ] [ underlying>> ] tri
swap set-alien-unsigned-4 ;
M: rel-fixup fixup*
[ [ arg>> ] [ class>> ] [ type>> ] tri { 0 8 16 } bitfield ]
[ class>> rc-absolute-cell = cell 4 ? compiled-offset swap - ] bi
[ relocation-table get push-4 ] bi@ ;
M: frame-required fixup* drop ;
M: integer fixup* , ;
: adjoin* ( obj table -- n )
2dup swap [ eq? ] curry find drop
[ 2nip ] [ dup length >r push r> ] if* ;
SYMBOL: literal-table
: add-literal ( obj -- n ) literal-table get adjoin* ;
: add-dlsym-literals ( symbol dll -- )
>r string>symbol r> 2array literal-table get push-all ;
: rel-dlsym ( name dll class -- )
>r literal-table get length >r
add-dlsym-literals
r> r> rt-dlsym rel-fixup ;
: rel-word ( word class -- )
>r add-literal r> rt-xt rel-fixup ;
: rel-primitive ( word class -- )
>r def>> first r> rt-primitive rel-fixup ;
: rel-literal ( literal class -- )
>r add-literal r> rt-literal rel-fixup ;
: rel-this ( class -- )
0 swap rt-label rel-fixup ;
: rel-here ( class -- )
0 swap rt-here rel-fixup ;
: init-fixup ( -- )
BV{ } clone relocation-table set
V{ } clone label-table set ;
: resolve-labels ( labels -- labels' )
[
first3 offset>>
[ "Unresolved label" throw ] unless*
3array
] map concat ;
: fixup ( code -- literals relocation labels code )
[
init-fixup
dup compute-stack-frame-size swap [ fixup* ] each drop
literal-table get >array
relocation-table get >byte-array
label-table get resolve-labels
] { } make ;

85
basis/compiler/generator/generator-docs.factor
View File

@ -1,85 +0,0 @@
USING: help.markup help.syntax words debugger
compiler.generator.fixup compiler.generator.registers quotations
kernel vectors arrays effects sequences ;
IN: compiler.generator
ARTICLE: "generator" "Compiled code generator"
"Most of the words in the " { $vocab-link "compiler.generator" } " vocabulary are internal to the compiler and user code has no reason to call them."
$nl
"Debugging information can be enabled or disabled; this hook is used by " { $link "tools.deploy" } ":"
{ $subsection compiled-stack-traces? }
"Assembler intrinsics can be defined for low-level optimization:"
{ $subsection define-intrinsic }
{ $subsection define-intrinsics }
{ $subsection define-if-intrinsic }
{ $subsection define-if-intrinsics }
"The main entry point into the code generator:"
{ $subsection generate } ;
ABOUT: "generator"
HELP: compiled
{ $var-description "During compilation, holds a hashtable mapping words to 5-element arrays holding compiled code." } ;
HELP: compiling-word
{ $var-description "The word currently being compiled, set by " { $link with-generator } "." } ;
HELP: compiling-label
{ $var-description "The label currently being compiled, set by " { $link with-generator } "." } ;
HELP: compiled-stack-traces?
{ $values { "?" "a boolean" } }
{ $description "Iftrue, compiled code blocks will retain what word they were compiled from. This information is used by " { $link :c } " to display call stack traces after an error is thrown from compiled code. This is on by default; the deployment tool switches it off to save some space in the deployed image." } ;
HELP: begin-compiling
{ $values { "word" word } { "label" word } }
{ $description "Prepares to generate machine code for a word." } ;
HELP: with-generator
{ $values { "nodes" "a sequence of nodes" } { "word" word } { "label" word } { "quot" "a quotation with stack effect " { $snippet "( node -- )" } } }
{ $description "Generates machine code for " { $snippet "label" } " by applying the quotation to the sequence of nodes." } ;
HELP: generate-node
{ $values { "node" "a dataflow node" } { "next" "a dataflow node" } }
{ $contract "Generates machine code for a dataflow node, and outputs the next node to generate machine code for." }
{ $notes "This word can only be called from inside the quotation passed to " { $link with-generator } "." } ;
HELP: generate-nodes
{ $values { "nodes" "a sequence of nodes" } }
{ $description "Recursively generate machine code for a dataflow graph." }
{ $notes "This word can only be called from inside the quotation passed to " { $link with-generator } "." } ;
HELP: generate
{ $values { "word" word } { "label" word } { "nodes" "a sequence of nodes" } }
{ $description "Generates machine code for " { $snippet "label" } " from " { $snippet "nodes" } ". The value of " { $snippet "word" } " is retained for debugging purposes; it is the word which will appear in a call stack trace if this compiled code block throws an error when run." } ;
HELP: define-intrinsics
{ $values { "word" word } { "intrinsics" "a sequence of " { $snippet "{ quot assoc }" } " pairs" } }
{ $description "Defines a set of assembly intrinsics for the word. When a call to the word is being compiled, each intrinsic is tested in turn; the first applicable one will be called to generate machine code. If no suitable intrinsic is found, a simple call to the word is compiled instead."
$nl
"See " { $link with-template } " for an explanation of the keys which may appear in " { $snippet "assoc" } "." } ;
HELP: define-intrinsic
{ $values { "word" word } { "quot" quotation } { "assoc" "an assoc" } }
{ $description "Defines an assembly intrinsic for the word. When a call to the word is being compiled, this intrinsic will be used if it is found to be applicable. If it is not applicable, a simple call to the word is compiled instead."
$nl
"See " { $link with-template } " for an explanation of the keys which may appear in " { $snippet "assoc" } "." } ;
HELP: if>boolean-intrinsic
{ $values { "quot" "a quotation with stack effect " { $snippet "( label -- )" } } }
{ $description "Generates code which pushes " { $link t } " or " { $link f } " on the data stack, depending on whether the quotation jumps to the label or not." } ;
HELP: define-if-intrinsics
{ $values { "word" word } { "intrinsics" "a sequence of " { $snippet "{ quot inputs }" } " pairs" } }
{ $description "Defines a set of conditional assembly intrinsics for the word, which must have a boolean value as its single output."
$nl
"The quotations must have stack effect " { $snippet "( label -- )" } "; they are required to branch to the label if the word evaluates to true."
$nl
"The " { $snippet "inputs" } " are in the same format as the " { $link +input+ } " key to " { $link with-template } "; a description can be found in the documentation for thatt word." }
{ $notes "Conditional intrinsics are used when the word is followed by a call to " { $link if } ". They allow for tighter code to be generated in certain situations; for example, if two integers are being compared and the result is immediately used to branch, the intermediate boolean does not need to be pushed at all." } ;
HELP: define-if-intrinsic
{ $values { "word" word } { "quot" "a quotation with stack effect " { $snippet "( label -- )" } } { "inputs" "a sequence of input register specifiers" } }
{ $description "Defines a conditional assembly intrinsic for the word, which must have a boolean value as its single output."
$nl
"See " { $link define-if-intrinsics } " for a description of the parameters." } ;

581
basis/compiler/generator/generator.factor
View File

@ -1,581 +0,0 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs classes combinators
cpu.architecture effects generic hashtables io kernel
kernel.private layouts math math.parser namespaces make
prettyprint quotations sequences system threads words vectors
sets deques continuations.private summary alien alien.c-types
alien.structs alien.strings alien.arrays libc compiler.errors
stack-checker.inlining compiler.tree compiler.tree.builder
compiler.tree.combinators compiler.tree.propagation.info
compiler.generator.fixup compiler.generator.registers
compiler.generator.iterator ;
IN: compiler.generator
SYMBOL: compile-queue
SYMBOL: compiled
: queue-compile ( word -- )
{
{ [ dup "forgotten" word-prop ] [ ] }
{ [ dup compiled get key? ] [ ] }
{ [ dup inlined-block? ] [ ] }
{ [ dup primitive? ] [ ] }
[ dup compile-queue get push-front ]
} cond drop ;
: maybe-compile ( word -- )
dup compiled>> [ drop ] [ queue-compile ] if ;
SYMBOL: compiling-word
SYMBOL: compiling-label
SYMBOL: compiling-loops
! Label of current word, after prologue, makes recursion faster
SYMBOL: current-label-start
: compiled-stack-traces? ( -- ? ) 59 getenv ;
: begin-compiling ( word label -- )
H{ } clone compiling-loops set
compiling-label set
compiling-word set
compiled-stack-traces?
compiling-word get f ?
1vector literal-table set
f compiling-label get compiled get set-at ;
: save-machine-code ( literals relocation labels code -- )
4array compiling-label get compiled get set-at ;
: with-generator ( nodes word label quot -- )
[
>r begin-compiling r>
{ } make fixup
save-machine-code
] with-scope ; inline
GENERIC: generate-node ( node -- next )
: generate-nodes ( nodes -- )
[ current-node generate-node ] iterate-nodes
end-basic-block ;
: init-generate-nodes ( -- )
init-templates
%save-word-xt
%prologue-later
current-label-start define-label
current-label-start resolve-label ;
: generate ( nodes word label -- )
[
init-generate-nodes
[ generate-nodes ] with-node-iterator
] with-generator ;
: intrinsics ( #call -- quot )
word>> "intrinsics" word-prop ;
: if-intrinsics ( #call -- quot )
word>> "if-intrinsics" word-prop ;
! node
M: node generate-node drop iterate-next ;
: %jump ( word -- )
dup compiling-label get eq?
[ drop current-label-start get ] [ %epilogue-later ] if
%jump-label ;
: generate-call ( label -- next )
dup maybe-compile
end-basic-block
dup compiling-loops get at [
%jump-label f
] [
tail-call? [
%jump f
] [
0 frame-required
%call
iterate-next
] if
] ?if ;
! #recursive
: compile-recursive ( node -- next )
dup label>> id>> generate-call >r
[ child>> ] [ label>> word>> ] [ label>> id>> ] tri generate
r> ;
: compiling-loop ( word -- )
<label> dup resolve-label swap compiling-loops get set-at ;
: compile-loop ( node -- next )
end-basic-block
[ label>> id>> compiling-loop ] [ child>> generate-nodes ] bi
iterate-next ;
M: #recursive generate-node
dup label>> loop?>> [ compile-loop ] [ compile-recursive ] if ;
! #if
: end-false-branch ( label -- )
tail-call? [ %return drop ] [ %jump-label ] if ;
: generate-branch ( nodes -- )
[ copy-templates generate-nodes ] with-scope ;
: generate-if ( node label -- next )
<label> [
>r >r children>> first2 swap generate-branch
r> r> end-false-branch resolve-label
generate-branch
init-templates
] keep resolve-label iterate-next ;
M: #if generate-node
[ <label> dup %jump-f ]
H{ { +input+ { { f "flag" } } } }
with-template
generate-if ;
! #dispatch
: dispatch-branch ( nodes word -- label )
gensym [
[
copy-templates
%save-dispatch-xt
%prologue-later
[ generate-nodes ] with-node-iterator
%return
] with-generator
] keep ;
: dispatch-branches ( node -- )
children>> [
compiling-word get dispatch-branch
%dispatch-label
] each ;
: generate-dispatch ( node -- )
%dispatch dispatch-branches init-templates ;
M: #dispatch generate-node
#! The order here is important, dispatch-branches must
#! run after %dispatch, so that each branch gets the
#! correct register state
tail-call? [
generate-dispatch iterate-next
] [
compiling-word get gensym [
[
init-generate-nodes
generate-dispatch
] with-generator
] keep generate-call
] if ;
! #call
: define-intrinsics ( word intrinsics -- )
"intrinsics" set-word-prop ;
: define-intrinsic ( word quot assoc -- )
2array 1array define-intrinsics ;
: define-if>branch-intrinsics ( word intrinsics -- )
"if-intrinsics" set-word-prop ;
: if>boolean-intrinsic ( quot -- )
"false" define-label
"end" define-label
"false" get swap call
t "if-scratch" get load-literal
"end" get %jump-label
"false" resolve-label
f "if-scratch" get load-literal
"end" resolve-label
"if-scratch" get phantom-push ; inline
: define-if>boolean-intrinsics ( word intrinsics -- )
[
>r [ if>boolean-intrinsic ] curry r>
{ { f "if-scratch" } } +scratch+ associate assoc-union
] assoc-map "intrinsics" set-word-prop ;
: define-if-intrinsics ( word intrinsics -- )
[ +input+ associate ] assoc-map
2dup define-if>branch-intrinsics
define-if>boolean-intrinsics ;
: define-if-intrinsic ( word quot inputs -- )
2array 1array define-if-intrinsics ;
: do-if-intrinsic ( pair -- next )
<label> [ swap do-template skip-next ] keep generate-if ;
: find-intrinsic ( #call -- pair/f )
intrinsics find-template ;
: find-if-intrinsic ( #call -- pair/f )
node@ {
{ [ dup length 2 < ] [ 2drop f ] }
{ [ dup second #if? ] [ drop if-intrinsics find-template ] }
[ 2drop f ]
} cond ;
M: #call generate-node
dup node-input-infos [ class>> ] map set-operand-classes
dup find-if-intrinsic [
do-if-intrinsic
] [
dup find-intrinsic [
do-template iterate-next
] [
word>> generate-call
] ?if
] ?if ;
! #call-recursive
M: #call-recursive generate-node label>> id>> generate-call ;
! #push
M: #push generate-node
literal>> <constant> phantom-push iterate-next ;
! #shuffle
M: #shuffle generate-node
shuffle-effect phantom-shuffle iterate-next ;
M: #>r generate-node
[ in-d>> length ] [ out-r>> empty? ] bi
[ phantom-drop ] [ phantom->r ] if
iterate-next ;
M: #r> generate-node
[ in-r>> length ] [ out-d>> empty? ] bi
[ phantom-rdrop ] [ phantom-r> ] if
iterate-next ;
! #return
M: #return generate-node
drop end-basic-block %return f ;
M: #return-recursive generate-node
end-basic-block
label>> id>> compiling-loops get key?
[ %return ] unless f ;
! #alien-invoke
: large-struct? ( ctype -- ? )
dup c-struct? [ struct-small-enough? not ] [ drop f ] if ;
: alien-parameters ( params -- seq )
dup parameters>>
swap return>> large-struct? [ "void*" prefix ] when ;
: alien-return ( params -- ctype )
return>> dup large-struct? [ drop "void" ] when ;
: c-type-stack-align ( type -- align )
dup c-type-stack-align? [ c-type-align ] [ drop cell ] if ;
: parameter-align ( n type -- n delta )
over >r c-type-stack-align align dup r> - ;
: parameter-sizes ( types -- total offsets )
#! Compute stack frame locations.
[
0 [
[ parameter-align drop dup , ] keep stack-size +
] reduce cell align
] { } make ;
: return-size ( ctype -- n )
#! Amount of space we reserve for a return value.
dup large-struct? [ heap-size ] [ drop 2 cells ] if ;
: alien-stack-frame ( params -- n )
stack-frame new
swap
[ return>> return-size >>return ]
[ alien-parameters parameter-sizes drop >>params ] bi
dup [ params>> ] [ return>> ] bi + >>size
dup size>> stack-frame-size >>total-size ;
: with-stack-frame ( params quot -- )
swap alien-stack-frame [ size>> frame-required ] [ stack-frame set ] bi
call
stack-frame off ; inline
GENERIC: reg-size ( register-class -- n )
M: int-regs reg-size drop cell ;
M: single-float-regs reg-size drop 4 ;
M: double-float-regs reg-size drop 8 ;
M: stack-params reg-size drop "void*" heap-size ;
GENERIC: reg-class-variable ( register-class -- symbol )
M: reg-class reg-class-variable ;
M: float-regs reg-class-variable drop float-regs ;
M: stack-params reg-class-variable drop stack-params ;
GENERIC: inc-reg-class ( register-class -- )
M: reg-class inc-reg-class
dup reg-class-variable inc
fp-shadows-int? [ reg-size stack-params +@ ] [ drop ] if ;
M: float-regs inc-reg-class
dup call-next-method
fp-shadows-int? [ reg-size cell /i int-regs +@ ] [ drop ] if ;
: reg-class-full? ( class -- ? )
[ reg-class-variable get ] [ param-regs length ] bi >= ;
: spill-param ( reg-class -- n reg-class )
stack-params get
>r reg-size stack-params +@ r>
stack-params ;
: fastcall-param ( reg-class -- n reg-class )
[ reg-class-variable get ] [ inc-reg-class ] [ ] tri ;
: alloc-parameter ( parameter -- reg reg-class )
c-type-reg-class dup reg-class-full?
[ spill-param ] [ fastcall-param ] if
[ param-reg ] keep ;
: (flatten-int-type) ( size -- types )
cell /i "void*" c-type <repetition> ;
GENERIC: flatten-value-type ( type -- types )
M: object flatten-value-type 1array ;
M: struct-type flatten-value-type ( type -- types )
stack-size cell align (flatten-int-type) ;
M: long-long-type flatten-value-type ( type -- types )
stack-size cell align (flatten-int-type) ;
: flatten-value-types ( params -- params )
#! Convert value type structs to consecutive void*s.
[
0 [
c-type
[ parameter-align (flatten-int-type) % ] keep
[ stack-size cell align + ] keep
flatten-value-type %
] reduce drop
] { } make ;
: each-parameter ( parameters quot -- )
>r [ parameter-sizes nip ] keep r> 2each ; inline
: reverse-each-parameter ( parameters quot -- )
>r [ parameter-sizes nip ] keep r> 2reverse-each ; inline
: reset-freg-counts ( -- )
{ int-regs float-regs stack-params } [ 0 swap set ] each ;
: with-param-regs ( quot -- )
#! In quot you can call alloc-parameter
[ reset-freg-counts call ] with-scope ; inline
: move-parameters ( node word -- )
#! Moves values from C stack to registers (if word is
#! %load-param-reg) and registers to C stack (if word is
#! %save-param-reg).
>r
alien-parameters
flatten-value-types
r> [ >r alloc-parameter r> execute ] curry each-parameter ;
inline
: unbox-parameters ( offset node -- )
parameters>> [
%prepare-unbox >r over + r> unbox-parameter
] reverse-each-parameter drop ;
: prepare-box-struct ( node -- offset )
#! Return offset on C stack where to store unboxed
#! parameters. If the C function is returning a structure,
#! the first parameter is an implicit target area pointer,
#! so we need to use a different offset.
return>> large-struct?
[ %prepare-box-struct cell ] [ 0 ] if ;
: objects>registers ( params -- )
#! Generate code for unboxing a list of C types, then
#! generate code for moving these parameters to register on
#! architectures where parameters are passed in registers.
[
[ prepare-box-struct ] keep
[ unbox-parameters ] keep
\ %load-param-reg move-parameters
] with-param-regs ;
: box-return* ( node -- )
return>> [ ] [ box-return ] if-void ;
TUPLE: no-such-library name ;
M: no-such-library summary
drop "Library not found" ;
M: no-such-library compiler-error-type
drop +linkage+ ;
: no-such-library ( name -- )
\ no-such-library boa
compiling-word get compiler-error ;
TUPLE: no-such-symbol name ;
M: no-such-symbol summary
drop "Symbol not found" ;
M: no-such-symbol compiler-error-type
drop +linkage+ ;
: no-such-symbol ( name -- )
\ no-such-symbol boa
compiling-word get compiler-error ;
: check-dlsym ( symbols dll -- )
dup dll-valid? [
dupd [ dlsym ] curry contains?
[ drop ] [ no-such-symbol ] if
] [
dll-path no-such-library drop
] if ;
: stdcall-mangle ( symbol node -- symbol )
"@"
swap parameters>> parameter-sizes drop
number>string 3append ;
: alien-invoke-dlsym ( params -- symbols dll )
dup function>> dup pick stdcall-mangle 2array
swap library>> library dup [ dll>> ] when
2dup check-dlsym ;
M: #alien-invoke generate-node
params>>
dup [
end-basic-block
%prepare-alien-invoke
dup objects>registers
%prepare-var-args
dup alien-invoke-dlsym %alien-invoke
dup %cleanup
box-return*
iterate-next
] with-stack-frame ;
! #alien-indirect
M: #alien-indirect generate-node
params>>
dup [
! Flush registers
end-basic-block
! Save registers for GC
%prepare-alien-invoke
! Save alien at top of stack to temporary storage
%prepare-alien-indirect
dup objects>registers
%prepare-var-args
! Call alien in temporary storage
%alien-indirect
dup %cleanup
box-return*
iterate-next
] with-stack-frame ;
! #alien-callback
: box-parameters ( params -- )
alien-parameters [ box-parameter ] each-parameter ;
: registers>objects ( node -- )
[
dup \ %save-param-reg move-parameters
"nest_stacks" f %alien-invoke
box-parameters
] with-param-regs ;
TUPLE: callback-context ;
: current-callback 2 getenv ;
: wait-to-return ( token -- )
dup current-callback eq? [
drop
] [
yield wait-to-return
] if ;
: do-callback ( quot token -- )
init-catchstack
dup 2 setenv
slip
wait-to-return ; inline
: callback-return-quot ( ctype -- quot )
return>> {
{ [ dup "void" = ] [ drop [ ] ] }
{ [ dup large-struct? ] [ heap-size [ memcpy ] curry ] }
[ c-type c-type-unboxer-quot ]
} cond ;
: callback-prep-quot ( params -- quot )
parameters>> [ c-type c-type-boxer-quot ] map spread>quot ;
: wrap-callback-quot ( params -- quot )
[
[ callback-prep-quot ]
[ quot>> ]
[ callback-return-quot ] tri 3append ,
[ callback-context new do-callback ] %
] [ ] make ;
: %unnest-stacks ( -- ) "unnest_stacks" f %alien-invoke ;
: callback-unwind ( params -- n )
{
{ [ dup abi>> "stdcall" = ] [ drop stack-frame get params>> ] }
{ [ dup return>> large-struct? ] [ drop 4 ] }
[ drop 0 ]
} cond ;
: %callback-return ( params -- )
#! All the extra book-keeping for %unwind is only for x86.
#! On other platforms its an alias for %return.
dup alien-return
[ %unnest-stacks ] [ %callback-value ] if-void
callback-unwind %unwind ;
: generate-callback ( params -- )
dup xt>> dup [
init-templates
%prologue-later
dup [
[ registers>objects ]
[ wrap-callback-quot %alien-callback ]
[ %callback-return ]
tri
] with-stack-frame
] with-generator ;
M: #alien-callback generate-node
end-basic-block
params>> generate-callback iterate-next ;

45
basis/compiler/generator/iterator/iterator.factor
View File

@ -1,45 +0,0 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces sequences kernel compiler.tree ;
IN: compiler.generator.iterator
SYMBOL: node-stack
: >node ( cursor -- ) node-stack get push ;
: node> ( -- cursor ) node-stack get pop ;
: node@ ( -- cursor ) node-stack get peek ;
: current-node ( -- node ) node@ first ;
: iterate-next ( -- cursor ) node@ rest-slice ;
: skip-next ( -- next ) node> rest-slice [ first ] [ >node ] bi ;
: iterate-nodes ( cursor quot: ( -- ) -- )
over empty? [
2drop
] [
[ swap >node call node> drop ] keep iterate-nodes
] if ; inline recursive
: with-node-iterator ( quot -- )
>r V{ } clone node-stack r> with-variable ; inline
DEFER: (tail-call?)
: tail-phi? ( cursor -- ? )
[ first #phi? ] [ rest-slice (tail-call?) ] bi and ;
: (tail-call?) ( cursor -- ? )
[ t ] [
[ first [ #return? ] [ #terminate? ] bi or ]
[ tail-phi? ]
bi or
] if-empty ;
: tail-call? ( -- ? )
node-stack get [
rest-slice
[ t ] [
[ (tail-call?) ]
[ first #terminate? not ]
bi and
] if-empty
] all? ;

672
basis/compiler/generator/registers/registers.factor
View File

@ -1,672 +0,0 @@
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs classes classes.private classes.algebra
combinators hashtables kernel layouts math namespaces make
quotations sequences system vectors words effects alien
byte-arrays accessors sets math.order cpu.architecture
compiler.generator.fixup ;
IN: compiler.generator.registers
SYMBOL: +input+
SYMBOL: +output+
SYMBOL: +scratch+
SYMBOL: +clobber+
SYMBOL: known-tag
<PRIVATE
! Value protocol
GENERIC: set-operand-class ( class obj -- )
GENERIC: operand-class* ( operand -- class )
GENERIC: move-spec ( obj -- spec )
GENERIC: live-vregs* ( obj -- )
GENERIC: live-loc? ( actual current -- ? )
GENERIC# (lazy-load) 1 ( value spec -- value )
GENERIC: lazy-store ( dst src -- )
GENERIC: minimal-ds-loc* ( min obj -- min )
! This will be a multimethod soon
DEFER: %move
MIXIN: value
PRIVATE>
: operand-class ( operand -- class )
operand-class* object or ;
! Default implementation
M: value set-operand-class 2drop ;
M: value operand-class* drop f ;
M: value live-vregs* drop ;
M: value live-loc? 2drop f ;
M: value minimal-ds-loc* drop ;
M: value lazy-store 2drop ;
! A scratch register for computations
TUPLE: vreg n reg-class ;
C: <vreg> vreg ( n reg-class -- vreg )
M: vreg v>operand [ n>> ] [ reg-class>> ] bi vregs nth ;
M: vreg live-vregs* , ;
M: vreg move-spec
reg-class>> {
{ [ dup int-regs? ] [ f ] }
{ [ dup float-regs? ] [ float ] }
} cond nip ;
M: vreg operand-class*
reg-class>> {
{ [ dup int-regs? ] [ f ] }
{ [ dup float-regs? ] [ float ] }
} cond nip ;
INSTANCE: vreg value
! Temporary register for stack shuffling
SINGLETON: temp-reg
M: temp-reg move-spec drop f ;
INSTANCE: temp-reg value
! A data stack location.
TUPLE: ds-loc n class ;
: <ds-loc> ( n -- loc ) f ds-loc boa ;
M: ds-loc minimal-ds-loc* n>> min ;
M: ds-loc live-loc?
over ds-loc? [ [ n>> ] bi@ = not ] [ 2drop t ] if ;
! A retain stack location.
TUPLE: rs-loc n class ;
: <rs-loc> ( n -- loc ) f rs-loc boa ;
M: rs-loc live-loc?
over rs-loc? [ [ n>> ] bi@ = not ] [ 2drop t ] if ;
UNION: loc ds-loc rs-loc ;
M: loc operand-class* class>> ;
M: loc set-operand-class (>>class) ;
M: loc move-spec drop loc ;
INSTANCE: loc value
M: f move-spec drop loc ;
M: f operand-class* ;
! A stack location which has been loaded into a register. To
! read the location, we just read the register, but when time
! comes to save it back to the stack, we know the register just
! contains a stack value so we don't have to redundantly write
! it back.
TUPLE: cached loc vreg ;
C: <cached> cached
M: cached set-operand-class vreg>> set-operand-class ;
M: cached operand-class* vreg>> operand-class* ;
M: cached move-spec drop cached ;
M: cached live-vregs* vreg>> live-vregs* ;
M: cached live-loc? loc>> live-loc? ;
M: cached (lazy-load) >r vreg>> r> (lazy-load) ;
M: cached lazy-store
2dup loc>> live-loc?
[ "live-locs" get at %move ] [ 2drop ] if ;
M: cached minimal-ds-loc* loc>> minimal-ds-loc* ;
INSTANCE: cached value
! A tagged pointer
TUPLE: tagged vreg class ;
: <tagged> ( vreg -- tagged )
f tagged boa ;
M: tagged v>operand vreg>> v>operand ;
M: tagged set-operand-class (>>class) ;
M: tagged operand-class* class>> ;
M: tagged move-spec drop f ;
M: tagged live-vregs* vreg>> , ;
INSTANCE: tagged value
! Unboxed alien pointers
TUPLE: unboxed-alien vreg ;
C: <unboxed-alien> unboxed-alien
M: unboxed-alien v>operand vreg>> v>operand ;
M: unboxed-alien operand-class* drop simple-alien ;
M: unboxed-alien move-spec class ;
M: unboxed-alien live-vregs* vreg>> , ;
INSTANCE: unboxed-alien value
TUPLE: unboxed-byte-array vreg ;
C: <unboxed-byte-array> unboxed-byte-array
M: unboxed-byte-array v>operand vreg>> v>operand ;
M: unboxed-byte-array operand-class* drop c-ptr ;
M: unboxed-byte-array move-spec class ;
M: unboxed-byte-array live-vregs* vreg>> , ;
INSTANCE: unboxed-byte-array value
TUPLE: unboxed-f vreg ;
C: <unboxed-f> unboxed-f
M: unboxed-f v>operand vreg>> v>operand ;
M: unboxed-f operand-class* drop \ f ;
M: unboxed-f move-spec class ;
M: unboxed-f live-vregs* vreg>> , ;
INSTANCE: unboxed-f value
TUPLE: unboxed-c-ptr vreg ;
C: <unboxed-c-ptr> unboxed-c-ptr
M: unboxed-c-ptr v>operand vreg>> v>operand ;
M: unboxed-c-ptr operand-class* drop c-ptr ;
M: unboxed-c-ptr move-spec class ;
M: unboxed-c-ptr live-vregs* vreg>> , ;
INSTANCE: unboxed-c-ptr value
! A constant value
TUPLE: constant value ;
C: <constant> constant
M: constant operand-class* value>> class ;
M: constant move-spec class ;
INSTANCE: constant value
<PRIVATE
! Moving values between locations and registers
: %move-bug ( -- * ) "Bug in generator.registers" throw ;
: %unbox-c-ptr ( dst src -- )
dup operand-class {
{ [ dup \ f class<= ] [ drop %unbox-f ] }
{ [ dup simple-alien class<= ] [ drop %unbox-alien ] }
{ [ dup byte-array class<= ] [ drop %unbox-byte-array ] }
[ drop %unbox-any-c-ptr ]
} cond ; inline
: %move-via-temp ( dst src -- )
#! For many transfers, such as loc to unboxed-alien, we
#! don't have an intrinsic, so we transfer the source to
#! temp then temp to the destination.
temp-reg over %move
operand-class temp-reg
tagged new
swap >>vreg
swap >>class
%move ;
: %move ( dst src -- )
2dup [ move-spec ] bi@ 2array {
{ { f f } [ %move-bug ] }
{ { f unboxed-c-ptr } [ %move-bug ] }
{ { f unboxed-byte-array } [ %move-bug ] }
{ { f constant } [ value>> swap load-literal ] }
{ { f float } [ %box-float ] }
{ { f unboxed-alien } [ %box-alien ] }
{ { f loc } [ %peek ] }
{ { float f } [ %unbox-float ] }
{ { unboxed-alien f } [ %unbox-alien ] }
{ { unboxed-byte-array f } [ %unbox-byte-array ] }
{ { unboxed-f f } [ %unbox-f ] }
{ { unboxed-c-ptr f } [ %unbox-c-ptr ] }
{ { loc f } [ swap %replace ] }
[ drop %move-via-temp ]
} case ;
! A compile-time stack
TUPLE: phantom-stack height stack ;
M: phantom-stack clone
call-next-method [ clone ] change-stack ;
GENERIC: finalize-height ( stack -- )
: new-phantom-stack ( class -- stack )
>r 0 V{ } clone r> boa ; inline
: (loc) ( m stack -- n )
#! Utility for methods on <loc>
height>> - ;
: (finalize-height) ( stack word -- )
#! We consolidate multiple stack height changes until the
#! last moment, and we emit the final height changing
#! instruction here.
[
over zero? [ 2drop ] [ execute ] if 0
] curry change-height drop ; inline
GENERIC: <loc> ( n stack -- loc )
TUPLE: phantom-datastack < phantom-stack ;
: <phantom-datastack> ( -- stack )
phantom-datastack new-phantom-stack ;
M: phantom-datastack <loc> (loc) <ds-loc> ;
M: phantom-datastack finalize-height
\ %inc-d (finalize-height) ;
TUPLE: phantom-retainstack < phantom-stack ;
: <phantom-retainstack> ( -- stack )
phantom-retainstack new-phantom-stack ;
M: phantom-retainstack <loc> (loc) <rs-loc> ;
M: phantom-retainstack finalize-height
\ %inc-r (finalize-height) ;
: phantom-locs ( n phantom -- locs )
#! A sequence of n ds-locs or rs-locs indexing the stack.
>r <reversed> r> [ <loc> ] curry map ;
: phantom-locs* ( phantom -- locs )
[ stack>> length ] keep phantom-locs ;
: phantoms ( -- phantom phantom )
phantom-datastack get phantom-retainstack get ;
: (each-loc) ( phantom quot -- )
>r [ phantom-locs* ] [ stack>> ] bi r> 2each ; inline
: each-loc ( quot -- )
phantoms 2array swap [ (each-loc) ] curry each ; inline
: adjust-phantom ( n phantom -- )
swap [ + ] curry change-height drop ;
: cut-phantom ( n phantom -- seq )
swap [ cut* swap ] curry change-stack drop ;
: phantom-append ( seq stack -- )
over length over adjust-phantom stack>> push-all ;
: add-locs ( n phantom -- )
2dup stack>> length <= [
2drop
] [
[ phantom-locs ] keep
[ stack>> length head-slice* ] keep
[ append >vector ] change-stack drop
] if ;
: phantom-input ( n phantom -- seq )
2dup add-locs
2dup cut-phantom
>r >r neg r> adjust-phantom r> ;
: each-phantom ( quot -- ) phantoms rot bi@ ; inline
: finalize-heights ( -- ) [ finalize-height ] each-phantom ;
: live-vregs ( -- seq )
[ [ stack>> [ live-vregs* ] each ] each-phantom ] { } make ;
: (live-locs) ( phantom -- seq )
#! Discard locs which haven't moved
[ phantom-locs* ] [ stack>> ] bi zip
[ live-loc? ] assoc-filter
values ;
: live-locs ( -- seq )
[ (live-locs) ] each-phantom append prune ;
! Operands holding pointers to freshly-allocated objects which
! are guaranteed to be in the nursery
SYMBOL: fresh-objects
! Computing free registers and initializing allocator
: reg-spec>class ( spec -- class )
float eq? double-float-regs int-regs ? ;
: free-vregs ( reg-class -- seq )
#! Free vregs in a given register class
\ free-vregs get at ;
: alloc-vreg ( spec -- reg )
[ reg-spec>class free-vregs pop ] keep {
{ f [ <tagged> ] }
{ unboxed-alien [ <unboxed-alien> ] }
{ unboxed-byte-array [ <unboxed-byte-array> ] }
{ unboxed-f [ <unboxed-f> ] }
{ unboxed-c-ptr [ <unboxed-c-ptr> ] }
[ drop ]
} case ;
: compatible? ( value spec -- ? )
>r move-spec r> {
{ [ 2dup = ] [ t ] }
{ [ dup unboxed-c-ptr eq? ] [
over { unboxed-byte-array unboxed-alien } member?
] }
[ f ]
} cond 2nip ;
: allocation ( value spec -- reg-class )
{
{ [ dup quotation? ] [ 2drop f ] }
{ [ 2dup compatible? ] [ 2drop f ] }
[ nip reg-spec>class ]
} cond ;
: alloc-vreg-for ( value spec -- vreg )
alloc-vreg swap operand-class
over tagged? [ >>class ] [ drop ] if ;
M: value (lazy-load)
2dup allocation [
dupd alloc-vreg-for dup rot %move
] [
drop
] if ;
: (compute-free-vregs) ( used class -- vector )
#! Find all vregs in 'class' which are not in 'used'.
[ vregs length reverse ] keep
[ <vreg> ] curry map swap diff
>vector ;
: compute-free-vregs ( -- )
#! Create a new hashtable for thee free-vregs variable.
live-vregs
{ int-regs double-float-regs }
[ 2dup (compute-free-vregs) ] H{ } map>assoc
\ free-vregs set
drop ;
M: loc lazy-store
2dup live-loc? [ "live-locs" get at %move ] [ 2drop ] if ;
: do-shuffle ( hash -- )
dup assoc-empty? [
drop
] [
"live-locs" set
[ lazy-store ] each-loc
] if ;
: fast-shuffle ( locs -- )
#! We have enough free registers to load all shuffle inputs
#! at once
[ dup f (lazy-load) ] H{ } map>assoc do-shuffle ;
: minimal-ds-loc ( phantom -- n )
#! When shuffling more values than can fit in registers, we
#! need to find an area on the data stack which isn't in
#! use.
[ stack>> ] [ height>> neg ] bi [ minimal-ds-loc* ] reduce ;
: find-tmp-loc ( -- n )
#! Find an area of the data stack which is not referenced
#! from the phantom stacks. We can clobber there all we want
[ minimal-ds-loc ] each-phantom min 1- ;
: slow-shuffle-mapping ( locs tmp -- pairs )
>r dup length r>
[ swap - <ds-loc> ] curry map zip ;
: slow-shuffle ( locs -- )
#! We don't have enough free registers to load all shuffle
#! inputs, so we use a single temporary register, together
#! with the area of the data stack above the stack pointer
find-tmp-loc slow-shuffle-mapping [
[
swap dup cached? [ vreg>> ] when %move
] assoc-each
] keep >hashtable do-shuffle ;
: fast-shuffle? ( live-locs -- ? )
#! Test if we have enough free registers to load all
#! shuffle inputs at once.
int-regs free-vregs [ length ] bi@ <= ;
: finalize-locs ( -- )
#! Perform any deferred stack shuffling.
[
\ free-vregs [ [ clone ] assoc-map ] change
live-locs dup fast-shuffle?
[ fast-shuffle ] [ slow-shuffle ] if
] with-scope ;
: finalize-vregs ( -- )
#! Store any vregs to their final stack locations.
[
dup loc? over cached? or [ 2drop ] [ %move ] if
] each-loc ;
: reset-phantom ( phantom -- )
#! Kill register assignments but preserve constants and
#! class information.
dup phantom-locs*
over stack>> [
dup constant? [ nip ] [
operand-class over set-operand-class
] if
] 2map
over stack>> delete-all
swap stack>> push-all ;
: reset-phantoms ( -- )
[ reset-phantom ] each-phantom ;
: finalize-contents ( -- )
finalize-locs finalize-vregs reset-phantoms ;
! Loading stacks to vregs
: free-vregs? ( int# float# -- ? )
double-float-regs free-vregs length <=
>r int-regs free-vregs length <= r> and ;
: phantom&spec ( phantom spec -- phantom' spec' )
>r stack>> r>
[ length f pad-left ] keep
[ <reversed> ] bi@ ; inline
: phantom&spec-agree? ( phantom spec quot -- ? )
>r phantom&spec r> 2all? ; inline
: vreg-substitution ( value vreg -- pair )
dupd <cached> 2array ;
: substitute-vreg? ( old new -- ? )
#! We don't substitute locs for float or alien vregs,
#! since in those cases the boxing overhead might kill us.
vreg>> tagged? >r loc? r> and ;
: substitute-vregs ( values vregs -- )
[ vreg-substitution ] 2map
[ substitute-vreg? ] assoc-filter >hashtable
[ >r stack>> r> substitute-here ] curry each-phantom ;
: set-operand ( value var -- )
>r dup constant? [ value>> ] when r> set ;
: lazy-load ( values template -- )
#! Set operand vars here.
2dup [ first (lazy-load) ] 2map
dup rot [ second set-operand ] 2each
substitute-vregs ;
: load-inputs ( -- )
+input+ get
[ length phantom-datastack get phantom-input ] keep
lazy-load ;
: output-vregs ( -- seq seq )
+output+ +clobber+ [ get [ get ] map ] bi@ ;
: clash? ( seq -- ? )
phantoms [ stack>> ] bi@ append [
dup cached? [ vreg>> ] when swap member?
] with contains? ;
: outputs-clash? ( -- ? )
output-vregs append clash? ;
: count-vregs ( reg-classes -- ) [ [ inc ] when* ] each ;
: count-input-vregs ( phantom spec -- )
phantom&spec [
>r dup cached? [ vreg>> ] when r> first allocation
] 2map count-vregs ;
: count-scratch-regs ( spec -- )
[ first reg-spec>class ] map count-vregs ;
: guess-vregs ( dinput rinput scratch -- int# float# )
[
0 int-regs set
0 double-float-regs set
count-scratch-regs
phantom-retainstack get swap count-input-vregs
phantom-datastack get swap count-input-vregs
int-regs get double-float-regs get
] with-scope ;
: alloc-scratch ( -- )
+scratch+ get [ >r alloc-vreg r> set ] assoc-each ;
: guess-template-vregs ( -- int# float# )
+input+ get { } +scratch+ get guess-vregs ;
: template-inputs ( -- )
! Load input values into registers
load-inputs
! Allocate scratch registers
alloc-scratch
! If outputs clash, we write values back to the stack
outputs-clash? [ finalize-contents ] when ;
: template-outputs ( -- )
+output+ get [ get ] map phantom-datastack get phantom-append ;
: value-matches? ( value spec -- ? )
#! If the spec is a quotation and the value is a literal
#! fixnum, see if the quotation yields true when applied
#! to the fixnum. Otherwise, the values don't match. If the
#! spec is not a quotation, its a reg-class, in which case
#! the value is always good.
dup quotation? [
over constant?
[ >r value>> r> call ] [ 2drop f ] if
] [
2drop t
] if ;
: class-matches? ( actual expected -- ? )
{
{ f [ drop t ] }
{ known-tag [ dup [ class-tag >boolean ] when ] }
[ class<= ]
} case ;
: spec-matches? ( value spec -- ? )
2dup first value-matches?
>r >r operand-class 2 r> ?nth class-matches? r> and ;
: template-matches? ( spec -- ? )
phantom-datastack get +input+ rot at
[ spec-matches? ] phantom&spec-agree? ;
: ensure-template-vregs ( -- )
guess-template-vregs free-vregs? [
finalize-contents compute-free-vregs
] unless ;
: clear-phantoms ( -- )
[ stack>> delete-all ] each-phantom ;
PRIVATE>
: set-operand-classes ( classes -- )
phantom-datastack get
over length over add-locs
stack>> [ set-operand-class ] 2reverse-each ;
: end-basic-block ( -- )
#! Commit all deferred stacking shuffling, and ensure the
#! in-memory data and retain stacks are up to date with
#! respect to the compiler's current picture.
finalize-contents
clear-phantoms
finalize-heights
fresh-objects get [ empty? [ %gc ] unless ] [ delete-all ] bi ;
: with-template ( quot hash -- )
clone [
ensure-template-vregs
template-inputs call template-outputs
] bind
compute-free-vregs ; inline
: do-template ( pair -- )
#! Use with return value from find-template
first2 with-template ;
: fresh-object ( obj -- ) fresh-objects get push ;
: fresh-object? ( obj -- ? ) fresh-objects get memq? ;
: init-templates ( -- )
#! Initialize register allocator.
V{ } clone fresh-objects set
<phantom-datastack> phantom-datastack set
<phantom-retainstack> phantom-retainstack set
compute-free-vregs ;
: copy-templates ( -- )
#! Copies register allocator state, used when compiling
#! branches.
fresh-objects [ clone ] change
phantom-datastack [ clone ] change
phantom-retainstack [ clone ] change
compute-free-vregs ;
: find-template ( templates -- pair/f )
#! Pair has shape { quot hash }
[ second template-matches? ] find nip ;
: operand-tag ( operand -- tag/f )
operand-class dup [ class-tag ] when ;
UNION: immediate fixnum POSTPONE: f ;
: operand-immediate? ( operand -- ? )
operand-class immediate class<= ;
: phantom-push ( obj -- )
1 phantom-datastack get adjust-phantom
phantom-datastack get stack>> push ;
: phantom-shuffle ( shuffle -- )
[ in>> length phantom-datastack get phantom-input ] keep
shuffle phantom-datastack get phantom-append ;
: phantom->r ( n -- )
phantom-datastack get phantom-input
phantom-retainstack get phantom-append ;
: phantom-r> ( n -- )
phantom-retainstack get phantom-input
phantom-datastack get phantom-append ;
: phantom-drop ( n -- )
phantom-datastack get phantom-input drop ;
: phantom-rdrop ( n -- )
phantom-retainstack get phantom-input drop ;

1
basis/compiler/generator/registers/summary.txt
View File

@ -1 +0,0 @@
Register allocation and intrinsic selection

45
basis/compiler/intrinsics/intrinsics.factor
View File

@ -1,45 +0,0 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel classes.tuple classes.tuple.private math arrays
byte-arrays words stack-checker.known-words ;
IN: compiler.intrinsics
ERROR: missing-intrinsic ;
: (tuple) ( n -- tuple ) missing-intrinsic ;
\ (tuple) { tuple-layout } { tuple } define-primitive
\ (tuple) make-flushable
: (array) ( n -- array ) missing-intrinsic ;
\ (array) { integer } { array } define-primitive
\ (array) make-flushable
: (byte-array) ( n -- byte-array ) missing-intrinsic ;
\ (byte-array) { integer } { byte-array } define-primitive
\ (byte-array) make-flushable
: (ratio) ( -- ratio ) missing-intrinsic ;
\ (ratio) { } { ratio } define-primitive
\ (ratio) make-flushable
: (complex) ( -- complex ) missing-intrinsic ;
\ (complex) { } { complex } define-primitive
\ (complex) make-flushable
: (wrapper) ( -- wrapper ) missing-intrinsic ;
\ (wrapper) { } { wrapper } define-primitive
\ (wrapper) make-flushable
: (set-slot) ( val obj n -- ) missing-intrinsic ;
\ (set-slot) { object object fixnum } { } define-primitive
: (write-barrier) ( obj -- ) missing-intrinsic ;
\ (write-barrier) { object } { } define-primitive

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

@ -173,7 +173,7 @@ C-STRUCT: rect
{ "float" "h" }
;
: <rect>
: <rect> ( x y w h -- rect )
"rect" <c-object>
[ set-rect-h ] keep
[ set-rect-w ] keep

75
basis/compiler/tests/intrinsics.factor
View File

@ -27,7 +27,7 @@ IN: compiler.tests
[ 1 ] [ { 1 2 } [ 2 slot ] compile-call ] unit-test
[ 1 ] [ [ { 1 2 } 2 slot ] compile-call ] unit-test
[ 3 ] [ 3 1 2 2array [ [ 2 set-slot ] keep ] compile-call first ] unit-test
[ 3 ] [ 3 1 2 2array [ { array } declare [ 2 set-slot ] keep ] compile-call first ] unit-test
[ 3 ] [ 3 1 2 [ 2array [ 2 set-slot ] keep ] compile-call first ] unit-test
[ 3 ] [ [ 3 1 2 2array [ 2 set-slot ] keep ] compile-call first ] unit-test
[ 3 ] [ 3 1 2 2array [ [ 3 set-slot ] keep ] compile-call second ] unit-test
@ -252,31 +252,34 @@ cell 8 = [
! Some randomized tests
: compiled-fixnum* fixnum* ;
: test-fixnum* ( -- )
32 random-bits >fixnum 32 random-bits >fixnum
2dup
[ fixnum* ] 2keep compiled-fixnum* =
[ 2drop ] [ "Oops" throw ] if ;
[ ] [ 10000 [ test-fixnum* ] times ] unit-test
[ ] [
10000 [
32 random-bits >fixnum 32 random-bits >fixnum
2dup
[ fixnum* ] 2keep compiled-fixnum* =
[ 2drop ] [ "Oops" throw ] if
] times
] unit-test
: compiled-fixnum>bignum fixnum>bignum ;
: test-fixnum>bignum ( -- )
32 random-bits >fixnum
dup [ fixnum>bignum ] keep compiled-fixnum>bignum =
[ drop ] [ "Oops" throw ] if ;
[ ] [ 10000 [ test-fixnum>bignum ] times ] unit-test
[ ] [
10000 [
32 random-bits >fixnum
dup [ fixnum>bignum ] keep compiled-fixnum>bignum =
[ drop ] [ "Oops" throw ] if
] times
] unit-test
: compiled-bignum>fixnum bignum>fixnum ;
: test-bignum>fixnum ( -- )
5 random [ drop 32 random-bits ] map product >bignum
dup [ bignum>fixnum ] keep compiled-bignum>fixnum =
[ drop ] [ "Oops" throw ] if ;
[ ] [ 10000 [ test-bignum>fixnum ] times ] unit-test
[ ] [
10000 [
5 random [ drop 32 random-bits ] map product >bignum
dup [ bignum>fixnum ] keep compiled-bignum>fixnum =
[ drop ] [ "Oops" throw ] if
] times
] unit-test
! Test overflow check removal
[ t ] [
@ -377,25 +380,23 @@ cell 8 = [
[ 252 ] [ B{ 1 2 3 -4 5 } 3 [ { byte-array fixnum } declare alien-unsigned-1 ] compile-call ] unit-test
[ -4 ] [ B{ 1 2 3 -4 5 } 3 [ { byte-array fixnum } declare alien-signed-1 ] compile-call ] unit-test
: xword-def ( word -- def ) def>> [ { fixnum } declare ] prepend ;
[ -100 ] [ -100 <char> [ { byte-array } declare *char ] compile-call ] unit-test
[ 156 ] [ -100 <uchar> [ { byte-array } declare *uchar ] compile-call ] unit-test
[ -100 ] [ -100 \ <char> xword-def compile-call *char ] unit-test
[ 156 ] [ -100 \ <uchar> xword-def compile-call *uchar ] unit-test
[ -100 ] [ -100 \ <char> def>> [ { fixnum } declare ] prepend compile-call *char ] unit-test
[ 156 ] [ -100 \ <uchar> def>> [ { fixnum } declare ] prepend compile-call *uchar ] unit-test
[ -1000 ] [ -1000 <short> [ { byte-array } declare *short ] compile-call ] unit-test
[ 64536 ] [ -1000 <ushort> [ { byte-array } declare *ushort ] compile-call ] unit-test
[ -1000 ] [ -1000 \ <short> xword-def compile-call *short ] unit-test
[ 64536 ] [ -1000 \ <ushort> xword-def compile-call *ushort ] unit-test
[ -1000 ] [ -1000 \ <short> def>> [ { fixnum } declare ] prepend compile-call *short ] unit-test
[ 64536 ] [ -1000 \ <ushort> def>> [ { fixnum } declare ] prepend compile-call *ushort ] unit-test
[ -100000 ] [ -100000 <int> [ { byte-array } declare *int ] compile-call ] unit-test
[ 4294867296 ] [ -100000 <uint> [ { byte-array } declare *uint ] compile-call ] unit-test
[ -100000 ] [ -100000 \ <int> xword-def compile-call *int ] unit-test
[ 4294867296 ] [ -100000 \ <uint> xword-def compile-call *uint ] unit-test
[ -100000 ] [ -100000 \ <int> def>> [ { fixnum } declare ] prepend compile-call *int ] unit-test
[ 4294867296 ] [ -100000 \ <uint> def>> [ { fixnum } declare ] prepend compile-call *uint ] unit-test
[ t ] [ pi pi <double> *double = ] unit-test
@ -461,3 +462,21 @@ TUPLE: alien-accessor-regression { b byte-array } { i fixnum } ;
] compile-call
b>>
] unit-test
: mutable-value-bug-1 ( a b -- c )
swap [
{ tuple } declare 1 slot
] [
0 slot
] if ;
[ t ] [ f B{ } mutable-value-bug-1 byte-array type-number = ] unit-test
: mutable-value-bug-2 ( a b -- c )
swap [
0 slot
] [
{ tuple } declare 1 slot
] if ;
[ t ] [ t B{ } mutable-value-bug-2 byte-array type-number = ] unit-test

14
basis/compiler/tests/simple.factor
View File

@ -1,8 +1,10 @@
USING: compiler.units tools.test kernel kernel.private
sequences.private math.private math combinators strings
alien arrays memory vocabs parser eval ;
USING: compiler compiler.units tools.test kernel kernel.private
sequences.private math.private math combinators strings alien
arrays memory vocabs parser eval ;
IN: compiler.tests
\ (compile) must-infer
! Test empty word
[ ] [ [ ] compile-call ] unit-test
@ -52,11 +54,11 @@ IN: compiler.tests
! Labels
: recursive ( ? -- ) [ f recursive ] when ; inline
: recursive-test ( ? -- ) [ f recursive-test ] when ; inline
[ ] [ t [ recursive ] compile-call ] unit-test
[ ] [ t [ recursive-test ] compile-call ] unit-test
[ ] [ t recursive ] unit-test
[ ] [ t recursive-test ] unit-test
! Make sure error reporting works

220
basis/compiler/tests/templates-early.factor
View File

@ -1,220 +0,0 @@
! Testing templates machinery without compiling anything
IN: compiler.tests
USING: compiler compiler.generator compiler.generator.registers
compiler.generator.registers.private tools.test namespaces
sequences words kernel math effects definitions compiler.units
accessors cpu.architecture make ;
: <int-vreg> ( n -- vreg ) int-regs <vreg> ;
[
[ ] [ init-templates ] unit-test
[ V{ 3 } ] [ 3 fresh-object fresh-objects get ] unit-test
[ ] [ 0 <int-vreg> phantom-push ] unit-test
[ ] [ compute-free-vregs ] unit-test
[ f ] [ 0 <int-vreg> int-regs free-vregs member? ] unit-test
[ f ] [
[
copy-templates
1 <int-vreg> phantom-push
compute-free-vregs
1 <int-vreg> int-regs free-vregs member?
] with-scope
] unit-test
[ t ] [ 1 <int-vreg> int-regs free-vregs member? ] unit-test
] with-scope
[
[ ] [ init-templates ] unit-test
[ ] [ T{ effect f 3 { 1 2 0 } f } phantom-shuffle ] unit-test
[ 3 ] [ live-locs length ] unit-test
[ ] [ T{ effect f 2 { 1 0 } f } phantom-shuffle ] unit-test
[ 2 ] [ live-locs length ] unit-test
] with-scope
[
[ ] [ init-templates ] unit-test
H{ } clone compiled set
[ ] [ gensym gensym begin-compiling ] unit-test
[ t ] [ [ end-basic-block ] { } make empty? ] unit-test
3 fresh-object
[ f ] [ [ end-basic-block ] { } make empty? ] unit-test
] with-scope
[
[ ] [ init-templates ] unit-test
H{
{ +input+ { { f "x" } } }
} clone [
[ 1 0 ] [ +input+ get { } { } guess-vregs ] unit-test
[ ] [ finalize-contents ] unit-test
[ ] [ [ template-inputs ] { } make drop ] unit-test
] bind
] with-scope
! Test template picking strategy
SYMBOL: template-chosen
: template-test ( a b -- c d ) ;
\ template-test {
{
[
1 template-chosen get push
] H{
{ +input+ { { f "obj" } { [ ] "n" } } }
{ +output+ { "obj" "obj" } }
}
}
{
[
2 template-chosen get push
] H{
{ +input+ { { f "obj" } { f "n" } } }
{ +output+ { "obj" "n" } }
}
}
} define-intrinsics
[ V{ 2 } ] [
V{ } clone template-chosen set
0 0 [ template-test ] compile-call 2drop
template-chosen get
] unit-test
[ V{ 1 } ] [
V{ } clone template-chosen set
1 [ dup 0 template-test ] compile-call 3drop
template-chosen get
] unit-test
[ V{ 1 } ] [
V{ } clone template-chosen set
1 [ 0 template-test ] compile-call 2drop
template-chosen get
] unit-test
! Regression
[
[ ] [ init-templates ] unit-test
! dup dup
[ ] [
T{ effect f { "x" } { "x" "x" } } phantom-shuffle
T{ effect f { "x" } { "x" "x" } } phantom-shuffle
] unit-test
! This is not empty since a load instruction is emitted
[ f ] [
[ { { f "x" } } +input+ set load-inputs ] { } make
empty?
] unit-test
! This is empty since we already loaded the value
[ t ] [
[ { { f "x" } } +input+ set load-inputs ] { } make
empty?
] unit-test
! This is empty since we didn't change the stack
[ t ] [ [ end-basic-block ] { } make empty? ] unit-test
] with-scope
! Regression
[
[ ] [ init-templates ] unit-test
! >r r>
[ ] [
1 phantom->r
1 phantom-r>
] unit-test
! This is empty since we didn't change the stack
[ t ] [ [ end-basic-block ] { } make empty? ] unit-test
! >r r>
[ ] [
1 phantom->r
1 phantom-r>
] unit-test
[ ] [ { object } set-operand-classes ] unit-test
! This is empty since we didn't change the stack
[ t ] [ [ end-basic-block ] { } make empty? ] unit-test
] with-scope
! Regression
[
[ ] [ init-templates ] unit-test
[ ] [ { object object } set-operand-classes ] unit-test
! 2dup
[ ] [
T{ effect f { "x" "y" } { "x" "y" "x" "y" } }
phantom-shuffle
] unit-test
[ ] [
2 phantom-datastack get phantom-input
[ { { f "a" } { f "b" } } lazy-load ] { } make drop
] unit-test
[ t ] [
phantom-datastack get stack>> [ cached? ] all?
] unit-test
! >r
[ ] [
1 phantom->r
] unit-test
! This should not fail
[ ] [ [ end-basic-block ] { } make drop ] unit-test
] with-scope
! Regression
SYMBOL: templates-chosen
V{ } clone templates-chosen set
: template-choice-1 ;
\ template-choice-1
[ "template-choice-1" templates-chosen get push ]
H{
{ +input+ { { f "obj" } { [ ] "n" } } }
{ +output+ { "obj" } }
} define-intrinsic
: template-choice-2 ;
\ template-choice-2
[ "template-choice-2" templates-chosen get push drop ]
{ { f "x" } { f "y" } } define-if-intrinsic
[ ] [
[ 2 template-choice-1 template-choice-2 ]
[ define-temp ] with-compilation-unit drop
] unit-test
[ V{ "template-choice-1" "template-choice-2" } ]
[ templates-chosen get ] unit-test

147
basis/compiler/tests/templates.factor
View File

@ -1,11 +1,15 @@
! Black box testing of templating optimization
USING: accessors arrays compiler kernel kernel.private math
hashtables.private math.private namespaces sequences
sequences.private tools.test namespaces.private slots.private
sequences.private byte-arrays alien alien.accessors layouts
words definitions compiler.units io combinators vectors ;
USING: generalizations accessors arrays compiler kernel
kernel.private math hashtables.private math.private namespaces
sequences sequences.private tools.test namespaces.private
slots.private sequences.private byte-arrays alien
alien.accessors layouts words definitions compiler.units io
combinators vectors ;
IN: compiler.tests
! Originally, this file did black box testing of templating
! optimization. We now have a different codegen, but the tests
! in here are still useful.
! Oops!
[ 5000 ] [ [ 5000 ] compile-call ] unit-test
[ "hi" ] [ [ "hi" ] compile-call ] unit-test
@ -101,9 +105,8 @@ unit-test
] [ define-temp ] with-compilation-unit drop
] unit-test
! Test how dispatch handles the end of a basic block
: try-breaking-dispatch ( n a b -- a b str )
: try-breaking-dispatch ( n a b -- x str )
float+ swap { [ "hey" ] [ "bye" ] } dispatch ;
: try-breaking-dispatch-2 ( -- ? )
@ -122,7 +125,7 @@ unit-test
] unit-test
! Regression
: hellish-bug-1 2drop ;
: hellish-bug-1 ( a b -- ) 2drop ;
: hellish-bug-2 ( i array x -- x )
2dup 1 slot eq? [ 2drop ] [
@ -132,7 +135,7 @@ unit-test
pick 2dup hellish-bug-1 3drop
] 2keep
] unless >r 2 fixnum+fast r> hellish-bug-2
] if ; inline
] if ; inline recursive
: hellish-bug-3 ( hash array -- )
0 swap hellish-bug-2 drop ;
@ -189,7 +192,7 @@ TUPLE: my-tuple ;
] unit-test
! Regression
: a-dummy ( -- ) drop "hi" print ;
: a-dummy ( a -- ) drop "hi" print ;
[ ] [
1 [
@ -245,8 +248,125 @@ TUPLE: my-tuple ;
[ dup float+ ]
} cleave ;
[ 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 ]
[ 1.0 float-spill-bug ] unit-test
[ t ] [ \ float-spill-bug compiled>> ] unit-test
: float-fixnum-spill-bug ( object -- object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object )
{
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
} cleave ;
[ 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 ]
[ 1.0 float-fixnum-spill-bug ] unit-test
[ t ] [ \ float-fixnum-spill-bug compiled>> ] unit-test
: resolve-spill-bug ( a b -- c )
[ 1 fixnum+fast ] bi@ dup 10 fixnum< [
nip 2 fixnum+fast
] [
drop {
[ dup fixnum+fast ]
[ dup fixnum+fast ]
[ dup fixnum+fast ]
[ dup fixnum+fast ]
[ dup fixnum+fast ]
[ dup fixnum+fast ]
[ dup fixnum+fast ]
[ dup fixnum+fast ]
[ dup fixnum+fast ]
[ dup fixnum+fast ]
[ dup fixnum+fast ]
[ dup fixnum+fast ]
[ dup fixnum+fast ]
[ dup fixnum+fast ]
[ dup fixnum+fast ]
[ dup fixnum+fast ]
} cleave
16 narray
] if ;
[ t ] [ \ resolve-spill-bug compiled>> ] unit-test
[ 4 ] [ 1 1 resolve-spill-bug ] unit-test
! Regression
: dispatch-alignment-regression ( -- c )
{ tuple vector } 3 slot { word } declare
@ -255,3 +375,8 @@ TUPLE: my-tuple ;
[ t ] [ \ dispatch-alignment-regression compiled>> ] unit-test
[ vector ] [ dispatch-alignment-regression ] unit-test
! Regression
: bad-value-bug ( a -- b ) [ 3 ] [ 3 ] if f <array> ;
[ { f f f } ] [ t bad-value-bug ] unit-test

2
basis/compiler/tree/builder/builder.factor
View File

@ -7,7 +7,7 @@ stack-checker.backend compiler.tree ;
IN: compiler.tree.builder
: with-tree-builder ( quot -- nodes )
[ V{ } clone stack-visitor set ] prepose
'[ V{ } clone stack-visitor set @ ]
with-infer ; inline
: build-tree ( quot -- nodes )

8
basis/compiler/tree/cleanup/cleanup-tests.factor
View File

@ -5,7 +5,7 @@ strings sbufs sequences.private slots.private combinators
definitions system layouts vectors math.partial-dispatch
math.order math.functions accessors hashtables classes assocs
io.encodings.utf8 io.encodings.ascii io.encodings fry slots
sorting.private
sorting.private combinators.short-circuit
compiler.tree
compiler.tree.combinators
compiler.tree.cleanup
@ -13,6 +13,7 @@ compiler.tree.builder
compiler.tree.recursive
compiler.tree.normalization
compiler.tree.propagation
compiler.tree.propagation.info
compiler.tree.checker
compiler.tree.debugger ;
@ -494,3 +495,8 @@ cell-bits 32 = [
[ t ] [
[ hashtable new ] \ new inlined?
] unit-test
[ t ] [
[ { array-capacity } declare 1 fixnum+ ] cleaned-up-tree
[ { [ #call? ] [ node-input-infos second literal>> 1 = ] } 1&& ] contains?
] unit-test

3
basis/compiler/tree/cleanup/cleanup.factor
View File

@ -5,7 +5,6 @@ classes.algebra namespaces assocs words math math.private
math.partial-dispatch math.intervals classes classes.tuple
classes.tuple.private layouts definitions stack-checker.state
stack-checker.branches
compiler.intrinsics
compiler.tree
compiler.tree.combinators
compiler.tree.propagation.info
@ -79,7 +78,7 @@ GENERIC: cleanup* ( node -- node/nodes )
} cond ;
: remove-overflow-check ( #call -- #call )
[ in-d>> ] [ out-d>> ] [ word>> no-overflow-variant ] tri #call cleanup* ;
[ no-overflow-variant ] change-word cleanup* ;
M: #call cleanup*
{

2
basis/compiler/tree/combinators/combinators.factor
View File

@ -48,7 +48,7 @@ IN: compiler.tree.combinators
: sift-children ( seq flags -- seq' )
zip [ nip ] assoc-filter keys ;
: (3each) [ 3array flip ] dip [ first3 ] prepose ; inline
: (3each) [ 3array flip ] dip '[ first3 @ ] ; inline
: 3each ( seq1 seq2 seq3 quot -- seq ) (3each) each ; inline

2
basis/compiler/tree/debugger/debugger.factor
View File

@ -24,7 +24,7 @@ IN: compiler.tree.debugger
GENERIC: node>quot ( node -- )
MACRO: match-choose ( alist -- )
[ [ ] curry ] assoc-map [ match-cond ] curry ;
[ '[ _ ] ] assoc-map '[ _ match-cond ] ;
MATCH-VARS: ?a ?b ?c ;

2
basis/compiler/tree/escape-analysis/escape-analysis-tests.factor
View File

@ -6,7 +6,7 @@ math.functions compiler.tree.propagation compiler.tree.cleanup
compiler.tree.combinators compiler.tree sequences math
math.private kernel tools.test accessors slots.private
quotations.private prettyprint classes.tuple.private classes
classes.tuple compiler.intrinsics namespaces
classes.tuple namespaces
compiler.tree.propagation.info stack-checker.errors
kernel.private ;

1
basis/compiler/tree/escape-analysis/simple/simple.factor
View File

@ -4,7 +4,6 @@ USING: kernel accessors sequences classes.tuple
classes.tuple.private arrays math math.private slots.private
combinators deques search-deques namespaces fry classes
classes.algebra stack-checker.state
compiler.intrinsics
compiler.tree
compiler.tree.propagation.info
compiler.tree.escape-analysis.nodes

86
basis/compiler/tree/finalization/finalization.factor
View File

@ -1,10 +1,6 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel arrays accessors sequences sequences.private words
fry namespaces make math math.order memoize classes.builtin
classes.tuple.private slots.private combinators layouts
byte-arrays alien.accessors
compiler.intrinsics
USING: kernel accessors sequences words memoize classes.builtin
compiler.tree
compiler.tree.combinators
compiler.tree.propagation.info
@ -15,14 +11,19 @@ IN: compiler.tree.finalization
! See the comment in compiler.tree.late-optimizations.
! This pass runs after propagation, so that it can expand
! built-in type predicates and memory allocation; these cannot
! be expanded before propagation since we need to see 'fixnum?'
! instead of 'tag 0 eq?' and so on, for semantic reasoning.
! built-in type predicates; these cannot be expanded before
! propagation since we need to see 'fixnum?' instead of
! 'tag 0 eq?' and so on, for semantic reasoning.
! We also delete empty stack shuffles and copies to facilitate
! tail call optimization in the code generator.
GENERIC: finalize* ( node -- nodes )
: finalize ( nodes -- nodes' ) [ finalize* ] map-nodes ;
: splice-final ( quot -- nodes ) splice-quot finalize ;
M: #copy finalize* drop f ;
M: #shuffle finalize*
@ -34,77 +35,12 @@ M: #shuffle finalize*
word>> "predicating" word-prop builtin-class? ;
MEMO: builtin-predicate-expansion ( word -- nodes )
def>> splice-quot ;
def>> splice-final ;
: expand-builtin-predicate ( #call -- nodes )
word>> builtin-predicate-expansion ;
: first-literal ( #call -- obj ) node-input-infos first literal>> ;
: last-literal ( #call -- obj ) node-input-infos peek literal>> ;
: expand-tuple-boa? ( #call -- ? )
dup word>> \ <tuple-boa> eq? [
last-literal tuple-layout?
] [ drop f ] if ;
MEMO: (tuple-boa-expansion) ( n -- quot )
[
[ 2 + ] map <reversed>
[ '[ [ _ set-slot ] keep ] % ] each
] [ ] make ;
: tuple-boa-expansion ( layout -- quot )
#! No memoization here since otherwise we'd hang on to
#! tuple layout objects.
size>> (tuple-boa-expansion) \ (tuple) prefix splice-quot ;
: expand-tuple-boa ( #call -- node )
last-literal tuple-boa-expansion ;
MEMO: <array>-expansion ( n -- quot )
[
[ swap (array) ] %
[ \ 2dup , , [ swap set-array-nth ] % ] each
\ nip ,
] [ ] make splice-quot ;
: expand-<array>? ( #call -- ? )
dup word>> \ <array> eq? [
first-literal dup integer?
[ 0 32 between? ] [ drop f ] if
] [ drop f ] if ;
: expand-<array> ( #call -- node )
first-literal <array>-expansion ;
: bytes>cells ( m -- n ) cell align cell /i ;
MEMO: <byte-array>-expansion ( n -- quot )
[
[ (byte-array) ] %
bytes>cells [ cell * ] map
[ [ 0 over ] % , [ set-alien-unsigned-cell ] % ] each
] [ ] make splice-quot ;
: expand-<byte-array>? ( #call -- ? )
dup word>> \ <byte-array> eq? [
first-literal dup integer?
[ 0 128 between? ] [ drop f ] if
] [ drop f ] if ;
: expand-<byte-array> ( #call -- nodes )
first-literal <byte-array>-expansion ;
M: #call finalize*
{
{ [ dup builtin-predicate? ] [ expand-builtin-predicate ] }
{ [ dup expand-tuple-boa? ] [ expand-tuple-boa ] }
{ [ dup expand-<array>? ] [ expand-<array> ] }
{ [ dup expand-<byte-array>? ] [ expand-<byte-array> ] }
[ ]
} cond ;
dup builtin-predicate? [ expand-builtin-predicate ] when ;
M: node finalize* ;
: finalize ( nodes -- nodes' ) [ finalize* ] map-nodes ;

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

@ -53,17 +53,8 @@ M: node maybe-modularize* 2drop ;
GENERIC: compute-modularized-values* ( node -- )
M: #call compute-modularized-values*
dup word>> {
{ [ \ >fixnum eq? ] [ in-d>> first maybe-modularize ] }
! { [
! {
! mod-integer-fixnum
! mod-integer-integer
! mod-fixnum-integer
! } memq?
! ] [ ] }
[ drop ]
} cond ;
dup word>> \ >fixnum eq?
[ in-d>> first maybe-modularize ] [ drop ] if ;
M: node compute-modularized-values* drop ;

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

@ -7,7 +7,6 @@ classes.algebra combinators generic.math splitting fry locals
classes.tuple alien.accessors classes.tuple.private slots.private
definitions
stack-checker.state
compiler.intrinsics
compiler.tree.comparisons
compiler.tree.propagation.info
compiler.tree.propagation.nodes
@ -277,10 +276,10 @@ generic-comparison-ops [
}
} cond
[ fixnum fits? fixnum integer ? ] keep <class/interval-info>
[ 2nip ] curry "outputs" set-word-prop
'[ 2drop _ ] "outputs" set-word-prop
] each
{ <tuple> <tuple-boa> (tuple) } [
{ <tuple> <tuple-boa> } [
[
literal>> dup tuple-layout? [ class>> ] [ drop tuple ] if <class-info>
[ clear ] dip

1
basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor
View File

@ -4,7 +4,6 @@ USING: namespaces assocs accessors kernel combinators
classes.algebra sequences sequences.deep slots.private
classes.tuple.private math math.private arrays
stack-checker.branches
compiler.intrinsics
compiler.tree
compiler.tree.combinators
compiler.tree.propagation.info

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

@ -2,9 +2,16 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays generic kernel kernel.private math
memory namespaces make sequences layouts system hashtables
classes alien byte-arrays combinators words sets ;
classes alien byte-arrays combinators words sets fry ;
IN: cpu.architecture
! Labels
TUPLE: label offset ;
: <label> ( -- label ) label new ;
: define-label ( name -- ) <label> swap set ;
: resolve-label ( label/name -- ) dup label? [ get ] unless , ;
! Register classes
SINGLETON: int-regs
SINGLETON: single-float-regs
@ -12,6 +19,9 @@ SINGLETON: double-float-regs
UNION: float-regs single-float-regs double-float-regs ;
UNION: reg-class int-regs float-regs ;
! Mapping from register class to machine registers
HOOK: machine-registers cpu ( -- assoc )
! A pseudo-register class for parameters spilled on the stack
SINGLETON: stack-params
@ -25,67 +35,102 @@ GENERIC: param-reg ( n register-class -- reg )
M: object param-reg param-regs nth ;
! Sequence mapping vreg-n to native assembler registers
GENERIC: vregs ( register-class -- regs )
HOOK: two-operand? cpu ( -- ? )
! Load a literal (immediate or indirect)
GENERIC# load-literal 1 ( obj vreg -- )
HOOK: %load-immediate cpu ( reg obj -- )
HOOK: %load-indirect cpu ( reg obj -- )
HOOK: load-indirect cpu ( obj reg -- )
HOOK: stack-frame-size cpu ( frame-size -- n )
TUPLE: stack-frame total-size size params return ;
! Set up caller stack frame
HOOK: %prologue cpu ( n -- )
: %prologue-later ( -- ) \ %prologue-later , ;
! Tear down stack frame
HOOK: %epilogue cpu ( n -- )
: %epilogue-later ( -- ) \ %epilogue-later , ;
! Store word XT in stack frame
HOOK: %save-word-xt cpu ( -- )
! Store dispatch branch XT in stack frame
HOOK: %save-dispatch-xt cpu ( -- )
M: object %save-dispatch-xt %save-word-xt ;
! Call another word
HOOK: %call cpu ( word -- )
! Local jump for branches
HOOK: %jump-label cpu ( label -- )
! Test if vreg is 'f' or not
HOOK: %jump-f cpu ( label -- )
HOOK: %dispatch cpu ( -- )
HOOK: %dispatch-label cpu ( word -- )
! Return to caller
HOOK: %return cpu ( -- )
! Change datastack height
HOOK: %peek cpu ( vreg loc -- )
HOOK: %replace cpu ( vreg loc -- )
HOOK: %inc-d cpu ( n -- )
! Change callstack height
HOOK: %inc-r cpu ( n -- )
! Load stack into vreg
HOOK: %peek cpu ( vreg loc -- )
HOOK: stack-frame-size cpu ( stack-frame -- n )
HOOK: %call cpu ( word -- )
HOOK: %jump-label cpu ( label -- )
HOOK: %return cpu ( -- )
! Store vreg to stack
HOOK: %replace cpu ( vreg loc -- )
HOOK: %dispatch cpu ( src temp -- )
HOOK: %dispatch-label cpu ( word -- )
! Box and unbox floats
HOOK: %slot cpu ( dst obj slot tag temp -- )
HOOK: %slot-imm cpu ( dst obj slot tag -- )
HOOK: %set-slot cpu ( src obj slot tag temp -- )
HOOK: %set-slot-imm cpu ( src obj slot tag -- )
HOOK: %add cpu ( dst src1 src2 -- )
HOOK: %add-imm cpu ( dst src1 src2 -- )
HOOK: %sub cpu ( dst src1 src2 -- )
HOOK: %sub-imm cpu ( dst src1 src2 -- )
HOOK: %mul cpu ( dst src1 src2 -- )
HOOK: %mul-imm cpu ( dst src1 src2 -- )
HOOK: %and cpu ( dst src1 src2 -- )
HOOK: %and-imm cpu ( dst src1 src2 -- )
HOOK: %or cpu ( dst src1 src2 -- )
HOOK: %or-imm cpu ( dst src1 src2 -- )
HOOK: %xor cpu ( dst src1 src2 -- )
HOOK: %xor-imm cpu ( dst src1 src2 -- )
HOOK: %shl-imm cpu ( dst src1 src2 -- )
HOOK: %shr-imm cpu ( dst src1 src2 -- )
HOOK: %sar-imm cpu ( dst src1 src2 -- )
HOOK: %not cpu ( dst src -- )
HOOK: %integer>bignum cpu ( dst src temp -- )
HOOK: %bignum>integer cpu ( dst src -- )
HOOK: %add-float cpu ( dst src1 src2 -- )
HOOK: %sub-float cpu ( dst src1 src2 -- )
HOOK: %mul-float cpu ( dst src1 src2 -- )
HOOK: %div-float cpu ( dst src1 src2 -- )
HOOK: %integer>float cpu ( dst src -- )
HOOK: %float>integer cpu ( dst src -- )
HOOK: %copy cpu ( dst src -- )
HOOK: %copy-float cpu ( dst src -- )
HOOK: %unbox-float cpu ( dst src -- )
HOOK: %box-float cpu ( dst src -- )
HOOK: %unbox-any-c-ptr cpu ( dst src temp -- )
HOOK: %box-float cpu ( dst src temp -- )
HOOK: %box-alien cpu ( dst src temp -- )
HOOK: %alien-unsigned-1 cpu ( dst src -- )
HOOK: %alien-unsigned-2 cpu ( dst src -- )
HOOK: %alien-unsigned-4 cpu ( dst src -- )
HOOK: %alien-signed-1 cpu ( dst src -- )
HOOK: %alien-signed-2 cpu ( dst src -- )
HOOK: %alien-signed-4 cpu ( dst src -- )
HOOK: %alien-cell cpu ( dst src -- )
HOOK: %alien-float cpu ( dst src -- )
HOOK: %alien-double cpu ( dst src -- )
HOOK: %set-alien-integer-1 cpu ( ptr value -- )
HOOK: %set-alien-integer-2 cpu ( ptr value -- )
HOOK: %set-alien-integer-4 cpu ( ptr value -- )
HOOK: %set-alien-cell cpu ( ptr value -- )
HOOK: %set-alien-float cpu ( ptr value -- )
HOOK: %set-alien-double cpu ( ptr value -- )
HOOK: %allot cpu ( dst size class temp -- )
HOOK: %write-barrier cpu ( src card# table -- )
HOOK: %gc cpu ( -- )
HOOK: %prologue cpu ( n -- )
HOOK: %epilogue cpu ( n -- )
HOOK: %compare cpu ( dst cc src1 src2 -- )
HOOK: %compare-imm cpu ( dst cc src1 src2 -- )
HOOK: %compare-float cpu ( dst cc src1 src2 -- )
HOOK: %compare-branch cpu ( label cc src1 src2 -- )
HOOK: %compare-imm-branch cpu ( label cc src1 src2 -- )
HOOK: %compare-float-branch cpu ( label cc src1 src2 -- )
HOOK: %spill-integer cpu ( src n -- )
HOOK: %spill-float cpu ( src n -- )
HOOK: %reload-integer cpu ( dst n -- )
HOOK: %reload-float cpu ( dst n -- )
HOOK: %loop-entry cpu ( -- )
! FFI stuff
@ -96,7 +141,7 @@ HOOK: small-enough? cpu ( n -- ? )
! Is this structure small enough to be returned in registers?
HOOK: struct-small-enough? cpu ( heap-size -- ? )
! Do we pass explode value structs?
! Do we pass value structs by value or hidden reference?
HOOK: value-structs? cpu ( -- ? )
! If t, fp parameters are shadowed by dummy int parameters
@ -134,69 +179,34 @@ M: object %prepare-var-args ;
HOOK: %alien-invoke cpu ( function library -- )
HOOK: %cleanup cpu ( alien-node -- )
HOOK: %cleanup cpu ( params -- )
M: object %cleanup ( params -- ) drop ;
HOOK: %prepare-alien-indirect cpu ( -- )
HOOK: %alien-indirect cpu ( -- )
HOOK: %alien-callback cpu ( quot -- )
HOOK: %callback-value cpu ( ctype -- )
! Return to caller with stdcall unwinding (only for x86)
HOOK: %unwind cpu ( n -- )
HOOK: %callback-return cpu ( params -- )
HOOK: %prepare-alien-indirect cpu ( -- )
HOOK: %alien-indirect cpu ( -- )
M: object %callback-return drop %return ;
M: stack-params param-reg drop ;
M: stack-params param-regs drop f ;
GENERIC: v>operand ( obj -- operand )
M: integer v>operand tag-fixnum ;
M: f v>operand drop \ f tag-number ;
M: object load-literal v>operand load-indirect ;
PREDICATE: small-slot < integer cells small-enough? ;
PREDICATE: small-tagged < integer v>operand small-enough? ;
: if-small-struct ( n size true false -- ? )
[ over not over struct-small-enough? and ] 2dip
[ [ nip ] prepose ] dip if ;
[ 2dup [ not ] [ struct-small-enough? ] bi* and ] 2dip
[ '[ nip @ ] ] dip if ;
inline
: %unbox-struct ( n c-type -- )
[
%unbox-small-struct
] [
%unbox-large-struct
] if-small-struct ;
[ %unbox-small-struct ] [ %unbox-large-struct ] if-small-struct ;
: %box-struct ( n c-type -- )
[
%box-small-struct
] [
%box-large-struct
] if-small-struct ;
! Alien accessors
HOOK: %unbox-byte-array cpu ( dst src -- )
HOOK: %unbox-alien cpu ( dst src -- )
HOOK: %unbox-f cpu ( dst src -- )
HOOK: %unbox-any-c-ptr cpu ( dst src -- )
HOOK: %box-alien cpu ( dst src -- )
! GC check
HOOK: %gc cpu ( -- )
: operand ( var -- op ) get v>operand ; inline
: unique-operands ( operands quot -- )
>r [ operand ] map prune r> each ; inline
[ %box-small-struct ] [ %box-large-struct ] if-small-struct ;

2
basis/cpu/ppc/allot/allot.factor
View File

@ -66,7 +66,7 @@ M: ppc %box-float ( dst src -- )
! is it zero?
0 over v>operand 0 CMPI
"non-zero" get BNE
0 >bignum over load-literal
dup 0 >bignum %load-literal
"end" get B
! it is non-zero
"non-zero" resolve-label

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

@ -128,8 +128,6 @@ M: ppc %dispatch-label ( word -- )
M: ppc %return ( -- ) %epilogue-later BLR ;
M: ppc %unwind drop %return ;
M: ppc %peek ( vreg loc -- )
>r v>operand r> loc>operand LWZ ;
@ -267,8 +265,6 @@ M: ppc %callback-value ( ctype -- )
! Unbox former top of data stack to return registers
unbox-return ;
M: ppc %cleanup ( alien-node -- ) drop ;
: %untag ( src dest -- ) 0 0 31 tag-bits get - RLWINM ;
: %tag-fixnum ( src dest -- ) tag-bits get SLWI ;

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

@ -1,6 +1,6 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: compiler.generator.fixup kernel namespaces words
USING: compiler.codegen.fixup kernel namespaces words
io.binary math math.order cpu.ppc.assembler.backend ;
IN: cpu.ppc.assembler

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

@ -1,7 +1,8 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: compiler.generator.fixup kernel namespaces make sequences
words math math.bitwise io.binary parser lexer ;
USING: compiler.codegen.fixup cpu.architecture
compiler.constants kernel namespaces make sequences words math
math.bitwise io.binary parser lexer ;
IN: cpu.ppc.assembler.backend
: insn ( operand opcode -- ) { 26 0 } bitfield , ;

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

@ -1,7 +1,7 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: bootstrap.image.private kernel kernel.private namespaces
system cpu.ppc.assembler compiler.generator.fixup compiler.units
system cpu.ppc.assembler compiler.codegen.fixup compiler.units
compiler.constants math math.private layouts words words.private
vocabs slots.private ;
IN: bootstrap.ppc

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

@ -1,12 +1,12 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: locals alien.c-types arrays cpu.x86.assembler
cpu.x86.architecture cpu.x86.intrinsics cpu.x86.allot
cpu.architecture kernel kernel.private math namespaces sequences
stack-checker.known-words compiler.generator.registers
compiler.generator.fixup compiler.generator system layouts
combinators command-line compiler compiler.units io
vocabs.loader accessors init ;
USING: locals alien.c-types alien.syntax arrays kernel
math namespaces sequences system layouts io vocabs.loader
accessors init combinators command-line cpu.x86.assembler
cpu.x86.architecture cpu.architecture compiler compiler.units
compiler.constants compiler.alien compiler.codegen
compiler.codegen.fixup compiler.cfg.instructions
compiler.cfg.builder compiler.cfg.intrinsics ;
IN: cpu.x86.32
! We implement the FFI for Linux, OS X and Windows all at once.
@ -14,14 +14,18 @@ IN: cpu.x86.32
! this on all platforms, sacrificing some stack space for
! code simplicity.
M: x86.32 machine-registers
{
{ int-regs { EAX ECX EDX EBP EBX } }
{ double-float-regs { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } }
} ;
M: x86.32 ds-reg ESI ;
M: x86.32 rs-reg EDI ;
M: x86.32 stack-reg ESP ;
M: x86.32 temp-reg-1 EAX ;
M: x86.32 temp-reg-2 ECX ;
M: temp-reg v>operand drop EBX ;
M: x86.32 %alien-global 0 [] MOV rc-absolute-cell rel-dlsym ;
M: x86.32 %alien-invoke (CALL) rel-dlsym ;
@ -36,7 +40,6 @@ M: x86.32 struct-small-enough? ( size -- ? )
! On x86, parameters are never passed in registers.
M: int-regs return-reg drop EAX ;
M: int-regs param-regs drop { } ;
M: int-regs vregs drop { EAX ECX EDX EBP } ;
M: int-regs push-return-reg return-reg PUSH ;
M: int-regs load-return-reg
@ -46,7 +49,6 @@ M: int-regs store-return-reg
[ stack@ ] [ return-reg ] bi* MOV ;
M: float-regs param-regs drop { } ;
M: float-regs vregs drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
: FSTP ( operand size -- ) 4 = [ FSTPS ] [ FSTPL ] if ;
@ -72,12 +74,12 @@ M: float-regs store-return-reg
[ [ align-sub ] [ call ] bi* ]
[ [ align-add ] [ drop ] bi* ] 2bi ; inline
M: x86.32 fixnum>slot@ 1 SHR ;
M: x86.32 rel-literal-x86 rc-absolute-cell rel-literal ;
M: x86.32 prepare-division CDQ ;
M: x86.32 load-indirect
0 [] MOV rc-absolute-cell rel-literal ;
M: x86.32 %prologue ( n -- )
dup PUSH
0 PUSH rc-absolute-cell rel-this
stack-reg swap 3 cells - SUB ;
M: object %load-param-reg 3drop ;
@ -219,7 +221,7 @@ M: x86.32 %alien-indirect ( -- )
M: x86.32 %alien-callback ( quot -- )
4 [
EAX load-indirect
EAX swap %load-indirect
EAX PUSH
"c_to_factor" f %alien-invoke
] with-aligned-stack ;
@ -239,7 +241,7 @@ M: x86.32 %callback-value ( ctype -- )
! Unbox EAX
unbox-return ;
M: x86.32 %cleanup ( alien-node -- )
M: x86.32 %cleanup ( params -- )
#! a) If we just called an stdcall function in Windows, it
#! cleaned up the stack frame for us. But we don't want that
#! so we 'undo' the cleanup since we do that in %epilogue.
@ -256,7 +258,19 @@ M: x86.32 %cleanup ( alien-node -- )
[ drop ]
} cond ;
M: x86.32 %unwind ( n -- ) %epilogue-later RET ;
M: x86.32 %callback-return ( n -- )
#! a) If the callback is stdcall, we have to clean up the
#! caller's stack frame.
#! b) If the callback is returning a large struct, we have
#! to fix ESP.
{
{ [ dup abi>> "stdcall" = ] [
<alien-stack-frame>
[ params>> ] [ return>> ] bi +
] }
{ [ dup return>> large-struct? ] [ drop 4 ] }
[ drop 0 ]
} cond RET ;
os windows? [
cell "longlong" c-type (>>align)
@ -264,34 +278,19 @@ os windows? [
4 "double" c-type (>>align)
] unless
: (sse2?) ( -- ? ) "Intrinsic" throw ;
FUNCTION: bool check_sse2 ( ) ;
<<
\ (sse2?) [
{ EAX EBX ECX EDX } [ PUSH ] each
EAX 1 MOV
CPUID
EDX 26 SHR
EDX 1 AND
{ EAX EBX ECX EDX } [ POP ] each
JE
] { } define-if-intrinsic
\ (sse2?) { } { object } define-primitive
>>
: sse2? ( -- ? ) (sse2?) ;
: sse2? ( -- ? )
check_sse2 ;
"-no-sse2" cli-args member? [
[ optimized-recompile-hook ] recompile-hook
[ { check_sse2 } compile ] with-variable
"Checking if your CPU supports SSE2..." print flush
[ optimized-recompile-hook ] recompile-hook [
[ sse2? ] compile-call
] with-variable
[
sse2? [
" - yes" print
"cpu.x86.sse2" require
enable-float-intrinsics
[
sse2? [
"This image was built to use SSE2, which your CPU does not support." print
@ -300,7 +299,5 @@ os windows? [
1 exit
] unless
] "cpu.x86" add-init-hook
] [
" - no" print
] if
] [ " - no" print ] if
] unless

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

@ -6,6 +6,9 @@ IN: bootstrap.x86
4 \ cell set
: shift-arg ( -- reg ) ECX ;
: div-arg ( -- reg ) EAX ;
: mod-arg ( -- reg ) EDX ;
: arg0 ( -- reg ) EAX ;
: arg1 ( -- reg ) EDX ;
: temp-reg ( -- reg ) EBX ;

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

@ -1,43 +1,44 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types arrays cpu.x86.assembler
cpu.x86.architecture cpu.x86.intrinsics cpu.x86.sse2
cpu.x86.allot cpu.architecture kernel kernel.private math
namespaces make sequences compiler.generator
compiler.generator.registers compiler.generator.fixup system
layouts alien alien.accessors alien.structs slots splitting
assocs combinators ;
USING: accessors arrays kernel math namespaces make sequences
system layouts alien alien.c-types alien.accessors alien.structs
slots splitting assocs combinators cpu.x86.assembler
cpu.x86.architecture cpu.architecture compiler.constants
compiler.codegen compiler.codegen.fixup
compiler.cfg.instructions compiler.cfg.builder
compiler.cfg.intrinsics ;
IN: cpu.x86.64
M: x86.64 machine-registers
{
{ int-regs { RAX RCX RDX RBX RBP RSI RDI R8 R9 R10 R11 R12 R13 } }
{ double-float-regs {
XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7
XMM8 XMM9 XMM10 XMM11 XMM12 XMM13 XMM14 XMM15
} }
} ;
M: x86.64 ds-reg R14 ;
M: x86.64 rs-reg R15 ;
M: x86.64 stack-reg RSP ;
M: x86.64 temp-reg-1 RAX ;
M: x86.64 temp-reg-2 RCX ;
M: temp-reg v>operand drop RBX ;
M: int-regs return-reg drop RAX ;
M: int-regs vregs drop { RAX RCX RDX RBP RSI RDI R8 R9 R10 R11 R12 R13 } ;
M: int-regs param-regs drop { RDI RSI RDX RCX R8 R9 } ;
M: float-regs return-reg drop XMM0 ;
M: float-regs vregs
drop {
XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7
XMM8 XMM9 XMM10 XMM11 XMM12 XMM13 XMM14 XMM15
} ;
M: float-regs param-regs
drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
M: x86.64 fixnum>slot@ drop ;
M: x86.64 rel-literal-x86 rc-relative rel-literal ;
M: x86.64 prepare-division CQO ;
M: x86.64 load-indirect ( literal reg -- )
0 [] MOV rc-relative rel-literal ;
M: x86.64 %prologue ( n -- )
temp-reg-1 0 MOV rc-absolute-cell rel-this
dup PUSH
temp-reg-1 PUSH
stack-reg swap 3 cells - SUB ;
M: stack-params %load-param-reg
drop
@ -199,7 +200,8 @@ M: x86.64 %alien-indirect ( -- )
RBP CALL ;
M: x86.64 %alien-callback ( quot -- )
RDI load-indirect "c_to_factor" f %alien-invoke ;
RDI swap %load-indirect
"c_to_factor" f %alien-invoke ;
M: x86.64 %callback-value ( ctype -- )
! Save top of data stack
@ -215,16 +217,9 @@ M: x86.64 %callback-value ( ctype -- )
! Unbox former top of data stack to return registers
unbox-return ;
M: x86.64 %cleanup ( alien-node -- ) drop ;
! The result of reading 4 bytes from memory is a fixnum on
! x86-64.
enable-alien-4-intrinsics
M: x86.64 %unwind ( n -- ) drop %epilogue-later 0 RET ;
USE: cpu.x86.intrinsics
! On 64-bit systems, the result of reading 4 bytes from memory
! is a fixnum.
\ alien-unsigned-4 small-reg-32 define-unsigned-getter
\ set-alien-unsigned-4 small-reg-32 define-setter
\ alien-signed-4 small-reg-32 define-signed-getter
\ set-alien-signed-4 small-reg-32 define-setter
! SSE2 is always available on x86-64.
enable-float-intrinsics

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

@ -6,6 +6,9 @@ IN: bootstrap.x86
8 \ cell set
: shift-arg ( -- reg ) RCX ;
: div-arg ( -- reg ) RAX ;
: mod-arg ( -- reg ) RDX ;
: arg0 ( -- reg ) RDI ;
: arg1 ( -- reg ) RSI ;
: temp-reg ( -- reg ) RBX ;

119
basis/cpu/x86/allot/allot.factor
View File

@ -1,119 +0,0 @@
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel cpu.architecture cpu.x86.assembler
cpu.x86.architecture kernel.private namespaces math sequences
generic arrays compiler.generator compiler.generator.fixup
compiler.generator.registers system layouts alien ;
IN: cpu.x86.allot
: allot-reg ( -- reg )
#! We temporarily use the datastack register, since it won't
#! be accessed inside the quotation given to %allot in any
#! case.
ds-reg ;
: (object@) ( n -- operand ) allot-reg swap [+] ;
: object@ ( n -- operand ) cells (object@) ;
: load-zone-ptr ( reg -- )
#! Load pointer to start of zone array
0 MOV "nursery" f rc-absolute-cell rel-dlsym ;
: load-allot-ptr ( -- )
allot-reg load-zone-ptr
allot-reg PUSH
allot-reg dup cell [+] MOV ;
: inc-allot-ptr ( n -- )
allot-reg POP
allot-reg cell [+] swap 8 align ADD ;
M: x86 %gc ( -- )
"end" define-label
temp-reg-1 load-zone-ptr
temp-reg-2 temp-reg-1 cell [+] MOV
temp-reg-2 1024 ADD
temp-reg-1 temp-reg-1 3 cells [+] MOV
temp-reg-2 temp-reg-1 CMP
"end" get JLE
0 frame-required
%prepare-alien-invoke
"minor_gc" f %alien-invoke
"end" resolve-label ;
: store-header ( header -- )
0 object@ swap type-number tag-fixnum MOV ;
: %allot ( header size quot -- )
allot-reg PUSH
swap >r >r
load-allot-ptr
store-header
r> call
r> inc-allot-ptr
allot-reg POP ; inline
: %store-tagged ( reg tag -- )
>r dup fresh-object v>operand r>
allot-reg swap tag-number OR
allot-reg MOV ;
M: x86 %box-float ( dst src -- )
#! Only called by pentium4 backend, uses SSE2 instruction
#! dest is a loc or a vreg
float 16 [
8 (object@) swap v>operand MOVSD
float %store-tagged
] %allot ;
: %allot-bignum-signed-1 ( outreg inreg -- )
#! on entry, inreg is a signed 32-bit quantity
#! exits with tagged ptr to bignum in outreg
#! 1 cell header, 1 cell length, 1 cell sign, + digits
#! length is the # of digits + sign
[
{ "end" "nonzero" "positive" "store" }
[ define-label ] each
dup v>operand 0 CMP ! is it zero?
"nonzero" get JNE
0 >bignum pick load-literal ! this is our result
"end" get JMP
"nonzero" resolve-label
bignum 4 cells [
! Write length
1 object@ 2 v>operand MOV
! Test sign
dup v>operand 0 CMP
"positive" get JGE
2 object@ 1 MOV ! negative sign
dup v>operand NEG
"store" get JMP
"positive" resolve-label
2 object@ 0 MOV ! positive sign
"store" resolve-label
3 object@ swap v>operand MOV
! Store tagged ptr in reg
bignum %store-tagged
] %allot
"end" resolve-label
] with-scope ;
M: x86 %box-alien ( dst src -- )
[
{ "end" "f" } [ define-label ] each
dup v>operand 0 CMP
"f" get JE
alien 4 cells [
1 object@ f v>operand MOV
2 object@ f v>operand MOV
! Store src in alien-offset slot
3 object@ swap v>operand MOV
! Store tagged ptr in dst
dup object %store-tagged
] %allot
"end" get JMP
"f" resolve-label
f [ v>operand ] bi@ MOV
"end" resolve-label
] with-scope ;

631
basis/cpu/x86/architecture/architecture.factor
View File

@ -1,29 +1,473 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.c-types arrays cpu.x86.assembler
cpu.x86.assembler.private cpu.architecture kernel kernel.private
math memory namespaces make sequences words compiler.generator
compiler.generator.registers compiler.generator.fixup system
layouts combinators compiler.constants math.order ;
USING: accessors assocs alien alien.c-types arrays
cpu.x86.assembler cpu.x86.assembler.private cpu.architecture
kernel kernel.private math memory namespaces make sequences
words system layouts combinators math.order fry locals
compiler.constants compiler.cfg.registers
compiler.cfg.instructions compiler.codegen
compiler.codegen.fixup ;
IN: cpu.x86.architecture
M: x86 two-operand? t ;
HOOK: temp-reg-1 cpu ( -- reg )
HOOK: temp-reg-2 cpu ( -- reg )
M: x86 %load-immediate MOV ;
HOOK: rel-literal-x86 cpu ( literal -- )
M: x86 %load-indirect swap 0 [] MOV rel-literal-x86 ;
HOOK: ds-reg cpu ( -- reg )
HOOK: rs-reg cpu ( -- reg )
HOOK: stack-reg cpu ( -- reg )
: stack@ ( n -- op ) stack-reg swap [+] ;
: next-stack@ ( n -- operand )
#! nth parameter from the next stack frame. Used to box
#! input values to callbacks; the callback has its own
#! stack frame set up, and we want to read the frame
#! set up by the caller.
stack-frame get total-size>> + stack@ ;
: reg-stack ( n reg -- op ) swap cells neg [+] ;
M: ds-loc v>operand n>> ds-reg reg-stack ;
M: rs-loc v>operand n>> rs-reg reg-stack ;
GENERIC: loc>operand ( loc -- operand )
M: ds-loc loc>operand n>> ds-reg reg-stack ;
M: rs-loc loc>operand n>> rs-reg reg-stack ;
M: x86 %peek loc>operand MOV ;
M: x86 %replace loc>operand swap MOV ;
: (%inc) ( n reg -- ) swap cells dup 0 > [ ADD ] [ neg SUB ] if ; inline
M: x86 %inc-d ( n -- ) ds-reg (%inc) ;
M: x86 %inc-r ( n -- ) rs-reg (%inc) ;
: align-stack ( n -- n' )
os macosx? cpu x86.64? or [ 16 align ] when ;
M: x86 stack-frame-size ( stack-frame -- i )
[ spill-counts>> [ swap reg-size * ] { } assoc>map sum ]
[ params>> ]
[ return>> ]
tri + +
3 cells +
align-stack ;
M: x86 %call ( label -- ) CALL ;
M: x86 %jump-label ( label -- ) JMP ;
M: x86 %return ( -- ) 0 RET ;
: code-alignment ( align -- n )
[ building get [ integer? ] count dup ] dip align swap - ;
: align-code ( n -- )
0 <repetition> % ;
M:: x86 %dispatch ( src temp -- )
! Load jump table base. We use a temporary register
! since on AMD64 we have to load a 64-bit immediate. On
! x86, this is redundant.
! Add jump table base
temp HEX: ffffffff MOV rc-absolute-cell rel-here
src temp ADD
src HEX: 7f [+] JMP
! Fix up the displacement above
cell code-alignment dup bootstrap-cell 8 = 15 9 ? +
building get dup pop* push
align-code ;
M: x86 %dispatch-label ( word -- )
0 cell, rc-absolute-cell rel-word ;
:: (%slot) ( obj slot tag temp -- op )
temp slot obj [+] LEA
temp tag neg [+] ; inline
:: (%slot-imm) ( obj slot tag -- op )
obj slot cells tag - [+] ; inline
M: x86 %slot ( dst obj slot tag temp -- ) (%slot) MOV ;
M: x86 %slot-imm ( dst obj slot tag -- ) (%slot-imm) MOV ;
M: x86 %set-slot ( src obj slot tag temp -- ) (%slot) swap MOV ;
M: x86 %set-slot-imm ( src obj slot tag -- ) (%slot-imm) swap MOV ;
M: x86 %add [+] LEA ;
M: x86 %add-imm [+] LEA ;
M: x86 %sub nip SUB ;
M: x86 %sub-imm neg [+] LEA ;
M: x86 %mul nip swap IMUL2 ;
M: x86 %mul-imm nip IMUL2 ;
M: x86 %and nip AND ;
M: x86 %and-imm nip AND ;
M: x86 %or nip OR ;
M: x86 %or-imm nip OR ;
M: x86 %xor nip XOR ;
M: x86 %xor-imm nip XOR ;
M: x86 %shl-imm nip SHL ;
M: x86 %shr-imm nip SHR ;
M: x86 %sar-imm nip SAR ;
M: x86 %not drop NOT ;
: bignum@ ( reg n -- op )
cells bignum tag-number - [+] ; inline
M:: x86 %integer>bignum ( dst src temp -- )
#! on entry, inreg is a signed 32-bit quantity
#! exits with tagged ptr to bignum in outreg
#! 1 cell header, 1 cell length, 1 cell sign, + digits
#! length is the # of digits + sign
[
{ "end" "nonzero" "positive" } [ define-label ] each
src 0 CMP ! is it zero?
"nonzero" get JNE
! Use cached zero value
dst 0 >bignum %load-indirect
"end" get JMP
"nonzero" resolve-label
! Allocate a bignum
dst 4 cells bignum temp %allot
! Write length
dst 1 bignum@ 2 tag-fixnum MOV
! Test sign
src 0 CMP
"positive" get JGE
dst 2 bignum@ 1 MOV ! negative sign
src NEG
dst 3 bignum@ src MOV
src NEG ! we don't want to clobber src
"end" get JMP
"positive" resolve-label
dst 2 bignum@ 0 MOV ! positive sign
dst 3 bignum@ src MOV
"end" resolve-label
] with-scope ;
M:: x86 %bignum>integer ( dst src -- )
[
"nonzero" define-label
"end" define-label
dst src 1 bignum@ MOV
! if the length is 1, its just the sign and nothing else,
! so output 0
dst 1 tag-fixnum CMP
"nonzero" get JNE
dst 0 MOV
"end" get JMP
"nonzero" resolve-label
! load the value
dst src 3 bignum@ MOV
! is the sign negative?
src 2 bignum@ 0 CMP
"end" get JE
dst NEG
"end" resolve-label
] with-scope ;
M: x86 %add-float nip ADDSD ;
M: x86 %sub-float nip SUBSD ;
M: x86 %mul-float nip MULSD ;
M: x86 %div-float nip DIVSD ;
M: x86 %integer>float CVTSI2SD ;
M: x86 %float>integer CVTTSD2SI ;
: ?MOV ( dst src -- )
2dup = [ 2drop ] [ MOV ] if ; inline
M: x86 %copy ( dst src -- ) ?MOV ;
M: x86 %copy-float ( dst src -- )
2dup = [ 2drop ] [ MOVSD ] if ;
M: x86 %unbox-float ( dst src -- )
float-offset [+] MOVSD ;
M:: x86 %unbox-any-c-ptr ( dst src temp -- )
[
{ "is-byte-array" "end" "start" } [ define-label ] each
dst 0 MOV
temp src MOV
! We come back here with displaced aliens
"start" resolve-label
! Is the object f?
temp \ f tag-number CMP
"end" get JE
! Is the object an alien?
temp header-offset [+] alien type-number tag-fixnum CMP
"is-byte-array" get JNE
! If so, load the offset and add it to the address
dst temp alien-offset [+] ADD
! Now recurse on the underlying alien
temp temp underlying-alien-offset [+] MOV
"start" get JMP
"is-byte-array" resolve-label
! Add byte array address to address being computed
dst temp ADD
! Add an offset to start of byte array's data
dst byte-array-offset ADD
"end" resolve-label
] with-scope ;
M:: x86 %box-float ( dst src temp -- )
dst 16 float temp %allot
dst float-offset [+] src MOVSD ;
: alien@ ( reg n -- op ) cells object tag-number - [+] ;
M:: x86 %box-alien ( dst src temp -- )
[
{ "end" "f" } [ define-label ] each
src 0 CMP
"f" get JE
dst 4 cells alien temp %allot
dst 1 alien@ \ f tag-number MOV
dst 2 alien@ \ f tag-number MOV
! Store src in alien-offset slot
dst 3 alien@ src MOV
"end" get JMP
"f" resolve-label
dst \ f tag-number MOV
"end" resolve-label
] with-scope ;
: small-reg-4 ( reg -- reg' )
H{
{ EAX EAX }
{ ECX ECX }
{ EDX EDX }
{ EBX EBX }
{ ESP ESP }
{ EBP EBP }
{ ESI ESP }
{ EDI EDI }
{ RAX EAX }
{ RCX ECX }
{ RDX EDX }
{ RBX EBX }
{ RSP ESP }
{ RBP EBP }
{ RSI ESP }
{ RDI EDI }
} at ; inline
: small-reg-2 ( reg -- reg' )
small-reg-4 H{
{ EAX AX }
{ ECX CX }
{ EDX DX }
{ EBX BX }
{ ESP SP }
{ EBP BP }
{ ESI SI }
{ EDI DI }
} at ; inline
: small-reg-1 ( reg -- reg' )
small-reg-4 {
{ EAX AL }
{ ECX CL }
{ EDX DL }
{ EBX BL }
} at ; inline
: small-reg ( reg size -- reg' )
{
{ 1 [ small-reg-1 ] }
{ 2 [ small-reg-2 ] }
{ 4 [ small-reg-4 ] }
} case ;
: small-regs ( -- regs ) { EAX ECX EDX EBX } ; inline
: small-reg-that-isn't ( exclude -- reg' )
small-reg-4 small-regs [ eq? not ] with find nip ;
: with-save/restore ( reg quot -- )
[ drop PUSH ] [ call ] [ drop POP ] 2tri ; inline
:: with-small-register ( dst src quot: ( dst src -- ) -- )
#! If the destination register overlaps a small register, we
#! call the quot with that. Otherwise, we find a small
#! register that is not equal to src, and call quot, saving
#! and restoring the small register.
dst small-reg-4 small-regs memq? [ dst src quot call ] [
src small-reg-that-isn't
[| new-dst |
new-dst src quot call
dst new-dst MOV
] with-save/restore
] if ; inline
: %alien-integer-getter ( dst src size quot -- )
'[ [ dup _ small-reg dup ] [ [] ] bi* MOV @ ]
with-small-register ; inline
: %alien-unsigned-getter ( dst src size -- )
[ MOVZX ] %alien-integer-getter ; inline
M: x86 %alien-unsigned-1 1 %alien-unsigned-getter ;
M: x86 %alien-unsigned-2 2 %alien-unsigned-getter ;
: %alien-signed-getter ( dst src size -- )
[ MOVSX ] %alien-integer-getter ; inline
M: x86 %alien-signed-1 1 %alien-signed-getter ;
M: x86 %alien-signed-2 2 %alien-signed-getter ;
M: x86 %alien-signed-4 4 %alien-signed-getter ;
M: x86 %alien-unsigned-4 4 [ 2drop ] %alien-integer-getter ;
M: x86 %alien-cell [] MOV ;
M: x86 %alien-float dupd [] MOVSS dup CVTSS2SD ;
M: x86 %alien-double [] MOVSD ;
:: %alien-integer-setter ( ptr value size -- )
value ptr [| new-value ptr |
new-value value ?MOV
ptr [] new-value size small-reg MOV
] with-small-register ; inline
M: x86 %set-alien-integer-1 1 %alien-integer-setter ;
M: x86 %set-alien-integer-2 2 %alien-integer-setter ;
M: x86 %set-alien-integer-4 4 %alien-integer-setter ;
M: x86 %set-alien-cell [ [] ] dip MOV ;
M: x86 %set-alien-float dup dup CVTSD2SS [ [] ] dip MOVSS ;
M: x86 %set-alien-double [ [] ] dip MOVSD ;
: load-zone-ptr ( reg -- )
#! Load pointer to start of zone array
0 MOV "nursery" f rc-absolute-cell rel-dlsym ;
: load-allot-ptr ( nursery-ptr allot-ptr -- )
[ drop load-zone-ptr ] [ swap cell [+] MOV ] 2bi ;
: inc-allot-ptr ( nursery-ptr n -- )
[ cell [+] ] dip 8 align ADD ;
: store-header ( temp type -- )
[ [] ] [ type-number tag-fixnum ] bi* MOV ;
: store-tagged ( dst tag -- )
tag-number OR ;
M:: x86 %allot ( dst size class nursery-ptr -- )
nursery-ptr dst load-allot-ptr
dst class store-header
dst class store-tagged
nursery-ptr size inc-allot-ptr ;
HOOK: %alien-global cpu ( symbol dll register -- )
M:: x86 %write-barrier ( src card# table -- )
#! Mark the card pointed to by vreg.
! Mark the card
card# src MOV
card# card-bits SHR
"cards_offset" f table %alien-global
table card# [+] card-mark <byte> MOV
! Mark the card deck
card# deck-bits card-bits - SHR
"decks_offset" f table %alien-global
table card# [+] card-mark <byte> MOV ;
M: x86 %gc ( -- )
"end" define-label
temp-reg-1 load-zone-ptr
temp-reg-2 temp-reg-1 cell [+] MOV
temp-reg-2 1024 ADD
temp-reg-1 temp-reg-1 3 cells [+] MOV
temp-reg-2 temp-reg-1 CMP
"end" get JLE
%prepare-alien-invoke
"minor_gc" f %alien-invoke
"end" resolve-label ;
HOOK: stack-reg cpu ( -- reg )
: decr-stack-reg ( n -- )
dup 0 = [ drop ] [ stack-reg swap SUB ] if ;
: incr-stack-reg ( n -- )
dup 0 = [ drop ] [ stack-reg swap ADD ] if ;
M: x86 %epilogue ( n -- ) cell - incr-stack-reg ;
: %boolean ( dst word -- )
over \ f tag-number MOV
0 [] swap execute
\ t rel-literal-x86 ; inline
M: x86 %compare ( dst cc src1 src2 -- )
CMP {
{ cc< [ \ CMOVL %boolean ] }
{ cc<= [ \ CMOVLE %boolean ] }
{ cc> [ \ CMOVG %boolean ] }
{ cc>= [ \ CMOVGE %boolean ] }
{ cc= [ \ CMOVE %boolean ] }
{ cc/= [ \ CMOVNE %boolean ] }
} case ;
M: x86 %compare-imm ( dst cc src1 src2 -- )
%compare ;
M: x86 %compare-float ( dst cc src1 src2 -- )
UCOMISD {
{ cc< [ \ CMOVB %boolean ] }
{ cc<= [ \ CMOVBE %boolean ] }
{ cc> [ \ CMOVA %boolean ] }
{ cc>= [ \ CMOVAE %boolean ] }
{ cc= [ \ CMOVE %boolean ] }
{ cc/= [ \ CMOVNE %boolean ] }
} case ;
M: x86 %compare-branch ( label cc src1 src2 -- )
CMP {
{ cc< [ JL ] }
{ cc<= [ JLE ] }
{ cc> [ JG ] }
{ cc>= [ JGE ] }
{ cc= [ JE ] }
{ cc/= [ JNE ] }
} case ;
M: x86 %compare-imm-branch ( label src1 src2 cc -- )
%compare-branch ;
M: x86 %compare-float-branch ( label cc src1 src2 -- )
UCOMISD {
{ cc< [ JB ] }
{ cc<= [ JBE ] }
{ cc> [ JA ] }
{ cc>= [ JAE ] }
{ cc= [ JE ] }
{ cc/= [ JNE ] }
} case ;
: stack@ ( n -- op ) stack-reg swap [+] ;
: spill-integer-base ( stack-frame -- n )
[ params>> ] [ return>> ] bi + ;
: spill-integer@ ( n -- op )
cells
stack-frame get spill-integer-base
+ stack@ ;
: spill-float-base ( stack-frame -- n )
[ spill-counts>> int-regs swap at int-regs reg-size * ]
[ params>> ]
[ return>> ]
tri + + ;
: spill-float@ ( n -- op )
double-float-regs reg-size *
stack-frame get spill-float-base
+ stack@ ;
M: x86 %spill-integer ( src n -- ) spill-integer@ swap MOV ;
M: x86 %reload-integer ( dst n -- ) spill-integer@ MOV ;
M: x86 %spill-float spill-float@ swap MOVSD ;
M: x86 %reload-float spill-float@ MOVSD ;
M: x86 %loop-entry
16 code-alignment [ NOP ] times ;
M: int-regs %save-param-reg drop >r stack@ r> MOV ;
M: int-regs %load-param-reg drop swap stack@ MOV ;
@ -31,7 +475,6 @@ M: int-regs %load-param-reg drop swap stack@ MOV ;
GENERIC: MOVSS/D ( dst src reg-class -- )
M: single-float-regs MOVSS/D drop MOVSS ;
M: double-float-regs MOVSS/D drop MOVSD ;
M: float-regs %save-param-reg >r >r stack@ r> r> MOVSS/D ;
@ -41,100 +484,15 @@ GENERIC: push-return-reg ( reg-class -- )
GENERIC: load-return-reg ( n reg-class -- )
GENERIC: store-return-reg ( n reg-class -- )
! Only used by inline allocation
HOOK: temp-reg-1 cpu ( -- reg )
HOOK: temp-reg-2 cpu ( -- reg )
HOOK: fixnum>slot@ cpu ( op -- )
HOOK: prepare-division cpu ( -- )
M: immediate load-literal v>operand swap v>operand MOV ;
: align-stack ( n -- n' )
os macosx? cpu x86.64? or [ 16 align ] when ;
M: x86 stack-frame-size ( n -- i )
3 cells + align-stack ;
M: x86 %save-word-xt ( -- )
temp-reg v>operand 0 MOV rc-absolute-cell rel-this ;
: decr-stack-reg ( n -- )
dup 0 = [ drop ] [ stack-reg swap SUB ] if ;
M: x86 %prologue ( n -- )
dup PUSH
temp-reg v>operand PUSH
3 cells - decr-stack-reg ;
: incr-stack-reg ( n -- )
dup 0 = [ drop ] [ stack-reg swap ADD ] if ;
M: x86 %epilogue ( n -- ) cell - incr-stack-reg ;
HOOK: %alien-global cpu ( symbol dll register -- )
M: x86 %prepare-alien-invoke
#! Save Factor stack pointers in case the C code calls a
#! callback which does a GC, which must reliably trace
#! all roots.
"stack_chain" f temp-reg v>operand %alien-global
temp-reg v>operand [] stack-reg MOV
temp-reg v>operand [] cell SUB
temp-reg v>operand 2 cells [+] ds-reg MOV
temp-reg v>operand 3 cells [+] rs-reg MOV ;
M: x86 %call ( label -- ) CALL ;
M: x86 %jump-label ( label -- ) JMP ;
M: x86 %jump-f ( label -- )
"flag" operand f v>operand CMP JE ;
: code-alignment ( -- n )
building get length dup cell align swap - ;
: align-code ( n -- )
0 <repetition> % ;
M: x86 %dispatch ( -- )
[
%epilogue-later
! Load jump table base. We use a temporary register
! since on AMD64 we have to load a 64-bit immediate. On
! x86, this is redundant.
! Untag and multiply to get a jump table offset
"n" operand fixnum>slot@
! Add jump table base
"offset" operand HEX: ffffffff MOV rc-absolute-cell rel-here
"n" operand "offset" operand ADD
"n" operand HEX: 7f [+] JMP
! Fix up the displacement above
code-alignment dup bootstrap-cell 8 = 15 9 ? +
building get dup pop* push
align-code
] H{
{ +input+ { { f "n" } } }
{ +scratch+ { { f "offset" } } }
{ +clobber+ { "n" } }
} with-template ;
M: x86 %dispatch-label ( word -- )
0 cell, rc-absolute-cell rel-word ;
M: x86 %unbox-float ( dst src -- )
[ v>operand ] bi@ float-offset [+] MOVSD ;
M: x86 %peek [ v>operand ] bi@ MOV ;
M: x86 %replace swap %peek ;
: (%inc) ( n reg -- ) swap cells dup 0 > [ ADD ] [ neg SUB ] if ;
M: x86 %inc-d ( n -- ) ds-reg (%inc) ;
M: x86 %inc-r ( n -- ) rs-reg (%inc) ;
"stack_chain" f temp-reg-1 %alien-global
temp-reg-1 [] stack-reg MOV
temp-reg-1 [] cell SUB
temp-reg-1 2 cells [+] ds-reg MOV
temp-reg-1 3 cells [+] rs-reg MOV ;
M: x86 fp-shadows-int? ( -- ? ) f ;
@ -143,54 +501,9 @@ M: x86 value-structs? t ;
M: x86 small-enough? ( n -- ? )
HEX: -80000000 HEX: 7fffffff between? ;
: %untag ( reg -- ) tag-mask get bitnot AND ;
: %untag-fixnum ( reg -- ) tag-bits get SAR ;
: %tag-fixnum ( reg -- ) tag-bits get SHL ;
M: x86 %return ( -- ) 0 %unwind ;
! Alien intrinsics
M: x86 %unbox-byte-array ( dst src -- )
[ v>operand ] bi@ byte-array-offset [+] LEA ;
M: x86 %unbox-alien ( dst src -- )
[ v>operand ] bi@ alien-offset [+] MOV ;
M: x86 %unbox-f ( dst src -- )
drop v>operand 0 MOV ;
M: x86 %unbox-any-c-ptr ( dst src -- )
{ "is-byte-array" "end" "start" } [ define-label ] each
! Address is computed in ds-reg
ds-reg PUSH
ds-reg 0 MOV
! Object is stored in ds-reg
rs-reg PUSH
rs-reg swap v>operand MOV
! We come back here with displaced aliens
"start" resolve-label
! Is the object f?
rs-reg f v>operand CMP
"end" get JE
! Is the object an alien?
rs-reg header-offset [+] alien type-number tag-fixnum CMP
"is-byte-array" get JNE
! If so, load the offset and add it to the address
ds-reg rs-reg alien-offset [+] ADD
! Now recurse on the underlying alien
rs-reg rs-reg underlying-alien-offset [+] MOV
"start" get JMP
"is-byte-array" resolve-label
! Add byte array address to address being computed
ds-reg rs-reg ADD
! Add an offset to start of byte array's data
ds-reg byte-array-offset ADD
"end" resolve-label
! Done, store address in destination register
v>operand ds-reg MOV
! Restore rs-reg
rs-reg POP
! Restore ds-reg
ds-reg POP ;
: next-stack@ ( n -- operand )
#! nth parameter from the next stack frame. Used to box
#! input values to callbacks; the callback has its own
#! stack frame set up, and we want to read the frame
#! set up by the caller.
stack-frame get total-size>> + stack@ ;

5
basis/cpu/x86/assembler/assembler-tests.factor
View File

@ -57,3 +57,8 @@ IN: cpu.x86.assembler.tests
[ { HEX: 49 HEX: 89 HEX: 04 HEX: 2c } ] [ [ R12 RBP [+] RAX MOV ] { } make ] unit-test
[ [ R12 RSP [+] RAX MOV ] { } make ] must-fail
[ { HEX: 48 HEX: d3 HEX: e0 } ] [ [ RAX CL SHL ] { } make ] unit-test
[ { HEX: 48 HEX: d3 HEX: e1 } ] [ [ RCX CL SHL ] { } make ] unit-test
[ { HEX: 48 HEX: d3 HEX: e8 } ] [ [ RAX CL SHR ] { } make ] unit-test
[ { HEX: 48 HEX: d3 HEX: e9 } ] [ [ RCX CL SHR ] { } make ] unit-test

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

@ -1,9 +1,9 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays compiler.generator.fixup io.binary kernel
combinators kernel.private math namespaces make sequences
words system layouts math.order accessors
cpu.x86.assembler.syntax ;
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 ;
IN: cpu.x86.assembler
! A postfix assembler for x86 and AMD64.
@ -379,6 +379,8 @@ GENERIC: CMP ( dst src -- )
M: immediate CMP swap { BIN: 111 t HEX: 80 } immediate-1/4 ;
M: operand CMP OCT: 070 2-operand ;
: XCHG ( dst src -- ) OCT: 207 2-operand ;
: NOT ( dst -- ) { BIN: 010 t HEX: f7 } 1-operand ;
: NEG ( dst -- ) { BIN: 011 t HEX: f7 } 1-operand ;
: MUL ( dst -- ) { BIN: 100 t HEX: f7 } 1-operand ;
@ -389,13 +391,20 @@ M: operand CMP OCT: 070 2-operand ;
: CDQ ( -- ) HEX: 99 , ;
: CQO ( -- ) HEX: 48 , CDQ ;
: ROL ( dst n -- ) swap { BIN: 000 t HEX: c0 } immediate-1 ;
: ROR ( dst n -- ) swap { BIN: 001 t HEX: c0 } immediate-1 ;
: RCL ( dst n -- ) swap { BIN: 010 t HEX: c0 } immediate-1 ;
: RCR ( dst n -- ) swap { BIN: 011 t HEX: c0 } immediate-1 ;
: SHL ( dst n -- ) swap { BIN: 100 t HEX: c0 } immediate-1 ;
: SHR ( dst n -- ) swap { BIN: 101 t HEX: c0 } immediate-1 ;
: SAR ( dst n -- ) swap { BIN: 111 t HEX: c0 } immediate-1 ;
: (SHIFT) ( dst src op -- )
over CL eq? [
nip t HEX: d3 3array 1-operand
] [
swapd t HEX: c0 3array immediate-1
] if ; inline
: ROL ( dst n -- ) BIN: 000 (SHIFT) ;
: ROR ( dst n -- ) BIN: 001 (SHIFT) ;
: RCL ( dst n -- ) BIN: 010 (SHIFT) ;
: RCR ( dst n -- ) BIN: 011 (SHIFT) ;
: SHL ( dst n -- ) BIN: 100 (SHIFT) ;
: SHR ( dst n -- ) BIN: 101 (SHIFT) ;
: SAR ( dst n -- ) BIN: 111 (SHIFT) ;
GENERIC: IMUL2 ( dst src -- )
M: immediate IMUL2 swap dup reg-code t HEX: 68 3array immediate-1/4 ;
@ -407,6 +416,12 @@ M: operand IMUL2 OCT: 257 extended-opcode (2-operand) ;
swapd
(2-operand) ;
: MOVZX ( dst src -- )
OCT: 266 extended-opcode
over register-16? [ BIN: 1 opcode-or ] when
swapd
(2-operand) ;
! Conditional move
: MOVcc ( dst src cc -- ) extended-opcode swapd (2-operand) ;
@ -431,6 +446,10 @@ M: operand IMUL2 OCT: 257 extended-opcode (2-operand) ;
: CPUID ( -- ) HEX: a2 extended-opcode, ;
! Misc
: NOP ( -- ) HEX: 90 , ;
! x87 Floating Point Unit
: FSTPS ( operand -- ) { BIN: 011 f HEX: d9 } 1-operand ;

Some files were not shown because too many files have changed in this diff Show More