Pango, X11, and OpenGL. On a Debian-derived Linux distribution
(like Ubuntu), you can use the following line to grab everything:
- sudo apt-get install libc6-dev libpango-1.0-dev libx11-dev
+ sudo apt-get install libc6-dev libpango1.0-dev libx11-dev libgl1-mesa-dev
+
+Note that if you are using a proprietary OpenGL driver, you should
+probably leave out the last package in the list.
If your DISPLAY environment variable is set, the UI will start
-automatically:
+automatically when you run Factor:
./factor
] bi* ;
: (fortran-in-shuffle) ( ret par -- seq )
- [ [ second ] bi@ <=> ] sort append ;
+ [ second ] sort-with append ;
: (fortran-out-shuffle) ( ret par -- seq )
append ;
: remove-library ( name -- )
libraries get delete-at* [ dispose ] [ drop ] if ;
-: add-library ( name path abi -- )
- <library> swap libraries get [ delete-at ] [ set-at ] 2bi ;
\ No newline at end of file
+: add-library ( name path abi -- )
+ [ 2drop remove-library ]
+ [ <library> swap libraries get set-at ] 3bi ;
\ No newline at end of file
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
+"profile-compiler" get [
+ "bootstrap.compiler.timing" require
+] when
+
! Don't bring this in when deploying, since it will store a
! reference to 'eval' in a global variable
"deploy-vocab" get "staging" get or [
! 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
"." write flush
{
- hashcode* = get set
+ hashcode* = equal? assoc-stack (assoc-stack) get set
} compile-unoptimized
"." write flush
{
memq? split harvest sift cut cut-slice start index clone
set-at reverse push-all class number>string string>number
+ like clone-like
} compile-unoptimized
"." write flush
"." write flush
-{ build-tree } compile-unoptimized
-
-"." write flush
-
-{ optimize-tree } compile-unoptimized
-
-"." write flush
-
-{ optimize-cfg } compile-unoptimized
-
-"." write flush
-
-{ compile-word } compile-unoptimized
-
-"." write flush
-
vocabs [ words compile-unoptimized "." write flush ] each
" done" print flush
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors compiler.cfg.builder compiler.cfg.linear-scan
+compiler.cfg.liveness compiler.cfg.mr compiler.cfg.optimizer
+compiler.cfg.stacks.finalize compiler.cfg.stacks.global
+compiler.codegen compiler.tree.builder compiler.tree.optimizer
+kernel make sequences tools.annotations tools.crossref ;
+IN: bootstrap.compiler.timing
+
+: passes ( word -- seq )
+ def>> uses [ vocabulary>> "compiler." head? ] filter ;
+
+: high-level-passes ( -- seq ) \ optimize-tree passes ;
+
+: low-level-passes ( -- seq ) \ optimize-cfg passes ;
+
+: machine-passes ( -- seq ) \ build-mr passes ;
+
+: linear-scan-passes ( -- seq ) \ (linear-scan) passes ;
+
+: all-passes ( -- seq )
+ [
+ \ build-tree ,
+ \ optimize-tree ,
+ high-level-passes %
+ \ build-cfg ,
+ \ compute-global-sets ,
+ \ finalize-stack-shuffling ,
+ \ optimize-cfg ,
+ low-level-passes %
+ \ compute-live-sets ,
+ \ build-mr ,
+ machine-passes %
+ linear-scan-passes %
+ \ generate ,
+ ] { } make ;
+
+all-passes [ [ reset ] [ add-timing ] bi ] each
\ No newline at end of file
--- /dev/null
+Alaric Snell-Pym
\ No newline at end of file
--- /dev/null
+USING: help.markup help.syntax ;
+IN: checksums.fnv1
+
+HELP: fnv1-32
+{ $class-description "Fowler-Noll-Vo checksum algorithm, v1, 32-bit." } ;
+
+HELP: fnv1a-32
+{ $class-description "Fowler-Noll-Vo checksum algorithm, v1a, 32-bit." } ;
+
+
+HELP: fnv1-64
+{ $class-description "Fowler-Noll-Vo checksum algorithm, v1, 64-bit." } ;
+
+HELP: fnv1a-64
+{ $class-description "Fowler-Noll-Vo checksum algorithm, v1a, 64-bit." } ;
+
+
+HELP: fnv1-128
+{ $class-description "Fowler-Noll-Vo checksum algorithm, v1, 128-bit." } ;
+
+HELP: fnv1a-128
+{ $class-description "Fowler-Noll-Vo checksum algorithm, v1a, 128-bit." } ;
+
+
+HELP: fnv1-256
+{ $class-description "Fowler-Noll-Vo checksum algorithm, v1, 256-bit." } ;
+
+HELP: fnv1a-256
+{ $class-description "Fowler-Noll-Vo checksum algorithm, v1a, 256-bit." } ;
+
+
+HELP: fnv1-512
+{ $class-description "Fowler-Noll-Vo checksum algorithm, v1, 512-bit." } ;
+
+HELP: fnv1a-512
+{ $class-description "Fowler-Noll-Vo checksum algorithm, v1a, 512-bit." } ;
+
+
+HELP: fnv1-1024
+{ $class-description "Fowler-Noll-Vo checksum algorithm, v1, 1024-bit." } ;
+
+HELP: fnv1a-1024
+{ $class-description "Fowler-Noll-Vo checksum algorithm, v1a, 1024-bit." } ;
+
+ARTICLE: "checksums.fnv1" "Fowler-Noll-Vo checksum"
+ "The Fowler-Noll-Vo checksum algorithm is another simple and fast checksum. It comes in 32, 64, 128, 256, 512 and 1024-bit versions, each in 1 and 1a variants. The 1a variants tend to produce a slightly better result. See http://en.wikipedia.org/wiki/Fowler_Noll_Vo_hash for more details."
+
+ { $subsection fnv1-32 }
+ { $subsection fnv1a-32 }
+
+ { $subsection fnv1-64 }
+ { $subsection fnv1a-64 }
+
+ { $subsection fnv1-128 }
+ { $subsection fnv1a-128 }
+
+ { $subsection fnv1-256 }
+ { $subsection fnv1a-256 }
+
+ { $subsection fnv1-512 }
+ { $subsection fnv1a-512 }
+
+ { $subsection fnv1-1024 }
+ { $subsection fnv1a-1024 }
+ ;
+
+ABOUT: "checksums.fnv1"
--- /dev/null
+USING: checksums.fnv1 checksums strings tools.test ;
+IN: checksums.fnv1.tests
+
+! A few test vectors taken from http://www.isthe.com/chongo/src/fnv/test_fnv.c
+
+[ HEX: 811c9dc5 ] [ "" fnv1-32 checksum-bytes ] unit-test
+[ HEX: 811c9dc5 ] [ "" fnv1a-32 checksum-bytes ] unit-test
+[ HEX: cbf29ce484222325 ] [ "" fnv1-64 checksum-bytes ] unit-test
+[ HEX: cbf29ce484222325 ] [ "" fnv1a-64 checksum-bytes ] unit-test
+
+[ HEX: 050c5d7e ] [ "a" fnv1-32 checksum-bytes ] unit-test
+[ HEX: e40c292c ] [ "a" fnv1a-32 checksum-bytes ] unit-test
+[ HEX: af63bd4c8601b7be ] [ "a" fnv1-64 checksum-bytes ] unit-test
+[ HEX: af63dc4c8601ec8c ] [ "a" fnv1a-64 checksum-bytes ] unit-test
+
+[ HEX: 050c5d7d ] [ "b" fnv1-32 checksum-bytes ] unit-test
+[ HEX: e70c2de5 ] [ "b" fnv1a-32 checksum-bytes ] unit-test
+[ HEX: af63bd4c8601b7bd ] [ "b" fnv1-64 checksum-bytes ] unit-test
+[ HEX: af63df4c8601f1a5 ] [ "b" fnv1a-64 checksum-bytes ] unit-test
+
+[ HEX: 31f0b262 ] [ "foobar" fnv1-32 checksum-bytes ] unit-test
+[ HEX: bf9cf968 ] [ "foobar" fnv1a-32 checksum-bytes ] unit-test
+[ HEX: 340d8765a4dda9c2 ] [ "foobar" fnv1-64 checksum-bytes ] unit-test
+[ HEX: 85944171f73967e8 ] [ "foobar" fnv1a-64 checksum-bytes ] unit-test
+
+! I couldn't find any test vectors for 128, 256, 512, or 1024 versions of FNV1 hashes.
+! So, just to check that your maths works the same as my maths, here's a few samples computed on my laptop.
+! So they may be right or wrong, but either way, them failing is cause for concern somewhere...
+
+[ 3897470310 ] [ "Hello, world!" fnv1-32 checksum-bytes ] unit-test
+[ 3985698964 ] [ "Hello, world!" fnv1a-32 checksum-bytes ] unit-test
+[ 7285062107457560934 ] [ "Hello, world!" fnv1-64 checksum-bytes ] unit-test
+[ 4094109891673226228 ] [ "Hello, world!" fnv1a-64 checksum-bytes ] unit-test
+[ 281580511747867177735318995358496831158 ] [ "Hello, world!" fnv1-128 checksum-bytes ] unit-test
+[ 303126633380056630368940439484674414572 ] [ "Hello, world!" fnv1a-128 checksum-bytes ] unit-test
+[ 104295939182568077644846978685759236849634734810631820736486253421270219742822 ] [ "Hello, world!" fnv1-256 checksum-bytes ] unit-test
+[ 9495445728692795332446740615588417456874414534608540692485745371050033741380 ] [ "Hello, world!" fnv1a-256 checksum-bytes ] unit-test
+[ 3577308325596719252093726711895047340166329831006673109476042102918876665433235513101496175651226507162015890004121912850661561110326527625579463564626958 ] [ "Hello, world!" fnv1-512 checksum-bytes ] unit-test
+[ 3577308325596719162840652138474318309664256091923081930027929425092517582111473988451078821416039944023089883981242376700859598441397004715365740906054208 ] [ "Hello, world!" fnv1a-512 checksum-bytes ] unit-test
+[ 52692754922840008511959888105094366091401994235075816792707658326855733053286986999719949898492311786648795846192078757217437117165934438286601534984230194601365788544275827382423366672856972872132009691615382991251544423521887009322211754219117294019951276080952271766377222613325328591830596794468813260226 ] [ "Hello, world!" fnv1-1024 checksum-bytes ] unit-test
+[ 52692754922840008511959888105094366091401994235075816792707658326855804920671100511873485674717442819607149127986090276849364757610838433887624184145636764448608707614141109841761957788887305179569455221243999538336208648824673027111352338809582124430199044921035232455717748500524777795242051756321605065326 ] [ "Hello, world!" fnv1a-1024 checksum-bytes ] unit-test
--- /dev/null
+! Copyright (C) 2009 Alaric Snell-Pym
+! See http://factorcode.org/license.txt for BSD license.
+
+USING: checksums classes.singleton kernel math math.ranges
+math.vectors sequences ;
+
+IN: checksums.fnv1
+
+SINGLETON: fnv1-32
+SINGLETON: fnv1a-32
+SINGLETON: fnv1-64
+SINGLETON: fnv1a-64
+SINGLETON: fnv1-128
+SINGLETON: fnv1a-128
+SINGLETON: fnv1-256
+SINGLETON: fnv1a-256
+SINGLETON: fnv1-512
+SINGLETON: fnv1a-512
+SINGLETON: fnv1-1024
+SINGLETON: fnv1a-1024
+
+CONSTANT: fnv1-32-prime 16777619
+CONSTANT: fnv1-64-prime 1099511628211
+CONSTANT: fnv1-128-prime 309485009821345068724781371
+CONSTANT: fnv1-256-prime 374144419156711147060143317175368453031918731002211
+CONSTANT: fnv1-512-prime 35835915874844867368919076489095108449946327955754392558399825615420669938882575126094039892345713852759
+CONSTANT: fnv1-1024-prime 5016456510113118655434598811035278955030765345404790744303017523831112055108147451509157692220295382716162651878526895249385292291816524375083746691371804094271873160484737966720260389217684476157468082573
+
+CONSTANT: fnv1-32-mod HEX: ffffffff
+CONSTANT: fnv1-64-mod HEX: ffffffffffffffff
+CONSTANT: fnv1-128-mod HEX: ffffffffffffffffffffffffffffffff
+CONSTANT: fnv1-256-mod HEX: ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
+CONSTANT: fnv1-512-mod HEX: ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
+CONSTANT: fnv1-1024-mod HEX: ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
+
+CONSTANT: fnv1-32-basis HEX: 811c9dc5
+CONSTANT: fnv1-64-basis HEX: cbf29ce484222325
+CONSTANT: fnv1-128-basis HEX: 6c62272e07bb014262b821756295c58d
+CONSTANT: fnv1-256-basis HEX: dd268dbcaac550362d98c384c4e576ccc8b1536847b6bbb31023b4c8caee0535
+CONSTANT: fnv1-512-basis HEX: b86db0b1171f4416dca1e50f309990acac87d059c90000000000000000000d21e948f68a34c192f62ea79bc942dbe7ce182036415f56e34bac982aac4afe9fd9
+CONSTANT: fnv1-1024-basis HEX: 5f7a76758ecc4d32e56d5a591028b74b29fc4223fdada16c3bf34eda3674da9a21d9000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000004c6d7eb6e73802734510a555f256cc005ae556bde8cc9c6a93b21aff4b16c71ee90b3
+
+M: fnv1-32 checksum-bytes ( bytes checksum -- value )
+ drop
+ fnv1-32-basis swap
+ [ swap fnv1-32-prime * bitxor fnv1-32-mod bitand ] each ;
+
+M: fnv1a-32 checksum-bytes ( bytes checksum -- value )
+ drop
+ fnv1-32-basis swap
+ [ bitxor fnv1-32-prime * fnv1-32-mod bitand ] each ;
+
+
+M: fnv1-64 checksum-bytes ( bytes checksum -- value )
+ drop
+ fnv1-64-basis swap
+ [ swap fnv1-64-prime * bitxor fnv1-64-mod bitand ] each ;
+
+M: fnv1a-64 checksum-bytes ( bytes checksum -- value )
+ drop
+ fnv1-64-basis swap
+ [ bitxor fnv1-64-prime * fnv1-64-mod bitand ] each ;
+
+
+M: fnv1-128 checksum-bytes ( bytes checksum -- value )
+ drop
+ fnv1-128-basis swap
+ [ swap fnv1-128-prime * bitxor fnv1-128-mod bitand ] each ;
+
+M: fnv1a-128 checksum-bytes ( bytes checksum -- value )
+ drop
+ fnv1-128-basis swap
+ [ bitxor fnv1-128-prime * fnv1-128-mod bitand ] each ;
+
+
+M: fnv1-256 checksum-bytes ( bytes checksum -- value )
+ drop
+ fnv1-256-basis swap
+ [ swap fnv1-256-prime * bitxor fnv1-256-mod bitand ] each ;
+
+M: fnv1a-256 checksum-bytes ( bytes checksum -- value )
+ drop
+ fnv1-256-basis swap
+ [ bitxor fnv1-256-prime * fnv1-256-mod bitand ] each ;
+
+
+M: fnv1-512 checksum-bytes ( bytes checksum -- value )
+ drop
+ fnv1-512-basis swap
+ [ swap fnv1-512-prime * bitxor fnv1-512-mod bitand ] each ;
+
+M: fnv1a-512 checksum-bytes ( bytes checksum -- value )
+ drop
+ fnv1-512-basis swap
+ [ bitxor fnv1-512-prime * fnv1-512-mod bitand ] each ;
+
+
+M: fnv1-1024 checksum-bytes ( bytes checksum -- value )
+ drop
+ fnv1-1024-basis swap
+ [ swap fnv1-1024-prime * bitxor fnv1-1024-mod bitand ] each ;
+
+M: fnv1a-1024 checksum-bytes ( bytes checksum -- value )
+ drop
+ fnv1-1024-basis swap
+ [ bitxor fnv1-1024-prime * fnv1-1024-mod bitand ] each ;
--- /dev/null
+Fowler-Noll-Vo checksum algorithm
V{ T{ ##branch } } 5 test-bb
-0 get 1 get 2 get V{ } 2sequence >>successors drop
+0 { 1 2 } edges
-1 get 3 get 4 get V{ } 2sequence >>successors drop
+1 { 3 4 } edges
-2 get 3 get 4 get V{ } 2sequence >>successors drop
+2 { 3 4 } edges
[ ] [ test-branch-splitting ] unit-test
V{ T{ ##branch } } 4 test-bb
-0 get 1 get 2 get V{ } 2sequence >>successors drop
+0 { 1 2 } edges
-1 get 3 get 4 get V{ } 2sequence >>successors drop
+1 { 3 4 } edges
-2 get 4 get 1vector >>successors drop
+2 4 edge
[ ] [ test-branch-splitting ] unit-test
V{ T{ ##branch } } 2 test-bb
-0 get 1 get 2 get V{ } 2sequence >>successors drop
+0 { 1 2 } edges
-1 get 2 get 1vector >>successors drop
+1 2 edge
[ ] [ test-branch-splitting ] unit-test
\ No newline at end of file
compiler.cfg.predecessors
compiler.cfg.builder.blocks
compiler.cfg.stacks
+compiler.cfg.stacks.local
compiler.alien ;
IN: compiler.cfg.builder
literal>> ^^load-literal ds-push ;
! #shuffle
+
+! Even though low level IR has its own dead code elimination pass,
+! we try not to introduce useless ##peeks here, since this reduces
+! the accuracy of global stack analysis.
+
+: make-input-map ( #shuffle -- assoc )
+ ! Assoc maps high-level IR values to stack locations.
+ [
+ [ in-d>> <reversed> [ <ds-loc> swap set ] each-index ]
+ [ in-r>> <reversed> [ <rs-loc> swap set ] each-index ] bi
+ ] H{ } make-assoc ;
+
+: make-output-seq ( values mapping input-map -- vregs )
+ '[ _ at _ at peek-loc ] map ;
+
+: load-shuffle ( #shuffle mapping input-map -- ds-vregs rs-vregs )
+ [ [ out-d>> ] 2dip make-output-seq ]
+ [ [ out-r>> ] 2dip make-output-seq ] 3bi ;
+
+: store-shuffle ( #shuffle ds-vregs rs-vregs -- )
+ [ [ in-d>> length neg inc-d ] dip ds-store ]
+ [ [ in-r>> length neg inc-r ] dip rs-store ]
+ bi-curry* bi ;
+
M: #shuffle emit-node
- dup
- H{ } clone
- [ [ in-d>> [ length ds-load ] keep ] dip '[ _ set-at ] 2each ]
- [ [ in-r>> [ length rs-load ] keep ] dip '[ _ set-at ] 2each ]
- [ nip ] 2tri
- [ [ [ out-d>> ] [ mapping>> ] bi ] dip '[ _ at _ at ] map ds-store ]
- [ [ [ out-r>> ] [ mapping>> ] bi ] dip '[ _ at _ at ] map rs-store ] 2bi ;
+ dup dup [ mapping>> ] [ make-input-map ] bi load-shuffle store-shuffle ;
! #return
: emit-return ( -- )
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces assocs accessors sequences grouping
-compiler.cfg.rpo compiler.cfg.renaming compiler.cfg.instructions ;
+combinators compiler.cfg.rpo compiler.cfg.renaming
+compiler.cfg.instructions ;
IN: compiler.cfg.copy-prop
! The first three definitions are also used in compiler.cfg.alias-analysis.
SYMBOL: copies
+! Initialized per-basic-block; a mapping from inputs to dst for eliminating
+! redundant phi instructions
+SYMBOL: phis
+
: resolve ( vreg -- vreg )
copies get ?at drop ;
M: ##copy visit-insn record-copy ;
+: useless-phi ( dst inputs -- ) first (record-copy) ;
+
+: redundant-phi ( dst inputs -- ) phis get at (record-copy) ;
+
+: record-phi ( dst inputs -- ) phis get set-at ;
+
M: ##phi visit-insn
[ dst>> ] [ inputs>> values [ resolve ] map ] bi
- dup all-equal? [ first (record-copy) ] [ 2drop ] if ;
+ {
+ { [ dup all-equal? ] [ useless-phi ] }
+ { [ dup phis get key? ] [ redundant-phi ] }
+ [ record-phi ]
+ } cond ;
M: insn visit-insn drop ;
: collect-copies ( cfg -- )
H{ } clone copies set
[
- instructions>>
- [ visit-insn ] each
+ H{ } clone phis set
+ instructions>> [ visit-insn ] each
] each-basic-block ;
GENERIC: update-insn ( insn -- keep? )
copies get dup assoc-empty? [ 2drop ] [
renamings set
[
- instructions>>
- [ update-insn ] filter-here
+ instructions>> [ update-insn ] filter-here
] each-basic-block
] if ;
--- /dev/null
+USING: accessors assocs compiler.cfg
+compiler.cfg.critical-edges compiler.cfg.debugger
+compiler.cfg.instructions compiler.cfg.predecessors
+compiler.cfg.registers cpu.architecture kernel namespaces
+sequences tools.test compiler.cfg.utilities ;
+IN: compiler.cfg.critical-edges.tests
+
+! Make sure we update phi nodes when splitting critical edges
+
+: test-critical-edges ( -- )
+ cfg new 0 get >>entry
+ compute-predecessors
+ split-critical-edges ;
+
+V{
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##branch }
+} 0 test-bb
+
+V{
+ T{ ##peek f V int-regs 1 D 1 }
+ T{ ##branch }
+} 1 test-bb
+
+V{
+ T{ ##phi f V int-regs 2 H{ { 0 V int-regs 0 } { 1 V int-regs 1 } } }
+ T{ ##return }
+} 2 test-bb
+
+0 { 1 2 } edges
+1 2 edge
+
+[ ] [ test-critical-edges ] unit-test
+
+[ t ] [ 0 get successors>> second successors>> first 2 get eq? ] unit-test
+
+[ V int-regs 0 ] [ 2 get instructions>> first inputs>> 0 get successors>> second swap at ] unit-test
\ No newline at end of file
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math accessors sequences
+USING: kernel math accessors sequences locals assocs fry
compiler.cfg compiler.cfg.rpo compiler.cfg.utilities ;
IN: compiler.cfg.critical-edges
: critical-edge? ( from to -- ? )
[ successors>> length 1 > ] [ predecessors>> length 1 > ] bi* and ;
+: new-key ( new-key old-key assoc -- )
+ [ delete-at* ] keep '[ swap _ set-at ] [ 2drop ] if ;
+
+:: update-phis ( from to bb -- )
+ ! Any phi nodes in 'to' which reference 'from'
+ ! should now reference 'bb'.
+ to [ [ bb from ] dip inputs>> new-key ] each-phi ;
+
: split-critical-edge ( from to -- )
- f <simple-block> insert-basic-block ;
+ f <simple-block> [ insert-basic-block ] [ update-phis ] 3bi ;
: split-critical-edges ( cfg -- )
dup [
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel words sequences quotations namespaces io vectors
-classes.tuple accessors prettyprint prettyprint.config
+classes.tuple accessors prettyprint prettyprint.config assocs
prettyprint.backend prettyprint.custom prettyprint.sections
parser compiler.tree.builder compiler.tree.optimizer
compiler.cfg.builder compiler.cfg.linearization
compiler.cfg.registers compiler.cfg.stack-frame
compiler.cfg.linear-scan compiler.cfg.two-operand
-compiler.cfg.optimizer
-compiler.cfg.mr compiler.cfg ;
+compiler.cfg.optimizer compiler.cfg.instructions
+compiler.cfg.utilities compiler.cfg.mr compiler.cfg ;
IN: compiler.cfg.debugger
GENERIC: test-cfg ( quot -- cfgs )
M: rs-loc pprint* \ R pprint-loc ;
+: resolve-phis ( bb -- )
+ [
+ [ [ [ get ] dip ] assoc-map ] change-inputs drop
+ ] each-phi ;
+
: test-bb ( insns n -- )
- [ <basic-block> swap >>number swap >>instructions ] keep set ;
+ [ <basic-block> swap >>number swap >>instructions dup ] keep set
+ resolve-phis ;
+
+: edge ( from to -- )
+ [ get ] bi@ 1vector >>successors drop ;
+
+: edges ( from tos -- )
+ [ get ] [ [ get ] V{ } map-as ] bi* >>successors drop ;
: test-diamond ( -- )
- 1 get 1vector 0 get (>>successors)
- 2 get 3 get V{ } 2sequence 1 get (>>successors)
- 4 get 1vector 2 get (>>successors)
- 4 get 1vector 3 get (>>successors) ;
\ No newline at end of file
+ 0 1 edge
+ 1 { 2 3 } edges
+ 2 4 edge
+ 3 4 edge ;
\ No newline at end of file
--- /dev/null
+Slava Pestov
+Daniel Ehrenberg
--- /dev/null
+! Copyright (C) 2009 Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel tools.test accessors vectors sequences namespaces
+arrays
+cpu.architecture
+compiler.cfg.def-use
+compiler.cfg
+compiler.cfg.debugger
+compiler.cfg.instructions
+compiler.cfg.registers ;
+
+V{
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##peek f V int-regs 1 D 0 }
+ T{ ##peek f V int-regs 2 D 0 }
+} 1 test-bb
+V{
+ T{ ##replace f V int-regs 2 D 0 }
+} 2 test-bb
+1 2 edge
+V{
+ T{ ##replace f V int-regs 0 D 0 }
+} 3 test-bb
+2 3 edge
+V{ } 4 test-bb
+V{ } 5 test-bb
+3 { 4 5 } edges
+V{
+ T{ ##phi f V int-regs 2 H{ { 2 V int-regs 0 } { 3 V int-regs 1 } } }
+} 6 test-bb
+4 6 edge
+5 6 edge
+
+cfg new 1 get >>entry 0 set
+[ ] [ 0 get [ compute-defs ] [ compute-uses ] bi ] unit-test
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays kernel assocs sequences namespaces fry
-sets compiler.cfg.rpo compiler.cfg.instructions ;
+sets compiler.cfg.rpo compiler.cfg.instructions locals ;
IN: compiler.cfg.def-use
GENERIC: defs-vreg ( insn -- vreg/f )
] each-basic-block
] keep insns set ;
-: compute-uses ( cfg -- )
- H{ } clone [
- '[
- dup instructions>> [
- uses-vregs [
- _ conjoin-at
- ] with each
- ] with each
- ] each-basic-block
- ] keep
- [ keys ] assoc-map
- uses set ;
-
-: compute-def-use ( cfg -- )
- [ compute-defs ] [ compute-uses ] [ compute-insns ] tri ;
\ No newline at end of file
+:: compute-uses ( cfg -- )
+ ! Here, a phi node uses its argument in the block that it comes from.
+ H{ } clone :> use
+ cfg [| block |
+ block instructions>> [
+ dup ##phi?
+ [ inputs>> [ use conjoin-at ] assoc-each ]
+ [ uses-vregs [ block swap use conjoin-at ] each ]
+ if
+ ] each
+ ] each-basic-block
+ use [ keys ] assoc-map uses set ;
V{ } 4 test-bb
V{ } 5 test-bb
-0 get 1 get 2 get V{ } 2sequence >>successors drop
-1 get 3 get 1vector >>successors drop
-2 get 4 get 1vector >>successors drop
-3 get 4 get 1vector >>successors drop
-4 get 5 get 1vector >>successors drop
+0 { 1 2 } edges
+1 3 edge
+2 4 edge
+3 4 edge
+4 5 edge
[ ] [ test-dominance ] unit-test
V{ } 3 test-bb
V{ } 4 test-bb
-0 get 1 get 2 get V{ } 2sequence >>successors drop
-1 get 3 get 1vector >>successors drop
-2 get 4 get 1vector >>successors drop
-3 get 4 get 1vector >>successors drop
-4 get 3 get 1vector >>successors drop
+0 { 1 2 } edges
+1 3 edge
+2 4 edge
+3 4 edge
+4 3 edge
[ ] [ test-dominance ] unit-test
V{ } 4 test-bb
V{ } 5 test-bb
-0 get 1 get 2 get V{ } 2sequence >>successors drop
-1 get 5 get 1vector >>successors drop
-2 get 4 get 3 get V{ } 2sequence >>successors drop
-5 get 4 get 1vector >>successors drop
-4 get 5 get 3 get V{ } 2sequence >>successors drop
-3 get 4 get 1vector >>successors drop
+0 { 1 2 } edges
+1 5 edge
+2 { 4 3 } edges
+5 4 edge
+4 { 5 3 } edges
+3 4 edge
[ ] [ test-dominance ] unit-test
--- /dev/null
+IN: compiler.cfg.gc-checks.tests
+USING: compiler.cfg.gc-checks compiler.cfg.debugger
+compiler.cfg.registers compiler.cfg.instructions compiler.cfg
+compiler.cfg.predecessors cpu.architecture tools.test kernel vectors
+namespaces accessors sequences ;
+
+: test-gc-checks ( -- )
+ cfg new 0 get >>entry
+ compute-predecessors
+ insert-gc-checks
+ drop ;
+
+V{
+ T{ ##inc-d f 3 }
+ T{ ##replace f V int-regs 0 D 1 }
+} 0 test-bb
+
+V{
+ T{ ##box-float f V int-regs 0 V int-regs 1 }
+} 1 test-bb
+
+0 1 edge
+
+[ ] [ test-gc-checks ] unit-test
+
+[ V{ D 0 D 2 } ] [ 1 get instructions>> first uninitialized-locs>> ] unit-test
\ No newline at end of file
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel sequences assocs
-compiler.cfg.rpo compiler.cfg.instructions
-compiler.cfg.hats ;
+USING: accessors kernel sequences assocs fry
+compiler.cfg.rpo
+compiler.cfg.hats
+compiler.cfg.registers
+compiler.cfg.instructions
+compiler.cfg.stacks.uninitialized ;
IN: compiler.cfg.gc-checks
-: gc? ( bb -- ? )
+: insert-gc-check? ( bb -- ? )
instructions>> [ ##allocation? ] any? ;
-: insert-gc-check ( basic-block -- )
- dup gc? [
- [ i i f \ ##gc new-insn prefix ] change-instructions drop
- ] [ drop ] if ;
+: blocks-with-gc ( cfg -- bbs )
+ post-order [ insert-gc-check? ] filter ;
+
+: insert-gc-check ( bb -- )
+ dup '[
+ i i f _ uninitialized-locs \ ##gc new-insn
+ prefix
+ ] change-instructions drop ;
: insert-gc-checks ( cfg -- cfg' )
- dup [ insert-gc-check ] each-basic-block ;
\ No newline at end of file
+ dup blocks-with-gc [
+ over compute-uninitialized-sets
+ [ insert-gc-check ] each
+ ] unless-empty ;
\ No newline at end of file
INSN: ##fixnum-sub < ##fixnum-overflow ;
INSN: ##fixnum-mul < ##fixnum-overflow ;
-INSN: ##gc temp1 temp2 live-values ;
+INSN: ##gc temp1 temp2 live-values uninitialized-locs ;
! Instructions used by machine IR only.
INSN: _prologue stack-frame ;
TUPLE: spill-slot n ; C: <spill-slot> spill-slot
-INSN: _gc temp1 temp2 gc-roots gc-root-count gc-root-size ;
+INSN: _gc temp1 temp2 gc-roots gc-root-count gc-root-size uninitialized-locs ;
! These instructions operate on machine registers and not
! virtual registers
slots.private:set-slot
strings.private:string-nth
strings.private:set-string-nth-fast
- ! classes.tuple.private:<tuple-boa>
- ! byte-arrays:<byte-array>
- ! byte-arrays:(byte-array)
- ! kernel:<wrapper>
+ classes.tuple.private:<tuple-boa>
+ arrays:<array>
+ byte-arrays:<byte-array>
+ byte-arrays:(byte-array)
+ kernel:<wrapper>
alien.accessors:alien-unsigned-1
alien.accessors:set-alien-unsigned-1
alien.accessors:alien-signed-1
alien.accessors:set-alien-unsigned-2
alien.accessors:alien-signed-2
alien.accessors:set-alien-signed-2
- ! alien.accessors:alien-cell
+ alien.accessors:alien-cell
alien.accessors:set-alien-cell
} [ t "intrinsic" set-word-prop ] each
alien.accessors:set-alien-float
alien.accessors:alien-double
alien.accessors:set-alien-double
- } drop f [ t "intrinsic" set-word-prop ] each ;
+ } [ t "intrinsic" set-word-prop ] each ;
: enable-fixnum-log2 ( -- )
\ math.integers.private:fixnum-log2 t "intrinsic" set-word-prop ;
: 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 ;
[ 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 ;
[ 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
! 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 {
: 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 ;
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 ;
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>
{ 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 } } }
{ 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 } } }
{ end 5 }
{ uses V{ 5 } }
{ ranges V{ T{ live-range f 5 5 } } }
+ { reload-from 10 }
}
] [
T{ live-interval
{ 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
[
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
T{ ##return }
} 3 test-bb
-1 get 1vector 0 get (>>successors)
-2 get 3 get V{ } 2sequence 1 get (>>successors)
-3 get 1vector 2 get (>>successors)
+0 1 edge
+1 { 2 3 } edges
+2 3 edge
SYMBOL: linear-scan-result
flatten-cfg 1array mr.
] with-scope ;
-! This test has a critical edge -- do we care about these?
-
-! [ { 1 2 } test-linear-scan-on-cfg ] unit-test
+[ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test
! Bug in inactive interval handling
! [ rot dup [ -rot ] when ]
[ ] [ { 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
T{ ##return }
} 6 test-bb
-0 get 1 get V{ } 1sequence >>successors drop
-1 get 2 get 3 get V{ } 2sequence >>successors drop
-2 get 4 get V{ } 1sequence >>successors drop
-3 get 4 get V{ } 1sequence >>successors drop
-4 get 5 get 6 get V{ } 2sequence >>successors drop
+0 1 edge
+1 { 2 3 } edges
+2 4 edge
+3 4 edge
+4 { 5 6 } edges
[ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test
T{ ##return }
} 9 test-bb
-0 get 1 get 1vector >>successors drop
-1 get 2 get 7 get V{ } 2sequence >>successors drop
-7 get 8 get 1vector >>successors drop
-8 get 9 get 1vector >>successors drop
-2 get 3 get 5 get V{ } 2sequence >>successors drop
-3 get 4 get 1vector >>successors drop
-4 get 9 get 1vector >>successors drop
-5 get 6 get 1vector >>successors drop
+0 1 edge
+1 { 2 7 } edges
+7 8 edge
+8 9 edge
+2 { 3 5 } edges
+3 4 edge
+4 9 edge
+5 6 edge
[ ] [ { 1 2 3 4 } test-linear-scan-on-cfg ] unit-test
T{ ##return }
} 5 test-bb
-0 get 1 get 1vector >>successors drop
-1 get 2 get 4 get V{ } 2sequence >>successors drop
-2 get 3 get 1vector >>successors drop
-3 get 5 get 1vector >>successors drop
-4 get 5 get 1vector >>successors drop
+0 1 edge
+1 { 2 4 } edges
+2 3 edge
+3 5 edge
+4 5 edge
[ ] [ { 1 2 3 4 5 } test-linear-scan-on-cfg ] unit-test
T{ ##return }
} 6 test-bb
-0 get 1 get 1vector >>successors drop
-1 get 2 get 5 get V{ } 2sequence >>successors drop
-2 get 3 get 1vector >>successors drop
-3 get 4 get 1vector >>successors drop
-4 get 6 get 1vector >>successors drop
-5 get 6 get 1vector >>successors drop
+0 1 edge
+1 { 2 5 } edges
+2 3 edge
+3 4 edge
+4 6 edge
+5 6 edge
[ ] [ { 1 2 3 4 5 } test-linear-scan-on-cfg ] unit-test
T{ ##return }
} 2 test-bb
-0 get 1 get 1vector >>successors drop
-1 get 2 get 1vector >>successors drop
+0 1 edge
+1 2 edge
[ ] [ { 1 2 3 } test-linear-scan-on-cfg ] unit-test
T{ ##return }
} 2 test-bb
-0 get 1 get 2 get V{ } 2sequence >>successors drop
+0 { 1 2 } edges
[ ] [ { 1 2 3 } test-linear-scan-on-cfg ] unit-test
TUPLE: live-interval
vreg
reg spill-to reload-from
-split-before split-after split-next
start end ranges uses
copy-from ;
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 ;
[
2dup = [ 2drop ] [ vreg reg-class>> add-mapping ] if ;
: compute-mappings ( bb to -- mappings )
- [
- dup live-in keys
- [ resolve-value-data-flow ] with with each
- ] { } make ;
+ dup live-in dup assoc-empty? [ 3drop f ] [
+ [ keys [ resolve-value-data-flow ] with with each ] { } make
+ ] if ;
: memory->register ( from to -- )
swap [ first2 ] [ first n>> ] bi* _reload ;
M: ##gc linearize-insn
nip
- [ temp1>> ]
- [ temp2>> ]
- [
- live-values>>
- [ compute-gc-roots ]
- [ count-gc-roots ]
- [ gc-roots-size ]
- tri
- ] tri
+ {
+ [ temp1>> ]
+ [ temp2>> ]
+ [
+ live-values>>
+ [ compute-gc-roots ]
+ [ count-gc-roots ]
+ [ gc-roots-size ]
+ tri
+ ]
+ [ uninitialized-locs>> ]
+ } cleave
_gc ;
: linearize-basic-blocks ( cfg -- insns )
T{ ##return }
} 3 test-bb
-1 get 2 get 3 get V{ } 2sequence >>successors drop
+1 { 2 3 } edges
test-liveness
T{ ##return }
} 2 test-bb
-1 get 2 get 1vector >>successors drop
+1 2 edge
test-liveness
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces deques accessors sets sequences assocs fry
hashtables dlists compiler.cfg.def-use compiler.cfg.instructions
-compiler.cfg.rpo compiler.cfg.liveness ;
+compiler.cfg.rpo compiler.cfg.liveness compiler.cfg.utilities ;
IN: compiler.cfg.liveness.ssa
! TODO: merge with compiler.cfg.liveness
! Assoc mapping basic blocks to sequences of sets of vregs; each sequence
-! is in conrrespondence with a predecessor
+! is in correspondence with a predecessor
SYMBOL: phi-live-ins
: phi-live-in ( predecessor basic-block -- set ) phi-live-ins get at at ;
[ live-out ] keep instructions>> transfer-liveness ;
: compute-phi-live-in ( basic-block -- phi-live-in )
- instructions>> [ ##phi? ] filter [ f ] [
- H{ } clone [
- '[ inputs>> [ swap _ conjoin-at ] assoc-each ] each
- ] keep
- ] if-empty ;
+ H{ } clone [
+ '[ inputs>> [ swap _ conjoin-at ] assoc-each ] each-phi
+ ] keep ;
: update-live-in ( basic-block -- changed? )
[ [ compute-live-in ] keep live-ins get maybe-set-at ]
[ [ compute-phi-live-in ] keep phi-live-ins get maybe-set-at ]
- bi and ;
+ bi or ;
: compute-live-out ( basic-block -- live-out )
[ successors>> [ live-in ] map ]
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
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors combinators fry sequences assocs compiler.cfg.rpo
-compiler.cfg.instructions ;
+compiler.cfg.instructions compiler.cfg.utilities ;
IN: compiler.cfg.predecessors
: update-predecessors ( bb -- )
] change-inputs drop ;
: update-phis ( bb -- )
- dup instructions>> [
- dup ##phi? [ update-phi ] [ 2drop ] if
- ] with each ;
+ dup [ update-phi ] with each-phi ;
: compute-predecessors ( cfg -- cfg' )
{
T{ ##return }
} 3 test-bb
-0 get 1 get 2 get V{ } 2sequence >>successors drop
-1 get 3 get 1vector >>successors drop
-2 get 3 get 1vector >>successors drop
+0 { 1 2 } edges
+1 3 edge
+2 3 edge
: test-ssa ( -- )
cfg new 0 get >>entry
V{ } 5 test-bb
V{ } 6 test-bb
-0 get 1 get 5 get V{ } 2sequence >>successors drop
-1 get 2 get 3 get V{ } 2sequence >>successors drop
-2 get 4 get 1vector >>successors drop
-3 get 4 get 1vector >>successors drop
-4 get 6 get 1vector >>successors drop
-5 get 6 get 1vector >>successors drop
+0 { 1 5 } edges
+1 { 2 3 } edges
+2 4 edge
+3 4 edge
+4 6 edge
+5 6 edge
[ ] [ test-ssa ] unit-test
V{ } 4 test-bb
V{ } 5 test-bb
-0 get 1 get 2 get V{ } 2sequence >>successors drop
-1 get 3 get 1vector >>successors drop
-2 get 4 get 1vector >>successors drop
-3 get 4 get 1vector >>successors drop
-4 get 5 get 1vector >>successors drop
+0 { 1 2 } edges
+1 3 edge
+2 4 edge
+3 4 edge
+4 5 edge
[ ] [ test-tdmsc ] unit-test
V{ } 5 test-bb
V{ } 6 test-bb
-0 get 1 get 5 get V{ } 2sequence >>successors drop
-1 get 2 get 3 get V{ } 2sequence >>successors drop
-2 get 4 get 1vector >>successors drop
-3 get 4 get 1vector >>successors drop
-4 get 6 get 1vector >>successors drop
-5 get 6 get 1vector >>successors drop
+0 { 1 5 } edges
+1 { 2 3 } edges
+2 4 edge
+3 4 edge
+4 6 edge
+5 6 edge
[ ] [ test-tdmsc ] unit-test
V{ } 6 test-bb
V{ } 7 test-bb
-0 get 1 get 1vector >>successors drop
-1 get 2 get 1vector >>successors drop
-2 get 3 get 6 get V{ } 2sequence >>successors drop
-3 get 4 get 1vector >>successors drop
-6 get 7 get 1vector >>successors drop
-4 get 5 get 1vector >>successors drop
-5 get 2 get 1vector >>successors drop
+0 1 edge
+1 2 edge
+2 { 3 6 } edges
+3 4 edge
+6 7 edge
+4 5 edge
+5 2 edge
[ ] [ test-tdmsc ] unit-test
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs kernel locals
+compiler.cfg.rpo
+compiler.cfg.hats
+compiler.cfg.utilities
+compiler.cfg.instructions ;
+IN: compiler.cfg.ssa.cssa
+
+! Convert SSA to conventional SSA.
+
+:: insert-copy ( bb src -- bb dst )
+ i :> dst
+ bb [ dst src ##copy ] add-instructions
+ bb dst ;
+
+: convert-phi ( ##phi -- )
+ [ [ insert-copy ] assoc-map ] change-inputs drop ;
+
+: construct-cssa ( cfg -- )
+ [ [ convert-phi ] each-phi ] each-basic-block ;
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs hashtables fry kernel make namespaces
-sequences compiler.cfg.ssa.destruction.state compiler.cfg.parallel-copy ;
-IN: compiler.cfg.ssa.destruction.copies
-
-ERROR: bad-copy ;
-
-: compute-copies ( assoc -- assoc' )
- dup assoc-size <hashtable> [
- '[
- [
- 2dup eq? [ 2drop ] [
- _ 2dup key?
- [ bad-copy ] [ set-at ] if
- ] if
- ] with each
- ] assoc-each
- ] keep ;
-
-: insert-copies ( -- )
- waiting get [
- [ instructions>> building ] dip '[
- building get pop
- _ compute-copies parallel-copy
- ,
- ] with-variable
- ] assoc-each ;
\ No newline at end of file
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs fry kernel locals math math.order
-sequences namespaces sets
+USING: accessors arrays assocs fry kernel namespaces
+sequences sequences.deep
+sets vectors
compiler.cfg.rpo
compiler.cfg.def-use
-compiler.cfg.utilities
+compiler.cfg.renaming
compiler.cfg.dominance
compiler.cfg.instructions
compiler.cfg.liveness.ssa
-compiler.cfg.critical-edges
-compiler.cfg.ssa.destruction.state
-compiler.cfg.ssa.destruction.forest
-compiler.cfg.ssa.destruction.copies
-compiler.cfg.ssa.destruction.renaming
-compiler.cfg.ssa.destruction.live-ranges
-compiler.cfg.ssa.destruction.process-blocks ;
+compiler.cfg.ssa.cssa
+compiler.cfg.ssa.interference
+compiler.cfg.ssa.interference.live-ranges
+compiler.cfg.utilities
+compiler.utilities ;
IN: compiler.cfg.ssa.destruction
-! Based on "Fast Copy Coalescing and Live-Range Identification"
-! http://www.cs.ucsd.edu/classes/sp02/cse231/kenpldi.pdf
+! Maps vregs to leaders.
+SYMBOL: leader-map
+
+: leader ( vreg -- vreg' ) leader-map get compress-path ;
+
+! Maps leaders to equivalence class elements.
+SYMBOL: class-element-map
+
+: class-elements ( vreg -- elts ) class-element-map get at ;
+
+! Sequence of vreg pairs
+SYMBOL: copies
+
+: init-coalescing ( -- )
+ H{ } clone leader-map set
+ H{ } clone class-element-map set
+ V{ } clone copies set ;
+
+: classes-interfere? ( vreg1 vreg2 -- ? )
+ [ leader ] bi@ 2dup eq? [ 2drop f ] [
+ [ class-elements flatten ] bi@ sets-interfere?
+ ] if ;
-! Dominance, liveness and def-use need to be computed
+: update-leaders ( vreg1 vreg2 -- )
+ swap leader-map get set-at ;
-: process-blocks ( cfg -- )
- [ [ process-block ] if-has-phis ] each-basic-block ;
+: merge-classes ( vreg1 vreg2 -- )
+ [ [ class-elements ] bi@ push ]
+ [ drop class-element-map get delete-at ] 2bi ;
-SYMBOL: seen
+: eliminate-copy ( vreg1 vreg2 -- )
+ [ leader ] bi@
+ 2dup eq? [ 2drop ] [
+ [ update-leaders ] [ merge-classes ] 2bi
+ ] if ;
-:: visit-renaming ( dst assoc src bb -- )
- src seen get key? [
- src dst bb waiting-for push-at
- src assoc delete-at
- ] [ src seen get conjoin ] if ;
+: introduce-vreg ( vreg -- )
+ [ leader-map get conjoin ]
+ [ [ 1vector ] keep class-element-map get set-at ] bi ;
-:: break-interferences ( -- )
- V{ } clone seen set
- renaming-sets get [| dst assoc |
- assoc [| src bb |
- dst assoc src bb visit-renaming
- ] assoc-each
+GENERIC: prepare-insn ( insn -- )
+
+M: ##copy prepare-insn
+ [ dst>> ] [ src>> ] bi 2array copies get push ;
+
+M: ##phi prepare-insn
+ [ dst>> ] [ inputs>> values ] bi
+ [ eliminate-copy ] with each ;
+
+M: insn prepare-insn drop ;
+
+: prepare-block ( bb -- )
+ instructions>> [ prepare-insn ] each ;
+
+: prepare-coalescing ( cfg -- )
+ init-coalescing
+ defs get keys [ introduce-vreg ] each
+ [ prepare-block ] each-basic-block ;
+
+: process-copies ( -- )
+ copies get [
+ 2dup classes-interfere?
+ [ 2drop ] [ eliminate-copy ] if
] assoc-each ;
-: remove-phis-from-block ( bb -- )
- instructions>> [ ##phi? not ] filter-here ;
+: useless-copy? ( ##copy -- ? )
+ dup ##copy? [ [ dst>> ] [ src>> ] bi eq? ] [ drop f ] if ;
-: remove-phis ( cfg -- )
- [ [ remove-phis-from-block ] if-has-phis ] each-basic-block ;
+: perform-renaming ( cfg -- )
+ leader-map get keys [ dup leader ] H{ } map>assoc renamings set
+ [
+ instructions>> [
+ [ rename-insn-defs ]
+ [ rename-insn-uses ]
+ [ [ useless-copy? ] [ ##phi? ] bi or not ] tri
+ ] filter-here
+ ] each-basic-block ;
: destruct-ssa ( cfg -- cfg' )
dup cfg-has-phis? [
- init-coalescing
- compute-ssa-live-sets
- dup split-critical-edges
- dup compute-def-use
+ dup construct-cssa
+ dup compute-defs
dup compute-dominance
+ compute-ssa-live-sets
dup compute-live-ranges
- dup process-blocks
- break-interferences
+ dup prepare-coalescing
+ process-copies
dup perform-renaming
- insert-copies
- dup remove-phis
] when ;
\ No newline at end of file
+++ /dev/null
-USING: accessors compiler.cfg compiler.cfg.ssa.destruction.forest
-compiler.cfg.debugger compiler.cfg.dominance compiler.cfg.instructions
-compiler.cfg.predecessors compiler.cfg.registers compiler.cfg.def-use
-cpu.architecture kernel namespaces sequences tools.test vectors sorting
-math.order ;
-IN: compiler.cfg.ssa.destruction.forest.tests
-
-V{ T{ ##peek f V int-regs 0 D 0 } } clone 0 test-bb
-V{ T{ ##peek f V int-regs 1 D 0 } } clone 1 test-bb
-V{ T{ ##peek f V int-regs 2 D 0 } } clone 2 test-bb
-V{ T{ ##peek f V int-regs 3 D 0 } } clone 3 test-bb
-V{ T{ ##peek f V int-regs 4 D 0 } } clone 4 test-bb
-V{ T{ ##peek f V int-regs 5 D 0 } } clone 5 test-bb
-V{ T{ ##peek f V int-regs 6 D 0 } } clone 6 test-bb
-
-0 get 1 get 2 get V{ } 2sequence >>successors drop
-2 get 3 get 4 get V{ } 2sequence >>successors drop
-3 get 5 get 1vector >>successors drop
-4 get 5 get 1vector >>successors drop
-1 get 6 get 1vector >>successors drop
-5 get 6 get 1vector >>successors drop
-
-: clean-up-forest ( forest -- forest' )
- [ [ vreg>> n>> ] compare ] sort
- [
- [ clean-up-forest ] change-children
- [ number>> ] change-bb
- ] V{ } map-as ;
-
-: test-dom-forest ( vregs -- forest )
- cfg new 0 get >>entry
- compute-predecessors
- dup compute-dominance
- compute-def-use
- compute-dom-forest
- clean-up-forest ;
-
-[ V{ } ] [ { } test-dom-forest ] unit-test
-
-[ V{ T{ dom-forest-node f V int-regs 0 0 V{ } } } ]
-[ { V int-regs 0 } test-dom-forest ]
-unit-test
-
-[
- V{
- T{ dom-forest-node
- f
- V int-regs 0
- 0
- V{ T{ dom-forest-node f V int-regs 1 1 V{ } } }
- }
- }
-]
-[ { V int-regs 0 V int-regs 1 } test-dom-forest ]
-unit-test
-
-[
- V{
- T{ dom-forest-node
- f
- V int-regs 1
- 1
- V{ }
- }
- T{ dom-forest-node
- f
- V int-regs 2
- 2
- V{
- T{ dom-forest-node f V int-regs 3 3 V{ } }
- T{ dom-forest-node f V int-regs 4 4 V{ } }
- T{ dom-forest-node f V int-regs 5 5 V{ } }
- }
- }
- T{ dom-forest-node
- f
- V int-regs 6
- 6
- V{ }
- }
- }
-]
-[
- { V int-regs 1 V int-regs 6 V int-regs 2 V int-regs 3 V int-regs 4 V int-regs 5 }
- test-dom-forest
-] unit-test
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs fry kernel math math.order
-namespaces sequences sorting vectors compiler.cfg.def-use
-compiler.cfg.dominance compiler.cfg.registers ;
-IN: compiler.cfg.ssa.destruction.forest
-
-TUPLE: dom-forest-node vreg bb children ;
-
-<PRIVATE
-
-: sort-vregs-by-bb ( vregs -- alist )
- defs get
- '[ dup _ at ] { } map>assoc
- [ [ second pre-of ] compare ] sort ;
-
-: <dom-forest-node> ( vreg bb parent -- node )
- [ V{ } clone dom-forest-node boa dup ] dip children>> push ;
-
-: <virtual-root> ( -- node )
- f f V{ } clone dom-forest-node boa ;
-
-: find-parent ( pre stack -- parent )
- 2dup last vreg>> def-of maxpre-of > [
- dup pop* find-parent
- ] [ nip last ] if ;
-
-: (compute-dom-forest) ( vreg bb stack -- )
- [ dup pre-of ] dip [ find-parent <dom-forest-node> ] keep push ;
-
-PRIVATE>
-
-: compute-dom-forest ( vregs -- forest )
- <virtual-root> [
- 1vector
- [ sort-vregs-by-bb ] dip
- '[ _ (compute-dom-forest) ] assoc-each
- ] keep children>> ;
+++ /dev/null
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs combinators combinators.short-circuit
-kernel math namespaces sequences locals compiler.cfg.def-use
-compiler.cfg.dominance compiler.cfg.ssa.destruction.live-ranges ;
-IN: compiler.cfg.ssa.destruction.interference
-
-<PRIVATE
-
-: kill-after-def? ( vreg1 vreg2 bb -- ? )
- ! If first register is used after second one is defined, they interfere.
- ! If they are used in the same instruction, no interference. If the
- ! instruction is a def-is-use-insn, then there will be a use at +1
- ! (instructions are 2 apart) and so outputs will interfere with
- ! inputs.
- [ kill-index ] [ def-index ] bi-curry bi* > ;
-
-: interferes-same-block? ( vreg1 vreg2 bb1 bb2 -- ? )
- ! If both are defined in the same basic block, they interfere if their
- ! local live ranges intersect.
- drop
- { [ kill-after-def? ] [ swapd kill-after-def? ] } 3|| ;
-
-: interferes-first-dominates? ( vreg1 vreg2 bb1 bb2 -- ? )
- ! If vreg1 dominates vreg2, then they interfere if vreg2's definition
- ! occurs before vreg1 is killed.
- nip
- kill-after-def? ;
-
-: interferes-second-dominates? ( vreg1 vreg2 bb1 bb2 -- ? )
- ! If vreg2 dominates vreg1, then they interfere if vreg1's definition
- ! occurs before vreg2 is killed.
- drop
- swapd kill-after-def? ;
-
-PRIVATE>
-
-: interferes? ( vreg1 vreg2 -- ? )
- 2dup [ def-of ] bi@ {
- { [ 2dup eq? ] [ interferes-same-block? ] }
- { [ 2dup dominates? ] [ interferes-first-dominates? ] }
- { [ 2dup swap dominates? ] [ interferes-second-dominates? ] }
- [ 2drop 2drop f ]
- } cond ;
+++ /dev/null
-! Copyright (C) 2009 Slava Pestov.
-! 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 ;
-IN: compiler.cfg.ssa.destruction.live-ranges
-
-! Live ranges for interference testing
-
-<PRIVATE
-
-SYMBOLS: local-def-indices local-kill-indices ;
-
-: record-def ( n vregs -- )
- dup [ local-def-indices get set-at ] [ 2drop ] if ;
-
-: record-uses ( n vregs -- )
- local-kill-indices get '[ _ set-at ] with each ;
-
-: visit-insn ( insn n -- )
- ! Instructions are numbered 2 apart. If the instruction requires
- ! that outputs are in different registers than the inputs, then
- ! a use will be registered for every output immediately after
- ! this instruction and before the next one, ensuring that outputs
- ! interfere with inputs.
- 2 *
- [ swap defs-vreg record-def ]
- [ swap uses-vregs record-uses ]
- [ over def-is-use-insn? [ 1 + swap defs-vreg 1array record-uses ] [ 2drop ] if ]
- 2tri ;
-
-SYMBOLS: def-indices kill-indices ;
-
-: compute-local-live-ranges ( bb -- )
- H{ } clone local-def-indices set
- H{ } clone local-kill-indices set
- [ instructions>> [ visit-insn ] each-index ]
- [ [ local-def-indices get ] dip def-indices get set-at ]
- [ [ local-kill-indices get ] dip kill-indices get set-at ]
- tri ;
-
-PRIVATE>
-
-: compute-live-ranges ( cfg -- )
- H{ } clone def-indices set
- H{ } clone kill-indices set
- [ compute-local-live-ranges ] each-basic-block ;
-
-: def-index ( vreg bb -- n )
- def-indices get at at ;
-
-ERROR: bad-kill-index vreg bb ;
-
-: kill-index ( vreg bb -- n )
- 2dup live-out key? [ 2drop 1/0. ] [
- 2dup kill-indices get at at* [ 2nip ] [
- drop 2dup live-in key?
- [ bad-kill-index ] [ 2drop -1/0. ] if
- ] if
- ] if ;
+++ /dev/null
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-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.dominance
-compiler.cfg.ssa.destruction.state
-compiler.cfg.ssa.destruction.forest
-compiler.cfg.ssa.destruction.interference ;
-IN: compiler.cfg.ssa.destruction.process-blocks
-
-! phi-union maps a vreg to the predecessor block
-! that carries it to the phi node's block
-
-! unioned-blocks is a set of bb's which defined
-! the source vregs above
-SYMBOLS: phi-union unioned-blocks ;
-
-:: operand-live-into-phi-node's-block? ( bb src dst -- ? )
- src bb live-in key? ;
-
-:: phi-node-is-live-out-of-operand's-block? ( bb src dst -- ? )
- dst src def-of live-out key? ;
-
-:: 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&& ;
-
-:: operand-being-renamed? ( bb src dst -- ? )
- src processed-names get key? ;
-
-:: two-operands-in-same-block? ( bb src dst -- ? )
- src def-of unioned-blocks get key? ;
-
-: trivial-interference? ( bb src dst -- ? )
- {
- [ operand-live-into-phi-node's-block? ]
- [ phi-node-is-live-out-of-operand's-block? ]
- [ operand-is-phi-node-and-live-into-operand's-block? ]
- [ operand-being-renamed? ]
- [ two-operands-in-same-block? ]
- } 3|| ;
-
-: don't-coalesce ( bb src dst -- )
- 2nip processed-name ;
-
-:: trivial-interference ( bb src dst -- )
- dst src bb waiting-for push-at
- src used-by-another get push ;
-
-:: add-to-renaming-set ( bb src dst -- )
- bb src phi-union get set-at
- src def-of unioned-blocks get conjoin ;
-
-: process-phi-operand ( bb src dst -- )
- {
- { [ 2dup eq? ] [ don't-coalesce ] }
- { [ 3dup trivial-interference? ] [ trivial-interference ] }
- [ add-to-renaming-set ]
- } cond ;
-
-: node-is-live-in-of-child? ( node child -- ? )
- [ vreg>> ] [ bb>> live-in ] bi* key? ;
-
-: node-is-live-out-of-child? ( node child -- ? )
- [ vreg>> ] [ bb>> live-out ] bi* key? ;
-
-:: insert-copy ( bb src dst -- )
- bb src dst trivial-interference
- src phi-union get delete-at ;
-
-:: insert-copy-for-parent ( bb src node dst -- )
- src node vreg>> eq? [ bb src dst insert-copy ] when ;
-
-: insert-copies-for-parent ( ##phi node child -- )
- drop
- [ [ inputs>> ] [ dst>> ] bi ] dip
- '[ _ _ insert-copy-for-parent ] assoc-each ;
-
-: defined-in-same-block? ( node child -- ? ) [ bb>> ] bi@ eq? ;
-
-: add-interference ( ##phi node child -- )
- [ vreg>> ] bi@ 2array , drop ;
-
-: process-df-child ( ##phi node child -- )
- {
- { [ 2dup node-is-live-out-of-child? ] [ insert-copies-for-parent ] }
- { [ 2dup node-is-live-in-of-child? ] [ add-interference ] }
- { [ 2dup defined-in-same-block? ] [ add-interference ] }
- [ 3drop ]
- } cond ;
-
-: process-df-node ( ##phi node -- )
- dup children>>
- [ [ process-df-child ] with with each ]
- [ nip [ process-df-node ] with each ]
- 3bi ;
-
-: process-phi-union ( ##phi dom-forest -- )
- [ process-df-node ] with each ;
-
-: add-local-interferences ( ##phi -- )
- [ phi-union get ] dip dst>> '[ drop _ 2array , ] assoc-each ;
-
-: compute-local-interferences ( ##phi -- pairs )
- [
- [ phi-union get keys compute-dom-forest process-phi-union ]
- [ add-local-interferences ]
- bi
- ] { } make ;
-
-:: insert-copies-for-interference ( ##phi src -- )
- ##phi inputs>> [| bb src' |
- src src' eq? [ bb src ##phi dst>> insert-copy ] when
- ] assoc-each ;
-
-: process-local-interferences ( ##phi pairs -- )
- [
- first2 2dup interferes?
- [ drop insert-copies-for-interference ] [ 3drop ] if
- ] with each ;
-
-: add-renaming-set ( ##phi -- )
- [ phi-union get ] dip dst>> renaming-sets get set-at
- phi-union get [ drop processed-name ] assoc-each ;
-
-: process-phi ( ##phi -- )
- H{ } clone phi-union set
- H{ } clone unioned-blocks set
- [ [ inputs>> ] [ dst>> ] bi '[ _ process-phi-operand ] assoc-each ]
- [ dup compute-local-interferences process-local-interferences ]
- [ add-renaming-set ]
- tri ;
-
-: process-block ( bb -- )
- instructions>>
- [ dup ##phi? [ process-phi t ] [ drop f ] if ] all? drop ;
+++ /dev/null
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs fry kernel namespaces sequences
-compiler.cfg.ssa.destruction.state compiler.cfg.renaming compiler.cfg.rpo
-disjoint-sets ;
-IN: compiler.cfg.ssa.destruction.renaming
-
-: build-disjoint-set ( assoc -- disjoint-set )
- <disjoint-set> dup [
- '[
- [ _ add-atom ]
- [ [ drop _ add-atom ] assoc-each ]
- bi*
- ] assoc-each
- ] keep ;
-
-: update-congruence-class ( dst assoc disjoint-set -- )
- [ keys swap ] dip equate-all-with ;
-
-: build-congruence-classes ( -- disjoint-set )
- renaming-sets get
- dup build-disjoint-set
- [ '[ _ update-congruence-class ] assoc-each ] keep ;
-
-: compute-renaming ( disjoint-set -- assoc )
- [ parents>> ] keep
- '[ drop dup _ representative ] assoc-map ;
-
-: rename-blocks ( cfg -- )
- [
- instructions>> [
- [ rename-insn-defs ]
- [ rename-insn-uses ] bi
- ] each
- ] each-basic-block ;
-
-: rename-copies ( -- )
- waiting renamings get '[
- [
- [ _ [ ?at drop ] [ '[ _ ?at drop ] map ] bi-curry bi* ] assoc-map
- ] assoc-map
- ] change ;
-
-: perform-renaming ( cfg -- )
- build-congruence-classes compute-renaming renamings set
- rename-blocks
- rename-copies ;
+++ /dev/null
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces sets kernel assocs ;
-IN: compiler.cfg.ssa.destruction.state
-
-SYMBOLS: processed-names waiting used-by-another renaming-sets ;
-
-: init-coalescing ( -- )
- H{ } clone renaming-sets set
- H{ } clone processed-names set
- H{ } clone waiting set
- V{ } clone used-by-another set ;
-
-: processed-name ( vreg -- ) processed-names get conjoin ;
-
-: waiting-for ( bb -- assoc ) waiting get [ drop H{ } clone ] cache ;
--- /dev/null
+USING: accessors compiler.cfg compiler.cfg.debugger
+compiler.cfg.def-use compiler.cfg.dominance
+compiler.cfg.instructions compiler.cfg.liveness.ssa
+compiler.cfg.registers compiler.cfg.predecessors
+compiler.cfg.ssa.interference
+compiler.cfg.ssa.interference.live-ranges cpu.architecture
+kernel namespaces tools.test ;
+IN: compiler.cfg.ssa.interference.tests
+
+: test-interference ( -- )
+ cfg new 0 get >>entry
+ compute-ssa-live-sets
+ compute-predecessors
+ dup compute-defs
+ dup compute-dominance
+ compute-live-ranges ;
+
+V{
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##peek f V int-regs 2 D 0 }
+ T{ ##copy f V int-regs 1 V int-regs 0 }
+ T{ ##copy f V int-regs 3 V int-regs 2 }
+ T{ ##branch }
+} 0 test-bb
+
+V{
+ T{ ##peek f V int-regs 4 D 0 }
+ T{ ##peek f V int-regs 5 D 0 }
+ T{ ##replace f V int-regs 3 D 0 }
+ T{ ##peek f V int-regs 6 D 0 }
+ T{ ##replace f V int-regs 5 D 0 }
+ T{ ##return }
+} 1 test-bb
+
+0 1 edge
+
+[ ] [ test-interference ] unit-test
+
+[ f ] [ V int-regs 0 V int-regs 1 vregs-interfere? ] unit-test
+[ f ] [ V int-regs 1 V int-regs 0 vregs-interfere? ] unit-test
+[ f ] [ V int-regs 2 V int-regs 3 vregs-interfere? ] unit-test
+[ f ] [ V int-regs 3 V int-regs 2 vregs-interfere? ] unit-test
+[ t ] [ V int-regs 0 V int-regs 2 vregs-interfere? ] unit-test
+[ t ] [ V int-regs 2 V int-regs 0 vregs-interfere? ] unit-test
+[ f ] [ V int-regs 1 V int-regs 3 vregs-interfere? ] unit-test
+[ f ] [ V int-regs 3 V int-regs 1 vregs-interfere? ] unit-test
+[ t ] [ V int-regs 3 V int-regs 4 vregs-interfere? ] unit-test
+[ t ] [ V int-regs 4 V int-regs 3 vregs-interfere? ] unit-test
+[ t ] [ V int-regs 3 V int-regs 5 vregs-interfere? ] unit-test
+[ t ] [ V int-regs 5 V int-regs 3 vregs-interfere? ] unit-test
+[ f ] [ V int-regs 3 V int-regs 6 vregs-interfere? ] unit-test
+[ f ] [ V int-regs 6 V int-regs 3 vregs-interfere? ] unit-test
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs combinators combinators.short-circuit fry
+kernel math math.order sorting namespaces sequences locals
+compiler.cfg.def-use compiler.cfg.dominance
+compiler.cfg.ssa.interference.live-ranges ;
+IN: compiler.cfg.ssa.interference
+
+<PRIVATE
+
+:: kill-after-def? ( vreg1 vreg2 bb -- ? )
+ ! If first register is used after second one is defined, they interfere.
+ ! If they are used in the same instruction, no interference. If the
+ ! instruction is a def-is-use-insn, then there will be a use at +1
+ ! (instructions are 2 apart) and so outputs will interfere with
+ ! inputs.
+ vreg1 bb kill-index
+ vreg2 bb def-index > ;
+
+:: interferes-same-block? ( vreg1 vreg2 bb1 bb2 -- ? )
+ ! If both are defined in the same basic block, they interfere if their
+ ! local live ranges intersect.
+ vreg1 bb1 def-index
+ vreg2 bb1 def-index <
+ [ vreg1 vreg2 ] [ vreg2 vreg1 ] if
+ bb1 kill-after-def? ;
+
+: interferes-first-dominates? ( vreg1 vreg2 bb1 bb2 -- ? )
+ ! If vreg1 dominates vreg2, then they interfere if vreg2's definition
+ ! occurs before vreg1 is killed.
+ nip
+ kill-after-def? ;
+
+: interferes-second-dominates? ( vreg1 vreg2 bb1 bb2 -- ? )
+ ! If vreg2 dominates vreg1, then they interfere if vreg1's definition
+ ! occurs before vreg2 is killed.
+ drop
+ swapd kill-after-def? ;
+
+PRIVATE>
+
+: vregs-interfere? ( vreg1 vreg2 -- ? )
+ 2dup [ def-of ] bi@ {
+ { [ 2dup eq? ] [ interferes-same-block? ] }
+ { [ 2dup dominates? ] [ interferes-first-dominates? ] }
+ { [ 2dup swap dominates? ] [ interferes-second-dominates? ] }
+ [ 2drop 2drop f ]
+ } cond ;
+
+! Debug this stuff later
+<PRIVATE
+
+: quadratic-test? ( seq1 seq2 -- ? ) [ length ] bi@ + 10 < ;
+
+: quadratic-test ( seq1 seq2 -- ? )
+ '[ _ [ vregs-interfere? ] with any? ] any? ;
+
+: sort-vregs-by-bb ( vregs -- alist )
+ defs get
+ '[ dup _ at ] { } map>assoc
+ [ second pre-of ] sort-with ;
+
+: ?last ( seq -- elt/f ) [ f ] [ last ] if-empty ; inline
+
+: find-parent ( dom current -- parent )
+ over empty? [ 2drop f ] [
+ over last over dominates? [ drop last ] [
+ over pop* find-parent
+ ] if
+ ] if ;
+
+:: linear-test ( seq1 seq2 -- ? )
+ ! Instead of sorting, SSA destruction should keep equivalence
+ ! classes sorted by merging them on append
+ V{ } clone :> dom
+ seq1 seq2 append sort-vregs-by-bb [| pair |
+ pair first :> current
+ dom current find-parent
+ dup [ current vregs-interfere? ] when
+ [ t ] [ current dom push f ] if
+ ] any? ;
+
+PRIVATE>
+
+: sets-interfere? ( seq1 seq2 -- ? )
+ quadratic-test ;
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! 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.ssa compiler.cfg.rpo ;
+IN: compiler.cfg.ssa.interference.live-ranges
+
+! Live ranges for interference testing
+
+<PRIVATE
+
+SYMBOLS: local-def-indices local-kill-indices ;
+
+: record-def ( n vregs -- )
+ dup [ local-def-indices get set-at ] [ 2drop ] if ;
+
+: record-uses ( n vregs -- )
+ local-kill-indices get '[ _ set-at ] with each ;
+
+: visit-insn ( insn n -- )
+ ! Instructions are numbered 2 apart. If the instruction requires
+ ! that outputs are in different registers than the inputs, then
+ ! a use will be registered for every output immediately after
+ ! this instruction and before the next one, ensuring that outputs
+ ! interfere with inputs.
+ 2 *
+ [ swap defs-vreg record-def ]
+ [ swap uses-vregs record-uses ]
+ [ over def-is-use-insn? [ 1 + swap defs-vreg 1array record-uses ] [ 2drop ] if ]
+ 2tri ;
+
+SYMBOLS: def-indices kill-indices ;
+
+: compute-local-live-ranges ( bb -- )
+ H{ } clone local-def-indices set
+ H{ } clone local-kill-indices set
+ [ instructions>> [ visit-insn ] each-index ]
+ [ [ local-def-indices get ] dip def-indices get set-at ]
+ [ [ local-kill-indices get ] dip kill-indices get set-at ]
+ tri ;
+
+PRIVATE>
+
+: compute-live-ranges ( cfg -- )
+ H{ } clone def-indices set
+ H{ } clone kill-indices set
+ [ compute-local-live-ranges ] each-basic-block ;
+
+: def-index ( vreg bb -- n )
+ def-indices get at at ;
+
+ERROR: bad-kill-index vreg bb ;
+
+: kill-index ( vreg bb -- n )
+ 2dup live-out? [ 2drop 1/0. ] [
+ 2dup kill-indices get at at* [ 2nip ] [
+ drop 2dup live-in?
+ [ bad-kill-index ] [ 2drop -1/0. ] if
+ ] if
+ ] if ;
--- /dev/null
+! Copyright (C) 2009 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel tools.test namespaces sequences vectors accessors sets
+arrays math.ranges assocs
+cpu.architecture
+compiler.cfg
+compiler.cfg.ssa.liveness.private
+compiler.cfg.ssa.liveness
+compiler.cfg.debugger
+compiler.cfg.instructions
+compiler.cfg.predecessors
+compiler.cfg.registers
+compiler.cfg.dominance
+compiler.cfg.def-use ;
+IN: compiler.cfg.ssa.liveness
+
+[ t ] [ { 1 } 1 only? ] unit-test
+[ t ] [ { } 1 only? ] unit-test
+[ f ] [ { 2 1 } 1 only? ] unit-test
+[ f ] [ { 2 } 1 only? ] unit-test
+
+: test-liveness ( -- )
+ cfg new 0 get >>entry
+ compute-predecessors
+ dup compute-defs
+ dup compute-uses
+ dup compute-dominance
+ precompute-liveness ;
+
+V{
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##replace f V int-regs 0 D 0 }
+ T{ ##replace f V int-regs 1 D 1 }
+} 0 test-bb
+
+V{
+ T{ ##replace f V int-regs 2 D 0 }
+} 1 test-bb
+
+V{
+ T{ ##replace f V int-regs 3 D 0 }
+} 2 test-bb
+
+0 { 1 2 } edges
+
+[ ] [ test-liveness ] unit-test
+
+[ H{ } ] [ back-edge-targets get ] unit-test
+[ t ] [ 0 get R_q { 0 1 2 } [ get ] map unique = ] unit-test
+[ t ] [ 1 get R_q { 1 } [ get ] map unique = ] unit-test
+[ t ] [ 2 get R_q { 2 } [ get ] map unique = ] unit-test
+
+: self-T_q ( n -- ? )
+ get [ T_q ] [ 1array unique ] bi = ;
+
+[ t ] [ 0 self-T_q ] unit-test
+[ t ] [ 1 self-T_q ] unit-test
+[ t ] [ 2 self-T_q ] unit-test
+
+[ f ] [ V int-regs 0 0 get live-in? ] unit-test
+[ t ] [ V int-regs 1 0 get live-in? ] unit-test
+[ t ] [ V int-regs 2 0 get live-in? ] unit-test
+[ t ] [ V int-regs 3 0 get live-in? ] unit-test
+
+[ f ] [ V int-regs 0 0 get live-out? ] unit-test
+[ f ] [ V int-regs 1 0 get live-out? ] unit-test
+[ t ] [ V int-regs 2 0 get live-out? ] unit-test
+[ t ] [ V int-regs 3 0 get live-out? ] unit-test
+
+[ f ] [ V int-regs 0 1 get live-in? ] unit-test
+[ f ] [ V int-regs 1 1 get live-in? ] unit-test
+[ t ] [ V int-regs 2 1 get live-in? ] unit-test
+[ f ] [ V int-regs 3 1 get live-in? ] unit-test
+
+[ f ] [ V int-regs 0 1 get live-out? ] unit-test
+[ f ] [ V int-regs 1 1 get live-out? ] unit-test
+[ f ] [ V int-regs 2 1 get live-out? ] unit-test
+[ f ] [ V int-regs 3 1 get live-out? ] unit-test
+
+[ f ] [ V int-regs 0 2 get live-in? ] unit-test
+[ f ] [ V int-regs 1 2 get live-in? ] unit-test
+[ f ] [ V int-regs 2 2 get live-in? ] unit-test
+[ t ] [ V int-regs 3 2 get live-in? ] unit-test
+
+[ f ] [ V int-regs 0 2 get live-out? ] unit-test
+[ f ] [ V int-regs 1 2 get live-out? ] unit-test
+[ f ] [ V int-regs 2 2 get live-out? ] unit-test
+[ f ] [ V int-regs 3 2 get live-out? ] unit-test
+
+V{ } 0 test-bb
+V{ } 1 test-bb
+V{ } 2 test-bb
+V{ } 3 test-bb
+V{
+ T{ ##phi f V int-regs 2 H{ { 2 V int-regs 0 } { 3 V int-regs 1 } } }
+} 4 test-bb
+test-diamond
+
+[ ] [ test-liveness ] unit-test
+
+[ t ] [ V int-regs 0 1 get live-in? ] unit-test
+[ t ] [ V int-regs 1 1 get live-in? ] unit-test
+[ f ] [ V int-regs 2 1 get live-in? ] unit-test
+
+[ t ] [ V int-regs 0 1 get live-out? ] unit-test
+[ t ] [ V int-regs 1 1 get live-out? ] unit-test
+[ f ] [ V int-regs 2 1 get live-out? ] unit-test
+
+[ t ] [ V int-regs 0 2 get live-in? ] unit-test
+[ f ] [ V int-regs 1 2 get live-in? ] unit-test
+[ f ] [ V int-regs 2 2 get live-in? ] unit-test
+
+[ f ] [ V int-regs 0 2 get live-out? ] unit-test
+[ f ] [ V int-regs 1 2 get live-out? ] unit-test
+[ f ] [ V int-regs 2 2 get live-out? ] unit-test
+
+[ f ] [ V int-regs 0 3 get live-in? ] unit-test
+[ t ] [ V int-regs 1 3 get live-in? ] unit-test
+[ f ] [ V int-regs 2 3 get live-in? ] unit-test
+
+[ f ] [ V int-regs 0 3 get live-out? ] unit-test
+[ f ] [ V int-regs 1 3 get live-out? ] unit-test
+[ f ] [ V int-regs 2 3 get live-out? ] unit-test
+
+[ f ] [ V int-regs 0 4 get live-in? ] unit-test
+[ f ] [ V int-regs 1 4 get live-in? ] unit-test
+[ f ] [ V int-regs 2 4 get live-in? ] unit-test
+
+[ f ] [ V int-regs 0 4 get live-out? ] unit-test
+[ f ] [ V int-regs 1 4 get live-out? ] unit-test
+[ f ] [ V int-regs 2 4 get live-out? ] unit-test
+
+! This is the CFG in Figure 3 from the paper
+V{ } 0 test-bb
+V{ } 1 test-bb
+0 1 edge
+V{ } 2 test-bb
+1 2 edge
+V{
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##peek f V int-regs 1 D 0 }
+ T{ ##peek f V int-regs 2 D 0 }
+} 3 test-bb
+V{ } 11 test-bb
+2 { 3 11 } edges
+V{
+ T{ ##replace f V int-regs 0 D 0 }
+} 4 test-bb
+V{ } 8 test-bb
+3 { 8 4 } edges
+V{
+ T{ ##replace f V int-regs 1 D 0 }
+} 9 test-bb
+8 9 edge
+V{
+ T{ ##replace f V int-regs 2 D 0 }
+} 5 test-bb
+4 5 edge
+V{ } 10 test-bb
+V{ } 6 test-bb
+5 6 edge
+9 { 6 10 } edges
+V{ } 7 test-bb
+6 { 5 7 } edges
+10 8 edge
+7 2 edge
+
+[ ] [ test-liveness ] unit-test
+
+[ t ] [ 1 get R_q 1 11 [a,b] [ get ] map unique = ] unit-test
+[ t ] [ 2 get R_q 2 11 [a,b] [ get ] map unique = ] unit-test
+[ t ] [ 3 get R_q 3 10 [a,b] [ get ] map unique = ] unit-test
+[ t ] [ 4 get R_q 4 7 [a,b] [ get ] map unique = ] unit-test
+[ t ] [ 5 get R_q 5 7 [a,b] [ get ] map unique = ] unit-test
+[ t ] [ 6 get R_q 6 7 [a,b] [ get ] map unique = ] unit-test
+[ t ] [ 7 get R_q 7 7 [a,b] [ get ] map unique = ] unit-test
+[ t ] [ 8 get R_q 6 10 [a,b] [ get ] map unique = ] unit-test
+[ t ] [ 9 get R_q 8 6 10 [a,b] remove [ get ] map unique = ] unit-test
+[ t ] [ 10 get R_q 10 10 [a,b] [ get ] map unique = ] unit-test
+[ t ] [ 11 get R_q 11 11 [a,b] [ get ] map unique = ] unit-test
+
+[ t ] [ 1 get T_q 1 get 1array unique = ] unit-test
+[ t ] [ 2 get T_q 2 get 1array unique = ] unit-test
+[ t ] [ 3 get T_q 3 get 2 get 2array unique = ] unit-test
+[ t ] [ 4 get T_q 4 get 2 get 2array unique = ] unit-test
+[ t ] [ 5 get T_q 5 get 2 get 2array unique = ] unit-test
+[ t ] [ 6 get T_q { 6 2 5 } [ get ] map unique = ] unit-test
+[ t ] [ 7 get T_q { 7 2 } [ get ] map unique = ] unit-test
+[ t ] [ 8 get T_q { 8 2 5 } [ get ] map unique = ] unit-test
+[ t ] [ 9 get T_q { 2 5 8 9 } [ get ] map unique = ] unit-test
+[ t ] [ 10 get T_q { 2 5 8 10 } [ get ] map unique = ] unit-test
+[ t ] [ 11 get T_q 11 get 1array unique = ] unit-test
+
+[ f ] [ 1 get back-edge-target? ] unit-test
+[ t ] [ 2 get back-edge-target? ] unit-test
+[ f ] [ 3 get back-edge-target? ] unit-test
+[ f ] [ 4 get back-edge-target? ] unit-test
+[ t ] [ 5 get back-edge-target? ] unit-test
+[ f ] [ 6 get back-edge-target? ] unit-test
+[ f ] [ 7 get back-edge-target? ] unit-test
+[ t ] [ 8 get back-edge-target? ] unit-test
+[ f ] [ 9 get back-edge-target? ] unit-test
+[ f ] [ 10 get back-edge-target? ] unit-test
+[ f ] [ 11 get back-edge-target? ] unit-test
+
+[ f ] [ V int-regs 0 1 get live-in? ] unit-test
+[ f ] [ V int-regs 1 1 get live-in? ] unit-test
+[ f ] [ V int-regs 2 1 get live-in? ] unit-test
+
+[ f ] [ V int-regs 0 1 get live-out? ] unit-test
+[ f ] [ V int-regs 1 1 get live-out? ] unit-test
+[ f ] [ V int-regs 2 1 get live-out? ] unit-test
+
+[ f ] [ V int-regs 0 2 get live-in? ] unit-test
+[ f ] [ V int-regs 1 2 get live-in? ] unit-test
+[ f ] [ V int-regs 2 2 get live-in? ] unit-test
+
+[ f ] [ V int-regs 0 2 get live-out? ] unit-test
+[ f ] [ V int-regs 1 2 get live-out? ] unit-test
+[ f ] [ V int-regs 2 2 get live-out? ] unit-test
+
+[ f ] [ V int-regs 0 3 get live-in? ] unit-test
+[ f ] [ V int-regs 1 3 get live-in? ] unit-test
+[ f ] [ V int-regs 2 3 get live-in? ] unit-test
+
+[ t ] [ V int-regs 0 3 get live-out? ] unit-test
+[ t ] [ V int-regs 1 3 get live-out? ] unit-test
+[ t ] [ V int-regs 2 3 get live-out? ] unit-test
+
+[ t ] [ V int-regs 0 4 get live-in? ] unit-test
+[ f ] [ V int-regs 1 4 get live-in? ] unit-test
+[ t ] [ V int-regs 2 4 get live-in? ] unit-test
+
+[ f ] [ V int-regs 0 4 get live-out? ] unit-test
+[ f ] [ V int-regs 1 4 get live-out? ] unit-test
+[ t ] [ V int-regs 2 4 get live-out? ] unit-test
+
+[ f ] [ V int-regs 0 5 get live-in? ] unit-test
+[ f ] [ V int-regs 1 5 get live-in? ] unit-test
+[ t ] [ V int-regs 2 5 get live-in? ] unit-test
+
+[ f ] [ V int-regs 0 5 get live-out? ] unit-test
+[ f ] [ V int-regs 1 5 get live-out? ] unit-test
+[ t ] [ V int-regs 2 5 get live-out? ] unit-test
+
+[ f ] [ V int-regs 0 6 get live-in? ] unit-test
+[ f ] [ V int-regs 1 6 get live-in? ] unit-test
+[ t ] [ V int-regs 2 6 get live-in? ] unit-test
+
+[ f ] [ V int-regs 0 6 get live-out? ] unit-test
+[ f ] [ V int-regs 1 6 get live-out? ] unit-test
+[ t ] [ V int-regs 2 6 get live-out? ] unit-test
+
+[ f ] [ V int-regs 0 7 get live-in? ] unit-test
+[ f ] [ V int-regs 1 7 get live-in? ] unit-test
+[ f ] [ V int-regs 2 7 get live-in? ] unit-test
+
+[ f ] [ V int-regs 0 7 get live-out? ] unit-test
+[ f ] [ V int-regs 1 7 get live-out? ] unit-test
+[ f ] [ V int-regs 2 7 get live-out? ] unit-test
+
+[ f ] [ V int-regs 0 8 get live-in? ] unit-test
+[ t ] [ V int-regs 1 8 get live-in? ] unit-test
+[ t ] [ V int-regs 2 8 get live-in? ] unit-test
+
+[ f ] [ V int-regs 0 8 get live-out? ] unit-test
+[ t ] [ V int-regs 1 8 get live-out? ] unit-test
+[ t ] [ V int-regs 2 8 get live-out? ] unit-test
+
+[ f ] [ V int-regs 0 9 get live-in? ] unit-test
+[ t ] [ V int-regs 1 9 get live-in? ] unit-test
+[ t ] [ V int-regs 2 9 get live-in? ] unit-test
+
+[ f ] [ V int-regs 0 9 get live-out? ] unit-test
+[ t ] [ V int-regs 1 9 get live-out? ] unit-test
+[ t ] [ V int-regs 2 9 get live-out? ] unit-test
+
+[ f ] [ V int-regs 0 10 get live-in? ] unit-test
+[ t ] [ V int-regs 1 10 get live-in? ] unit-test
+[ t ] [ V int-regs 2 10 get live-in? ] unit-test
+
+[ f ] [ V int-regs 0 10 get live-out? ] unit-test
+[ t ] [ V int-regs 1 10 get live-out? ] unit-test
+[ t ] [ V int-regs 2 10 get live-out? ] unit-test
+
+[ f ] [ V int-regs 0 11 get live-in? ] unit-test
+[ f ] [ V int-regs 1 11 get live-in? ] unit-test
+[ f ] [ V int-regs 2 11 get live-in? ] unit-test
+
+[ f ] [ V int-regs 0 11 get live-out? ] unit-test
+[ f ] [ V int-regs 1 11 get live-out? ] unit-test
+[ f ] [ V int-regs 2 11 get live-out? ] unit-test
--- /dev/null
+! Copyright (C) 2009 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences assocs accessors
+namespaces fry math sets combinators locals
+compiler.cfg.rpo
+compiler.cfg.dominance
+compiler.cfg.def-use
+compiler.cfg.instructions ;
+IN: compiler.cfg.ssa.liveness
+
+! Liveness checking on SSA IR, as described in
+! "Fast Liveness Checking for SSA-Form Programs", Sebastian Hack et al.
+! http://hal.archives-ouvertes.fr/docs/00/19/22/19/PDF/fast_liveness.pdf
+
+<PRIVATE
+
+! The sets T_q and R_q are described there
+SYMBOL: T_q-sets
+SYMBOL: R_q-sets
+
+! Targets of back edges
+SYMBOL: back-edge-targets
+
+: T_q ( q -- T_q )
+ T_q-sets get at ;
+
+: R_q ( q -- R_q )
+ R_q-sets get at ;
+
+: back-edge-target? ( block -- ? )
+ back-edge-targets get key? ;
+
+: next-R_q ( q -- R_q )
+ [ ] [ successors>> ] [ number>> ] tri
+ '[ number>> _ >= ] filter
+ [ R_q ] map assoc-combine
+ [ conjoin ] keep ;
+
+: set-R_q ( q -- )
+ [ next-R_q ] keep R_q-sets get set-at ;
+
+: set-back-edges ( q -- )
+ [ successors>> ] [ number>> ] bi '[
+ dup number>> _ <
+ [ back-edge-targets get conjoin ] [ drop ] if
+ ] each ;
+
+: init-R_q ( -- )
+ H{ } clone R_q-sets set
+ H{ } clone back-edge-targets set ;
+
+: compute-R_q ( cfg -- )
+ init-R_q
+ post-order [
+ [ set-R_q ] [ set-back-edges ] bi
+ ] each ;
+
+! This algorithm for computing T_q uses equation (1)
+! but not the faster algorithm described in the paper
+
+: back-edges-from ( q -- edges )
+ R_q keys [
+ [ successors>> ] [ number>> ] bi
+ '[ number>> _ < ] filter
+ ] gather ;
+
+: T^_q ( q -- T^_q )
+ [ back-edges-from ] [ R_q ] bi
+ '[ _ key? not ] filter ;
+
+: next-T_q ( q -- T_q )
+ dup dup T^_q [ next-T_q keys ] map
+ concat unique [ conjoin ] keep
+ [ swap T_q-sets get set-at ] keep ;
+
+: compute-T_q ( cfg -- )
+ H{ } T_q-sets set
+ [ next-T_q drop ] each-basic-block ;
+
+PRIVATE>
+
+: precompute-liveness ( cfg -- )
+ [ compute-R_q ] [ compute-T_q ] bi ;
+
+<PRIVATE
+
+! This doesn't take advantage of ordering T_q,a so you
+! only have to check one if the CFG is reducible.
+! It should be changed to be more efficient.
+
+: only? ( seq obj -- ? )
+ '[ _ eq? ] all? ;
+
+: strictly-dominates? ( bb1 bb2 -- ? )
+ [ dominates? ] [ eq? not ] 2bi and ;
+
+: T_q,a ( a q -- T_q,a )
+ ! This could take advantage of the structure of dominance,
+ ! but probably I'll replace it with the algorithm that works
+ ! on reducible CFGs anyway
+ T_q keys swap def-of
+ [ '[ _ swap strictly-dominates? ] filter ] when* ;
+
+: live? ( vreg node quot -- ? )
+ [ [ T_q,a ] [ drop uses-of ] 2bi ] dip
+ '[ [ R_q keys _ ] keep @ intersects? ] any? ; inline
+
+PRIVATE>
+
+: live-in? ( vreg node -- ? )
+ [ drop ] live? ;
+
+<PRIVATE
+
+: (live-out?) ( vreg node -- ? )
+ dup dup dup '[
+ _ = _ back-edge-target? not and
+ [ _ swap remove ] when
+ ] live? ;
+
+PRIVATE>
+
+:: live-out? ( vreg node -- ? )
+ [let | def [ vreg def-of ] |
+ {
+ { [ node def eq? ] [ vreg uses-of def only? not ] }
+ { [ def node strictly-dominates? ] [ vreg node (live-out?) ] }
+ [ f ]
+ } cond
+ ] ;
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces assocs kernel fry accessors sequences make math
+USING: namespaces assocs kernel fry accessors sequences make math locals
combinators compiler.cfg compiler.cfg.hats compiler.cfg.instructions
compiler.cfg.utilities compiler.cfg.rpo compiler.cfg.stacks.local
compiler.cfg.stacks.global compiler.cfg.stacks.height ;
! This pass inserts peeks and replaces.
-: inserting-peeks ( from to -- assoc )
- peek-in swap [ peek-out ] [ avail-out ] bi
- assoc-union assoc-diff ;
-
-: inserting-replaces ( from to -- assoc )
- [ replace-out ] [ [ kill-in ] [ replace-in ] bi ] bi*
- assoc-union assoc-diff ;
+:: inserting-peeks ( from to -- assoc )
+ ! A peek is inserted on an edge if the destination anticipates
+ ! the stack location, the source does not anticipate it and
+ ! it is not available from the source in a register.
+ to anticip-in
+ from anticip-out from avail-out assoc-union
+ assoc-diff ;
+
+:: inserting-replaces ( from to -- assoc )
+ ! A replace is inserted on an edge if two conditions hold:
+ ! - the location is not dead at the destination, OR
+ ! the location is live at the destination but not available
+ ! at the destination
+ ! - the location is pending in the source but not the destination
+ from pending-out to pending-in assoc-diff
+ to dead-in to live-in to anticip-in assoc-diff assoc-diff
+ assoc-diff ;
: each-insertion ( assoc bb quot: ( vreg loc -- ) -- )
'[ drop [ loc>vreg ] [ _ untranslate-loc ] bi @ ] assoc-each ; inline
[ dup n>> 0 < [ 2drop ] [ ##replace ] if ] each-insertion ;
: visit-edge ( from to -- )
- 2dup [ [ insert-peeks ] [ insert-replaces ] 2bi ] V{ } make
- [ 2drop ] [ <simple-block> insert-basic-block ] if-empty ;
+ ! If both blocks are subroutine calls, don't bother
+ ! computing anything.
+ 2dup [ kill-block? ] both? [ 2drop ] [
+ 2dup [ [ insert-replaces ] [ insert-peeks ] 2bi ] V{ } make
+ [ 2drop ] [ <simple-block> insert-basic-block ] if-empty
+ ] if ;
: visit-block ( bb -- )
[ predecessors>> ] keep '[ _ visit-edge ] each ;
compiler.cfg.stacks.local ;
IN: compiler.cfg.stacks.global
-! Peek analysis. Peek-in is the set of all locations anticipated at
-! the start of a basic block.
-BACKWARD-ANALYSIS: peek
+: transfer-peeked-locs ( assoc bb -- assoc' )
+ [ replace-set assoc-diff ] [ peek-set assoc-union ] bi ;
-M: peek-analysis transfer-set drop [ replace-set assoc-diff ] keep peek-set assoc-union ;
+! A stack location is anticipated at a location if every path from
+! the location to an exit block will read the stack location
+! before writing it.
+BACKWARD-ANALYSIS: anticip
-! Replace analysis. Replace-in is the set of all locations which
-! will be overwritten at some point after the start of a basic block.
-FORWARD-ANALYSIS: replace
+M: anticip-analysis transfer-set drop transfer-peeked-locs ;
-M: replace-analysis transfer-set drop replace-set assoc-union ;
+! A stack location is live at a location if some path from
+! the location to an exit block will read the stack location
+! before writing it.
+BACKWARD-ANALYSIS: live
-! Availability analysis. Avail-out is the set of all locations
-! in registers at the end of a basic block.
+M: live-analysis transfer-set drop transfer-peeked-locs ;
+
+M: live-analysis join-sets drop assoc-combine ;
+
+! A stack location is available at a location if all paths from
+! the entry block to the location load the location into a
+! register.
FORWARD-ANALYSIS: avail
-M: avail-analysis transfer-set drop [ peek-set ] [ replace-set ] bi assoc-union assoc-union ;
+M: avail-analysis transfer-set
+ drop [ peek-set assoc-union ] [ replace-set assoc-union ] bi ;
+
+! A stack location is pending at a location if all paths from
+! the entry block to the location write the location.
+FORWARD-ANALYSIS: pending
+
+M: pending-analysis transfer-set
+ drop replace-set assoc-union ;
-! Kill analysis. Kill-in is the set of all locations
-! which are going to be overwritten.
-BACKWARD-ANALYSIS: kill
+! A stack location is dead at a location if no paths from the
+! location to the exit block read the location before writing it.
+BACKWARD-ANALYSIS: dead
-M: kill-analysis transfer-set drop replace-set assoc-union ;
+M: dead-analysis transfer-set
+ drop
+ [ kill-set assoc-union ]
+ [ replace-set assoc-union ] bi ;
! Main word
: compute-global-sets ( cfg -- cfg' )
{
- [ compute-peek-sets ]
- [ compute-replace-sets ]
+ [ compute-anticip-sets ]
+ [ compute-live-sets ]
+ [ compute-pending-sets ]
+ [ compute-dead-sets ]
[ compute-avail-sets ]
- [ compute-kill-sets ]
[ ]
} cleave ;
\ No newline at end of file
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs kernel math namespaces sets make sequences
+USING: accessors assocs kernel math math.order namespaces sets make
+sequences combinators fry
compiler.cfg
compiler.cfg.hats
compiler.cfg.instructions
compiler.cfg.parallel-copy ;
IN: compiler.cfg.stacks.local
-! Local stack analysis. We build local peek and replace sets for every basic
-! block while constructing the CFG.
+! Local stack analysis. We build three sets for every basic block
+! in the CFG:
+! - peek-set: all stack locations that the block reads before writing
+! - replace-set: all stack locations that the block writes
+! - kill-set: all stack locations which become unavailable after the
+! block ends because of the stack height being decremented
+! This is done while constructing the CFG.
-SYMBOLS: peek-sets replace-sets ;
+SYMBOLS: peek-sets replace-sets kill-sets ;
SYMBOL: locs>vregs
: loc>vreg ( loc -- vreg ) locs>vregs get [ drop i ] cache ;
: vreg>loc ( vreg -- loc/f ) locs>vregs get value-at ;
-TUPLE: current-height { d initial: 0 } { r initial: 0 } { emit-d initial: 0 } { emit-r initial: 0 } ;
+TUPLE: current-height
+{ d initial: 0 }
+{ r initial: 0 }
+{ emit-d initial: 0 }
+{ emit-r initial: 0 } ;
SYMBOLS: local-peek-set local-replace-set replace-mapping ;
bi
] if ;
+: compute-local-kill-set ( -- assoc )
+ basic-block get current-height get
+ [ [ ds-heights get at dup ] [ d>> ] bi* [-] iota [ swap - <ds-loc> ] with map ]
+ [ [ rs-heights get at dup ] [ r>> ] bi* [-] iota [ swap - <rs-loc> ] with map ] 2bi
+ append unique ;
+
: begin-local-analysis ( -- )
H{ } clone local-peek-set set
H{ } clone local-replace-set set
H{ } clone replace-mapping set
- current-height get 0 >>emit-d 0 >>emit-r drop
- current-height get [ d>> ] [ r>> ] bi basic-block get record-stack-heights ;
+ current-height get
+ [ 0 >>emit-d 0 >>emit-r drop ]
+ [ [ d>> ] [ r>> ] bi basic-block get record-stack-heights ] bi ;
: end-local-analysis ( -- )
emit-changes
- local-peek-set get basic-block get peek-sets get set-at
- local-replace-set get basic-block get replace-sets get set-at ;
+ basic-block get {
+ [ [ local-peek-set get ] dip peek-sets get set-at ]
+ [ [ local-replace-set get ] dip replace-sets get set-at ]
+ [ [ compute-local-kill-set ] dip kill-sets get set-at ]
+ } cleave ;
: clone-current-height ( -- )
current-height [ clone ] change ;
: peek-set ( bb -- assoc ) peek-sets get at ;
: replace-set ( bb -- assoc ) replace-sets get at ;
+: kill-set ( bb -- assoc ) kill-sets get at ;
\ No newline at end of file
H{ } clone rs-heights set
H{ } clone peek-sets set
H{ } clone replace-sets set
+ H{ } clone kill-sets set
current-height new current-height set ;
: end-stack-analysis ( -- )
--- /dev/null
+IN: compiler.cfg.stacks.uninitialized.tests
+USING: compiler.cfg.stacks.uninitialized compiler.cfg.debugger
+compiler.cfg.registers compiler.cfg.instructions compiler.cfg
+compiler.cfg.predecessors cpu.architecture tools.test kernel vectors
+namespaces accessors sequences ;
+
+: test-uninitialized ( -- )
+ cfg new 0 get >>entry
+ compute-predecessors
+ compute-uninitialized-sets ;
+
+V{
+ T{ ##inc-d f 3 }
+} 0 test-bb
+
+V{
+ T{ ##replace f V int-regs 0 D 0 }
+ T{ ##replace f V int-regs 0 D 1 }
+ T{ ##replace f V int-regs 0 D 2 }
+ T{ ##inc-r f 1 }
+} 1 test-bb
+
+V{
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##inc-d f 1 }
+} 2 test-bb
+
+0 1 edge
+1 2 edge
+
+[ ] [ test-uninitialized ] unit-test
+
+[ V{ D 0 D 1 D 2 } ] [ 1 get uninitialized-locs ] unit-test
+[ V{ R 0 } ] [ 2 get uninitialized-locs ] unit-test
+
+! When merging, if a location is uninitialized in one branch and
+! initialized in another, we have to consider it uninitialized,
+! since it cannot be safely read from by a ##peek, or traced by GC.
+
+V{ } 0 test-bb
+
+V{
+ T{ ##inc-d f 1 }
+} 1 test-bb
+
+V{
+ T{ ##call f namestack }
+ T{ ##branch }
+} 2 test-bb
+
+V{
+ T{ ##return }
+} 3 test-bb
+
+0 { 1 2 } edges
+1 3 edge
+2 3 edge
+
+[ ] [ test-uninitialized ] unit-test
+
+[ V{ D 0 } ] [ 3 get uninitialized-locs ] unit-test
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences byte-arrays namespaces accessors classes math
+math.order fry arrays combinators compiler.cfg.registers
+compiler.cfg.instructions compiler.cfg.dataflow-analysis ;
+IN: compiler.cfg.stacks.uninitialized
+
+! Uninitialized stack location analysis.
+
+! Consider the following sequence of instructions:
+! ##inc-d 2
+! _gc
+! ##replace ... D 0
+! ##replace ... D 1
+! The GC check runs before stack locations 0 and 1 have been initialized,
+! and it needs to zero them out so that GC doesn't try to trace them.
+
+<PRIVATE
+
+GENERIC: visit-insn ( insn -- )
+
+: handle-inc ( n symbol -- )
+ [
+ swap {
+ { [ dup 0 < ] [ neg short tail ] }
+ { [ dup 0 > ] [ <byte-array> prepend ] }
+ } cond
+ ] change ;
+
+M: ##inc-d visit-insn n>> ds-loc handle-inc ;
+
+M: ##inc-r visit-insn n>> rs-loc handle-inc ;
+
+ERROR: uninitialized-peek insn ;
+
+M: ##peek visit-insn
+ dup loc>> [ n>> ] [ class get ] bi ?nth 0 =
+ [ uninitialized-peek ] [ drop ] if ;
+
+M: ##replace visit-insn
+ loc>> [ n>> ] [ class get ] bi
+ 2dup length < [ [ 1 ] 2dip set-nth ] [ 2drop ] if ;
+
+M: insn visit-insn drop ;
+
+: prepare ( pair -- )
+ [ first2 [ [ clone ] [ B{ } ] if* ] bi@ ] [ B{ } B{ } ] if*
+ [ ds-loc set ] [ rs-loc set ] bi* ;
+
+: visit-block ( bb -- ) instructions>> [ visit-insn ] each ;
+
+: finish ( -- pair ) ds-loc get rs-loc get 2array ;
+
+: (join-sets) ( seq1 seq2 -- seq )
+ 2dup [ length ] bi@ max '[ _ 1 pad-tail ] bi@ [ bitand ] 2map ;
+
+: (uninitialized-locs) ( seq quot -- seq' )
+ [ dup length [ drop 0 = ] pusher [ 2each ] dip ] dip map ; inline
+
+PRIVATE>
+
+FORWARD-ANALYSIS: uninitialized
+
+M: uninitialized-analysis transfer-set ( pair bb analysis -- pair' )
+ drop [ prepare ] dip visit-block finish ;
+
+M: uninitialized-analysis join-sets ( sets analysis -- pair )
+ drop sift [ f ] [ [ ] [ [ (join-sets) ] 2map ] map-reduce ] if-empty ;
+
+: uninitialized-locs ( bb -- locs )
+ uninitialized-in dup [
+ first2
+ [ [ <ds-loc> ] (uninitialized-locs) ]
+ [ [ <rs-loc> ] (uninitialized-locs) ]
+ bi* append
+ ] when ;
\ No newline at end of file
[
V{
- T{ ##copy f V int-regs 4 V int-regs 2 }
- T{ ##sub f V int-regs 4 V int-regs 4 V int-regs 1 }
- T{ ##copy f V int-regs 1 V int-regs 4 }
+ T{ ##copy f V int-regs 4 V int-regs 1 }
+ T{ ##copy f V int-regs 1 V int-regs 2 }
+ T{ ##sub f V int-regs 1 V int-regs 1 V int-regs 4 }
}
] [
{
T{ ##sub f V int-regs 1 V int-regs 2 V int-regs 1 }
} (convert-two-operand)
] unit-test
-
-! This should never come up after coalescing
-[
- V{
- T{ ##fixnum-add f V int-regs 2 V int-regs 4 V int-regs 2 }
- } (convert-two-operand)
-] must-fail
: case-2? ( insn -- ? ) [ dst>> ] [ src2>> ] bi = ; inline
-ERROR: bad-case-2 insn ;
-
: case-2 ( insn -- )
- ! This can't work with a ##fixnum-overflow since it branches
- dup ##fixnum-overflow? [ bad-case-2 ] when
dup dst>> reg-class>> next-vreg
- [ swap src1>> emit-copy ]
- [ [ >>src1 ] [ >>dst ] bi , ]
- [ [ src2>> ] dip emit-copy ]
+ [ swap src2>> emit-copy ]
+ [ drop [ src2>> ] [ src1>> ] bi emit-copy ]
+ [ >>src2 dup dst>> >>src1 , ]
2tri ; inline
: case-3 ( insn -- )
M: insn convert-two-operand* , ;
-: (convert-two-operand) ( cfg -- cfg' )
- [ [ convert-two-operand* ] each ] V{ } make ;
+: (convert-two-operand) ( insns -- insns' )
+ dup first kill-vreg-insn? [
+ [ [ convert-two-operand* ] each ] V{ } make
+ ] unless ;
: convert-two-operand ( cfg -- cfg' )
two-operand? [ [ (convert-two-operand) ] local-optimization ] when ;
\ No newline at end of file
to predecessors>> [ dup from eq? [ drop bb ] when ] change-each
from successors>> [ dup to eq? [ drop bb ] when ] change-each ;
+: add-instructions ( bb quot -- )
+ [ instructions>> building ] dip '[
+ building get pop
+ @
+ ,
+ ] with-variable ; inline
+
: <simple-block> ( insns -- bb )
<basic-block>
swap >vector
: if-has-phis ( bb quot: ( bb -- ) -- )
[ dup has-phis? ] dip [ drop ] if ; inline
+: each-phi ( bb quot: ( ##phi -- ) -- )
+ [ instructions>> ] dip
+ '[ dup ##phi? [ @ t ] [ drop f ] if ] all? drop ; inline
+
: predecessor ( bb -- pred )
predecessors>> first ; inline
} 3 test-bb
V{
- T{ ##phi f V int-regs 3 { } }
+ T{ ##phi f V int-regs 3 H{ { 2 V int-regs 1 } { 3 V int-regs 2 } } }
T{ ##replace f V int-regs 3 D 0 }
T{ ##return }
} 4 test-bb
-4 get instructions>> first
-2 get V int-regs 1 2array
-3 get V int-regs 2 2array 2array
->>inputs drop
-
test-diamond
[ ] [
T{ ##return }
} 5 test-bb
-0 get 1 get 1vector >>successors drop
-1 get 2 get 4 get V{ } 2sequence >>successors drop
-2 get 3 get 1vector >>successors drop
-4 get 5 get 1vector >>successors drop
+0 1 edge
+1 { 2 4 } edges
+2 3 edge
+4 5 edge
[ ] [
cfg new 0 get >>entry
kernel kernel.private layouts assocs words summary arrays
combinators classes.algebra alien alien.c-types alien.structs
alien.strings alien.arrays alien.complex alien.libraries sets libc
-continuations.private fry cpu.architecture classes
+continuations.private fry cpu.architecture classes locals
source-files.errors
compiler.errors
compiler.alien
[ table>> ]
tri %write-barrier ;
+! GC checks
+: wipe-locs ( locs temp -- )
+ '[
+ _
+ [ 0 %load-immediate ]
+ [ swap [ %replace ] with each ] bi
+ ] unless-empty ;
+
+GENERIC# save-gc-root 1 ( gc-root operand temp -- )
+
+M:: spill-slot save-gc-root ( gc-root operand temp -- )
+ temp operand n>> %reload-integer
+ gc-root temp %save-gc-root ;
+
+M: object save-gc-root drop %save-gc-root ;
+
+: save-gc-roots ( gc-roots temp -- ) '[ _ save-gc-root ] assoc-each ;
+
+GENERIC# load-gc-root 1 ( gc-root operand temp -- )
+
+M:: spill-slot load-gc-root ( gc-root operand temp -- )
+ gc-root temp %load-gc-root
+ temp operand n>> %spill-integer ;
+
+M: object load-gc-root drop %load-gc-root ;
+
+: load-gc-roots ( gc-roots temp -- ) '[ _ load-gc-root ] assoc-each ;
+
M: _gc generate-insn
+ "no-gc" define-label
{
- [ temp1>> ]
- [ temp2>> ]
- [ gc-roots>> ]
- [ gc-root-count>> ]
- } cleave %gc ;
+ [ [ "no-gc" get ] dip [ temp1>> ] [ temp2>> ] bi %check-nursery ]
+ [ [ uninitialized-locs>> ] [ temp1>> ] bi wipe-locs ]
+ [ [ gc-roots>> ] [ temp1>> ] bi save-gc-roots ]
+ [ gc-root-count>> %call-gc ]
+ [ [ gc-roots>> ] [ temp1>> ] bi load-gc-roots ]
+ } cleave
+ "no-gc" resolve-label ;
M: _loop-entry generate-insn drop %loop-entry ;
math hashtables.private math.private namespaces sequences tools.test
namespaces.private slots.private sequences.private byte-arrays alien
alien.accessors layouts words definitions compiler.units io
-combinators vectors grouping make alien.c-types ;
+combinators vectors grouping make alien.c-types combinators.short-circuit
+math.order ;
QUALIFIED: namespaces.private
IN: compiler.tests.codegen
dup [ \ vector eq? ] [ drop f ] if
over rot [ drop ] [ nip ] if
] compile-call
-] unit-test
\ No newline at end of file
+] unit-test
+
+! Coalesing bug reduced from sequence-parser:take-sequence
+: coalescing-bug-1 ( a b c d -- a b c d )
+ 3dup {
+ [ 2drop 0 < ]
+ [ [ drop ] 2dip length > ]
+ [ drop > ]
+ } 3|| [ 3drop f ] [ slice boa ] if swap [ [ length ] bi@ ] 2keep ;
+
+[ 0 3 f { 1 2 3 } ] [ { 1 2 3 } -10 3 "hello" coalescing-bug-1 ] unit-test
+[ 0 3 f { 1 2 3 } ] [ { 1 2 3 } 0 7 "hello" coalescing-bug-1 ] unit-test
+[ 0 3 f { 1 2 3 } ] [ { 1 2 3 } 3 2 "hello" coalescing-bug-1 ] unit-test
+[ 2 3 T{ slice f 1 3 "hello" } { 1 2 3 } ] [ { 1 2 3 } 1 3 "hello" coalescing-bug-1 ] unit-test
+
+! Another one, found by Dan
+: coalescing-bug-2 ( a -- b )
+ dup dup 10 fixnum< [ 1 fixnum+fast ] when
+ fixnum+fast 2 fixnum*fast 2 fixnum-fast 2 fixnum*fast 2 fixnum+fast ;
+
+[ 10 ] [ 1 coalescing-bug-2 ] unit-test
+[ 86 ] [ 11 coalescing-bug-2 ] unit-test
+
+! Regression in suffix-arrays code
+: coalescing-bug-3 ( from/f to/f seq -- slice )
+ [
+ [ drop 0 or ] [ length or ] bi-curry bi*
+ [ min ] keep
+ ] keep <slice> ;
+
+[ T{ slice f 0 5 "hello" } ] [ f f "hello" coalescing-bug-3 ] unit-test
+[ T{ slice f 1 5 "hello" } ] [ 1 f "hello" coalescing-bug-3 ] unit-test
+[ T{ slice f 0 3 "hello" } ] [ f 3 "hello" coalescing-bug-3 ] unit-test
+[ T{ slice f 1 3 "hello" } ] [ 1 3 "hello" coalescing-bug-3 ] unit-test
+[ T{ slice f 3 3 "hello" } ] [ 4 3 "hello" coalescing-bug-3 ] unit-test
+[ T{ slice f 5 5 "hello" } ] [ 6 f "hello" coalescing-bug-3 ] unit-test
+
+! Reduction
+: coalescing-bug-4 ( a b c -- a b c )
+ [ [ min ] keep ] dip vector? [ 1 ] [ 2 ] if ;
+
+ [ 2 3 2 ] [ 2 3 "" coalescing-bug-4 ] unit-test
+ [ 3 3 2 ] [ 4 3 "" coalescing-bug-4 ] unit-test
+ [ 3 3 2 ] [ 4 3 "" coalescing-bug-4 ] unit-test
+ [ 2 3 1 ] [ 2 3 V{ } coalescing-bug-4 ] unit-test
+ [ 3 3 1 ] [ 4 3 V{ } coalescing-bug-4 ] unit-test
+ [ 3 3 1 ] [ 4 3 V{ } coalescing-bug-4 ] unit-test
+
+! Global stack analysis dataflow equations are wrong
+: some-word ( a -- b ) 2 + ;
+: global-dcn-bug-1 ( a b -- c d )
+ dup [ [ drop 1 ] dip ] [ [ some-word ] dip ] if
+ dup [ [ 1 fixnum+fast ] dip ] [ [ drop 1 ] dip ] if ;
+
+[ 2 t ] [ 0 t global-dcn-bug-1 ] unit-test
+[ 1 f ] [ 0 f global-dcn-bug-1 ] unit-test
\ No newline at end of file
T{ ##epilogue }
T{ ##return }
} [ clone ] map 2 test-bb
- 0 get 1 get 1vector >>successors drop
- 1 get 2 get 1vector >>successors drop
+ 0 1 edge
+ 1 2 edge
compile-test-cfg
execute( -- result ) ;
[ f ] [ [ [ [ ] [ 1 ] if ] ] final-info first infer-value ] unit-test
[ f ] [ [ [ 1 ] '[ @ ] ] final-info first infer-value ] unit-test
[ f ] [ [ dup drop ] final-info first infer-value ] unit-test
+
+! This should not hang
+[ ] [ [ [ dup call( quot -- ) ] dup call( quot -- ) ] final-info drop ] unit-test
+[ ] [ [ [ dup curry call( quot -- ) ] dup curry call( quot -- ) ] final-info drop ] unit-test
\ No newline at end of file
USING: accessors combinators combinators.private effects fry
kernel kernel.private make sequences continuations quotations
words math stack-checker stack-checker.transforms
-compiler.tree.propagation.info slots.private ;
+compiler.tree.propagation.info
+compiler.tree.propagation.inlining ;
IN: compiler.tree.propagation.call-effect
! call( and execute( have complex expansions.
: (infer-value) ( value-info -- effect )
dup class>> {
{ \ quotation [
- literal>> [ uninferable ] unless* cached-effect
- dup +unknown+ = [ uninferable ] when
+ literal>> [ uninferable ] unless*
+ dup already-inlined? [ uninferable ] when
+ cached-effect dup +unknown+ = [ uninferable ] when
] }
{ \ curry [
slots>> third (infer-value)
: (value>quot) ( value-info -- quot )
dup class>> {
- { \ quotation [ literal>> '[ drop @ ] ] }
+ { \ quotation [ literal>> dup remember-inlining '[ drop @ ] ] }
{ \ curry [
slots>> third (value>quot)
'[ [ obj>> ] [ quot>> @ ] bi ]
stack-checker.branches
compiler.tree
compiler.tree.def-use
-compiler.tree.combinators ;
+compiler.tree.combinators
+compiler.utilities ;
IN: compiler.tree.propagation.copy
! Two values are copy-equivalent if they are always identical
! Mapping from values to their canonical leader
SYMBOL: copies
-:: compress-path ( source assoc -- destination )
- [let | destination [ source assoc at ] |
- source destination = [ source ] [
- [let | destination' [ destination assoc compress-path ] |
- destination' destination = [
- destination' source assoc set-at
- ] unless
- destination'
- ]
- ] if
- ] ;
-
: resolve-copy ( copy -- val ) copies get compress-path ;
: is-copy-of ( val copy -- ) copies get set-at ;
SYMBOL: history
+: already-inlined? ( obj -- ? ) history get memq? ;
+
+: add-to-history ( obj -- ) history [ swap suffix ] change ;
+
: remember-inlining ( word -- )
[ inlining-count get inc-at ]
- [ history [ swap suffix ] change ]
+ [ add-to-history ]
bi ;
:: inline-word ( #call word -- ? )
- word history get memq? [ f ] [
+ word already-inlined? [ f ] [
#call word splicing-body [
[
word remember-inlining
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences sequences.private arrays vectors fry
-math math.order namespaces assocs ;
+math math.order namespaces assocs locals ;
IN: compiler.utilities
: flattener ( seq quot -- seq vector quot' )
[ ] [ [ [ second ] bi@ > ] most ] map-reduce ;
: penultimate ( seq -- elt ) [ length 2 - ] keep nth ;
+
+:: compress-path ( source assoc -- destination )
+ [let | destination [ source assoc at ] |
+ source destination = [ source ] [
+ [let | destination' [ destination assoc compress-path ] |
+ destination' destination = [
+ destination' source assoc set-at
+ ] unless
+ destination'
+ ]
+ ] if
+ ] ;
HOOK: %allot cpu ( dst size class temp -- )
HOOK: %write-barrier cpu ( src card# table -- )
-HOOK: %gc cpu ( temp1 temp2 live-registers live-spill-slots -- )
+
+! GC checks
+HOOK: %check-nursery cpu ( label temp1 temp2 -- )
+HOOK: %save-gc-root cpu ( gc-root register -- )
+HOOK: %load-gc-root cpu ( gc-root register -- )
+HOOK: %call-gc cpu ( gc-root-count -- )
HOOK: %prologue cpu ( n -- )
HOOK: %epilogue cpu ( n -- )
math.order math.ranges system namespaces locals layouts words
alien alien.accessors alien.c-types literals cpu.architecture
cpu.ppc.assembler cpu.ppc.assembler.backend compiler.cfg.registers
-compiler.cfg.instructions compiler.constants compiler.codegen
+compiler.cfg.instructions compiler.cfg.comparisons
compiler.codegen.fixup compiler.cfg.intrinsics
compiler.cfg.stack-frame compiler.cfg.build-stack-frame
-compiler.units ;
+compiler.units compiler.constants compiler.codegen ;
FROM: cpu.ppc.assembler => B ;
IN: cpu.ppc
: xt-save ( n -- i ) 2 cells - ;
! Next, we have the spill area as well as the FFI parameter area.
-! They overlap, since basic blocks with FFI calls will never
-! spill.
+! It is safe for them to overlap, since basic blocks with FFI calls
+! will never spill -- indeed, basic blocks with FFI calls do not
+! use vregs at all, and the FFI call is a stack analysis sync point.
+! In the future this will change and the stack frame logic will
+! need to be untangled somewhat.
+
: param@ ( n -- x ) reserved-area-size + ; inline
: param-save-size ( -- n ) 8 cells ; foldable
: local@ ( n -- x )
reserved-area-size param-save-size + + ; inline
-: spill-integer-base ( -- n )
- stack-frame get spill-counts>> double-float-regs swap at
- double-float-regs reg-size * ;
-
: spill-integer@ ( n -- offset )
- cells spill-integer-base + param@ ;
+ spill-integer-offset local@ ;
: spill-float@ ( n -- offset )
- double-float-regs reg-size * param@ ;
+ spill-float-offset local@ ;
! Some FP intrinsics need a temporary scratch area in the stack
-! frame, 8 bytes in size
+! frame, 8 bytes in size. This is in the param-save area so it
+! does not overlap with spill slots.
: scratch@ ( n -- offset )
stack-frame get total-size>>
factor-area-size -
param-save-size -
+ ;
+! GC root area
+: gc-root@ ( n -- offset )
+ gc-root-offset local@ ;
+
! Finally we have the linkage area
HOOK: lr-save os ( -- n )
M: ppc stack-frame-size ( stack-frame -- i )
- [ spill-counts>> [ swap reg-size * ] { } assoc>map sum ]
- [ params>> ]
- [ return>> ]
- tri + +
+ (stack-frame-size)
param-save-size +
reserved-area-size +
factor-area-size +
M: ppc %or-imm ORI ;
M: ppc %xor XOR ;
M: ppc %xor-imm XORI ;
+M: ppc %shl SLW ;
M: ppc %shl-imm swapd SLWI ;
+M: ppc %shr SRW ;
M: ppc %shr-imm swapd SRWI ;
+M: ppc %sar SRAW ;
M: ppc %sar-imm SRAWI ;
M: ppc %not NOT ;
-: %alien-invoke-tail ( func dll -- )
- [ scratch-reg ] 2dip %alien-global scratch-reg MTCTR BCTR ;
-
-:: exchange-regs ( r1 r2 -- )
- scratch-reg r1 MR
- r1 r2 MR
- r2 scratch-reg MR ;
-
-: ?MR ( r1 r2 -- ) 2dup = [ 2drop ] [ MR ] if ;
-
-:: move>args ( src1 src2 -- )
- {
- { [ src1 4 = ] [ 3 src2 ?MR 3 4 exchange-regs ] }
- { [ src1 3 = ] [ 4 src2 ?MR ] }
- { [ src2 3 = ] [ 4 src1 ?MR 3 4 exchange-regs ] }
- { [ src2 4 = ] [ 3 src1 ?MR ] }
- [ 3 src1 MR 4 src2 MR ]
- } cond ;
-
-: clear-xer ( -- )
+:: overflow-template ( label dst src1 src2 insn -- )
0 0 LI
- 0 MTXER ; inline
-
-:: overflow-template ( src1 src2 insn func -- )
- "no-overflow" define-label
- clear-xer
- scratch-reg src2 src1 insn call
- scratch-reg ds-reg 0 STW
- "no-overflow" get BNO
- src1 src2 move>args
- %prepare-alien-invoke
- func f %alien-invoke
- "no-overflow" resolve-label ; inline
-
-:: overflow-template-tail ( src1 src2 insn func -- )
- "overflow" define-label
- clear-xer
- scratch-reg src2 src1 insn call
- "overflow" get BO
- scratch-reg ds-reg 0 STW
- BLR
- "overflow" resolve-label
- src1 src2 move>args
- %prepare-alien-invoke
- func f %alien-invoke-tail ; inline
+ 0 MTXER
+ dst src2 src1 insn call
+ label BO ; inline
-M: ppc %fixnum-add ( src1 src2 -- )
- [ ADDO. ] "overflow_fixnum_add" overflow-template ;
+M: ppc %fixnum-add ( label dst src1 src2 -- )
+ [ ADDO. ] overflow-template ;
-M: ppc %fixnum-add-tail ( src1 src2 -- )
- [ ADDO. ] "overflow_fixnum_add" overflow-template-tail ;
+M: ppc %fixnum-sub ( label dst src1 src2 -- )
+ [ SUBFO. ] overflow-template ;
-M: ppc %fixnum-sub ( src1 src2 -- )
- [ SUBFO. ] "overflow_fixnum_subtract" overflow-template ;
-
-M: ppc %fixnum-sub-tail ( src1 src2 -- )
- [ SUBFO. ] "overflow_fixnum_subtract" overflow-template-tail ;
-
-M:: ppc %fixnum-mul ( src1 src2 temp1 temp2 -- )
- "no-overflow" define-label
- clear-xer
- temp1 src1 tag-bits get SRAWI
- temp2 temp1 src2 MULLWO.
- temp2 ds-reg 0 STW
- "no-overflow" get BNO
- src2 src2 tag-bits get SRAWI
- temp1 src2 move>args
- %prepare-alien-invoke
- "overflow_fixnum_multiply" f %alien-invoke
- "no-overflow" resolve-label ;
-
-M:: ppc %fixnum-mul-tail ( src1 src2 temp1 temp2 -- )
- "overflow" define-label
- clear-xer
- temp1 src1 tag-bits get SRAWI
- temp2 temp1 src2 MULLWO.
- "overflow" get BO
- temp2 ds-reg 0 STW
- BLR
- "overflow" resolve-label
- src2 src2 tag-bits get SRAWI
- temp1 src2 move>args
- %prepare-alien-invoke
- "overflow_fixnum_multiply" f %alien-invoke-tail ;
+M: ppc %fixnum-mul ( label dst src1 src2 -- )
+ [ MULLWO. ] overflow-template ;
: bignum@ ( n -- offset ) cells bignum tag-number - ; inline
src card# deck-bits SRWI
table scratch-reg card# STBX ;
-M:: ppc %gc ( temp1 temp2 gc-roots gc-root-count -- )
- "end" define-label
+M:: ppc %check-nursery ( label temp1 temp2 -- )
temp2 load-zone-ptr
temp1 temp2 cell LWZ
temp2 temp2 3 cells LWZ
- temp1 temp1 1024 ADDI ! add ALLOT_BUFFER_ZONE to here
- temp1 0 temp2 CMP ! is here >= end?
- "end" get BLE
+ ! add ALLOT_BUFFER_ZONE to here
+ temp1 temp1 1024 ADDI
+ ! is here >= end?
+ temp1 0 temp2 CMP
+ label BLE ;
+
+M:: ppc %save-gc-root ( gc-root register -- )
+ register 1 gc-root gc-root@ STW ;
+
+M:: ppc %load-gc-root ( gc-root register -- )
+ register 1 gc-root gc-root@ LWZ ;
+
+M:: ppc %call-gc ( gc-root-count -- )
%prepare-alien-invoke
- 0 3 LI
- 0 4 LI
- "inline_gc" f %alien-invoke
- "end" resolve-label ;
+ 3 1 gc-root-base local@ ADDI
+ gc-root-count 4 LI
+ "inline_gc" f %alien-invoke ;
M: ppc %prologue ( n -- )
0 11 LOAD32 rc-absolute-ppc-2/2 rel-this
! 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.
! 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
! 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
! 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
! 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 ;
! 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 } ;
! 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 ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel layouts system math alien.c-types sequences
-compiler.cfg.registers cpu.architecture cpu.x86.assembler cpu.x86 ;
+compiler.cfg.registers cpu.architecture cpu.x86.assembler cpu.x86
+cpu.x86.assembler.operands ;
IN: cpu.x86.64.winnt
M: int-regs param-regs drop { RCX RDX R8 R9 } ;
-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
! sse shift instructions
[ { HEX: 66 HEX: 0f HEX: 71 HEX: d0 HEX: 05 } ] [ [ XMM0 5 PSRLW ] { } make ] unit-test
+[ { HEX: 66 HEX: 0f HEX: d1 HEX: c1 } ] [ [ XMM0 XMM1 PSRLW ] { } make ] unit-test
! sse comparison instructions
[ { HEX: 66 HEX: 0f HEX: c2 HEX: c1 HEX: 02 } ] [ [ XMM0 XMM1 CMPLEPD ] { } make ] unit-test
-! 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 ;
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? ] }
: 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 ;
+
+: 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 -- )
+:: 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 ;
: 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 ;
: MAXPD ( dest src -- ) HEX: 5f HEX: 66 2-operand-rm-sse ;
: MAXSD ( dest src -- ) HEX: 5f HEX: f2 2-operand-rm-sse ;
: MAXSS ( dest src -- ) HEX: 5f HEX: f3 2-operand-rm-sse ;
+: PUNPCKLBW ( dest src -- ) HEX: 60 HEX: 66 2-operand-rm-sse ;
+: PUNPCKLWD ( dest src -- ) HEX: 61 HEX: 66 2-operand-rm-sse ;
+: PUNPCKLDQ ( dest src -- ) HEX: 62 HEX: 66 2-operand-rm-sse ;
+: PACKSSWB ( dest src -- ) HEX: 63 HEX: 66 2-operand-rm-sse ;
+: PCMPGTB ( dest src -- ) HEX: 64 HEX: 66 2-operand-rm-sse ;
+: PCMPGTW ( dest src -- ) HEX: 65 HEX: 66 2-operand-rm-sse ;
+: PCMPGTD ( dest src -- ) HEX: 66 HEX: 66 2-operand-rm-sse ;
+: PACKUSWB ( dest src -- ) HEX: 67 HEX: 66 2-operand-rm-sse ;
+: PUNPCKHBW ( dest src -- ) HEX: 68 HEX: 66 2-operand-rm-sse ;
+: PUNPCKHWD ( dest src -- ) HEX: 69 HEX: 66 2-operand-rm-sse ;
+: PUNPCKHDQ ( dest src -- ) HEX: 6a HEX: 66 2-operand-rm-sse ;
+: PACKSSDW ( dest src -- ) HEX: 6b HEX: 66 2-operand-rm-sse ;
: PUNPCKLQDQ ( dest src -- ) HEX: 6c HEX: 66 2-operand-rm-sse ;
: PUNPCKHQDQ ( dest src -- ) HEX: 6d HEX: 66 2-operand-rm-sse ;
+: MOVD ( dest src -- ) { HEX: 6e HEX: 7e } HEX: 66 2-operand-rm-mr-sse ;
: MOVDQA ( dest src -- ) { HEX: 6f HEX: 7f } HEX: 66 2-operand-rm-mr-sse ;
: MOVDQU ( dest src -- ) { HEX: 6f HEX: 7f } HEX: f3 2-operand-rm-mr-sse ;
: PSHUFD ( dest src imm -- ) HEX: 70 HEX: 66 3-operand-rm-sse ;
: PSHUFLW ( dest src imm -- ) HEX: 70 HEX: f2 3-operand-rm-sse ;
: PSHUFHW ( dest src imm -- ) HEX: 70 HEX: f3 3-operand-rm-sse ;
-: PSRLW ( dest imm -- ) BIN: 010 HEX: 71 HEX: 66 2-operand-sse-shift ;
-: PSRAW ( dest imm -- ) BIN: 100 HEX: 71 HEX: 66 2-operand-sse-shift ;
-: PSLLW ( dest imm -- ) BIN: 110 HEX: 71 HEX: 66 2-operand-sse-shift ;
-: PSRLD ( dest imm -- ) BIN: 010 HEX: 72 HEX: 66 2-operand-sse-shift ;
-: PSRAD ( dest imm -- ) BIN: 100 HEX: 72 HEX: 66 2-operand-sse-shift ;
-: PSLLD ( dest imm -- ) BIN: 110 HEX: 72 HEX: 66 2-operand-sse-shift ;
-: PSRLQ ( dest imm -- ) BIN: 010 HEX: 73 HEX: 66 2-operand-sse-shift ;
+
+: (PSRLW-imm) ( dest imm -- ) BIN: 010 HEX: 71 HEX: 66 2-operand-sse-shift ;
+: (PSRAW-imm) ( dest imm -- ) BIN: 100 HEX: 71 HEX: 66 2-operand-sse-shift ;
+: (PSLLW-imm) ( dest imm -- ) BIN: 110 HEX: 71 HEX: 66 2-operand-sse-shift ;
+: (PSRLD-imm) ( dest imm -- ) BIN: 010 HEX: 72 HEX: 66 2-operand-sse-shift ;
+: (PSRAD-imm) ( dest imm -- ) BIN: 100 HEX: 72 HEX: 66 2-operand-sse-shift ;
+: (PSLLD-imm) ( dest imm -- ) BIN: 110 HEX: 72 HEX: 66 2-operand-sse-shift ;
+: (PSRLQ-imm) ( dest imm -- ) BIN: 010 HEX: 73 HEX: 66 2-operand-sse-shift ;
+: (PSLLQ-imm) ( dest imm -- ) BIN: 110 HEX: 73 HEX: 66 2-operand-sse-shift ;
+
+: (PSRLW-reg) ( dest src -- ) HEX: d1 HEX: 66 2-operand-rm-sse ;
+: (PSRLD-reg) ( dest src -- ) HEX: d2 HEX: 66 2-operand-rm-sse ;
+: (PSRLQ-reg) ( dest src -- ) HEX: d3 HEX: 66 2-operand-rm-sse ;
+: (PSRAW-reg) ( dest src -- ) HEX: e1 HEX: 66 2-operand-rm-sse ;
+: (PSRAD-reg) ( dest src -- ) HEX: e2 HEX: 66 2-operand-rm-sse ;
+: (PSLLW-reg) ( dest src -- ) HEX: f1 HEX: 66 2-operand-rm-sse ;
+: (PSLLD-reg) ( dest src -- ) HEX: f2 HEX: 66 2-operand-rm-sse ;
+: (PSLLQ-reg) ( dest src -- ) HEX: f3 HEX: 66 2-operand-rm-sse ;
+
+: PSRLW ( dest src -- ) dup integer? [ (PSRLW-imm) ] [ (PSRLW-reg) ] if ;
+: PSRAW ( dest src -- ) dup integer? [ (PSRAW-imm) ] [ (PSRAW-reg) ] if ;
+: PSLLW ( dest src -- ) dup integer? [ (PSLLW-imm) ] [ (PSLLW-reg) ] if ;
+: PSRLD ( dest src -- ) dup integer? [ (PSRLD-imm) ] [ (PSRLD-reg) ] if ;
+: PSRAD ( dest src -- ) dup integer? [ (PSRAD-imm) ] [ (PSRAD-reg) ] if ;
+: PSLLD ( dest src -- ) dup integer? [ (PSLLD-imm) ] [ (PSLLD-reg) ] if ;
+: PSRLQ ( dest src -- ) dup integer? [ (PSRLQ-imm) ] [ (PSRLQ-reg) ] if ;
+: PSLLQ ( dest src -- ) dup integer? [ (PSLLQ-imm) ] [ (PSLLQ-reg) ] if ;
+
: PSRLDQ ( dest imm -- ) BIN: 011 HEX: 73 HEX: 66 2-operand-sse-shift ;
-: PSLLQ ( dest imm -- ) BIN: 110 HEX: 73 HEX: 66 2-operand-sse-shift ;
: PSLLDQ ( dest imm -- ) BIN: 111 HEX: 73 HEX: 66 2-operand-sse-shift ;
: PCMPEQB ( dest src -- ) HEX: 74 HEX: 66 2-operand-rm-sse ;
: HSUBPD ( dest src -- ) HEX: 7d HEX: 66 2-operand-rm-sse ;
: HSUBPS ( dest src -- ) HEX: 7d HEX: f2 2-operand-rm-sse ;
+: FXSAVE ( dest -- ) { BIN: 000 f { HEX: 0f HEX: ae } } 1-operand ;
+: FXRSTOR ( src -- ) { BIN: 001 f { HEX: 0f HEX: ae } } 1-operand ;
: LDMXCSR ( src -- ) { BIN: 010 f { HEX: 0f HEX: ae } } 1-operand ;
: STMXCSR ( dest -- ) { BIN: 011 f { HEX: 0f HEX: ae } } 1-operand ;
: LFENCE ( -- ) HEX: 0f , HEX: ae , OCT: 350 , ;
: MFENCE ( -- ) HEX: 0f , HEX: ae , OCT: 360 , ;
: SFENCE ( -- ) HEX: 0f , HEX: ae , OCT: 370 , ;
+: CLFLUSH ( dest -- ) { BIN: 111 f { HEX: 0f HEX: ae } } 1-operand ;
: POPCNT ( dest src -- ) HEX: b8 HEX: f3 2-operand-rm-sse ;
: ADDSUBPD ( dest src -- ) HEX: d0 HEX: 66 2-operand-rm-sse ;
: ADDSUBPS ( dest src -- ) HEX: d0 HEX: f2 2-operand-rm-sse ;
: PADDQ ( dest src -- ) HEX: d4 HEX: 66 2-operand-rm-sse ;
+: PMULLW ( dest src -- ) HEX: d5 HEX: 66 2-operand-rm-sse ;
+: PMOVMSKB ( dest src -- ) HEX: d7 HEX: 66 2-operand-rm-sse ;
+: PSUBUSB ( dest src -- ) HEX: d8 HEX: 66 2-operand-rm-sse ;
+: PSUBUSW ( dest src -- ) HEX: d9 HEX: 66 2-operand-rm-sse ;
: PMINUB ( dest src -- ) HEX: da HEX: 66 2-operand-rm-sse ;
+: PAND ( dest src -- ) HEX: db HEX: 66 2-operand-rm-sse ;
+: PADDUSB ( dest src -- ) HEX: dc HEX: 66 2-operand-rm-sse ;
+: PADDUSW ( dest src -- ) HEX: dd HEX: 66 2-operand-rm-sse ;
: PMAXUB ( dest src -- ) HEX: de HEX: 66 2-operand-rm-sse ;
+: PANDN ( dest src -- ) HEX: df HEX: 66 2-operand-rm-sse ;
: PAVGB ( dest src -- ) HEX: e0 HEX: 66 2-operand-rm-sse ;
: PAVGW ( dest src -- ) HEX: e3 HEX: 66 2-operand-rm-sse ;
: PMULHUW ( dest src -- ) HEX: e4 HEX: 66 2-operand-rm-sse ;
+: PMULHW ( dest src -- ) HEX: e5 HEX: 66 2-operand-rm-sse ;
: CVTTPD2DQ ( dest src -- ) HEX: e6 HEX: 66 2-operand-rm-sse ;
: CVTPD2DQ ( dest src -- ) HEX: e6 HEX: f2 2-operand-rm-sse ;
: CVTDQ2PD ( dest src -- ) HEX: e6 HEX: f3 2-operand-rm-sse ;
: MOVNTDQ ( dest src -- ) HEX: e7 HEX: 66 2-operand-mr-sse ;
+: PSUBSB ( dest src -- ) HEX: e8 HEX: 66 2-operand-rm-sse ;
+: PSUBSW ( dest src -- ) HEX: e9 HEX: 66 2-operand-rm-sse ;
: PMINSW ( dest src -- ) HEX: ea HEX: 66 2-operand-rm-sse ;
+: POR ( dest src -- ) HEX: eb HEX: 66 2-operand-rm-sse ;
+: PADDSB ( dest src -- ) HEX: ec HEX: 66 2-operand-rm-sse ;
+: PADDSW ( dest src -- ) HEX: ed HEX: 66 2-operand-rm-sse ;
: PMAXSW ( dest src -- ) HEX: ee HEX: 66 2-operand-rm-sse ;
+: PXOR ( dest src -- ) HEX: ef HEX: 66 2-operand-rm-sse ;
: LDDQU ( dest src -- ) HEX: f0 HEX: f2 2-operand-rm-sse ;
: PMULUDQ ( dest src -- ) HEX: f4 HEX: 66 2-operand-rm-sse ;
+: PMADDWD ( dest src -- ) HEX: f5 HEX: 66 2-operand-rm-sse ;
: PSADBW ( dest src -- ) HEX: f6 HEX: 66 2-operand-rm-sse ;
-
: MASKMOVDQU ( dest src -- ) HEX: f7 HEX: 66 2-operand-rm-sse ;
-
+: PSUBB ( dest src -- ) HEX: f8 HEX: 66 2-operand-rm-sse ;
+: PSUBW ( dest src -- ) HEX: f9 HEX: 66 2-operand-rm-sse ;
+: PSUBD ( dest src -- ) HEX: fa HEX: 66 2-operand-rm-sse ;
: PSUBQ ( dest src -- ) HEX: fb HEX: 66 2-operand-rm-sse ;
+: PADDB ( dest src -- ) HEX: fc HEX: 66 2-operand-rm-sse ;
+: PADDW ( dest src -- ) HEX: fd HEX: 66 2-operand-rm-sse ;
+: PADDD ( dest src -- ) HEX: fe HEX: 66 2-operand-rm-sse ;
! x86-64 branch prediction hints
--- /dev/null
+! 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 ;
\ No newline at end of file
-! 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 ;
! 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
! 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
"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 }
-
- { RAX RAX }
- { RCX RCX }
- { RDX RDX }
- { RBX RBX }
- { RSP RSP }
- { RBP RBP }
- { RSI RSP }
- { RDI RDI }
- } at ; inline
-
-: 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
-
-: small-reg-2 ( reg -- reg' )
- small-reg-4 H{
- { EAX AX }
- { ECX CX }
- { EDX DX }
- { EBX BX }
- { ESP SP }
- { EBP BP }
- { ESI SI }
- { EDI DI }
- } at ; inline
-
-: small-reg-1 ( reg -- reg' )
- small-reg-4 {
- { EAX AL }
- { ECX CL }
- { EDX DL }
- { EBX BL }
- } at ; inline
-
-: small-reg ( reg size -- reg' )
- {
- { 1 [ small-reg-1 ] }
- { 2 [ small-reg-2 ] }
- { 4 [ small-reg-4 ] }
- { 8 [ small-reg-8 ] }
- } case ;
+! 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.
-HOOK: small-regs cpu ( -- regs )
+HOOK: has-small-reg? cpu ( reg size -- ? )
-M: x86.32 small-regs { EAX ECX EDX EBX } ;
-M: x86.64 small-regs { RAX RCX RDX RBX } ;
+CONSTANT: have-byte-regs { EAX ECX EDX EBX }
-HOOK: small-reg-native cpu ( reg -- reg' )
+M: x86.32 has-small-reg?
+ {
+ { 8 [ have-byte-regs memq? ] }
+ { 16 [ drop t ] }
+ { 32 [ drop t ] }
+ } case ;
-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
-: shift-count? ( reg -- ? ) { ECX RCX } memq? ;
-
-:: emit-shift ( dst src1 src2 quot -- )
- src2 shift-count? [
- dst CL quot call
- ] [
- dst shift-count? [
- dst src2 XCHG
- src2 CL quot call
- dst src2 XCHG
- ] [
- ECX small-reg-native [
- CL src2 MOV
- drop dst CL quot call
- ] with-save/restore
- ] if
- ] if ; inline
-
-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 -- )
+ ! We request a small-reg of size 8 since those of size 16 are
+ ! a superset.
"end" define-label
- dst { src index temp } [| new-dst |
+ 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 1 small-reg temp string-offset [+] MOV
- new-dst new-dst 1 small-reg MOVZX
+ 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
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 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
] with-small-register ;
M:: x86 %set-string-nth-fast ( ch str index temp -- )
- ch { index str temp } [| new-ch |
+ ch { index str temp } 8 [| new-ch |
new-ch ch ?MOV
temp str index [+] LEA
- temp string-offset [+] new-ch 1 small-reg MOV
+ temp string-offset [+] new-ch 8-bit-version-of MOV
] with-small-register ;
:: %alien-integer-getter ( dst src size quot -- )
- dst { src } [| new-dst |
- new-dst dup size small-reg dup src [] MOV
+ 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 1 %alien-unsigned-getter ;
-M: x86 %alien-unsigned-2 2 %alien-unsigned-getter ;
+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 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-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 } [| new-value |
+ value { ptr } size [| new-value |
new-value value ?MOV
- ptr [] new-value size small-reg MOV
+ ptr [] new-value size n-bit-version-of 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-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 -- )
+ src2 shift-count? [
+ dst CL quot call
+ ] [
+ dst shift-count? [
+ dst src2 XCHG
+ src2 CL quot call
+ dst src2 XCHG
+ ] [
+ ECX native-version-of [
+ CL src2 MOV
+ drop dst CL quot call
+ ] with-save/restore
+ ] if
+ ] if ; inline
+
+M: x86 %shl [ SHL ] emit-shift ;
+M: x86 %shr [ SHR ] emit-shift ;
+M: x86 %sar [ SAR ] emit-shift ;
+
: load-zone-ptr ( reg -- )
#! Load pointer to start of zone array
0 MOV "nursery" f rc-absolute-cell rel-dlsym ;
table table [] MOV
table card# [+] card-mark <byte> MOV ;
-:: check-nursery ( temp1 temp2 -- )
+M:: x86 %check-nursery ( label temp1 temp2 -- )
temp1 load-zone-ptr
temp2 temp1 cell [+] MOV
temp2 1024 ADD
temp1 temp1 3 cells [+] MOV
- temp2 temp1 CMP ;
-
-GENERIC# save-gc-root 1 ( gc-root operand temp -- )
-
-M:: spill-slot save-gc-root ( gc-root spill-slot temp -- )
- temp spill-slot n>> spill-integer@ MOV
- gc-root gc-root@ temp MOV ;
+ temp2 temp1 CMP
+ label JLE ;
-M:: word save-gc-root ( gc-root register temp -- )
- gc-root gc-root@ register MOV ;
+M: x86 %save-gc-root ( gc-root register -- ) [ gc-root@ ] dip MOV ;
-: save-gc-roots ( gc-roots temp -- )
- '[ _ save-gc-root ] assoc-each ;
+M: x86 %load-gc-root ( gc-root register -- ) swap gc-root@ MOV ;
-GENERIC# load-gc-root 1 ( gc-root operand temp -- )
-
-M:: spill-slot load-gc-root ( gc-root spill-slot temp -- )
- temp gc-root gc-root@ MOV
- spill-slot n>> spill-integer@ temp MOV ;
-
-M:: word load-gc-root ( gc-root register temp -- )
- register gc-root gc-root@ MOV ;
-
-: load-gc-roots ( gc-roots temp -- )
- '[ _ load-gc-root ] assoc-each ;
-
-:: call-gc ( gc-root-count -- )
+M:: x86 %call-gc ( gc-root-count -- )
! Pass pointer to start of GC roots as first parameter
param-reg-1 gc-root-base param@ LEA
! Pass number of roots as second parameter
%prepare-alien-invoke
"inline_gc" f %alien-invoke ;
-M:: x86 %gc ( temp1 temp2 gc-roots gc-root-count -- )
- "end" define-label
- temp1 temp2 check-nursery
- "end" get JLE
- gc-roots temp1 save-gc-roots
- gc-root-count call-gc
- gc-roots temp1 load-gc-roots
- "end" resolve-label ;
-
M: x86 %alien-global
[ 0 MOV ] 2dip rc-absolute-cell rel-dlsym ;
] each
: sort-entries ( entries -- entries' )
- [ [ key>> ] compare ] sort ;
+ [ key>> ] sort-with ;
: delete-test ( n -- obj1 obj2 )
[
dup topic>filename utf8 [ help>html write-xml ] with-file-writer ;
: all-vocabs-really ( -- seq )
- all-vocabs >hashtable f over delete-at no-roots remove-redundant-prefixes ;
+ all-vocabs-recursive >hashtable f over delete-at no-roots remove-redundant-prefixes ;
: all-topics ( -- topics )
[
load-index swap >lower
'[ [ drop _ ] dip >lower subseq? ] assoc-filter
[ swap result boa ] { } assoc>map
- [ [ title>> ] compare ] sort ;
+ [ title>> ] sort-with ;
: article-apropos ( string -- results )
"articles.idx" offline-apropos ;
array>> [ value ] map ;\r
\r
: <interval-map> ( specification -- map )\r
- all-intervals [ [ first second ] compare ] sort\r
+ all-intervals [ first second ] sort-with\r
>intervals ensure-disjoint interval-map boa ;\r
\r
: <interval-set> ( specification -- map )\r
drop
[ downward-slices ]
[ stable-slices ]
- [ upward-slices ] tri 3append [ [ from>> ] compare ] sort
+ [ upward-slices ] tri 3append [ from>> ] sort-with
]
} case ;
: <operations-menu> ( target hook -- menu )
over object-operations
[ primary-operation? ] partition
- [ reverse ] [ [ [ command-name ] compare ] sort ] bi*
+ [ reverse ] [ [ command-name ] sort-with ] bi*
{ ---- } glue <commands-menu> ;
: show-operations-menu ( gadget target hook -- )
make-mirror [ <slot-description> ] { } assoc>map ;
M: hashtable make-slot-descriptions
- call-next-method [ [ key-string>> ] compare ] sort ;
+ call-next-method [ key-string>> ] sort-with ;
: <inspector-table> ( model -- table )
[ make-slot-descriptions ] <arrow> inspector-renderer <table>
<PRIVATE
: sort-vocabs ( seq -- seq' )
- [ [ vocab-name ] compare ] sort ;
+ [ vocab-name ] sort-with ;
: pprint-using ( seq -- )
[ "syntax" vocab = not ] filter
[ 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
\ No newline at end of file
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
[ B{ CHAR: \n } join ] dip checksum-bytes ;
: checksum-file ( path checksum -- value )
- #! normalize-path (file-reader) is equivalen to
+ #! normalize-path (file-reader) is equivalent to
#! binary <file-reader>. We use the lower-level form
#! so that we can move io.encodings.binary to basis/.
[ normalize-path (file-reader) ] dip checksum-stream ;
[ "Topological sort failed" throw ] unless* ;\r
\r
: sort-classes ( seq -- newseq )\r
- [ [ name>> ] compare ] sort >vector\r
+ [ name>> ] sort-with >vector\r
[ dup empty? not ]\r
[ dup largest-class [ over delete-nth ] dip ]\r
produce nip ;\r
"You can ask a class for its superclass:"
{ $subsection superclass }
{ $subsection superclasses }
+{ $subsection subclass-of? }
"Class predicates can be used to test instances directly:"
{ $subsection "class-predicates" }
"There is a universal class which all objects are an instance of, and an empty class with no instances:"
}
} ;
-{ superclass superclasses } related-words
+HELP: subclass-of?
+{ $values
+ { "class" class }
+ { "superclass" class }
+ { "?" boolean }
+}
+{ $description "Outputs a boolean value indicating whether " { $snippet "class" } " is at any level a subclass of " { $snippet "superclass" } "." }
+{ $examples
+ { $example "USING: classes classes.tuple prettyprint words ;"
+ "tuple-class \\ class subclass-of? ."
+ "t"
+ }
+} ;
+
+{ superclass superclasses subclass-of? } related-words
HELP: members
{ $values { "class" class } { "seq" "a sequence of union members, or " { $link f } } }
: superclasses ( class -- supers )
[ superclass ] follow reverse ;
+: subclass-of? ( class superclass -- ? )
+ swap superclasses member? ;
+
: members ( class -- seq )
#! Output f for non-classes to work with algebra code
dup class? [ "members" word-prop ] [ drop f ] if ;
{ bi* tri* spread } related-words
+HELP: to-fixed-point
+{ $values { "object" object } { "quot" { $quotation "( object(n) -- object(n+1) )" } } { "object(n)" object } }
+{ $description "Applies the quotation repeatedly with " { $snippet "object" } " as the initial input until the output of the quotation equals the input." }
+{ $examples
+ { $example
+ "USING: combinators kernel math prettyprint sequences ;"
+ "IN: scratchpad"
+ ": flatten ( sequence -- sequence' )"
+ " \"flatten\" over index"
+ " [ [ 1 + swap nth ] [ nip dup 2 + ] [ drop ] 2tri replace-slice ] when* ;"
+ ""
+ "{ \"flatten\" { 1 { 2 3 } \"flatten\" { 4 5 } { 6 } } } [ flatten ] to-fixed-point ."
+ "{ 1 { 2 3 } 4 5 { 6 } }"
+ }
+} ;
+
HELP: alist>quot
{ $values { "default" "a quotation" } { "assoc" "a sequence of quotation pairs" } { "quot" "a new quotation" } }
{ $description "Constructs a quotation which calls the first quotation in each pair of " { $snippet "assoc" } " until one of them outputs a true value, and then calls the second quotation in the corresponding pair. Quotations are called in reverse order, and if no quotation outputs a true value then " { $snippet "default" } " is called." }
] if ;
: <buckets> ( initial length -- array )
- next-power-of-2 swap [ nip clone ] curry map ;
+ next-power-of-2 iota swap [ nip clone ] curry map ;
: distribute-buckets ( alist initial quot -- buckets )
swapd [ [ dup first ] dip call 2array ] curry map
dup assoc-size 1 eq?
[ assoc-hashcode ] [ nip assoc-size ] if
] recursive-hashcode ;
+
+: to-fixed-point ( object quot: ( object(n) -- object(n+1) ) -- object(n) )
+ [ keep over = ] keep [ to-fixed-point ] curry unless ; inline recursive
default get <array> [ <enum> swap update ] keep ;
: lo-tag-number ( class -- n )
- "type" word-prop dup num-tags get member?
+ "type" word-prop dup num-tags get iota member?
[ drop object tag-number ] unless ;
M: tag-dispatch-engine compile-engine
: nth-byte ( x n -- b ) -8 * shift mask-byte ; inline
-: >le ( x n -- byte-array ) [ nth-byte ] with B{ } map-as ;
+: >le ( x n -- byte-array ) iota [ nth-byte ] with B{ } map-as ;
: >be ( x n -- byte-array ) >le dup reverse-here ;
: d>w/w ( d -- w1 w2 )
{ $example "USING: io.pathnames prettyprint ;" "\"/usr/libexec/awk/\" file-name ." "\"awk\"" }
} ;
+HELP: file-extension
+{ $values { "path" "a pathname string" } { "extension" string } }
+{ $description "Outputs the extension of " { $snippet "path" } ", or " { $link f } " if the filename has no extension." }
+{ $examples
+ { $example "USING: io.pathnames prettyprint ;" "\"/usr/bin/gcc\" file-extension ." "f" }
+ { $example "USING: io.pathnames prettyprint ;" "\"/home/csi/gui.vbs\" file-extension ." "\"vbs\"" }
+} ;
+
+HELP: file-stem
+{ $values { "path" "a pathname string" } { "stem" string } }
+{ $description "Outputs the " { $link file-name } " of " { $snippet "filename" } " with the file extension removed, if any." }
+{ $examples
+ { $example "USING: io.pathnames prettyprint ;" "\"/usr/bin/gcc\" file-stem ." "\"gcc\"" }
+ { $example "USING: io.pathnames prettyprint ;" "\"/home/csi/gui.vbs\" file-stem ." "\"gui\"" }
+} ;
+
+{ file-name file-stem file-extension } related-words
+
HELP: path-components
{ $values { "path" "a pathnames string" } { "seq" sequence } }
{ $description "Splits a pathname on the " { $link path-separator } " into its its component strings." } ;
"Pathname manipulation:"
{ $subsection parent-directory }
{ $subsection file-name }
+{ $subsection file-stem }
+{ $subsection file-extension }
{ $subsection last-path-separator }
{ $subsection path-components }
{ $subsection prepend-path }
] if
] unless ;
-: file-extension ( filename -- extension )
+: file-stem ( path -- stem )
+ file-name "." split1-last drop ;
+
+: file-extension ( path -- extension )
file-name "." split1-last nip ;
: path-components ( path -- seq )
: make ( quot exemplar -- seq )
[
[
- 1024 swap new-resizable [
+ 100 swap new-resizable [
building set call
] keep
] keep like
3tri ;
: reverse-here ( seq -- )
- [ length 2/ ] [ length ] [ ] tri
+ [ length 2/ iota ] [ length ] [ ] tri
[ [ over - 1 - ] dip exchange-unsafe ] 2curry each ;
: reverse ( seq -- newseq )
<PRIVATE
: (start) ( subseq seq n -- subseq seq ? )
- pick length [
+ pick length iota [
[ 3dup ] dip [ + swap nth-unsafe ] keep rot nth-unsafe =
] all? nip ; inline
PRIVATE>
: start* ( subseq seq n -- i )
- pick length pick length swap - 1 +
+ pick length pick length swap - 1 + iota
[ (start) ] find-from
swap [ 3drop ] dip ;
[ drop define ]
3bi ;
-: reader-quot ( slot-spec -- quot )
- [
+GENERIC# reader-quot 1 ( class slot-spec -- quot )
+
+M: object reader-quot
+ nip [
dup offset>> ,
\ slot ,
dup class>> object bootstrap-word eq?
: define-reader ( class slot-spec -- )
[ nip name>> define-reader-generic ]
[
- [ name>> reader-word ] [ reader-quot ] [ reader-props ] tri
- define-typecheck
+ {
+ [ drop ]
+ [ nip name>> reader-word ]
+ [ reader-quot ]
+ [ nip reader-props ]
+ } 2cleave define-typecheck
] 2bi ;
: writer-word ( name -- word )
: writer-quot/fixnum ( slot-spec -- )
[ [ >fixnum ] dip ] % writer-quot/check ;
-: writer-quot ( slot-spec -- quot )
- [
+GENERIC# writer-quot 1 ( class slot-spec -- quot )
+
+M: object writer-quot
+ nip [
{
{ [ dup class>> object bootstrap-word eq? ] [ writer-quot/object ] }
{ [ dup class>> "coercer" word-prop ] [ writer-quot/coerce ] }
: define-writer ( class slot-spec -- )
[ nip name>> define-writer-generic ] [
- [ name>> writer-word ] [ writer-quot ] [ writer-props ] tri
- define-typecheck
+ {
+ [ drop ]
+ [ nip name>> writer-word ]
+ [ writer-quot ]
+ [ nip writer-props ]
+ } 2cleave define-typecheck
] 2bi ;
: setter-word ( name -- word )
"Sorting a sequence with a custom comparator:"
{ $subsection sort }
"Sorting a sequence with common comparators:"
+{ $subsection sort-with }
+{ $subsection inv-sort-with }
{ $subsection natural-sort }
{ $subsection sort-keys }
{ $subsection sort-values } ;
HELP: sort
{ $values { "seq" "a sequence" } { "quot" { $quotation "( obj1 obj2 -- <=> )" } } { "sortedseq" "a new sorted sequence" } }
-{ $description "Sorts the elements into a new array using a stable sort." }
+{ $description "Sorts the elements of " { $snippet "seq" } " into a new array using a stable sort." }
{ $notes "The algorithm used is the merge sort." } ;
+HELP: sort-with
+{ $values { "seq" "a sequence" } { "quot" { $quotation "( object -- key )" } } { "sortedseq" "a new sorted sequence" } }
+{ $description "Sorts the elements of " { $snippet "seq" } " by applying " { $link compare } " with " { $snippet "quot" } " to each pair of elements in the sequence." } ;
+
+HELP: inv-sort-with
+{ $values { "seq" "a sequence" } { "quot" { $quotation "( object -- key )" } } { "sortedseq" "a new sorted sequence" } }
+{ $description "Sorts the elements of " { $snippet "seq" } " by applying " { $link compare } " with " { $snippet "quot" } " to each pair of elements in the sequence and inverting the results." } ;
+
HELP: sort-keys
{ $values { "seq" "an alist" } { "sortedseq" "a new sorted sequence" } }
-{ $description "Sorts the elements comparing first elements of pairs using the " { $link <=> } " word." } ;
+{ $description "Sorts the elements of " { $snippet "seq" } " comparing first elements of pairs using the " { $link <=> } " word." } ;
HELP: sort-values
{ $values { "seq" "an alist" } { "sortedseq" "a new sorted sequence" } }
-{ $description "Sorts the elements comparing second elements of pairs using the " { $link <=> } " word." } ;
+{ $description "Sorts the elements of " { $snippet "seq" } " comparing second elements of pairs using the " { $link <=> } " word." } ;
HELP: natural-sort
{ $values { "seq" "a sequence of real numbers" } { "sortedseq" "a new sorted sequence" } }
{ $values { "seq" "a sequence" } { "n" integer } }
{ $description "Outputs the index of the midpoint of " { $snippet "seq" } "." } ;
-{ <=> compare natural-sort sort-keys sort-values } related-words
+{ <=> compare natural-sort sort-with inv-sort-with sort-keys sort-values } related-words
: natural-sort ( seq -- sortedseq ) [ <=> ] sort ;
-: sort-keys ( seq -- sortedseq ) [ [ first ] compare ] sort ;
+: sort-with ( seq quot -- sortedseq )
+ [ compare ] curry sort ; inline
+: inv-sort-with ( seq quot -- sortedseq )
+ [ compare invert-comparison ] curry sort ; inline
-: sort-values ( seq -- sortedseq ) [ [ second ] compare ] sort ;
+: sort-keys ( seq -- sortedseq ) [ first ] sort-with ;
+
+: sort-values ( seq -- sortedseq ) [ second ] sort-with ;
: sort-pair ( a b -- c d ) 2dup after? [ swap ] when ;
TUPLE: source-file-error error asset file line# ;
: sort-errors ( errors -- alist )
- [ [ [ line#>> ] compare ] sort ] { } assoc-map-as sort-keys ;
+ [ [ line#>> ] sort-with ] { } assoc-map-as sort-keys ;
: group-by-source-file ( errors -- assoc )
H{ } clone [ [ push-at ] curry [ dup file>> ] prepose each ] keep ;
"C-LIBRARY: exlib"
""
"C-INCLUDE: <stdio.h>"
+ "C-INCLUDE: <stdlib.h>"
"CM-FUNCTION: char* sum_diff ( const-int a, const-int b, int* x, int* y )"
" *x = a + b;"
" *y = a - b;"
! http://crazybob.org/BeustSequence.java.html
:: (count-numbers) ( remaining first value used max listener: ( -- ) -- ? )
- 10 first - [| i |
+ 10 first - iota [| i |
[let* | digit [ i first + ]
mask [ digit 2^ ]
value' [ i value + ] |
] any? ; inline recursive
:: count-numbers ( max listener -- )
- 10 [ 1+ 1 1 0 max listener (count-numbers) ] any? drop ;
+ 10 iota [ 1+ 1 1 0 max listener (count-numbers) ] any? drop ;
inline
:: beust ( -- )
[ 1 { { 1 0 } { 0 1 } } ] dip 0 0 (pidigits) ;
: pidigits-main ( -- )
- 10000 pidigits ;
+ 2000 pidigits ;
MAIN: pidigits-main
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors c.lexer kernel sequence-parser tools.test ;
+IN: c.lexer.tests
+
+[ 36 ]
+[
+ " //jofiejoe\n //eoieow\n/*asdf*/\n "
+ <sequence-parser> skip-whitespace/comments n>>
+] unit-test
+
+[ f "33asdf" ]
+[ "33asdf" <sequence-parser> [ take-c-identifier ] [ take-rest ] bi ] unit-test
+
+[ "asdf" ]
+[ "asdf" <sequence-parser> take-c-identifier ] unit-test
+
+[ "_asdf" ]
+[ "_asdf" <sequence-parser> take-c-identifier ] unit-test
+
+[ "_asdf400" ]
+[ "_asdf400" <sequence-parser> take-c-identifier ] unit-test
+
+[ "asdfasdf" ] [
+ "/*asdfasdf*/" <sequence-parser> take-c-comment
+] unit-test
+
+[ "k" ] [
+ "/*asdfasdf*/k" <sequence-parser> [ take-c-comment drop ] [ take-rest ] bi
+] unit-test
+
+[ "omg" ] [
+ "//asdfasdf\nomg" <sequence-parser>
+ [ take-c++-comment drop ] [ take-rest ] bi
+] unit-test
+
+[ "omg" ] [
+ "omg" <sequence-parser>
+ [ take-c++-comment drop ] [ take-rest ] bi
+] unit-test
+
+[ "/*asdfasdf" ] [
+ "/*asdfasdf" <sequence-parser> [ take-c-comment drop ] [ take-rest ] bi
+] unit-test
+
+[ "asdf" "eoieoei" ] [
+ "//asdf\neoieoei" <sequence-parser>
+ [ take-c++-comment ] [ take-rest ] bi
+] unit-test
+
+[ f ]
+[
+ "\"abc\" asdf" <sequence-parser>
+ [ CHAR: \ CHAR: " take-quoted-string drop ] [ "asdf" take-sequence ] bi
+] unit-test
+
+[ "abc\\\"def" ]
+[
+ "\"abc\\\"def\" asdf" <sequence-parser>
+ CHAR: \ CHAR: " take-quoted-string
+] unit-test
+
+[ "asdf" ]
+[
+ "\"abc\" asdf" <sequence-parser>
+ [ CHAR: \ CHAR: " take-quoted-string drop ]
+ [ skip-whitespace "asdf" take-sequence ] bi
+] unit-test
+
+[ f ]
+[
+ "\"abc asdf" <sequence-parser>
+ CHAR: \ CHAR: " take-quoted-string
+] unit-test
+
+[ "\"abc" ]
+[
+ "\"abc asdf" <sequence-parser>
+ [ CHAR: \ CHAR: " take-quoted-string drop ]
+ [ "\"abc" take-sequence ] bi
+] unit-test
+
+[ "c" ]
+[ "c" <sequence-parser> take-token ] unit-test
+
+[ f ]
+[ "" <sequence-parser> take-token ] unit-test
+
+[ "abcd e \\\"f g" ]
+[ "\"abcd e \\\"f g\"" <sequence-parser> CHAR: \ CHAR: " take-token* ] unit-test
+
+[ "123" ]
+[ "123jjj" <sequence-parser> take-c-integer ] unit-test
+
+[ "123uLL" ]
+[ "123uLL" <sequence-parser> take-c-integer ] unit-test
+
+[ "123ull" ]
+[ "123ull" <sequence-parser> take-c-integer ] unit-test
+
+[ "123u" ]
+[ "123u" <sequence-parser> take-c-integer ] unit-test
+
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors combinators combinators.short-circuit
+generalizations kernel locals math.order math.ranges
+sequence-parser sequences sorting.functor sorting.slots
+unicode.categories ;
+IN: c.lexer
+
+: take-c-comment ( sequence-parser -- seq/f )
+ [
+ dup "/*" take-sequence [
+ "*/" take-until-sequence*
+ ] [
+ drop f
+ ] if
+ ] with-sequence-parser ;
+
+: take-c++-comment ( sequence-parser -- seq/f )
+ [
+ dup "//" take-sequence [
+ [
+ [
+ { [ current CHAR: \n = ] [ sequence-parse-end? ] } 1||
+ ] take-until
+ ] [
+ advance drop
+ ] bi
+ ] [
+ drop f
+ ] if
+ ] with-sequence-parser ;
+
+: skip-whitespace/comments ( sequence-parser -- sequence-parser )
+ skip-whitespace-eol
+ {
+ { [ dup take-c-comment ] [ skip-whitespace/comments ] }
+ { [ dup take-c++-comment ] [ skip-whitespace/comments ] }
+ [ ]
+ } cond ;
+
+: take-define-identifier ( sequence-parser -- string )
+ skip-whitespace/comments
+ [ current { [ blank? ] [ CHAR: ( = ] } 1|| ] take-until ;
+
+:: take-quoted-string ( sequence-parser escape-char quote-char -- string )
+ sequence-parser n>> :> start-n
+ sequence-parser advance
+ [
+ {
+ [ { [ previous escape-char = ] [ current quote-char = ] } 1&& ]
+ [ current quote-char = not ]
+ } 1||
+ ] take-while :> string
+ sequence-parser current quote-char = [
+ sequence-parser advance* string
+ ] [
+ start-n sequence-parser (>>n) f
+ ] if ;
+
+: (take-token) ( sequence-parser -- string )
+ skip-whitespace [ current { [ blank? ] [ f = ] } 1|| ] take-until ;
+
+:: take-token* ( sequence-parser escape-char quote-char -- string/f )
+ sequence-parser skip-whitespace
+ dup current {
+ { quote-char [ escape-char quote-char take-quoted-string ] }
+ { f [ drop f ] }
+ [ drop (take-token) ]
+ } case ;
+
+: take-token ( sequence-parser -- string/f )
+ CHAR: \ CHAR: " take-token* ;
+
+: c-identifier-begin? ( ch -- ? )
+ CHAR: a CHAR: z [a,b]
+ CHAR: A CHAR: Z [a,b]
+ { CHAR: _ } 3append member? ;
+
+: c-identifier-ch? ( ch -- ? )
+ CHAR: a CHAR: z [a,b]
+ CHAR: A CHAR: Z [a,b]
+ CHAR: 0 CHAR: 9 [a,b]
+ { CHAR: _ } 4 nappend member? ;
+
+: (take-c-identifier) ( sequence-parser -- string/f )
+ dup current c-identifier-begin? [
+ [ current c-identifier-ch? ] take-while
+ ] [
+ drop f
+ ] if ;
+
+: take-c-identifier ( sequence-parser -- string/f )
+ [ (take-c-identifier) ] with-sequence-parser ;
+
+<< "length" [ length ] define-sorting >>
+
+: sort-tokens ( seq -- seq' )
+ { length>=< <=> } sort-by ;
+
+: take-c-integer ( sequence-parser -- string/f )
+ [
+ dup take-integer [
+ swap
+ { "ull" "uLL" "Ull" "ULL" "ll" "LL" "l" "L" "u" "U" }
+ take-longest [ append ] when*
+ ] [
+ drop f
+ ] if*
+ ] with-sequence-parser ;
+
+CONSTANT: c-punctuators
+ {
+ "[" "]" "(" ")" "{" "}" "." "->"
+ "++" "--" "&" "*" "+" "-" "~" "!"
+ "/" "%" "<<" ">>" "<" ">" "<=" ">=" "==" "!=" "^" "|" "&&" "||"
+ "?" ":" ";" "..."
+ "=" "*=" "/=" "%=" "+=" "-=" "<<=" ">>=" "&=" "^=" "|="
+ "," "#" "##"
+ "<:" ":>" "<%" "%>" "%:" "%:%:"
+ }
+
+: take-c-punctuator ( sequence-parser -- string/f )
+ c-punctuators take-longest ;
io.streams.string kernel combinators accessors io.pathnames
fry sequences arrays locals namespaces io.directories
assocs math splitting make unicode.categories
-combinators.short-circuit ;
+combinators.short-circuit c.lexer ;
IN: c.preprocessor
: initial-library-paths ( -- seq )
--- /dev/null
+USING: classes.tuple.change-tracking tools.test strings accessors kernel continuations ;
+IN: classes.tuple.change-tracking.tests
+
+TUPLE: resource < change-tracking-tuple
+ { pathname string } ;
+
+: <resource> ( pathname -- resource ) f swap resource boa ;
+
+[ t ] [ "foo" <resource> "bar" >>pathname changed?>> ] unit-test
+[ f ] [ "foo" <resource> [ 123 >>pathname ] [ drop ] recover changed?>> ] unit-test
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: accessors classes classes.tuple fry kernel sequences slots ;
+IN: classes.tuple.change-tracking
+
+TUPLE: change-tracking-tuple
+ { changed? boolean } ;
+
+PREDICATE: change-tracking-tuple-class < tuple-class
+ change-tracking-tuple subclass-of? ;
+
+: changed? ( tuple -- changed? ) changed?>> ; inline
+: clear-changed ( tuple -- tuple ) f >>changed? ; inline
+
+: filter-changed ( sequence -- sequence' ) [ changed? ] filter ; inline
+
+<PRIVATE
+
+M: change-tracking-tuple-class writer-quot ( class slot-spec -- )
+ [ call-next-method ]
+ [ name>> "changed?" = [ '[ _ [ t >>changed? drop ] bi ] ] unless ] bi ;
+
+PRIVATE>
+
--- /dev/null
+Tuple classes that keep track of when they've been modified
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: sort-largest-first ( seq -- seq ) [ [ length ] compare ] sort reverse ;
+: sort-largest-first ( seq -- seq ) [ length ] sort-with reverse ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
dup dup >vocab-link where normalize-loc 4array ;
: sort-xrefs ( seq -- seq' )
- [ [ first ] dip first <=> ] sort ;
+ [ first ] sort-with ;
: format-xrefs ( seq -- seq' )
[ word? ] filter [ word>xref ] map ;
bunny-uniforms boa ;
: draw-bunny ( world -- )
- T{ depth-state { comparison cmp-less } } set-gpu-state*
+ T{ depth-state { comparison cmp-less } } set-gpu-state
[
sobel>> framebuffer>> {
sobel-uniforms boa ;
: draw-sobel ( world -- )
- T{ depth-state { comparison f } } set-gpu-state*
+ T{ depth-state { comparison f } } set-gpu-state
sobel>> {
{ "primitive-mode" [ drop triangle-strip-mode ] }
[ draw-bunny ] [ draw-sobel ] bi ;
: draw-loading ( world -- )
- T{ depth-state { comparison f } } set-gpu-state*
+ T{ depth-state { comparison f } } set-gpu-state
loading>> {
{ "primitive-mode" [ drop triangle-strip-mode ] }
void
main()
{
- gl_FragColor = /*vec4(border_factor(texcoord));*/ mix(
+ gl_FragColor = mix(
texture2D(color_texture, texcoord),
line_color,
border_factor(texcoord)
lexer locals math math.order math.parser namespaces opengl
opengl.gl parser quotations sequences slots sorting
specialized-arrays.alien specialized-arrays.float specialized-arrays.int
-specialized-arrays.uint strings tr ui.gadgets.worlds variants
+specialized-arrays.uint strings ui.gadgets.worlds variants
vocabs.parser words ;
IN: gpu.render
C: <multi-index-range> multi-index-range
TUPLE: index-elements
- { ptr gpu-data-ptr read-only }
+ { ptr read-only }
{ count integer read-only }
{ index-type index-type read-only } ;
texture-unit'
value>>-quot { value-cleave 2cleave } append ;
-TR: hyphens>underscores "-" "_" ;
-
:: [bind-uniform] ( texture-unit uniform prefix -- texture-unit' quot )
prefix uniform name>> append hyphens>underscores :> name
uniform uniform-type>> :> type
[ [ length ] [ >int-array ] bi glDrawBuffers ] if ;
: bind-named-output-attachments ( program-instance framebuffer attachments -- )
- rot '[ [ first _ swap output-index ] bi@ <=> ] sort [ second ] map
+ rot '[ first _ swap output-index ] sort-with [ second ] map
bind-unnamed-output-attachments ;
: bind-output-attachments ( program-instance framebuffer attachments -- )
locals math math.parser memoize multiline namespaces opengl
opengl.gl opengl.shaders parser quotations sequences
specialized-arrays.alien specialized-arrays.int splitting
-strings ui.gadgets.worlds variants vectors vocabs vocabs.loader
+strings tr ui.gadgets.worlds variants vectors vocabs vocabs.loader
vocabs.parser words words.constant ;
IN: gpu.shaders
<PRIVATE
+TR: hyphens>underscores "-" "_" ;
+
: gl-vertex-type ( component-type -- gl-type )
{
{ ubyte-components [ GL_UNSIGNED_BYTE ] }
} 0&& [ vertex-attribute inaccurate-feedback-attribute-error ] unless ;
:: [bind-vertex-attribute] ( stride offset vertex-attribute -- stride offset' quot )
- vertex-attribute name>> :> name
- vertex-attribute component-type>> :> type
- type gl-vertex-type :> gl-type
- vertex-attribute dim>> :> dim
- vertex-attribute normalize?>> >c-bool :> normalize?
- vertex-attribute vertex-attribute-size :> size
+ vertex-attribute name>> hyphens>underscores :> name
+ vertex-attribute component-type>> :> type
+ type gl-vertex-type :> gl-type
+ vertex-attribute dim>> :> dim
+ vertex-attribute normalize?>> >c-bool :> normalize?
+ vertex-attribute vertex-attribute-size :> size
stride offset size +
{
! (c)2009 Joe Groff bsd license
-USING: byte-arrays classes gpu.buffers help.markup help.syntax
+USING: alien byte-arrays classes gpu.buffers help.markup help.syntax
images kernel math ;
IN: gpu.textures
{ texture-cube-map <texture-cube-map> } related-words
HELP: texture-data
-{ $class-description { $snippet "texture-data" } " tuples are used to feed image data to " { $link allocate-texture } " and " { $link update-texture } ". In addition to providing a " { $snippet "ptr" } " to CPU memory or a GPU " { $link buffer-ptr } ", the " { $link texture-data } " object also specifies the " { $link component-order } " and " { $link component-type } " of the referenced data." }
+{ $class-description { $snippet "texture-data" } " tuples are used to feed image data to " { $link allocate-texture } " and " { $link update-texture } "."
+{ $list
+{ "The " { $snippet "ptr" } " slot references either CPU memory (as a " { $link byte-array } " or " { $link alien } ") or a GPU " { $link buffer-ptr } " that contains the image data." }
+{ "The " { $snippet "component-order" } " and " { $snippet "component-type" } " slots determine the " { $link component-order } " and " { $link component-type } " of the referenced data." }
+} }
{ $notes "Using a " { $link buffer-ptr } " as the " { $snippet "ptr" } " of a " { $snippet "texture-data" } " object requires OpenGL 2.1 or later or the " { $snippet "GL_ARB_pixel_buffer_object" } " extension." } ;
{ texture-data <texture-data> } related-words
{ $class-description { $snippet "texture-filter" } " values are used in a " { $link texture-parameters } " tuple to determine how a texture should be sampled between pixels or between levels of detail. " { $link filter-linear } " selects linear filtering, while " { $link filter-nearest } " selects nearest-neighbor sampling." } ;
HELP: texture-parameters
-{ $class-description "When a " { $link texture } " is created, the following " { $snippet "texture-parameter" } "s are set to control how the texture is sampled:"
+{ $class-description "A " { $snippet "texture-parameters" } " tuple is supplied when constructing a " { $link texture } " to control the wrapping, filtering, and level-of-detail handling of the texture. These tuples have the following slots:"
{ $list
{ "The " { $snippet "wrap" } " slot determines how texture coordinates outside the 0.0 to 1.0 range are mapped to the texture image. The slot either contains a single " { $link texture-wrap } " value, which will apply to all three axes, or a sequence of up to three values, which will apply to the S, T, and R axes, respectively." }
-{ "The " { $snippet "min-filter" } " and " { $snippet "min-mipmap-filter" } " determine how the texture image is filtered when sampled below its highest level of detail, the former controlling filtering between pixels within a level of detail and the latter filtering between levels of detail. A setting of " { $link filter-linear } " uses linear, bilinear, or trilinear filtering among sampled pixels, while a setting of " { $link filter-nearest } " uses nearest-neighbor sampling. The " { $snippet "min-mipmap-filter" } " slot may additionally be set to " { $link f } " to disable mipmapping and only sample the highest level of detail." }
+{ "The " { $snippet "min-filter" } " and " { $snippet "min-mipmap-filter" } " determine how the texture image is filtered when sampled below its highest level of detail, the former filtering between pixels within a level of detail and the latter filtering between levels of detail. A setting of " { $link filter-linear } " uses linear, bilinear, or trilinear filtering among the sampled pixels, while a setting of " { $link filter-nearest } " uses nearest-neighbor sampling. The " { $snippet "min-mipmap-filter" } " slot may additionally be set to " { $link f } " to disable mipmapping and only sample the highest level of detail." }
{ "The " { $snippet "mag-filter" } " analogously determines how the texture image is filtered when sampled above its highest level of detail." }
{ "The " { $snippet "min-lod" } " and " { $snippet "max-lod" } " slots contain integer values that will clamp the range of levels of detail that will be sampled from the texture." }
{ "The " { $snippet "lod-bias" } " slot contains an integer value that will offset the levels of detail that would normally be sampled from the texture." }
{ "The " { $snippet "base-level" } " slot contains an integer value that identifies the highest level of detail for the image, typically zero." }
-{ "The " { $snippet "max-level" } " slot contains an integer value that identifies the lowest level of detail for the image. This value will automatically be clamped to the maximum of the base-2 logarithm of the dimensions of the highest level of detail image." }
+{ "The " { $snippet "max-level" } " slot contains an integer value that identifies the lowest level of detail for the image. This value will automatically be clamped to the maximum of the base-2 logarithms of the dimensions of the highest level of detail image." }
} } ;
{ texture-parameters set-texture-parameters } related-words
{ axis cube-map-axis read-only } ;
C: <cube-map-face> cube-map-face
-UNION: texture-data-target
- texture-1d texture-2d texture-3d cube-map-face ;
UNION: texture-1d-data-target
texture-1d ;
UNION: texture-2d-data-target
texture-2d texture-rectangle texture-1d-array cube-map-face ;
UNION: texture-3d-data-target
texture-3d texture-2d-array ;
+UNION: texture-data-target
+ texture-1d-data-target texture-2d-data-target texture-3d-data-target ;
M: texture dispose
[ [ delete-texture ] when* f ] change-handle drop ;
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 ;
: 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
: sorted-pair-methods ( word -- alist )
"pair-generic-methods" word-prop >alist
- [ [ first method-sort-key ] bi@ >=< ] sort ;
+ [ first method-sort-key ] inv-sort-with ;
: pair-generic-definition ( word -- def )
[ sorted-pair-methods [ first2 pair-method-cond ] map ]
[ "cd" ]
[ "abcd" <sequence-parser> [ "ab" take-sequence drop ] [ "cd" take-sequence ] bi ] unit-test
-[ f ]
-[
- "\"abc\" asdf" <sequence-parser>
- [ CHAR: \ CHAR: " take-quoted-string drop ] [ "asdf" take-sequence ] bi
-] unit-test
-
-[ "abc\\\"def" ]
-[
- "\"abc\\\"def\" asdf" <sequence-parser>
- CHAR: \ CHAR: " take-quoted-string
-] unit-test
-
-[ "asdf" ]
-[
- "\"abc\" asdf" <sequence-parser>
- [ CHAR: \ CHAR: " take-quoted-string drop ]
- [ skip-whitespace "asdf" take-sequence ] bi
-] unit-test
-
-[ f ]
-[
- "\"abc asdf" <sequence-parser>
- CHAR: \ CHAR: " take-quoted-string
-] unit-test
-
-[ "\"abc" ]
-[
- "\"abc asdf" <sequence-parser>
- [ CHAR: \ CHAR: " take-quoted-string drop ]
- [ "\"abc" take-sequence ] bi
-] unit-test
-
-[ "c" ]
-[ "c" <sequence-parser> take-token ] unit-test
-
-[ f ]
-[ "" <sequence-parser> take-token ] unit-test
-
-[ "abcd e \\\"f g" ]
-[ "\"abcd e \\\"f g\"" <sequence-parser> CHAR: \ CHAR: " take-token* ] unit-test
-
[ f ]
[ "" <sequence-parser> take-rest ] unit-test
[ "abcd" ] [ "abcd" <sequence-parser> 4 take-n ] unit-test
[ "abcd" "efg" ] [ "abcdefg" <sequence-parser> [ 4 take-n ] [ take-rest ] bi ] unit-test
-[ "asdfasdf" ] [
- "/*asdfasdf*/" <sequence-parser> take-c-comment
-] unit-test
-
-[ "k" ] [
- "/*asdfasdf*/k" <sequence-parser> [ take-c-comment drop ] [ take-rest ] bi
-] unit-test
-
-[ "omg" ] [
- "//asdfasdf\nomg" <sequence-parser>
- [ take-c++-comment drop ] [ take-rest ] bi
-] unit-test
-
-[ "omg" ] [
- "omg" <sequence-parser>
- [ take-c++-comment drop ] [ take-rest ] bi
-] unit-test
-
-[ "/*asdfasdf" ] [
- "/*asdfasdf" <sequence-parser> [ take-c-comment drop ] [ take-rest ] bi
-] unit-test
-
-[ "asdf" "eoieoei" ] [
- "//asdf\neoieoei" <sequence-parser>
- [ take-c++-comment ] [ take-rest ] bi
-] unit-test
-
-[ f "33asdf" ]
-[ "33asdf" <sequence-parser> [ take-c-identifier ] [ take-rest ] bi ] unit-test
-
-[ "asdf" ]
-[ "asdf" <sequence-parser> take-c-identifier ] unit-test
-
-[ "_asdf" ]
-[ "_asdf" <sequence-parser> take-c-identifier ] unit-test
-
-[ "_asdf400" ]
-[ "_asdf400" <sequence-parser> take-c-identifier ] unit-test
-
-[ "123" ]
-[ "123jjj" <sequence-parser> take-c-integer ] unit-test
-
-[ "123uLL" ]
-[ "123uLL" <sequence-parser> take-c-integer ] unit-test
-
-[ "123ull" ]
-[ "123ull" <sequence-parser> take-c-integer ] unit-test
-
-[ "123u" ]
-[ "123u" <sequence-parser> take-c-integer ] unit-test
-
-[ 36 ]
-[
- " //jofiejoe\n //eoieow\n/*asdf*/\n "
- <sequence-parser> skip-whitespace/comments n>>
-] unit-test
-
[ f ]
[ "\n" <sequence-parser> take-integer ] unit-test
! Copyright (C) 2005, 2009 Daniel Ehrenberg, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces math kernel sequences accessors fry circular
-unicode.case unicode.categories locals combinators.short-circuit
-make combinators io splitting math.parser math.ranges
-generalizations sorting.functor math.order sorting.slots ;
+USING: accessors circular combinators.short-circuit fry io
+kernel locals math math.order sequences sorting.functor
+sorting.slots unicode.categories ;
IN: sequence-parser
TUPLE: sequence-parser sequence n ;
: skip-whitespace-eol ( sequence-parser -- sequence-parser )
[ [ current " \t\r" member? not ] take-until drop ] keep ;
-: take-c-comment ( sequence-parser -- seq/f )
- [
- dup "/*" take-sequence [
- "*/" take-until-sequence*
- ] [
- drop f
- ] if
- ] with-sequence-parser ;
-
-: take-c++-comment ( sequence-parser -- seq/f )
- [
- dup "//" take-sequence [
- [
- [
- { [ current CHAR: \n = ] [ sequence-parse-end? ] } 1||
- ] take-until
- ] [
- advance drop
- ] bi
- ] [
- drop f
- ] if
- ] with-sequence-parser ;
-
-: skip-whitespace/comments ( sequence-parser -- sequence-parser )
- skip-whitespace-eol
- {
- { [ dup take-c-comment ] [ skip-whitespace/comments ] }
- { [ dup take-c++-comment ] [ skip-whitespace/comments ] }
- [ ]
- } cond ;
-
-: take-define-identifier ( sequence-parser -- string )
- skip-whitespace/comments
- [ current { [ blank? ] [ CHAR: ( = ] } 1|| ] take-until ;
-
: take-rest-slice ( sequence-parser -- sequence/f )
[ sequence>> ] [ n>> ] bi
2dup [ length ] dip < [ 2drop f ] [ tail-slice ] if ; inline
: parse-sequence ( sequence quot -- )
[ <sequence-parser> ] dip call ; inline
-:: take-quoted-string ( sequence-parser escape-char quote-char -- string )
- sequence-parser n>> :> start-n
- sequence-parser advance
- [
- {
- [ { [ previous escape-char = ] [ current quote-char = ] } 1&& ]
- [ current quote-char = not ]
- } 1||
- ] take-while :> string
- sequence-parser current quote-char = [
- sequence-parser advance* string
- ] [
- start-n sequence-parser (>>n) f
- ] if ;
-
-: (take-token) ( sequence-parser -- string )
- skip-whitespace [ current { [ blank? ] [ f = ] } 1|| ] take-until ;
-
-:: take-token* ( sequence-parser escape-char quote-char -- string/f )
- sequence-parser skip-whitespace
- dup current {
- { quote-char [ escape-char quote-char take-quoted-string ] }
- { f [ drop f ] }
- [ drop (take-token) ]
- } case ;
-
-: take-token ( sequence-parser -- string/f )
- CHAR: \ CHAR: " take-token* ;
-
: take-integer ( sequence-parser -- n/f )
[ current digit? ] take-while ;
sequence-parser [ n + ] change-n drop
] if ;
-: c-identifier-begin? ( ch -- ? )
- CHAR: a CHAR: z [a,b]
- CHAR: A CHAR: Z [a,b]
- { CHAR: _ } 3append member? ;
-
-: c-identifier-ch? ( ch -- ? )
- CHAR: a CHAR: z [a,b]
- CHAR: A CHAR: Z [a,b]
- CHAR: 0 CHAR: 9 [a,b]
- { CHAR: _ } 4 nappend member? ;
-
-: (take-c-identifier) ( sequence-parser -- string/f )
- dup current c-identifier-begin? [
- [ current c-identifier-ch? ] take-while
- ] [
- drop f
- ] if ;
-
-: take-c-identifier ( sequence-parser -- string/f )
- [ (take-c-identifier) ] with-sequence-parser ;
-
<< "length" [ length ] define-sorting >>
: sort-tokens ( seq -- seq' )
swap
'[ _ [ swap take-sequence ] with-sequence-parser ] find nip ;
-
: take-longest ( sequence-parser seq -- seq )
sort-tokens take-first-matching ;
-: take-c-integer ( sequence-parser -- string/f )
- [
- dup take-integer [
- swap
- { "ull" "uLL" "Ull" "ULL" "ll" "LL" "l" "L" "u" "U" }
- take-longest [ append ] when*
- ] [
- drop f
- ] if*
- ] with-sequence-parser ;
-
-CONSTANT: c-punctuators
- {
- "[" "]" "(" ")" "{" "}" "." "->"
- "++" "--" "&" "*" "+" "-" "~" "!"
- "/" "%" "<<" ">>" "<" ">" "<=" ">=" "==" "!=" "^" "|" "&&" "||"
- "?" ":" ";" "..."
- "=" "*=" "/=" "%=" "+=" "-=" "<<=" ">>=" "&=" "^=" "|="
- "," "#" "##"
- "<:" ":>" "<%" "%>" "%:" "%:%:"
- }
-
-: take-c-punctuator ( sequence-parser -- string/f )
- c-punctuators take-longest ;
-
: write-full ( sequence-parser -- ) sequence>> write ;
: write-rest ( sequence-parser -- ) take-rest write ;
>>comments ;
: reverse-chronological-order ( seq -- sorted )
- [ [ date>> ] compare invert-comparison ] sort ;
+ [ date>> ] inv-sort-with ;
: validate-author ( -- )
{ { "author" [ v-username ] } } validate-params ;
: pastes ( -- pastes )
f <paste> select-tuples
- [ [ date>> ] compare ] sort
+ [ date>> ] sort-with
reverse ;
TUPLE: annotation < entity parent ;
: blogroll ( -- seq )
f <blog> select-tuples
- [ [ name>> ] compare ] sort ;
+ [ name>> ] sort-with ;
: postings ( -- seq )
posting new select-tuples
- [ [ date>> ] compare invert-comparison ] sort ;
+ [ date>> ] inv-sort-with ;
: <edit-blogroll-action> ( -- action )
<page-action>
[ '[ _ <posting> ] map ] 2map concat ;
: sort-entries ( entries -- entries' )
- [ [ date>> ] compare invert-comparison ] sort ;
+ [ date>> ] inv-sort-with ;
: update-cached-postings ( -- )
blogroll fetch-blogroll sort-entries 8 short head [
M: revision feed-entry-url id>> revision-url ;
: reverse-chronological-order ( seq -- sorted )
- [ [ date>> ] compare invert-comparison ] sort ;
+ [ date>> ] inv-sort-with ;
: <revision> ( id -- revision )
revision new swap >>id ;
[
f <article> select-tuples
- [ [ title>> ] compare ] sort
+ [ title>> ] sort-with
"articles" set-value
] >>init
("\\_<\\(}\\)\\_>" (1 "){"))
;; Parenthesis:
("\\_<\\((\\)\\_>" (1 "()"))
- ("\\_<call\\((\\)\\_>" (1 "()"))
+ ("\\_<\\w*\\((\\)\\_>" (1 "()"))
("\\_<\\()\\)\\_>" (1 ")("))
("\\_<(\\((\\)\\_>" (1 "()"))
("\\_<\\()\\))\\_>" (1 ")("))
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()
static void load_code_heap(FILE *file, image_header *h, vm_parameters *p)
{
- cell good_size = h->code_size + (1 << 19);
-
- if(good_size > p->code_size)
- p->code_size = good_size;
+ if(h->code_size > p->code_size)
+ fatal_error("Code heap too small to fit image",h->code_size);
init_code_heap(p->code_size);
projects / factor.git / commitdiff