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

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

db4
Joe Groff 2009-07-30 11:05:36 -05:00
parent 455956b16c cd7a1d6c58
commit b6ddcafcbd
31 changed files with 467 additions and 475 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -6,9 +6,8 @@ classes.private arrays hashtables vectors classes.tuple sbufs
hashtables.private sequences.private math classes.tuple.private hashtables.private sequences.private math classes.tuple.private
growable namespaces.private assocs words command-line vocabs io growable namespaces.private assocs words command-line vocabs io
io.encodings.string libc splitting math.parser memory compiler.units io.encodings.string libc splitting math.parser memory compiler.units
math.order compiler.tree.builder compiler.tree.optimizer math.order quotations quotations.private assocs.private ;
compiler.cfg.optimizer ; FROM: compiler => enable-optimizer ;
FROM: compiler => enable-optimizer compile-word ;
IN: bootstrap.compiler IN: bootstrap.compiler
! Don't bring this in when deploying, since it will store a ! Don't bring this in when deploying, since it will store a
@ -42,16 +41,24 @@ nl
! which are also quick to compile are replaced by ! which are also quick to compile are replaced by
! compiled definitions as soon as possible. ! compiled definitions as soon as possible.
{ {
not not ?
2over roll -roll
array? hashtable? vector? array? hashtable? vector?
tuple? sbuf? tombstone? tuple? sbuf? tombstone?
curry? compose? callable?
quotation?
array-nth set-array-nth curry compose uncurry
array-nth set-array-nth length>>
wrap probe wrap probe
namestack* namestack*
layout-of
} compile-unoptimized } compile-unoptimized
"." write flush "." write flush
@ -75,7 +82,7 @@ nl
"." write flush "." write flush
{ {
hashcode* = get set hashcode* = equal? assoc-stack (assoc-stack) get set
} compile-unoptimized } compile-unoptimized
"." write flush "." write flush
@ -100,22 +107,6 @@ nl
"." write flush "." write flush
{ build-tree } compile-unoptimized
"." write flush
{ optimize-tree } compile-unoptimized
"." write flush
{ optimize-cfg } compile-unoptimized
"." write flush
{ compile-word } compile-unoptimized
"." write flush
vocabs [ words compile-unoptimized "." write flush ] each vocabs [ words compile-unoptimized "." write flush ] each
" done" print flush " done" print flush

18
basis/compiler/cfg/linear-scan/allocation/allocation.factor
View File

@ -28,29 +28,11 @@ IN: compiler.cfg.linear-scan.allocation
: no-free-registers? ( result -- ? ) : no-free-registers? ( result -- ? )
second 0 = ; inline second 0 = ; inline
: split-to-fit ( new n -- before after )
split-interval
[ [ compute-start/end ] bi@ ]
[ >>split-next drop ]
[ ]
2tri ;
: register-partially-available ( new result -- )
{
{ [ 2dup second 1 - spill-live-out? ] [ drop spill-live-out ] }
{ [ 2dup second 1 - spill-live-in? ] [ drop spill-live-in ] }
[
[ second 1 - split-to-fit ] keep
'[ _ register-available ] [ add-unhandled ] bi*
]
} cond ;
: assign-register ( new -- ) : assign-register ( new -- )
dup coalesce? [ coalesce ] [ dup coalesce? [ coalesce ] [
dup register-status { dup register-status {
{ [ dup no-free-registers? ] [ drop assign-blocked-register ] } { [ dup no-free-registers? ] [ drop assign-blocked-register ] }
{ [ 2dup register-available? ] [ register-available ] } { [ 2dup register-available? ] [ register-available ] }
! [ register-partially-available ]
[ drop assign-blocked-register ] [ drop assign-blocked-register ]
} cond } cond
] if ; ] if ;

90
basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor
View File

