Merge branch 'master' of git://factorcode.org/git/factor
Joe Groff
commit
b6ddcafcbd
|
|
@ -6,9 +6,8 @@ classes.private arrays hashtables vectors classes.tuple sbufs
|
|||
hashtables.private sequences.private math classes.tuple.private
|
||||
growable namespaces.private assocs words command-line vocabs io
|
||||
io.encodings.string libc splitting math.parser memory compiler.units
|
||||
math.order compiler.tree.builder compiler.tree.optimizer
|
||||
compiler.cfg.optimizer ;
|
||||
FROM: compiler => enable-optimizer compile-word ;
|
||||
math.order quotations quotations.private assocs.private ;
|
||||
FROM: compiler => enable-optimizer ;
|
||||
IN: bootstrap.compiler
|
||||
|
||||
! 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
|
||||
! compiled definitions as soon as possible.
|
||||
{
|
||||
not
|
||||
not ?
|
||||
|
||||
2over roll -roll
|
||||
|
||||
array? hashtable? vector?
|
||||
tuple? sbuf? tombstone?
|
||||
curry? compose? callable?
|
||||
quotation?
|
||||
|
||||
array-nth set-array-nth
|
||||
curry compose uncurry
|
||||
|
||||
array-nth set-array-nth length>>
|
||||
|
||||
wrap probe
|
||||
|
||||
namestack*
|
||||
|
||||
layout-of
|
||||
} compile-unoptimized
|
||||
|
||||
"." write flush
|
||||
|
|
@ -75,7 +82,7 @@ nl
|
|||
"." write flush
|
||||
|
||||
{
|
||||
hashcode* = get set
|
||||
hashcode* = equal? assoc-stack (assoc-stack) get set
|
||||
} compile-unoptimized
|
||||
|
||||
"." write flush
|
||||
|
|
@ -100,22 +107,6 @@ nl
|
|||
|
||||
"." 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
|
||||
|
||||
" done" print flush
|
||||
|
|
|
|||
|
|
@ -28,29 +28,11 @@ IN: compiler.cfg.linear-scan.allocation
|
|||
: no-free-registers? ( result -- ? )
|
||||
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 -- )
|
||||
dup coalesce? [ coalesce ] [
|
||||
dup register-status {
|
||||
{ [ dup no-free-registers? ] [ drop assign-blocked-register ] }
|
||||
{ [ 2dup register-available? ] [ register-available ] }
|
||||
! [ register-partially-available ]
|
||||
[ drop assign-blocked-register ]
|
||||
} cond
|
||||
] if ;
|
||||
|
|
|
|||
|
|
@ -28,23 +28,42 @@ ERROR: bad-live-ranges interval ;
|
|||
[ swap first (>>from) ]
|
||||
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 -- )
|
||||
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 -- )
|
||||
dup vreg>> assign-spill-slot >>reload-from drop ;
|
||||
|
||||
: split-and-spill ( live-interval n -- before after )
|
||||
split-for-spill 2dup [ assign-spill ] [ assign-reload ] bi* ;
|
||||
: spill-after ( after -- after/f )
|
||||
! 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 )
|
||||
[ uses>> ] [ start>> '[ _ >= ] ] bi* find nip 1/0. or ;
|
||||
|
|
@ -72,47 +91,12 @@ ERROR: bad-live-ranges interval ;
|
|||
[ uses>> first ] [ second ] bi* > ;
|
||||
|
||||
: spill-new ( new pair -- )
|
||||
drop
|
||||
{
|
||||
[ 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 ;
|
||||
drop spill-after add-unhandled ;
|
||||
|
||||
: spill ( live-interval n -- )
|
||||
{
|
||||
{ [ 2dup spill-live-out? ] [ drop spill-live-out ] }
|
||||
{ [ 2dup spill-live-in? ] [ drop spill-live-in ] }
|
||||
[ split-and-spill [ add-handled ] [ add-unhandled ] bi* ]
|
||||
} cond ;
|
||||
split-for-spill
|
||||
[ [ add-handled ] when* ]
|
||||
[ [ add-unhandled ] when* ] bi* ;
|
||||
|
||||
:: spill-intersecting-active ( new reg -- )
|
||||
! 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
|
||||
! interval's lifetime if all active and inactive intervals
|
||||
! using that register were split and spilled.
|
||||
[ second 1 - split-and-spill add-unhandled ] keep
|
||||
spill-available ;
|
||||
[ second 1 - split-for-spill [ add-unhandled ] when* ] keep
|
||||
'[ _ spill-available ] when* ;
|
||||
|
||||
: assign-blocked-register ( new -- )
|
||||
dup spill-status {
|
||||
|
|
|
|||
|
|
@ -27,9 +27,6 @@ IN: compiler.cfg.linear-scan.allocation.splitting
|
|||
: split-uses ( uses n -- before after )
|
||||
'[ _ <= ] partition ;
|
||||
|
||||
: record-split ( live-interval before after -- )
|
||||
[ >>split-before ] [ >>split-after ] bi* drop ; inline
|
||||
|
||||
ERROR: splitting-too-early ;
|
||||
|
||||
ERROR: splitting-too-late ;
|
||||
|
|
@ -56,7 +53,6 @@ ERROR: splitting-atomic-interval ;
|
|||
live-interval clone :> after
|
||||
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 before after record-split
|
||||
before split-before
|
||||
after split-after ;
|
||||
|
||||
|
|
|
|||
|
|
@ -5,25 +5,12 @@ namespaces prettyprint compiler.cfg.linear-scan.live-intervals
|
|||
compiler.cfg.linear-scan.allocation compiler.cfg assocs ;
|
||||
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 -- )
|
||||
[
|
||||
[ clone ] map dup [ [ vreg>> ] keep ] H{ } map>assoc
|
||||
live-intervals set
|
||||
] dip allocate-registers
|
||||
[ split-children ] map concat check-assigned ;
|
||||
] dip
|
||||
allocate-registers drop ;
|
||||
|
||||
: picture ( uses -- str )
|
||||
dup last 1 + CHAR: space <string>
|
||||
|
|
|
|||
|
|
@ -75,6 +75,9 @@ check-numbering? on
|
|||
{ T{ live-range f 0 5 } } 0 split-ranges
|
||||
] unit-test
|
||||
|
||||
H{ { int-regs 10 } { float-regs 20 } } clone spill-counts set
|
||||
H{ } spill-slots set
|
||||
|
||||
[
|
||||
T{ live-interval
|
||||
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
|
||||
|
|
@ -82,6 +85,7 @@ check-numbering? on
|
|||
{ end 2 }
|
||||
{ uses V{ 0 1 } }
|
||||
{ ranges V{ T{ live-range f 0 2 } } }
|
||||
{ spill-to 10 }
|
||||
}
|
||||
T{ live-interval
|
||||
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
|
||||
|
|
@ -89,6 +93,7 @@ check-numbering? on
|
|||
{ end 5 }
|
||||
{ uses V{ 5 } }
|
||||
{ ranges V{ T{ live-range f 5 5 } } }
|
||||
{ reload-from 10 }
|
||||
}
|
||||
] [
|
||||
T{ live-interval
|
||||
|
|
@ -97,82 +102,61 @@ check-numbering? on
|
|||
{ end 5 }
|
||||
{ uses V{ 0 1 5 } }
|
||||
{ ranges V{ T{ live-range f 0 5 } } }
|
||||
} 2 split-for-spill [ f >>split-next ] bi@
|
||||
} 2 split-for-spill
|
||||
] unit-test
|
||||
|
||||
[
|
||||
T{ live-interval
|
||||
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
|
||||
{ vreg T{ vreg { reg-class int-regs } { n 2 } } }
|
||||
{ start 0 }
|
||||
{ end 1 }
|
||||
{ uses V{ 0 } }
|
||||
{ ranges V{ T{ live-range f 0 1 } } }
|
||||
{ spill-to 11 }
|
||||
}
|
||||
T{ live-interval
|
||||
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
|
||||
{ vreg T{ vreg { reg-class int-regs } { n 2 } } }
|
||||
{ start 1 }
|
||||
{ end 5 }
|
||||
{ uses V{ 1 5 } }
|
||||
{ ranges V{ T{ live-range f 1 5 } } }
|
||||
{ reload-from 11 }
|
||||
}
|
||||
] [
|
||||
T{ live-interval
|
||||
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
|
||||
{ vreg T{ vreg { reg-class int-regs } { n 2 } } }
|
||||
{ start 0 }
|
||||
{ end 5 }
|
||||
{ uses V{ 0 1 5 } }
|
||||
{ ranges V{ T{ live-range f 0 5 } } }
|
||||
} 0 split-for-spill [ f >>split-next ] bi@
|
||||
} 0 split-for-spill
|
||||
] unit-test
|
||||
|
||||
[
|
||||
T{ live-interval
|
||||
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
|
||||
{ vreg T{ vreg { reg-class int-regs } { n 3 } } }
|
||||
{ start 0 }
|
||||
{ end 1 }
|
||||
{ uses V{ 0 } }
|
||||
{ ranges V{ T{ live-range f 0 1 } } }
|
||||
{ spill-to 12 }
|
||||
}
|
||||
T{ live-interval
|
||||
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
|
||||
{ vreg T{ vreg { reg-class int-regs } { n 3 } } }
|
||||
{ start 20 }
|
||||
{ end 30 }
|
||||
{ uses V{ 20 30 } }
|
||||
{ ranges V{ T{ live-range f 20 30 } } }
|
||||
{ reload-from 12 }
|
||||
}
|
||||
] [
|
||||
T{ live-interval
|
||||
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
|
||||
{ vreg T{ vreg { reg-class int-regs } { n 3 } } }
|
||||
{ start 0 }
|
||||
{ end 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 } } }
|
||||
} 10 split-for-spill [ f >>split-next ] bi@
|
||||
] 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@
|
||||
} 10 split-for-spill
|
||||
] unit-test
|
||||
|
||||
[
|
||||
|
|
@ -352,6 +336,78 @@ check-numbering? on
|
|||
check-linear-scan
|
||||
] 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: taken
|
||||
|
|
@ -1761,11 +1817,6 @@ test-diamond
|
|||
|
||||
[ ] [ { 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
|
||||
! [ _copy ] [ 3 get instructions>> second class ] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -13,7 +13,6 @@ C: <live-range> live-range
|
|||
TUPLE: live-interval
|
||||
vreg
|
||||
reg spill-to reload-from
|
||||
split-before split-after split-next
|
||||
start end ranges uses
|
||||
copy-from ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
IN: compiler.cfg.linear-scan.resolve.tests
|
||||
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 ;
|
||||
|
||||
[
|
||||
|
|
|
|||
|
|
@ -55,3 +55,7 @@ SYMBOL: work-list
|
|||
H{ } clone live-outs set
|
||||
dup post-order add-to-work-list
|
||||
work-list get [ liveness-step ] slurp-deque ;
|
||||
|
||||
: live-in? ( vreg bb -- ? ) live-in key? ;
|
||||
|
||||
: live-out? ( vreg bb -- ? ) live-out key? ;
|
||||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors assocs fry kernel namespaces sequences math
|
||||
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
|
||||
|
||||
! Live ranges for interference testing
|
||||
|
|
@ -52,9 +52,9 @@ PRIVATE>
|
|||
ERROR: bad-kill-index vreg bb ;
|
||||
|
||||
: 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 ] [
|
||||
drop 2dup live-in key?
|
||||
drop 2dup live-in?
|
||||
[ bad-kill-index ] [ 2drop -1/0. ] if
|
||||
] if
|
||||
] if ;
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ USING: accessors assocs fry kernel locals math math.order arrays
|
|||
namespaces sequences sorting sets combinators combinators.short-circuit make
|
||||
compiler.cfg.def-use
|
||||
compiler.cfg.instructions
|
||||
compiler.cfg.liveness
|
||||
compiler.cfg.liveness.ssa
|
||||
compiler.cfg.dominance
|
||||
compiler.cfg.ssa.destruction.state
|
||||
compiler.cfg.ssa.destruction.forest
|
||||
|
|
@ -19,13 +19,13 @@ IN: compiler.cfg.ssa.destruction.process-blocks
|
|||
SYMBOLS: phi-union unioned-blocks ;
|
||||
|
||||
:: 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 -- ? )
|
||||
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 -- ? )
|
||||
{ [ 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 -- ? )
|
||||
src processed-names get key? ;
|
||||
|
|
@ -61,10 +61,10 @@ SYMBOLS: phi-union unioned-blocks ;
|
|||
} cond ;
|
||||
|
||||
: 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 -- ? )
|
||||
[ vreg>> ] [ bb>> live-out ] bi* key? ;
|
||||
[ vreg>> ] [ bb>> ] bi* live-out? ;
|
||||
|
||||
:: insert-copy ( bb src dst -- )
|
||||
bb src dst trivial-interference
|
||||
|
|
|
|||
|
|
@ -1,13 +1,12 @@
|
|||
! Copyright (C) 2005, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: locals alien.c-types alien.syntax arrays kernel fry
|
||||
math namespaces sequences system layouts io vocabs.loader
|
||||
accessors init combinators command-line cpu.x86.assembler
|
||||
cpu.x86 cpu.architecture make compiler compiler.units
|
||||
USING: locals alien.c-types alien.syntax arrays kernel fry math
|
||||
namespaces sequences system layouts io vocabs.loader accessors init
|
||||
combinators command-line make compiler compiler.units
|
||||
compiler.constants compiler.alien compiler.codegen
|
||||
compiler.codegen.fixup compiler.cfg.instructions
|
||||
compiler.cfg.builder compiler.cfg.intrinsics
|
||||
compiler.cfg.stack-frame ;
|
||||
compiler.codegen.fixup compiler.cfg.instructions compiler.cfg.builder
|
||||
compiler.cfg.intrinsics compiler.cfg.stack-frame cpu.x86.assembler
|
||||
cpu.x86.assembler.operands cpu.x86 cpu.architecture ;
|
||||
IN: cpu.x86.32
|
||||
|
||||
! We implement the FFI for Linux, OS X and Windows all at once.
|
||||
|
|
|
|||
|
|
@ -1,7 +1,8 @@
|
|||
! Copyright (C) 2007, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: bootstrap.image.private kernel namespaces system
|
||||
cpu.x86.assembler layouts vocabs parser compiler.constants ;
|
||||
cpu.x86.assembler cpu.x86.assembler.operands layouts
|
||||
vocabs parser compiler.constants ;
|
||||
IN: bootstrap.x86
|
||||
|
||||
4 \ cell set
|
||||
|
|
|
|||
|
|
@ -1,12 +1,11 @@
|
|||
! Copyright (C) 2005, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays kernel math namespaces make sequences
|
||||
system layouts alien alien.c-types alien.accessors alien.structs
|
||||
slots splitting assocs combinators locals cpu.x86.assembler
|
||||
cpu.x86 cpu.architecture compiler.constants
|
||||
compiler.codegen compiler.codegen.fixup
|
||||
compiler.cfg.instructions compiler.cfg.builder
|
||||
compiler.cfg.intrinsics compiler.cfg.stack-frame ;
|
||||
USING: accessors arrays kernel math namespaces make sequences system
|
||||
layouts alien alien.c-types alien.accessors alien.structs slots
|
||||
splitting assocs combinators locals compiler.constants
|
||||
compiler.codegen compiler.codegen.fixup compiler.cfg.instructions
|
||||
compiler.cfg.builder compiler.cfg.intrinsics compiler.cfg.stack-frame
|
||||
cpu.x86.assembler cpu.x86.assembler.operands cpu.x86 cpu.architecture ;
|
||||
IN: cpu.x86.64
|
||||
|
||||
M: x86.64 machine-registers
|
||||
|
|
|
|||
|
|
@ -1,7 +1,8 @@
|
|||
! Copyright (C) 2007, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: bootstrap.image.private kernel namespaces system
|
||||
cpu.x86.assembler layouts vocabs parser compiler.constants math ;
|
||||
layouts vocabs parser compiler.constants math
|
||||
cpu.x86.assembler cpu.x86.assembler.operands ;
|
||||
IN: bootstrap.x86
|
||||
|
||||
8 \ cell set
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
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
|
||||
|
||||
: stack-frame-size ( -- n ) 4 bootstrap-cells ;
|
||||
|
|
|
|||
|
|
@ -1,9 +1,9 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays sequences math splitting make assocs
|
||||
kernel layouts system alien.c-types alien.structs
|
||||
cpu.architecture cpu.x86.assembler cpu.x86
|
||||
compiler.codegen compiler.cfg.registers ;
|
||||
USING: accessors arrays sequences math splitting make assocs kernel
|
||||
layouts system alien.c-types alien.structs cpu.architecture
|
||||
cpu.x86.assembler cpu.x86.assembler.operands cpu.x86 compiler.codegen
|
||||
compiler.cfg.registers ;
|
||||
IN: cpu.x86.64.unix
|
||||
|
||||
M: int-regs param-regs drop { RDI RSI RDX RCX R8 R9 } ;
|
||||
|
|
|
|||
|
|
@ -1,7 +1,8 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
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
|
||||
|
||||
: stack-frame-size ( -- n ) 8 bootstrap-cells ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
[ { 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: 8b HEX: 06 } ] [ [ RAX R14 [] MOV ] { } make ] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
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
|
||||
cpu.x86.assembler.syntax ;
|
||||
cpu.x86.assembler.operands cpu.x86.assembler.operands.private ;
|
||||
QUALIFIED: sequences
|
||||
IN: cpu.x86.assembler
|
||||
|
||||
! 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
|
||||
|
||||
#! 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 ;
|
||||
|
||||
: indirect-base* ( op -- n ) base>> EBP or reg-code ;
|
||||
|
|
@ -159,27 +84,13 @@ M: indirect displacement,
|
|||
dup displacement>> dup [
|
||||
swap base>>
|
||||
[ dup fits-in-byte? [ , ] [ 4, ] if ] [ 4, ] if
|
||||
] [
|
||||
2drop
|
||||
] if ;
|
||||
] [ 2drop ] if ;
|
||||
|
||||
M: register displacement, drop ;
|
||||
|
||||
: addressing ( reg# indirect -- )
|
||||
[ 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 -- ? )
|
||||
{
|
||||
{ [ dup register-128? ] [ drop operand-64? ] }
|
||||
|
|
@ -192,22 +103,25 @@ M: object operand-64? drop f ;
|
|||
|
||||
: rex.b ( m op -- n )
|
||||
[ extended? [ BIN: 00000001 bitor ] when ] keep
|
||||
dup indirect? [
|
||||
index>> extended? [ BIN: 00000010 bitor ] when
|
||||
] [
|
||||
drop
|
||||
] if ;
|
||||
dup indirect? [ 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.
|
||||
2over rex.w? BIN: 01001000 BIN: 01000000 ?
|
||||
swap rex.r swap rex.b
|
||||
dup BIN: 01000000 = [ drop ] [ , ] if ;
|
||||
rex.w reg r/m rex.w? BIN: 01001000 BIN: 01000000 ?
|
||||
r/m rex.r
|
||||
reg rex.b
|
||||
dup reg r/m no-prefix? [ drop ] [ , ] if ;
|
||||
|
||||
: 16-prefix ( reg r/m -- )
|
||||
[ 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 ;
|
||||
|
||||
|
|
@ -269,22 +183,10 @@ M: object operand-64? drop f ;
|
|||
: 2-operand ( dst src op -- )
|
||||
#! Sets the opcode's direction bit. It is set if the
|
||||
#! destination is a direct register operand.
|
||||
2over 16-prefix
|
||||
direction-bit
|
||||
operand-size-bit
|
||||
(2-operand) ;
|
||||
[ drop 16-prefix ] [ direction-bit operand-size-bit (2-operand) ] 3bi ;
|
||||
|
||||
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
|
||||
GENERIC: PUSH ( op -- )
|
||||
M: register PUSH f HEX: 50 short-operand ;
|
||||
|
|
|
|||
|
|
@ -1 +1,2 @@
|
|||
Slava Pestov
|
||||
Joe Groff
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
@ -1,14 +1,23 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! 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
|
||||
|
||||
: define-register ( name num size -- )
|
||||
[ "cpu.x86.assembler" create dup define-symbol ] 2dip
|
||||
[ dupd "register" set-word-prop ] dip
|
||||
"register-size" set-word-prop ;
|
||||
SYMBOL: registers
|
||||
|
||||
: define-registers ( names size -- )
|
||||
'[ _ define-register ] each-index ;
|
||||
registers [ H{ } clone ] initialize
|
||||
|
||||
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 ;
|
||||
|
|
|
|||
|
|
@ -1,9 +1,9 @@
|
|||
! Copyright (C) 2007, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: bootstrap.image.private kernel kernel.private namespaces
|
||||
system cpu.x86.assembler layouts compiler.units math
|
||||
math.private compiler.constants vocabs slots.private words
|
||||
locals.backend make sequences combinators arrays ;
|
||||
USING: bootstrap.image.private kernel kernel.private namespaces system
|
||||
layouts compiler.units math math.private compiler.constants vocabs
|
||||
slots.private words locals.backend make sequences combinators arrays
|
||||
cpu.x86.assembler cpu.x86.assembler.operands ;
|
||||
IN: bootstrap.x86
|
||||
|
||||
big-endian off
|
||||
|
|
|
|||
|
|
@ -1,9 +1,9 @@
|
|||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors assocs alien alien.c-types arrays strings
|
||||
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
|
||||
cpu.x86.assembler cpu.x86.assembler.private cpu.x86.assembler.operands
|
||||
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
|
||||
|
|
@ -264,93 +264,118 @@ M:: x86 %box-alien ( dst src temp -- )
|
|||
"end" resolve-label
|
||||
] with-scope ;
|
||||
|
||||
: small-reg-8 ( reg -- reg' )
|
||||
H{
|
||||
{ EAX RAX }
|
||||
{ ECX RCX }
|
||||
{ EDX RDX }
|
||||
{ EBX RBX }
|
||||
{ ESP RSP }
|
||||
{ EBP RBP }
|
||||
{ ESI RSP }
|
||||
{ EDI RDI }
|
||||
! The 'small-reg' mess is pretty crappy, but its only used on x86-32.
|
||||
! On x86-64, all registers have 8-bit versions. However, a similar
|
||||
! problem arises for shifts, where the shift count must be in CL, and
|
||||
! so one day I will fix this properly by adding precoloring to the
|
||||
! register allocator.
|
||||
|
||||
{ RAX RAX }
|
||||
{ RCX RCX }
|
||||
{ RDX RDX }
|
||||
{ RBX RBX }
|
||||
{ RSP RSP }
|
||||
{ RBP RBP }
|
||||
{ RSI RSP }
|
||||
{ RDI RDI }
|
||||
} at ; inline
|
||||
HOOK: has-small-reg? cpu ( reg size -- ? )
|
||||
|
||||
: small-reg-4 ( reg -- reg' )
|
||||
small-reg-8 H{
|
||||
{ RAX EAX }
|
||||
{ RCX ECX }
|
||||
{ RDX EDX }
|
||||
{ RBX EBX }
|
||||
{ RSP ESP }
|
||||
{ RBP EBP }
|
||||
{ RSI ESP }
|
||||
{ RDI EDI }
|
||||
} at ; inline
|
||||
CONSTANT: have-byte-regs { EAX ECX EDX EBX }
|
||||
|
||||
: 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' )
|
||||
M: x86.32 has-small-reg?
|
||||
{
|
||||
{ 1 [ small-reg-1 ] }
|
||||
{ 2 [ small-reg-2 ] }
|
||||
{ 4 [ small-reg-4 ] }
|
||||
{ 8 [ small-reg-8 ] }
|
||||
{ 8 [ have-byte-regs memq? ] }
|
||||
{ 16 [ drop t ] }
|
||||
{ 32 [ drop t ] }
|
||||
} case ;
|
||||
|
||||
HOOK: small-regs cpu ( -- regs )
|
||||
|
||||
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 ;
|
||||
M: x86.64 has-small-reg? 2drop t ;
|
||||
|
||||
: 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 -- )
|
||||
[ drop PUSH ] [ call ] [ drop POP ] 2tri ; inline
|
||||
|
||||
:: with-small-register ( dst exclude quot: ( new-dst -- ) -- )
|
||||
#! If the destination register overlaps a small register, we
|
||||
#! call the quot with that. Otherwise, we find a small
|
||||
#! register that is not in exclude, and call quot, saving
|
||||
#! and restoring the small register.
|
||||
dst small-reg-native small-regs memq? [ dst quot call ] [
|
||||
:: with-small-register ( dst exclude size quot: ( new-dst -- ) -- )
|
||||
! If the destination register overlaps a small register with
|
||||
! 'size' bits, we call the quot with that. Otherwise, we find a
|
||||
! small register that is not in exclude, and call quot, saving and
|
||||
! restoring the small register.
|
||||
dst size has-small-reg? [ dst quot call ] [
|
||||
exclude small-reg-that-isn't
|
||||
[ quot call ] with-save/restore
|
||||
] 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? ;
|
||||
|
||||
:: emit-shift ( dst src1 src2 quot -- )
|
||||
|
|
@ -362,7 +387,7 @@ M: x86.64 small-reg-native small-reg-8 ;
|
|||
src2 CL quot call
|
||||
dst src2 XCHG
|
||||
] [
|
||||
ECX small-reg-native [
|
||||
ECX native-version-of [
|
||||
CL src2 MOV
|
||||
drop dst CL quot call
|
||||
] with-save/restore
|
||||
|
|
@ -373,80 +398,6 @@ M: x86 %shl [ SHL ] emit-shift ;
|
|||
M: x86 %shr [ SHR ] 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 pointer to start of zone array
|
||||
0 MOV "nursery" f rc-absolute-cell rel-dlsym ;
|
||||
|
|
|
|||
|
|
@ -73,3 +73,7 @@ SYMBOL: xml-file
|
|||
[ 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
|
||||
[ "ß" ] [ "<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
|
||||
|
|
@ -110,6 +110,7 @@ PRIVATE>
|
|||
TUPLE: pull-xml scope ;
|
||||
: <pull-xml> ( -- pull-xml )
|
||||
[
|
||||
init-parser
|
||||
input-stream [ ] change ! bring var in this scope
|
||||
init-xml text-now? on
|
||||
] H{ } make-assoc
|
||||
|
|
|
|||
|
|
@ -75,8 +75,9 @@ M: to-many-chats message-forwards sender>> participant-chats ;
|
|||
GENERIC: process-message ( irc-message -- )
|
||||
M: object process-message drop ;
|
||||
M: ping process-message trailing>> /PONG ;
|
||||
M: join process-message [ sender>> ] [ chat> ] bi join-participant ;
|
||||
M: part process-message [ sender>> ] [ chat> ] bi part-participant ;
|
||||
! FIXME: it shouldn't be checking for the presence of chat here...
|
||||
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: nick process-message [ trailing>> ] [ sender>> ] bi rename-participant* ;
|
||||
M: rpl-nickname-in-use process-message name>> "_" append /NICK ;
|
||||
|
|
|
|||
|
|
@ -21,15 +21,17 @@ SYMBOL: current-stream
|
|||
: timestamp-path ( timestamp -- path )
|
||||
timestamp>ymd ".log" append log-directory prepend-path ;
|
||||
|
||||
: update-current-stream ( timestamp -- )
|
||||
current-stream get [ dispose ] when*
|
||||
[ day-of-year current-day set ]
|
||||
[ timestamp-path latin1 <file-appender> ] bi
|
||||
current-stream set ;
|
||||
|
||||
: same-day? ( timestamp -- ? ) day-of-year current-day get = ;
|
||||
|
||||
: timestamp>stream ( timestamp -- stream )
|
||||
dup day-of-year current-day get = [
|
||||
drop
|
||||
] [
|
||||
current-stream get [ dispose ] when*
|
||||
[ day-of-year current-day set ]
|
||||
[ timestamp-path latin1 <file-appender> ] bi
|
||||
current-stream set
|
||||
] if current-stream get ;
|
||||
dup same-day? [ drop ] [ update-current-stream ] if
|
||||
current-stream get ;
|
||||
|
||||
: log-message ( string timestamp -- )
|
||||
[ add-timestamp ] [ timestamp>stream ] bi
|
||||
|
|
|
|||
|
|
@ -281,7 +281,7 @@
|
|||
("\\_<\\(}\\)\\_>" (1 "){"))
|
||||
;; Parenthesis:
|
||||
("\\_<\\((\\)\\_>" (1 "()"))
|
||||
("\\_<call\\((\\)\\_>" (1 "()"))
|
||||
("\\_<\\w*\\((\\)\\_>" (1 "()"))
|
||||
("\\_<\\()\\)\\_>" (1 ")("))
|
||||
("\\_<(\\((\\)\\_>" (1 "()"))
|
||||
("\\_<\\()\\))\\_>" (1 ")("))
|
||||
|
|
|
|||
|
|
@ -173,10 +173,15 @@ void print_stack_frame(stack_frame *frame)
|
|||
print_string("\n");
|
||||
print_obj(frame_scan(frame));
|
||||
print_string("\n");
|
||||
print_string("word/quot addr: ");
|
||||
print_cell_hex((cell)frame_executing(frame));
|
||||
print_string(" ");
|
||||
print_string("\n");
|
||||
print_string("word/quot xt: ");
|
||||
print_cell_hex((cell)frame->xt);
|
||||
print_string("\n");
|
||||
print_string("return address: ");
|
||||
print_cell_hex((cell)FRAME_RETURN_ADDRESS(frame));
|
||||
print_string("\n");
|
||||
}
|
||||
|
||||
void print_callstack()
|
||||
|
|
|
|||
Loading…
Reference in New Issue