diff --git a/basis/bootstrap/compiler/compiler.factor b/basis/bootstrap/compiler/compiler.factor index 0505dcb184..0a3ff10a8e 100755 --- a/basis/bootstrap/compiler/compiler.factor +++ b/basis/bootstrap/compiler/compiler.factor @@ -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 diff --git a/basis/compiler/cfg/linear-scan/allocation/allocation.factor b/basis/compiler/cfg/linear-scan/allocation/allocation.factor index c197da9814..d55266e6e4 100644 --- a/basis/compiler/cfg/linear-scan/allocation/allocation.factor +++ b/basis/compiler/cfg/linear-scan/allocation/allocation.factor @@ -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 ; diff --git a/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor b/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor index 14046a91f1..4dd3c8176c 100644 --- a/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor +++ b/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor @@ -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 { diff --git a/basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor b/basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor index 0a67710bc8..874523d70a 100644 --- a/basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor +++ b/basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor @@ -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 ; diff --git a/basis/compiler/cfg/linear-scan/debugger/debugger.factor b/basis/compiler/cfg/linear-scan/debugger/debugger.factor index a350ee5f43..c9c1b77a0d 100644 --- a/basis/compiler/cfg/linear-scan/debugger/debugger.factor +++ b/basis/compiler/cfg/linear-scan/debugger/debugger.factor @@ -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 diff --git a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor index 1673b1b365..df91109e78 100644 --- a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor +++ b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor @@ -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 diff --git a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor index 77aae14503..48bef197e6 100644 --- a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor +++ b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor @@ -13,7 +13,6 @@ C: live-range TUPLE: live-interval vreg reg spill-to reload-from -split-before split-after split-next start end ranges uses copy-from ; diff --git a/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor b/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor index b1b44cde44..ee3595dd06 100644 --- a/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor +++ b/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor @@ -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 ; [ diff --git a/basis/compiler/cfg/liveness/ssa/ssa.factor b/basis/compiler/cfg/liveness/ssa/ssa.factor index 9fa22d22b1..dbfe2d70b4 100644 --- a/basis/compiler/cfg/liveness/ssa/ssa.factor +++ b/basis/compiler/cfg/liveness/ssa/ssa.factor @@ -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? ; \ No newline at end of file diff --git a/basis/compiler/cfg/ssa/destruction/live-ranges/live-ranges.factor b/basis/compiler/cfg/ssa/destruction/live-ranges/live-ranges.factor index 536f5e1e68..01aebd7e1c 100644 --- a/basis/compiler/cfg/ssa/destruction/live-ranges/live-ranges.factor +++ b/basis/compiler/cfg/ssa/destruction/live-ranges/live-ranges.factor @@ -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 ; diff --git a/basis/compiler/cfg/ssa/destruction/process-blocks/process-blocks.factor b/basis/compiler/cfg/ssa/destruction/process-blocks/process-blocks.factor index f8c8a4d8b2..ce2aa1c5d7 100644 --- a/basis/compiler/cfg/ssa/destruction/process-blocks/process-blocks.factor +++ b/basis/compiler/cfg/ssa/destruction/process-blocks/process-blocks.factor @@ -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 diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index 727131aa25..76699c1306 100755 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -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. diff --git a/basis/cpu/x86/32/bootstrap.factor b/basis/cpu/x86/32/bootstrap.factor index 490d37ccbc..674cc817d7 100644 --- a/basis/cpu/x86/32/bootstrap.factor +++ b/basis/cpu/x86/32/bootstrap.factor @@ -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 diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor index 8eb04eb2b5..f837c7de73 100644 --- a/basis/cpu/x86/64/64.factor +++ b/basis/cpu/x86/64/64.factor @@ -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 diff --git a/basis/cpu/x86/64/bootstrap.factor b/basis/cpu/x86/64/bootstrap.factor index c5c7e63dbc..8b0d53cda5 100644 --- a/basis/cpu/x86/64/bootstrap.factor +++ b/basis/cpu/x86/64/bootstrap.factor @@ -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 diff --git a/basis/cpu/x86/64/unix/bootstrap.factor b/basis/cpu/x86/64/unix/bootstrap.factor index e48a20a9de..b6d56840e2 100644 --- a/basis/cpu/x86/64/unix/bootstrap.factor +++ b/basis/cpu/x86/64/unix/bootstrap.factor @@ -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 ; diff --git a/basis/cpu/x86/64/unix/unix.factor b/basis/cpu/x86/64/unix/unix.factor index eea960d03d..7ab25b6d3f 100644 --- a/basis/cpu/x86/64/unix/unix.factor +++ b/basis/cpu/x86/64/unix/unix.factor @@ -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 } ; diff --git a/basis/cpu/x86/64/winnt/bootstrap.factor b/basis/cpu/x86/64/winnt/bootstrap.factor index ff15ef27af..0228082956 100644 --- a/basis/cpu/x86/64/winnt/bootstrap.factor +++ b/basis/cpu/x86/64/winnt/bootstrap.factor @@ -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 ; diff --git a/basis/cpu/x86/assembler/assembler-tests.factor b/basis/cpu/x86/assembler/assembler-tests.factor index 1fe65b719c..47d6434279 100644 --- a/basis/cpu/x86/assembler/assembler-tests.factor +++ b/basis/cpu/x86/assembler/assembler-tests.factor @@ -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 diff --git a/basis/cpu/x86/assembler/assembler.factor b/basis/cpu/x86/assembler/assembler.factor index 1bcf672ce7..2b99513fc1 100644 --- a/basis/cpu/x86/assembler/assembler.factor +++ b/basis/cpu/x86/assembler/assembler.factor @@ -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 - ; - -! 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 ; - -: ( 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 ; - -: [+] ( reg displacement -- indirect ) - dup integer? - [ dup zero? [ drop f ] when [ f f ] dip ] - [ f f ] if - ; - ! Moving stuff GENERIC: PUSH ( op -- ) M: register PUSH f HEX: 50 short-operand ; diff --git a/basis/cpu/x86/assembler/authors.txt b/basis/cpu/x86/assembler/authors.txt index 1901f27a24..580f882c8d 100755 --- a/basis/cpu/x86/assembler/authors.txt +++ b/basis/cpu/x86/assembler/authors.txt @@ -1 +1,2 @@ Slava Pestov +Joe Groff diff --git a/basis/cpu/x86/assembler/operands/operands.factor b/basis/cpu/x86/assembler/operands/operands.factor new file mode 100644 index 0000000000..d3cb66ff12 --- /dev/null +++ b/basis/cpu/x86/assembler/operands/operands.factor @@ -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 ; + + ; + +! 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 ; + +: ( 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 ; + +: [+] ( reg displacement -- indirect ) + dup integer? + [ dup zero? [ drop f ] when [ f f ] dip ] + [ f f ] if + ; + +TUPLE: byte value ; + +C: 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 ; \ No newline at end of file diff --git a/basis/cpu/x86/assembler/syntax/syntax.factor b/basis/cpu/x86/assembler/syntax/syntax.factor index 631dcaa8f7..5b65c19155 100644 --- a/basis/cpu/x86/assembler/syntax/syntax.factor +++ b/basis/cpu/x86/assembler/syntax/syntax.factor @@ -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 ; diff --git a/basis/cpu/x86/bootstrap.factor b/basis/cpu/x86/bootstrap.factor index 474ce2ea46..6363f17e48 100644 --- a/basis/cpu/x86/bootstrap.factor +++ b/basis/cpu/x86/bootstrap.factor @@ -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 diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index 258f842598..5bad8e067c 100644 --- a/basis/cpu/x86/x86.factor +++ b/basis/cpu/x86/x86.factor @@ -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 ; diff --git a/basis/xml/tests/test.factor b/basis/xml/tests/test.factor index 74ba931c79..e371c3aab5 100644 --- a/basis/xml/tests/test.factor +++ b/basis/xml/tests/test.factor @@ -73,3 +73,7 @@ SYMBOL: xml-file [ T{ xml-chunk f V{ "hello" } } ] [ "hello" string>xml-chunk ] unit-test [ "1.1" ] [ "" string>xml prolog>> version>> ] unit-test [ "ß" ] [ "ß" read-xml children>string ] unit-test + +! tests +! this tests just checks that pull-event doesn't raise an exception +[ ] [ "vocab:xml/tests/test.xml" binary [ pull-event drop ] with-file-reader ] unit-test \ No newline at end of file diff --git a/basis/xml/xml.factor b/basis/xml/xml.factor index cca1b5e2e0..a1d734f291 100755 --- a/basis/xml/xml.factor +++ b/basis/xml/xml.factor @@ -110,6 +110,7 @@ PRIVATE> TUPLE: pull-xml scope ; : ( -- pull-xml ) [ + init-parser input-stream [ ] change ! bring var in this scope init-xml text-now? on ] H{ } make-assoc diff --git a/extra/irc/client/internals/internals.factor b/extra/irc/client/internals/internals.factor index 1b4a4550dc..b065dfe2f0 100644 --- a/extra/irc/client/internals/internals.factor +++ b/extra/irc/client/internals/internals.factor @@ -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 ; diff --git a/extra/irc/logbot/logbot.factor b/extra/irc/logbot/logbot.factor index ff8085a9a9..976a3832f4 100644 --- a/extra/irc/logbot/logbot.factor +++ b/extra/irc/logbot/logbot.factor @@ -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 ] 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 ] 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 diff --git a/misc/fuel/fuel-syntax.el b/misc/fuel/fuel-syntax.el index a4559c5c5c..73d6781313 100644 --- a/misc/fuel/fuel-syntax.el +++ b/misc/fuel/fuel-syntax.el @@ -281,7 +281,7 @@ ("\\_<\\(}\\)\\_>" (1 "){")) ;; Parenthesis: ("\\_<\\((\\)\\_>" (1 "()")) - ("\\_" (1 "()")) + ("\\_<\\w*\\((\\)\\_>" (1 "()")) ("\\_<\\()\\)\\_>" (1 ")(")) ("\\_<(\\((\\)\\_>" (1 "()")) ("\\_<\\()\\))\\_>" (1 ")(")) diff --git a/vm/debug.cpp b/vm/debug.cpp index 22e92809a7..5f78afb9db 100755 --- a/vm/debug.cpp +++ b/vm/debug.cpp @@ -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()