@ -28,23 +28,42 @@ ERROR: bad-live-ranges interval ;
[ swap first (>>from) ] [ swap first (>>from) ]
2bi ; 2bi ;
: split-for-spill ( live-interval n -- before after )
split-interval
{
[ [ trim-before-ranges ] [ trim-after-ranges ] bi* ]
[ [ compute-start/end ] bi@ ]
[ [ check-ranges ] bi@ ]
[ ]
} 2cleave ;
: assign-spill ( live-interval -- ) : assign-spill ( live-interval -- )
dup vreg>> assign-spill-slot >>spill-to f >>split-next drop ; dup vreg>> assign-spill-slot >>spill-to drop ;
: spill-before ( before -- before/f )
! If the interval does not have any usages before the spill location,
! then it is the second child of an interval that was split. We reload
! the value and let the resolve pass insert a split later.
dup uses>> empty? [ drop f ] [
{
[ ]
[ assign-spill ]
[ trim-before-ranges ]
[ compute-start/end ]
[ check-ranges ]
} cleave
] if ;
: assign-reload ( live-interval -- ) : assign-reload ( live-interval -- )
dup vreg>> assign-spill-slot >>reload-from drop ; dup vreg>> assign-spill-slot >>reload-from drop ;
: split-and-spill ( live-interval n -- before after ) : spill-after ( after -- after/f )
split-for-spill 2dup [ assign-spill ] [ assign-reload ] bi* ; ! If the interval has no more usages after the spill location,
! then it is the first child of an interval that was split. We
! spill the value and let the resolve pass insert a reload later.
dup uses>> empty? [ drop f ] [
{
[ ]
[ assign-reload ]
[ trim-after-ranges ]
[ compute-start/end ]
[ check-ranges ]
} cleave
] if ;
: split-for-spill ( live-interval n -- before after )
split-interval [ spill-before ] [ spill-after ] bi* ;
: find-use-position ( live-interval new -- n ) : find-use-position ( live-interval new -- n )
[ uses>> ] [ start>> '[ _ >= ] ] bi* find nip 1/0. or ; [ uses>> ] [ start>> '[ _ >= ] ] bi* find nip 1/0. or ;
@ -72,47 +91,12 @@ ERROR: bad-live-ranges interval ;
[ uses>> first ] [ second ] bi* > ; [ uses>> first ] [ second ] bi* > ;
: spill-new ( new pair -- ) : spill-new ( new pair -- )
drop drop spill-after add-unhandled ;
{
[ trim-after-ranges ]
[ compute-start/end ]
[ assign-reload ]
[ add-unhandled ]
} cleave ;
: spill-live-out? ( live-interval n -- ? ) [ uses>> last ] dip < ;
: spill-live-out ( live-interval -- )
! The interval has no more usages after the spill location. This
! means it is the first child of an interval that was split. We
! spill the value and let the resolve pass insert a reload later.
{
[ trim-before-ranges ]
[ compute-start/end ]
[ assign-spill ]
[ add-handled ]
} cleave ;
: spill-live-in? ( live-interval n -- ? ) [ uses>> first ] dip > ;
: spill-live-in ( live-interval -- )
! The interval does not have any usages before the spill location.
! This means it is the second child of an interval that was
! split. We reload the value and let the resolve pass insert a
! split later.
{
[ trim-after-ranges ]
[ compute-start/end ]
[ assign-reload ]
[ add-unhandled ]
} cleave ;
: spill ( live-interval n -- ) : spill ( live-interval n -- )
{ split-for-spill
{ [ 2dup spill-live-out? ] [ drop spill-live-out ] } [ [ add-handled ] when* ]
{ [ 2dup spill-live-in? ] [ drop spill-live-in ] } [ [ add-unhandled ] when* ] bi* ;
[ split-and-spill [ add-handled ] [ add-unhandled ] bi* ]
} cond ;
:: spill-intersecting-active ( new reg -- ) :: spill-intersecting-active ( new reg -- )
! If there is an active interval using 'reg' (there should be at ! If there is an active interval using 'reg' (there should be at
@ -149,8 +133,8 @@ ERROR: bad-live-ranges interval ;
! A register would be available for part of the new ! A register would be available for part of the new
! interval's lifetime if all active and inactive intervals ! interval's lifetime if all active and inactive intervals
! using that register were split and spilled. ! using that register were split and spilled.
[ second 1 - split-and-spill add-unhandled ] keep [ second 1 - split-for-spill [ add-unhandled ] when* ] keep
spill-available ; '[ _ spill-available ] when* ;
: assign-blocked-register ( new -- ) : assign-blocked-register ( new -- )
dup spill-status { dup spill-status {

4
basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor
View File

@ -27,9 +27,6 @@ IN: compiler.cfg.linear-scan.allocation.splitting
: split-uses ( uses n -- before after ) : split-uses ( uses n -- before after )
'[ _ <= ] partition ; '[ _ <= ] partition ;
: record-split ( live-interval before after -- )
[ >>split-before ] [ >>split-after ] bi* drop ; inline
ERROR: splitting-too-early ; ERROR: splitting-too-early ;
ERROR: splitting-too-late ; ERROR: splitting-too-late ;
@ -56,7 +53,6 @@ ERROR: splitting-atomic-interval ;
live-interval clone :> after live-interval clone :> after
live-interval uses>> n split-uses before after [ (>>uses) ] bi-curry@ bi* live-interval uses>> n split-uses before after [ (>>uses) ] bi-curry@ bi*
live-interval ranges>> n split-ranges before after [ (>>ranges) ] bi-curry@ bi* live-interval ranges>> n split-ranges before after [ (>>ranges) ] bi-curry@ bi*
live-interval before after record-split
before split-before before split-before
after split-after ; after split-after ;

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

@ -5,25 +5,12 @@ namespaces prettyprint compiler.cfg.linear-scan.live-intervals
compiler.cfg.linear-scan.allocation compiler.cfg assocs ; compiler.cfg.linear-scan.allocation compiler.cfg assocs ;
IN: compiler.cfg.linear-scan.debugger IN: compiler.cfg.linear-scan.debugger
: check-assigned ( live-intervals -- )
[
reg>>
[ "Not all intervals have registers" throw ] unless
] each ;
: split-children ( live-interval -- seq )
dup split-before>> [
[ split-before>> ] [ split-after>> ] bi
[ split-children ] bi@
append
] [ 1array ] if ;
: check-linear-scan ( live-intervals machine-registers -- ) : check-linear-scan ( live-intervals machine-registers -- )
[ [
[ clone ] map dup [ [ vreg>> ] keep ] H{ } map>assoc [ clone ] map dup [ [ vreg>> ] keep ] H{ } map>assoc
live-intervals set live-intervals set
] dip allocate-registers ] dip
[ split-children ] map concat check-assigned ; allocate-registers drop ;
: picture ( uses -- str ) : picture ( uses -- str )
dup last 1 + CHAR: space <string> dup last 1 + CHAR: space <string>

129
basis/compiler/cfg/linear-scan/linear-scan-tests.factor
View File

@ -75,6 +75,9 @@ check-numbering? on
{ T{ live-range f 0 5 } } 0 split-ranges { T{ live-range f 0 5 } } 0 split-ranges
] unit-test ] unit-test
H{ { int-regs 10 } { float-regs 20 } } clone spill-counts set
H{ } spill-slots set
[ [
T{ live-interval T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } } { vreg T{ vreg { reg-class int-regs } { n 1 } } }
@ -82,6 +85,7 @@ check-numbering? on
{ end 2 } { end 2 }
{ uses V{ 0 1 } } { uses V{ 0 1 } }
{ ranges V{ T{ live-range f 0 2 } } } { ranges V{ T{ live-range f 0 2 } } }
{ spill-to 10 }
} }
T{ live-interval T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } } { vreg T{ vreg { reg-class int-regs } { n 1 } } }
@ -89,6 +93,7 @@ check-numbering? on
{ end 5 } { end 5 }
{ uses V{ 5 } } { uses V{ 5 } }
{ ranges V{ T{ live-range f 5 5 } } } { ranges V{ T{ live-range f 5 5 } } }
{ reload-from 10 }
} }
] [ ] [
T{ live-interval T{ live-interval
@ -97,82 +102,61 @@ check-numbering? on
{ end 5 } { end 5 }
{ uses V{ 0 1 5 } } { uses V{ 0 1 5 } }
{ ranges V{ T{ live-range f 0 5 } } } { ranges V{ T{ live-range f 0 5 } } }
} 2 split-for-spill [ f >>split-next ] bi@ } 2 split-for-spill
] unit-test ] unit-test
[ [
T{ live-interval T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } } { vreg T{ vreg { reg-class int-regs } { n 2 } } }
{ start 0 } { start 0 }
{ end 1 } { end 1 }
{ uses V{ 0 } } { uses V{ 0 } }
{ ranges V{ T{ live-range f 0 1 } } } { ranges V{ T{ live-range f 0 1 } } }
{ spill-to 11 }
} }
T{ live-interval T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } } { vreg T{ vreg { reg-class int-regs } { n 2 } } }
{ start 1 } { start 1 }
{ end 5 } { end 5 }
{ uses V{ 1 5 } } { uses V{ 1 5 } }
{ ranges V{ T{ live-range f 1 5 } } } { ranges V{ T{ live-range f 1 5 } } }
{ reload-from 11 }
} }
] [ ] [
T{ live-interval T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } } { vreg T{ vreg { reg-class int-regs } { n 2 } } }
{ start 0 } { start 0 }
{ end 5 } { end 5 }
{ uses V{ 0 1 5 } } { uses V{ 0 1 5 } }
{ ranges V{ T{ live-range f 0 5 } } } { ranges V{ T{ live-range f 0 5 } } }
} 0 split-for-spill [ f >>split-next ] bi@ } 0 split-for-spill
] unit-test ] unit-test
[ [
T{ live-interval T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } } { vreg T{ vreg { reg-class int-regs } { n 3 } } }
{ start 0 } { start 0 }
{ end 1 } { end 1 }
{ uses V{ 0 } } { uses V{ 0 } }
{ ranges V{ T{ live-range f 0 1 } } } { ranges V{ T{ live-range f 0 1 } } }
{ spill-to 12 }
} }
T{ live-interval T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } } { vreg T{ vreg { reg-class int-regs } { n 3 } } }
{ start 20 } { start 20 }
{ end 30 } { end 30 }
{ uses V{ 20 30 } } { uses V{ 20 30 } }
{ ranges V{ T{ live-range f 20 30 } } } { ranges V{ T{ live-range f 20 30 } } }
{ reload-from 12 }
} }
] [ ] [
T{ live-interval T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } } { vreg T{ vreg { reg-class int-regs } { n 3 } } }
{ start 0 } { start 0 }
{ end 30 } { end 30 }
{ uses V{ 0 20 30 } } { uses V{ 0 20 30 } }
{ ranges V{ T{ live-range f 0 8 } T{ live-range f 10 18 } T{ live-range f 20 30 } } } { ranges V{ T{ live-range f 0 8 } T{ live-range f 10 18 } T{ live-range f 20 30 } } }
} 10 split-for-spill [ f >>split-next ] bi@ } 10 split-for-spill
] unit-test
[
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 0 }
{ end 4 }
{ uses V{ 0 1 4 } }
{ ranges V{ T{ live-range f 0 4 } } }
}
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 5 }
{ end 10 }
{ uses V{ 5 10 } }
{ ranges V{ T{ live-range f 5 10 } } }
}
] [
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 0 }
{ end 10 }
{ uses V{ 0 1 4 5 10 } }
{ ranges V{ T{ live-range f 0 10 } } }
} 4 split-to-fit [ f >>split-next ] bi@
] unit-test ] unit-test
[ [
@ -352,6 +336,78 @@ check-numbering? on
check-linear-scan check-linear-scan
] must-fail ] must-fail
! Problem with spilling intervals with no more usages after the spill location
[ ] [
{
T{ live-interval
{ vreg T{ vreg { n 1 } { reg-class int-regs } } }
{ start 0 }
{ end 20 }
{ uses V{ 0 10 20 } }
{ ranges V{ T{ live-range f 0 2 } T{ live-range f 10 20 } } }
}
T{ live-interval
{ vreg T{ vreg { n 2 } { reg-class int-regs } } }
{ start 0 }
{ end 20 }
{ uses V{ 0 10 20 } }
{ ranges V{ T{ live-range f 0 2 } T{ live-range f 10 20 } } }
}
T{ live-interval
{ vreg T{ vreg { n 3 } { reg-class int-regs } } }
{ start 4 }
{ end 8 }
{ uses V{ 6 } }
{ ranges V{ T{ live-range f 4 8 } } }
}
T{ live-interval
{ vreg T{ vreg { n 4 } { reg-class int-regs } } }
{ start 4 }
{ end 8 }
{ uses V{ 8 } }
{ ranges V{ T{ live-range f 4 8 } } }
}
! This guy will invoke the 'spill partially available' code path
T{ live-interval
{ vreg T{ vreg { n 5 } { reg-class int-regs } } }
{ start 4 }
{ end 8 }
{ uses V{ 8 } }
{ ranges V{ T{ live-range f 4 8 } } }
}
}
H{ { int-regs { "A" "B" } } }
check-linear-scan
] unit-test
! Test spill-new code path
[ ] [
{
T{ live-interval
{ vreg T{ vreg { n 1 } { reg-class int-regs } } }
{ start 0 }
{ end 10 }
{ uses V{ 0 6 10 } }
{ ranges V{ T{ live-range f 0 10 } } }
}
! This guy will invoke the 'spill new' code path
T{ live-interval
{ vreg T{ vreg { n 5 } { reg-class int-regs } } }
{ start 2 }
{ end 8 }
{ uses V{ 8 } }
{ ranges V{ T{ live-range f 2 8 } } }
}
}
H{ { int-regs { "A" } } }
check-linear-scan
] unit-test
SYMBOL: available SYMBOL: available
SYMBOL: taken SYMBOL: taken
@ -1761,11 +1817,6 @@ test-diamond
[ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test [ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test
[ ] [
1 get instructions>> first regs>> V int-regs 0 swap at
2 get instructions>> first regs>> V int-regs 1 swap at assert=
] unit-test
! Not until splitting is finished ! Not until splitting is finished
! [ _copy ] [ 3 get instructions>> second class ] unit-test ! [ _copy ] [ 3 get instructions>> second class ] unit-test

1
basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor
View File

@ -13,7 +13,6 @@ C: <live-range> live-range
TUPLE: live-interval TUPLE: live-interval
vreg vreg
reg spill-to reload-from reg spill-to reload-from
split-before split-after split-next
start end ranges uses start end ranges uses
copy-from ; copy-from ;

2
basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor
View File

@ -1,6 +1,6 @@
IN: compiler.cfg.linear-scan.resolve.tests IN: compiler.cfg.linear-scan.resolve.tests
USING: compiler.cfg.linear-scan.resolve tools.test kernel namespaces USING: compiler.cfg.linear-scan.resolve tools.test kernel namespaces
compiler.cfg.instructions cpu.architecture make compiler.cfg.instructions cpu.architecture make sequences
compiler.cfg.linear-scan.allocation.state ; compiler.cfg.linear-scan.allocation.state ;
[ [

4
basis/compiler/cfg/liveness/ssa/ssa.factor
View File

@ -55,3 +55,7 @@ SYMBOL: work-list
H{ } clone live-outs set H{ } clone live-outs set
dup post-order add-to-work-list dup post-order add-to-work-list
work-list get [ liveness-step ] slurp-deque ; work-list get [ liveness-step ] slurp-deque ;
: live-in? ( vreg bb -- ? ) live-in key? ;
: live-out? ( vreg bb -- ? ) live-out key? ;

6
basis/compiler/cfg/ssa/destruction/live-ranges/live-ranges.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs fry kernel namespaces sequences math USING: accessors assocs fry kernel namespaces sequences math
arrays compiler.cfg.def-use compiler.cfg.instructions arrays compiler.cfg.def-use compiler.cfg.instructions
compiler.cfg.liveness compiler.cfg.rpo ; compiler.cfg.liveness.ssa compiler.cfg.rpo ;
IN: compiler.cfg.ssa.destruction.live-ranges IN: compiler.cfg.ssa.destruction.live-ranges
! Live ranges for interference testing ! Live ranges for interference testing
@ -52,9 +52,9 @@ PRIVATE>
ERROR: bad-kill-index vreg bb ; ERROR: bad-kill-index vreg bb ;
: kill-index ( vreg bb -- n ) : kill-index ( vreg bb -- n )
2dup live-out key? [ 2drop 1/0. ] [ 2dup live-out? [ 2drop 1/0. ] [
2dup kill-indices get at at* [ 2nip ] [ 2dup kill-indices get at at* [ 2nip ] [
drop 2dup live-in key? drop 2dup live-in?
[ bad-kill-index ] [ 2drop -1/0. ] if [ bad-kill-index ] [ 2drop -1/0. ] if
] if ] if
] if ; ] if ;

12
basis/compiler/cfg/ssa/destruction/process-blocks/process-blocks.factor
View File

@ -4,7 +4,7 @@ USING: accessors assocs fry kernel locals math math.order arrays
namespaces sequences sorting sets combinators combinators.short-circuit make namespaces sequences sorting sets combinators combinators.short-circuit make
compiler.cfg.def-use compiler.cfg.def-use
compiler.cfg.instructions compiler.cfg.instructions
compiler.cfg.liveness compiler.cfg.liveness.ssa
compiler.cfg.dominance compiler.cfg.dominance
compiler.cfg.ssa.destruction.state compiler.cfg.ssa.destruction.state
compiler.cfg.ssa.destruction.forest compiler.cfg.ssa.destruction.forest
@ -19,13 +19,13 @@ IN: compiler.cfg.ssa.destruction.process-blocks
SYMBOLS: phi-union unioned-blocks ; SYMBOLS: phi-union unioned-blocks ;
:: operand-live-into-phi-node's-block? ( bb src dst -- ? ) :: operand-live-into-phi-node's-block? ( bb src dst -- ? )
src bb live-in key? ; src bb live-in? ;
:: phi-node-is-live-out-of-operand's-block? ( bb src dst -- ? ) :: phi-node-is-live-out-of-operand's-block? ( bb src dst -- ? )
dst src def-of live-out key? ; dst src def-of live-out? ;
:: operand-is-phi-node-and-live-into-operand's-block? ( bb src dst -- ? ) :: operand-is-phi-node-and-live-into-operand's-block? ( bb src dst -- ? )
{ [ src insn-of ##phi? ] [ src src def-of live-in key? ] } 0&& ; { [ src insn-of ##phi? ] [ src src def-of live-in? ] } 0&& ;
:: operand-being-renamed? ( bb src dst -- ? ) :: operand-being-renamed? ( bb src dst -- ? )
src processed-names get key? ; src processed-names get key? ;
@ -61,10 +61,10 @@ SYMBOLS: phi-union unioned-blocks ;
} cond ; } cond ;
: node-is-live-in-of-child? ( node child -- ? ) : node-is-live-in-of-child? ( node child -- ? )
[ vreg>> ] [ bb>> live-in ] bi* key? ; [ vreg>> ] [ bb>> ] bi* live-in? ;
: node-is-live-out-of-child? ( node child -- ? ) : node-is-live-out-of-child? ( node child -- ? )
[ vreg>> ] [ bb>> live-out ] bi* key? ; [ vreg>> ] [ bb>> ] bi* live-out? ;
:: insert-copy ( bb src dst -- ) :: insert-copy ( bb src dst -- )
bb src dst trivial-interference bb src dst trivial-interference

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

@ -1,13 +1,12 @@
! Copyright (C) 2005, 2009 Slava Pestov. ! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: locals alien.c-types alien.syntax arrays kernel fry USING: locals alien.c-types alien.syntax arrays kernel fry math
math namespaces sequences system layouts io vocabs.loader namespaces sequences system layouts io vocabs.loader accessors init
accessors init combinators command-line cpu.x86.assembler combinators command-line make compiler compiler.units
cpu.x86 cpu.architecture make compiler compiler.units
compiler.constants compiler.alien compiler.codegen compiler.constants compiler.alien compiler.codegen
compiler.codegen.fixup compiler.cfg.instructions compiler.codegen.fixup compiler.cfg.instructions compiler.cfg.builder
compiler.cfg.builder compiler.cfg.intrinsics compiler.cfg.intrinsics compiler.cfg.stack-frame cpu.x86.assembler
compiler.cfg.stack-frame ; cpu.x86.assembler.operands cpu.x86 cpu.architecture ;
IN: cpu.x86.32 IN: cpu.x86.32
! We implement the FFI for Linux, OS X and Windows all at once. ! We implement the FFI for Linux, OS X and Windows all at once.

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

@ -1,7 +1,8 @@
! Copyright (C) 2007, 2009 Slava Pestov. ! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: bootstrap.image.private kernel namespaces system USING: bootstrap.image.private kernel namespaces system
cpu.x86.assembler layouts vocabs parser compiler.constants ; cpu.x86.assembler cpu.x86.assembler.operands layouts
vocabs parser compiler.constants ;
IN: bootstrap.x86 IN: bootstrap.x86
4 \ cell set 4 \ cell set

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

@ -1,12 +1,11 @@
! Copyright (C) 2005, 2009 Slava Pestov. ! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays kernel math namespaces make sequences USING: accessors arrays kernel math namespaces make sequences system
system layouts alien alien.c-types alien.accessors alien.structs layouts alien alien.c-types alien.accessors alien.structs slots
slots splitting assocs combinators locals cpu.x86.assembler splitting assocs combinators locals compiler.constants
cpu.x86 cpu.architecture compiler.constants compiler.codegen compiler.codegen.fixup compiler.cfg.instructions
compiler.codegen compiler.codegen.fixup compiler.cfg.builder compiler.cfg.intrinsics compiler.cfg.stack-frame
compiler.cfg.instructions compiler.cfg.builder cpu.x86.assembler cpu.x86.assembler.operands cpu.x86 cpu.architecture ;
compiler.cfg.intrinsics compiler.cfg.stack-frame ;
IN: cpu.x86.64 IN: cpu.x86.64
M: x86.64 machine-registers M: x86.64 machine-registers

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

@ -1,7 +1,8 @@
! Copyright (C) 2007, 2009 Slava Pestov. ! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: bootstrap.image.private kernel namespaces system USING: bootstrap.image.private kernel namespaces system
cpu.x86.assembler layouts vocabs parser compiler.constants math ; layouts vocabs parser compiler.constants math
cpu.x86.assembler cpu.x86.assembler.operands ;
IN: bootstrap.x86 IN: bootstrap.x86
8 \ cell set 8 \ cell set

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

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: bootstrap.image.private kernel namespaces system USING: bootstrap.image.private kernel namespaces system
cpu.x86.assembler layouts vocabs parser ; cpu.x86.assembler cpu.x86.assembler.operands layouts vocabs parser ;
IN: bootstrap.x86 IN: bootstrap.x86
: stack-frame-size ( -- n ) 4 bootstrap-cells ; : stack-frame-size ( -- n ) 4 bootstrap-cells ;

8
basis/cpu/x86/64/unix/unix.factor
View File

@ -1,9 +1,9 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays sequences math splitting make assocs USING: accessors arrays sequences math splitting make assocs kernel
kernel layouts system alien.c-types alien.structs layouts system alien.c-types alien.structs cpu.architecture
cpu.architecture cpu.x86.assembler cpu.x86 cpu.x86.assembler cpu.x86.assembler.operands cpu.x86 compiler.codegen
compiler.codegen compiler.cfg.registers ; compiler.cfg.registers ;
IN: cpu.x86.64.unix IN: cpu.x86.64.unix
M: int-regs param-regs drop { RDI RSI RDX RCX R8 R9 } ; M: int-regs param-regs drop { RDI RSI RDX RCX R8 R9 } ;

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

@ -1,7 +1,8 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: bootstrap.image.private kernel namespaces system USING: bootstrap.image.private kernel namespaces system
cpu.x86.assembler layouts vocabs parser ; layouts vocabs parser cpu.x86.assembler
cpu.x86.assembler.operands ;
IN: bootstrap.x86 IN: bootstrap.x86
: stack-frame-size ( -- n ) 8 bootstrap-cells ; : stack-frame-size ( -- n ) 8 bootstrap-cells ;

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

@ -1,6 +1,9 @@
USING: cpu.x86.assembler kernel tools.test namespaces make ; USING: cpu.x86.assembler cpu.x86.assembler.operands
kernel tools.test namespaces make ;
IN: cpu.x86.assembler.tests IN: cpu.x86.assembler.tests
[ { HEX: 40 HEX: 8a HEX: 2a } ] [ [ BPL RDX [] MOV ] { } make ] unit-test
[ { HEX: 49 HEX: 89 HEX: 04 HEX: 24 } ] [ [ R12 [] RAX MOV ] { } make ] unit-test [ { HEX: 49 HEX: 89 HEX: 04 HEX: 24 } ] [ [ R12 [] RAX MOV ] { } make ] unit-test
[ { HEX: 49 HEX: 8b HEX: 06 } ] [ [ RAX R14 [] MOV ] { } make ] unit-test [ { HEX: 49 HEX: 8b HEX: 06 } ] [ [ RAX R14 [] MOV ] { } make ] unit-test

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

@ -1,90 +1,15 @@
! Copyright (C) 2005, 2009 Slava Pestov. ! Copyright (C) 2005, 2009 Slava Pestov, Joe Groff.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays io.binary kernel combinators kernel.private math USING: arrays io.binary kernel combinators kernel.private math locals
namespaces make sequences words system layouts math.order accessors namespaces make sequences words system layouts math.order accessors
cpu.x86.assembler.syntax ; cpu.x86.assembler.operands cpu.x86.assembler.operands.private ;
QUALIFIED: sequences QUALIFIED: sequences
IN: cpu.x86.assembler IN: cpu.x86.assembler
! A postfix assembler for x86-32 and x86-64. ! A postfix assembler for x86-32 and x86-64.
! In 32-bit mode, { 1234 } is absolute indirect addressing.
! In 64-bit mode, { 1234 } is RIP-relative.
! Beware!
! Register operands -- eg, ECX
REGISTERS: 8 AL CL DL BL SPL BPL SIL DIL R8B R9B R10B R11B R12B R13B R14B R15B ;
ALIAS: AH SPL
ALIAS: CH BPL
ALIAS: DH SIL
ALIAS: BH DIL
REGISTERS: 16 AX CX DX BX SP BP SI DI R8W R9W R10W R11W R12W R13W R14W R15W ;
REGISTERS: 32 EAX ECX EDX EBX ESP EBP ESI EDI R8D R9D R10D R11D R12D R13D R14D R15D ;
REGISTERS: 64
RAX RCX RDX RBX RSP RBP RSI RDI R8 R9 R10 R11 R12 R13 R14 R15 ;
REGISTERS: 128
XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7
XMM8 XMM9 XMM10 XMM11 XMM12 XMM13 XMM14 XMM15 ;
TUPLE: byte value ;
C: <byte> byte
<PRIVATE <PRIVATE
#! Extended AMD64 registers (R8-R15) return true.
GENERIC: extended? ( op -- ? )
M: object extended? drop f ;
PREDICATE: register < word
"register" word-prop ;
PREDICATE: register-8 < register
"register-size" word-prop 8 = ;
PREDICATE: register-16 < register
"register-size" word-prop 16 = ;
PREDICATE: register-32 < register
"register-size" word-prop 32 = ;
PREDICATE: register-64 < register
"register-size" word-prop 64 = ;
PREDICATE: register-128 < register
"register-size" word-prop 128 = ;
M: register extended? "register" word-prop 7 > ;
! Addressing modes
TUPLE: indirect base index scale displacement ;
M: indirect extended? base>> extended? ;
: canonicalize-EBP ( indirect -- indirect )
#! { EBP } ==> { EBP 0 }
dup [ base>> { EBP RBP R13 } member? ] [ displacement>> not ] bi and
[ 0 >>displacement ] when ;
ERROR: bad-index indirect ;
: check-ESP ( indirect -- indirect )
dup index>> { ESP RSP } memq? [ bad-index ] when ;
: canonicalize ( indirect -- indirect )
#! Modify the indirect to work around certain addressing mode
#! quirks.
canonicalize-EBP check-ESP ;
: <indirect> ( base index scale displacement -- indirect )
indirect boa canonicalize ;
: reg-code ( reg -- n ) "register" word-prop 7 bitand ; : reg-code ( reg -- n ) "register" word-prop 7 bitand ;
: indirect-base* ( op -- n ) base>> EBP or reg-code ; : indirect-base* ( op -- n ) base>> EBP or reg-code ;
@ -159,27 +84,13 @@ M: indirect displacement,
dup displacement>> dup [ dup displacement>> dup [
swap base>> swap base>>
[ dup fits-in-byte? [ , ] [ 4, ] if ] [ 4, ] if [ dup fits-in-byte? [ , ] [ 4, ] if ] [ 4, ] if
] [ ] [ 2drop ] if ;
2drop
] if ;
M: register displacement, drop ; M: register displacement, drop ;
: addressing ( reg# indirect -- ) : addressing ( reg# indirect -- )
[ mod-r/m, ] [ sib, ] [ displacement, ] tri ; [ mod-r/m, ] [ sib, ] [ displacement, ] tri ;
! Utilities
UNION: operand register indirect ;
GENERIC: operand-64? ( operand -- ? )
M: indirect operand-64?
[ base>> ] [ index>> ] bi [ operand-64? ] either? ;
M: register-64 operand-64? drop t ;
M: object operand-64? drop f ;
: rex.w? ( rex.w reg r/m -- ? ) : rex.w? ( rex.w reg r/m -- ? )
{ {
{ [ dup register-128? ] [ drop operand-64? ] } { [ dup register-128? ] [ drop operand-64? ] }
@ -192,22 +103,25 @@ M: object operand-64? drop f ;
: rex.b ( m op -- n ) : rex.b ( m op -- n )
[ extended? [ BIN: 00000001 bitor ] when ] keep [ extended? [ BIN: 00000001 bitor ] when ] keep
dup indirect? [ dup indirect? [ index>> extended? [ BIN: 00000010 bitor ] when ] [ drop ] if ;
index>> extended? [ BIN: 00000010 bitor ] when
] [
drop
] if ;
: rex-prefix ( reg r/m rex.w -- ) : no-prefix? ( prefix reg r/m -- ? )
[ BIN: 01000000 = ]
[ extended-8-bit-register? not ]
[ extended-8-bit-register? not ] tri*
and and ;
:: rex-prefix ( reg r/m rex.w -- )
#! Compile an AMD64 REX prefix. #! Compile an AMD64 REX prefix.
2over rex.w? BIN: 01001000 BIN: 01000000 ? rex.w reg r/m rex.w? BIN: 01001000 BIN: 01000000 ?
swap rex.r swap rex.b r/m rex.r
dup BIN: 01000000 = [ drop ] [ , ] if ; reg rex.b
dup reg r/m no-prefix? [ drop ] [ , ] if ;
: 16-prefix ( reg r/m -- ) : 16-prefix ( reg r/m -- )
[ register-16? ] either? [ HEX: 66 , ] when ; [ register-16? ] either? [ HEX: 66 , ] when ;
: prefix ( reg r/m rex.w -- ) 2over 16-prefix rex-prefix ; : prefix ( reg r/m rex.w -- ) [ drop 16-prefix ] [ rex-prefix ] 3bi ;
: prefix-1 ( reg rex.w -- ) f swap prefix ; : prefix-1 ( reg rex.w -- ) f swap prefix ;
@ -269,22 +183,10 @@ M: object operand-64? drop f ;
: 2-operand ( dst src op -- ) : 2-operand ( dst src op -- )
#! Sets the opcode's direction bit. It is set if the #! Sets the opcode's direction bit. It is set if the
#! destination is a direct register operand. #! destination is a direct register operand.
2over 16-prefix [ drop 16-prefix ] [ direction-bit operand-size-bit (2-operand) ] 3bi ;
direction-bit
operand-size-bit
(2-operand) ;
PRIVATE> PRIVATE>
: [] ( reg/displacement -- indirect )
dup integer? [ [ f f f ] dip ] [ f f f ] if <indirect> ;
: [+] ( reg displacement -- indirect )
dup integer?
[ dup zero? [ drop f ] when [ f f ] dip ]
[ f f ] if
<indirect> ;
! Moving stuff ! Moving stuff
GENERIC: PUSH ( op -- ) GENERIC: PUSH ( op -- )
M: register PUSH f HEX: 50 short-operand ; M: register PUSH f HEX: 50 short-operand ;

1
basis/cpu/x86/assembler/authors.txt
View File

@ -1 +1,2 @@
Slava Pestov Slava Pestov
Joe Groff

118
basis/cpu/x86/assembler/operands/operands.factor Normal file
View File

@ -0,0 +1,118 @@
! Copyright (C) 2008, 2009 Slava Pestov, Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel words math accessors sequences namespaces
assocs layouts cpu.x86.assembler.syntax ;
IN: cpu.x86.assembler.operands
! In 32-bit mode, { 1234 } is absolute indirect addressing.
! In 64-bit mode, { 1234 } is RIP-relative.
! Beware!
REGISTERS: 8 AL CL DL BL SPL BPL SIL DIL R8B R9B R10B R11B R12B R13B R14B R15B ;
ALIAS: AH SPL
ALIAS: CH BPL
ALIAS: DH SIL
ALIAS: BH DIL
REGISTERS: 16 AX CX DX BX SP BP SI DI R8W R9W R10W R11W R12W R13W R14W R15W ;
REGISTERS: 32 EAX ECX EDX EBX ESP EBP ESI EDI R8D R9D R10D R11D R12D R13D R14D R15D ;
REGISTERS: 64
RAX RCX RDX RBX RSP RBP RSI RDI R8 R9 R10 R11 R12 R13 R14 R15 ;
REGISTERS: 128
XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7
XMM8 XMM9 XMM10 XMM11 XMM12 XMM13 XMM14 XMM15 ;
<PRIVATE
GENERIC: extended? ( op -- ? )
M: object extended? drop f ;
PREDICATE: register < word
"register" word-prop ;
PREDICATE: register-8 < register
"register-size" word-prop 8 = ;
PREDICATE: register-16 < register
"register-size" word-prop 16 = ;
PREDICATE: register-32 < register
"register-size" word-prop 32 = ;
PREDICATE: register-64 < register
"register-size" word-prop 64 = ;
PREDICATE: register-128 < register
"register-size" word-prop 128 = ;
M: register extended? "register" word-prop 7 > ;
! Addressing modes
TUPLE: indirect base index scale displacement ;
M: indirect extended? base>> extended? ;
: canonicalize-EBP ( indirect -- indirect )
#! { EBP } ==> { EBP 0 }
dup [ base>> { EBP RBP R13 } member? ] [ displacement>> not ] bi and
[ 0 >>displacement ] when ;
ERROR: bad-index indirect ;
: check-ESP ( indirect -- indirect )
dup index>> { ESP RSP } memq? [ bad-index ] when ;
: canonicalize ( indirect -- indirect )
#! Modify the indirect to work around certain addressing mode
#! quirks.
canonicalize-EBP check-ESP ;
: <indirect> ( base index scale displacement -- indirect )
indirect boa canonicalize ;
! Utilities
UNION: operand register indirect ;
GENERIC: operand-64? ( operand -- ? )
M: indirect operand-64?
[ base>> ] [ index>> ] bi [ operand-64? ] either? ;
M: register-64 operand-64? drop t ;
M: object operand-64? drop f ;
PRIVATE>
: [] ( reg/displacement -- indirect )
dup integer? [ [ f f f ] dip ] [ f f f ] if <indirect> ;
: [+] ( reg displacement -- indirect )
dup integer?
[ dup zero? [ drop f ] when [ f f ] dip ]
[ f f ] if
<indirect> ;
TUPLE: byte value ;
C: <byte> byte
: extended-8-bit-register? ( register -- ? )
{ SPL BPL SIL DIL } memq? ;
: n-bit-version-of ( register n -- register' )
! Certain 8-bit registers don't exist in 32-bit mode...
[ "register" word-prop ] dip registers get at nth
dup extended-8-bit-register? cell 4 = and
[ drop f ] when ;
: 8-bit-version-of ( register -- register' ) 8 n-bit-version-of ;
: 16-bit-version-of ( register -- register' ) 16 n-bit-version-of ;
: 32-bit-version-of ( register -- register' ) 32 n-bit-version-of ;
: 64-bit-version-of ( register -- register' ) 64 n-bit-version-of ;
: native-version-of ( register -- register' ) cell-bits n-bit-version-of ;

27
basis/cpu/x86/assembler/syntax/syntax.factor
View File

@ -1,14 +1,23 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel words words.symbol sequences lexer parser fry ; USING: kernel words words.symbol sequences lexer parser fry
namespaces combinators assocs ;
IN: cpu.x86.assembler.syntax IN: cpu.x86.assembler.syntax
: define-register ( name num size -- ) SYMBOL: registers
[ "cpu.x86.assembler" create dup define-symbol ] 2dip
[ dupd "register" set-word-prop ] dip
"register-size" set-word-prop ;
: define-registers ( names size -- ) registers [ H{ } clone ] initialize
'[ _ define-register ] each-index ;
SYNTAX: REGISTERS: scan-word ";" parse-tokens swap define-registers ; : define-register ( name num size -- word )
[ "cpu.x86.assembler.operands" create ] 2dip {
[ 2drop ]
[ 2drop define-symbol ]
[ drop "register" set-word-prop ]
[ nip "register-size" set-word-prop ]
} 3cleave ;
: define-registers ( size names -- )
[ swap '[ _ define-register ] map-index ] [ drop ] 2bi
registers get set-at ;
SYNTAX: REGISTERS: scan-word ";" parse-tokens define-registers ;

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

@ -1,9 +1,9 @@
! Copyright (C) 2007, 2009 Slava Pestov. ! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: bootstrap.image.private kernel kernel.private namespaces USING: bootstrap.image.private kernel kernel.private namespaces system
system cpu.x86.assembler layouts compiler.units math layouts compiler.units math math.private compiler.constants vocabs
math.private compiler.constants vocabs slots.private words slots.private words locals.backend make sequences combinators arrays
locals.backend make sequences combinators arrays ; cpu.x86.assembler cpu.x86.assembler.operands ;
IN: bootstrap.x86 IN: bootstrap.x86
big-endian off big-endian off

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

@ -1,9 +1,9 @@
! Copyright (C) 2005, 2008 Slava Pestov. ! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs alien alien.c-types arrays strings USING: accessors assocs alien alien.c-types arrays strings
cpu.x86.assembler cpu.x86.assembler.private cpu.architecture cpu.x86.assembler cpu.x86.assembler.private cpu.x86.assembler.operands
kernel kernel.private math memory namespaces make sequences cpu.architecture kernel kernel.private math memory namespaces make
words system layouts combinators math.order fry locals sequences words system layouts combinators math.order fry locals
compiler.constants compiler.constants
compiler.cfg.registers compiler.cfg.registers
compiler.cfg.instructions compiler.cfg.instructions
@ -264,93 +264,118 @@ M:: x86 %box-alien ( dst src temp -- )
"end" resolve-label "end" resolve-label
] with-scope ; ] with-scope ;
: small-reg-8 ( reg -- reg' ) ! The 'small-reg' mess is pretty crappy, but its only used on x86-32.
H{ ! On x86-64, all registers have 8-bit versions. However, a similar
{ EAX RAX } ! problem arises for shifts, where the shift count must be in CL, and
{ ECX RCX } ! so one day I will fix this properly by adding precoloring to the
{ EDX RDX } ! register allocator.
{ EBX RBX }
{ ESP RSP }
{ EBP RBP }
{ ESI RSP }
{ EDI RDI }
{ RAX RAX } HOOK: has-small-reg? cpu ( reg size -- ? )
{ RCX RCX }
{ RDX RDX }
{ RBX RBX }
{ RSP RSP }
{ RBP RBP }
{ RSI RSP }
{ RDI RDI }
} at ; inline
: small-reg-4 ( reg -- reg' ) CONSTANT: have-byte-regs { EAX ECX EDX EBX }
small-reg-8 H{
{ RAX EAX }
{ RCX ECX }
{ RDX EDX }
{ RBX EBX }
{ RSP ESP }
{ RBP EBP }
{ RSI ESP }
{ RDI EDI }
} at ; inline
: small-reg-2 ( reg -- reg' ) M: x86.32 has-small-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 ] } { 8 [ have-byte-regs memq? ] }
{ 2 [ small-reg-2 ] } { 16 [ drop t ] }
{ 4 [ small-reg-4 ] } { 32 [ drop t ] }
{ 8 [ small-reg-8 ] }
} case ; } case ;
HOOK: small-regs cpu ( -- regs ) M: x86.64 has-small-reg? 2drop t ;
M: x86.32 small-regs { EAX ECX EDX EBX } ;
M: x86.64 small-regs { RAX RCX RDX RBX } ;
HOOK: small-reg-native cpu ( reg -- reg' )
M: x86.32 small-reg-native small-reg-4 ;
M: x86.64 small-reg-native small-reg-8 ;
: small-reg-that-isn't ( exclude -- reg' ) : small-reg-that-isn't ( exclude -- reg' )
small-regs swap [ small-reg-native ] map '[ _ memq? not ] find nip ; [ have-byte-regs ] dip
[ native-version-of ] map
'[ _ memq? not ] find nip ;
: with-save/restore ( reg quot -- ) : with-save/restore ( reg quot -- )
[ drop PUSH ] [ call ] [ drop POP ] 2tri ; inline [ drop PUSH ] [ call ] [ drop POP ] 2tri ; inline
:: with-small-register ( dst exclude quot: ( new-dst -- ) -- ) :: with-small-register ( dst exclude size quot: ( new-dst -- ) -- )
#! If the destination register overlaps a small register, we ! If the destination register overlaps a small register with
#! call the quot with that. Otherwise, we find a small ! 'size' bits, we call the quot with that. Otherwise, we find a
#! register that is not in exclude, and call quot, saving ! small register that is not in exclude, and call quot, saving and
#! and restoring the small register. ! restoring the small register.
dst small-reg-native small-regs memq? [ dst quot call ] [ dst size has-small-reg? [ dst quot call ] [
exclude small-reg-that-isn't exclude small-reg-that-isn't
[ quot call ] with-save/restore [ quot call ] with-save/restore
] if ; inline ] if ; inline
M:: x86 %string-nth ( dst src index temp -- )
! We request a small-reg of size 8 since those of size 16 are
! a superset.
"end" define-label
dst { src index temp } 8 [| new-dst |
! Load the least significant 7 bits into new-dst.
! 8th bit indicates whether we have to load from
! the aux vector or not.
temp src index [+] LEA
new-dst 8-bit-version-of temp string-offset [+] MOV
new-dst new-dst 8-bit-version-of MOVZX
! Do we have to look at the aux vector?
new-dst HEX: 80 CMP
"end" get JL
! Yes, this is a non-ASCII character. Load aux vector
temp src string-aux-offset [+] MOV
new-dst temp XCHG
! Compute index
new-dst index ADD
new-dst index ADD
! Load high 16 bits
new-dst 16-bit-version-of new-dst byte-array-offset [+] MOV
new-dst new-dst 16-bit-version-of MOVZX
new-dst 7 SHL
! Compute code point
new-dst temp XOR
"end" resolve-label
dst new-dst ?MOV
] with-small-register ;
M:: x86 %set-string-nth-fast ( ch str index temp -- )
ch { index str temp } 8 [| new-ch |
new-ch ch ?MOV
temp str index [+] LEA
temp string-offset [+] new-ch 8-bit-version-of MOV
] with-small-register ;
:: %alien-integer-getter ( dst src size quot -- )
dst { src } size [| new-dst |
new-dst dup size n-bit-version-of dup src [] MOV
quot call
dst new-dst ?MOV
] with-small-register ; inline
: %alien-unsigned-getter ( dst src size -- )
[ MOVZX ] %alien-integer-getter ; inline
M: x86 %alien-unsigned-1 8 %alien-unsigned-getter ;
M: x86 %alien-unsigned-2 16 %alien-unsigned-getter ;
M: x86 %alien-unsigned-4 32 [ 2drop ] %alien-integer-getter ;
: %alien-signed-getter ( dst src size -- )
[ MOVSX ] %alien-integer-getter ; inline
M: x86 %alien-signed-1 8 %alien-signed-getter ;
M: x86 %alien-signed-2 16 %alien-signed-getter ;
M: x86 %alien-signed-4 32 %alien-signed-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 } size [| new-value |
new-value value ?MOV
ptr [] new-value size n-bit-version-of MOV
] with-small-register ; inline
M: x86 %set-alien-integer-1 8 %alien-integer-setter ;
M: x86 %set-alien-integer-2 16 %alien-integer-setter ;
M: x86 %set-alien-integer-4 32 %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 ;
: shift-count? ( reg -- ? ) { ECX RCX } memq? ; : shift-count? ( reg -- ? ) { ECX RCX } memq? ;
:: emit-shift ( dst src1 src2 quot -- ) :: emit-shift ( dst src1 src2 quot -- )
@ -362,7 +387,7 @@ M: x86.64 small-reg-native small-reg-8 ;
src2 CL quot call src2 CL quot call
dst src2 XCHG dst src2 XCHG
] [ ] [
ECX small-reg-native [ ECX native-version-of [
CL src2 MOV CL src2 MOV
drop dst CL quot call drop dst CL quot call
] with-save/restore ] with-save/restore
@ -373,80 +398,6 @@ M: x86 %shl [ SHL ] emit-shift ;
M: x86 %shr [ SHR ] emit-shift ; M: x86 %shr [ SHR ] emit-shift ;
M: x86 %sar [ SAR ] emit-shift ; M: x86 %sar [ SAR ] emit-shift ;
M:: x86 %string-nth ( dst src index temp -- )
"end" define-label
dst { src index temp } [| new-dst |
! Load the least significant 7 bits into new-dst.
! 8th bit indicates whether we have to load from
! the aux vector or not.
temp src index [+] LEA
new-dst 1 small-reg temp string-offset [+] MOV
new-dst new-dst 1 small-reg MOVZX
! Do we have to look at the aux vector?
new-dst HEX: 80 CMP
"end" get JL
! Yes, this is a non-ASCII character. Load aux vector
temp src string-aux-offset [+] MOV
new-dst temp XCHG
! Compute index
new-dst index ADD
new-dst index ADD
! Load high 16 bits
new-dst 2 small-reg new-dst byte-array-offset [+] MOV
new-dst new-dst 2 small-reg MOVZX
new-dst 7 SHL
! Compute code point
new-dst temp XOR
"end" resolve-label
dst new-dst ?MOV
] with-small-register ;
M:: x86 %set-string-nth-fast ( ch str index temp -- )
ch { index str temp } [| new-ch |
new-ch ch ?MOV
temp str index [+] LEA
temp string-offset [+] new-ch 1 small-reg MOV
] with-small-register ;
:: %alien-integer-getter ( dst src size quot -- )
dst { src } [| new-dst |
new-dst dup size small-reg dup src [] MOV
quot call
dst new-dst ?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 |
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-zone-ptr ( reg -- )
#! Load pointer to start of zone array #! Load pointer to start of zone array
0 MOV "nursery" f rc-absolute-cell rel-dlsym ; 0 MOV "nursery" f rc-absolute-cell rel-dlsym ;

4
basis/xml/tests/test.factor
View File

@ -73,3 +73,7 @@ SYMBOL: xml-file
[ T{ xml-chunk f V{ "hello" } } ] [ "hello" string>xml-chunk ] unit-test [ T{ xml-chunk f V{ "hello" } } ] [ "hello" string>xml-chunk ] unit-test
[ "1.1" ] [ "<?xml version='1.1'?><x/>" string>xml prolog>> version>> ] unit-test [ "1.1" ] [ "<?xml version='1.1'?><x/>" string>xml prolog>> version>> ] unit-test
[ "ß" ] [ "<x>ß</x>" <string-reader> read-xml children>string ] unit-test [ "ß" ] [ "<x>ß</x>" <string-reader> read-xml children>string ] unit-test
! <pull-xml> tests
! this tests just checks that pull-event doesn't raise an exception
[ ] [ "vocab:xml/tests/test.xml" binary [ <pull-xml> pull-event drop ] with-file-reader ] unit-test

1
basis/xml/xml.factor
View File

@ -110,6 +110,7 @@ PRIVATE>
TUPLE: pull-xml scope ; TUPLE: pull-xml scope ;
: <pull-xml> ( -- pull-xml ) : <pull-xml> ( -- pull-xml )
[ [
init-parser
input-stream [ ] change ! bring var in this scope input-stream [ ] change ! bring var in this scope
init-xml text-now? on init-xml text-now? on
] H{ } make-assoc ] H{ } make-assoc

5
extra/irc/client/internals/internals.factor
View File

@ -75,8 +75,9 @@ M: to-many-chats message-forwards sender>> participant-chats ;
GENERIC: process-message ( irc-message -- ) GENERIC: process-message ( irc-message -- )
M: object process-message drop ; M: object process-message drop ;
M: ping process-message trailing>> /PONG ; M: ping process-message trailing>> /PONG ;
M: join process-message [ sender>> ] [ chat> ] bi join-participant ; ! FIXME: it shouldn't be checking for the presence of chat here...
M: part process-message [ sender>> ] [ chat> ] bi part-participant ; M: join process-message [ sender>> ] [ chat> ] bi [ join-participant ] [ drop ] if* ;
M: part process-message [ sender>> ] [ chat> ] bi [ part-participant ] [ drop ] if* ;
M: quit process-message sender>> quit-participant ; M: quit process-message sender>> quit-participant ;
M: nick process-message [ trailing>> ] [ sender>> ] bi rename-participant* ; M: nick process-message [ trailing>> ] [ sender>> ] bi rename-participant* ;
M: rpl-nickname-in-use process-message name>> "_" append /NICK ; M: rpl-nickname-in-use process-message name>> "_" append /NICK ;

14
extra/irc/logbot/logbot.factor
View File

@ -21,15 +21,17 @@ SYMBOL: current-stream
: timestamp-path ( timestamp -- path ) : timestamp-path ( timestamp -- path )
timestamp>ymd ".log" append log-directory prepend-path ; timestamp>ymd ".log" append log-directory prepend-path ;
: timestamp>stream ( timestamp -- stream ) : update-current-stream ( timestamp -- )
dup day-of-year current-day get = [
drop
] [
current-stream get [ dispose ] when* current-stream get [ dispose ] when*
[ day-of-year current-day set ] [ day-of-year current-day set ]
[ timestamp-path latin1 <file-appender> ] bi [ timestamp-path latin1 <file-appender> ] bi
current-stream set current-stream set ;
] if current-stream get ;
: same-day? ( timestamp -- ? ) day-of-year current-day get = ;
: timestamp>stream ( timestamp -- stream )
dup same-day? [ drop ] [ update-current-stream ] if
current-stream get ;
: log-message ( string timestamp -- ) : log-message ( string timestamp -- )
[ add-timestamp ] [ timestamp>stream ] bi [ add-timestamp ] [ timestamp>stream ] bi

2
misc/fuel/fuel-syntax.el
View File

@ -281,7 +281,7 @@
("\\_<\\(}\\)\\_>" (1 "){")) ("\\_<\\(}\\)\\_>" (1 "){"))
;; Parenthesis: ;; Parenthesis:
("\\_<\\((\\)\\_>" (1 "()")) ("\\_<\\((\\)\\_>" (1 "()"))
("\\_<call\\((\\)\\_>" (1 "()")) ("\\_<\\w*\\((\\)\\_>" (1 "()"))
("\\_<\\()\\)\\_>" (1 ")(")) ("\\_<\\()\\)\\_>" (1 ")("))
("\\_<(\\((\\)\\_>" (1 "()")) ("\\_<(\\((\\)\\_>" (1 "()"))
("\\_<\\()\\))\\_>" (1 ")(")) ("\\_<\\()\\))\\_>" (1 ")("))

7
vm/debug.cpp
View File

@ -173,10 +173,15 @@ void print_stack_frame(stack_frame *frame)
print_string("\n"); print_string("\n");
print_obj(frame_scan(frame)); print_obj(frame_scan(frame));
print_string("\n"); print_string("\n");
print_string("word/quot addr: ");
print_cell_hex((cell)frame_executing(frame)); print_cell_hex((cell)frame_executing(frame));
print_string(" "); print_string("\n");
print_string("word/quot xt: ");
print_cell_hex((cell)frame->xt); print_cell_hex((cell)frame->xt);
print_string("\n"); print_string("\n");
print_string("return address: ");
print_cell_hex((cell)FRAME_RETURN_ADDRESS(frame));
print_string("\n");
} }
void print_callstack() void print_callstack()