M: array c-type-class drop object ;
+M: array c-type-boxed-class drop object ;
+
M: array heap-size unclip [ product ] [ heap-size ] bi* * ;
M: array c-type-align first c-type-align ;
M: array c-type-unboxer-quot drop [ >c-ptr ] ;
-M: value-type c-type-reg-class drop int-regs ;
+M: value-type c-type-rep drop int-rep ;
M: value-type c-type-getter
drop [ swap <displaced-alien> ] ;
M: string-type c-type ;
-M: string-type c-type-class
- drop object ;
+M: string-type c-type-class drop object ;
+
+M: string-type c-type-boxed-class drop object ;
M: string-type heap-size
drop "void*" heap-size ;
M: string-type stack-size
drop "void*" stack-size ;
-M: string-type c-type-reg-class
- drop int-regs ;
+M: string-type c-type-rep
+ drop int-rep ;
M: string-type c-type-boxer
drop "void*" c-type-boxer ;
: little-endian? ( -- ? ) 1 <int> *char 1 = ; foldable
-TUPLE: c-type
+TUPLE: abstract-c-type
{ class class initial: object }
-boxer
+{ boxed-class class initial: object }
{ boxer-quot callable }
-unboxer
{ unboxer-quot callable }
{ getter callable }
{ setter callable }
-{ reg-class initial: int-regs }
size
-align
+align ;
+
+TUPLE: c-type < abstract-c-type
+boxer
+unboxer
+{ rep initial: int-rep }
stack-align? ;
: <c-type> ( -- type )
GENERIC: c-type-class ( name -- class )
-M: c-type c-type-class class>> ;
+M: abstract-c-type c-type-class class>> ;
M: string c-type-class c-type c-type-class ;
+GENERIC: c-type-boxed-class ( name -- class )
+
+M: abstract-c-type c-type-boxed-class boxed-class>> ;
+
+M: string c-type-boxed-class c-type c-type-boxed-class ;
+
GENERIC: c-type-boxer ( name -- boxer )
M: c-type c-type-boxer boxer>> ;
GENERIC: c-type-boxer-quot ( name -- quot )
-M: c-type c-type-boxer-quot boxer-quot>> ;
+M: abstract-c-type c-type-boxer-quot boxer-quot>> ;
M: string c-type-boxer-quot c-type c-type-boxer-quot ;
GENERIC: c-type-unboxer-quot ( name -- quot )
-M: c-type c-type-unboxer-quot unboxer-quot>> ;
+M: abstract-c-type c-type-unboxer-quot unboxer-quot>> ;
M: string c-type-unboxer-quot c-type c-type-unboxer-quot ;
-GENERIC: c-type-reg-class ( name -- reg-class )
+GENERIC: c-type-rep ( name -- rep )
-M: c-type c-type-reg-class reg-class>> ;
+M: c-type c-type-rep rep>> ;
-M: string c-type-reg-class c-type c-type-reg-class ;
+M: string c-type-rep c-type c-type-rep ;
GENERIC: c-type-getter ( name -- quot )
GENERIC: c-type-align ( name -- n )
-M: c-type c-type-align align>> ;
+M: abstract-c-type c-type-align align>> ;
M: string c-type-align c-type c-type-align ;
M: string c-type-stack-align? c-type c-type-stack-align? ;
: c-type-box ( n type -- )
- dup c-type-reg-class
- swap c-type-boxer [ "No boxer" throw ] unless*
+ [ c-type-rep ] [ c-type-boxer [ "No boxer" throw ] unless* ] bi
%box ;
: c-type-unbox ( n ctype -- )
- dup c-type-reg-class
- swap c-type-unboxer [ "No unboxer" throw ] unless*
+ [ c-type-rep ] [ c-type-unboxer [ "No unboxer" throw ] unless* ] bi
%unbox ;
GENERIC: box-parameter ( n ctype -- )
M: string heap-size c-type heap-size ;
-M: c-type heap-size size>> ;
+M: abstract-c-type heap-size size>> ;
GENERIC: stack-size ( type -- size ) foldable
[
<c-type>
c-ptr >>class
+ c-ptr >>boxed-class
[ alien-cell ] >>getter
[ [ >c-ptr ] 2dip set-alien-cell ] >>setter
bootstrap-cell >>size
<long-long-type>
integer >>class
+ integer >>boxed-class
[ alien-signed-8 ] >>getter
[ set-alien-signed-8 ] >>setter
8 >>size
<long-long-type>
integer >>class
+ integer >>boxed-class
[ alien-unsigned-8 ] >>getter
[ set-alien-unsigned-8 ] >>setter
8 >>size
<c-type>
integer >>class
+ integer >>boxed-class
[ alien-signed-cell ] >>getter
[ set-alien-signed-cell ] >>setter
bootstrap-cell >>size
<c-type>
integer >>class
+ integer >>boxed-class
[ alien-unsigned-cell ] >>getter
[ set-alien-unsigned-cell ] >>setter
bootstrap-cell >>size
<c-type>
integer >>class
+ integer >>boxed-class
[ alien-signed-4 ] >>getter
[ set-alien-signed-4 ] >>setter
4 >>size
<c-type>
integer >>class
+ integer >>boxed-class
[ alien-unsigned-4 ] >>getter
[ set-alien-unsigned-4 ] >>setter
4 >>size
<c-type>
fixnum >>class
+ fixnum >>boxed-class
[ alien-signed-2 ] >>getter
[ set-alien-signed-2 ] >>setter
2 >>size
<c-type>
fixnum >>class
+ fixnum >>boxed-class
[ alien-unsigned-2 ] >>getter
[ set-alien-unsigned-2 ] >>setter
2 >>size
<c-type>
fixnum >>class
+ fixnum >>boxed-class
[ alien-signed-1 ] >>getter
[ set-alien-signed-1 ] >>setter
1 >>size
<c-type>
fixnum >>class
+ fixnum >>boxed-class
[ alien-unsigned-1 ] >>getter
[ set-alien-unsigned-1 ] >>setter
1 >>size
<c-type>
float >>class
+ float >>boxed-class
[ alien-float ] >>getter
[ [ >float ] 2dip set-alien-float ] >>setter
4 >>size
4 >>align
"box_float" >>boxer
"to_float" >>unboxer
- single-float-regs >>reg-class
+ single-float-rep >>rep
[ >float ] >>unboxer-quot
"float" define-primitive-type
<c-type>
float >>class
+ float >>boxed-class
[ alien-double ] >>getter
[ [ >float ] 2dip set-alien-double ] >>setter
8 >>size
8 >>align
"box_double" >>boxer
"to_double" >>unboxer
- double-float-regs >>reg-class
+ double-float-rep >>rep
[ >float ] >>unboxer-quot
"double" define-primitive-type
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test alien.complex kernel alien.c-types alien.syntax
-namespaces ;
+namespaces math ;
IN: alien.complex.tests
C-STRUCT: complex-holder
] unit-test
[ C{ 1.0 2.0 } ] [ "h" get complex-holder-z ] unit-test
+
+[ complex ] [ "complex-float" c-type-boxed-class ] unit-test
+
+[ complex ] [ "complex-double" c-type-boxed-class ] unit-test
\ No newline at end of file
T c-type
<T> 1quotation >>unboxer-quot
*T 1quotation >>boxer-quot
+number >>boxed-class
drop
;FUNCTOR
] 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
quotations byte-arrays ;
IN: alien.structs
-TUPLE: struct-type
-size
-align
-fields
-{ boxer-quot callable }
-{ unboxer-quot callable }
-{ getter callable }
-{ setter callable }
-return-in-registers? ;
+TUPLE: struct-type < abstract-c-type fields return-in-registers? ;
M: struct-type c-type ;
-M: struct-type heap-size size>> ;
-
-M: struct-type c-type-class drop byte-array ;
-
-M: struct-type c-type-align align>> ;
-
M: struct-type c-type-stack-align? drop f ;
-M: struct-type c-type-boxer-quot boxer-quot>> ;
-
-M: struct-type c-type-unboxer-quot unboxer-quot>> ;
-
: if-value-struct ( ctype true false -- )
[ dup value-struct? ] 2dip '[ drop "void*" @ ] if ; inline
: (define-struct) ( name size align fields -- )
[ [ align ] keep ] dip
struct-type new
+ byte-array >>class
+ byte-array >>boxed-class
swap >>fields
swap >>align
swap >>size
{
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
! 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 ;
+USING: accessors kernel make sequences tools.annotations tools.crossref ;
+QUALIFIED: compiler.cfg.builder
+QUALIFIED: compiler.cfg.linear-scan
+QUALIFIED: compiler.cfg.mr
+QUALIFIED: compiler.cfg.optimizer
+QUALIFIED: compiler.cfg.stacks.finalize
+QUALIFIED: compiler.cfg.stacks.global
+QUALIFIED: compiler.codegen
+QUALIFIED: compiler.tree.builder
+QUALIFIED: compiler.tree.optimizer
IN: bootstrap.compiler.timing
: passes ( word -- seq )
def>> uses [ vocabulary>> "compiler." head? ] filter ;
-: high-level-passes ( -- seq ) \ optimize-tree passes ;
+: high-level-passes ( -- seq ) \ compiler.tree.optimizer:optimize-tree passes ;
-: low-level-passes ( -- seq ) \ optimize-cfg passes ;
+: low-level-passes ( -- seq ) \ compiler.cfg.optimizer:optimize-cfg passes ;
-: machine-passes ( -- seq ) \ build-mr passes ;
+: machine-passes ( -- seq ) \ compiler.cfg.mr:build-mr passes ;
-: linear-scan-passes ( -- seq ) \ (linear-scan) passes ;
+: linear-scan-passes ( -- seq ) \ compiler.cfg.linear-scan:(linear-scan) passes ;
: all-passes ( -- seq )
[
- \ build-tree ,
- \ optimize-tree ,
+ \ compiler.tree.builder:build-tree ,
+ \ compiler.tree.optimizer:optimize-tree ,
high-level-passes %
- \ build-cfg ,
- \ compute-global-sets ,
- \ finalize-stack-shuffling ,
- \ optimize-cfg ,
+ \ compiler.cfg.builder:build-cfg ,
+ \ compiler.cfg.stacks.global:compute-global-sets ,
+ \ compiler.cfg.stacks.finalize:finalize-stack-shuffling ,
+ \ compiler.cfg.optimizer:optimize-cfg ,
low-level-passes %
- \ compute-live-sets ,
- \ build-mr ,
+ \ compiler.cfg.mr:build-mr ,
machine-passes %
linear-scan-passes %
- \ generate ,
+ \ compiler.codegen: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
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math namespaces assocs hashtables sequences arrays
-accessors vectors combinators sets classes compiler.cfg
+accessors vectors combinators sets classes cpu.architecture compiler.cfg
compiler.cfg.registers compiler.cfg.instructions
compiler.cfg.copy-prop compiler.cfg.rpo compiler.cfg.liveness ;
IN: compiler.cfg.alias-analysis
call-next-method
dup [ dst>> ] [ insn-slot# ] [ insn-object ] tri
2dup live-slot dup [
- 2nip \ ##copy new-insn analyze-aliases* nip
+ 2nip any-rep \ ##copy new-insn analyze-aliases* nip
] [
drop remember-slot
] if ;
! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators.short-circuit kernel sequences math
compiler.utilities compiler.cfg compiler.cfg.instructions compiler.cfg.rpo
-compiler.cfg.utilities ;
+compiler.cfg.predecessors compiler.cfg.utilities ;
IN: compiler.cfg.block-joining
! Joining blocks that are not calls and are connected by a single CFG edge.
-! Predecessors must be recomputed after this. Also this pass does not
-! update ##phi nodes and should therefore only run before stack analysis.
+! This pass does not update ##phi nodes and should therefore only run
+! before stack analysis.
: join-block? ( bb -- ? )
{
[ kill-block? not ]
[ join-instructions ] [ update-successors ] 2bi ;
: join-blocks ( cfg -- cfg' )
+ needs-predecessors
+
dup post-order [
dup join-block?
[ dup predecessor join-block ] [ drop ] if
] each
- cfg-changed ;
+
+ cfg-changed predecessors-changed ;
: check-predecessors ( cfg -- )
[ get-predecessors ]
- [ compute-predecessors drop ]
+ [ needs-predecessors drop ]
[ get-predecessors ] tri assert= ;
: check-branch-splitting ( cfg -- )
- compute-predecessors
+ needs-predecessors
split-branches
check-predecessors ;
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
! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators.short-circuit kernel math math.order
sequences assocs namespaces vectors fry arrays splitting
-compiler.cfg.def-use compiler.cfg compiler.cfg.rpo
+compiler.cfg.def-use compiler.cfg compiler.cfg.rpo compiler.cfg.predecessors
compiler.cfg.renaming compiler.cfg.instructions compiler.cfg.utilities ;
IN: compiler.cfg.branch-splitting
] if ;
: split-branches ( cfg -- cfg' )
+ needs-predecessors
+
dup [
dup split-branch? [ split-branch ] [ drop ] if
] each-basic-block
+
cfg-changed ;
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces accessors math.order assocs kernel sequences
-combinators make classes words cpu.architecture
+combinators make classes words cpu.architecture layouts
compiler.cfg.instructions compiler.cfg.registers
compiler.cfg.stack-frame ;
IN: compiler.cfg.build-stack-frame
SYMBOL: frame-required?
-SYMBOL: spill-counts
-
GENERIC: compute-stack-frame* ( insn -- )
: request-stack-frame ( stack-frame -- )
M: _gc compute-stack-frame*
frame-required? on
- stack-frame new swap gc-root-size>> >>gc-root-size
+ stack-frame new swap tagged-values>> length cells >>gc-root-size
request-stack-frame ;
-M: _spill-counts compute-stack-frame*
- counts>> stack-frame get (>>spill-counts) ;
+M: _spill-area-size compute-stack-frame*
+ n>> stack-frame get (>>spill-area-size) ;
M: insn compute-stack-frame*
class frame-required? word-prop [
: compute-stack-frame ( insns -- )
frame-required? off
- T{ stack-frame } clone stack-frame set
+ stack-frame new stack-frame set
[ compute-stack-frame* ] each
stack-frame get dup stack-frame-size >>total-size drop ;
prettyprint alien alien.accessors math.private compiler.tree.builder
compiler.tree.optimizer compiler.cfg.builder compiler.cfg.debugger
compiler.cfg.optimizer compiler.cfg.predecessors compiler.cfg.checker
-arrays locals byte-arrays kernel.private math slots.private vectors sbufs
-strings math.partial-dispatch strings.private ;
+compiler.cfg arrays locals byte-arrays kernel.private math
+slots.private vectors sbufs strings math.partial-dispatch
+strings.private ;
! Just ensure that various CFGs build correctly.
: unit-test-cfg ( quot -- )
- '[ _ test-cfg [ optimize-cfg check-cfg ] each ] [ ] swap unit-test ;
+ '[ _ test-cfg [ [ optimize-cfg check-cfg ] with-cfg ] each ] [ ] swap unit-test ;
: blahblah ( nodes -- ? )
{ fixnum } declare [
compiler.cfg.predecessors
compiler.cfg.builder.blocks
compiler.cfg.stacks
+compiler.cfg.stacks.local
compiler.alien ;
IN: compiler.cfg.builder
! Inputs to the final instruction need to be copied because of
! loc>vreg sync. ^^offset>slot always returns a fresh vreg,
! though.
- ds-pop ^^offset>slot i ##dispatch emit-if ;
+ ds-pop ^^offset>slot next-vreg ##dispatch emit-if ;
! #call
M: #call emit-node
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 ( -- )
M: #enter-recursive emit-node drop ;
M: #phi emit-node drop ;
+
+M: #declare emit-node drop ;
\ No newline at end of file
V{ } clone >>predecessors
\ basic-block counter >>id ;
-TUPLE: cfg { entry basic-block } word label spill-counts post-order ;
+TUPLE: cfg { entry basic-block } word label
+spill-area-size reps
+post-order linear-order
+predecessors-valid? dominance-valid? loops-valid? ;
-: <cfg> ( entry word label -- cfg ) f f cfg boa ;
+: <cfg> ( entry word label -- cfg )
+ cfg new
+ swap >>label
+ swap >>word
+ swap >>entry ;
+
+: cfg-changed ( cfg -- cfg )
+ f >>post-order
+ f >>linear-order
+ f >>dominance-valid?
+ f >>loops-valid? ; inline
+
+: predecessors-changed ( cfg -- cfg )
+ f >>predecessors-valid? ;
-: cfg-changed ( cfg -- cfg ) f >>post-order ; inline
+: with-cfg ( cfg quot: ( cfg -- ) -- )
+ [ dup cfg ] dip with-variable ; inline
TUPLE: mr { instructions array } word label ;
! 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 compiler.cfg.predecessors ;
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 ;
PRIVATE>
: copy-propagation ( cfg -- cfg' )
+ needs-predecessors
+
[ collect-copies ]
[ rename-copies ]
[ ]
+++ /dev/null
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math accessors sequences
-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 ;
-
-: split-critical-edge ( from to -- )
- f <simple-block> insert-basic-block ;
-
-: split-critical-edges ( cfg -- )
- dup [
- dup successors>> [
- 2dup critical-edge?
- [ split-critical-edge ] [ 2drop ] if
- ] with each
- ] each-basic-block
- cfg-changed
- drop ;
\ No newline at end of file
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs deques dlists kernel locals sequences lexer
namespaces functors compiler.cfg.rpo compiler.cfg.utilities
-compiler.cfg ;
+compiler.cfg.predecessors compiler.cfg ;
IN: compiler.cfg.dataflow-analysis
GENERIC: join-sets ( sets dfa -- set )
] when ; inline
:: run-dataflow-analysis ( cfg dfa -- in-sets out-sets )
+ cfg needs-predecessors drop
H{ } clone :> in-sets
H{ } clone :> out-sets
cfg dfa <dfa-worklist> :> work-list
entry>> instructions>> ;
[ V{
- T{ ##load-immediate { dst V int-regs 1 } { val 8 } }
- T{ ##load-immediate { dst V int-regs 2 } { val 16 } }
- T{ ##add { dst V int-regs 3 } { src1 V int-regs 1 } { src2 V int-regs 2 } }
- T{ ##replace { src V int-regs 3 } { loc D 0 } }
+ T{ ##load-immediate { dst 1 } { val 8 } }
+ T{ ##load-immediate { dst 2 } { val 16 } }
+ T{ ##add { dst 3 } { src1 1 } { src2 2 } }
+ T{ ##replace { src 3 } { loc D 0 } }
} ] [ V{
- T{ ##load-immediate { dst V int-regs 1 } { val 8 } }
- T{ ##load-immediate { dst V int-regs 2 } { val 16 } }
- T{ ##add { dst V int-regs 3 } { src1 V int-regs 1 } { src2 V int-regs 2 } }
- T{ ##replace { src V int-regs 3 } { loc D 0 } }
+ T{ ##load-immediate { dst 1 } { val 8 } }
+ T{ ##load-immediate { dst 2 } { val 16 } }
+ T{ ##add { dst 3 } { src1 1 } { src2 2 } }
+ T{ ##replace { src 3 } { loc D 0 } }
} test-dce ] unit-test
[ V{ } ] [ V{
- T{ ##load-immediate { dst V int-regs 1 } { val 8 } }
- T{ ##load-immediate { dst V int-regs 2 } { val 16 } }
- T{ ##add { dst V int-regs 3 } { src1 V int-regs 1 } { src2 V int-regs 2 } }
+ T{ ##load-immediate { dst 1 } { val 8 } }
+ T{ ##load-immediate { dst 2 } { val 16 } }
+ T{ ##add { dst 3 } { src1 1 } { src2 2 } }
} test-dce ] unit-test
[ V{ } ] [ V{
- T{ ##load-immediate { dst V int-regs 3 } { val 8 } }
- T{ ##allot { dst V int-regs 1 } { temp V int-regs 2 } }
+ T{ ##load-immediate { dst 3 } { val 8 } }
+ T{ ##allot { dst 1 } { temp 2 } }
} test-dce ] unit-test
[ V{ } ] [ V{
- T{ ##load-immediate { dst V int-regs 3 } { val 8 } }
- T{ ##allot { dst V int-regs 1 } { temp V int-regs 2 } }
- T{ ##set-slot-imm { obj V int-regs 1 } { src V int-regs 3 } }
+ T{ ##load-immediate { dst 3 } { val 8 } }
+ T{ ##allot { dst 1 } { temp 2 } }
+ T{ ##set-slot-imm { obj 1 } { src 3 } }
} test-dce ] unit-test
[ V{
- T{ ##load-immediate { dst V int-regs 3 } { val 8 } }
- T{ ##allot { dst V int-regs 1 } { temp V int-regs 2 } }
- T{ ##set-slot-imm { obj V int-regs 1 } { src V int-regs 3 } }
- T{ ##replace { src V int-regs 1 } { loc D 0 } }
+ T{ ##load-immediate { dst 3 } { val 8 } }
+ T{ ##allot { dst 1 } { temp 2 } }
+ T{ ##set-slot-imm { obj 1 } { src 3 } }
+ T{ ##replace { src 1 } { loc D 0 } }
} ] [ V{
- T{ ##load-immediate { dst V int-regs 3 } { val 8 } }
- T{ ##allot { dst V int-regs 1 } { temp V int-regs 2 } }
- T{ ##set-slot-imm { obj V int-regs 1 } { src V int-regs 3 } }
- T{ ##replace { src V int-regs 1 } { loc D 0 } }
+ T{ ##load-immediate { dst 3 } { val 8 } }
+ T{ ##allot { dst 1 } { temp 2 } }
+ T{ ##set-slot-imm { obj 1 } { src 3 } }
+ T{ ##replace { src 1 } { loc D 0 } }
} test-dce ] unit-test
[ V{
- T{ ##allot { dst V int-regs 1 } { temp V int-regs 2 } }
- T{ ##replace { src V int-regs 1 } { loc D 0 } }
+ T{ ##allot { dst 1 } { temp 2 } }
+ T{ ##replace { src 1 } { loc D 0 } }
} ] [ V{
- T{ ##allot { dst V int-regs 1 } { temp V int-regs 2 } }
- T{ ##replace { src V int-regs 1 } { loc D 0 } }
+ T{ ##allot { dst 1 } { temp 2 } }
+ T{ ##replace { src 1 } { loc D 0 } }
} test-dce ] unit-test
[ V{
- T{ ##allot { dst V int-regs 1 } { temp V int-regs 2 } }
- T{ ##replace { src V int-regs 1 } { loc D 0 } }
- T{ ##load-immediate { dst V int-regs 3 } { val 8 } }
- T{ ##set-slot-imm { obj V int-regs 1 } { src V int-regs 3 } }
+ T{ ##allot { dst 1 } { temp 2 } }
+ T{ ##replace { src 1 } { loc D 0 } }
+ T{ ##load-immediate { dst 3 } { val 8 } }
+ T{ ##set-slot-imm { obj 1 } { src 3 } }
} ] [ V{
- T{ ##allot { dst V int-regs 1 } { temp V int-regs 2 } }
- T{ ##replace { src V int-regs 1 } { loc D 0 } }
- T{ ##load-immediate { dst V int-regs 3 } { val 8 } }
- T{ ##set-slot-imm { obj V int-regs 1 } { src V int-regs 3 } }
+ T{ ##allot { dst 1 } { temp 2 } }
+ T{ ##replace { src 1 } { loc D 0 } }
+ T{ ##load-immediate { dst 3 } { val 8 } }
+ T{ ##set-slot-imm { obj 1 } { src 3 } }
} test-dce ] unit-test
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs sets kernel namespaces sequences
compiler.cfg.instructions compiler.cfg.def-use
-compiler.cfg.rpo ;
+compiler.cfg.rpo compiler.cfg.predecessors ;
IN: compiler.cfg.dce
! Maps vregs to sequences of vregs
M: insn live-insn? drop t ;
: eliminate-dead-code ( cfg -- cfg' )
+ needs-predecessors
+
init-dead-code
dup
[ [ instructions>> [ build-liveness-graph ] each ] each-basic-block ]
! 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
+cpu.architecture 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.def-use
+compiler.cfg.rpo compiler.cfg.mr compiler.cfg ;
IN: compiler.cfg.debugger
GENERIC: test-cfg ( quot -- cfgs )
: test-mr ( quot -- mrs )
test-cfg [
- optimize-cfg
- build-mr
+ [
+ optimize-cfg
+ build-mr
+ ] with-cfg
] map ;
: insn. ( insn -- )
] each ;
! Prettyprinting
-M: vreg pprint*
- <block
- \ V pprint-word [ reg-class>> pprint* ] [ n>> pprint* ] bi
- block> ;
-
: pprint-loc ( loc word -- ) <block pprint-word n>> pprint* block> ;
M: ds-loc pprint* \ D pprint-loc ;
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 ;
+
+: fake-representations ( cfg -- )
+ post-order [
+ instructions>>
+ [ [ temp-vregs ] [ defs-vreg ] bi [ suffix ] when* ]
+ map concat
+ ] map concat
+ [ int-rep ] H{ } map>assoc representations set ;
\ 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 0 D 0 }
+ T{ ##peek f 1 D 0 }
+ T{ ##peek f 2 D 0 }
+} 1 test-bb
+V{
+ T{ ##replace f 2 D 0 }
+} 2 test-bb
+1 2 edge
+V{
+ T{ ##replace f 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 2 H{ { 2 0 } { 3 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 ;
: test-dominance ( -- )
cfg new 0 get >>entry
- compute-predecessors
- compute-dominance ;
+ needs-dominance drop ;
! Example with no back edges
V{ } 0 test-bb
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
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs combinators sets math fry kernel math.order
dlists deques vectors namespaces sequences sorting locals
-compiler.cfg.rpo ;
+compiler.cfg.rpo compiler.cfg.predecessors ;
IN: compiler.cfg.dominance
! Reference:
H{ } clone maxpreorder set
[ 0 ] dip entry>> (compute-dfs) drop ;
+: compute-dominance ( cfg -- cfg' )
+ [ compute-dom-parents compute-dom-children ] [ compute-dfs ] [ ] tri ;
+
PRIVATE>
-: compute-dominance ( cfg -- )
- [ compute-dom-parents compute-dom-children ] [ compute-dfs ] bi ;
+: needs-dominance ( cfg -- cfg' )
+ needs-predecessors
+ dup dominance-valid?>> [ compute-dominance t >>dominance-valid? ] unless ;
: dominates? ( bb1 bb2 -- ? )
swap [ pre-of ] [ [ pre-of ] [ maxpre-of ] bi ] bi* between? ;
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors sequences combinators combinators.short-circuit
-classes vectors compiler.cfg compiler.cfg.instructions compiler.cfg.rpo ;
+USING: kernel accessors sequences namespaces combinators
+combinators.short-circuit classes vectors compiler.cfg
+compiler.cfg.instructions compiler.cfg.rpo ;
IN: compiler.cfg.empty-blocks
-
+
+<PRIVATE
+
: update-predecessor ( bb -- )
! We have to replace occurrences of bb with bb's successor
! in bb's predecessor's list of successors.
2dup eq? [ drop predecessors>> first ] [ nip ] if
] with map
] change-predecessors drop ;
-
+
+SYMBOL: changed?
+
: delete-basic-block ( bb -- )
- [ update-predecessor ] [ update-successor ] bi ;
+ [ update-predecessor ] [ update-successor ] bi
+ changed? on ;
: delete-basic-block? ( bb -- ? )
{
[ successors>> length 1 = ]
[ instructions>> first ##branch? ]
} 1&& ;
-
+
+PRIVATE>
+
: delete-empty-blocks ( cfg -- cfg' )
+ changed? off
dup [ dup delete-basic-block? [ delete-basic-block ] [ drop ] if ] each-basic-block
- cfg-changed ;
\ No newline at end of file
+ changed? get [ cfg-changed ] when ;
\ No newline at end of file
namespaces accessors sequences ;
: test-gc-checks ( -- )
+ H{ } clone representations set
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 }
+ T{ ##replace f 0 D 1 }
} 0 test-bb
V{
- T{ ##box-float f V int-regs 0 V int-regs 1 }
+ T{ ##box-float f 0 1 }
} 1 test-bb
-0 get 1 get 1vector >>successors drop
+0 1 edge
[ ] [ test-gc-checks ] unit-test
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel sequences assocs fry
+cpu.architecture
compiler.cfg.rpo
-compiler.cfg.hats
compiler.cfg.registers
compiler.cfg.instructions
compiler.cfg.stacks.uninitialized ;
IN: compiler.cfg.gc-checks
+! Garbage collection check insertion. This pass runs after representation
+! selection, so it must keep track of representations.
+
: insert-gc-check? ( bb -- ? )
instructions>> [ ##allocation? ] any? ;
: insert-gc-check ( bb -- )
dup '[
- i i f _ uninitialized-locs \ ##gc new-insn
+ int-rep next-vreg-rep
+ int-rep next-vreg-rep
+ f f _ uninitialized-locs \ ##gc new-insn
prefix
] change-instructions drop ;
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays byte-arrays kernel layouts math namespaces
+USING: accessors arrays byte-arrays kernel layouts math namespaces
sequences classes.tuple cpu.architecture compiler.cfg.registers
compiler.cfg.instructions ;
IN: compiler.cfg.hats
-: i ( -- vreg ) int-regs next-vreg ; inline
-: ^^i ( -- vreg vreg ) i dup ; inline
-: ^^i1 ( obj -- vreg vreg obj ) [ ^^i ] dip ; inline
-: ^^i2 ( obj obj -- vreg vreg obj obj ) [ ^^i ] 2dip ; inline
-: ^^i3 ( obj obj obj -- vreg vreg obj obj obj ) [ ^^i ] 3dip ; inline
+: ^^r ( -- vreg vreg ) next-vreg dup ; inline
+: ^^r1 ( obj -- vreg vreg obj ) [ ^^r ] dip ; inline
+: ^^r2 ( obj obj -- vreg vreg obj obj ) [ ^^r ] 2dip ; inline
+: ^^r3 ( obj obj obj -- vreg vreg obj obj obj ) [ ^^r ] 3dip ; inline
-: d ( -- vreg ) double-float-regs next-vreg ; inline
-: ^^d ( -- vreg vreg ) d dup ; inline
-: ^^d1 ( obj -- vreg vreg obj ) [ ^^d ] dip ; inline
-: ^^d2 ( obj obj -- vreg vreg obj obj ) [ ^^d ] 2dip ; inline
-: ^^d3 ( obj obj obj -- vreg vreg obj obj obj ) [ ^^d ] 3dip ; inline
-
-: ^^load-literal ( obj -- dst ) ^^i1 ##load-literal ; inline
-: ^^copy ( src -- dst ) ^^i1 ##copy ; inline
-: ^^slot ( obj slot tag -- dst ) ^^i3 i ##slot ; inline
-: ^^slot-imm ( obj slot tag -- dst ) ^^i3 ##slot-imm ; inline
-: ^^set-slot ( src obj slot tag -- ) i ##set-slot ; inline
-: ^^string-nth ( obj index -- dst ) ^^i2 i ##string-nth ; inline
-: ^^add ( src1 src2 -- dst ) ^^i2 ##add ; inline
-: ^^add-imm ( src1 src2 -- dst ) ^^i2 ##add-imm ; inline
-: ^^sub ( src1 src2 -- dst ) ^^i2 ##sub ; inline
-: ^^sub-imm ( src1 src2 -- dst ) ^^i2 ##sub-imm ; inline
+: ^^load-literal ( obj -- dst ) ^^r1 ##load-literal ; inline
+: ^^copy ( src -- dst ) ^^r1 any-rep ##copy ; inline
+: ^^slot ( obj slot tag -- dst ) ^^r3 next-vreg ##slot ; inline
+: ^^slot-imm ( obj slot tag -- dst ) ^^r3 ##slot-imm ; inline
+: ^^set-slot ( src obj slot tag -- ) next-vreg ##set-slot ; inline
+: ^^string-nth ( obj index -- dst ) ^^r2 next-vreg ##string-nth ; inline
+: ^^add ( src1 src2 -- dst ) ^^r2 ##add ; inline
+: ^^add-imm ( src1 src2 -- dst ) ^^r2 ##add-imm ; inline
+: ^^sub ( src1 src2 -- dst ) ^^r2 ##sub ; inline
+: ^^sub-imm ( src1 src2 -- dst ) ^^r2 ##sub-imm ; inline
: ^^neg ( src -- dst ) [ 0 ^^load-literal ] dip ^^sub ; inline
-: ^^mul ( src1 src2 -- dst ) ^^i2 ##mul ; inline
-: ^^mul-imm ( src1 src2 -- dst ) ^^i2 ##mul-imm ; inline
-: ^^and ( input mask -- output ) ^^i2 ##and ; inline
-: ^^and-imm ( input mask -- output ) ^^i2 ##and-imm ; inline
-: ^^or ( src1 src2 -- dst ) ^^i2 ##or ; inline
-: ^^or-imm ( src1 src2 -- dst ) ^^i2 ##or-imm ; inline
-: ^^xor ( src1 src2 -- dst ) ^^i2 ##xor ; inline
-: ^^xor-imm ( src1 src2 -- dst ) ^^i2 ##xor-imm ; inline
-: ^^shl ( src1 src2 -- dst ) ^^i2 ##shl ; inline
-: ^^shl-imm ( src1 src2 -- dst ) ^^i2 ##shl-imm ; inline
-: ^^shr ( src1 src2 -- dst ) ^^i2 ##shr ; inline
-: ^^shr-imm ( src1 src2 -- dst ) ^^i2 ##shr-imm ; inline
-: ^^sar ( src1 src2 -- dst ) ^^i2 ##sar ; inline
-: ^^sar-imm ( src1 src2 -- dst ) ^^i2 ##sar-imm ; inline
-: ^^not ( src -- dst ) ^^i1 ##not ; inline
-: ^^log2 ( src -- dst ) ^^i1 ##log2 ; inline
-: ^^bignum>integer ( src -- dst ) ^^i1 i ##bignum>integer ; inline
-: ^^integer>bignum ( src -- dst ) ^^i1 i ##integer>bignum ; inline
-: ^^add-float ( src1 src2 -- dst ) ^^d2 ##add-float ; inline
-: ^^sub-float ( src1 src2 -- dst ) ^^d2 ##sub-float ; inline
-: ^^mul-float ( src1 src2 -- dst ) ^^d2 ##mul-float ; inline
-: ^^div-float ( src1 src2 -- dst ) ^^d2 ##div-float ; inline
-: ^^float>integer ( src -- dst ) ^^i1 ##float>integer ; inline
-: ^^integer>float ( src -- dst ) ^^d1 ##integer>float ; inline
-: ^^allot ( size class -- dst ) ^^i2 i ##allot ; inline
+: ^^mul ( src1 src2 -- dst ) ^^r2 ##mul ; inline
+: ^^mul-imm ( src1 src2 -- dst ) ^^r2 ##mul-imm ; inline
+: ^^and ( input mask -- output ) ^^r2 ##and ; inline
+: ^^and-imm ( input mask -- output ) ^^r2 ##and-imm ; inline
+: ^^or ( src1 src2 -- dst ) ^^r2 ##or ; inline
+: ^^or-imm ( src1 src2 -- dst ) ^^r2 ##or-imm ; inline
+: ^^xor ( src1 src2 -- dst ) ^^r2 ##xor ; inline
+: ^^xor-imm ( src1 src2 -- dst ) ^^r2 ##xor-imm ; inline
+: ^^shl ( src1 src2 -- dst ) ^^r2 ##shl ; inline
+: ^^shl-imm ( src1 src2 -- dst ) ^^r2 ##shl-imm ; inline
+: ^^shr ( src1 src2 -- dst ) ^^r2 ##shr ; inline
+: ^^shr-imm ( src1 src2 -- dst ) ^^r2 ##shr-imm ; inline
+: ^^sar ( src1 src2 -- dst ) ^^r2 ##sar ; inline
+: ^^sar-imm ( src1 src2 -- dst ) ^^r2 ##sar-imm ; inline
+: ^^not ( src -- dst ) ^^r1 ##not ; inline
+: ^^log2 ( src -- dst ) ^^r1 ##log2 ; inline
+: ^^bignum>integer ( src -- dst ) ^^r1 next-vreg ##bignum>integer ; inline
+: ^^integer>bignum ( src -- dst ) ^^r1 next-vreg ##integer>bignum ; inline
+: ^^add-float ( src1 src2 -- dst ) ^^r2 ##add-float ; inline
+: ^^sub-float ( src1 src2 -- dst ) ^^r2 ##sub-float ; inline
+: ^^mul-float ( src1 src2 -- dst ) ^^r2 ##mul-float ; inline
+: ^^div-float ( src1 src2 -- dst ) ^^r2 ##div-float ; inline
+: ^^float>integer ( src -- dst ) ^^r1 ##float>integer ; inline
+: ^^integer>float ( src -- dst ) ^^r1 ##integer>float ; inline
+: ^^allot ( size class -- dst ) ^^r2 next-vreg ##allot ; inline
: ^^allot-tuple ( n -- dst ) 2 + cells tuple ^^allot ; inline
: ^^allot-array ( n -- dst ) 2 + cells array ^^allot ; inline
: ^^allot-byte-array ( n -- dst ) 2 cells + byte-array ^^allot ; inline
-: ^^box-float ( src -- dst ) ^^i1 i ##box-float ; inline
-: ^^unbox-float ( src -- dst ) ^^d1 ##unbox-float ; inline
-: ^^box-alien ( src -- dst ) ^^i1 i ##box-alien ; inline
-: ^^unbox-alien ( src -- dst ) ^^i1 ##unbox-alien ; inline
-: ^^unbox-c-ptr ( src class -- dst ) ^^i2 i ##unbox-c-ptr ;
-: ^^alien-unsigned-1 ( src -- dst ) ^^i1 ##alien-unsigned-1 ; inline
-: ^^alien-unsigned-2 ( src -- dst ) ^^i1 ##alien-unsigned-2 ; inline
-: ^^alien-unsigned-4 ( src -- dst ) ^^i1 ##alien-unsigned-4 ; inline
-: ^^alien-signed-1 ( src -- dst ) ^^i1 ##alien-signed-1 ; inline
-: ^^alien-signed-2 ( src -- dst ) ^^i1 ##alien-signed-2 ; inline
-: ^^alien-signed-4 ( src -- dst ) ^^i1 ##alien-signed-4 ; inline
-: ^^alien-cell ( src -- dst ) ^^i1 ##alien-cell ; inline
-: ^^alien-float ( src -- dst ) ^^d1 ##alien-float ; inline
-: ^^alien-double ( src -- dst ) ^^d1 ##alien-double ; inline
-: ^^alien-global ( symbol library -- dst ) ^^i2 ##alien-global ; inline
-: ^^compare ( src1 src2 cc -- dst ) ^^i3 i ##compare ; inline
-: ^^compare-imm ( src1 src2 cc -- dst ) ^^i3 i ##compare-imm ; inline
-: ^^compare-float ( src1 src2 cc -- dst ) ^^i3 i ##compare-float ; inline
+: ^^box-alien ( src -- dst ) ^^r1 next-vreg ##box-alien ; inline
+: ^^unbox-alien ( src -- dst ) ^^r1 ##unbox-alien ; inline
+: ^^unbox-c-ptr ( src class -- dst ) ^^r2 next-vreg ##unbox-c-ptr ;
+: ^^alien-unsigned-1 ( src -- dst ) ^^r1 ##alien-unsigned-1 ; inline
+: ^^alien-unsigned-2 ( src -- dst ) ^^r1 ##alien-unsigned-2 ; inline
+: ^^alien-unsigned-4 ( src -- dst ) ^^r1 ##alien-unsigned-4 ; inline
+: ^^alien-signed-1 ( src -- dst ) ^^r1 ##alien-signed-1 ; inline
+: ^^alien-signed-2 ( src -- dst ) ^^r1 ##alien-signed-2 ; inline
+: ^^alien-signed-4 ( src -- dst ) ^^r1 ##alien-signed-4 ; inline
+: ^^alien-cell ( src -- dst ) ^^r1 ##alien-cell ; inline
+: ^^alien-float ( src -- dst ) ^^r1 ##alien-float ; inline
+: ^^alien-double ( src -- dst ) ^^r1 ##alien-double ; inline
+: ^^alien-global ( symbol library -- dst ) ^^r2 ##alien-global ; inline
+: ^^compare ( src1 src2 cc -- dst ) ^^r3 next-vreg ##compare ; inline
+: ^^compare-imm ( src1 src2 cc -- dst ) ^^r3 next-vreg ##compare-imm ; inline
+: ^^compare-float ( src1 src2 cc -- dst ) ^^r3 next-vreg ##compare-float ; inline
: ^^offset>slot ( vreg -- vreg' ) cell 4 = [ 1 ^^shr-imm ] [ ^^copy ] if ; inline
-: ^^tag-fixnum ( src -- dst ) ^^i1 ##tag-fixnum ; inline
-: ^^untag-fixnum ( src -- dst ) ^^i1 ##untag-fixnum ; inline
-: ^^fixnum-add ( src1 src2 -- dst ) ^^i2 ##fixnum-add ; inline
-: ^^fixnum-sub ( src1 src2 -- dst ) ^^i2 ##fixnum-sub ; inline
-: ^^fixnum-mul ( src1 src2 -- dst ) ^^i2 ##fixnum-mul ; inline
-: ^^phi ( inputs -- dst ) ^^i1 ##phi ; inline
\ No newline at end of file
+: ^^tag-fixnum ( src -- dst ) ^^r1 ##tag-fixnum ; inline
+: ^^untag-fixnum ( src -- dst ) ^^r1 ##untag-fixnum ; inline
+: ^^fixnum-add ( src1 src2 -- dst ) ^^r2 ##fixnum-add ; inline
+: ^^fixnum-sub ( src1 src2 -- dst ) ^^r2 ##fixnum-sub ; inline
+: ^^fixnum-mul ( src1 src2 -- dst ) ^^r2 ##fixnum-mul ; inline
+: ^^phi ( inputs -- dst ) ^^r1 ##phi ; inline
\ No newline at end of file
INSN: ##integer>float < ##unary ;
! Boxing and unboxing
-INSN: ##copy < ##unary ;
-INSN: ##copy-float < ##unary ;
+INSN: ##copy < ##unary rep ;
INSN: ##unbox-float < ##unary ;
INSN: ##unbox-any-c-ptr < ##unary/temp ;
INSN: ##box-float < ##unary/temp ;
INSN: ##fixnum-sub < ##fixnum-overflow ;
INSN: ##fixnum-mul < ##fixnum-overflow ;
-INSN: ##gc temp1 temp2 live-values uninitialized-locs ;
+INSN: ##gc temp1 temp2 data-values tagged-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 uninitialized-locs ;
+INSN: _gc temp1 temp2 data-values tagged-values uninitialized-locs ;
! These instructions operate on machine registers and not
! virtual registers
-INSN: _spill src class n ;
-INSN: _reload dst class n ;
-INSN: _copy dst src class ;
-INSN: _spill-counts counts ;
+INSN: _spill src rep n ;
+INSN: _reload dst rep n ;
+INSN: _spill-area-size n ;
! Instructions that use vregs
UNION: vreg-insn
##alien-indirect
##alien-callback ;
+! Instructions that output floats
+UNION: output-float-insn
+ ##add-float
+ ##sub-float
+ ##mul-float
+ ##div-float
+ ##integer>float
+ ##unbox-float
+ ##alien-float
+ ##alien-double ;
+
+! Instructions that take floats as inputs
+UNION: input-float-insn
+ ##add-float
+ ##sub-float
+ ##mul-float
+ ##div-float
+ ##float>integer
+ ##box-float
+ ##set-alien-float
+ ##set-alien-double
+ ##compare-float
+ ##compare-float-branch ;
+
+! Smackdown
+INTERSECTION: ##unary-float ##unary input-float-insn ;
+INTERSECTION: ##binary-float ##binary input-float-insn ;
+
! Instructions that have complex expansions and require that the
! output registers are not equal to any of the input registers
UNION: def-is-use-insn
inline-alien ; inline
: inline-alien-float-setter ( node quot -- )
- '[ ds-pop ^^unbox-float @ ]
+ '[ ds-pop @ ]
[ float inline-alien-setter? ]
inline-alien ; inline
: emit-alien-cell-setter ( node -- )
[ ##set-alien-cell ] inline-alien-cell-setter ;
-: emit-alien-float-getter ( node reg-class -- )
+: emit-alien-float-getter ( node rep -- )
'[
_ {
- { single-float-regs [ ^^alien-float ] }
- { double-float-regs [ ^^alien-double ] }
- } case ^^box-float
+ { single-float-rep [ ^^alien-float ] }
+ { double-float-rep [ ^^alien-double ] }
+ } case
] inline-alien-getter ;
-: emit-alien-float-setter ( node reg-class -- )
+: emit-alien-float-setter ( node rep -- )
'[
_ {
- { single-float-regs [ ##set-alien-float ] }
- { double-float-regs [ ##set-alien-double ] }
+ { single-float-rep [ ##set-alien-float ] }
+ { double-float-rep [ ##set-alien-double ] }
} case
] inline-alien-float-setter ;
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel compiler.cfg.stacks compiler.cfg.hats
compiler.cfg.instructions compiler.cfg.utilities ;
IN: compiler.cfg.intrinsics.float
: emit-float-op ( insn -- )
- [ 2inputs [ ^^unbox-float ] bi@ ] dip call ^^box-float
- ds-push ; inline
+ [ 2inputs ] dip call ds-push ; inline
: emit-float-comparison ( cc -- )
- [ 2inputs [ ^^unbox-float ] bi@ ] dip ^^compare-float
- ds-push ; inline
+ [ 2inputs ] dip ^^compare-float ds-push ; inline
: emit-float>fixnum ( -- )
- ds-pop ^^unbox-float ^^float>integer ^^tag-fixnum ds-push ;
+ ds-pop ^^float>integer ^^tag-fixnum ds-push ;
: emit-fixnum>float ( -- )
- ds-pop ^^untag-fixnum ^^integer>float ^^box-float ds-push ;
+ ds-pop ^^untag-fixnum ^^integer>float ds-push ;
{ \ alien.accessors:set-alien-signed-4 [ 4 emit-alien-integer-setter ] }
{ \ alien.accessors:alien-cell [ emit-alien-cell-getter ] }
{ \ alien.accessors:set-alien-cell [ emit-alien-cell-setter ] }
- { \ alien.accessors:alien-float [ single-float-regs emit-alien-float-getter ] }
- { \ alien.accessors:set-alien-float [ single-float-regs emit-alien-float-setter ] }
- { \ alien.accessors:alien-double [ double-float-regs emit-alien-float-getter ] }
- { \ alien.accessors:set-alien-double [ double-float-regs emit-alien-float-setter ] }
+ { \ alien.accessors:alien-float [ single-float-rep emit-alien-float-getter ] }
+ { \ alien.accessors:set-alien-float [ single-float-rep emit-alien-float-setter ] }
+ { \ alien.accessors:alien-double [ double-float-rep emit-alien-float-getter ] }
+ { \ alien.accessors:set-alien-double [ double-float-rep emit-alien-float-setter ] }
} case ;
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: layouts namespaces kernel accessors sequences
-classes.algebra compiler.tree.propagation.info
-compiler.cfg.stacks compiler.cfg.hats compiler.cfg.instructions
+USING: layouts namespaces kernel accessors sequences classes.algebra
+compiler.tree.propagation.info compiler.cfg.stacks compiler.cfg.hats
+compiler.cfg.registers compiler.cfg.instructions
compiler.cfg.utilities compiler.cfg.builder.blocks ;
IN: compiler.cfg.intrinsics.slots
dup third value-info-small-fixnum?
[ (emit-set-slot-imm) ] [ (emit-set-slot) ] if
] [ first class>> immediate class<= ] bi
- [ drop ] [ i i ##write-barrier ] if
+ [ drop ] [ next-vreg next-vreg ##write-barrier ] if
] [ drop emit-primitive ] if ;
: emit-string-nth ( -- )
: emit-set-string-nth-fast ( -- )
3inputs [ ^^untag-fixnum ] [ ^^untag-fixnum ] [ ] tri*
- swap i ##set-string-nth-fast ;
+ swap next-vreg ##set-string-nth-fast ;
USING: accessors assocs heaps kernel namespaces sequences fry math
math.order combinators arrays sorting compiler.utilities
compiler.cfg.linear-scan.live-intervals
-compiler.cfg.linear-scan.allocation.coalescing
compiler.cfg.linear-scan.allocation.spilling
compiler.cfg.linear-scan.allocation.splitting
compiler.cfg.linear-scan.allocation.state ;
second 0 = ; inline
: assign-register ( new -- )
- dup coalesce? [ coalesce ] [
- dup register-status {
- { [ dup no-free-registers? ] [ drop assign-blocked-register ] }
- { [ 2dup register-available? ] [ register-available ] }
- [ drop assign-blocked-register ]
- } cond
- ] if ;
+ dup register-status {
+ { [ dup no-free-registers? ] [ drop assign-blocked-register ] }
+ { [ 2dup register-available? ] [ register-available ] }
+ [ drop assign-blocked-register ]
+ } cond ;
: handle-interval ( live-interval -- )
[
+++ /dev/null
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel sequences namespaces assocs fry
-combinators.short-circuit
-compiler.cfg.linear-scan.live-intervals
-compiler.cfg.linear-scan.allocation.state ;
-IN: compiler.cfg.linear-scan.allocation.coalescing
-
-: active-interval ( vreg -- live-interval )
- dup [ dup active-intervals-for [ vreg>> = ] with find nip ] when ;
-
-: avoids-inactive-intervals? ( live-interval -- ? )
- dup vreg>> inactive-intervals-for
- [ intervals-intersect? not ] with all? ;
-
-: coalesce? ( live-interval -- ? )
- {
- [ copy-from>> active-interval ]
- [ [ start>> ] [ copy-from>> active-interval end>> ] bi = ]
- [ avoids-inactive-intervals? ]
- } 1&& ;
-
-: reuse-spill-slot ( old new -- )
- [ vreg>> spill-slots get at ] dip '[ _ vreg>> spill-slots get set-at ] when* ;
-
-: reuse-register ( old new -- )
- reg>> >>reg drop ;
-
-: (coalesce) ( old new -- )
- [ add-active ] [ [ delete-active ] [ add-handled ] bi ] bi* ;
-
-: coalesce ( live-interval -- )
- dup copy-from>> active-interval
- [ reuse-spill-slot ] [ reuse-register ] [ (coalesce) ] 2tri ;
-
\ No newline at end of file
f >>spill-to ; inline
: split-after ( after -- after' )
- f >>copy-from f >>reg f >>reload-from ; inline
+ f >>reg f >>reload-from ; inline
:: split-interval ( live-interval n -- before after )
live-interval n check-split
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs combinators cpu.architecture fry heaps
kernel math math.order namespaces sequences vectors
+compiler.cfg compiler.cfg.registers
compiler.cfg.linear-scan.live-intervals ;
IN: compiler.cfg.linear-scan.allocation.state
SYMBOL: active-intervals
: active-intervals-for ( vreg -- seq )
- reg-class>> active-intervals get at ;
+ rep-of reg-class-of active-intervals get at ;
: add-active ( live-interval -- )
dup vreg>> active-intervals-for push ;
SYMBOL: inactive-intervals
: inactive-intervals-for ( vreg -- seq )
- reg-class>> inactive-intervals get at ;
+ rep-of reg-class-of inactive-intervals get at ;
: add-inactive ( live-interval -- )
dup vreg>> inactive-intervals-for push ;
[ dup start>> unhandled-intervals get heap-push ]
bi ;
-CONSTANT: reg-classes { int-regs double-float-regs }
-
: reg-class-assoc ( quot -- assoc )
[ reg-classes ] dip { } map>assoc ; inline
-! Mapping from register classes to spill counts
-SYMBOL: spill-counts
-
-: next-spill-slot ( reg-class -- n )
- spill-counts get [ dup 1 + ] change-at ;
+: next-spill-slot ( rep -- n )
+ rep-size cfg get
+ [ swap [ align dup ] [ + ] bi ] change-spill-area-size drop ;
! Mapping from vregs to spill slots
SYMBOL: spill-slots
: assign-spill-slot ( vreg -- n )
- spill-slots get [ reg-class>> next-spill-slot ] cache ;
+ spill-slots get [ rep-of next-spill-slot ] cache ;
: init-allocator ( registers -- )
registers set
[ V{ } clone ] reg-class-assoc active-intervals set
[ V{ } clone ] reg-class-assoc inactive-intervals set
V{ } clone handled-intervals set
- [ 0 ] reg-class-assoc spill-counts set
+ cfg get 0 >>spill-area-size drop
H{ } clone spill-slots set
-1 progress set ;
! A utility used by register-status and spill-status words
: free-positions ( new -- assoc )
- vreg>> reg-class>> registers get at [ 1/0. ] H{ } map>assoc ;
+ vreg>> rep-of reg-class-of registers get at [ 1/0. ] H{ } map>assoc ;
: add-use-position ( n reg assoc -- ) [ [ min ] when* ] change-at ;
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel math assocs namespaces sequences heaps
-fry make combinators sets locals
+fry make combinators sets locals arrays
cpu.architecture
compiler.cfg
-compiler.cfg.rpo
compiler.cfg.def-use
compiler.cfg.liveness
compiler.cfg.registers
compiler.cfg.instructions
compiler.cfg.renaming.functor
+compiler.cfg.linearization.order
compiler.cfg.linear-scan.allocation
compiler.cfg.linear-scan.allocation.state
compiler.cfg.linear-scan.live-intervals ;
init-unhandled ;
: insert-spill ( live-interval -- )
- [ reg>> ] [ vreg>> reg-class>> ] [ spill-to>> ] tri _spill ;
+ [ reg>> ] [ vreg>> rep-of ] [ spill-to>> ] tri _spill ;
: handle-spill ( live-interval -- )
dup spill-to>> [ insert-spill ] [ drop ] if ;
pending-interval-heap get (expire-old-intervals) ;
: insert-reload ( live-interval -- )
- [ reg>> ] [ vreg>> reg-class>> ] [ reload-from>> ] tri _reload ;
+ [ reg>> ] [ vreg>> rep-of ] [ reload-from>> ] tri _reload ;
: handle-reload ( live-interval -- )
dup reload-from>> [ insert-reload ] [ drop ] if ;
M: vreg-insn assign-registers-in-insn
[ assign-insn-defs ] [ assign-insn-uses ] [ assign-insn-temps ] tri ;
+! TODO: needs tagged-rep
+
+: trace-on-gc ( assoc -- assoc' )
+ ! When a GC occurs, virtual registers which contain tagged data
+ ! are traced by the GC. Outputs a sequence physical registers.
+ [ drop rep-of int-rep eq? ] { } assoc-filter-as values ;
+
+: spill-on-gc? ( vreg reg -- ? )
+ [ rep-of int-rep? not ] [ spill-slot? not ] bi* and ;
+
+: spill-on-gc ( assoc -- assoc' )
+ ! When a GC occurs, virtual registers which contain untagged data,
+ ! and are stored in physical registers, are saved to their spill
+ ! slots. Outputs sequence of triples:
+ ! - physical register
+ ! - spill slot
+ ! - representation
+ [
+ [
+ 2dup spill-on-gc?
+ [ swap [ assign-spill-slot ] [ rep-of ] bi 3array , ] [ 2drop ] if
+ ] assoc-each
+ ] { } make ;
+
M: ##gc assign-registers-in-insn
- ! This works because ##gc is always the first instruction
- ! in a block.
+ ! Since ##gc is always the first instruction in a block, the set of
+ ! values live at the ##gc is just live-in.
dup call-next-method
- basic-block get register-live-ins get at >>live-values
+ basic-block get register-live-ins get at
+ [ trace-on-gc >>tagged-values ] [ spill-on-gc >>data-values ] bi
drop ;
M: insn assign-registers-in-insn drop ;
: assign-registers ( live-intervals cfg -- )
[ init-assignment ] dip
- [ assign-registers-in-block ] each-basic-block ;
+ linearization-order [ assign-registers-in-block ] each ;
: interval-picture ( interval -- str )
[ uses>> picture ]
- [ copy-from>> unparse ]
[ vreg>> unparse ]
- tri 3array ;
+ bi 2array ;
: live-intervals. ( seq -- )
[ interval-picture ] map simple-table. ;
IN: compiler.cfg.linear-scan.tests
USING: tools.test random sorting sequences sets hashtables assocs
kernel fry arrays splitting namespaces math accessors vectors locals
-math.order grouping strings strings.private classes
+math.order grouping strings strings.private classes layouts
cpu.architecture
compiler.cfg
compiler.cfg.optimizer
compiler.cfg.rpo
compiler.cfg.linearization
compiler.cfg.debugger
+compiler.cfg.def-use
compiler.cfg.comparisons
compiler.cfg.linear-scan
compiler.cfg.linear-scan.numbering
{ T{ live-range f 0 5 } } 0 split-ranges
] unit-test
-H{ { int-regs 10 } { float-regs 20 } } clone spill-counts set
+cfg new 0 >>spill-area-size cfg set
H{ } spill-slots set
+H{
+ { 1 single-float-rep }
+ { 2 single-float-rep }
+ { 3 single-float-rep }
+} representations set
+
[
T{ live-interval
- { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+ { vreg 1 }
{ start 0 }
{ end 2 }
{ uses V{ 0 1 } }
{ ranges V{ T{ live-range f 0 2 } } }
- { spill-to 10 }
+ { spill-to 0 }
}
T{ live-interval
- { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+ { vreg 1 }
{ start 5 }
{ end 5 }
{ uses V{ 5 } }
{ ranges V{ T{ live-range f 5 5 } } }
- { reload-from 10 }
+ { reload-from 0 }
}
] [
T{ live-interval
- { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+ { vreg 1 }
{ start 0 }
{ end 5 }
{ uses V{ 0 1 5 } }
[
T{ live-interval
- { vreg T{ vreg { reg-class int-regs } { n 2 } } }
+ { vreg 2 }
{ start 0 }
{ end 1 }
{ uses V{ 0 } }
{ ranges V{ T{ live-range f 0 1 } } }
- { spill-to 11 }
+ { spill-to 4 }
}
T{ live-interval
- { vreg T{ vreg { reg-class int-regs } { n 2 } } }
+ { vreg 2 }
{ start 1 }
{ end 5 }
{ uses V{ 1 5 } }
{ ranges V{ T{ live-range f 1 5 } } }
- { reload-from 11 }
+ { reload-from 4 }
}
] [
T{ live-interval
- { vreg T{ vreg { reg-class int-regs } { n 2 } } }
+ { vreg 2 }
{ start 0 }
{ end 5 }
{ uses V{ 0 1 5 } }
[
T{ live-interval
- { vreg T{ vreg { reg-class int-regs } { n 3 } } }
+ { vreg 3 }
{ start 0 }
{ end 1 }
{ uses V{ 0 } }
{ ranges V{ T{ live-range f 0 1 } } }
- { spill-to 12 }
+ { spill-to 8 }
}
T{ live-interval
- { vreg T{ vreg { reg-class int-regs } { n 3 } } }
+ { vreg 3 }
{ start 20 }
{ end 30 }
{ uses V{ 20 30 } }
{ ranges V{ T{ live-range f 20 30 } } }
- { reload-from 12 }
+ { reload-from 8 }
}
] [
T{ live-interval
- { vreg T{ vreg { reg-class int-regs } { n 3 } } }
+ { vreg 3 }
{ start 0 }
{ end 30 }
{ uses V{ 0 20 30 } }
} 10 split-for-spill
] unit-test
+H{
+ { 1 int-rep }
+ { 2 int-rep }
+ { 3 int-rep }
+} representations set
+
[
{
3
{ int-regs
V{
T{ live-interval
- { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+ { vreg 1 }
{ reg 1 }
{ start 1 }
{ end 15 }
{ uses V{ 1 3 7 10 15 } }
}
T{ live-interval
- { vreg T{ vreg { reg-class int-regs } { n 2 } } }
+ { vreg 2 }
{ reg 2 }
{ start 3 }
{ end 8 }
{ uses V{ 3 4 8 } }
}
T{ live-interval
- { vreg T{ vreg { reg-class int-regs } { n 3 } } }
+ { vreg 3 }
{ reg 3 }
{ start 3 }
{ end 10 }
} active-intervals set
H{ } inactive-intervals set
T{ live-interval
- { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+ { vreg 1 }
{ start 5 }
{ end 5 }
{ uses V{ 5 } }
{ int-regs
V{
T{ live-interval
- { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+ { vreg 1 }
{ reg 1 }
{ start 1 }
{ end 15 }
{ uses V{ 1 } }
}
T{ live-interval
- { vreg T{ vreg { reg-class int-regs } { n 2 } } }
+ { vreg 2 }
{ reg 2 }
{ start 3 }
{ end 8 }
} active-intervals set
H{ } inactive-intervals set
T{ live-interval
- { vreg T{ vreg { reg-class int-regs } { n 3 } } }
+ { vreg 3 }
{ start 5 }
{ end 5 }
{ uses V{ 5 } }
spill-status
] unit-test
+H{ { 1 int-rep } { 2 int-rep } } representations set
+
[ ] [
{
T{ live-interval
- { vreg T{ vreg { n 1 } { reg-class int-regs } } }
+ { vreg 1 }
{ start 0 }
{ end 100 }
{ uses V{ 0 100 } }
[ ] [
{
T{ live-interval
- { vreg T{ vreg { n 1 } { reg-class int-regs } } }
+ { vreg 1 }
{ start 0 }
{ end 10 }
{ uses V{ 0 10 } }
{ ranges V{ T{ live-range f 0 10 } } }
}
T{ live-interval
- { vreg T{ vreg { n 2 } { reg-class int-regs } } }
+ { vreg 2 }
{ start 11 }
{ end 20 }
{ uses V{ 11 20 } }
[ ] [
{
T{ live-interval
- { vreg T{ vreg { n 1 } { reg-class int-regs } } }
+ { vreg 1 }
{ start 0 }
{ end 100 }
{ uses V{ 0 100 } }
{ ranges V{ T{ live-range f 0 100 } } }
}
T{ live-interval
- { vreg T{ vreg { n 2 } { reg-class int-regs } } }
+ { vreg 2 }
{ start 30 }
{ end 60 }
{ uses V{ 30 60 } }
[ ] [
{
T{ live-interval
- { vreg T{ vreg { n 1 } { reg-class int-regs } } }
+ { vreg 1 }
{ start 0 }
{ end 100 }
{ uses V{ 0 100 } }
{ ranges V{ T{ live-range f 0 100 } } }
}
T{ live-interval
- { vreg T{ vreg { n 2 } { reg-class int-regs } } }
+ { vreg 2 }
{ start 30 }
{ end 200 }
{ uses V{ 30 200 } }
[
{
T{ live-interval
- { vreg T{ vreg { n 1 } { reg-class int-regs } } }
+ { vreg 1 }
{ start 0 }
{ end 100 }
{ uses V{ 0 100 } }
{ ranges V{ T{ live-range f 0 100 } } }
}
T{ live-interval
- { vreg T{ vreg { n 2 } { reg-class int-regs } } }
+ { vreg 2 }
{ start 30 }
{ end 100 }
{ uses V{ 30 100 } }
] must-fail
! Problem with spilling intervals with no more usages after the spill location
+H{
+ { 1 int-rep }
+ { 2 int-rep }
+ { 3 int-rep }
+ { 4 int-rep }
+ { 5 int-rep }
+} representations set
[ ] [
{
T{ live-interval
- { vreg T{ vreg { n 1 } { reg-class int-regs } } }
+ { vreg 1 }
{ 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 } } }
+ { vreg 2 }
{ 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 } } }
+ { vreg 3 }
{ 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 } } }
+ { vreg 4 }
{ start 4 }
{ end 8 }
{ uses V{ 8 } }
! This guy will invoke the 'spill partially available' code path
T{ live-interval
- { vreg T{ vreg { n 5 } { reg-class int-regs } } }
+ { vreg 5 }
{ start 4 }
{ end 8 }
{ uses V{ 8 } }
check-linear-scan
] unit-test
-
! Test spill-new code path
[ ] [
{
T{ live-interval
- { vreg T{ vreg { n 1 } { reg-class int-regs } } }
+ { vreg 1 }
{ start 0 }
{ end 10 }
{ uses V{ 0 6 10 } }
! This guy will invoke the 'spill new' code path
T{ live-interval
- { vreg T{ vreg { n 5 } { reg-class int-regs } } }
+ { vreg 5 }
{ start 2 }
{ end 8 }
{ uses V{ 8 } }
check-linear-scan
] unit-test
-SYMBOL: available
-
-SYMBOL: taken
-
-SYMBOL: max-registers
-
-SYMBOL: max-insns
-
-SYMBOL: max-uses
-
-: not-taken ( -- n )
- available get keys dup empty? [ "Oops" throw ] when
- random
- dup taken get nth 1 + max-registers get = [
- dup available get delete-at
- ] [
- dup taken get [ 1 + ] change-nth
- ] if ;
-
-: random-live-intervals ( num-intervals max-uses max-registers max-insns -- seq )
- [
- max-insns set
- max-registers set
- max-uses set
- max-insns get [ 0 ] replicate taken set
- max-insns get [ dup ] H{ } map>assoc available set
- [
- \ live-interval new
- swap int-regs swap vreg boa >>vreg
- max-uses get random 2 max [ not-taken 2 * ] replicate natural-sort
- [ >>uses ] [ first >>start ] bi
- dup uses>> last >>end
- dup [ start>> ] [ end>> ] bi <live-range> 1vector >>ranges
- ] map
- ] with-scope ;
-
-: random-test ( num-intervals max-uses max-registers max-insns -- )
- over [ random-live-intervals ] dip int-regs associate check-linear-scan ;
-
-[ ] [ 30 2 1 60 random-test ] unit-test
-[ ] [ 60 2 2 60 random-test ] unit-test
-[ ] [ 80 2 3 200 random-test ] unit-test
-[ ] [ 70 2 5 30 random-test ] unit-test
-[ ] [ 60 2 6 30 random-test ] unit-test
-[ ] [ 1 2 10 10 random-test ] unit-test
-
-[ ] [ 10 4 2 60 random-test ] unit-test
-[ ] [ 10 20 2 400 random-test ] unit-test
-[ ] [ 10 20 4 300 random-test ] unit-test
-
-USING: math.private ;
-
-[ ] [
- [ float+ float>fixnum 3 fixnum*fast ]
- test-cfg first optimize-cfg linear-scan drop
-] unit-test
-
-: fake-live-ranges ( seq -- seq' )
- [
- clone dup [ start>> ] [ end>> ] bi <live-range> 1vector >>ranges
- ] map ;
-
-! Coalescing interacted badly with splitting
-[ ] [
- {
- T{ live-interval
- { vreg V int-regs 70 }
- { start 14 }
- { end 17 }
- { uses V{ 14 15 16 17 } }
- { copy-from V int-regs 67 }
- }
- T{ live-interval
- { vreg V int-regs 67 }
- { start 13 }
- { end 14 }
- { uses V{ 13 14 } }
- }
- T{ live-interval
- { vreg V int-regs 30 }
- { start 4 }
- { end 18 }
- { uses V{ 4 12 16 17 18 } }
- }
- T{ live-interval
- { vreg V int-regs 27 }
- { start 3 }
- { end 13 }
- { uses V{ 3 7 13 } }
- }
- T{ live-interval
- { vreg V int-regs 59 }
- { start 10 }
- { end 18 }
- { uses V{ 10 11 12 18 } }
- { copy-from V int-regs 56 }
- }
- T{ live-interval
- { vreg V int-regs 60 }
- { start 12 }
- { end 17 }
- { uses V{ 12 17 } }
- }
- T{ live-interval
- { vreg V int-regs 56 }
- { start 9 }
- { end 10 }
- { uses V{ 9 10 } }
- }
- } fake-live-ranges
- { { int-regs { 0 1 2 3 } } }
- allocate-registers drop
-] unit-test
-
-[ ] [
- {
- T{ live-interval
- { vreg V int-regs 3687168 }
- { start 106 }
- { end 112 }
- { uses V{ 106 112 } }
- }
- T{ live-interval
- { vreg V int-regs 3687169 }
- { start 107 }
- { end 113 }
- { uses V{ 107 113 } }
- }
- T{ live-interval
- { vreg V int-regs 3687727 }
- { start 190 }
- { end 198 }
- { uses V{ 190 195 198 } }
- }
- T{ live-interval
- { vreg V int-regs 3686445 }
- { start 43 }
- { end 44 }
- { uses V{ 43 44 } }
- }
- T{ live-interval
- { vreg V int-regs 3686195 }
- { start 5 }
- { end 11 }
- { uses V{ 5 11 } }
- }
- T{ live-interval
- { vreg V int-regs 3686449 }
- { start 44 }
- { end 56 }
- { uses V{ 44 45 45 46 56 } }
- { copy-from V int-regs 3686445 }
- }
- T{ live-interval
- { vreg V int-regs 3686198 }
- { start 8 }
- { end 10 }
- { uses V{ 8 9 10 } }
- }
- T{ live-interval
- { vreg V int-regs 3686454 }
- { start 46 }
- { end 49 }
- { uses V{ 46 47 47 49 } }
- { copy-from V int-regs 3686449 }
- }
- T{ live-interval
- { vreg V int-regs 3686196 }
- { start 6 }
- { end 12 }
- { uses V{ 6 12 } }
- }
- T{ live-interval
- { vreg V int-regs 3686197 }
- { start 7 }
- { end 14 }
- { uses V{ 7 13 14 } }
- }
- T{ live-interval
- { vreg V int-regs 3686455 }
- { start 48 }
- { end 51 }
- { uses V{ 48 51 } }
- }
- T{ live-interval
- { vreg V int-regs 3686463 }
- { start 52 }
- { end 53 }
- { uses V{ 52 53 } }
- }
- T{ live-interval
- { vreg V int-regs 3686460 }
- { start 49 }
- { end 52 }
- { uses V{ 49 50 50 52 } }
- { copy-from V int-regs 3686454 }
- }
- T{ live-interval
- { vreg V int-regs 3686461 }
- { start 51 }
- { end 71 }
- { uses V{ 51 52 64 68 71 } }
- }
- T{ live-interval
- { vreg V int-regs 3686464 }
- { start 53 }
- { end 54 }
- { uses V{ 53 54 } }
- }
- T{ live-interval
- { vreg V int-regs 3686465 }
- { start 54 }
- { end 76 }
- { uses V{ 54 55 55 76 } }
- { copy-from V int-regs 3686464 }
- }
- T{ live-interval
- { vreg V int-regs 3686470 }
- { start 58 }
- { end 60 }
- { uses V{ 58 59 59 60 } }
- { copy-from V int-regs 3686469 }
- }
- T{ live-interval
- { vreg V int-regs 3686469 }
- { start 56 }
- { end 58 }
- { uses V{ 56 57 57 58 } }
- { copy-from V int-regs 3686449 }
- }
- T{ live-interval
- { vreg V int-regs 3686473 }
- { start 60 }
- { end 62 }
- { uses V{ 60 61 61 62 } }
- { copy-from V int-regs 3686470 }
- }
- T{ live-interval
- { vreg V int-regs 3686479 }
- { start 62 }
- { end 64 }
- { uses V{ 62 63 63 64 } }
- { copy-from V int-regs 3686473 }
- }
- T{ live-interval
- { vreg V int-regs 3686735 }
- { start 78 }
- { end 96 }
- { uses V{ 78 79 79 96 } }
- { copy-from V int-regs 3686372 }
- }
- T{ live-interval
- { vreg V int-regs 3686482 }
- { start 64 }
- { end 65 }
- { uses V{ 64 65 } }
- }
- T{ live-interval
- { vreg V int-regs 3686483 }
- { start 65 }
- { end 66 }
- { uses V{ 65 66 } }
- }
- T{ live-interval
- { vreg V int-regs 3687510 }
- { start 168 }
- { end 171 }
- { uses V{ 168 171 } }
- }
- T{ live-interval
- { vreg V int-regs 3687511 }
- { start 169 }
- { end 176 }
- { uses V{ 169 176 } }
- }
- T{ live-interval
- { vreg V int-regs 3686484 }
- { start 66 }
- { end 75 }
- { uses V{ 66 67 67 75 } }
- { copy-from V int-regs 3686483 }
- }
- T{ live-interval
- { vreg V int-regs 3687509 }
- { start 162 }
- { end 163 }
- { uses V{ 162 163 } }
- }
- T{ live-interval
- { vreg V int-regs 3686491 }
- { start 68 }
- { end 69 }
- { uses V{ 68 69 } }
- }
- T{ live-interval
- { vreg V int-regs 3687512 }
- { start 170 }
- { end 178 }
- { uses V{ 170 177 178 } }
- }
- T{ live-interval
- { vreg V int-regs 3687515 }
- { start 172 }
- { end 173 }
- { uses V{ 172 173 } }
- }
- T{ live-interval
- { vreg V int-regs 3686492 }
- { start 69 }
- { end 74 }
- { uses V{ 69 70 70 74 } }
- { copy-from V int-regs 3686491 }
- }
- T{ live-interval
- { vreg V int-regs 3687778 }
- { start 202 }
- { end 208 }
- { uses V{ 202 208 } }
- }
- T{ live-interval
- { vreg V int-regs 3686499 }
- { start 71 }
- { end 72 }
- { uses V{ 71 72 } }
- }
- T{ live-interval
- { vreg V int-regs 3687520 }
- { start 174 }
- { end 175 }
- { uses V{ 174 175 } }
- }
- T{ live-interval
- { vreg V int-regs 3687779 }
- { start 203 }
- { end 209 }
- { uses V{ 203 209 } }
- }
- T{ live-interval
- { vreg V int-regs 3687782 }
- { start 206 }
- { end 207 }
- { uses V{ 206 207 } }
- }
- T{ live-interval
- { vreg V int-regs 3686503 }
- { start 74 }
- { end 75 }
- { uses V{ 74 75 } }
- }
- T{ live-interval
- { vreg V int-regs 3686500 }
- { start 72 }
- { end 74 }
- { uses V{ 72 73 73 74 } }
- { copy-from V int-regs 3686499 }
- }
- T{ live-interval
- { vreg V int-regs 3687780 }
- { start 204 }
- { end 210 }
- { uses V{ 204 210 } }
- }
- T{ live-interval
- { vreg V int-regs 3686506 }
- { start 75 }
- { end 76 }
- { uses V{ 75 76 } }
- }
- T{ live-interval
- { vreg V int-regs 3687530 }
- { start 185 }
- { end 192 }
- { uses V{ 185 192 } }
- }
- T{ live-interval
- { vreg V int-regs 3687528 }
- { start 183 }
- { end 198 }
- { uses V{ 183 198 } }
- }
- T{ live-interval
- { vreg V int-regs 3687529 }
- { start 184 }
- { end 197 }
- { uses V{ 184 197 } }
- }
- T{ live-interval
- { vreg V int-regs 3687781 }
- { start 205 }
- { end 211 }
- { uses V{ 205 211 } }
- }
- T{ live-interval
- { vreg V int-regs 3687535 }
- { start 187 }
- { end 194 }
- { uses V{ 187 194 } }
- }
- T{ live-interval
- { vreg V int-regs 3686252 }
- { start 9 }
- { end 17 }
- { uses V{ 9 15 17 } }
- }
- T{ live-interval
- { vreg V int-regs 3686509 }
- { start 76 }
- { end 90 }
- { uses V{ 76 87 90 } }
- }
- T{ live-interval
- { vreg V int-regs 3687532 }
- { start 186 }
- { end 196 }
- { uses V{ 186 196 } }
- }
- T{ live-interval
- { vreg V int-regs 3687538 }
- { start 188 }
- { end 193 }
- { uses V{ 188 193 } }
- }
- T{ live-interval
- { vreg V int-regs 3687827 }
- { start 217 }
- { end 219 }
- { uses V{ 217 219 } }
- }
- T{ live-interval
- { vreg V int-regs 3687825 }
- { start 215 }
- { end 218 }
- { uses V{ 215 216 218 } }
- }
- T{ live-interval
- { vreg V int-regs 3687831 }
- { start 218 }
- { end 219 }
- { uses V{ 218 219 } }
- }
- T{ live-interval
- { vreg V int-regs 3686296 }
- { start 16 }
- { end 18 }
- { uses V{ 16 18 } }
- }
- T{ live-interval
- { vreg V int-regs 3686302 }
- { start 29 }
- { end 31 }
- { uses V{ 29 31 } }
- }
- T{ live-interval
- { vreg V int-regs 3687838 }
- { start 231 }
- { end 232 }
- { uses V{ 231 232 } }
- }
- T{ live-interval
- { vreg V int-regs 3686300 }
- { start 26 }
- { end 27 }
- { uses V{ 26 27 } }
- }
- T{ live-interval
- { vreg V int-regs 3686301 }
- { start 27 }
- { end 30 }
- { uses V{ 27 28 28 30 } }
- { copy-from V int-regs 3686300 }
- }
- T{ live-interval
- { vreg V int-regs 3686306 }
- { start 37 }
- { end 93 }
- { uses V{ 37 82 93 } }
- }
- T{ live-interval
- { vreg V int-regs 3686307 }
- { start 38 }
- { end 88 }
- { uses V{ 38 85 88 } }
- }
- T{ live-interval
- { vreg V int-regs 3687837 }
- { start 222 }
- { end 223 }
- { uses V{ 222 223 } }
- }
- T{ live-interval
- { vreg V int-regs 3686305 }
- { start 36 }
- { end 81 }
- { uses V{ 36 42 77 81 } }
- }
- T{ live-interval
- { vreg V int-regs 3686310 }
- { start 39 }
- { end 95 }
- { uses V{ 39 84 95 } }
- }
- T{ live-interval
- { vreg V int-regs 3687836 }
- { start 227 }
- { end 228 }
- { uses V{ 227 228 } }
- }
- T{ live-interval
- { vreg V int-regs 3687839 }
- { start 239 }
- { end 246 }
- { uses V{ 239 245 246 } }
- }
- T{ live-interval
- { vreg V int-regs 3687841 }
- { start 240 }
- { end 241 }
- { uses V{ 240 241 } }
- }
- T{ live-interval
- { vreg V int-regs 3687845 }
- { start 241 }
- { end 243 }
- { uses V{ 241 243 } }
- }
- T{ live-interval
- { vreg V int-regs 3686315 }
- { start 40 }
- { end 94 }
- { uses V{ 40 83 94 } }
- }
- T{ live-interval
- { vreg V int-regs 3687846 }
- { start 242 }
- { end 245 }
- { uses V{ 242 245 } }
- }
- T{ live-interval
- { vreg V int-regs 3687849 }
- { start 243 }
- { end 245 }
- { uses V{ 243 244 244 245 } }
- { copy-from V int-regs 3687845 }
- }
- T{ live-interval
- { vreg V int-regs 3687850 }
- { start 245 }
- { end 245 }
- { uses V{ 245 } }
- }
- T{ live-interval
- { vreg V int-regs 3687851 }
- { start 246 }
- { end 246 }
- { uses V{ 246 } }
- }
- T{ live-interval
- { vreg V int-regs 3687852 }
- { start 246 }
- { end 246 }
- { uses V{ 246 } }
- }
- T{ live-interval
- { vreg V int-regs 3687853 }
- { start 247 }
- { end 248 }
- { uses V{ 247 248 } }
- }
- T{ live-interval
- { vreg V int-regs 3687854 }
- { start 249 }
- { end 250 }
- { uses V{ 249 250 } }
- }
- T{ live-interval
- { vreg V int-regs 3687855 }
- { start 258 }
- { end 259 }
- { uses V{ 258 259 } }
- }
- T{ live-interval
- { vreg V int-regs 3687080 }
- { start 280 }
- { end 285 }
- { uses V{ 280 285 } }
- }
- T{ live-interval
- { vreg V int-regs 3687081 }
- { start 281 }
- { end 286 }
- { uses V{ 281 286 } }
- }
- T{ live-interval
- { vreg V int-regs 3687082 }
- { start 282 }
- { end 287 }
- { uses V{ 282 287 } }
- }
- T{ live-interval
- { vreg V int-regs 3687083 }
- { start 283 }
- { end 288 }
- { uses V{ 283 288 } }
- }
- T{ live-interval
- { vreg V int-regs 3687085 }
- { start 284 }
- { end 299 }
- { uses V{ 284 285 286 287 288 296 299 } }
- }
- T{ live-interval
- { vreg V int-regs 3687086 }
- { start 284 }
- { end 284 }
- { uses V{ 284 } }
- }
- T{ live-interval
- { vreg V int-regs 3687087 }
- { start 289 }
- { end 293 }
- { uses V{ 289 293 } }
- }
- T{ live-interval
- { vreg V int-regs 3687088 }
- { start 290 }
- { end 294 }
- { uses V{ 290 294 } }
- }
- T{ live-interval
- { vreg V int-regs 3687089 }
- { start 291 }
- { end 297 }
- { uses V{ 291 297 } }
- }
- T{ live-interval
- { vreg V int-regs 3687090 }
- { start 292 }
- { end 298 }
- { uses V{ 292 298 } }
- }
- T{ live-interval
- { vreg V int-regs 3687363 }
- { start 118 }
- { end 119 }
- { uses V{ 118 119 } }
- }
- T{ live-interval
- { vreg V int-regs 3686599 }
- { start 77 }
- { end 89 }
- { uses V{ 77 86 89 } }
- }
- T{ live-interval
- { vreg V int-regs 3687370 }
- { start 131 }
- { end 132 }
- { uses V{ 131 132 } }
- }
- T{ live-interval
- { vreg V int-regs 3687371 }
- { start 138 }
- { end 143 }
- { uses V{ 138 143 } }
- }
- T{ live-interval
- { vreg V int-regs 3687368 }
- { start 127 }
- { end 128 }
- { uses V{ 127 128 } }
- }
- T{ live-interval
- { vreg V int-regs 3687369 }
- { start 122 }
- { end 123 }
- { uses V{ 122 123 } }
- }
- T{ live-interval
- { vreg V int-regs 3687373 }
- { start 139 }
- { end 140 }
- { uses V{ 139 140 } }
- }
- T{ live-interval
- { vreg V int-regs 3686352 }
- { start 41 }
- { end 91 }
- { uses V{ 41 43 79 91 } }
- }
- T{ live-interval
- { vreg V int-regs 3687377 }
- { start 140 }
- { end 141 }
- { uses V{ 140 141 } }
- }
- T{ live-interval
- { vreg V int-regs 3687382 }
- { start 143 }
- { end 143 }
- { uses V{ 143 } }
- }
- T{ live-interval
- { vreg V int-regs 3687383 }
- { start 144 }
- { end 161 }
- { uses V{ 144 159 161 } }
- }
- T{ live-interval
- { vreg V int-regs 3687380 }
- { start 141 }
- { end 143 }
- { uses V{ 141 142 142 143 } }
- { copy-from V int-regs 3687377 }
- }
- T{ live-interval
- { vreg V int-regs 3687381 }
- { start 143 }
- { end 160 }
- { uses V{ 143 160 } }
- }
- T{ live-interval
- { vreg V int-regs 3687384 }
- { start 145 }
- { end 158 }
- { uses V{ 145 158 } }
- }
- T{ live-interval
- { vreg V int-regs 3687385 }
- { start 146 }
- { end 157 }
- { uses V{ 146 157 } }
- }
- T{ live-interval
- { vreg V int-regs 3687640 }
- { start 189 }
- { end 191 }
- { uses V{ 189 191 } }
- }
- T{ live-interval
- { vreg V int-regs 3687388 }
- { start 147 }
- { end 152 }
- { uses V{ 147 152 } }
- }
- T{ live-interval
- { vreg V int-regs 3687393 }
- { start 148 }
- { end 153 }
- { uses V{ 148 153 } }
- }
- T{ live-interval
- { vreg V int-regs 3687398 }
- { start 149 }
- { end 154 }
- { uses V{ 149 154 } }
- }
- T{ live-interval
- { vreg V int-regs 3686372 }
- { start 42 }
- { end 92 }
- { uses V{ 42 45 78 80 92 } }
- }
- T{ live-interval
- { vreg V int-regs 3687140 }
- { start 293 }
- { end 295 }
- { uses V{ 293 294 294 295 } }
- { copy-from V int-regs 3687087 }
- }
- T{ live-interval
- { vreg V int-regs 3687403 }
- { start 150 }
- { end 155 }
- { uses V{ 150 155 } }
- }
- T{ live-interval
- { vreg V int-regs 3687150 }
- { start 304 }
- { end 306 }
- { uses V{ 304 306 } }
- }
- T{ live-interval
- { vreg V int-regs 3687151 }
- { start 305 }
- { end 307 }
- { uses V{ 305 307 } }
- }
- T{ live-interval
- { vreg V int-regs 3687408 }
- { start 151 }
- { end 156 }
- { uses V{ 151 156 } }
- }
- T{ live-interval
- { vreg V int-regs 3687153 }
- { start 312 }
- { end 313 }
- { uses V{ 312 313 } }
- }
- T{ live-interval
- { vreg V int-regs 3686902 }
- { start 267 }
- { end 272 }
- { uses V{ 267 272 } }
- }
- T{ live-interval
- { vreg V int-regs 3686903 }
- { start 268 }
- { end 273 }
- { uses V{ 268 273 } }
- }
- T{ live-interval
- { vreg V int-regs 3686900 }
- { start 265 }
- { end 270 }
- { uses V{ 265 270 } }
- }
- T{ live-interval
- { vreg V int-regs 3686901 }
- { start 266 }
- { end 271 }
- { uses V{ 266 271 } }
- }
- T{ live-interval
- { vreg V int-regs 3687162 }
- { start 100 }
- { end 119 }
- { uses V{ 100 114 117 119 } }
- }
- T{ live-interval
- { vreg V int-regs 3687163 }
- { start 101 }
- { end 118 }
- { uses V{ 101 115 116 118 } }
- }
- T{ live-interval
- { vreg V int-regs 3686904 }
- { start 269 }
- { end 274 }
- { uses V{ 269 274 } }
- }
- T{ live-interval
- { vreg V int-regs 3687166 }
- { start 104 }
- { end 110 }
- { uses V{ 104 110 } }
- }
- T{ live-interval
- { vreg V int-regs 3687167 }
- { start 105 }
- { end 111 }
- { uses V{ 105 111 } }
- }
- T{ live-interval
- { vreg V int-regs 3687164 }
- { start 102 }
- { end 108 }
- { uses V{ 102 108 } }
- }
- T{ live-interval
- { vreg V int-regs 3687165 }
- { start 103 }
- { end 109 }
- { uses V{ 103 109 } }
- }
- } fake-live-ranges
- { { int-regs { 0 1 2 3 4 } } }
- allocate-registers drop
-] unit-test
-
-! A reduction of the above
-[ ] [
- {
- T{ live-interval
- { vreg V int-regs 6449 }
- { start 44 }
- { end 56 }
- { uses V{ 44 45 46 56 } }
- }
- T{ live-interval
- { vreg V int-regs 6454 }
- { start 46 }
- { end 49 }
- { uses V{ 46 47 49 } }
- }
- T{ live-interval
- { vreg V int-regs 6455 }
- { start 48 }
- { end 51 }
- { uses V{ 48 51 } }
- }
- T{ live-interval
- { vreg V int-regs 6460 }
- { start 49 }
- { end 52 }
- { uses V{ 49 50 52 } }
- }
- T{ live-interval
- { vreg V int-regs 6461 }
- { start 51 }
- { end 71 }
- { uses V{ 51 52 64 68 71 } }
- }
- T{ live-interval
- { vreg V int-regs 6464 }
- { start 53 }
- { end 54 }
- { uses V{ 53 54 } }
- }
- T{ live-interval
- { vreg V int-regs 6470 }
- { start 58 }
- { end 60 }
- { uses V{ 58 59 60 } }
- }
- T{ live-interval
- { vreg V int-regs 6469 }
- { start 56 }
- { end 58 }
- { uses V{ 56 57 58 } }
- }
- T{ live-interval
- { vreg V int-regs 6473 }
- { start 60 }
- { end 62 }
- { uses V{ 60 61 62 } }
- }
- T{ live-interval
- { vreg V int-regs 6479 }
- { start 62 }
- { end 64 }
- { uses V{ 62 63 64 } }
- }
- T{ live-interval
- { vreg V int-regs 6735 }
- { start 78 }
- { end 96 }
- { uses V{ 78 79 96 } }
- { copy-from V int-regs 6372 }
- }
- T{ live-interval
- { vreg V int-regs 6483 }
- { start 65 }
- { end 66 }
- { uses V{ 65 66 } }
- }
- T{ live-interval
- { vreg V int-regs 7845 }
- { start 91 }
- { end 93 }
- { uses V{ 91 93 } }
- }
- T{ live-interval
- { vreg V int-regs 6372 }
- { start 42 }
- { end 92 }
- { uses V{ 42 45 78 80 92 } }
- }
- } fake-live-ranges
- { { int-regs { 0 1 2 3 } } }
- allocate-registers drop
-] unit-test
-
[ f ] [
T{ live-range f 0 10 }
T{ live-range f 20 30 }
! register-status had problems because it used map>assoc where the sequence
! had multiple keys
+H{
+ { 1 int-rep }
+ { 2 int-rep }
+ { 3 int-rep }
+ { 4 int-rep }
+} representations set
+
[ { 0 10 } ] [
H{ { int-regs { 0 1 } } } registers set
H{
{ int-regs
{
T{ live-interval
- { vreg V int-regs 1 }
+ { vreg 1 }
{ start 0 }
{ end 20 }
{ reg 0 }
}
T{ live-interval
- { vreg V int-regs 2 }
+ { vreg 2 }
{ start 4 }
{ end 40 }
{ reg 0 }
{ int-regs
{
T{ live-interval
- { vreg V int-regs 3 }
+ { vreg 3 }
{ start 0 }
{ end 40 }
{ reg 1 }
} active-intervals set
T{ live-interval
- { vreg V int-regs 4 }
+ { vreg 4 }
{ start 8 }
{ end 10 }
{ ranges V{ T{ live-range f 8 10 } } }
register-status
] unit-test
+:: test-linear-scan-on-cfg ( regs -- )
+ [
+ cfg new 0 get >>entry
+ dup cfg set
+ dup fake-representations
+ dup { { int-regs regs } } (linear-scan)
+ flatten-cfg 1array mr.
+ ] with-scope ;
+
! Bug in live spill slots calculation
V{ T{ ##prologue } T{ ##branch } } 0 test-bb
V{
T{ ##peek
- { dst V int-regs 703128 }
+ { dst 703128 }
{ loc D 1 }
}
T{ ##peek
- { dst V int-regs 703129 }
+ { dst 703129 }
{ loc D 0 }
}
T{ ##copy
- { dst V int-regs 703134 }
- { src V int-regs 703128 }
+ { dst 703134 }
+ { src 703128 }
}
T{ ##copy
- { dst V int-regs 703135 }
- { src V int-regs 703129 }
+ { dst 703135 }
+ { src 703129 }
}
T{ ##compare-imm-branch
- { src1 V int-regs 703128 }
+ { src1 703128 }
{ src2 5 }
{ cc cc/= }
}
V{
T{ ##copy
- { dst V int-regs 703134 }
- { src V int-regs 703129 }
+ { dst 703134 }
+ { src 703129 }
}
T{ ##copy
- { dst V int-regs 703135 }
- { src V int-regs 703128 }
+ { dst 703135 }
+ { src 703128 }
}
T{ ##branch }
} 2 test-bb
V{
T{ ##replace
- { src V int-regs 703134 }
+ { src 703134 }
{ loc D 0 }
}
T{ ##replace
- { src V int-regs 703135 }
+ { src 703135 }
{ loc D 1 }
}
T{ ##epilogue }
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)
-
-SYMBOL: linear-scan-result
-
-:: test-linear-scan-on-cfg ( regs -- )
- [
- cfg new 0 get >>entry
- compute-predecessors
- dup { { int-regs regs } } (linear-scan)
- cfg-changed
- 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
+0 1 edge
+1 { 2 3 } edges
+2 3 edge
! Bug in inactive interval handling
! [ rot dup [ -rot ] when ]
V{
T{ ##peek
- { dst V int-regs 689473 }
+ { dst 689473 }
{ loc D 2 }
}
T{ ##peek
- { dst V int-regs 689474 }
+ { dst 689474 }
{ loc D 1 }
}
T{ ##peek
- { dst V int-regs 689475 }
+ { dst 689475 }
{ loc D 0 }
}
T{ ##compare-imm-branch
- { src1 V int-regs 689473 }
+ { src1 689473 }
{ src2 5 }
{ cc cc/= }
}
V{
T{ ##copy
- { dst V int-regs 689481 }
- { src V int-regs 689475 }
+ { dst 689481 }
+ { src 689475 }
}
T{ ##copy
- { dst V int-regs 689482 }
- { src V int-regs 689474 }
+ { dst 689482 }
+ { src 689474 }
}
T{ ##copy
- { dst V int-regs 689483 }
- { src V int-regs 689473 }
+ { dst 689483 }
+ { src 689473 }
}
T{ ##branch }
} 2 test-bb
V{
T{ ##copy
- { dst V int-regs 689481 }
- { src V int-regs 689473 }
+ { dst 689481 }
+ { src 689473 }
}
T{ ##copy
- { dst V int-regs 689482 }
- { src V int-regs 689475 }
+ { dst 689482 }
+ { src 689475 }
}
T{ ##copy
- { dst V int-regs 689483 }
- { src V int-regs 689474 }
+ { dst 689483 }
+ { src 689474 }
}
T{ ##branch }
} 3 test-bb
V{
T{ ##replace
- { src V int-regs 689481 }
+ { src 689481 }
{ loc D 0 }
}
T{ ##replace
- { src V int-regs 689482 }
+ { src 689482 }
{ loc D 1 }
}
T{ ##replace
- { src V int-regs 689483 }
+ { src 689483 }
{ loc D 2 }
}
T{ ##epilogue }
V{
T{ ##peek
- { dst V int-regs 689600 }
+ { dst 689600 }
{ loc D 1 }
}
T{ ##peek
- { dst V int-regs 689601 }
+ { dst 689601 }
{ loc D 0 }
}
T{ ##compare-imm-branch
- { src1 V int-regs 689600 }
+ { src1 689600 }
{ src2 5 }
{ cc cc/= }
}
V{
T{ ##peek
- { dst V int-regs 689604 }
+ { dst 689604 }
{ loc D 2 }
}
T{ ##copy
- { dst V int-regs 689607 }
- { src V int-regs 689604 }
+ { dst 689607 }
+ { src 689604 }
}
T{ ##copy
- { dst V int-regs 689608 }
- { src V int-regs 689600 }
+ { dst 689608 }
+ { src 689600 }
}
T{ ##copy
- { dst V int-regs 689610 }
- { src V int-regs 689601 }
+ { dst 689610 }
+ { src 689601 }
}
T{ ##branch }
} 2 test-bb
V{
T{ ##peek
- { dst V int-regs 689609 }
+ { dst 689609 }
{ loc D 2 }
}
T{ ##copy
- { dst V int-regs 689607 }
- { src V int-regs 689600 }
+ { dst 689607 }
+ { src 689600 }
}
T{ ##copy
- { dst V int-regs 689608 }
- { src V int-regs 689601 }
+ { dst 689608 }
+ { src 689601 }
}
T{ ##copy
- { dst V int-regs 689610 }
- { src V int-regs 689609 }
+ { dst 689610 }
+ { src 689609 }
}
T{ ##branch }
} 3 test-bb
V{
T{ ##replace
- { src V int-regs 689607 }
+ { src 689607 }
{ loc D 0 }
}
T{ ##replace
- { src V int-regs 689608 }
+ { src 689608 }
{ loc D 1 }
}
T{ ##replace
- { src V int-regs 689610 }
+ { src 689610 }
{ loc D 2 }
}
T{ ##epilogue }
V{
T{ ##peek
- { dst V int-regs 0 }
+ { dst 0 }
{ loc D 0 }
}
T{ ##compare-imm-branch
- { src1 V int-regs 0 }
+ { src1 0 }
{ src2 5 }
{ cc cc/= }
}
V{
T{ ##peek
- { dst V int-regs 1 }
+ { dst 1 }
{ loc D 1 }
}
T{ ##copy
- { dst V int-regs 2 }
- { src V int-regs 1 }
+ { dst 2 }
+ { src 1 }
}
T{ ##branch }
} 2 test-bb
V{
T{ ##peek
- { dst V int-regs 3 }
+ { dst 3 }
{ loc D 2 }
}
T{ ##copy
- { dst V int-regs 2 }
- { src V int-regs 3 }
+ { dst 2 }
+ { src 3 }
}
T{ ##branch }
} 3 test-bb
V{
T{ ##replace
- { src V int-regs 2 }
+ { src 2 }
{ loc D 0 }
}
T{ ##return }
! Inactive interval handling: splitting active interval
! if it fits in lifetime hole only partially
-V{ T{ ##peek f V int-regs 3 R 1 } T{ ##branch } } 0 test-bb
+V{ T{ ##peek f 3 R 1 } T{ ##branch } } 0 test-bb
V{
- T{ ##peek f V int-regs 2 R 0 }
- T{ ##compare-imm-branch f V int-regs 2 5 cc= }
+ T{ ##peek f 2 R 0 }
+ T{ ##compare-imm-branch f 2 5 cc= }
} 1 test-bb
V{
- T{ ##peek f V int-regs 0 D 0 }
+ T{ ##peek f 0 D 0 }
T{ ##branch }
} 2 test-bb
V{
- T{ ##peek f V int-regs 1 D 1 }
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##replace f V int-regs 1 D 2 }
+ T{ ##peek f 1 D 1 }
+ T{ ##peek f 0 D 0 }
+ T{ ##replace f 1 D 2 }
T{ ##branch }
} 3 test-bb
V{
- T{ ##replace f V int-regs 3 R 2 }
- T{ ##replace f V int-regs 0 D 0 }
+ T{ ##replace f 3 R 2 }
+ T{ ##replace f 0 D 0 }
T{ ##return }
} 4 test-bb
! [ _copy ] [ 3 get instructions>> second class ] unit-test
! Resolve pass; make sure the spilling is done correctly
-V{ T{ ##peek f V int-regs 3 R 1 } T{ ##branch } } 0 test-bb
+V{ T{ ##peek f 3 R 1 } T{ ##branch } } 0 test-bb
V{
- T{ ##peek f V int-regs 2 R 0 }
- T{ ##compare-imm-branch f V int-regs 2 5 cc= }
+ T{ ##peek f 2 R 0 }
+ T{ ##compare-imm-branch f 2 5 cc= }
} 1 test-bb
V{
} 2 test-bb
V{
- T{ ##replace f V int-regs 3 R 1 }
- T{ ##peek f V int-regs 1 D 1 }
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##replace f V int-regs 1 D 2 }
- T{ ##replace f V int-regs 0 D 2 }
+ T{ ##replace f 3 R 1 }
+ T{ ##peek f 1 D 1 }
+ T{ ##peek f 0 D 0 }
+ T{ ##replace f 1 D 2 }
+ T{ ##replace f 0 D 2 }
T{ ##branch }
} 3 test-bb
V{
- T{ ##replace f V int-regs 3 R 2 }
+ T{ ##replace f 3 R 2 }
T{ ##return }
} 4 test-bb
} 0 test-bb
V{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##compare-imm-branch f V int-regs 0 5 cc= }
+ T{ ##peek f 0 D 0 }
+ T{ ##compare-imm-branch f 0 5 cc= }
} 1 test-bb
V{
- T{ ##replace 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 }
- T{ ##replace f V int-regs 1 D 0 }
- T{ ##replace f V int-regs 2 D 0 }
+ T{ ##replace f 0 D 0 }
+ T{ ##peek f 1 D 0 }
+ T{ ##peek f 2 D 0 }
+ T{ ##replace f 1 D 0 }
+ T{ ##replace f 2 D 0 }
T{ ##branch }
} 2 test-bb
} 3 test-bb
V{
- T{ ##peek f V int-regs 1 D 0 }
- T{ ##compare-imm-branch f V int-regs 1 5 cc= }
+ T{ ##peek f 1 D 0 }
+ T{ ##compare-imm-branch f 1 5 cc= }
} 4 test-bb
V{
- T{ ##replace f V int-regs 0 D 0 }
+ T{ ##replace f 0 D 0 }
T{ ##return }
} 5 test-bb
V{
- T{ ##replace f V int-regs 0 D 0 }
+ T{ ##replace f 0 D 0 }
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
! got fixed
V{ T{ ##branch } } 0 test-bb
V{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##peek f V int-regs 1 D 1 }
- T{ ##peek f V int-regs 2 D 2 }
- T{ ##peek f V int-regs 3 D 3 }
- T{ ##peek f V int-regs 4 D 0 }
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##peek f 2 D 2 }
+ T{ ##peek f 3 D 3 }
+ T{ ##peek f 4 D 0 }
T{ ##branch }
} 1 test-bb
V{ T{ ##branch } } 2 test-bb
V{ T{ ##branch } } 3 test-bb
V{
- T{ ##replace f V int-regs 1 D 1 }
- T{ ##replace f V int-regs 2 D 2 }
- T{ ##replace f V int-regs 3 D 3 }
- T{ ##replace f V int-regs 4 D 4 }
- T{ ##replace f V int-regs 0 D 0 }
+ T{ ##replace f 1 D 1 }
+ T{ ##replace f 2 D 2 }
+ T{ ##replace f 3 D 3 }
+ T{ ##replace f 4 D 4 }
+ T{ ##replace f 0 D 0 }
T{ ##branch }
} 4 test-bb
-V{ T{ ##replace f V int-regs 0 D 0 } T{ ##branch } } 5 test-bb
+V{ T{ ##replace f 0 D 0 } T{ ##branch } } 5 test-bb
V{ T{ ##return } } 6 test-bb
V{ T{ ##branch } } 7 test-bb
V{
- T{ ##replace f V int-regs 1 D 1 }
- T{ ##replace f V int-regs 2 D 2 }
- T{ ##replace f V int-regs 3 D 3 }
- T{ ##peek f V int-regs 5 D 1 }
- T{ ##peek f V int-regs 6 D 2 }
- T{ ##peek f V int-regs 7 D 3 }
- T{ ##peek f V int-regs 8 D 4 }
- T{ ##replace f V int-regs 5 D 1 }
- T{ ##replace f V int-regs 6 D 2 }
- T{ ##replace f V int-regs 7 D 3 }
- T{ ##replace f V int-regs 8 D 4 }
+ T{ ##replace f 1 D 1 }
+ T{ ##replace f 2 D 2 }
+ T{ ##replace f 3 D 3 }
+ T{ ##peek f 5 D 1 }
+ T{ ##peek f 6 D 2 }
+ T{ ##peek f 7 D 3 }
+ T{ ##peek f 8 D 4 }
+ T{ ##replace f 5 D 1 }
+ T{ ##replace f 6 D 2 }
+ T{ ##replace f 7 D 3 }
+ T{ ##replace f 8 D 4 }
T{ ##branch }
} 8 test-bb
V{
- T{ ##replace f V int-regs 1 D 1 }
- T{ ##replace f V int-regs 2 D 2 }
- T{ ##replace f V int-regs 3 D 3 }
+ T{ ##replace f 1 D 1 }
+ T{ ##replace f 2 D 2 }
+ T{ ##replace f 3 D 3 }
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
[ _spill ] [ 1 get instructions>> second class ] unit-test
[ _reload ] [ 4 get instructions>> 4 swap nth class ] unit-test
-[ V{ 3 2 1 } ] [ 8 get instructions>> [ _spill? ] filter [ n>> ] map ] unit-test
-[ V{ 3 2 1 } ] [ 9 get instructions>> [ _reload? ] filter [ n>> ] map ] unit-test
+[ V{ 3 2 1 } ] [ 8 get instructions>> [ _spill? ] filter [ n>> cell / ] map ] unit-test
+[ V{ 3 2 1 } ] [ 9 get instructions>> [ _reload? ] filter [ n>> cell / ] map ] unit-test
! Resolve pass should insert this
[ _reload ] [ 5 get predecessors>> first instructions>> first class ] unit-test
! Some random bug
V{
- T{ ##peek f V int-regs 1 D 1 }
- T{ ##peek f V int-regs 2 D 2 }
- T{ ##replace f V int-regs 1 D 1 }
- T{ ##replace f V int-regs 2 D 2 }
- T{ ##peek f V int-regs 3 D 0 }
- T{ ##peek f V int-regs 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##peek f 2 D 2 }
+ T{ ##replace f 1 D 1 }
+ T{ ##replace f 2 D 2 }
+ T{ ##peek f 3 D 0 }
+ T{ ##peek f 0 D 0 }
T{ ##branch }
} 0 test-bb
V{ T{ ##branch } } 1 test-bb
V{
- T{ ##peek f V int-regs 1 D 1 }
- T{ ##peek f V int-regs 2 D 2 }
- T{ ##replace f V int-regs 3 D 3 }
- T{ ##replace f V int-regs 1 D 1 }
- T{ ##replace f V int-regs 2 D 2 }
- T{ ##replace f V int-regs 0 D 3 }
+ T{ ##peek f 1 D 1 }
+ T{ ##peek f 2 D 2 }
+ T{ ##replace f 3 D 3 }
+ T{ ##replace f 1 D 1 }
+ T{ ##replace f 2 D 2 }
+ T{ ##replace f 0 D 3 }
T{ ##branch }
} 2 test-bb
! Spilling an interval immediately after its activated;
! and the interval does not have a use at the activation point
V{
- T{ ##peek f V int-regs 1 D 1 }
- T{ ##peek f V int-regs 2 D 2 }
- T{ ##replace f V int-regs 1 D 1 }
- T{ ##replace f V int-regs 2 D 2 }
- T{ ##peek f V int-regs 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##peek f 2 D 2 }
+ T{ ##replace f 1 D 1 }
+ T{ ##replace f 2 D 2 }
+ T{ ##peek f 0 D 0 }
T{ ##branch }
} 0 test-bb
V{ T{ ##branch } } 1 test-bb
V{
- T{ ##peek f V int-regs 1 D 1 }
+ T{ ##peek f 1 D 1 }
T{ ##branch }
} 2 test-bb
V{
- T{ ##replace f V int-regs 1 D 1 }
- T{ ##peek f V int-regs 2 D 2 }
- T{ ##replace f V int-regs 2 D 2 }
+ T{ ##replace f 1 D 1 }
+ T{ ##peek f 2 D 2 }
+ T{ ##replace f 2 D 2 }
T{ ##branch }
} 3 test-bb
V{ T{ ##branch } } 4 test-bb
V{
- T{ ##replace f V int-regs 0 D 0 }
+ T{ ##replace f 0 D 0 }
T{ ##return }
} 5 test-bb
-1 get 1vector 0 get (>>successors)
-2 get 4 get V{ } 2sequence 1 get (>>successors)
-5 get 1vector 4 get (>>successors)
-3 get 1vector 2 get (>>successors)
-5 get 1vector 3 get (>>successors)
+0 1 edge
+1 { 2 4 } edges
+4 5 edge
+2 3 edge
+3 5 edge
[ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test
V{ T{ ##prologue } T{ ##branch } } 0 test-bb
V{
- T{ ##load-immediate { dst V int-regs 61 } }
- T{ ##peek { dst V int-regs 62 } { loc D 0 } }
- T{ ##peek { dst V int-regs 64 } { loc D 1 } }
+ T{ ##load-immediate { dst 61 } }
+ T{ ##peek { dst 62 } { loc D 0 } }
+ T{ ##peek { dst 64 } { loc D 1 } }
T{ ##slot-imm
- { dst V int-regs 69 }
- { obj V int-regs 64 }
+ { dst 69 }
+ { obj 64 }
{ slot 1 }
{ tag 2 }
}
- T{ ##copy { dst V int-regs 79 } { src V int-regs 69 } }
+ T{ ##copy { dst 79 } { src 69 } }
T{ ##slot-imm
- { dst V int-regs 85 }
- { obj V int-regs 62 }
+ { dst 85 }
+ { obj 62 }
{ slot 2 }
{ tag 7 }
}
T{ ##compare-branch
- { src1 V int-regs 69 }
- { src2 V int-regs 85 }
+ { src1 69 }
+ { src2 85 }
{ cc cc> }
}
} 1 test-bb
V{
T{ ##slot-imm
- { dst V int-regs 97 }
- { obj V int-regs 62 }
+ { dst 97 }
+ { obj 62 }
{ slot 2 }
{ tag 7 }
}
- T{ ##replace { src V int-regs 79 } { loc D 3 } }
- T{ ##replace { src V int-regs 62 } { loc D 4 } }
- T{ ##replace { src V int-regs 79 } { loc D 1 } }
- T{ ##replace { src V int-regs 62 } { loc D 2 } }
- T{ ##replace { src V int-regs 61 } { loc D 5 } }
- T{ ##replace { src V int-regs 62 } { loc R 0 } }
- T{ ##replace { src V int-regs 69 } { loc R 1 } }
- T{ ##replace { src V int-regs 97 } { loc D 0 } }
+ T{ ##replace { src 79 } { loc D 3 } }
+ T{ ##replace { src 62 } { loc D 4 } }
+ T{ ##replace { src 79 } { loc D 1 } }
+ T{ ##replace { src 62 } { loc D 2 } }
+ T{ ##replace { src 61 } { loc D 5 } }
+ T{ ##replace { src 62 } { loc R 0 } }
+ T{ ##replace { src 69 } { loc R 1 } }
+ T{ ##replace { src 97 } { loc D 0 } }
T{ ##call { word resize-array } }
T{ ##branch }
} 2 test-bb
V{
- T{ ##peek { dst V int-regs 98 } { loc R 0 } }
- T{ ##peek { dst V int-regs 100 } { loc D 0 } }
+ T{ ##peek { dst 98 } { loc R 0 } }
+ T{ ##peek { dst 100 } { loc D 0 } }
T{ ##set-slot-imm
- { src V int-regs 100 }
- { obj V int-regs 98 }
+ { src 100 }
+ { obj 98 }
{ slot 2 }
{ tag 7 }
}
- T{ ##peek { dst V int-regs 108 } { loc D 2 } }
- T{ ##peek { dst V int-regs 110 } { loc D 3 } }
- T{ ##peek { dst V int-regs 112 } { loc D 0 } }
- T{ ##peek { dst V int-regs 114 } { loc D 1 } }
- T{ ##peek { dst V int-regs 116 } { loc D 4 } }
- T{ ##peek { dst V int-regs 119 } { loc R 0 } }
- T{ ##copy { dst V int-regs 109 } { src V int-regs 108 } }
- T{ ##copy { dst V int-regs 111 } { src V int-regs 110 } }
- T{ ##copy { dst V int-regs 113 } { src V int-regs 112 } }
- T{ ##copy { dst V int-regs 115 } { src V int-regs 114 } }
- T{ ##copy { dst V int-regs 117 } { src V int-regs 116 } }
- T{ ##copy { dst V int-regs 120 } { src V int-regs 119 } }
+ T{ ##peek { dst 108 } { loc D 2 } }
+ T{ ##peek { dst 110 } { loc D 3 } }
+ T{ ##peek { dst 112 } { loc D 0 } }
+ T{ ##peek { dst 114 } { loc D 1 } }
+ T{ ##peek { dst 116 } { loc D 4 } }
+ T{ ##peek { dst 119 } { loc R 0 } }
+ T{ ##copy { dst 109 } { src 108 } }
+ T{ ##copy { dst 111 } { src 110 } }
+ T{ ##copy { dst 113 } { src 112 } }
+ T{ ##copy { dst 115 } { src 114 } }
+ T{ ##copy { dst 117 } { src 116 } }
+ T{ ##copy { dst 120 } { src 119 } }
T{ ##branch }
} 3 test-bb
V{
- T{ ##copy { dst V int-regs 109 } { src V int-regs 62 } }
- T{ ##copy { dst V int-regs 111 } { src V int-regs 61 } }
- T{ ##copy { dst V int-regs 113 } { src V int-regs 62 } }
- T{ ##copy { dst V int-regs 115 } { src V int-regs 79 } }
- T{ ##copy { dst V int-regs 117 } { src V int-regs 64 } }
- T{ ##copy { dst V int-regs 120 } { src V int-regs 69 } }
+ T{ ##copy { dst 109 } { src 62 } }
+ T{ ##copy { dst 111 } { src 61 } }
+ T{ ##copy { dst 113 } { src 62 } }
+ T{ ##copy { dst 115 } { src 79 } }
+ T{ ##copy { dst 117 } { src 64 } }
+ T{ ##copy { dst 120 } { src 69 } }
T{ ##branch }
} 4 test-bb
V{
- T{ ##replace { src V int-regs 120 } { loc D 0 } }
- T{ ##replace { src V int-regs 109 } { loc D 3 } }
- T{ ##replace { src V int-regs 111 } { loc D 4 } }
- T{ ##replace { src V int-regs 113 } { loc D 1 } }
- T{ ##replace { src V int-regs 115 } { loc D 2 } }
- T{ ##replace { src V int-regs 117 } { loc D 5 } }
+ T{ ##replace { src 120 } { loc D 0 } }
+ T{ ##replace { src 109 } { loc D 3 } }
+ T{ ##replace { src 111 } { loc D 4 } }
+ T{ ##replace { src 113 } { loc D 1 } }
+ T{ ##replace { src 115 } { loc D 2 } }
+ T{ ##replace { src 117 } { loc D 5 } }
T{ ##epilogue }
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
V{ T{ ##prologue } T{ ##branch } } 0 test-bb
V{
- T{ ##peek { dst V int-regs 85 } { loc D 0 } }
+ T{ ##peek { dst 85 } { loc D 0 } }
T{ ##slot-imm
- { dst V int-regs 89 }
- { obj V int-regs 85 }
+ { dst 89 }
+ { obj 85 }
{ slot 3 }
{ tag 7 }
}
- T{ ##peek { dst V int-regs 91 } { loc D 1 } }
+ T{ ##peek { dst 91 } { loc D 1 } }
T{ ##slot-imm
- { dst V int-regs 96 }
- { obj V int-regs 91 }
+ { dst 96 }
+ { obj 91 }
{ slot 1 }
{ tag 2 }
}
T{ ##add
- { dst V int-regs 109 }
- { src1 V int-regs 89 }
- { src2 V int-regs 96 }
+ { dst 109 }
+ { src1 89 }
+ { src2 96 }
}
T{ ##slot-imm
- { dst V int-regs 115 }
- { obj V int-regs 85 }
+ { dst 115 }
+ { obj 85 }
{ slot 2 }
{ tag 7 }
}
T{ ##slot-imm
- { dst V int-regs 118 }
- { obj V int-regs 115 }
+ { dst 118 }
+ { obj 115 }
{ slot 1 }
{ tag 2 }
}
T{ ##compare-branch
- { src1 V int-regs 109 }
- { src2 V int-regs 118 }
+ { src1 109 }
+ { src2 118 }
{ cc cc> }
}
} 1 test-bb
V{
T{ ##add-imm
- { dst V int-regs 128 }
- { src1 V int-regs 109 }
+ { dst 128 }
+ { src1 109 }
{ src2 8 }
}
- T{ ##load-immediate { dst V int-regs 129 } { val 24 } }
+ T{ ##load-immediate { dst 129 } { val 24 } }
T{ ##inc-d { n 4 } }
T{ ##inc-r { n 1 } }
- T{ ##replace { src V int-regs 109 } { loc D 2 } }
- T{ ##replace { src V int-regs 85 } { loc D 3 } }
- T{ ##replace { src V int-regs 128 } { loc D 0 } }
- T{ ##replace { src V int-regs 85 } { loc D 1 } }
- T{ ##replace { src V int-regs 89 } { loc D 4 } }
- T{ ##replace { src V int-regs 96 } { loc R 0 } }
- T{ ##replace { src V int-regs 129 } { loc R 0 } }
+ T{ ##replace { src 109 } { loc D 2 } }
+ T{ ##replace { src 85 } { loc D 3 } }
+ T{ ##replace { src 128 } { loc D 0 } }
+ T{ ##replace { src 85 } { loc D 1 } }
+ T{ ##replace { src 89 } { loc D 4 } }
+ T{ ##replace { src 96 } { loc R 0 } }
+ T{ ##replace { src 129 } { loc R 0 } }
T{ ##branch }
} 2 test-bb
V{
- T{ ##peek { dst V int-regs 134 } { loc D 1 } }
+ T{ ##peek { dst 134 } { loc D 1 } }
T{ ##slot-imm
- { dst V int-regs 140 }
- { obj V int-regs 134 }
+ { dst 140 }
+ { obj 134 }
{ slot 2 }
{ tag 7 }
}
T{ ##inc-d { n 1 } }
T{ ##inc-r { n 1 } }
- T{ ##replace { src V int-regs 140 } { loc D 0 } }
- T{ ##replace { src V int-regs 134 } { loc R 0 } }
+ T{ ##replace { src 140 } { loc D 0 } }
+ T{ ##replace { src 134 } { loc R 0 } }
T{ ##call { word resize-array } }
T{ ##branch }
} 3 test-bb
V{
- T{ ##peek { dst V int-regs 141 } { loc R 0 } }
- T{ ##peek { dst V int-regs 143 } { loc D 0 } }
+ T{ ##peek { dst 141 } { loc R 0 } }
+ T{ ##peek { dst 143 } { loc D 0 } }
T{ ##set-slot-imm
- { src V int-regs 143 }
- { obj V int-regs 141 }
+ { src 143 }
+ { obj 141 }
{ slot 2 }
{ tag 7 }
}
T{ ##write-barrier
- { src V int-regs 141 }
- { card# V int-regs 145 }
- { table V int-regs 146 }
+ { src 141 }
+ { card# 145 }
+ { table 146 }
}
T{ ##inc-d { n -1 } }
T{ ##inc-r { n -1 } }
- T{ ##peek { dst V int-regs 156 } { loc D 2 } }
- T{ ##peek { dst V int-regs 158 } { loc D 3 } }
- T{ ##peek { dst V int-regs 160 } { loc D 0 } }
- T{ ##peek { dst V int-regs 162 } { loc D 1 } }
- T{ ##peek { dst V int-regs 164 } { loc D 4 } }
- T{ ##peek { dst V int-regs 167 } { loc R 0 } }
- T{ ##copy { dst V int-regs 157 } { src V int-regs 156 } }
- T{ ##copy { dst V int-regs 159 } { src V int-regs 158 } }
- T{ ##copy { dst V int-regs 161 } { src V int-regs 160 } }
- T{ ##copy { dst V int-regs 163 } { src V int-regs 162 } }
- T{ ##copy { dst V int-regs 165 } { src V int-regs 164 } }
- T{ ##copy { dst V int-regs 168 } { src V int-regs 167 } }
+ T{ ##peek { dst 156 } { loc D 2 } }
+ T{ ##peek { dst 158 } { loc D 3 } }
+ T{ ##peek { dst 160 } { loc D 0 } }
+ T{ ##peek { dst 162 } { loc D 1 } }
+ T{ ##peek { dst 164 } { loc D 4 } }
+ T{ ##peek { dst 167 } { loc R 0 } }
+ T{ ##copy { dst 157 } { src 156 } }
+ T{ ##copy { dst 159 } { src 158 } }
+ T{ ##copy { dst 161 } { src 160 } }
+ T{ ##copy { dst 163 } { src 162 } }
+ T{ ##copy { dst 165 } { src 164 } }
+ T{ ##copy { dst 168 } { src 167 } }
T{ ##branch }
} 4 test-bb
V{
T{ ##inc-d { n 3 } }
T{ ##inc-r { n 1 } }
- T{ ##copy { dst V int-regs 157 } { src V int-regs 85 } }
- T{ ##copy { dst V int-regs 159 } { src V int-regs 89 } }
- T{ ##copy { dst V int-regs 161 } { src V int-regs 85 } }
- T{ ##copy { dst V int-regs 163 } { src V int-regs 109 } }
- T{ ##copy { dst V int-regs 165 } { src V int-regs 91 } }
- T{ ##copy { dst V int-regs 168 } { src V int-regs 96 } }
+ T{ ##copy { dst 157 } { src 85 } }
+ T{ ##copy { dst 159 } { src 89 } }
+ T{ ##copy { dst 161 } { src 85 } }
+ T{ ##copy { dst 163 } { src 109 } }
+ T{ ##copy { dst 165 } { src 91 } }
+ T{ ##copy { dst 168 } { src 96 } }
T{ ##branch }
} 5 test-bb
V{
T{ ##set-slot-imm
- { src V int-regs 163 }
- { obj V int-regs 161 }
+ { src 163 }
+ { obj 161 }
{ slot 3 }
{ tag 7 }
}
T{ ##inc-d { n 1 } }
T{ ##inc-r { n -1 } }
- T{ ##replace { src V int-regs 168 } { loc D 0 } }
- T{ ##replace { src V int-regs 157 } { loc D 3 } }
- T{ ##replace { src V int-regs 159 } { loc D 4 } }
- T{ ##replace { src V int-regs 161 } { loc D 1 } }
- T{ ##replace { src V int-regs 163 } { loc D 2 } }
- T{ ##replace { src V int-regs 165 } { loc D 5 } }
+ T{ ##replace { src 168 } { loc D 0 } }
+ T{ ##replace { src 157 } { loc D 3 } }
+ T{ ##replace { src 159 } { loc D 4 } }
+ T{ ##replace { src 161 } { loc D 1 } }
+ T{ ##replace { src 163 } { loc D 2 } }
+ T{ ##replace { src 165 } { loc D 5 } }
T{ ##epilogue }
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
V{ T{ ##branch } } 0 test-bb
V{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##compare-imm-branch f V int-regs 0 5 cc= }
+ T{ ##peek f 0 D 0 }
+ T{ ##compare-imm-branch f 0 5 cc= }
} 1 test-bb
V{ T{ ##branch } } 2 test-bb
V{
- T{ ##peek f V int-regs 1 D 0 }
- T{ ##peek f V int-regs 2 D 0 }
- T{ ##replace f V int-regs 1 D 0 }
- T{ ##replace f V int-regs 2 D 0 }
+ T{ ##peek f 1 D 0 }
+ T{ ##peek f 2 D 0 }
+ T{ ##replace f 1 D 0 }
+ T{ ##replace f 2 D 0 }
T{ ##branch }
} 3 test-bb
V{
- T{ ##replace f V int-regs 0 D 0 }
+ T{ ##replace f 0 D 0 }
T{ ##return }
} 4 test-bb
V{ T{ ##branch } } 0 test-bb
V{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##compare-imm-branch f V int-regs 0 5 cc= }
+ T{ ##peek f 0 D 0 }
+ T{ ##compare-imm-branch f 0 5 cc= }
} 1 test-bb
V{
- T{ ##peek f V int-regs 1 D 0 }
- T{ ##peek f V int-regs 2 D 0 }
- T{ ##replace f V int-regs 1 D 0 }
- T{ ##replace f V int-regs 2 D 0 }
- T{ ##replace f V int-regs 0 D 0 }
+ T{ ##peek f 1 D 0 }
+ T{ ##peek f 2 D 0 }
+ T{ ##replace f 1 D 0 }
+ T{ ##replace f 2 D 0 }
+ T{ ##replace f 0 D 0 }
T{ ##branch }
} 2 test-bb
} 3 test-bb
V{
- T{ ##replace f V int-regs 0 D 0 }
+ T{ ##replace f 0 D 0 }
T{ ##return }
} 4 test-bb
[ 0 ] [ 4 get instructions>> [ _reload? ] count ] unit-test
-! GC check tests
-
-! Spill slot liveness was computed incorrectly, leading to a FEP
-! early in bootstrap on x86-32
-[ t ] [
- [
- T{ basic-block
- { id 12345 }
- { instructions
- V{
- T{ ##gc f V int-regs 6 V int-regs 7 }
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##peek f V int-regs 1 D 1 }
- T{ ##peek f V int-regs 2 D 2 }
- T{ ##peek f V int-regs 3 D 3 }
- T{ ##peek f V int-regs 4 D 4 }
- T{ ##peek f V int-regs 5 D 5 }
- T{ ##replace f V int-regs 0 D 1 }
- T{ ##replace f V int-regs 1 D 2 }
- T{ ##replace f V int-regs 2 D 3 }
- T{ ##replace f V int-regs 3 D 4 }
- T{ ##replace f V int-regs 4 D 5 }
- T{ ##replace f V int-regs 5 D 0 }
- }
- }
- } cfg new over >>entry
- { { int-regs V{ 0 1 2 3 } } } (linear-scan)
- instructions>> first
- live-values>> assoc-empty?
- ] with-scope
-] unit-test
-
V{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##peek f V int-regs 1 D 1 }
- T{ ##replace f V int-regs 1 D 1 }
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##replace f 1 D 1 }
T{ ##branch }
} 0 test-bb
V{
- T{ ##gc f V int-regs 2 V int-regs 3 }
+ T{ ##gc f 2 3 }
T{ ##branch }
} 1 test-bb
V{
- T{ ##replace f V int-regs 0 D 0 }
+ T{ ##replace f 0 D 0 }
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
-[ H{ { V int-regs 0 3 } } ] [ 1 get instructions>> first live-values>> ] unit-test
-
-
+[ { 3 } ] [ 1 get instructions>> first tagged-values>> ] unit-test
V{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##peek f V int-regs 1 D 1 }
- T{ ##compare-imm-branch f V int-regs 1 5 cc= }
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##compare-imm-branch f 1 5 cc= }
} 0 test-bb
V{
- T{ ##gc f V int-regs 2 V int-regs 3 }
- T{ ##replace f V int-regs 0 D 0 }
+ T{ ##gc f 2 3 }
+ T{ ##replace f 0 D 0 }
T{ ##return }
} 1 test-bb
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
-[ H{ { V int-regs 0 3 } } ] [ 1 get instructions>> first live-values>> ] unit-test
+[ { 3 } ] [ 1 get instructions>> first tagged-values>> ] unit-test
compiler.cfg
compiler.cfg.rpo
compiler.cfg.liveness
+compiler.cfg.registers
compiler.cfg.instructions
compiler.cfg.linear-scan.numbering
compiler.cfg.linear-scan.live-intervals
cfg check-numbering ;
: linear-scan ( cfg -- cfg' )
- [
- dup machine-registers (linear-scan)
- spill-counts get >>spill-counts
- cfg-changed
- ] with-scope ;
+ dup machine-registers (linear-scan) ;
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces kernel assocs accessors sequences math math.order fry
combinators binary-search compiler.cfg.instructions compiler.cfg.registers
-compiler.cfg.def-use compiler.cfg.liveness compiler.cfg.rpo
+compiler.cfg.def-use compiler.cfg.liveness compiler.cfg.linearization.order
compiler.cfg ;
IN: compiler.cfg.linear-scan.live-intervals
TUPLE: live-interval
vreg
reg spill-to reload-from
-start end ranges uses
-copy-from ;
+start end ranges uses ;
GENERIC: covers? ( insn# obj -- ? )
[ [ temp-vregs ] 2dip '[ [ _ ] dip _ handle-temp ] each ]
3tri ;
-: record-copy ( insn -- )
- [ dst>> live-intervals get at ] [ src>> ] bi >>copy-from drop ;
-
-M: ##copy compute-live-intervals*
- [ call-next-method ] [ record-copy ] bi ;
-
-M: ##copy-float compute-live-intervals*
- [ call-next-method ] [ record-copy ] bi ;
-
: handle-live-out ( bb -- )
live-out keys
basic-block get [ block-from ] [ block-to ] bi
: compute-live-intervals ( cfg -- live-intervals )
H{ } clone [
live-intervals set
- post-order [ compute-live-intervals-step ] each
+ linearization-order <reversed>
+ [ compute-live-intervals-step ] each
] keep values dup finish-live-intervals ;
: relevant-ranges ( interval1 interval2 -- ranges1 ranges2 )
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors math sequences grouping namespaces
-compiler.cfg.rpo ;
+compiler.cfg.linearization.order ;
IN: compiler.cfg.linear-scan.numbering
: number-instructions ( rpo -- )
- [ 0 ] dip [
+ linearization-order 0 [
instructions>> [
[ (>>insn#) ] [ drop 2 + ] 2bi
] each
- ] each-basic-block drop ;
+ ] reduce drop ;
SYMBOL: check-numbering?
[ drop ] [ bad-numbering ] if ;
: check-numbering ( cfg -- )
- check-numbering? get [ [ check-block-numbering ] each-basic-block ] [ drop ] if ;
\ No newline at end of file
+ check-numbering? get
+ [ linearization-order [ check-block-numbering ] each ] [ drop ] if ;
\ No newline at end of file
IN: compiler.cfg.linear-scan.resolve.tests
USING: compiler.cfg.linear-scan.resolve tools.test kernel namespaces
+accessors
+compiler.cfg
compiler.cfg.instructions cpu.architecture make sequences
compiler.cfg.linear-scan.allocation.state ;
[
{
- { { T{ spill-slot f 0 } int-regs } { 1 int-regs } }
+ { { T{ spill-slot f 0 } int-rep } { 1 int-rep } }
}
] [
[
- 0 <spill-slot> 1 int-regs add-mapping
+ 0 <spill-slot> 1 int-rep add-mapping
] { } make
] unit-test
[
{
- T{ _reload { dst 1 } { class int-regs } { n 0 } }
+ T{ _reload { dst 1 } { rep int-rep } { n 0 } }
}
] [
[
- { T{ spill-slot f 0 } int-regs } { 1 int-regs } >insn
+ { T{ spill-slot f 0 } int-rep } { 1 int-rep } >insn
] { } make
] unit-test
[
{
- T{ _spill { src 1 } { class int-regs } { n 0 } }
+ T{ _spill { src 1 } { rep int-rep } { n 0 } }
}
] [
[
- { 1 int-regs } { T{ spill-slot f 0 } int-regs } >insn
+ { 1 int-rep } { T{ spill-slot f 0 } int-rep } >insn
] { } make
] unit-test
[
{
- T{ _copy { src 1 } { dst 2 } { class int-regs } }
+ T{ ##copy { src 1 } { dst 2 } { rep int-rep } }
}
] [
[
- { 1 int-regs } { 2 int-regs } >insn
+ { 1 int-rep } { 2 int-rep } >insn
] { } make
] unit-test
-H{ { int-regs 10 } { float-regs 20 } } clone spill-counts set
+cfg new 8 >>spill-area-size cfg set
H{ } clone spill-temps set
[
t
] [
- { { { 0 int-regs } { 1 int-regs } } { { 1 int-regs } { 0 int-regs } } }
+ { { { 0 int-rep } { 1 int-rep } } { { 1 int-rep } { 0 int-rep } } }
mapping-instructions {
{
- T{ _spill { src 0 } { class int-regs } { n 10 } }
- T{ _copy { dst 0 } { src 1 } { class int-regs } }
- T{ _reload { dst 1 } { class int-regs } { n 10 } }
+ T{ _spill { src 0 } { rep int-rep } { n 8 } }
+ T{ ##copy { dst 0 } { src 1 } { rep int-rep } }
+ T{ _reload { dst 1 } { rep int-rep } { n 8 } }
}
{
- T{ _spill { src 1 } { class int-regs } { n 10 } }
- T{ _copy { dst 1 } { src 0 } { class int-regs } }
- T{ _reload { dst 0 } { class int-regs } { n 10 } }
+ T{ _spill { src 1 } { rep int-rep } { n 8 } }
+ T{ ##copy { dst 1 } { src 0 } { rep int-rep } }
+ T{ _reload { dst 0 } { rep int-rep } { n 8 } }
}
} member?
] unit-test
\ No newline at end of file
USING: accessors arrays assocs combinators
combinators.short-circuit fry kernel locals namespaces
make math sequences hashtables
+compiler.cfg
compiler.cfg.rpo
compiler.cfg.liveness
+compiler.cfg.registers
compiler.cfg.utilities
compiler.cfg.instructions
+compiler.cfg.predecessors
compiler.cfg.parallel-copy
compiler.cfg.linear-scan.assignment
compiler.cfg.linear-scan.allocation.state ;
SYMBOL: spill-temps
-: spill-temp ( reg-class -- n )
+: spill-temp ( rep -- n )
spill-temps get [ next-spill-slot ] cache ;
-: add-mapping ( from to reg-class -- )
+: add-mapping ( from to rep -- )
'[ _ 2array ] bi@ 2array , ;
:: resolve-value-data-flow ( bb to vreg -- )
vreg bb vreg-at-end
vreg to vreg-at-start
- 2dup = [ 2drop ] [ vreg reg-class>> add-mapping ] if ;
+ 2dup = [ 2drop ] [ vreg rep-of 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 ;
drop [ first2 ] [ second spill-temp ] bi _spill ;
: register->register ( from to -- )
- swap [ first ] [ first2 ] bi* _copy ;
+ swap [ first ] [ first2 ] bi* ##copy ;
SYMBOL: temp
: perform-mappings ( bb to mappings -- )
dup empty? [ 3drop ] [
- mapping-instructions <simple-block>
- insert-basic-block
+ mapping-instructions <simple-block> insert-basic-block
+ cfg get cfg-changed drop
] if ;
: resolve-edge-data-flow ( bb to -- )
dup successors>> [ resolve-edge-data-flow ] with each ;
: resolve-data-flow ( cfg -- )
+ needs-predecessors
+
H{ } clone spill-temps set
[ resolve-block-data-flow ] each-basic-block ;
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math accessors sequences namespaces make
-combinators assocs arrays locals cpu.architecture
+combinators assocs arrays locals layouts hashtables
+cpu.architecture
compiler.cfg
compiler.cfg.comparisons
compiler.cfg.stack-frame
compiler.cfg.linearization.order ;
IN: compiler.cfg.linearization
+<PRIVATE
+
+SYMBOL: numbers
+
+: block-number ( bb -- n ) numbers get at ;
+
+: number-blocks ( bbs -- ) [ 2array ] map-index >hashtable numbers set ;
+
! Convert CFG IR to machine IR.
GENERIC: linearize-insn ( basic-block insn -- )
[ successors>> [ block-number _dispatch-label ] each ]
bi* ;
-: (compute-gc-roots) ( n live-values -- n )
- [
- [ nip 2array , ]
- [ drop reg-class>> reg-size + ]
- 3bi
- ] assoc-each ;
-
-: oop-values ( regs -- regs' )
- [ drop reg-class>> int-regs eq? ] assoc-filter ;
-
-: data-values ( regs -- regs' )
- [ drop reg-class>> double-float-regs eq? ] assoc-filter ;
-
-: compute-gc-roots ( live-values -- alist )
- [
- [ 0 ] dip
- ! we put float registers last; the GC doesn't actually scan them
- [ oop-values (compute-gc-roots) ]
- [ data-values (compute-gc-roots) ] bi
- drop
- ] { } make ;
-
-: count-gc-roots ( live-values -- n )
- ! Size of GC root area, minus the float registers
- oop-values assoc-size ;
+: gc-root-offsets ( registers -- alist )
+ ! Outputs a sequence of { offset register/spill-slot } pairs
+ [ length iota [ cell * ] map ] keep zip ;
M: ##gc linearize-insn
nip
{
[ temp1>> ]
[ temp2>> ]
- [
- live-values>>
- [ compute-gc-roots ]
- [ count-gc-roots ]
- [ gc-roots-size ]
- tri
- ]
+ [ data-values>> ]
+ [ tagged-values>> gc-root-offsets ]
[ uninitialized-locs>> ]
} cleave
_gc ;
: linearize-basic-blocks ( cfg -- insns )
[
- [ linearization-order [ linearize-basic-block ] each ]
- [ spill-counts>> _spill-counts ]
- bi
+ [
+ linearization-order
+ [ number-blocks ]
+ [ [ linearize-basic-block ] each ] bi
+ ] [ spill-area-size>> _spill-area-size ] bi
] { } make ;
+PRIVATE>
+
: flatten-cfg ( cfg -- mr )
[ linearize-basic-blocks ] [ word>> ] [ label>> ] tri
<mr> ;
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs deques dlists kernel make
+USING: accessors assocs deques dlists kernel make sorting
namespaces sequences combinators combinators.short-circuit
-fry math sets compiler.cfg.rpo compiler.cfg.utilities ;
+fry math sets compiler.cfg.rpo compiler.cfg.utilities
+compiler.cfg.loop-detection ;
IN: compiler.cfg.linearization.order
! This is RPO except loops are rotated. Based on SBCL's src/compiler/control.lisp
<PRIVATE
-SYMBOLS: work-list loop-heads visited numbers next-number ;
+SYMBOLS: work-list loop-heads visited ;
: visited? ( bb -- ? ) visited get key? ;
work-list get push-back
] if ;
+: init-linearization-order ( cfg -- )
+ <dlist> work-list set
+ H{ } clone visited set
+ entry>> add-to-work-list ;
+
: (find-alternate-loop-head) ( bb -- bb' )
dup {
[ predecessor visited? not ]
add-to-work-list
] [ drop ] if ;
-: assign-number ( bb -- )
- next-number [ get ] [ inc ] bi swap numbers get set-at ;
+: sorted-successors ( bb -- seq )
+ successors>> <reversed> [ loop-nesting-at ] sort-with ;
: process-block ( bb -- )
- {
- [ , ]
- [ assign-number ]
- [ visited get conjoin ]
- [ successors>> <reversed> [ process-successor ] each ]
- } cleave ;
+ [ , ]
+ [ visited get conjoin ]
+ [ sorted-successors [ process-successor ] each ]
+ tri ;
+
+: (linearization-order) ( cfg -- bbs )
+ init-linearization-order
+
+ [ work-list get [ process-block ] slurp-deque ] { } make ;
PRIVATE>
: linearization-order ( cfg -- bbs )
- ! We call 'post-order drop' to ensure blocks receive their
- ! RPO numbers.
- <dlist> work-list set
- H{ } clone visited set
- H{ } clone numbers set
- 0 next-number set
- [ post-order drop ]
- [ entry>> add-to-work-list ] bi
- [ work-list get [ process-block ] slurp-deque ] { } make ;
+ needs-post-order needs-loops
-: block-number ( bb -- n ) numbers get at ;
+ dup linear-order>> [ ] [
+ dup (linearization-order)
+ >>linear-order linear-order>>
+ ] ?if ;
\ No newline at end of file
: test-liveness ( -- )
cfg new 1 get >>entry
- compute-predecessors
compute-live-sets ;
! Sanity check...
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 }
- T{ ##peek f V int-regs 1 D 1 }
+ T{ ##peek f 0 D 0 }
+ T{ ##replace f 0 D 0 }
+ T{ ##replace f 1 D 1 }
+ T{ ##peek f 1 D 1 }
T{ ##branch }
} 1 test-bb
V{
- T{ ##replace f V int-regs 2 D 0 }
+ T{ ##replace f 2 D 0 }
T{ ##branch }
} 2 test-bb
V{
- T{ ##replace f V int-regs 3 D 0 }
+ T{ ##replace f 3 D 0 }
T{ ##return }
} 3 test-bb
-1 get 2 get 3 get V{ } 2sequence >>successors drop
+1 { 2 3 } edges
test-liveness
[
H{
- { V int-regs 1 V int-regs 1 }
- { V int-regs 2 V int-regs 2 }
- { V int-regs 3 V int-regs 3 }
+ { 1 1 }
+ { 2 2 }
+ { 3 3 }
}
]
[ 1 get live-in ]
! Tricky case; defs must be killed before uses
V{
- T{ ##peek f V int-regs 0 D 0 }
+ T{ ##peek f 0 D 0 }
T{ ##branch }
} 1 test-bb
V{
- T{ ##add-imm f V int-regs 0 V int-regs 0 10 }
+ T{ ##add-imm f 0 0 10 }
T{ ##return }
} 2 test-bb
-1 get 2 get 1vector >>successors drop
+1 2 edge
test-liveness
-[ H{ { V int-regs 0 V int-regs 0 } } ] [ 2 get live-in ] unit-test
\ No newline at end of file
+[ H{ { 0 0 } } ] [ 2 get live-in ] unit-test
\ No newline at end of file
! 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
+compiler.cfg.predecessors ;
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 ]
] [ drop ] if ;
: compute-ssa-live-sets ( cfg -- cfg' )
+ needs-predecessors
+
<hashed-dlist> work-list set
H{ } clone live-ins set
H{ } clone phi-live-ins set
--- /dev/null
+IN: compiler.cfg.loop-detection.tests
+USING: compiler.cfg compiler.cfg.loop-detection
+compiler.cfg.predecessors
+compiler.cfg.debugger
+tools.test kernel namespaces accessors ;
+
+V{ } 0 test-bb
+V{ } 1 test-bb
+V{ } 2 test-bb
+
+0 { 1 2 } edges
+2 0 edge
+
+: test-loop-detection ( -- ) cfg new 0 get >>entry needs-loops drop ;
+
+[ ] [ test-loop-detection ] unit-test
+
+[ 1 ] [ 0 get loop-nesting-at ] unit-test
+[ 0 ] [ 1 get loop-nesting-at ] unit-test
+[ 1 ] [ 2 get loop-nesting-at ] unit-test
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs combinators deques dlists fry kernel
+namespaces sequences sets compiler.cfg compiler.cfg.predecessors ;
+IN: compiler.cfg.loop-detection
+
+TUPLE: natural-loop header index ends blocks ;
+
+<PRIVATE
+
+SYMBOL: loops
+
+: <natural-loop> ( header index -- loop )
+ H{ } clone H{ } clone natural-loop boa ;
+
+: lookup-header ( header -- loop )
+ loops get [
+ loops get assoc-size <natural-loop>
+ ] cache ;
+
+SYMBOLS: visited active ;
+
+: record-back-edge ( from to -- )
+ lookup-header ends>> conjoin ;
+
+DEFER: find-loop-headers
+
+: visit-edge ( from to -- )
+ dup active get key?
+ [ record-back-edge ]
+ [ nip find-loop-headers ]
+ if ;
+
+: find-loop-headers ( bb -- )
+ dup visited get key? [ drop ] [
+ {
+ [ visited get conjoin ]
+ [ active get conjoin ]
+ [ dup successors>> [ visit-edge ] with each ]
+ [ active get delete-at ]
+ } cleave
+ ] if ;
+
+SYMBOL: work-list
+
+: process-loop-block ( bb loop -- )
+ 2dup blocks>> key? [ 2drop ] [
+ [ blocks>> conjoin ] [
+ 2dup header>> eq? [ 2drop ] [
+ drop predecessors>> work-list get push-all-front
+ ] if
+ ] 2bi
+ ] if ;
+
+: process-loop-ends ( loop -- )
+ [ ends>> keys <dlist> [ push-all-front ] [ work-list set ] [ ] tri ] keep
+ '[ _ process-loop-block ] slurp-deque ;
+
+: process-loop-headers ( -- )
+ loops get values [ process-loop-ends ] each ;
+
+SYMBOL: loop-nesting
+
+: compute-loop-nesting ( -- )
+ loops get H{ } clone [
+ [ values ] dip '[ blocks>> values [ _ inc-at ] each ] each
+ ] keep loop-nesting set ;
+
+: detect-loops ( cfg -- cfg' )
+ needs-predecessors
+ H{ } clone loops set
+ H{ } clone visited set
+ H{ } clone active set
+ H{ } clone loop-nesting set
+ dup entry>> find-loop-headers process-loop-headers compute-loop-nesting ;
+
+PRIVATE>
+
+: loop-nesting-at ( bb -- n ) loop-nesting get at 0 or ;
+
+: needs-loops ( cfg -- cfg' )
+ needs-predecessors
+ dup loops-valid?>> [ detect-loops t >>loops-valid? ] unless ;
\ No newline at end of file
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: compiler.cfg.linearization compiler.cfg.two-operand
-compiler.cfg.gc-checks compiler.cfg.linear-scan
-compiler.cfg.build-stack-frame compiler.cfg.rpo ;
+USING: kernel namespaces accessors compiler.cfg
+compiler.cfg.linearization compiler.cfg.gc-checks
+compiler.cfg.linear-scan compiler.cfg.build-stack-frame ;
IN: compiler.cfg.mr
: build-mr ( cfg -- mr )
- convert-two-operand
insert-gc-checks
linear-scan
flatten-cfg
compiler.cfg.copy-prop
compiler.cfg.dce
compiler.cfg.write-barrier
+compiler.cfg.representations
+compiler.cfg.two-operand
compiler.cfg.ssa.destruction
compiler.cfg.empty-blocks
-compiler.cfg.predecessors
-compiler.cfg.rpo
compiler.cfg.checker ;
IN: compiler.cfg.optimizer
] when ;
: optimize-cfg ( cfg -- cfg' )
- ! Note that compute-predecessors has to be called several times.
- ! The passes that need this document it.
- [
- optimize-tail-calls
- delete-useless-conditionals
- compute-predecessors
- split-branches
- join-blocks
- compute-predecessors
- construct-ssa
- alias-analysis
- value-numbering
- compute-predecessors
- copy-propagation
- eliminate-dead-code
- eliminate-write-barriers
- destruct-ssa
- delete-empty-blocks
- ?check
- ] with-scope ;
+ optimize-tail-calls
+ delete-useless-conditionals
+ split-branches
+ join-blocks
+ construct-ssa
+ alias-analysis
+ value-numbering
+ copy-propagation
+ eliminate-dead-code
+ eliminate-write-barriers
+ select-representations
+ convert-two-operand
+ destruct-ssa
+ delete-empty-blocks
+ ?check ;
[
{
- T{ ##copy f V int-regs 4 V int-regs 2 }
- T{ ##copy f V int-regs 2 V int-regs 1 }
- T{ ##copy f V int-regs 1 V int-regs 4 }
+ T{ ##copy f 4 2 any-rep }
+ T{ ##copy f 2 1 any-rep }
+ T{ ##copy f 1 4 any-rep }
}
] [
H{
- { V int-regs 1 V int-regs 2 }
- { V int-regs 2 V int-regs 1 }
+ { 1 2 }
+ { 2 1 }
} test-parallel-copy
] unit-test
[
{
- T{ ##copy f V int-regs 1 V int-regs 2 }
- T{ ##copy f V int-regs 3 V int-regs 4 }
+ T{ ##copy f 1 2 any-rep }
+ T{ ##copy f 3 4 any-rep }
}
] [
H{
- { V int-regs 1 V int-regs 2 }
- { V int-regs 3 V int-regs 4 }
+ { 1 2 }
+ { 3 4 }
} test-parallel-copy
] unit-test
[
{
- T{ ##copy f V int-regs 1 V int-regs 3 }
- T{ ##copy f V int-regs 2 V int-regs 1 }
+ T{ ##copy f 1 3 any-rep }
+ T{ ##copy f 2 1 any-rep }
}
] [
H{
- { V int-regs 1 V int-regs 3 }
- { V int-regs 2 V int-regs 3 }
+ { 1 3 }
+ { 2 3 }
} test-parallel-copy
] unit-test
[
{
- T{ ##copy f V int-regs 4 V int-regs 3 }
- T{ ##copy f V int-regs 3 V int-regs 2 }
- T{ ##copy f V int-regs 2 V int-regs 1 }
- T{ ##copy f V int-regs 1 V int-regs 4 }
+ T{ ##copy f 4 3 any-rep }
+ T{ ##copy f 3 2 any-rep }
+ T{ ##copy f 2 1 any-rep }
+ T{ ##copy f 1 4 any-rep }
}
] [
{
- { V int-regs 2 V int-regs 1 }
- { V int-regs 3 V int-regs 2 }
- { V int-regs 1 V int-regs 3 }
- { V int-regs 4 V int-regs 3 }
+ { 2 1 }
+ { 3 2 }
+ { 1 3 }
+ { 4 3 }
} test-parallel-copy
] unit-test
\ No newline at end of file
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: assocs compiler.cfg.hats compiler.cfg.instructions
-deques dlists fry kernel locals namespaces sequences
-hashtables ;
+USING: assocs cpu.architecture compiler.cfg.registers
+compiler.cfg.instructions deques dlists fry kernel locals namespaces
+sequences hashtables ;
IN: compiler.cfg.parallel-copy
! Revisiting Out-of-SSA Translation for Correctness, Code Quality, and Efficiency
] slurp-deque
] with-scope ; inline
-: parallel-copy ( mapping -- ) i [ ##copy ] parallel-mapping ;
\ No newline at end of file
+: parallel-copy ( mapping -- )
+ next-vreg [ any-rep ##copy ] parallel-mapping ;
\ 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
+<PRIVATE
+
: update-predecessors ( bb -- )
dup successors>> [ predecessors>> push ] with each ;
] 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' )
{
[ [ update-phis ] each-basic-block ]
[ ]
} cleave ;
+
+PRIVATE>
+
+: needs-predecessors ( cfg -- cfg' )
+ dup predecessors-valid?>>
+ [ compute-predecessors t >>predecessors-valid? ] unless ;
\ No newline at end of file
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors namespaces kernel arrays parser math math.order ;
+USING: accessors namespaces kernel parser assocs ;
IN: compiler.cfg.registers
-! Virtual registers, used by CFG and machine IRs
-TUPLE: vreg { reg-class read-only } { n fixnum read-only } ;
+! Virtual registers, used by CFG and machine IRs, are just integers
+SYMBOL: vreg-counter
-M: vreg equal? over vreg? [ [ n>> ] bi@ eq? ] [ 2drop f ] if ;
+: next-vreg ( -- vreg )
+ ! This word cannot be called AFTER representation selection has run;
+ ! use next-vreg-rep in that case
+ \ vreg-counter counter ;
-M: vreg hashcode* nip n>> ;
+SYMBOL: representations
-SYMBOL: vreg-counter
+ERROR: bad-vreg vreg ;
+
+: rep-of ( vreg -- rep )
+ ! This word cannot be called BEFORE representation selection has run;
+ ! use any-rep for ##copy instructions and so on
+ representations get ?at [ bad-vreg ] unless ;
+
+: set-rep-of ( rep vreg -- )
+ representations get set-at ;
-: next-vreg ( reg-class -- vreg ) \ vreg-counter counter vreg boa ;
+: next-vreg-rep ( rep -- vreg )
+ ! This word cannot be called BEFORE representation selection has run;
+ ! use next-vreg in that case
+ next-vreg [ set-rep-of ] keep ;
! Stack locations -- 'n' is an index starting from the top of the stack
! going down. So 0 is the top of the stack, 1 is what would be the top
TUPLE: rs-loc < loc ;
C: <rs-loc> rs-loc
-SYNTAX: V scan-word scan-word vreg boa parsed ;
SYNTAX: D scan-word <ds-loc> parsed ;
SYNTAX: R scan-word <rs-loc> parsed ;
: rename-value ( vreg -- vreg' )
renamings get ?at drop ;
-: fresh-value ( vreg -- vreg' )
- reg-class>> next-vreg ;
-
-RENAMING: rename [ rename-value ] [ rename-value ] [ fresh-value ]
+RENAMING: rename [ rename-value ] [ rename-value ] [ drop next-vreg ]
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors sequences arrays fry namespaces
+cpu.architecture compiler.cfg.utilities compiler.cfg compiler.cfg.rpo
+compiler.cfg.instructions compiler.cfg.def-use ;
+IN: compiler.cfg.representations.preferred
+
+GENERIC: defs-vreg-rep ( insn -- rep/f )
+GENERIC: temp-vreg-reps ( insn -- reps )
+GENERIC: uses-vreg-reps ( insn -- reps )
+
+M: ##flushable defs-vreg-rep drop int-rep ;
+M: ##copy defs-vreg-rep rep>> ;
+M: output-float-insn defs-vreg-rep drop double-float-rep ;
+M: ##fixnum-overflow defs-vreg-rep drop int-rep ;
+M: _fixnum-overflow defs-vreg-rep drop int-rep ;
+M: ##phi defs-vreg-rep drop "##phi must be special-cased" throw ;
+M: insn defs-vreg-rep drop f ;
+
+M: ##write-barrier temp-vreg-reps drop { int-rep int-rep } ;
+M: ##unary/temp temp-vreg-reps drop { int-rep } ;
+M: ##allot temp-vreg-reps drop { int-rep } ;
+M: ##dispatch temp-vreg-reps drop { int-rep } ;
+M: ##slot temp-vreg-reps drop { int-rep } ;
+M: ##set-slot temp-vreg-reps drop { int-rep } ;
+M: ##string-nth temp-vreg-reps drop { int-rep } ;
+M: ##set-string-nth-fast temp-vreg-reps drop { int-rep } ;
+M: ##compare temp-vreg-reps drop { int-rep } ;
+M: ##compare-imm temp-vreg-reps drop { int-rep } ;
+M: ##compare-float temp-vreg-reps drop { int-rep } ;
+M: ##gc temp-vreg-reps drop { int-rep int-rep } ;
+M: _dispatch temp-vreg-reps drop { int-rep } ;
+M: insn temp-vreg-reps drop f ;
+
+M: ##copy uses-vreg-reps rep>> 1array ;
+M: ##unary uses-vreg-reps drop { int-rep } ;
+M: ##unary-float uses-vreg-reps drop { double-float-rep } ;
+M: ##binary uses-vreg-reps drop { int-rep int-rep } ;
+M: ##binary-imm uses-vreg-reps drop { int-rep } ;
+M: ##binary-float uses-vreg-reps drop { double-float-rep double-float-rep } ;
+M: ##effect uses-vreg-reps drop { int-rep } ;
+M: ##slot uses-vreg-reps drop { int-rep int-rep } ;
+M: ##slot-imm uses-vreg-reps drop { int-rep } ;
+M: ##set-slot uses-vreg-reps drop { int-rep int-rep int-rep } ;
+M: ##set-slot-imm uses-vreg-reps drop { int-rep int-rep } ;
+M: ##string-nth uses-vreg-reps drop { int-rep int-rep } ;
+M: ##set-string-nth-fast uses-vreg-reps drop { int-rep int-rep int-rep } ;
+M: ##compare-branch uses-vreg-reps drop { int-rep int-rep } ;
+M: ##compare-imm-branch uses-vreg-reps drop { int-rep } ;
+M: ##compare-float-branch uses-vreg-reps drop { double-float-rep double-float-rep } ;
+M: ##dispatch uses-vreg-reps drop { int-rep } ;
+M: ##alien-getter uses-vreg-reps drop { int-rep } ;
+M: ##alien-setter uses-vreg-reps drop { int-rep int-rep } ;
+M: ##set-alien-float uses-vreg-reps drop { int-rep double-float-rep } ;
+M: ##set-alien-double uses-vreg-reps drop { int-rep double-float-rep } ;
+M: ##fixnum-overflow uses-vreg-reps drop { int-rep int-rep } ;
+M: _compare-imm-branch uses-vreg-reps drop { int-rep } ;
+M: _compare-branch uses-vreg-reps drop { int-rep int-rep } ;
+M: _compare-float-branch uses-vreg-reps drop { double-float-rep double-float-rep } ;
+M: _dispatch uses-vreg-reps drop { int-rep } ;
+M: ##phi uses-vreg-reps drop "##phi must be special-cased" throw ;
+M: insn uses-vreg-reps drop f ;
+
+: each-def-rep ( insn vreg-quot: ( vreg rep -- ) -- )
+ [ [ defs-vreg ] [ defs-vreg-rep ] bi ] dip with when* ; inline
+
+: each-use-rep ( insn vreg-quot: ( vreg rep -- ) -- )
+ [ [ uses-vregs ] [ uses-vreg-reps ] bi ] dip 2each ; inline
+
+: each-temp-rep ( insn vreg-quot: ( vreg rep -- ) -- )
+ [ [ temp-vregs ] [ temp-vreg-reps ] bi ] dip 2each ; inline
+
+: with-vreg-reps ( cfg vreg-quot: ( vreg rep -- ) -- )
+ '[
+ [ basic-block set ] [
+ [
+ _
+ [ each-def-rep ]
+ [ each-use-rep ]
+ [ each-temp-rep ] 2tri
+ ] each-non-phi
+ ] bi
+ ] each-basic-block ; inline
--- /dev/null
+USING: tools.test cpu.architecture
+compiler.cfg.registers compiler.cfg.instructions
+compiler.cfg.representations.preferred ;
+IN: compiler.cfg.representations
+
+[ { double-float-rep double-float-rep } ] [
+ T{ ##add-float
+ { dst 5 }
+ { src1 3 }
+ { src2 4 }
+ } uses-vreg-reps
+] unit-test
+
+[ double-float-rep ] [
+ T{ ##alien-double
+ { dst 5 }
+ { src 3 }
+ } defs-vreg-rep
+] 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: kernel fry accessors sequences assocs sets namespaces
+arrays combinators make locals deques dlists
+cpu.architecture compiler.utilities
+compiler.cfg
+compiler.cfg.rpo
+compiler.cfg.registers
+compiler.cfg.instructions
+compiler.cfg.def-use
+compiler.cfg.utilities
+compiler.cfg.loop-detection
+compiler.cfg.renaming.functor
+compiler.cfg.representations.preferred ;
+IN: compiler.cfg.representations
+
+! Virtual register representation selection.
+
+: emit-conversion ( dst src dst-rep src-rep -- )
+ 2array {
+ { { int-rep int-rep } [ int-rep ##copy ] }
+ { { double-float-rep double-float-rep } [ double-float-rep ##copy ] }
+ { { double-float-rep int-rep } [ ##unbox-float ] }
+ { { int-rep double-float-rep } [ int-rep next-vreg-rep ##box-float ] }
+ } case ;
+
+<PRIVATE
+
+! For every vreg, compute possible representations.
+SYMBOL: possibilities
+
+: possible ( vreg -- reps ) possibilities get at ;
+
+: compute-possibilities ( cfg -- )
+ H{ } clone [ '[ swap _ conjoin-at ] with-vreg-reps ] keep
+ [ keys ] assoc-map possibilities set ;
+
+! Compute vregs which must remain tagged for their lifetime.
+SYMBOL: always-boxed
+
+:: (compute-always-boxed) ( vreg rep assoc -- )
+ rep int-rep eq? [
+ int-rep vreg assoc set-at
+ ] when ;
+
+: compute-always-boxed ( cfg -- assoc )
+ H{ } clone [
+ '[
+ [
+ dup ##load-reference? [ drop ] [
+ [ _ (compute-always-boxed) ] each-def-rep
+ ] if
+ ] each-non-phi
+ ] each-basic-block
+ ] keep ;
+
+! For every vreg, compute the cost of keeping it in every possible
+! representation.
+
+! Cost map maps vreg to representation to cost.
+SYMBOL: costs
+
+: init-costs ( -- )
+ possibilities get [ [ 0 ] H{ } map>assoc ] assoc-map costs set ;
+
+: increase-cost ( rep vreg -- )
+ ! Increase cost of keeping vreg in rep, making a choice of rep less
+ ! likely.
+ [ basic-block get loop-nesting-at ] 2dip costs get at at+ ;
+
+: maybe-increase-cost ( possible vreg preferred -- )
+ pick eq? [ 2drop ] [ increase-cost ] if ;
+
+: representation-cost ( vreg preferred -- )
+ ! 'preferred' is a representation that the instruction can accept with no cost.
+ ! So, for each representation that's not preferred, increase the cost of keeping
+ ! the vreg in that representation.
+ [ drop possible ]
+ [ '[ _ _ maybe-increase-cost ] ]
+ 2bi each ;
+
+: compute-costs ( cfg -- costs )
+ init-costs [ representation-cost ] with-vreg-reps costs get ;
+
+! For every vreg, compute preferred representation, that minimizes costs.
+: minimize-costs ( costs -- representations )
+ [ >alist alist-min first ] assoc-map ;
+
+: compute-representations ( cfg -- )
+ [ compute-costs minimize-costs ]
+ [ compute-always-boxed ]
+ bi assoc-union
+ representations set ;
+
+! Insert conversions. This introduces new temporaries, so we need
+! to rename opearands too.
+
+:: emit-def-conversion ( dst preferred required -- new-dst' )
+ ! If an instruction defines a register with representation 'required',
+ ! but the register has preferred representation 'preferred', then
+ ! we rename the instruction's definition to a new register, which
+ ! becomes the input of a conversion instruction.
+ dst required next-vreg-rep [ preferred required emit-conversion ] keep ;
+
+:: emit-use-conversion ( src preferred required -- new-src' )
+ ! If an instruction uses a register with representation 'required',
+ ! but the register has preferred representation 'preferred', then
+ ! we rename the instruction's input to a new register, which
+ ! becomes the output of a conversion instruction.
+ required next-vreg-rep [ src required preferred emit-conversion ] keep ;
+
+SYMBOLS: renaming-set needs-renaming? ;
+
+: init-renaming-set ( -- )
+ needs-renaming? off
+ V{ } clone renaming-set set ;
+
+: no-renaming ( vreg -- )
+ dup 2array renaming-set get push ;
+
+: record-renaming ( from to -- )
+ 2array renaming-set get push needs-renaming? on ;
+
+:: (compute-renaming-set) ( vreg required quot: ( vreg preferred required -- ) -- )
+ vreg rep-of :> preferred
+ preferred required eq?
+ [ vreg no-renaming ]
+ [ vreg vreg preferred required quot call record-renaming ] if ; inline
+
+: compute-renaming-set ( insn -- )
+ ! temp vregs don't need conversions since they're always in their
+ ! preferred representation
+ init-renaming-set
+ [ [ [ emit-use-conversion ] (compute-renaming-set) ] each-use-rep ]
+ [ , ]
+ [ [ [ emit-def-conversion ] (compute-renaming-set) ] each-def-rep ]
+ tri ;
+
+: converted-value ( vreg -- vreg' )
+ renaming-set get pop first2 [ assert= ] dip ;
+
+RENAMING: convert [ converted-value ] [ converted-value ] [ ]
+
+: perform-renaming ( insn -- )
+ needs-renaming? get [
+ renaming-set get reverse-here
+ [ convert-insn-uses ] [ convert-insn-defs ] bi
+ renaming-set get length 0 assert=
+ ] [ drop ] if ;
+
+GENERIC: conversions-for-insn ( insn -- )
+
+SYMBOL: phi-mappings
+
+! compiler.cfg.cssa inserts conversions which convert phi inputs into
+! the representation of the output. However, we still have to do some
+! processing here, because if the only node that uses the output of
+! the phi instruction is another phi instruction then this phi node's
+! output won't have a representation assigned.
+M: ##phi conversions-for-insn
+ [ , ] [ [ inputs>> values ] [ dst>> ] bi phi-mappings get set-at ] bi ;
+
+M: vreg-insn conversions-for-insn
+ [ compute-renaming-set ] [ perform-renaming ] bi ;
+
+M: insn conversions-for-insn , ;
+
+: conversions-for-block ( bb -- )
+ dup kill-block? [ drop ] [
+ [
+ [
+ [ conversions-for-insn ] each
+ ] V{ } make
+ ] change-instructions drop
+ ] if ;
+
+! If the output of a phi instruction is only used as the input to another
+! phi instruction, then we want to use the same representation for both
+! if possible.
+SYMBOL: work-list
+
+: add-to-work-list ( vregs -- )
+ work-list get push-all-front ;
+
+: rep-assigned ( vregs -- vregs' )
+ representations get '[ _ key? ] filter ;
+
+: rep-not-assigned ( vregs -- vregs' )
+ representations get '[ _ key? not ] filter ;
+
+: add-ready-phis ( -- )
+ phi-mappings get keys rep-assigned add-to-work-list ;
+
+: process-phi-mapping ( dst -- )
+ ! If dst = phi(src1,src2,...) and dst's representation has been
+ ! determined, assign that representation to each one of src1,...
+ ! that does not have a representation yet, and process those, too.
+ dup phi-mappings get at* [
+ [ rep-of ] [ rep-not-assigned ] bi*
+ [ [ set-rep-of ] with each ] [ add-to-work-list ] bi
+ ] [ 2drop ] if ;
+
+: remaining-phi-mappings ( -- )
+ phi-mappings get keys rep-not-assigned
+ [ [ int-rep ] dip set-rep-of ] each ;
+
+: process-phi-mappings ( -- )
+ <hashed-dlist> work-list set
+ add-ready-phis
+ work-list get [ process-phi-mapping ] slurp-deque
+ remaining-phi-mappings ;
+
+: insert-conversions ( cfg -- )
+ H{ } clone phi-mappings set
+ [ conversions-for-block ] each-basic-block
+ process-phi-mappings ;
+
+PRIVATE>
+
+: select-representations ( cfg -- cfg' )
+ needs-loops
+
+ {
+ [ compute-possibilities ]
+ [ compute-representations ]
+ [ insert-conversions ]
+ [ ]
+ } cleave
+ representations get cfg get (>>reps) ;
\ No newline at end of file
[ change-instructions drop ] 2bi ; inline
: local-optimization ( cfg quot: ( insns -- insns' ) -- cfg' )
- dupd '[ _ optimize-basic-block ] each-basic-block ; inline
\ No newline at end of file
+ dupd '[ _ optimize-basic-block ] each-basic-block ; inline
+
+: needs-post-order ( cfg -- cfg' )
+ dup post-order drop ;
\ No newline at end of file
reset-counters
V{
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##add-imm f V int-regs 2 V int-regs 1 50 }
- T{ ##add-imm f V int-regs 2 V int-regs 2 10 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##add-imm f 2 1 50 }
+ T{ ##add-imm f 2 2 10 }
T{ ##branch }
} 0 test-bb
V{
- T{ ##load-immediate f V int-regs 3 3 }
+ T{ ##load-immediate f 3 3 }
T{ ##branch }
} 1 test-bb
V{
- T{ ##load-immediate f V int-regs 3 4 }
+ T{ ##load-immediate f 3 4 }
T{ ##branch }
} 2 test-bb
V{
- T{ ##replace f V int-regs 3 D 0 }
+ T{ ##replace f 3 D 0 }
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
- compute-predecessors
+ dup cfg set
construct-ssa
drop ;
[
V{
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##add-imm f V int-regs 2 V int-regs 1 50 }
- T{ ##add-imm f V int-regs 3 V int-regs 2 10 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##add-imm f 2 1 50 }
+ T{ ##add-imm f 3 2 10 }
T{ ##branch }
}
] [ 0 get instructions>> ] unit-test
[
V{
- T{ ##load-immediate f V int-regs 4 3 }
+ T{ ##load-immediate f 4 3 }
T{ ##branch }
}
] [ 1 get instructions>> ] unit-test
[
V{
- T{ ##load-immediate f V int-regs 5 4 }
+ T{ ##load-immediate f 5 4 }
T{ ##branch }
}
] [ 2 get instructions>> ] unit-test
[
V{
- T{ ##phi f V int-regs 6 H{ { 1 V int-regs 4 } { 2 V int-regs 5 } } }
- T{ ##replace f V int-regs 6 D 0 }
+ T{ ##phi f 6 H{ { 1 4 } { 2 5 } } }
+ T{ ##replace f 6 D 0 }
T{ ##return }
}
] [
V{ } 0 test-bb
V{ } 1 test-bb
-V{ T{ ##peek f V int-regs 0 D 0 } } 2 test-bb
-V{ T{ ##peek f V int-regs 0 D 0 } } 3 test-bb
-V{ T{ ##replace f V int-regs 0 D 0 } } 4 test-bb
+V{ T{ ##peek f 0 D 0 } } 2 test-bb
+V{ T{ ##peek f 0 D 0 } } 3 test-bb
+V{ T{ ##replace f 0 D 0 } } 4 test-bb
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{
- 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{ ##phi f 3 H{ { 2 1 } { 3 2 } } }
+ T{ ##replace f 3 D 0 }
}
] [
4 get instructions>>
compiler.cfg.registers
compiler.cfg.dominance
compiler.cfg.instructions
+compiler.cfg.renaming
compiler.cfg.renaming.functor
compiler.cfg.ssa.construction.tdmsc ;
IN: compiler.cfg.ssa.construction
-! SSA construction. Predecessors must be computed first.
-
! The phi placement algorithm is implemented in
! compiler.cfg.ssa.construction.tdmsc.
H{ } clone stacks set ;
: gen-name ( vreg -- vreg' )
- [ reg-class>> next-vreg dup ] keep
+ [ next-vreg dup ] dip
dup pushed get 2dup key?
[ 2drop stacks get at set-last ]
[ conjoin stacks get push-at ]
: construct-ssa ( cfg -- cfg' )
{
- [ ]
[ compute-live-sets ]
- [ compute-dominance ]
[ compute-merge-sets ]
[ compute-defs compute-phi-nodes insert-phi-nodes ]
[ rename ]
+ [ ]
} cleave ;
\ No newline at end of file
IN: compiler.cfg.ssa.construction.tdmsc.tests
: test-tdmsc ( -- )
- cfg new 0 get >>entry
- compute-predecessors
- dup compute-dominance
+ cfg new 0 get >>entry dup cfg set
compute-merge-sets ;
V{ } 0 test-bb
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
PRIVATE>
: compute-merge-sets ( cfg -- )
- dup cfg set
+ needs-dominance
+
H{ } clone visited set
[ compute-levels ]
[ init-merge-sets ]
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs kernel locals fry
+cpu.architecture
+compiler.cfg.rpo
+compiler.cfg.utilities
+compiler.cfg.registers
+compiler.cfg.instructions
+compiler.cfg.representations ;
+IN: compiler.cfg.ssa.cssa
+
+! Convert SSA to conventional SSA. This pass runs after representation
+! selection, so it must keep track of representations when introducing
+! new values.
+
+:: insert-copy ( bb src rep -- bb dst )
+ rep next-vreg-rep :> dst
+ bb [ dst src rep src rep-of emit-conversion ] add-instructions
+ bb dst ;
+
+: convert-phi ( ##phi -- )
+ dup dst>> rep-of '[ [ _ 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 compute-dominance
- dup compute-live-ranges
- dup process-blocks
- break-interferences
- dup perform-renaming
- insert-copies
- dup remove-phis
- ] when ;
\ No newline at end of file
+ needs-dominance
+
+ dup construct-cssa
+ dup compute-defs
+ compute-ssa-live-sets
+ dup compute-live-ranges
+ dup prepare-coalescing
+ process-copies
+ dup perform-renaming ;
\ 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.ssa 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? [ 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 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.ssa
-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? ;
-
-:: phi-node-is-live-out-of-operand's-block? ( bb src dst -- ? )
- dst src def-of live-out? ;
-
-:: operand-is-phi-node-and-live-into-operand's-block? ( bb src dst -- ? )
- { [ src insn-of ##phi? ] [ src src def-of live-in? ] } 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>> ] bi* live-in? ;
-
-: node-is-live-out-of-child? ( node child -- ? )
- [ vreg>> ] [ bb>> ] bi* live-out? ;
-
-:: 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
+ dup compute-defs
+ compute-live-ranges ;
+
+V{
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 2 D 0 }
+ T{ ##copy f 1 0 }
+ T{ ##copy f 3 2 }
+ T{ ##branch }
+} 0 test-bb
+
+V{
+ T{ ##peek f 4 D 0 }
+ T{ ##peek f 5 D 0 }
+ T{ ##replace f 3 D 0 }
+ T{ ##peek f 6 D 0 }
+ T{ ##replace f 5 D 0 }
+ T{ ##return }
+} 1 test-bb
+
+0 1 edge
+
+[ ] [ test-interference ] unit-test
+
+[ f ] [ 0 1 vregs-interfere? ] unit-test
+[ f ] [ 1 0 vregs-interfere? ] unit-test
+[ f ] [ 2 3 vregs-interfere? ] unit-test
+[ f ] [ 3 2 vregs-interfere? ] unit-test
+[ t ] [ 0 2 vregs-interfere? ] unit-test
+[ t ] [ 2 0 vregs-interfere? ] unit-test
+[ f ] [ 1 3 vregs-interfere? ] unit-test
+[ f ] [ 3 1 vregs-interfere? ] unit-test
+[ t ] [ 3 4 vregs-interfere? ] unit-test
+[ t ] [ 4 3 vregs-interfere? ] unit-test
+[ t ] [ 3 5 vregs-interfere? ] unit-test
+[ t ] [ 5 3 vregs-interfere? ] unit-test
+[ f ] [ 3 6 vregs-interfere? ] unit-test
+[ f ] [ 6 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
+
+! Interference testing using SSA properties. Actually the only SSA property
+! used here is that definitions dominate uses; because of this, the input
+! is allowed to have multiple definitions of each vreg as long as they're
+! all in the same basic block. This is needed because two-operand conversion
+! runs before coalescing, which uses SSA interference testing.
+<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 ;
+
+<PRIVATE
+
+! Debug this stuff later
+
+: 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 compiler.cfg.dominance ;
+IN: compiler.cfg.ssa.interference.live-ranges
+
+! Live ranges for interference testing
+
+<PRIVATE
+
+SYMBOLS: local-def-indices local-kill-indices ;
+
+: record-def ( n vreg -- )
+ ! We allow multiple defs of a vreg as long as they're
+ ! all in the same basic block
+ dup [
+ local-def-indices get 2dup key?
+ [ 3drop ] [ set-at ] if
+ ] [ 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 -- )
+ needs-dominance
+
+ 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
+ dup compute-defs
+ dup compute-uses
+ needs-dominance
+ precompute-liveness ;
+
+V{
+ T{ ##peek f 0 D 0 }
+ T{ ##replace f 0 D 0 }
+ T{ ##replace f 1 D 1 }
+} 0 test-bb
+
+V{
+ T{ ##replace f 2 D 0 }
+} 1 test-bb
+
+V{
+ T{ ##replace f 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 ] [ 0 0 get live-in? ] unit-test
+[ t ] [ 1 0 get live-in? ] unit-test
+[ t ] [ 2 0 get live-in? ] unit-test
+[ t ] [ 3 0 get live-in? ] unit-test
+
+[ f ] [ 0 0 get live-out? ] unit-test
+[ f ] [ 1 0 get live-out? ] unit-test
+[ t ] [ 2 0 get live-out? ] unit-test
+[ t ] [ 3 0 get live-out? ] unit-test
+
+[ f ] [ 0 1 get live-in? ] unit-test
+[ f ] [ 1 1 get live-in? ] unit-test
+[ t ] [ 2 1 get live-in? ] unit-test
+[ f ] [ 3 1 get live-in? ] unit-test
+
+[ f ] [ 0 1 get live-out? ] unit-test
+[ f ] [ 1 1 get live-out? ] unit-test
+[ f ] [ 2 1 get live-out? ] unit-test
+[ f ] [ 3 1 get live-out? ] unit-test
+
+[ f ] [ 0 2 get live-in? ] unit-test
+[ f ] [ 1 2 get live-in? ] unit-test
+[ f ] [ 2 2 get live-in? ] unit-test
+[ t ] [ 3 2 get live-in? ] unit-test
+
+[ f ] [ 0 2 get live-out? ] unit-test
+[ f ] [ 1 2 get live-out? ] unit-test
+[ f ] [ 2 2 get live-out? ] unit-test
+[ f ] [ 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 2 H{ { 2 0 } { 3 1 } } }
+} 4 test-bb
+test-diamond
+
+[ ] [ test-liveness ] unit-test
+
+[ t ] [ 0 1 get live-in? ] unit-test
+[ t ] [ 1 1 get live-in? ] unit-test
+[ f ] [ 2 1 get live-in? ] unit-test
+
+[ t ] [ 0 1 get live-out? ] unit-test
+[ t ] [ 1 1 get live-out? ] unit-test
+[ f ] [ 2 1 get live-out? ] unit-test
+
+[ t ] [ 0 2 get live-in? ] unit-test
+[ f ] [ 1 2 get live-in? ] unit-test
+[ f ] [ 2 2 get live-in? ] unit-test
+
+[ f ] [ 0 2 get live-out? ] unit-test
+[ f ] [ 1 2 get live-out? ] unit-test
+[ f ] [ 2 2 get live-out? ] unit-test
+
+[ f ] [ 0 3 get live-in? ] unit-test
+[ t ] [ 1 3 get live-in? ] unit-test
+[ f ] [ 2 3 get live-in? ] unit-test
+
+[ f ] [ 0 3 get live-out? ] unit-test
+[ f ] [ 1 3 get live-out? ] unit-test
+[ f ] [ 2 3 get live-out? ] unit-test
+
+[ f ] [ 0 4 get live-in? ] unit-test
+[ f ] [ 1 4 get live-in? ] unit-test
+[ f ] [ 2 4 get live-in? ] unit-test
+
+[ f ] [ 0 4 get live-out? ] unit-test
+[ f ] [ 1 4 get live-out? ] unit-test
+[ f ] [ 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 0 D 0 }
+ T{ ##peek f 1 D 0 }
+ T{ ##peek f 2 D 0 }
+} 3 test-bb
+V{ } 11 test-bb
+2 { 3 11 } edges
+V{
+ T{ ##replace f 0 D 0 }
+} 4 test-bb
+V{ } 8 test-bb
+3 { 8 4 } edges
+V{
+ T{ ##replace f 1 D 0 }
+} 9 test-bb
+8 9 edge
+V{
+ T{ ##replace f 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 ] [ 0 1 get live-in? ] unit-test
+[ f ] [ 1 1 get live-in? ] unit-test
+[ f ] [ 2 1 get live-in? ] unit-test
+
+[ f ] [ 0 1 get live-out? ] unit-test
+[ f ] [ 1 1 get live-out? ] unit-test
+[ f ] [ 2 1 get live-out? ] unit-test
+
+[ f ] [ 0 2 get live-in? ] unit-test
+[ f ] [ 1 2 get live-in? ] unit-test
+[ f ] [ 2 2 get live-in? ] unit-test
+
+[ f ] [ 0 2 get live-out? ] unit-test
+[ f ] [ 1 2 get live-out? ] unit-test
+[ f ] [ 2 2 get live-out? ] unit-test
+
+[ f ] [ 0 3 get live-in? ] unit-test
+[ f ] [ 1 3 get live-in? ] unit-test
+[ f ] [ 2 3 get live-in? ] unit-test
+
+[ t ] [ 0 3 get live-out? ] unit-test
+[ t ] [ 1 3 get live-out? ] unit-test
+[ t ] [ 2 3 get live-out? ] unit-test
+
+[ t ] [ 0 4 get live-in? ] unit-test
+[ f ] [ 1 4 get live-in? ] unit-test
+[ t ] [ 2 4 get live-in? ] unit-test
+
+[ f ] [ 0 4 get live-out? ] unit-test
+[ f ] [ 1 4 get live-out? ] unit-test
+[ t ] [ 2 4 get live-out? ] unit-test
+
+[ f ] [ 0 5 get live-in? ] unit-test
+[ f ] [ 1 5 get live-in? ] unit-test
+[ t ] [ 2 5 get live-in? ] unit-test
+
+[ f ] [ 0 5 get live-out? ] unit-test
+[ f ] [ 1 5 get live-out? ] unit-test
+[ t ] [ 2 5 get live-out? ] unit-test
+
+[ f ] [ 0 6 get live-in? ] unit-test
+[ f ] [ 1 6 get live-in? ] unit-test
+[ t ] [ 2 6 get live-in? ] unit-test
+
+[ f ] [ 0 6 get live-out? ] unit-test
+[ f ] [ 1 6 get live-out? ] unit-test
+[ t ] [ 2 6 get live-out? ] unit-test
+
+[ f ] [ 0 7 get live-in? ] unit-test
+[ f ] [ 1 7 get live-in? ] unit-test
+[ f ] [ 2 7 get live-in? ] unit-test
+
+[ f ] [ 0 7 get live-out? ] unit-test
+[ f ] [ 1 7 get live-out? ] unit-test
+[ f ] [ 2 7 get live-out? ] unit-test
+
+[ f ] [ 0 8 get live-in? ] unit-test
+[ t ] [ 1 8 get live-in? ] unit-test
+[ t ] [ 2 8 get live-in? ] unit-test
+
+[ f ] [ 0 8 get live-out? ] unit-test
+[ t ] [ 1 8 get live-out? ] unit-test
+[ t ] [ 2 8 get live-out? ] unit-test
+
+[ f ] [ 0 9 get live-in? ] unit-test
+[ t ] [ 1 9 get live-in? ] unit-test
+[ t ] [ 2 9 get live-in? ] unit-test
+
+[ f ] [ 0 9 get live-out? ] unit-test
+[ t ] [ 1 9 get live-out? ] unit-test
+[ t ] [ 2 9 get live-out? ] unit-test
+
+[ f ] [ 0 10 get live-in? ] unit-test
+[ t ] [ 1 10 get live-in? ] unit-test
+[ t ] [ 2 10 get live-in? ] unit-test
+
+[ f ] [ 0 10 get live-out? ] unit-test
+[ t ] [ 1 10 get live-out? ] unit-test
+[ t ] [ 2 10 get live-out? ] unit-test
+
+[ f ] [ 0 11 get live-in? ] unit-test
+[ f ] [ 1 11 get live-in? ] unit-test
+[ f ] [ 2 11 get live-in? ] unit-test
+
+[ f ] [ 0 11 get live-out? ] unit-test
+[ f ] [ 1 11 get live-out? ] unit-test
+[ f ] [ 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
+ ] ;
{ return integer }
{ total-size integer }
{ gc-root-size integer }
-spill-counts ;
+{ spill-area-size integer } ;
! Stack frame utilities
: param-base ( -- n )
stack-frame get [ params>> ] [ return>> ] bi + ;
-: spill-float-offset ( n -- offset )
- double-float-regs reg-size * ;
-
-: spill-integer-base ( -- n )
- stack-frame get spill-counts>> double-float-regs [ swap at ] keep reg-size *
+: spill-offset ( n -- offset )
param-base + ;
-: spill-integer-offset ( n -- offset )
- cells spill-integer-base + ;
-
-: spill-area-size ( stack-frame -- n )
- spill-counts>> [ swap reg-size * ] { } assoc>map sum ;
-
: gc-root-base ( -- n )
- stack-frame get spill-area-size
- param-base + ;
+ stack-frame get spill-area-size>> param-base + ;
: gc-root-offset ( n -- n' ) gc-root-base + ;
-: gc-roots-size ( live-values -- n )
- keys [ reg-class>> reg-size ] sigma ;
-
: (stack-frame-size) ( stack-frame -- n )
[
{
- [ spill-area-size ]
- [ gc-root-size>> ]
[ params>> ]
[ return>> ]
+ [ gc-root-size>> ]
+ [ spill-area-size>> ]
} cleave
] sum-outputs ;
! 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 ;
+compiler.cfg.stacks.global compiler.cfg.stacks.height
+compiler.cfg.predecessors ;
IN: compiler.cfg.stacks.finalize
! 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 ;
: finalize-stack-shuffling ( cfg -- cfg' )
+ needs-predecessors
+
dup [ visit-block ] each-basic-block
+
cfg-changed ;
\ No newline at end of file
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 ;
+: loc>vreg ( loc -- vreg ) locs>vregs get [ drop next-vreg ] 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 ( -- )
cfg get
- compute-predecessors
compute-global-sets
finalize-stack-shuffling
drop ;
: test-uninitialized ( -- )
cfg new 0 get >>entry
- compute-predecessors
compute-uninitialized-sets ;
V{
} 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{ ##replace f 0 D 0 }
+ T{ ##replace f 0 D 1 }
+ T{ ##replace f 0 D 2 }
T{ ##inc-r f 1 }
} 1 test-bb
V{
- T{ ##peek f V int-regs 0 D 0 }
+ T{ ##peek f 0 D 0 }
T{ ##inc-d f 1 }
} 2 test-bb
-0 get 1 get 1vector >>successors drop
-1 get 2 get 1vector >>successors drop
+0 1 edge
+1 2 edge
[ ] [ test-uninitialized ] unit-test
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-uninitialized ] unit-test
: finish ( -- pair ) ds-loc get rs-loc get 2array ;
: (join-sets) ( seq1 seq2 -- seq )
- 2dup [ length ] bi@ max '[ _ 1 pad-tail ] bi@ [ min ] 2map ;
+ 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
compiler.cfg.utilities ;
IN: compiler.cfg.tco
-! Tail call optimization. You must run compute-predecessors after this
+! Tail call optimization.
: return? ( bb -- ? )
skip-empty-blocks
] [ drop ] if ;
: optimize-tail-calls ( cfg -- cfg' )
- dup cfg set
dup [ optimize-tail-call ] each-basic-block
- cfg-changed ;
\ No newline at end of file
+
+ cfg-changed predecessors-changed ;
\ No newline at end of file
IN: compiler.cfg.two-operand.tests
-USING: compiler.cfg.two-operand compiler.cfg.instructions
+USING: kernel compiler.cfg.two-operand compiler.cfg.instructions
compiler.cfg.registers cpu.architecture namespaces tools.test ;
3 vreg-counter set-global
[
V{
- 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 3 }
+ T{ ##copy f 1 2 int-rep }
+ T{ ##sub f 1 1 3 }
}
] [
+ H{
+ { 1 int-rep }
+ { 2 int-rep }
+ { 3 int-rep }
+ } clone representations set
{
- T{ ##sub f V int-regs 1 V int-regs 2 V int-regs 3 }
+ T{ ##sub f 1 2 3 }
} (convert-two-operand)
] unit-test
[
V{
- T{ ##sub f V int-regs 1 V int-regs 1 V int-regs 2 }
+ T{ ##copy f 1 2 double-float-rep }
+ T{ ##sub-float f 1 1 3 }
}
] [
+ H{
+ { 1 double-float-rep }
+ { 2 double-float-rep }
+ { 3 double-float-rep }
+ } clone representations set
{
- T{ ##sub f V int-regs 1 V int-regs 1 V int-regs 2 }
+ T{ ##sub-float f 1 2 3 }
} (convert-two-operand)
] unit-test
[
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 1 2 double-float-rep }
+ T{ ##mul-float f 1 1 1 }
}
] [
+ H{
+ { 1 double-float-rep }
+ { 2 double-float-rep }
+ } clone representations set
{
- T{ ##sub f V int-regs 1 V int-regs 2 V int-regs 1 }
+ T{ ##mul-float f 1 2 2 }
} (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
compiler.cfg.rpo cpu.architecture ;
IN: compiler.cfg.two-operand
-! This pass runs after SSA coalescing and normalizes instructions
-! to fit the x86 two-address scheme. Possibilities are:
-
-! 1) x = x op y
-! 2) x = y op x
-! 3) x = y op z
-
-! In case 1, there is nothing to do.
-
-! In case 2, we convert to
-! z = y
-! z = z op x
-! x = z
-
-! In case 3, we convert to
+! This pass runs before SSA coalescing and normalizes instructions
+! to fit the x86 two-address scheme. Since the input is in SSA,
+! it suffices to convert
+!
+! x = y op z
+!
+! to
+!
! x = y
! x = x op z
-
-! In case 2 and case 3, linear scan coalescing will eliminate a
-! copy if the value y is never used again.
-
+!
! We don't bother with ##add, ##add-imm, ##sub-imm or ##mul-imm
! since x86 has LEA and IMUL instructions which are effectively
! three-operand addition and multiplication, respectively.
GENERIC: convert-two-operand* ( insn -- )
: emit-copy ( dst src -- )
- dup reg-class>> {
- { int-regs [ ##copy ] }
- { double-float-regs [ ##copy-float ] }
- } case ; inline
-
-: case-1? ( insn -- ? ) [ dst>> ] [ src1>> ] bi = ; inline
-
-: case-1 ( insn -- ) , ; inline
-
-: 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 ]
- 2tri ; inline
-
-: case-3 ( insn -- )
- [ [ dst>> ] [ src1>> ] bi emit-copy ]
- [ dup dst>> >>src1 , ]
- bi ; inline
+ dup rep-of ##copy ; inline
M: two-operand-insn convert-two-operand*
- {
- { [ dup case-1? ] [ case-1 ] }
- { [ dup case-2? ] [ case-2 ] }
- [ case-3 ]
- } cond ; inline
+ [ [ dst>> ] [ src1>> ] bi emit-copy ]
+ [
+ dup [ src1>> ] [ src2>> ] bi = [ dup dst>> >>src2 ] when
+ dup dst>> >>src1 ,
+ ] bi ;
M: ##not convert-two-operand*
- dup [ dst>> ] [ src>> ] bi = [
- [ [ dst>> ] [ src>> ] bi ##copy ]
- [ dup dst>> >>src ]
- bi
- ] unless , ;
+ [ [ dst>> ] [ src>> ] bi emit-copy ]
+ [ dup dst>> >>src , ]
+ bi ;
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
dup [
dup delete-conditional? [ delete-conditional ] [ drop ] if
] each-basic-block
- cfg-changed ;
+
+ cfg-changed predecessors-changed ;
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
+
+: each-non-phi ( bb quot: ( insn -- ) -- )
+ [ instructions>> ] dip
+ '[ dup ##phi? [ drop ] _ if ] each ; inline
+
: predecessor ( bb -- pred )
predecessors>> first ; inline
fry kernel layouts math namespaces sequences cpu.architecture
math.bitwise math.order classes vectors
compiler.cfg
-compiler.cfg.hats
+compiler.cfg.registers
compiler.cfg.comparisons
compiler.cfg.instructions
compiler.cfg.value-numbering.expressions
M: ##compare-imm rewrite-tagged-comparison
[ dst>> ] [ (rewrite-tagged-comparison) ] bi
- i \ ##compare-imm new-insn ;
+ next-vreg \ ##compare-imm new-insn ;
: rewrite-redundant-comparison? ( insn -- ? )
{
: rewrite-redundant-comparison ( insn -- insn' )
[ cc>> ] [ dst>> ] [ src1>> vreg>expr dup op>> ] tri {
- { \ ##compare [ >compare-expr< i \ ##compare new-insn ] }
- { \ ##compare-imm [ >compare-imm-expr< i \ ##compare-imm new-insn ] }
- { \ ##compare-float [ >compare-expr< i \ ##compare-float new-insn ] }
+ { \ ##compare [ >compare-expr< next-vreg \ ##compare new-insn ] }
+ { \ ##compare-imm [ >compare-imm-expr< next-vreg \ ##compare-imm new-insn ] }
+ { \ ##compare-float [ >compare-expr< next-vreg \ ##compare-float new-insn ] }
} case
swap cc= eq? [ [ negate-cc ] change-cc ] when ;
] dip
swap-compare
[ vreg>constant ] dip
- i \ ##compare-imm new-insn ; inline
+ next-vreg \ ##compare-imm new-insn ; inline
: >boolean-insn ( insn ? -- insn' )
[ dst>> ] dip
! Return value of f means we didn't simplify.
GENERIC: simplify* ( expr -- vn/expr/f )
-: simplify-unbox ( in boxer -- vn/expr/f )
- over op>> eq? [ in>> ] [ drop f ] if ; inline
-
-: simplify-unbox-float ( in -- vn/expr/f )
- \ ##box-float simplify-unbox ; inline
-
: simplify-unbox-alien ( in -- vn/expr/f )
- \ ##box-alien simplify-unbox ; inline
+ dup op>> \ ##box-alien eq? [ in>> ] [ drop f ] if ; inline
M: unary-expr simplify*
#! Note the copy propagation: a copy always simplifies to
#! its source VN.
[ in>> vn>expr ] [ op>> ] bi {
{ \ ##copy [ ] }
- { \ ##copy-float [ ] }
- { \ ##unbox-float [ simplify-unbox-float ] }
{ \ ##unbox-alien [ simplify-unbox-alien ] }
{ \ ##unbox-any-c-ptr [ simplify-unbox-alien ] }
[ 2drop f ]
-IN: compiler.cfg.value-numbering.tests
USING: compiler.cfg.value-numbering compiler.cfg.instructions
compiler.cfg.registers compiler.cfg.debugger compiler.cfg.comparisons
cpu.architecture tools.test kernel math combinators.short-circuit
-accessors sequences compiler.cfg.predecessors locals
-compiler.cfg.dce compiler.cfg.ssa.destruction
-compiler.cfg assocs vectors arrays layouts namespaces ;
+accessors sequences compiler.cfg.predecessors locals compiler.cfg.dce
+compiler.cfg.ssa.destruction compiler.cfg.loop-detection
+compiler.cfg.representations compiler.cfg assocs vectors arrays
+layouts namespaces ;
+IN: compiler.cfg.value-numbering.tests
: trim-temps ( insns -- insns )
[
! Folding constants together
[
{
- T{ ##load-reference f V int-regs 0 0.0 }
- T{ ##load-reference f V int-regs 1 -0.0 }
- T{ ##replace f V int-regs 0 D 0 }
- T{ ##replace f V int-regs 1 D 1 }
+ T{ ##load-reference f 0 0.0 }
+ T{ ##load-reference f 1 -0.0 }
+ T{ ##replace f 0 D 0 }
+ T{ ##replace f 1 D 1 }
}
] [
{
- T{ ##load-reference f V int-regs 0 0.0 }
- T{ ##load-reference f V int-regs 1 -0.0 }
- T{ ##replace f V int-regs 0 D 0 }
- T{ ##replace f V int-regs 1 D 1 }
+ T{ ##load-reference f 0 0.0 }
+ T{ ##load-reference f 1 -0.0 }
+ T{ ##replace f 0 D 0 }
+ T{ ##replace f 1 D 1 }
} value-numbering-step
] unit-test
[
{
- T{ ##load-reference f V int-regs 0 0.0 }
- T{ ##copy f V int-regs 1 V int-regs 0 }
- T{ ##replace f V int-regs 0 D 0 }
- T{ ##replace f V int-regs 1 D 1 }
+ T{ ##load-reference f 0 0.0 }
+ T{ ##copy f 1 0 any-rep }
+ T{ ##replace f 0 D 0 }
+ T{ ##replace f 1 D 1 }
}
] [
{
- T{ ##load-reference f V int-regs 0 0.0 }
- T{ ##load-reference f V int-regs 1 0.0 }
- T{ ##replace f V int-regs 0 D 0 }
- T{ ##replace f V int-regs 1 D 1 }
+ T{ ##load-reference f 0 0.0 }
+ T{ ##load-reference f 1 0.0 }
+ T{ ##replace f 0 D 0 }
+ T{ ##replace f 1 D 1 }
} value-numbering-step
] unit-test
[
{
- T{ ##load-reference f V int-regs 0 t }
- T{ ##copy f V int-regs 1 V int-regs 0 }
- T{ ##replace f V int-regs 0 D 0 }
- T{ ##replace f V int-regs 1 D 1 }
+ T{ ##load-reference f 0 t }
+ T{ ##copy f 1 0 any-rep }
+ T{ ##replace f 0 D 0 }
+ T{ ##replace f 1 D 1 }
}
] [
{
- T{ ##load-reference f V int-regs 0 t }
- T{ ##load-reference f V int-regs 1 t }
- T{ ##replace f V int-regs 0 D 0 }
- T{ ##replace f V int-regs 1 D 1 }
+ T{ ##load-reference f 0 t }
+ T{ ##load-reference f 1 t }
+ T{ ##replace f 0 D 0 }
+ T{ ##replace f 1 D 1 }
} value-numbering-step
] unit-test
! Compare propagation
[
{
- T{ ##load-reference f V int-regs 1 + }
- T{ ##peek f V int-regs 2 D 0 }
- T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc> }
- T{ ##copy f V int-regs 6 V int-regs 4 }
- T{ ##replace f V int-regs 6 D 0 }
+ T{ ##load-reference f 1 + }
+ T{ ##peek f 2 D 0 }
+ T{ ##compare f 4 2 1 cc> }
+ T{ ##copy f 6 4 any-rep }
+ T{ ##replace f 6 D 0 }
}
] [
{
- T{ ##load-reference f V int-regs 1 + }
- T{ ##peek f V int-regs 2 D 0 }
- T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc> }
- T{ ##compare-imm f V int-regs 6 V int-regs 4 5 cc/= }
- T{ ##replace f V int-regs 6 D 0 }
+ T{ ##load-reference f 1 + }
+ T{ ##peek f 2 D 0 }
+ T{ ##compare f 4 2 1 cc> }
+ T{ ##compare-imm f 6 4 5 cc/= }
+ T{ ##replace f 6 D 0 }
} value-numbering-step trim-temps
] unit-test
[
{
- T{ ##load-reference f V int-regs 1 + }
- T{ ##peek f V int-regs 2 D 0 }
- T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc<= }
- T{ ##compare f V int-regs 6 V int-regs 2 V int-regs 1 cc> }
- T{ ##replace f V int-regs 6 D 0 }
+ T{ ##load-reference f 1 + }
+ T{ ##peek f 2 D 0 }
+ T{ ##compare f 4 2 1 cc<= }
+ T{ ##compare f 6 2 1 cc> }
+ T{ ##replace f 6 D 0 }
}
] [
{
- T{ ##load-reference f V int-regs 1 + }
- T{ ##peek f V int-regs 2 D 0 }
- T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc<= }
- T{ ##compare-imm f V int-regs 6 V int-regs 4 5 cc= }
- T{ ##replace f V int-regs 6 D 0 }
+ T{ ##load-reference f 1 + }
+ T{ ##peek f 2 D 0 }
+ T{ ##compare f 4 2 1 cc<= }
+ T{ ##compare-imm f 6 4 5 cc= }
+ T{ ##replace f 6 D 0 }
} value-numbering-step trim-temps
] unit-test
[
{
- T{ ##peek f V int-regs 8 D 0 }
- T{ ##peek f V int-regs 9 D -1 }
- T{ ##unbox-float f V double-float-regs 10 V int-regs 8 }
- T{ ##unbox-float f V double-float-regs 11 V int-regs 9 }
- T{ ##compare-float f V int-regs 12 V double-float-regs 10 V double-float-regs 11 cc< }
- T{ ##compare-float f V int-regs 14 V double-float-regs 10 V double-float-regs 11 cc>= }
- T{ ##replace f V int-regs 14 D 0 }
+ T{ ##peek f 8 D 0 }
+ T{ ##peek f 9 D -1 }
+ T{ ##unbox-float f 10 8 }
+ T{ ##unbox-float f 11 9 }
+ T{ ##compare-float f 12 10 11 cc< }
+ T{ ##compare-float f 14 10 11 cc>= }
+ T{ ##replace f 14 D 0 }
}
] [
{
- T{ ##peek f V int-regs 8 D 0 }
- T{ ##peek f V int-regs 9 D -1 }
- T{ ##unbox-float f V double-float-regs 10 V int-regs 8 }
- T{ ##unbox-float f V double-float-regs 11 V int-regs 9 }
- T{ ##compare-float f V int-regs 12 V double-float-regs 10 V double-float-regs 11 cc< }
- T{ ##compare-imm f V int-regs 14 V int-regs 12 5 cc= }
- T{ ##replace f V int-regs 14 D 0 }
+ T{ ##peek f 8 D 0 }
+ T{ ##peek f 9 D -1 }
+ T{ ##unbox-float f 10 8 }
+ T{ ##unbox-float f 11 9 }
+ T{ ##compare-float f 12 10 11 cc< }
+ T{ ##compare-imm f 14 12 5 cc= }
+ T{ ##replace f 14 D 0 }
} value-numbering-step trim-temps
] unit-test
[
{
- T{ ##peek f V int-regs 29 D -1 }
- T{ ##peek f V int-regs 30 D -2 }
- T{ ##compare f V int-regs 33 V int-regs 29 V int-regs 30 cc<= }
- T{ ##compare-branch f V int-regs 29 V int-regs 30 cc<= }
+ T{ ##peek f 29 D -1 }
+ T{ ##peek f 30 D -2 }
+ T{ ##compare f 33 29 30 cc<= }
+ T{ ##compare-branch f 29 30 cc<= }
}
] [
{
- T{ ##peek f V int-regs 29 D -1 }
- T{ ##peek f V int-regs 30 D -2 }
- T{ ##compare f V int-regs 33 V int-regs 29 V int-regs 30 cc<= }
- T{ ##compare-imm-branch f V int-regs 33 5 cc/= }
+ T{ ##peek f 29 D -1 }
+ T{ ##peek f 30 D -2 }
+ T{ ##compare f 33 29 30 cc<= }
+ T{ ##compare-imm-branch f 33 5 cc/= }
} value-numbering-step trim-temps
] unit-test
! Immediate operand conversion
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##add-imm f V int-regs 2 V int-regs 0 100 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##add-imm f 2 0 100 }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##add f V int-regs 2 V int-regs 0 V int-regs 1 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##add f 2 0 1 }
} value-numbering-step
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##add-imm f V int-regs 2 V int-regs 0 100 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##add-imm f 2 0 100 }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##add f V int-regs 2 V int-regs 1 V int-regs 0 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##add f 2 1 0 }
} value-numbering-step
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##add-imm f V int-regs 2 V int-regs 0 -100 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##add-imm f 2 0 -100 }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##sub f V int-regs 2 V int-regs 0 V int-regs 1 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##sub f 2 0 1 }
} value-numbering-step
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 0 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 0 }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##sub f V int-regs 1 V int-regs 0 V int-regs 0 }
+ T{ ##peek f 0 D 0 }
+ T{ ##sub f 1 0 0 }
} value-numbering-step
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##mul-imm f V int-regs 2 V int-regs 0 100 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##mul-imm f 2 0 100 }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##mul f V int-regs 2 V int-regs 0 V int-regs 1 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##mul f 2 0 1 }
} value-numbering-step
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##mul-imm f V int-regs 2 V int-regs 0 100 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##mul-imm f 2 0 100 }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##mul f V int-regs 2 V int-regs 1 V int-regs 0 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##mul f 2 1 0 }
} value-numbering-step
] unit-test
[
{
- T{ ##peek f V int-regs 1 D 0 }
- T{ ##shl-imm f V int-regs 2 V int-regs 1 3 }
+ T{ ##peek f 1 D 0 }
+ T{ ##shl-imm f 2 1 3 }
}
] [
{
- T{ ##peek f V int-regs 1 D 0 }
- T{ ##mul-imm f V int-regs 2 V int-regs 1 8 }
+ T{ ##peek f 1 D 0 }
+ T{ ##mul-imm f 2 1 8 }
} value-numbering-step
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##and-imm f V int-regs 2 V int-regs 0 100 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##and-imm f 2 0 100 }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##and f V int-regs 2 V int-regs 0 V int-regs 1 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##and f 2 0 1 }
} value-numbering-step
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##and-imm f V int-regs 2 V int-regs 0 100 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##and-imm f 2 0 100 }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##and f V int-regs 2 V int-regs 1 V int-regs 0 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##and f 2 1 0 }
} value-numbering-step
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##or-imm f V int-regs 2 V int-regs 0 100 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##or-imm f 2 0 100 }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##or f V int-regs 2 V int-regs 0 V int-regs 1 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##or f 2 0 1 }
} value-numbering-step
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##or-imm f V int-regs 2 V int-regs 0 100 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##or-imm f 2 0 100 }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##or f V int-regs 2 V int-regs 1 V int-regs 0 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##or f 2 1 0 }
} value-numbering-step
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##xor-imm f V int-regs 2 V int-regs 0 100 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##xor-imm f 2 0 100 }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##xor f V int-regs 2 V int-regs 0 V int-regs 1 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##xor f 2 0 1 }
} value-numbering-step
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##xor-imm f V int-regs 2 V int-regs 0 100 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##xor-imm f 2 0 100 }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##xor f V int-regs 2 V int-regs 1 V int-regs 0 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##xor f 2 1 0 }
} value-numbering-step
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##compare-imm f V int-regs 2 V int-regs 0 100 cc<= }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##compare-imm f 2 0 100 cc<= }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##compare f V int-regs 2 V int-regs 0 V int-regs 1 cc<= }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##compare f 2 0 1 cc<= }
} value-numbering-step trim-temps
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##compare-imm f V int-regs 2 V int-regs 0 100 cc>= }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##compare-imm f 2 0 100 cc>= }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##compare f V int-regs 2 V int-regs 1 V int-regs 0 cc<= }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##compare f 2 1 0 cc<= }
} value-numbering-step trim-temps
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##compare-imm-branch f V int-regs 0 100 cc<= }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##compare-imm-branch f 0 100 cc<= }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##compare-branch f V int-regs 0 V int-regs 1 cc<= }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##compare-branch f 0 1 cc<= }
} value-numbering-step
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##compare-imm-branch f V int-regs 0 100 cc>= }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##compare-imm-branch f 0 100 cc>= }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##compare-branch f V int-regs 1 V int-regs 0 cc<= }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##compare-branch f 1 0 cc<= }
} value-numbering-step trim-temps
] unit-test
! Reassociation
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##add-imm f V int-regs 2 V int-regs 0 100 }
- T{ ##load-immediate f V int-regs 3 50 }
- T{ ##add-imm f V int-regs 4 V int-regs 0 150 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##add-imm f 2 0 100 }
+ T{ ##load-immediate f 3 50 }
+ T{ ##add-imm f 4 0 150 }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##add f V int-regs 2 V int-regs 0 V int-regs 1 }
- T{ ##load-immediate f V int-regs 3 50 }
- T{ ##add f V int-regs 4 V int-regs 2 V int-regs 3 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##add f 2 0 1 }
+ T{ ##load-immediate f 3 50 }
+ T{ ##add f 4 2 3 }
} value-numbering-step
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##add-imm f V int-regs 2 V int-regs 0 100 }
- T{ ##load-immediate f V int-regs 3 50 }
- T{ ##add-imm f V int-regs 4 V int-regs 0 150 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##add-imm f 2 0 100 }
+ T{ ##load-immediate f 3 50 }
+ T{ ##add-imm f 4 0 150 }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##add f V int-regs 2 V int-regs 1 V int-regs 0 }
- T{ ##load-immediate f V int-regs 3 50 }
- T{ ##add f V int-regs 4 V int-regs 3 V int-regs 2 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##add f 2 1 0 }
+ T{ ##load-immediate f 3 50 }
+ T{ ##add f 4 3 2 }
} value-numbering-step
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##add-imm f V int-regs 2 V int-regs 0 100 }
- T{ ##load-immediate f V int-regs 3 50 }
- T{ ##add-imm f V int-regs 4 V int-regs 0 50 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##add-imm f 2 0 100 }
+ T{ ##load-immediate f 3 50 }
+ T{ ##add-imm f 4 0 50 }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##add f V int-regs 2 V int-regs 0 V int-regs 1 }
- T{ ##load-immediate f V int-regs 3 50 }
- T{ ##sub f V int-regs 4 V int-regs 2 V int-regs 3 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##add f 2 0 1 }
+ T{ ##load-immediate f 3 50 }
+ T{ ##sub f 4 2 3 }
} value-numbering-step
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##add-imm f V int-regs 2 V int-regs 0 -100 }
- T{ ##load-immediate f V int-regs 3 50 }
- T{ ##add-imm f V int-regs 4 V int-regs 0 -150 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##add-imm f 2 0 -100 }
+ T{ ##load-immediate f 3 50 }
+ T{ ##add-imm f 4 0 -150 }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##sub f V int-regs 2 V int-regs 0 V int-regs 1 }
- T{ ##load-immediate f V int-regs 3 50 }
- T{ ##sub f V int-regs 4 V int-regs 2 V int-regs 3 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##sub f 2 0 1 }
+ T{ ##load-immediate f 3 50 }
+ T{ ##sub f 4 2 3 }
} value-numbering-step
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##mul-imm f V int-regs 2 V int-regs 0 100 }
- T{ ##load-immediate f V int-regs 3 50 }
- T{ ##mul-imm f V int-regs 4 V int-regs 0 5000 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##mul-imm f 2 0 100 }
+ T{ ##load-immediate f 3 50 }
+ T{ ##mul-imm f 4 0 5000 }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##mul f V int-regs 2 V int-regs 0 V int-regs 1 }
- T{ ##load-immediate f V int-regs 3 50 }
- T{ ##mul f V int-regs 4 V int-regs 2 V int-regs 3 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##mul f 2 0 1 }
+ T{ ##load-immediate f 3 50 }
+ T{ ##mul f 4 2 3 }
} value-numbering-step
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##mul-imm f V int-regs 2 V int-regs 0 100 }
- T{ ##load-immediate f V int-regs 3 50 }
- T{ ##mul-imm f V int-regs 4 V int-regs 0 5000 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##mul-imm f 2 0 100 }
+ T{ ##load-immediate f 3 50 }
+ T{ ##mul-imm f 4 0 5000 }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##mul f V int-regs 2 V int-regs 1 V int-regs 0 }
- T{ ##load-immediate f V int-regs 3 50 }
- T{ ##mul f V int-regs 4 V int-regs 3 V int-regs 2 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##mul f 2 1 0 }
+ T{ ##load-immediate f 3 50 }
+ T{ ##mul f 4 3 2 }
} value-numbering-step
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##and-imm f V int-regs 2 V int-regs 0 100 }
- T{ ##load-immediate f V int-regs 3 50 }
- T{ ##and-imm f V int-regs 4 V int-regs 0 32 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##and-imm f 2 0 100 }
+ T{ ##load-immediate f 3 50 }
+ T{ ##and-imm f 4 0 32 }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##and f V int-regs 2 V int-regs 0 V int-regs 1 }
- T{ ##load-immediate f V int-regs 3 50 }
- T{ ##and f V int-regs 4 V int-regs 2 V int-regs 3 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##and f 2 0 1 }
+ T{ ##load-immediate f 3 50 }
+ T{ ##and f 4 2 3 }
} value-numbering-step
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##and-imm f V int-regs 2 V int-regs 0 100 }
- T{ ##load-immediate f V int-regs 3 50 }
- T{ ##and-imm f V int-regs 4 V int-regs 0 32 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##and-imm f 2 0 100 }
+ T{ ##load-immediate f 3 50 }
+ T{ ##and-imm f 4 0 32 }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##and f V int-regs 2 V int-regs 1 V int-regs 0 }
- T{ ##load-immediate f V int-regs 3 50 }
- T{ ##and f V int-regs 4 V int-regs 3 V int-regs 2 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##and f 2 1 0 }
+ T{ ##load-immediate f 3 50 }
+ T{ ##and f 4 3 2 }
} value-numbering-step
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##or-imm f V int-regs 2 V int-regs 0 100 }
- T{ ##load-immediate f V int-regs 3 50 }
- T{ ##or-imm f V int-regs 4 V int-regs 0 118 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##or-imm f 2 0 100 }
+ T{ ##load-immediate f 3 50 }
+ T{ ##or-imm f 4 0 118 }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##or f V int-regs 2 V int-regs 0 V int-regs 1 }
- T{ ##load-immediate f V int-regs 3 50 }
- T{ ##or f V int-regs 4 V int-regs 2 V int-regs 3 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##or f 2 0 1 }
+ T{ ##load-immediate f 3 50 }
+ T{ ##or f 4 2 3 }
} value-numbering-step
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##or-imm f V int-regs 2 V int-regs 0 100 }
- T{ ##load-immediate f V int-regs 3 50 }
- T{ ##or-imm f V int-regs 4 V int-regs 0 118 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##or-imm f 2 0 100 }
+ T{ ##load-immediate f 3 50 }
+ T{ ##or-imm f 4 0 118 }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##or f V int-regs 2 V int-regs 1 V int-regs 0 }
- T{ ##load-immediate f V int-regs 3 50 }
- T{ ##or f V int-regs 4 V int-regs 3 V int-regs 2 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##or f 2 1 0 }
+ T{ ##load-immediate f 3 50 }
+ T{ ##or f 4 3 2 }
} value-numbering-step
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##xor-imm f V int-regs 2 V int-regs 0 100 }
- T{ ##load-immediate f V int-regs 3 50 }
- T{ ##xor-imm f V int-regs 4 V int-regs 0 86 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##xor-imm f 2 0 100 }
+ T{ ##load-immediate f 3 50 }
+ T{ ##xor-imm f 4 0 86 }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##xor f V int-regs 2 V int-regs 0 V int-regs 1 }
- T{ ##load-immediate f V int-regs 3 50 }
- T{ ##xor f V int-regs 4 V int-regs 2 V int-regs 3 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##xor f 2 0 1 }
+ T{ ##load-immediate f 3 50 }
+ T{ ##xor f 4 2 3 }
} value-numbering-step
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##xor-imm f V int-regs 2 V int-regs 0 100 }
- T{ ##load-immediate f V int-regs 3 50 }
- T{ ##xor-imm f V int-regs 4 V int-regs 0 86 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##xor-imm f 2 0 100 }
+ T{ ##load-immediate f 3 50 }
+ T{ ##xor-imm f 4 0 86 }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 100 }
- T{ ##xor f V int-regs 2 V int-regs 1 V int-regs 0 }
- T{ ##load-immediate f V int-regs 3 50 }
- T{ ##xor f V int-regs 4 V int-regs 3 V int-regs 2 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 100 }
+ T{ ##xor f 2 1 0 }
+ T{ ##load-immediate f 3 50 }
+ T{ ##xor f 4 3 2 }
} value-numbering-step
] unit-test
! Simplification
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##peek f V int-regs 1 D 1 }
- T{ ##load-immediate f V int-regs 2 0 }
- T{ ##copy f V int-regs 3 V int-regs 0 }
- T{ ##replace f V int-regs 3 D 0 }
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##load-immediate f 2 0 }
+ T{ ##copy f 3 0 any-rep }
+ T{ ##replace f 3 D 0 }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##peek f V int-regs 1 D 1 }
- T{ ##sub f V int-regs 2 V int-regs 1 V int-regs 1 }
- T{ ##add f V int-regs 3 V int-regs 0 V int-regs 2 }
- T{ ##replace f V int-regs 3 D 0 }
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##sub f 2 1 1 }
+ T{ ##add f 3 0 2 }
+ T{ ##replace f 3 D 0 }
} value-numbering-step
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##peek f V int-regs 1 D 1 }
- T{ ##load-immediate f V int-regs 2 0 }
- T{ ##copy f V int-regs 3 V int-regs 0 }
- T{ ##replace f V int-regs 3 D 0 }
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##load-immediate f 2 0 }
+ T{ ##copy f 3 0 any-rep }
+ T{ ##replace f 3 D 0 }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##peek f V int-regs 1 D 1 }
- T{ ##sub f V int-regs 2 V int-regs 1 V int-regs 1 }
- T{ ##sub f V int-regs 3 V int-regs 0 V int-regs 2 }
- T{ ##replace f V int-regs 3 D 0 }
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##sub f 2 1 1 }
+ T{ ##sub f 3 0 2 }
+ T{ ##replace f 3 D 0 }
} value-numbering-step
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##peek f V int-regs 1 D 1 }
- T{ ##load-immediate f V int-regs 2 0 }
- T{ ##copy f V int-regs 3 V int-regs 0 }
- T{ ##replace f V int-regs 3 D 0 }
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##load-immediate f 2 0 }
+ T{ ##copy f 3 0 any-rep }
+ T{ ##replace f 3 D 0 }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##peek f V int-regs 1 D 1 }
- T{ ##sub f V int-regs 2 V int-regs 1 V int-regs 1 }
- T{ ##or f V int-regs 3 V int-regs 0 V int-regs 2 }
- T{ ##replace f V int-regs 3 D 0 }
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##sub f 2 1 1 }
+ T{ ##or f 3 0 2 }
+ T{ ##replace f 3 D 0 }
} value-numbering-step
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##peek f V int-regs 1 D 1 }
- T{ ##load-immediate f V int-regs 2 0 }
- T{ ##copy f V int-regs 3 V int-regs 0 }
- T{ ##replace f V int-regs 3 D 0 }
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##load-immediate f 2 0 }
+ T{ ##copy f 3 0 any-rep }
+ T{ ##replace f 3 D 0 }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##peek f V int-regs 1 D 1 }
- T{ ##sub f V int-regs 2 V int-regs 1 V int-regs 1 }
- T{ ##xor f V int-regs 3 V int-regs 0 V int-regs 2 }
- T{ ##replace f V int-regs 3 D 0 }
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##sub f 2 1 1 }
+ T{ ##xor f 3 0 2 }
+ T{ ##replace f 3 D 0 }
} value-numbering-step
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 1 }
- T{ ##copy f V int-regs 2 V int-regs 0 }
- T{ ##replace f V int-regs 2 D 0 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 1 }
+ T{ ##copy f 2 0 any-rep }
+ T{ ##replace f 2 D 0 }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 1 }
- T{ ##mul f V int-regs 2 V int-regs 0 V int-regs 1 }
- T{ ##replace f V int-regs 2 D 0 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 1 }
+ T{ ##mul f 2 0 1 }
+ T{ ##replace f 2 D 0 }
} value-numbering-step
] unit-test
! Constant folding
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 1 }
- T{ ##load-immediate f V int-regs 2 3 }
- T{ ##load-immediate f V int-regs 3 4 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 1 }
+ T{ ##load-immediate f 2 3 }
+ T{ ##load-immediate f 3 4 }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 1 }
- T{ ##load-immediate f V int-regs 2 3 }
- T{ ##add f V int-regs 3 V int-regs 1 V int-regs 2 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 1 }
+ T{ ##load-immediate f 2 3 }
+ T{ ##add f 3 1 2 }
} value-numbering-step
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 1 }
- T{ ##load-immediate f V int-regs 2 3 }
- T{ ##load-immediate f V int-regs 3 -2 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 1 }
+ T{ ##load-immediate f 2 3 }
+ T{ ##load-immediate f 3 -2 }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 1 }
- T{ ##load-immediate f V int-regs 2 3 }
- T{ ##sub f V int-regs 3 V int-regs 1 V int-regs 2 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 1 }
+ T{ ##load-immediate f 2 3 }
+ T{ ##sub f 3 1 2 }
} value-numbering-step
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 2 }
- T{ ##load-immediate f V int-regs 2 3 }
- T{ ##load-immediate f V int-regs 3 6 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 2 }
+ T{ ##load-immediate f 2 3 }
+ T{ ##load-immediate f 3 6 }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 2 }
- T{ ##load-immediate f V int-regs 2 3 }
- T{ ##mul f V int-regs 3 V int-regs 1 V int-regs 2 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 2 }
+ T{ ##load-immediate f 2 3 }
+ T{ ##mul f 3 1 2 }
} value-numbering-step
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 2 }
- T{ ##load-immediate f V int-regs 2 1 }
- T{ ##load-immediate f V int-regs 3 0 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 2 }
+ T{ ##load-immediate f 2 1 }
+ T{ ##load-immediate f 3 0 }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 2 }
- T{ ##load-immediate f V int-regs 2 1 }
- T{ ##and f V int-regs 3 V int-regs 1 V int-regs 2 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 2 }
+ T{ ##load-immediate f 2 1 }
+ T{ ##and f 3 1 2 }
} value-numbering-step
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 2 }
- T{ ##load-immediate f V int-regs 2 1 }
- T{ ##load-immediate f V int-regs 3 3 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 2 }
+ T{ ##load-immediate f 2 1 }
+ T{ ##load-immediate f 3 3 }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 2 }
- T{ ##load-immediate f V int-regs 2 1 }
- T{ ##or f V int-regs 3 V int-regs 1 V int-regs 2 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 2 }
+ T{ ##load-immediate f 2 1 }
+ T{ ##or f 3 1 2 }
} value-numbering-step
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 2 }
- T{ ##load-immediate f V int-regs 2 3 }
- T{ ##load-immediate f V int-regs 3 1 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 2 }
+ T{ ##load-immediate f 2 3 }
+ T{ ##load-immediate f 3 1 }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 2 }
- T{ ##load-immediate f V int-regs 2 3 }
- T{ ##xor f V int-regs 3 V int-regs 1 V int-regs 2 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 2 }
+ T{ ##load-immediate f 2 3 }
+ T{ ##xor f 3 1 2 }
} value-numbering-step
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 1 }
- T{ ##load-immediate f V int-regs 3 8 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 1 }
+ T{ ##load-immediate f 3 8 }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 1 }
- T{ ##shl-imm f V int-regs 3 V int-regs 1 3 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 1 }
+ T{ ##shl-imm f 3 1 3 }
} value-numbering-step
] unit-test
cell 8 = [
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 -1 }
- T{ ##load-immediate f V int-regs 3 HEX: ffffffffffff }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 -1 }
+ T{ ##load-immediate f 3 HEX: ffffffffffff }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 -1 }
- T{ ##shr-imm f V int-regs 3 V int-regs 1 16 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 -1 }
+ T{ ##shr-imm f 3 1 16 }
} value-numbering-step
] unit-test
] when
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 -8 }
- T{ ##load-immediate f V int-regs 3 -4 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 -8 }
+ T{ ##load-immediate f 3 -4 }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 -8 }
- T{ ##sar-imm f V int-regs 3 V int-regs 1 1 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 -8 }
+ T{ ##sar-imm f 3 1 1 }
} value-numbering-step
] unit-test
cell 8 = [
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 65536 }
- T{ ##load-immediate f V int-regs 2 140737488355328 }
- T{ ##add f V int-regs 3 V int-regs 0 V int-regs 2 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 65536 }
+ T{ ##load-immediate f 2 140737488355328 }
+ T{ ##add f 3 0 2 }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 65536 }
- T{ ##shl-imm f V int-regs 2 V int-regs 1 31 }
- T{ ##add f V int-regs 3 V int-regs 0 V int-regs 2 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 65536 }
+ T{ ##shl-imm f 2 1 31 }
+ T{ ##add f 3 0 2 }
} value-numbering-step
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 2 140737488355328 }
- T{ ##add f V int-regs 3 V int-regs 0 V int-regs 2 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 2 140737488355328 }
+ T{ ##add f 3 0 2 }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 2 140737488355328 }
- T{ ##add f V int-regs 3 V int-regs 0 V int-regs 2 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 2 140737488355328 }
+ T{ ##add f 3 0 2 }
} value-numbering-step
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 2 2147483647 }
- T{ ##add-imm f V int-regs 3 V int-regs 0 2147483647 }
- T{ ##add-imm f V int-regs 4 V int-regs 3 2147483647 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 2 2147483647 }
+ T{ ##add-imm f 3 0 2147483647 }
+ T{ ##add-imm f 4 3 2147483647 }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 2 2147483647 }
- T{ ##add f V int-regs 3 V int-regs 0 V int-regs 2 }
- T{ ##add f V int-regs 4 V int-regs 3 V int-regs 2 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 2 2147483647 }
+ T{ ##add f 3 0 2 }
+ T{ ##add f 4 3 2 }
} value-numbering-step
] unit-test
] when
! Branch folding
[
{
- T{ ##load-immediate f V int-regs 1 1 }
- T{ ##load-immediate f V int-regs 2 2 }
- T{ ##load-immediate f V int-regs 3 5 }
+ T{ ##load-immediate f 1 1 }
+ T{ ##load-immediate f 2 2 }
+ T{ ##load-immediate f 3 5 }
}
] [
{
- T{ ##load-immediate f V int-regs 1 1 }
- T{ ##load-immediate f V int-regs 2 2 }
- T{ ##compare f V int-regs 3 V int-regs 1 V int-regs 2 cc= }
+ T{ ##load-immediate f 1 1 }
+ T{ ##load-immediate f 2 2 }
+ T{ ##compare f 3 1 2 cc= }
} value-numbering-step
] unit-test
[
{
- T{ ##load-immediate f V int-regs 1 1 }
- T{ ##load-immediate f V int-regs 2 2 }
- T{ ##load-reference f V int-regs 3 t }
+ T{ ##load-immediate f 1 1 }
+ T{ ##load-immediate f 2 2 }
+ T{ ##load-reference f 3 t }
}
] [
{
- T{ ##load-immediate f V int-regs 1 1 }
- T{ ##load-immediate f V int-regs 2 2 }
- T{ ##compare f V int-regs 3 V int-regs 1 V int-regs 2 cc/= }
+ T{ ##load-immediate f 1 1 }
+ T{ ##load-immediate f 2 2 }
+ T{ ##compare f 3 1 2 cc/= }
} value-numbering-step
] unit-test
[
{
- T{ ##load-immediate f V int-regs 1 1 }
- T{ ##load-immediate f V int-regs 2 2 }
- T{ ##load-reference f V int-regs 3 t }
+ T{ ##load-immediate f 1 1 }
+ T{ ##load-immediate f 2 2 }
+ T{ ##load-reference f 3 t }
}
] [
{
- T{ ##load-immediate f V int-regs 1 1 }
- T{ ##load-immediate f V int-regs 2 2 }
- T{ ##compare f V int-regs 3 V int-regs 1 V int-regs 2 cc< }
+ T{ ##load-immediate f 1 1 }
+ T{ ##load-immediate f 2 2 }
+ T{ ##compare f 3 1 2 cc< }
} value-numbering-step
] unit-test
[
{
- T{ ##load-immediate f V int-regs 1 1 }
- T{ ##load-immediate f V int-regs 2 2 }
- T{ ##load-immediate f V int-regs 3 5 }
+ T{ ##load-immediate f 1 1 }
+ T{ ##load-immediate f 2 2 }
+ T{ ##load-immediate f 3 5 }
}
] [
{
- T{ ##load-immediate f V int-regs 1 1 }
- T{ ##load-immediate f V int-regs 2 2 }
- T{ ##compare f V int-regs 3 V int-regs 2 V int-regs 1 cc< }
+ T{ ##load-immediate f 1 1 }
+ T{ ##load-immediate f 2 2 }
+ T{ ##compare f 3 2 1 cc< }
} value-numbering-step
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 5 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 5 }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##compare f V int-regs 1 V int-regs 0 V int-regs 0 cc< }
+ T{ ##peek f 0 D 0 }
+ T{ ##compare f 1 0 0 cc< }
} value-numbering-step
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-reference f V int-regs 1 t }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-reference f 1 t }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##compare f V int-regs 1 V int-regs 0 V int-regs 0 cc<= }
+ T{ ##peek f 0 D 0 }
+ T{ ##compare f 1 0 0 cc<= }
} value-numbering-step
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 5 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 5 }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##compare f V int-regs 1 V int-regs 0 V int-regs 0 cc> }
+ T{ ##peek f 0 D 0 }
+ T{ ##compare f 1 0 0 cc> }
} value-numbering-step
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-reference f V int-regs 1 t }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-reference f 1 t }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##compare f V int-regs 1 V int-regs 0 V int-regs 0 cc>= }
+ T{ ##peek f 0 D 0 }
+ T{ ##compare f 1 0 0 cc>= }
} value-numbering-step
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-immediate f V int-regs 1 5 }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 5 }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##compare f V int-regs 1 V int-regs 0 V int-regs 0 cc/= }
+ T{ ##peek f 0 D 0 }
+ T{ ##compare f 1 0 0 cc/= }
} value-numbering-step
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-reference f V int-regs 1 t }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-reference f 1 t }
}
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##compare f V int-regs 1 V int-regs 0 V int-regs 0 cc= }
+ T{ ##peek f 0 D 0 }
+ T{ ##compare f 1 0 0 cc= }
} value-numbering-step
] unit-test
[
{
- T{ ##load-immediate f V int-regs 1 1 }
- T{ ##load-immediate f V int-regs 2 2 }
+ T{ ##load-immediate f 1 1 }
+ T{ ##load-immediate f 2 2 }
T{ ##branch }
}
1
] [
{
- T{ ##load-immediate f V int-regs 1 1 }
- T{ ##load-immediate f V int-regs 2 2 }
- T{ ##compare-branch f V int-regs 1 V int-regs 2 cc= }
+ T{ ##load-immediate f 1 1 }
+ T{ ##load-immediate f 2 2 }
+ T{ ##compare-branch f 1 2 cc= }
} test-branch-folding
] unit-test
[
{
- T{ ##load-immediate f V int-regs 1 1 }
- T{ ##load-immediate f V int-regs 2 2 }
+ T{ ##load-immediate f 1 1 }
+ T{ ##load-immediate f 2 2 }
T{ ##branch }
}
0
] [
{
- T{ ##load-immediate f V int-regs 1 1 }
- T{ ##load-immediate f V int-regs 2 2 }
- T{ ##compare-branch f V int-regs 1 V int-regs 2 cc/= }
+ T{ ##load-immediate f 1 1 }
+ T{ ##load-immediate f 2 2 }
+ T{ ##compare-branch f 1 2 cc/= }
} test-branch-folding
] unit-test
[
{
- T{ ##load-immediate f V int-regs 1 1 }
- T{ ##load-immediate f V int-regs 2 2 }
+ T{ ##load-immediate f 1 1 }
+ T{ ##load-immediate f 2 2 }
T{ ##branch }
}
0
] [
{
- T{ ##load-immediate f V int-regs 1 1 }
- T{ ##load-immediate f V int-regs 2 2 }
- T{ ##compare-branch f V int-regs 1 V int-regs 2 cc< }
+ T{ ##load-immediate f 1 1 }
+ T{ ##load-immediate f 2 2 }
+ T{ ##compare-branch f 1 2 cc< }
} test-branch-folding
] unit-test
[
{
- T{ ##load-immediate f V int-regs 1 1 }
- T{ ##load-immediate f V int-regs 2 2 }
+ T{ ##load-immediate f 1 1 }
+ T{ ##load-immediate f 2 2 }
T{ ##branch }
}
1
] [
{
- T{ ##load-immediate f V int-regs 1 1 }
- T{ ##load-immediate f V int-regs 2 2 }
- T{ ##compare-branch f V int-regs 2 V int-regs 1 cc< }
+ T{ ##load-immediate f 1 1 }
+ T{ ##load-immediate f 2 2 }
+ T{ ##compare-branch f 2 1 cc< }
} test-branch-folding
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
+ T{ ##peek f 0 D 0 }
T{ ##branch }
}
1
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##compare-branch f V int-regs 0 V int-regs 0 cc< }
+ T{ ##peek f 0 D 0 }
+ T{ ##compare-branch f 0 0 cc< }
} test-branch-folding
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
+ T{ ##peek f 0 D 0 }
T{ ##branch }
}
0
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##compare-branch f V int-regs 0 V int-regs 0 cc<= }
+ T{ ##peek f 0 D 0 }
+ T{ ##compare-branch f 0 0 cc<= }
} test-branch-folding
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
+ T{ ##peek f 0 D 0 }
T{ ##branch }
}
1
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##compare-branch f V int-regs 0 V int-regs 0 cc> }
+ T{ ##peek f 0 D 0 }
+ T{ ##compare-branch f 0 0 cc> }
} test-branch-folding
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
+ T{ ##peek f 0 D 0 }
T{ ##branch }
}
0
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##compare-branch f V int-regs 0 V int-regs 0 cc>= }
+ T{ ##peek f 0 D 0 }
+ T{ ##compare-branch f 0 0 cc>= }
} test-branch-folding
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
+ T{ ##peek f 0 D 0 }
T{ ##branch }
}
0
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##compare-branch f V int-regs 0 V int-regs 0 cc= }
+ T{ ##peek f 0 D 0 }
+ T{ ##compare-branch f 0 0 cc= }
} test-branch-folding
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
+ T{ ##peek f 0 D 0 }
T{ ##branch }
}
1
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##compare-branch f V int-regs 0 V int-regs 0 cc/= }
+ T{ ##peek f 0 D 0 }
+ T{ ##compare-branch f 0 0 cc/= }
} test-branch-folding
] unit-test
[
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##load-reference f V int-regs 1 t }
+ T{ ##peek f 0 D 0 }
+ T{ ##load-reference f 1 t }
T{ ##branch }
}
0
] [
{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##compare f V int-regs 1 V int-regs 0 V int-regs 0 cc<= }
- T{ ##compare-imm-branch f V int-regs 1 5 cc/= }
+ T{ ##peek f 0 D 0 }
+ T{ ##compare f 1 0 0 cc<= }
+ T{ ##compare-imm-branch f 1 5 cc/= }
} test-branch-folding
] unit-test
V{ T{ ##branch } } 0 test-bb
V{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##compare-branch f V int-regs 0 V int-regs 0 cc< }
+ T{ ##peek f 0 D 0 }
+ T{ ##compare-branch f 0 0 cc< }
} 1 test-bb
V{
- T{ ##load-immediate f V int-regs 1 1 }
+ T{ ##load-immediate f 1 1 }
T{ ##branch }
} 2 test-bb
V{
- T{ ##load-immediate f V int-regs 2 2 }
+ T{ ##load-immediate f 2 2 }
T{ ##branch }
} 3 test-bb
V{
- T{ ##phi f V int-regs 3 { } }
- T{ ##replace f V int-regs 3 D 0 }
+ T{ ##phi f 3 H{ { 2 1 } { 3 2 } } }
+ T{ ##replace f 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
[ ] [
- cfg new 0 get >>entry
+ cfg new 0 get >>entry dup cfg set
value-numbering
- compute-predecessors
+ select-representations
destruct-ssa drop
] unit-test
[ 2 ] [ 4 get instructions>> length ] unit-test
V{
- T{ ##peek f V int-regs 0 D 0 }
+ T{ ##peek f 0 D 0 }
T{ ##branch }
} 0 test-bb
V{
- T{ ##peek f V int-regs 1 D 1 }
- T{ ##compare-branch f V int-regs 1 V int-regs 1 cc< }
+ T{ ##peek f 1 D 1 }
+ T{ ##compare-branch f 1 1 cc< }
} 1 test-bb
V{
- T{ ##copy f V int-regs 2 V int-regs 0 }
+ T{ ##copy f 2 0 any-rep }
T{ ##branch }
} 2 test-bb
V{
- T{ ##phi f V int-regs 3 V{ } }
+ T{ ##phi f 3 V{ } }
T{ ##branch }
} 3 test-bb
V{
- T{ ##replace f V int-regs 3 D 0 }
+ T{ ##replace f 3 D 0 }
T{ ##return }
} 4 test-bb
-1 get V int-regs 1 2array
-2 get V int-regs 0 2array 2array 3 get instructions>> first (>>inputs)
+1 get 1 2array
+2 get 0 2array 2array 3 get instructions>> first (>>inputs)
test-diamond
[ ] [
cfg new 0 get >>entry
- compute-predecessors
value-numbering
- compute-predecessors
eliminate-dead-code
drop
] unit-test
V{ T{ ##prologue } T{ ##branch } } 0 test-bb
V{
- T{ ##peek { dst V int-regs 15 } { loc D 0 } }
- T{ ##copy { dst V int-regs 16 } { src V int-regs 15 } }
- T{ ##copy { dst V int-regs 17 } { src V int-regs 15 } }
- T{ ##copy { dst V int-regs 18 } { src V int-regs 15 } }
- T{ ##copy { dst V int-regs 19 } { src V int-regs 15 } }
+ T{ ##peek { dst 15 } { loc D 0 } }
+ T{ ##copy { dst 16 } { src 15 } { rep any-rep } }
+ T{ ##copy { dst 17 } { src 15 } { rep any-rep } }
+ T{ ##copy { dst 18 } { src 15 } { rep any-rep } }
+ T{ ##copy { dst 19 } { src 15 } { rep any-rep } }
T{ ##compare
- { dst V int-regs 20 }
- { src1 V int-regs 18 }
- { src2 V int-regs 19 }
+ { dst 20 }
+ { src1 18 }
+ { src2 19 }
{ cc cc= }
- { temp V int-regs 22 }
+ { temp 22 }
}
- T{ ##copy { dst V int-regs 21 } { src V int-regs 20 } }
+ T{ ##copy { dst 21 } { src 20 } { rep any-rep } }
T{ ##compare-imm-branch
- { src1 V int-regs 21 }
+ { src1 21 }
{ src2 5 }
{ cc cc/= }
}
} 1 test-bb
V{
- T{ ##copy { dst V int-regs 23 } { src V int-regs 15 } }
- T{ ##copy { dst V int-regs 24 } { src V int-regs 15 } }
- T{ ##load-reference { dst V int-regs 25 } { obj t } }
+ T{ ##copy { dst 23 } { src 15 } { rep any-rep } }
+ T{ ##copy { dst 24 } { src 15 } { rep any-rep } }
+ T{ ##load-reference { dst 25 } { obj t } }
T{ ##branch }
} 2 test-bb
V{
- T{ ##replace { src V int-regs 25 } { loc D 0 } }
+ T{ ##replace { src 25 } { loc D 0 } }
T{ ##epilogue }
T{ ##return }
} 3 test-bb
V{
- T{ ##copy { dst V int-regs 26 } { src V int-regs 15 } }
- T{ ##copy { dst V int-regs 27 } { src V int-regs 15 } }
+ T{ ##copy { dst 26 } { src 15 } { rep any-rep } }
+ T{ ##copy { dst 27 } { src 15 } { rep any-rep } }
T{ ##add
- { dst V int-regs 28 }
- { src1 V int-regs 26 }
- { src2 V int-regs 27 }
+ { dst 28 }
+ { src1 26 }
+ { src2 27 }
}
T{ ##branch }
} 4 test-bb
V{
- T{ ##replace { src V int-regs 28 } { loc D 0 } }
+ T{ ##replace { src 28 } { loc D 0 } }
T{ ##epilogue }
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
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces assocs kernel accessors
sorting sets sequences
+cpu.architecture
compiler.cfg
compiler.cfg.rpo
compiler.cfg.instructions
compiler.cfg.value-numbering.rewrite ;
IN: compiler.cfg.value-numbering
-! Local value numbering. Predecessors must be recomputed after this
+! Local value numbering.
+
: >copy ( insn -- insn/##copy )
dup dst>> dup vreg>vn vn>vreg
- 2dup eq? [ 2drop ] [ \ ##copy new-insn nip ] if ;
+ 2dup eq? [ 2drop ] [ any-rep \ ##copy new-insn nip ] if ;
: rewrite-loop ( insn -- insn' )
dup rewrite [ rewrite-loop ] [ ] ?if ;
[ process-instruction ] map ;
: value-numbering ( cfg -- cfg' )
- [ value-numbering-step ] local-optimization cfg-changed ;
+ [ value-numbering-step ] local-optimization
+
+ cfg-changed predecessors-changed ;
[
V{
- T{ ##peek f V int-regs 4 D 0 f }
- T{ ##allot f V int-regs 7 24 array V int-regs 8 f }
- T{ ##load-immediate f V int-regs 9 8 f }
- T{ ##set-slot-imm f V int-regs 9 V int-regs 7 1 3 f }
- T{ ##set-slot-imm f V int-regs 4 V int-regs 7 2 3 f }
- T{ ##replace f V int-regs 7 D 0 f }
+ T{ ##peek f 4 D 0 f }
+ T{ ##allot f 7 24 array 8 f }
+ T{ ##load-immediate f 9 8 f }
+ T{ ##set-slot-imm f 9 7 1 3 f }
+ T{ ##set-slot-imm f 4 7 2 3 f }
+ T{ ##replace f 7 D 0 f }
T{ ##branch }
}
] [
{
- T{ ##peek f V int-regs 4 D 0 }
- T{ ##allot f V int-regs 7 24 array V int-regs 8 }
- T{ ##load-immediate f V int-regs 9 8 }
- T{ ##set-slot-imm f V int-regs 9 V int-regs 7 1 3 }
- T{ ##write-barrier f V int-regs 7 V int-regs 10 V int-regs 11 }
- T{ ##set-slot-imm f V int-regs 4 V int-regs 7 2 3 }
- T{ ##write-barrier f V int-regs 7 V int-regs 12 V int-regs 13 }
- T{ ##replace f V int-regs 7 D 0 }
+ T{ ##peek f 4 D 0 }
+ T{ ##allot f 7 24 array 8 }
+ T{ ##load-immediate f 9 8 }
+ T{ ##set-slot-imm f 9 7 1 3 }
+ T{ ##write-barrier f 7 10 11 }
+ T{ ##set-slot-imm f 4 7 2 3 }
+ T{ ##write-barrier f 7 12 13 }
+ T{ ##replace f 7 D 0 }
} test-write-barrier
] unit-test
[
V{
- T{ ##load-immediate f V int-regs 4 24 }
- T{ ##peek f V int-regs 5 D -1 }
- T{ ##peek f V int-regs 6 D -2 }
- T{ ##set-slot-imm f V int-regs 5 V int-regs 6 3 2 }
- T{ ##write-barrier f V int-regs 6 V int-regs 7 V int-regs 8 }
+ T{ ##load-immediate f 4 24 }
+ T{ ##peek f 5 D -1 }
+ T{ ##peek f 6 D -2 }
+ T{ ##set-slot-imm f 5 6 3 2 }
+ T{ ##write-barrier f 6 7 8 }
T{ ##branch }
}
] [
{
- T{ ##load-immediate f V int-regs 4 24 }
- T{ ##peek f V int-regs 5 D -1 }
- T{ ##peek f V int-regs 6 D -2 }
- T{ ##set-slot-imm f V int-regs 5 V int-regs 6 3 2 }
- T{ ##write-barrier f V int-regs 6 V int-regs 7 V int-regs 8 }
+ T{ ##load-immediate f 4 24 }
+ T{ ##peek f 5 D -1 }
+ T{ ##peek f 6 D -2 }
+ T{ ##set-slot-imm f 5 6 3 2 }
+ T{ ##write-barrier f 6 7 8 }
} test-write-barrier
] unit-test
[
V{
- T{ ##peek f V int-regs 19 D -3 }
- T{ ##peek f V int-regs 22 D -2 }
- T{ ##set-slot-imm f V int-regs 22 V int-regs 19 3 2 }
- T{ ##write-barrier f V int-regs 19 V int-regs 24 V int-regs 25 }
- T{ ##peek f V int-regs 28 D -1 }
- T{ ##set-slot-imm f V int-regs 28 V int-regs 19 4 2 }
+ T{ ##peek f 19 D -3 }
+ T{ ##peek f 22 D -2 }
+ T{ ##set-slot-imm f 22 19 3 2 }
+ T{ ##write-barrier f 19 24 25 }
+ T{ ##peek f 28 D -1 }
+ T{ ##set-slot-imm f 28 19 4 2 }
T{ ##branch }
}
] [
{
- T{ ##peek f V int-regs 19 D -3 }
- T{ ##peek f V int-regs 22 D -2 }
- T{ ##set-slot-imm f V int-regs 22 V int-regs 19 3 2 }
- T{ ##write-barrier f V int-regs 19 V int-regs 24 V int-regs 25 }
- T{ ##peek f V int-regs 28 D -1 }
- T{ ##set-slot-imm f V int-regs 28 V int-regs 19 4 2 }
- T{ ##write-barrier f V int-regs 19 V int-regs 30 V int-regs 3 }
+ T{ ##peek f 19 D -3 }
+ T{ ##peek f 22 D -2 }
+ T{ ##set-slot-imm f 22 19 3 2 }
+ T{ ##write-barrier f 19 24 25 }
+ T{ ##peek f 28 D -1 }
+ T{ ##set-slot-imm f 28 19 4 2 }
+ T{ ##write-barrier f 19 30 3 }
} test-write-barrier
] unit-test
M: ##integer>float generate-insn dst/src %integer>float ;
M: ##float>integer generate-insn dst/src %float>integer ;
-M: ##copy generate-insn dst/src %copy ;
-M: ##copy-float generate-insn dst/src %copy-float ;
-M: ##unbox-float generate-insn dst/src %unbox-float ;
-M: ##unbox-any-c-ptr generate-insn dst/src/temp %unbox-any-c-ptr ;
-M: ##box-float generate-insn dst/src/temp %box-float ;
-M: ##box-alien generate-insn dst/src/temp %box-alien ;
+M: ##copy generate-insn [ dst/src ] [ rep>> ] bi %copy ;
+
+M: ##unbox-float generate-insn dst/src %unbox-float ;
+M: ##unbox-any-c-ptr generate-insn dst/src/temp %unbox-any-c-ptr ;
+M: ##box-float generate-insn dst/src/temp %box-float ;
+M: ##box-alien generate-insn dst/src/temp %box-alien ;
M: ##alien-unsigned-1 generate-insn dst/src %alien-unsigned-1 ;
M: ##alien-unsigned-2 generate-insn dst/src %alien-unsigned-2 ;
GENERIC# save-gc-root 1 ( gc-root operand temp -- )
M:: spill-slot save-gc-root ( gc-root operand temp -- )
- temp operand n>> %reload-integer
+ temp operand n>> int-rep %reload
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 ;
+: save-data-regs ( data-regs -- ) [ first3 %spill ] 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 ;
+ temp operand n>> int-rep %spill ;
M: object load-gc-root drop %load-gc-root ;
: load-gc-roots ( gc-roots temp -- ) '[ _ load-gc-root ] assoc-each ;
+: load-data-regs ( data-regs -- ) [ first3 %reload ] each ;
+
M: _gc generate-insn
"no-gc" define-label
{
[ [ "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 ]
+ [ data-values>> save-data-regs ]
+ [ [ tagged-values>> ] [ temp1>> ] bi save-gc-roots ]
+ [ tagged-values>> length %call-gc ]
+ [ [ tagged-values>> ] [ temp1>> ] bi load-gc-roots ]
+ [ data-values>> load-data-regs ]
} cleave
"no-gc" resolve-label ;
%alien-global ;
! ##alien-invoke
-GENERIC: reg-class-variable ( register-class -- symbol )
-
-M: reg-class reg-class-variable ;
-
-M: float-regs reg-class-variable drop float-regs ;
+GENERIC: next-fastcall-param ( reg-class -- )
-GENERIC: inc-reg-class ( register-class -- )
+: ?dummy-stack-params ( rep -- )
+ dummy-stack-params? [ rep-size cell align stack-params +@ ] [ drop ] if ;
-: ?dummy-stack-params ( reg-class -- )
- dummy-stack-params? [ reg-size cell align stack-params +@ ] [ drop ] if ;
+: ?dummy-int-params ( rep -- )
+ dummy-int-params? [ rep-size cell /i 1 max int-regs +@ ] [ drop ] if ;
-: ?dummy-int-params ( reg-class -- )
- dummy-int-params? [ reg-size cell /i 1 max int-regs +@ ] [ drop ] if ;
-
-: ?dummy-fp-params ( reg-class -- )
+: ?dummy-fp-params ( rep -- )
drop dummy-fp-params? [ float-regs inc ] when ;
-M: int-regs inc-reg-class
- [ reg-class-variable inc ]
- [ ?dummy-stack-params ]
- [ ?dummy-fp-params ]
- tri ;
+M: int-rep next-fastcall-param
+ int-regs inc [ ?dummy-stack-params ] [ ?dummy-fp-params ] bi ;
-M: float-regs inc-reg-class
- [ reg-class-variable inc ]
- [ ?dummy-stack-params ]
- [ ?dummy-int-params ]
- tri ;
+M: single-float-rep next-fastcall-param
+ float-regs inc [ ?dummy-stack-params ] [ ?dummy-int-params ] bi ;
-GENERIC: reg-class-full? ( class -- ? )
+M: double-float-rep next-fastcall-param
+ float-regs inc [ ?dummy-stack-params ] [ ?dummy-int-params ] bi ;
+
+GENERIC: reg-class-full? ( reg-class -- ? )
M: stack-params reg-class-full? drop t ;
-M: object reg-class-full?
- [ reg-class-variable get ] [ param-regs length ] bi >= ;
+M: reg-class reg-class-full?
+ [ get ] [ param-regs length ] bi >= ;
-: spill-param ( reg-class -- n reg-class )
+: alloc-stack-param ( rep -- n reg-class rep )
stack-params get
- [ reg-size cell align stack-params +@ ] dip
- stack-params ;
+ [ rep-size cell align stack-params +@ ] dip
+ stack-params dup ;
-: fastcall-param ( reg-class -- n reg-class )
- [ reg-class-variable get ] [ inc-reg-class ] [ ] tri ;
+: alloc-fastcall-param ( rep -- n reg-class rep )
+ [ reg-class-of [ get ] [ inc ] [ ] tri ] keep ;
-: alloc-parameter ( parameter -- reg reg-class )
- c-type-reg-class dup reg-class-full?
- [ spill-param ] [ fastcall-param ] if
- [ param-reg ] keep ;
+: alloc-parameter ( parameter -- reg rep )
+ c-type-rep dup reg-class-of reg-class-full?
+ [ alloc-stack-param ] [ alloc-fastcall-param ] if
+ [ param-reg ] dip ;
: (flatten-int-type) ( size -- seq )
cell /i "void*" c-type <repetition> ;
: reverse-each-parameter ( parameters quot -- )
[ [ parameter-sizes nip ] keep ] dip 2reverse-each ; inline
-: reset-freg-counts ( -- )
+: reset-fastcall-counts ( -- )
{ int-regs float-regs stack-params } [ 0 swap set ] each ;
: with-param-regs ( quot -- )
#! In quot you can call alloc-parameter
- [ reset-freg-counts call ] with-scope ; inline
+ [ reset-fastcall-counts call ] with-scope ; inline
: move-parameters ( node word -- )
#! Moves values from C stack to registers (if word is
alien-parameters [ box-parameter ] each-parameter ;
: registers>objects ( node -- )
+ ! Generate code for boxing input parameters in a callback.
[
dup \ %save-param-reg move-parameters
"nest_stacks" f %alien-invoke
>binary-branch< %compare-float-branch ;
M: _spill generate-insn
- [ src>> ] [ n>> ] [ class>> ] tri {
- { int-regs [ %spill-integer ] }
- { double-float-regs [ %spill-float ] }
- } case ;
+ [ src>> ] [ n>> ] [ rep>> ] tri %spill ;
M: _reload generate-insn
- [ dst>> ] [ n>> ] [ class>> ] tri {
- { int-regs [ %reload-integer ] }
- { double-float-regs [ %reload-float ] }
- } case ;
-
-M: _copy generate-insn
- [ dst>> ] [ src>> ] [ class>> ] tri {
- { int-regs [ %copy ] }
- { double-float-regs [ %copy-float ] }
- } case ;
-
-M: _spill-counts generate-insn drop ;
+ [ dst>> ] [ n>> ] [ rep>> ] tri %reload ;
+
+M: _spill-area-size generate-insn drop ;
compiler.tree.builder
compiler.tree.optimizer
+compiler.cfg
compiler.cfg.builder
compiler.cfg.optimizer
compiler.cfg.mr
: backend ( tree word -- )
build-cfg [
- optimize-cfg
- build-mr
+ [ optimize-cfg build-mr ] with-cfg
generate
save-asm
] each ;
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
[ associate >alist modify-code-heap ] keep ;
: compile-test-cfg ( -- word )
- cfg new
- 0 get >>entry
+ cfg new 0 get >>entry
+ dup cfg set
+ dup fake-representations representations get >>reps
compile-cfg ;
: compile-test-bb ( insns -- result )
V{ T{ ##prologue } T{ ##branch } } 0 test-bb
V{
T{ ##inc-d f 1 }
- T{ ##replace f V int-regs 0 D 0 }
+ T{ ##replace f 0 D 0 }
T{ ##branch }
} [ clone ] map append 1 test-bb
V{
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 ) ;
! loading immediates
[ f ] [
V{
- T{ ##load-immediate f V int-regs 0 5 }
+ T{ ##load-immediate f 0 5 }
} compile-test-bb
] unit-test
[ "hello" ] [
V{
- T{ ##load-reference f V int-regs 0 "hello" }
+ T{ ##load-reference f 0 "hello" }
} compile-test-bb
] unit-test
! one of the sources
[ t ] [
V{
- T{ ##load-immediate f V int-regs 1 $[ 2 cell log2 shift ] }
- T{ ##load-reference f V int-regs 0 { t f t } }
- T{ ##slot f V int-regs 0 V int-regs 0 V int-regs 1 $[ array tag-number ] V int-regs 2 }
+ T{ ##load-immediate f 1 $[ 2 cell log2 shift ] }
+ T{ ##load-reference f 0 { t f t } }
+ T{ ##slot f 0 0 1 $[ array tag-number ] 2 }
} compile-test-bb
] unit-test
[ t ] [
V{
- T{ ##load-reference f V int-regs 0 { t f t } }
- T{ ##slot-imm f V int-regs 0 V int-regs 0 2 $[ array tag-number ] V int-regs 2 }
+ T{ ##load-reference f 0 { t f t } }
+ T{ ##slot-imm f 0 0 2 $[ array tag-number ] 2 }
} compile-test-bb
] unit-test
[ t ] [
V{
- T{ ##load-immediate f V int-regs 1 $[ 2 cell log2 shift ] }
- T{ ##load-reference f V int-regs 0 { t f t } }
- T{ ##set-slot f V int-regs 0 V int-regs 0 V int-regs 1 $[ array tag-number ] V int-regs 2 }
+ T{ ##load-immediate f 1 $[ 2 cell log2 shift ] }
+ T{ ##load-reference f 0 { t f t } }
+ T{ ##set-slot f 0 0 1 $[ array tag-number ] 2 }
} compile-test-bb
dup first eq?
] unit-test
[ t ] [
V{
- T{ ##load-reference f V int-regs 0 { t f t } }
- T{ ##set-slot-imm f V int-regs 0 V int-regs 0 2 $[ array tag-number ] }
+ T{ ##load-reference f 0 { t f t } }
+ T{ ##set-slot-imm f 0 0 2 $[ array tag-number ] }
} compile-test-bb
dup first eq?
] unit-test
[ 8 ] [
V{
- T{ ##load-immediate f V int-regs 0 4 }
- T{ ##shl f V int-regs 0 V int-regs 0 V int-regs 0 }
+ T{ ##load-immediate f 0 4 }
+ T{ ##shl f 0 0 0 }
} compile-test-bb
] unit-test
[ 4 ] [
V{
- T{ ##load-immediate f V int-regs 0 4 }
- T{ ##shl-imm f V int-regs 0 V int-regs 0 3 }
+ T{ ##load-immediate f 0 4 }
+ T{ ##shl-imm f 0 0 3 }
} compile-test-bb
] unit-test
[ 31 ] [
V{
- T{ ##load-reference f V int-regs 1 B{ 31 67 52 } }
- T{ ##unbox-any-c-ptr f V int-regs 0 V int-regs 1 V int-regs 2 }
- T{ ##alien-unsigned-1 f V int-regs 0 V int-regs 0 }
- T{ ##shl-imm f V int-regs 0 V int-regs 0 3 }
+ T{ ##load-reference f 1 B{ 31 67 52 } }
+ T{ ##unbox-any-c-ptr f 0 1 2 }
+ T{ ##alien-unsigned-1 f 0 0 }
+ T{ ##shl-imm f 0 0 3 }
} compile-test-bb
] unit-test
[ CHAR: l ] [
V{
- T{ ##load-reference f V int-regs 0 "hello world" }
- T{ ##load-immediate f V int-regs 1 3 }
- T{ ##string-nth f V int-regs 0 V int-regs 0 V int-regs 1 V int-regs 2 }
- T{ ##shl-imm f V int-regs 0 V int-regs 0 3 }
+ T{ ##load-reference f 0 "hello world" }
+ T{ ##load-immediate f 1 3 }
+ T{ ##string-nth f 0 0 1 2 }
+ T{ ##shl-imm f 0 0 3 }
} compile-test-bb
] unit-test
[ 1 ] [
V{
- T{ ##load-immediate f V int-regs 0 16 }
- T{ ##add-imm f V int-regs 0 V int-regs 0 -8 }
+ T{ ##load-immediate f 0 16 }
+ T{ ##add-imm f 0 0 -8 }
} compile-test-bb
] unit-test
[ 100 ] [
V{
- T{ ##load-immediate f V int-regs 0 100 }
- T{ ##integer>bignum f V int-regs 0 V int-regs 0 V int-regs 1 }
+ T{ ##load-immediate f 0 100 }
+ T{ ##integer>bignum f 0 0 1 }
} compile-test-bb
] unit-test
[ 1 ] [
V{
- T{ ##load-reference f V int-regs 0 ALIEN: 8 }
- T{ ##unbox-any-c-ptr f V int-regs 0 V int-regs 0 V int-regs 1 }
+ T{ ##load-reference f 0 ALIEN: 8 }
+ T{ ##unbox-any-c-ptr f 0 0 1 }
} compile-test-bb
] unit-test
: build-tree ( word/quot -- nodes )
[ f ] dip build-tree-with ;
-:: build-sub-tree ( #call word/quot -- nodes/f )
+:: build-sub-tree ( in-d out-d word/quot -- nodes/f )
#! We don't want methods on mixins to have a declaration for that mixin.
#! This slows down compiler.tree.propagation.inlining since then every
#! inlined usage of a method has an inline-dependency on the mixin, and
#! not the more specific type at the call site.
f specialize-method? [
[
- #call in-d>> word/quot build-tree-with unclip-last in-d>> :> in-d
+ in-d word/quot build-tree-with unclip-last in-d>> :> in-d'
{
{ [ dup not ] [ ] }
- { [ dup ends-with-terminate? ] [ #call out-d>> [ f swap #push ] map append ] }
- [ in-d #call out-d>> #copy suffix ]
+ { [ dup ends-with-terminate? ] [ out-d [ f swap #push ] map append ] }
+ [ in-d' out-d [ [ length ] bi@ assert= ] [ #copy suffix ] 2bi ]
} cond
] [ dup inference-error? [ drop f ] [ rethrow ] if ] recover
- ] with-variable ;
-
+ ] with-variable ;
\ No newline at end of file
grouping stack-checker.branches
compiler.tree
compiler.tree.def-use
+compiler.tree.recursive
compiler.tree.combinators ;
IN: compiler.tree.checker
GENERIC: delete-node ( node -- )
M: #call-recursive delete-node
- dup label>> [ [ eq? not ] with filter ] change-calls drop ;
+ dup label>> calls>> [ node>> eq? not ] with filter-here ;
M: #return-recursive delete-node
label>> f >>return drop ;
[ ]
} cond ;
-M: #declare cleanup* drop f ;
-
: delete-unreachable-branches ( #branch -- )
dup live-branches>> '[
_
USING: accessors arrays assocs sequences kernel locals fry
combinators stack-checker.backend
compiler.tree
+compiler.tree.recursive
compiler.tree.dead-code.branches
compiler.tree.dead-code.liveness
compiler.tree.dead-code.simple ;
compiler.tree.optimizer
compiler.tree.combinators
compiler.tree.checker
+compiler.tree.identities
compiler.tree.dead-code
compiler.tree.modular-arithmetic ;
FROM: fry => _ ;
normalize
propagate
cleanup
+ apply-identities
compute-def-use
remove-dead-code
compute-def-use
M: #introduce node-uses-values drop f ;
M: #push node-uses-values drop f ;
M: #phi node-uses-values phi-in-d>> concat remove-bottom prune ;
-M: #declare node-uses-values declaration>> keys ;
+M: #declare node-uses-values drop f ;
M: #terminate node-uses-values [ in-d>> ] [ in-r>> ] bi append ;
M: #shuffle node-uses-values [ in-d>> ] [ in-r>> ] bi append ;
M: #alien-callback node-uses-values drop f ;
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs namespaces sequences kernel math
combinators sets disjoint-sets fry stack-checker.values ;
IN: compiler.tree.escape-analysis.allocations
+! A map from values to classes. Only for #introduce outputs
+SYMBOL: value-classes
+
+: value-class ( value -- class ) value-classes get at ;
+
+: set-value-class ( class value -- ) value-classes get set-at ;
+
! A map from values to one of the following:
! - f -- initial status, assigned to values we have not seen yet;
! may potentially become an allocation later
--- /dev/null
+IN: compiler.tree.escape-analysis.check.tests
+USING: compiler.tree.escape-analysis.check tools.test accessors kernel
+kernel.private math compiler.tree.builder compiler.tree.normalization
+compiler.tree.propagation compiler.tree.cleanup ;
+
+: test-checker ( quot -- ? )
+ build-tree normalize propagate cleanup run-escape-analysis? ;
+
+[ t ] [
+ [ { complex } declare [ real>> ] [ imaginary>> ] bi ]
+ test-checker
+] unit-test
+
+[ t ] [
+ [ complex boa [ real>> ] [ imaginary>> ] bi ]
+ test-checker
+] unit-test
+
+[ t ] [
+ [ [ complex boa [ real>> ] [ imaginary>> ] bi ] when ]
+ test-checker
+] unit-test
+
+[ f ] [
+ [ swap 1 2 ? ]
+ test-checker
+] unit-test
\ 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: classes classes.tuple math math.private accessors
-combinators kernel compiler.tree compiler.tree.combinators
-compiler.tree.propagation.info ;
+USING: classes classes.tuple math math.private accessors sequences
+combinators.short-circuit kernel compiler.tree
+compiler.tree.combinators compiler.tree.propagation.info ;
IN: compiler.tree.escape-analysis.check
GENERIC: run-escape-analysis* ( node -- ? )
+: unbox-inputs? ( nodes -- ? )
+ {
+ [ length 2 >= ]
+ [ first #introduce? ]
+ [ second #declare? ]
+ } 1&& ;
+
+: run-escape-analysis? ( nodes -- ? )
+ { [ unbox-inputs? ] [ [ run-escape-analysis* ] any? ] } 1|| ;
+
M: #push run-escape-analysis*
- literal>> [ class immutable-tuple-class? ] [ complex? ] bi or ;
+ literal>> class immutable-tuple-class? ;
M: #call run-escape-analysis*
- {
- { [ dup immutable-tuple-boa? ] [ t ] }
- [ f ]
- } cond nip ;
+ immutable-tuple-boa? ;
-M: node run-escape-analysis* drop f ;
+M: #recursive run-escape-analysis*
+ child>> run-escape-analysis? ;
-: run-escape-analysis? ( nodes -- ? )
- [ run-escape-analysis* ] contains-node? ;
+M: #branch run-escape-analysis*
+ children>> [ run-escape-analysis? ] any? ;
+
+M: node run-escape-analysis* drop f ;
classes.tuple namespaces
compiler.tree.propagation.info stack-checker.errors
compiler.tree.checker
-kernel.private ;
+kernel.private vectors ;
GENERIC: count-unboxed-allocations* ( m node -- n )
dup literal>> class immutable-tuple-class?
[ (count-unboxed-allocations) ] [ drop ] if ;
+M: #introduce count-unboxed-allocations*
+ out-d>> [ escaping-allocation? [ 1+ ] unless ] each ;
+
M: node count-unboxed-allocations* drop ;
: count-unboxed-allocations ( quot -- sizes )
TUPLE: empty-tuple ;
[ ] [ [ empty-tuple boa layout-of ] count-unboxed-allocations drop ] unit-test
+
+! New feature!
+
+[ 1 ] [ [ { complex } declare real>> ] count-unboxed-allocations ] unit-test
+
+[ 1 ] [
+ [ { complex } declare [ real>> ] [ imaginary>> ] bi ]
+ count-unboxed-allocations
+] unit-test
+
+[ 0 ] [
+ [ { vector } declare length>> ]
+ count-unboxed-allocations
+] unit-test
\ No newline at end of file
init-escaping-values
H{ } clone allocations set
H{ } clone slot-accesses set
+ H{ } clone value-classes set
dup (escape-analysis)
compute-escaping-allocations ;
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences
+USING: kernel sequences fry math namespaces
compiler.tree
compiler.tree.def-use
compiler.tree.escape-analysis.allocations ;
GENERIC: escape-analysis* ( node -- )
+SYMBOL: next-node
+
+: each-with-next ( seq quot: ( elt -- ) -- )
+ dupd '[ 1 + _ ?nth next-node set @ ] each-index ; inline
+
: (escape-analysis) ( node -- )
[
[ node-defs-values introduce-values ]
[ escape-analysis* ]
bi
- ] each ;
+ ] each-with-next ;
USING: kernel sequences math combinators accessors namespaces
fry disjoint-sets
compiler.tree
+compiler.tree.recursive
compiler.tree.combinators
compiler.tree.escape-analysis.nodes
compiler.tree.escape-analysis.branches
[ call-next-method ]
[
[ in-d>> ] [ label>> calls>> ] bi
- [ out-d>> escaping-values get '[ _ equate ] 2each ] with each
+ [ node>> out-d>> escaping-values get '[ _ equate ] 2each ] with each
] bi ;
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors sequences classes.tuple
classes.tuple.private arrays math math.private slots.private
combinators deques search-deques namespaces fry classes
-classes.algebra stack-checker.state
+classes.algebra assocs stack-checker.state
compiler.tree
compiler.tree.propagation.info
compiler.tree.escape-analysis.nodes
compiler.tree.escape-analysis.allocations ;
IN: compiler.tree.escape-analysis.simple
+M: #declare escape-analysis* drop ;
+
M: #terminate escape-analysis* drop ;
M: #renaming escape-analysis* inputs/outputs copy-values ;
-M: #introduce escape-analysis* out-d>> unknown-allocations ;
+: declared-class ( value -- class/f )
+ next-node get dup #declare? [ declaration>> at ] [ 2drop f ] if ;
+
+: record-param-allocation ( value class -- )
+ dup immutable-tuple-class? [
+ [ swap set-value-class ] [
+ all-slots [
+ [ <slot-value> dup ] [ class>> ] bi*
+ record-param-allocation
+ ] map swap record-allocation
+ ] 2bi
+ ] [ drop unknown-allocation ] if ;
+
+M: #introduce escape-analysis*
+ out-d>> [ dup declared-class record-param-allocation ] each ;
DEFER: record-literal-allocation
: object-slots ( object -- slots/f )
{
{ [ dup class immutable-tuple-class? ] [ tuple-slots ] }
- { [ dup complex? ] [ [ real-part ] [ imaginary-part ] bi 2array ] }
[ drop f ]
} cond ;
! See http://factorcode.org/license.txt for BSD license.
IN: compiler.tree.modular-arithmetic.tests
USING: kernel kernel.private tools.test math math.partial-dispatch
-math.private accessors slots.private sequences strings sbufs
+math.private accessors slots.private sequences sequences.private strings sbufs
compiler.tree.builder
compiler.tree.normalization
compiler.tree.debugger
[ [ [ { fixnum fixnum } declare + ] 2dip set-alien-signed-8 ] test-modular-arithmetic ] unit-test
[ t ] [ [ { fixnum byte-array } declare [ + ] with map ] { + fixnum+ >fixnum } inlined? ] unit-test
+
+[ t ] [
+ [ 0 10 <byte-array> 10 [ 1 pick 0 + >fixnum pick set-nth-unsafe [ 1 + >fixnum ] dip ] times ]
+ { >fixnum } inlined?
+] unit-test
\ No newline at end of file
[ 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 ;
[ t ] [
null-info 3 <literal-info> value-info<=
] unit-test
+
+[ t t ] [
+ f <literal-info>
+ fixnum 0 40 [a,b] <class/interval-info>
+ value-info-union
+ \ f class-not <class-info>
+ value-info-intersect
+ [ class>> fixnum class= ]
+ [ interval>> 0 40 [a,b] = ] bi
+] unit-test
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs classes classes.algebra classes.tuple
-classes.tuple.private kernel accessors math math.intervals
-namespaces sequences words combinators byte-arrays strings
-arrays layouts cpu.architecture compiler.tree.propagation.copy ;
+classes.tuple.private kernel accessors math math.intervals namespaces
+sequences sequences.private words combinators
+combinators.short-circuit byte-arrays strings arrays layouts
+cpu.architecture compiler.tree.propagation.copy ;
IN: compiler.tree.propagation.info
: false-class? ( class -- ? ) \ f class<= ;
CONSTANT: object-info T{ value-info f object full-interval }
-: class-interval ( class -- interval )
- dup real class<=
- [ "interval" word-prop [-inf,inf] or ] [ drop f ] if ;
-
: interval>literal ( class interval -- literal literal? )
#! If interval has zero length and the class is sufficiently
#! precise, we can turn it into a literal
UNION: fixed-length array byte-array string ;
: init-literal-info ( info -- info )
- [-inf,inf] >>interval
+ empty-interval >>interval
dup literal>> class >>class
dup literal>> {
{ [ dup real? ] [ [a,a] >>interval ] }
[ drop ]
} cond ; inline
+: empty-set? ( info -- ? )
+ {
+ [ class>> null-class? ]
+ [ [ class>> real class<= ] [ interval>> empty-interval eq? ] bi and ]
+ } 1|| ;
+
+: min-value ( class -- n ) fixnum eq? [ most-negative-fixnum ] [ -1/0. ] if ;
+
+: max-value ( class -- n ) fixnum eq? [ most-positive-fixnum ] [ 1/0. ] if ;
+
+: class-interval ( class -- i ) fixnum eq? [ fixnum-interval ] [ full-interval ] if ;
+
+: wrap-interval ( interval class -- interval' )
+ {
+ { fixnum [ interval->fixnum ] }
+ { array-capacity [ max-array-capacity [a,a] interval-rem ] }
+ [ drop ]
+ } case ;
+
+: init-interval ( info -- info )
+ dup [ interval>> full-interval or ] [ class>> ] bi wrap-interval >>interval
+ dup class>> integer class<= [ [ integral-closure ] change-interval ] when ; inline
+
: init-value-info ( info -- info )
dup literal?>> [
init-literal-info
] [
- dup [ class>> null-class? ] [ interval>> empty-interval eq? ] bi or [
+ dup empty-set? [
null >>class
empty-interval >>interval
] [
- [ [-inf,inf] or ] change-interval
- dup class>> integer class<= [ [ integral-closure ] change-interval ] when
+ init-interval
dup [ class>> ] [ interval>> ] bi interval>literal
[ >>literal ] [ >>literal? ] bi*
] if
init-value-info ; foldable
: <class-info> ( class -- info )
- dup word? [ dup "interval" word-prop ] [ f ] if [-inf,inf] or
- <class/interval-info> ; foldable
+ f <class/interval-info> ; foldable
: <interval-info> ( interval -- info )
<value-info>
: splicing-call ( #call word -- nodes )
[ [ in-d>> ] [ out-d>> ] bi ] dip #call 1array ;
+: open-code-#call ( #call word/quot -- nodes/f )
+ [ [ in-d>> ] [ out-d>> ] bi ] dip build-sub-tree ;
+
: splicing-body ( #call quot/word -- nodes/f )
- build-sub-tree dup [ analyze-recursive normalize ] when ;
+ open-code-#call dup [ analyze-recursive normalize ] when ;
! Dispatch elimination
: undo-inlining ( #call -- ? )
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
compiler.tree.propagation.transforms ;
IN: compiler.tree.propagation.known-words
-\ fixnum
-most-negative-fixnum most-positive-fixnum [a,b]
-"interval" set-word-prop
-
-\ array-capacity
-0 max-array-capacity [a,b]
-"interval" set-word-prop
-
{ + - * / }
[ { number number } "input-classes" set-word-prop ] each
{ fixnum bignum integer rational float real number object }
[ class<= ] with find nip ;
-: fits? ( interval class -- ? )
- "interval" word-prop interval-subset? ;
+: fits-in-fixnum? ( interval -- ? )
+ fixnum-interval interval-subset? ;
: binary-op-class ( info1 info2 -- newclass )
[ class>> ] bi@
[ [ interval>> ] bi@ ] dip call ; inline
: won't-overflow? ( class interval -- ? )
- [ fixnum class<= ] [ fixnum fits? ] bi* and ;
+ [ fixnum class<= ] [ fits-in-fixnum? ] bi* and ;
: may-overflow ( class interval -- class' interval' )
over null-class? [
[ object-info ] [ f <literal-info> ] if ;
: info-intervals-intersect? ( info1 info2 -- ? )
- [ interval>> ] bi@ intervals-intersect? ;
+ 2dup [ class>> real class<= ] both?
+ [ [ interval>> ] bi@ intervals-intersect? ] [ 2drop t ] if ;
{ number= bignum= float= } [
[
{ >integer integer }
} [
- '[
- _
- [ nip ] [
- [ interval>> ] [ class-interval ] bi*
- interval-intersect
- ] 2bi
- <class/interval-info>
- ] "outputs" set-word-prop
+ '[ _ swap interval>> <class/interval-info> ] "outputs" set-word-prop
] assoc-each
{ numerator denominator }
[ string>number 8 * 2^ 1- 0 swap [a,b] ]
}
} cond
- [ fixnum fits? fixnum integer ? ] keep <class/interval-info>
+ [ fits-in-fixnum? fixnum integer ? ] keep <class/interval-info>
'[ 2drop _ ] "outputs" set-word-prop
] each
] final-literals
] unit-test
+[ V{ t } ] [ [ 40 mod 40 < ] final-literals ] unit-test
+
+[ V{ f } ] [ [ 40 mod 0 >= ] final-literals ] unit-test
+
+[ V{ t } ] [ [ 40 rem 0 >= ] final-literals ] unit-test
+
+[ V{ t } ] [ [ abs 40 mod 0 >= ] final-literals ] unit-test
+
[ V{ string } ] [
[ dup string? not [ "Oops" throw ] [ ] if ] final-classes
] unit-test
[ { integer } declare 127 bitand ] final-info first interval>>
] unit-test
+[ V{ t } ] [
+ [ [ 123 bitand ] [ drop f ] if dup [ 0 >= ] [ not ] if ] final-literals
+] unit-test
+
[ V{ bignum } ] [
[ { bignum } declare dup 1- bitxor ] final-classes
] unit-test
[ V{ 1 } ] [ [ { } length 1+ f <array> length ] final-literals ] unit-test
+! generalize-counter is not tight enough
+[ V{ fixnum } ] [ [ 0 10 [ 1 + >fixnum ] times ] final-classes ] unit-test
+
+[ V{ fixnum } ] [ [ 0 10 [ 1 + >fixnum ] times 0 + ] final-classes ] unit-test
+
+! Coercions need to update intervals
+[ V{ f } ] [ [ 1 2 ? 100 shift >fixnum 1 = ] final-literals ] unit-test
+
+[ V{ t } ] [ [ >fixnum 1 + >fixnum most-positive-fixnum <= ] final-literals ] unit-test
+
+[ V{ t } ] [ [ >fixnum 1 + >fixnum most-negative-fixnum >= ] final-literals ] unit-test
+
+[ V{ f } ] [ [ >fixnum 1 + >fixnum most-negative-fixnum > ] final-literals ] unit-test
+
! Mutable tuples with circularity should not cause problems
TUPLE: circle me ;
IN: compiler.tree.propagation.recursive.tests
USING: tools.test compiler.tree.propagation.recursive
-math.intervals kernel ;
+math.intervals kernel math literals layouts ;
[ T{ interval f { 0 t } { 1/0. t } } ] [
T{ interval f { 1 t } { 1 t } }
- T{ interval f { 0 t } { 0 t } } generalize-counter-interval
+ T{ interval f { 0 t } { 0 t } }
+ integer generalize-counter-interval
+] unit-test
+
+[ T{ interval f { 0 t } { $[ most-positive-fixnum ] t } } ] [
+ T{ interval f { 1 t } { 1 t } }
+ T{ interval f { 0 t } { 0 t } }
+ fixnum generalize-counter-interval
] unit-test
[ T{ interval f { -1/0. t } { 10 t } } ] [
T{ interval f { -1 t } { -1 t } }
- T{ interval f { 10 t } { 10 t } } generalize-counter-interval
+ T{ interval f { 10 t } { 10 t } }
+ integer generalize-counter-interval
+] unit-test
+
+[ T{ interval f { $[ most-negative-fixnum ] t } { 10 t } } ] [
+ T{ interval f { -1 t } { -1 t } }
+ T{ interval f { 10 t } { 10 t } }
+ fixnum generalize-counter-interval
] unit-test
[ t ] [
T{ interval f { 1 t } { 268435455 t } }
T{ interval f { -268435456 t } { 268435455 t } } tuck
- generalize-counter-interval =
+ integer generalize-counter-interval =
+] unit-test
+
+[ t ] [
+ T{ interval f { 1 t } { 268435455 t } }
+ T{ interval f { -268435456 t } { 268435455 t } } tuck
+ fixnum generalize-counter-interval =
+] unit-test
+
+[ full-interval ] [
+ T{ interval f { -5 t } { 3 t } }
+ T{ interval f { 2 t } { 11 t } }
+ integer generalize-counter-interval
+] unit-test
+
+[ $[ fixnum-interval ] ] [
+ T{ interval f { -5 t } { 3 t } }
+ T{ interval f { 2 t } { 11 t } }
+ fixnum generalize-counter-interval
] unit-test
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences accessors arrays fry math.intervals
-combinators namespaces
+USING: kernel sequences accessors arrays fry math math.intervals
+layouts combinators namespaces locals
stack-checker.inlining
compiler.tree
compiler.tree.combinators
in-d>> [ value-info ] map ;
: recursive-stacks ( #enter-recursive -- stacks initial )
- [ label>> calls>> [ node-input-infos ] map flip ]
+ [ label>> calls>> [ node>> node-input-infos ] map flip ]
[ latest-input-infos ] bi ;
-: generalize-counter-interval ( interval initial-interval -- interval' )
+:: generalize-counter-interval ( interval initial-interval class -- interval' )
{
- { [ 2dup interval-subset? ] [ empty-interval ] }
- { [ over empty-interval eq? ] [ empty-interval ] }
- { [ 2dup interval>= t eq? ] [ 1/0. [a,a] ] }
- { [ 2dup interval<= t eq? ] [ -1/0. [a,a] ] }
- [ [-inf,inf] ]
- } cond interval-union nip ;
+ { [ interval initial-interval interval-subset? ] [ initial-interval ] }
+ { [ interval empty-interval eq? ] [ initial-interval ] }
+ {
+ [ interval initial-interval interval>= t eq? ]
+ [ class max-value [a,a] initial-interval interval-union ]
+ }
+ {
+ [ interval initial-interval interval<= t eq? ]
+ [ class min-value [a,a] initial-interval interval-union ]
+ }
+ [ class class-interval ]
+ } cond ;
: generalize-counter ( info' initial -- info )
2dup [ not ] either? [ drop ] [
2dup [ class>> null-class? ] either? [ drop ] [
[ clone ] dip
- [ [ drop ] [ [ interval>> ] bi@ generalize-counter-interval ] 2bi >>interval ]
+ [ [ drop ] [ [ [ interval>> ] bi@ ] [ drop class>> ] 2bi generalize-counter-interval ] 2bi >>interval ]
[ [ drop ] [ [ slots>> ] bi@ [ generalize-counter ] 2map ] 2bi >>slots ]
[ [ drop ] [ [ length>> ] bi@ generalize-counter ] 2bi >>length ]
tri
IN: compiler.tree.recursive.tests
-USING: compiler.tree.recursive tools.test
-kernel combinators.short-circuit math sequences accessors
+USING: tools.test kernel combinators.short-circuit math sequences accessors
compiler.tree
compiler.tree.builder
-compiler.tree.combinators ;
+compiler.tree.combinators
+compiler.tree.recursive
+compiler.tree.recursive.private ;
[ { f f f f } ] [ f { f t f f } (tail-calls) ] unit-test
[ { f f f t } ] [ t { f t f f } (tail-calls) ] unit-test
\ loop-test-3 label-is-not-loop?
] unit-test
-: loop-test-4 ( a -- )
- dup [
- loop-test-4
- ] [
- drop
- ] if ; inline recursive
-
[ f ] [
[ [ [ ] map ] map ] build-tree analyze-recursive
[
DEFER: a''
-: b'' ( -- )
+: b'' ( a -- b )
a'' ; inline recursive
-: a'' ( -- )
- b'' a'' ; inline recursive
+: a'' ( a -- b )
+ dup [ b'' a'' ] when ; inline recursive
[ t ] [
[ a'' ] build-tree analyze-recursive
\ a'' label-is-not-loop?
] unit-test
+[ t ] [
+ [ a'' ] build-tree analyze-recursive
+ \ b'' label-is-loop?
+] unit-test
+
+[ t ] [
+ [ b'' ] build-tree analyze-recursive
+ \ a'' label-is-loop?
+] unit-test
+
+[ t ] [
+ [ b'' ] build-tree analyze-recursive
+ \ b'' label-is-not-loop?
+] unit-test
+
: loop-in-non-loop ( x quot: ( i -- ) -- )
over 0 > [
[ [ 1 - ] dip loop-in-non-loop ] [ call ] 2bi
build-tree analyze-recursive
\ (each-integer) label-is-loop?
] unit-test
+
+DEFER: a'''
+
+: b''' ( -- )
+ blah [ b''' ] [ a''' b''' ] if ; inline recursive
+
+: a''' ( -- )
+ blah [ b''' ] [ a''' ] if ; inline recursive
+
+[ t ] [
+ [ b''' ] build-tree analyze-recursive
+ \ a''' label-is-loop?
+] unit-test
+
+DEFER: b4
+
+: a4 ( a -- b ) dup [ b4 ] when ; inline recursive
+
+: b4 ( a -- b ) dup [ a4 reverse ] when ; inline recursive
+
+[ t ] [ [ b4 ] build-tree analyze-recursive \ a4 label-is-loop? ] unit-test
+[ t ] [ [ b4 ] build-tree analyze-recursive \ b4 label-is-not-loop? ] unit-test
+[ t ] [ [ a4 ] build-tree analyze-recursive \ a4 label-is-not-loop? ] unit-test
+[ t ] [ [ a4 ] build-tree analyze-recursive \ b4 label-is-loop? ] unit-test
\ 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 assocs arrays namespaces accessors sequences deques
-search-deques dlists compiler.tree compiler.tree.combinators ;
+USING: kernel assocs arrays namespaces accessors sequences deques fry
+search-deques dlists combinators.short-circuit make sets compiler.tree ;
IN: compiler.tree.recursive
-! Collect label info
-GENERIC: collect-label-info ( node -- )
+TUPLE: call-site tail? node label ;
-M: #return-recursive collect-label-info
- dup label>> (>>return) ;
+: recursive-phi-in ( #enter-recursive -- seq )
+ [ label>> calls>> [ node>> in-d>> ] map ] [ in-d>> ] bi suffix ;
-M: #call-recursive collect-label-info
- dup label>> calls>> push ;
+<PRIVATE
-M: #recursive collect-label-info
- label>> V{ } clone >>calls drop ;
+TUPLE: call-graph-node tail? label children calls ;
-M: node collect-label-info drop ;
-
-! A loop is a #recursive which only tail calls itself, and those
-! calls are nested inside other loops only. We optimistically
-! assume all #recursive nodes are loops, disqualifying them as
-! we see evidence to the contrary.
: (tail-calls) ( tail? seq -- seq' )
reverse [ swap [ and ] keep ] map nip reverse ;
: tail-calls ( tail? node -- seq )
[
- [ #phi? ]
- [ #return? ]
- [ #return-recursive? ]
- tri or or
+ {
+ [ #phi? ]
+ [ #return? ]
+ [ #return-recursive? ]
+ } 1||
] map (tail-calls) ;
-SYMBOL: loop-heights
-SYMBOL: loop-calls
-SYMBOL: loop-stack
-SYMBOL: work-list
+SYMBOLS: children calls ;
+
+GENERIC: node-call-graph ( tail? node -- )
-GENERIC: collect-loop-info* ( tail? node -- )
+: (build-call-graph) ( tail? nodes -- )
+ [ tail-calls ] keep
+ [ node-call-graph ] 2each ;
-: non-tail-label-info ( nodes -- )
- [ f swap collect-loop-info* ] each ;
+: build-call-graph ( nodes -- labels calls )
+ [
+ V{ } clone children set
+ V{ } clone calls set
+ [ t ] dip (build-call-graph)
+ children get
+ calls get
+ ] with-scope ;
-: (collect-loop-info) ( tail? nodes -- )
- [ tail-calls ] keep [ collect-loop-info* ] 2each ;
+M: #return-recursive node-call-graph
+ nip dup label>> (>>return) ;
-: remember-loop-info ( label -- )
- loop-stack get length swap loop-heights get set-at ;
+M: #call-recursive node-call-graph
+ [ dup label>> call-site boa ] keep
+ [ drop calls get push ]
+ [ label>> calls>> push ] 2bi ;
-M: #recursive collect-loop-info*
+M: #recursive node-call-graph
+ [ label>> V{ } clone >>calls drop ]
[
- [
- label>>
- [ swap 2array loop-stack [ swap suffix ] change ]
- [ remember-loop-info ]
- [ t >>loop? drop ]
- tri
- ]
- [ t swap child>> (collect-loop-info) ] bi
- ] with-scope ;
+ [ label>> ] [ child>> build-call-graph ] bi
+ call-graph-node boa children get push
+ ] bi ;
-: current-loop-nesting ( label -- alist )
- loop-stack get swap loop-heights get at tail ;
+M: #branch node-call-graph
+ children>> [ (build-call-graph) ] with each ;
-: disqualify-loop ( label -- )
- work-list get push-front ;
+M: node node-call-graph 2drop ;
-M: #call-recursive collect-loop-info*
- label>>
- swap [ dup disqualify-loop ] unless
- dup current-loop-nesting
- [ keys [ loop-calls get push-at ] with each ]
- [ [ nip not ] assoc-filter keys [ disqualify-loop ] each ]
- bi ;
+SYMBOLS: not-loops recursive-nesting ;
-M: #if collect-loop-info*
- children>> [ (collect-loop-info) ] with each ;
+: not-a-loop ( label -- ) not-loops get conjoin ;
-M: #dispatch collect-loop-info*
- children>> [ (collect-loop-info) ] with each ;
+: not-a-loop? ( label -- ? ) not-loops get key? ;
-M: node collect-loop-info* 2drop ;
+: non-tail-calls ( call-graph-node -- seq )
+ calls>> [ tail?>> not ] filter ;
+
+: visit-back-edges ( call-graph -- )
+ [
+ [ non-tail-calls [ label>> not-a-loop ] each ]
+ [ children>> visit-back-edges ]
+ bi
+ ] each ;
+
+SYMBOL: changed?
+
+: check-cross-frame-call ( call-site -- )
+ label>> dup not-a-loop? [ drop ] [
+ recursive-nesting get <reversed> [
+ 2dup label>> eq? [ 2drop f ] [
+ [ label>> not-a-loop? ] [ tail?>> not ] bi or
+ [ not-a-loop changed? on ] [ drop ] if t
+ ] if
+ ] with all? drop
+ ] if ;
+
+: detect-cross-frame-calls ( call-graph -- )
+ ! Suppose we have a nesting of recursives A --> B --> C
+ ! B tail-calls A, and C non-tail-calls B. Then A cannot be
+ ! a loop, it needs its own procedure, since the call from
+ ! C to A crosses a call-frame boundary.
+ [
+ [ recursive-nesting get push ]
+ [ calls>> [ check-cross-frame-call ] each ]
+ [ children>> detect-cross-frame-calls ] tri
+ recursive-nesting get pop*
+ ] each ;
+
+: while-changing ( quot: ( -- ) -- )
+ changed? off
+ [ call ] [ changed? get [ while-changing ] [ drop ] if ] bi ;
+ inline recursive
+
+: detect-loops ( call-graph -- )
+ H{ } clone not-loops set
+ V{ } clone recursive-nesting set
+ [ visit-back-edges ]
+ [ '[ _ detect-cross-frame-calls ] while-changing ]
+ bi ;
+
+: mark-loops ( call-graph -- )
+ [
+ [ label>> dup not-a-loop? [ t >>loop? ] unless drop ]
+ [ children>> mark-loops ]
+ bi
+ ] each ;
-: collect-loop-info ( node -- )
- { } loop-stack set
- H{ } clone loop-calls set
- H{ } clone loop-heights set
- <hashed-dlist> work-list set
- t swap (collect-loop-info) ;
+PRIVATE>
-: disqualify-loops ( -- )
- work-list get [
- dup loop?>> [
- [ f >>loop? drop ]
- [ loop-calls get at [ disqualify-loop ] each ]
- bi
- ] [ drop ] if
- ] slurp-deque ;
+SYMBOL: call-graph
: analyze-recursive ( nodes -- nodes )
- dup [ collect-label-info ] each-node
- dup collect-loop-info disqualify-loops ;
+ dup build-call-graph drop
+ [ call-graph set ]
+ [ detect-loops ]
+ [ mark-loops ]
+ tri ;
M: #copy inputs/outputs [ in-d>> ] [ out-d>> ] bi ;
M: #return-recursive inputs/outputs [ in-d>> ] [ out-d>> ] bi ;
-: recursive-phi-in ( #enter-recursive -- seq )
- [ label>> calls>> [ in-d>> ] map ] [ in-d>> ] bi suffix ;
-
: ends-with-terminate? ( nodes -- ? )
[ f ] [ last #terminate? ] if-empty ;
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces assocs accessors kernel combinators
+USING: namespaces assocs accessors kernel kernel.private combinators
classes.algebra sequences slots.private fry vectors
classes.tuple.private math math.private arrays
-stack-checker.branches
+stack-checker.branches stack-checker.values
compiler.utilities
compiler.tree
+compiler.tree.builder
+compiler.tree.cleanup
compiler.tree.combinators
+compiler.tree.propagation
compiler.tree.propagation.info
compiler.tree.escape-analysis.simple
compiler.tree.escape-analysis.allocations ;
} case ;
M: #declare unbox-tuples*
- #! We don't look at declarations after propagation anyway.
- f >>declaration ;
+ #! We don't look at declarations after escape analysis anyway.
+ drop f ;
M: #copy unbox-tuples*
[ flatten-values ] change-in-d
[ flatten-values ] change-in-d
[ flatten-values ] change-out-d ;
+: value-declaration ( value -- quot )
+ value-class [ 1array '[ _ declare ] ] [ [ ] ] if* ;
+
+: unbox-parameter-quot ( allocation -- quot )
+ dup unboxed-allocation {
+ { [ dup not ] [ 2drop [ ] ] }
+ { [ dup array? ] [
+ [ value-declaration ] [
+ [
+ [ unbox-parameter-quot ] [ 2 + '[ _ slot ] ] bi*
+ prepose
+ ] map-index
+ ] bi* '[ @ _ cleave ]
+ ] }
+ } cond ;
+
+: unbox-parameters-quot ( values -- quot )
+ [ unbox-parameter-quot ] map
+ dup [ [ ] = ] all? [ drop [ ] ] [ '[ _ spread ] ] if ;
+
+: unbox-parameters-nodes ( new-values old-values -- nodes )
+ [ flatten-values ] [ unbox-parameters-quot ] bi build-sub-tree ;
+
+: new-and-old-values ( values -- new-values old-values )
+ [ length [ <value> ] replicate ] keep ;
+
+: unbox-hairy-introduce ( #introduce -- nodes )
+ dup out-d>> new-and-old-values
+ [ drop >>out-d ] [ unbox-parameters-nodes ] 2bi
+ swap prefix propagate ;
+
+M: #introduce unbox-tuples*
+ ! For every output that is unboxed, insert slot accessors
+ ! to convert the stack value into its unboxed form
+ dup out-d>> [ unboxed-allocation ] any? [
+ unbox-hairy-introduce
+ ] when ;
+
! These nodes never participate in unboxing
: assert-not-unboxed ( values -- )
dup array?
M: #return unbox-tuples* dup in-d>> assert-not-unboxed ;
-M: #introduce unbox-tuples* dup out-d>> assert-not-unboxed ;
-
M: #alien-invoke unbox-tuples* dup in-d>> assert-not-unboxed ;
M: #alien-indirect unbox-tuples* dup in-d>> assert-not-unboxed ;
! 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' )
dup
'[
@ [
- dup array?
+ dup [ array? ] [ vector? ] bi or
[ _ push-all ] [ _ push ] if
] when*
]
yield-hook [ [ ] ] initialize
-: alist-max ( alist -- pair )
- [ ] [ [ [ second ] bi@ > ] most ] map-reduce ;
+: alist-most ( alist quot -- pair )
+ [ [ ] ] dip '[ [ [ second ] bi@ @ ] most ] map-reduce ; inline
+
+: alist-min ( alist -- pair ) [ before? ] alist-most ;
+
+: alist-max ( alist -- pair ) [ after? ] alist-most ;
: 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
+ ] ;
-! Copyright (C) 2006, 2008 Slava Pestov.
+! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays generic kernel kernel.private math
memory namespaces make sequences layouts system hashtables
classes alien byte-arrays combinators words sets fry ;
IN: cpu.architecture
-! Register classes
-SINGLETON: int-regs
-SINGLETON: single-float-regs
-SINGLETON: double-float-regs
-UNION: float-regs single-float-regs double-float-regs ;
-UNION: reg-class int-regs float-regs ;
-
-! A pseudo-register class for parameters spilled on the stack
-SINGLETON: stack-params
-
-GENERIC: reg-size ( register-class -- n )
+! Representations -- these are like low-level types
-M: int-regs reg-size drop cell ;
+! Unknown representation; this is used for ##copy instructions which
+! get eliminated later
+SINGLETON: any-rep
-M: single-float-regs reg-size drop 4 ;
+! Integer registers can contain data with one of these three representations
+! tagged-rep: tagged pointer or fixnum
+! int-rep: untagged fixnum, not a pointer
+SINGLETONS: tagged-rep int-rep ;
-M: double-float-regs reg-size drop 8 ;
+! Floating point registers can contain data with
+! one of these representations
+SINGLETONS: single-float-rep double-float-rep ;
-M: stack-params reg-size drop cell ;
+UNION: representation any-rep tagged-rep int-rep single-float-rep double-float-rep ;
-! Mapping from register class to machine registers
-HOOK: machine-registers cpu ( -- assoc )
+! Register classes
+SINGLETONS: int-regs float-regs ;
-! Return values of this class go here
-GENERIC: return-reg ( register-class -- reg )
+UNION: reg-class int-regs float-regs ;
+CONSTANT: reg-classes { int-regs float-regs }
-! Sequence of registers used for parameter passing in class
-GENERIC: param-regs ( register-class -- regs )
+! A pseudo-register class for parameters spilled on the stack
+SINGLETON: stack-params
-GENERIC: param-reg ( n register-class -- reg )
+: reg-class-of ( rep -- reg-class )
+ {
+ { tagged-rep [ int-regs ] }
+ { int-rep [ int-regs ] }
+ { single-float-rep [ float-regs ] }
+ { double-float-rep [ float-regs ] }
+ { stack-params [ stack-params ] }
+ } case ;
+
+: rep-size ( rep -- n )
+ {
+ { tagged-rep [ cell ] }
+ { int-rep [ cell ] }
+ { single-float-rep [ 4 ] }
+ { double-float-rep [ 8 ] }
+ { stack-params [ cell ] }
+ } case ;
-M: object param-reg param-regs nth ;
+! Mapping from register class to machine registers
+HOOK: machine-registers cpu ( -- assoc )
HOOK: two-operand? cpu ( -- ? )
HOOK: %integer>float cpu ( dst src -- )
HOOK: %float>integer cpu ( dst src -- )
-HOOK: %copy cpu ( dst src -- )
-HOOK: %copy-float cpu ( dst src -- )
+HOOK: %copy cpu ( dst src rep -- )
HOOK: %unbox-float cpu ( dst src -- )
HOOK: %unbox-any-c-ptr cpu ( dst src temp -- )
HOOK: %box-float cpu ( dst src temp -- )
HOOK: %compare-imm-branch cpu ( label cc src1 src2 -- )
HOOK: %compare-float-branch cpu ( label cc src1 src2 -- )
-HOOK: %spill-integer cpu ( src n -- )
-HOOK: %spill-float cpu ( src n -- )
-HOOK: %reload-integer cpu ( dst n -- )
-HOOK: %reload-float cpu ( dst n -- )
+HOOK: %spill cpu ( src n rep -- )
+HOOK: %reload cpu ( dst n rep -- )
HOOK: %loop-entry cpu ( -- )
! FFI stuff
+! Return values of this class go here
+GENERIC: return-reg ( reg-class -- reg )
+
+! Sequence of registers used for parameter passing in class
+GENERIC: param-regs ( reg-class -- regs )
+
+M: stack-params param-regs drop f ;
+
+GENERIC: param-reg ( n reg-class -- reg )
+
+M: reg-class param-reg param-regs nth ;
+
+M: stack-params param-reg drop ;
+
! Is this integer small enough to appear in value template
! slots?
HOOK: small-enough? cpu ( n -- ? )
HOOK: %prepare-unbox cpu ( -- )
-HOOK: %unbox cpu ( n reg-class func -- )
+HOOK: %unbox cpu ( n rep func -- )
HOOK: %unbox-long-long cpu ( n func -- )
HOOK: %unbox-large-struct cpu ( n c-type -- )
-HOOK: %box cpu ( n reg-class func -- )
+HOOK: %box cpu ( n rep func -- )
HOOK: %box-long-long cpu ( n func -- )
HOOK: %box-large-struct cpu ( n c-type -- )
-GENERIC: %save-param-reg ( stack reg reg-class -- )
+HOOK: %save-param-reg cpu ( stack reg rep -- )
-GENERIC: %load-param-reg ( stack reg reg-class -- )
+HOOK: %load-param-reg cpu ( stack reg rep -- )
HOOK: %prepare-alien-invoke cpu ( -- )
HOOK: %callback-return cpu ( params -- )
M: object %callback-return drop %return ;
-
-M: stack-params param-reg drop ;
-
-M: stack-params param-regs drop f ;
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
M: ppc machine-registers
{
{ int-regs $[ 2 12 [a,b] 15 29 [a,b] append ] }
- { double-float-regs $[ 0 29 [a,b] ] }
+ { float-regs $[ 0 29 [a,b] ] }
} ;
CONSTANT: scratch-reg 30
reserved-area-size param-save-size + + ; inline
: spill-integer@ ( n -- offset )
- spill-integer-offset param@ ;
+ spill-integer-offset local@ ;
: spill-float@ ( n -- offset )
- spill-float-offset param@ ;
+ spill-float-offset local@ ;
! Some FP intrinsics need a temporary scratch area in the stack
! frame, 8 bytes in size. This is in the param-save area so it
-! should not overlap with spill slots.
+! does not overlap with spill slots.
: scratch@ ( n -- offset )
stack-frame get total-size>>
factor-area-size -
! GC root area
: gc-root@ ( n -- offset )
- gc-root-offset param@ ;
+ gc-root-offset local@ ;
! Finally we have the linkage area
HOOK: lr-save os ( -- n )
M: ppc %xor-imm XORI ;
M: ppc %shl SLW ;
M: ppc %shl-imm swapd SLWI ;
-M: ppc %shr-imm SRW ;
+M: ppc %shr SRW ;
M: ppc %shr-imm swapd SRWI ;
M: ppc %sar SRAW ;
M: ppc %sar-imm SRAWI ;
0 0 LI
0 MTXER
dst src2 src1 insn call
- label BNO ; inline
+ label BO ; inline
M: ppc %fixnum-add ( label dst src1 src2 -- )
[ ADDO. ] overflow-template ;
M: ppc %fixnum-sub ( label dst src1 src2 -- )
[ SUBFO. ] overflow-template ;
-M:: ppc %fixnum-mul ( label dst src1 src2 -- )
+M: ppc %fixnum-mul ( label dst src1 src2 -- )
[ MULLWO. ] overflow-template ;
: bignum@ ( n -- offset ) cells bignum tag-number - ; inline
M:: ppc %call-gc ( gc-root-count -- )
%prepare-alien-invoke
- 3 1 gc-root-base param@ ADDI
+ 3 1 gc-root-base local@ ADDI
gc-root-count 4 LI
- "inline_gc" f %alien-invoke
- "end" resolve-label ;
+ "inline_gc" f %alien-invoke ;
M: ppc %prologue ( n -- )
0 11 LOAD32 rc-absolute-ppc-2/2 rel-this
M: int-regs %save-param-reg drop 1 rot local@ STW ;
M: int-regs %load-param-reg drop 1 rot local@ LWZ ;
-GENERIC: STF ( src dst off reg-class -- )
+M: single-float-rep %save-param-reg drop 1 rot local@ STFS ;
+M: single-float-rep %load-param-reg 1 rot local@ LFS ;
-M: single-float-regs STF drop STFS ;
-M: double-float-regs STF drop STFD ;
+M: double-float-rep %save-param-reg drop 1 rot local@ STFD ;
+M: double-float-rep %load-param-reg 1 rot local@ LFD ;
-M: float-regs %save-param-reg [ 1 rot local@ ] dip STF ;
-
-GENERIC: LF ( dst src off reg-class -- )
-
-M: single-float-regs LF drop LFS ;
-M: double-float-regs LF drop LFD ;
-
-M: float-regs %load-param-reg [ 1 rot local@ ] dip LF ;
-
-M: stack-params %load-param-reg ( stack reg reg-class -- )
+M: stack-params %load-param-reg ( stack reg rep -- )
drop [ 0 1 rot local@ LWZ 0 1 ] dip param@ STW ;
: next-param@ ( n -- x ) param@ stack-frame get total-size>> + ;
-M: stack-params %save-param-reg ( stack reg reg-class -- )
+M: stack-params %save-param-reg ( stack reg rep -- )
#! Funky. Read the parameter from the caller's stack frame.
#! This word is used in callbacks
drop
3 ds-reg 0 LWZ
ds-reg dup cell SUBI ;
-M: ppc %unbox ( n reg-class func -- )
+M: ppc %unbox ( n rep func -- )
! Value must be in r3
! Call the unboxer
f %alien-invoke
! Store the return value on the C stack
- over [ [ return-reg ] keep %save-param-reg ] [ 2drop ] if ;
+ over [ [ reg-class-of return-reg ] keep %save-param-reg ] [ 2drop ] if ;
M: ppc %unbox-long-long ( n func -- )
! Value must be in r3:r4
! Call the function
"to_value_struct" f %alien-invoke ;
-M: ppc %box ( n reg-class func -- )
+M: ppc %box ( n rep func -- )
! If the source is a stack location, load it into freg #0.
! If the source is f, then we assume the value is already in
! freg #0.
- [ over [ 0 over param-reg swap %load-param-reg ] [ 2drop ] if ] dip
+ [ over [ 0 over reg-class-of param-reg swap %load-param-reg ] [ 2drop ] if ] dip
f %alien-invoke ;
M: ppc %box-long-long ( n func -- )
IN: cpu.x86.32
! We implement the FFI for Linux, OS X and Windows all at once.
-! OS X requires that the stack be 16-byte aligned, and we do
-! this on all platforms, sacrificing some stack space for
-! code simplicity.
+! OS X requires that the stack be 16-byte aligned.
M: x86.32 machine-registers
{
{ int-regs { EAX ECX EDX EBP EBX } }
- { double-float-regs { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } }
+ { float-regs { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } }
} ;
M: x86.32 ds-reg ESI ;
M: x86.32 rs-reg EDI ;
M: x86.32 stack-reg ESP ;
-M: x86.32 temp-reg-1 ECX ;
-M: x86.32 temp-reg-2 EDX ;
+M: x86.32 temp-reg ECX ;
M:: x86.32 %dispatch ( src temp -- )
! Load jump table base.
! On x86, parameters are never passed in registers.
M: int-regs return-reg drop EAX ;
M: int-regs param-regs drop { } ;
-M: int-regs push-return-reg return-reg PUSH ;
-
-M: int-regs load-return-reg
- return-reg swap next-stack@ MOV ;
-
-M: int-regs store-return-reg
- [ stack@ ] [ return-reg ] bi* MOV ;
-
M: float-regs param-regs drop { } ;
-: FSTP ( operand size -- ) 4 = [ FSTPS ] [ FSTPL ] if ;
-
-M: float-regs push-return-reg
- stack-reg swap reg-size
- [ SUB ] [ [ [] ] dip FSTP ] 2bi ;
+GENERIC: push-return-reg ( rep -- )
+GENERIC: load-return-reg ( n rep -- )
+GENERIC: store-return-reg ( n rep -- )
-: FLD ( operand size -- ) 4 = [ FLDS ] [ FLDL ] if ;
+M: int-rep push-return-reg drop EAX PUSH ;
+M: int-rep load-return-reg drop EAX swap next-stack@ MOV ;
+M: int-rep store-return-reg drop stack@ EAX MOV ;
-M: float-regs load-return-reg
- [ next-stack@ ] [ reg-size ] bi* FLD ;
+M: single-float-rep push-return-reg drop ESP 4 SUB ESP [] FSTPS ;
+M: single-float-rep load-return-reg drop next-stack@ FLDS ;
+M: single-float-rep store-return-reg drop stack@ FSTPS ;
-M: float-regs store-return-reg
- [ stack@ ] [ reg-size ] bi* FSTP ;
+M: double-float-rep push-return-reg drop ESP 8 SUB ESP [] FSTPL ;
+M: double-float-rep load-return-reg drop next-stack@ FLDL ;
+M: double-float-rep store-return-reg drop stack@ FSTPL ;
: align-sub ( n -- )
[ align-stack ] keep - decr-stack-reg ;
0 PUSH rc-absolute-cell rel-this
3 cells - decr-stack-reg ;
-M: object %load-param-reg 3drop ;
+M: x86.32 %load-param-reg 3drop ;
-M: object %save-param-reg 3drop ;
+M: x86.32 %save-param-reg 3drop ;
-: (%box) ( n reg-class -- )
+: (%box) ( n rep -- )
#! If n is f, push the return register onto the stack; we
#! are boxing a return value of a C function. If n is an
#! integer, push [ESP+n] on the stack; we are boxing a
#! parameter being passed to a callback from C.
over [ load-return-reg ] [ 2drop ] if ;
-M:: x86.32 %box ( n reg-class func -- )
- n reg-class (%box)
- reg-class reg-size [
- reg-class push-return-reg
+M:: x86.32 %box ( n rep func -- )
+ n rep (%box)
+ rep rep-size [
+ rep push-return-reg
func f %alien-invoke
] with-aligned-stack ;
EAX ESI [] MOV
ESI 4 SUB ;
-: (%unbox) ( func -- )
+: call-unbox-func ( func -- )
4 [
! Push parameter
EAX PUSH
f %alien-invoke
] with-aligned-stack ;
-M: x86.32 %unbox ( n reg-class func -- )
+M: x86.32 %unbox ( n rep func -- )
#! The value being unboxed must already be in EAX.
#! If n is f, we're unboxing a return value about to be
#! returned by the callback. Otherwise, we're unboxing
#! a parameter to a C function about to be called.
- (%unbox)
+ call-unbox-func
! Store the return value on the C stack
over [ store-return-reg ] [ 2drop ] if ;
M: x86.32 %unbox-long-long ( n func -- )
- (%unbox)
+ call-unbox-func
! Store the return value on the C stack
[
dup stack@ EAX MOV
M: x86.64 machine-registers
{
{ int-regs { RAX RCX RDX RBX RBP RSI RDI R8 R9 R10 R11 R12 R13 } }
- { double-float-regs {
+ { float-regs {
XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7
XMM8 XMM9 XMM10 XMM11 XMM12 XMM13 XMM14 XMM15
} }
M: float-regs return-reg drop XMM0 ;
M: x86.64 %prologue ( n -- )
- temp-reg-1 0 MOV rc-absolute-cell rel-this
+ temp-reg 0 MOV rc-absolute-cell rel-this
dup PUSH
- temp-reg-1 PUSH
+ temp-reg PUSH
stack-reg swap 3 cells - SUB ;
-M: stack-params %load-param-reg
+M: stack-params copy-register*
drop
- [ R11 swap param@ MOV ] dip
- param@ R11 MOV ;
+ {
+ { [ dup integer? ] [ R11 swap next-stack@ MOV R11 MOV ] }
+ { [ over integer? ] [ R11 swap MOV param@ R11 MOV ] }
+ } cond ;
-M: stack-params %save-param-reg
- drop
- R11 swap next-stack@ MOV
- param@ R11 MOV ;
+M: x86 %save-param-reg [ param@ ] 2dip copy-register ;
+
+M: x86 %load-param-reg [ swap param@ ] dip copy-register ;
: with-return-regs ( quot -- )
[
param-reg-1 R14 [] MOV
R14 cell SUB ;
-M: x86.64 %unbox ( n reg-class func -- )
+M:: x86.64 %unbox ( n rep func -- )
! Call the unboxer
- f %alien-invoke
- ! Store the return value on the C stack
- over [ [ return-reg ] keep %save-param-reg ] [ 2drop ] if ;
+ func f %alien-invoke
+ ! Store the return value on the C stack if this is an
+ ! alien-invoke, otherwise leave it the return register if
+ ! this is the end of alien-callback
+ n [ n rep reg-class-of return-reg rep %save-param-reg ] when ;
M: x86.64 %unbox-long-long ( n func -- )
- int-regs swap %unbox ;
+ [ int-rep ] dip %unbox ;
: %unbox-struct-field ( c-type i -- )
! Alien must be in param-reg-1.
- R11 swap cells [+] swap reg-class>> {
+ R11 swap cells [+] swap rep>> reg-class-of {
{ int-regs [ int-regs get pop swap MOV ] }
- { double-float-regs [ float-regs get pop swap MOVSD ] }
+ { float-regs [ float-regs get pop swap MOVSD ] }
} case ;
M: x86.64 %unbox-small-struct ( c-type -- )
! Copy the struct to the C stack
"to_value_struct" f %alien-invoke ;
-: load-return-value ( reg-class -- )
- 0 over param-reg swap return-reg
- 2dup eq? [ 2drop ] [ MOV ] if ;
-
-M: x86.64 %box ( n reg-class func -- )
- rot [
- rot [ 0 swap param-reg ] keep %load-param-reg
+: load-return-value ( rep -- )
+ [ [ 0 ] dip reg-class-of param-reg ]
+ [ reg-class-of return-reg ]
+ [ ]
+ tri copy-register ;
+
+M:: x86.64 %box ( n rep func -- )
+ n [
+ n
+ 0 rep reg-class-of param-reg
+ rep %load-param-reg
] [
- swap load-return-value
- ] if*
- f %alien-invoke ;
+ rep load-return-value
+ ] if
+ func f %alien-invoke ;
M: x86.64 %box-long-long ( n func -- )
- int-regs swap %box ;
+ [ int-rep ] dip %box ;
: box-struct-field@ ( i -- operand ) 1+ cells param@ ;
: %box-struct-field ( c-type i -- )
- box-struct-field@ swap reg-class>> {
+ box-struct-field@ swap c-type-rep reg-class-of {
{ int-regs [ int-regs get pop MOV ] }
- { double-float-regs [ float-regs get pop MOVSD ] }
+ { float-regs [ float-regs get pop MOVSD ] }
} case ;
M: x86.64 %box-small-struct ( c-type -- )
compiler.cfg.registers ;
IN: cpu.x86.64.unix
-M: int-regs param-regs drop { RDI RSI RDX RCX R8 R9 } ;
+M: int-regs param-regs
+ drop { RDI RSI RDX RCX R8 R9 } ;
M: float-regs param-regs
drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
! The ABI for passing structs by value is pretty messed up
<< "void*" c-type clone "__stack_value" define-primitive-type
-stack-params "__stack_value" c-type (>>reg-class) >>
+stack-params "__stack_value" c-type (>>rep) >>
: struct-types&offset ( struct-type -- pairs )
fields>> [
: flatten-small-struct ( c-type -- seq )
struct-types&offset split-struct [
- [ c-type c-type-reg-class ] map
+ [ c-type c-type-rep reg-class-of ] map
int-regs swap member? "void*" "double" ? c-type
] map ;
M: x86.64 dummy-fp-params? f ;
-M: x86.64 temp-reg-1 R8 ;
-
-M: x86.64 temp-reg-2 R9 ;
+M: x86.64 temp-reg R8 ;
! 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 } ;
M: x86.64 dummy-fp-params? t ;
-M: x86.64 temp-reg-1 RAX ;
-
-M: x86.64 temp-reg-2 RCX ;
+M: x86.64 temp-reg RAX ;
<<
"longlong" "ptrdiff_t" typedef
: PSHUFLW ( dest src imm -- ) HEX: 70 HEX: f2 3-operand-rm-sse ;
: PSHUFHW ( dest src imm -- ) HEX: 70 HEX: f3 3-operand-rm-sse ;
+<PRIVATE
+
: (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 ;
: (PSLLD-reg) ( dest src -- ) HEX: f2 HEX: 66 2-operand-rm-sse ;
: (PSLLQ-reg) ( dest src -- ) HEX: f3 HEX: 66 2-operand-rm-sse ;
+PRIVATE>
+
: 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 ;
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 ;
+<PRIVATE
+
PREDICATE: register-8 < register
"register-size" word-prop 8 = ;
PREDICATE: register-128 < register
"register-size" word-prop 128 = ;
+GENERIC: extended? ( op -- ? )
+
+M: object extended? drop f ;
+
M: register extended? "register" word-prop 7 > ;
! Addressing modes
: param@ ( n -- op ) reserved-area-size + stack@ ;
-: spill-integer@ ( n -- op ) spill-integer-offset param@ ;
-
-: spill-float@ ( n -- op ) spill-float-offset param@ ;
+: spill@ ( n -- op ) spill-offset param@ ;
: gc-root@ ( n -- op ) gc-root-offset param@ ;
M: x86 stack-frame-size ( stack-frame -- i )
(stack-frame-size) 3 cells reserved-area-size + + align-stack ;
-HOOK: temp-reg-1 cpu ( -- reg )
-HOOK: temp-reg-2 cpu ( -- reg )
+! Must be a volatile register not used for parameter passing, for safe
+! use in calls in and out of C
+HOOK: temp-reg cpu ( -- reg )
+! Fastcall calling convention
HOOK: param-reg-1 cpu ( -- reg )
HOOK: param-reg-2 cpu ( -- reg )
M: x86 %not drop NOT ;
M: x86 %log2 BSR ;
-: ?MOV ( dst src -- )
- 2dup = [ 2drop ] [ MOV ] if ; inline
-
:: overflow-template ( label dst src1 src2 insn -- )
src1 src2 insn call
label JO ; inline
M: x86 %integer>float CVTSI2SD ;
M: x86 %float>integer CVTTSD2SI ;
-M: x86 %copy ( dst src -- ) ?MOV ;
+GENERIC: copy-register* ( dst src rep -- )
-M: x86 %copy-float ( dst src -- )
- 2dup = [ 2drop ] [ MOVSD ] if ;
+M: int-rep copy-register* drop MOV ;
+M: tagged-rep copy-register* drop MOV ;
+M: single-float-rep copy-register* drop MOVSS ;
+M: double-float-rep copy-register* drop MOVSD ;
+
+: copy-register ( dst src rep -- )
+ 2over eq? [ 3drop ] [ copy-register* ] if ;
+
+M: x86 %copy ( dst src rep -- ) copy-register ;
M: x86 %unbox-float ( dst src -- )
float-offset [+] MOVSD ;
[ quot call ] with-save/restore
] if ; inline
+: ?MOV ( dst src -- )
+ 2dup = [ 2drop ] [ MOV ] if ; inline
+
M:: x86 %string-nth ( dst src index temp -- )
! We request a small-reg of size 8 since those of size 16 are
! a superset.
{ cc/= [ JNE ] }
} case ;
-M: x86 %spill-integer ( src n -- ) spill-integer@ swap MOV ;
-M: x86 %reload-integer ( dst n -- ) spill-integer@ MOV ;
-
-M: x86 %spill-float ( src n -- ) spill-float@ swap MOVSD ;
-M: x86 %reload-float ( dst n -- ) spill-float@ MOVSD ;
+M: x86 %spill ( src n rep -- ) [ spill@ swap ] dip copy-register ;
+M: x86 %reload ( dst n rep -- ) [ spill@ ] dip copy-register ;
M: x86 %loop-entry 16 code-alignment [ NOP ] times ;
-M: int-regs %save-param-reg drop [ param@ ] dip MOV ;
-M: int-regs %load-param-reg drop swap param@ MOV ;
-
-GENERIC: MOVSS/D ( dst src reg-class -- )
-
-M: single-float-regs MOVSS/D drop MOVSS ;
-M: double-float-regs MOVSS/D drop MOVSD ;
-
-M: float-regs %save-param-reg [ param@ ] 2dip MOVSS/D ;
-M: float-regs %load-param-reg [ swap param@ ] dip MOVSS/D ;
-
-GENERIC: push-return-reg ( reg-class -- )
-GENERIC: load-return-reg ( n reg-class -- )
-GENERIC: store-return-reg ( n reg-class -- )
-
M: x86 %prepare-alien-invoke
#! Save Factor stack pointers in case the C code calls a
#! callback which does a GC, which must reliably trace
#! all roots.
- temp-reg-1 "stack_chain" f %alien-global
- temp-reg-1 temp-reg-1 [] MOV
- temp-reg-1 [] stack-reg MOV
- temp-reg-1 [] cell SUB
- temp-reg-1 2 cells [+] ds-reg MOV
- temp-reg-1 3 cells [+] rs-reg MOV ;
+ temp-reg "stack_chain" f %alien-global
+ temp-reg temp-reg [] MOV
+ temp-reg [] stack-reg MOV
+ temp-reg [] cell SUB
+ temp-reg 2 cells [+] ds-reg MOV
+ temp-reg 3 cells [+] rs-reg MOV ;
M: x86 value-struct? drop t ;
: edit-vocab ( name -- )
>vocab-link edit ;
-GENERIC: error-file ( error -- file )
-
-GENERIC: error-line ( error -- line )
-
-M: lexer-error error-file
- error>> error-file ;
-
-M: lexer-error error-line
- [ error>> error-line ] [ line>> ] bi or ;
-
-M: source-file-error error-file
- [ error>> error-file ] [ file>> ] bi or ;
-
-M: source-file-error error-line
- error>> error-line ;
-
-M: condition error-file
- error>> error-file ;
-
-M: condition error-line
- error>> error-line ;
-
-M: object error-file
- drop f ;
-
-M: object error-line
- drop f ;
-
-: (:edit) ( error -- )
+: edit-error ( error -- )
[ error-file ] [ error-line ] bi
2dup and [ edit-location ] [ 2drop ] if ;
: :edit ( -- )
- error get (:edit) ;
-
-: edit-error ( error -- )
- [ file>> ] [ line#>> ] bi 2dup and [ edit-location ] [ 2drop ] if ;
+ error get edit-error ;
: edit-each ( seq -- )
[
[ "mate" , "-a" , "-l" , number>string , , ] { } make
run-detached drop ;
-[ textmate ] edit-hook set-global
+[ textmate ] edit-hook set-global
\ No newline at end of file
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays classes.mixin classes.parser classes.singleton
-classes.tuple classes.tuple.parser combinators effects effects.parser
-fry generic generic.parser generic.standard interpolate
-io.streams.string kernel lexer locals.parser locals.rewrite.closures
-locals.types make namespaces parser quotations sequences vocabs.parser
-words words.symbol ;
+USING: accessors arrays classes.mixin classes.parser
+classes.singleton classes.tuple classes.tuple.parser
+combinators effects.parser fry generic generic.parser
+generic.standard interpolate io.streams.string kernel lexer
+locals.parser locals.types macros make namespaces parser
+quotations sequences vocabs.parser words words.symbol ;
IN: functors
! This is a hack
complete-effect parsed
\ define-simple-generic* parsed ;
+SYNTAX: `MACRO:
+ scan-param parsed
+ parse-declared*
+ \ define-macro parsed ;
+
SYNTAX: `inline [ word make-inline ] over push-all ;
SYNTAX: `call-next-method T{ fake-call-next-method } parsed ;
{ "SYNTAX:" POSTPONE: `SYNTAX: }
{ "SYMBOL:" POSTPONE: `SYMBOL: }
{ "inline" POSTPONE: `inline }
+ { "MACRO:" POSTPONE: `MACRO: }
{ "call-next-method" POSTPONE: `call-next-method }
} ;
HELP: page-action
{ $class-description "The class of Chloe page actions. These are actions whose " { $slot "display" } " slot is pre-set to serve the Chloe template stored in the " { $slot "page" } " slot." } ;
-HELP: param
-{ $values
- { "name" string }
- { "value" string }
-}
-{ $description "Outputs the value of a query parameter (if the current request is a GET or HEAD request) or a POST parameter (if the current request is a POST request)." }
-{ $notes "Instead of using this word, it is better to use " { $link validate-params } " and then access parameters via " { $link "html.forms.values" } " words." } ;
-
-HELP: params
-{ $var-description "A variable holding an assoc of query parameters (if the current request is a GET or HEAD request) or POST parameters (if the current request is a POST request)." }
-{ $notes "Instead of using this word, it is better to use " { $link validate-params } " and then access parameters via " { $link "html.forms.values" } " words." } ;
-
HELP: validate-integer-id
{ $description "A utility word which validates an integer parameter named " { $snippet "id" } "." }
{ $examples
ARTICLE: "furnace.actions.config" "Furnace action configuration"
"Actions have the following slots:"
{ $table
- { { $slot "rest" } { "A parameter name to map the rest of the URL, after the action name, to. If this is not set, then navigating to a URL where the action is not the last path component will return to the client with an error." } }
+ { { $slot "rest" } { "A parameter name to map the rest of the URL, after the action name, to. If this is not set, then navigating to a URL where the action is not the last path component will return to the client with an error. A more general facility can be found in the " { $vocab-link "http.server.rewrite" } " vocabulary." } }
{ { $slot "init" } { "A quotation called at the beginning of a GET or HEAD request. Typically this quotation configures " { $link "html.forms" } " and parses query parameters." } }
{ { $slot "authorize" } { "A quotation called at the beginning of a GET, HEAD or POST request. In GET requests, it is called after the " { $slot "init" } " quotation; in POST requests, it is called after the " { $slot "validate" } " quotation. By convention, this quotation performs custom authorization checks which depend on query parameters or POST parameters." } }
{ { $slot "display" } { "A quotation called after the " { $slot "init" } " quotation in a GET request. This quotation must return an HTTP " { $link response } "." } }
"Any one of the above steps can perform validation; if " { $link validation-failed } " is called during a POST request, the client is sent back to the page containing the form submission, with current form values and validation errors passed in a " { $link "furnace.conversations" } "." ;
ARTICLE: "furnace.actions.impl" "Furnace actions implementation"
-"The following words are used by the action implementation and there is rarely any reason to call them directly:"
-{ $subsection new-action }
-{ $subsection param }
-{ $subsection params } ;
+"The following parametrized constructor should be called from constructors for subclasses of " { $link action } ":"
+{ $subsection new-action } ;
ARTICLE: "furnace.actions" "Furnace actions"
"The " { $vocab-link "furnace.actions" } " vocabulary implements a type of responder, called an " { $emphasis "action" } ", which handles the form validation lifecycle."
html.templates.chloe.compiler ;\r
IN: furnace.actions\r
\r
-SYMBOL: params\r
-\r
SYMBOL: rest\r
\r
TUPLE: action rest init authorize display validate submit ;\r
] [ drop <400> ] if\r
] with-exit-continuation ;\r
\r
-: param ( name -- value )\r
- params get at ;\r
-\r
CONSTANT: revalidate-url-key "__u"\r
\r
: revalidate-url ( -- url/f )\r
] [ drop <400> ] if\r
] with-exit-continuation ;\r
\r
-: handle-rest ( path action -- assoc )\r
- rest>> dup [ [ "/" join ] dip associate ] [ 2drop f ] if ;\r
+: handle-rest ( path action -- )\r
+ rest>> dup [ [ "/" join ] dip set-param ] [ 2drop ] if ;\r
\r
: init-action ( path action -- )\r
begin-form\r
- handle-rest\r
- request get request-params assoc-union params set ;\r
+ handle-rest ;\r
\r
M: action call-responder* ( path action -- response )\r
[ init-action ] keep\r
\r
"auth-test.db" temp-file <sqlite-db> [\r
\r
- <request> init-request\r
+ <request> "GET" >>method init-request\r
session ensure-table\r
\r
"127.0.0.1" 1234 <inet4> remote-address set\r
{ $values { "referrer/f" { $maybe string } } }
{ $description "Outputs the current request's referrer URL." } ;
-HELP: request-params
-{ $values { "request" request } { "assoc" assoc } }
-{ $description "Outputs the query parameters (if the current request is a GET or HEAD request) or the POST parameters (if the current request is a POST request)." } ;
-
HELP: resolve-base-path
{ $values { "string" string } { "string'" string } }
{ $description "Resolves a responder-relative URL." } ;
{ $subsection exit-with }
"Other useful words:"
{ $subsection hidden-form-field }
-{ $subsection request-params }
{ $subsection client-state }
{ $subsection user-agent } ;
CONSTANT: nested-forms-key "__n"
-: request-params ( request -- assoc )
- dup method>> {
- { "GET" [ url>> query>> ] }
- { "HEAD" [ url>> query>> ] }
- { "POST" [ post-data>> params>> ] }
- } case ;
-
: referrer ( -- referrer/f )
#! Typo is intentional, it's in the HTTP spec!
"referer" request get header>> at
] each
: sort-entries ( entries -- entries' )
- [ [ key>> ] compare ] sort ;
+ [ key>> ] sort-with ;
: delete-test ( n -- obj1 obj2 )
[
{ $code ": sq ( x -- y ) dup * ;" }
"(You could have looked this up yourself by clicking on the " { $link sq } " word itself.)"
$nl
-"Note the key elements in a word definition: The colon " { $link POSTPONE: : } " denotes the start of a word definition. The name of the new word must immediately follow. The word definition then continues on until the " { $link POSTPONE: ; } " token signifies the end of the definition. This type of word definition is called a " { $emphasis "compound definition." }
+"Note the key elements in a word definition: The colon " { $link POSTPONE: : } " denotes the start of a word definition. The name of the new word and a stack effect declaration must immediately follow. The word definition then continues on until the " { $link POSTPONE: ; } " token signifies the end of the definition. This type of word definition is called a " { $emphasis "compound definition." }
$nl
"Factor is all about code reuse through short and logical colon definitions. Breaking up a problem into small pieces which are easy to test is called " { $emphasis "factoring." }
$nl
}
"Note that words must be defined before being referenced. The following is generally invalid:"
{ $code
- ": frob accelerate particles ;"
- ": accelerate accelerator on ;"
- ": particles [ (particles) ] each ;"
+ ": frob ( what -- ) accelerate particles ;"
+ ": accelerate ( -- ) accelerator on ;"
+ ": particles ( what -- ) [ (particles) ] each ;"
}
-"You would have to place the first definition after the two others for the parser to accept the file."
+"You would have to place the first definition after the two others for the parser to accept the file. If you have a set of mutually recursive words, you can use " { $link POSTPONE: DEFER: } "."
{ $references
{ }
"word-search"
"Don't worry about efficiency unless your program is too slow. Don't prefer complex code to simple code just because you feel it will be more efficient. The Factor compiler is designed to make idiomatic code run fast."
{ "None of the above are hard-and-fast rules: there are exceptions to all of them. But one rule unconditionally holds: " { $emphasis "there is always a simpler way" } "." }
}
-"Factor tries to implement as much of itself as possible, because this improves simplicity and performance. One consequence is that Factor exposes its internals for extension and study. You even have the option of using low-level features not usually found in high-level languages, such manual memory management, pointer arithmetic, and inline assembly code."
+"Factor tries to implement as much of itself as possible, because this improves simplicity and performance. One consequence is that Factor exposes its internals for extension and study. You even have the option of using low-level features not usually found in high-level languages, such as manual memory management, pointer arithmetic, and inline assembly code."
$nl
"Unsafe features are tucked away so that you will not invoke them by accident, or have to use them to solve conventional programming problems. However when the need arises, unsafe features are invaluable, for example you might have to do some pointer arithmetic when interfacing directly with C libraries." ;
"Factor only makes use of one native thread, and Factor threads are scheduled co-operatively. C library calls block the entire VM."
"Factor does not hide anything from the programmer, all internals are exposed. It is your responsibility to avoid writing fragile code which depends too much on implementation detail."
{ "If a literal object appears in a word definition, the object itself is pushed on the stack when the word executes, not a copy. If you intend to mutate this object, you must " { $link clone } " it first. See " { $link "syntax-literals" } "." }
+ { "Also, " { $link dup } " and related shuffle words don't copy entire objects or arrays; they only duplicate the reference to them. If you want to guard an object against mutation, use " { $link clone } "." }
{ "For a discussion of potential issues surrounding the " { $link f } " object, see " { $link "booleans" } "." }
{ "Factor's object system is quite flexible. Careless usage of union, mixin and predicate classes can lead to similar problems to those caused by “multiple inheritance” in other languages. In particular, it is possible to have two classes such that they have a non-empty intersection and yet neither is a subclass of the other. If a generic word defines methods on two such classes, various disambiguation rules are applied to ensure method dispatch remains deterministic, however they may not be what you expect. See " { $link "method-order" } " for details." }
{ "Be careful when calling words which access variables from a " { $link make-assoc } " which constructs an assoc with arbitrary keys, since those keys might shadow variables." }
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 ;
{ $code "USE: tools.scaffold" }
"Then, ask the scaffold tool to create a new vocabulary named " { $snippet "palindrome" } ":"
{ $code "\"resource:work\" \"palindrome\" scaffold-vocab" }
-"If you look at the output, you will see that a few files were created in your “work” directory. The following phrase will print the full path of your work directory:"
+"If you look at the output, you will see that a few files were created in your “work” directory, and that the new source file was loaded."
+$nl
+"The following phrase will print the full path of your work directory:"
{ $code "\"work\" resource-path ." }
"The work directory is one of several " { $link "vocabs.roots" } " where Factor searches for vocabularies. It is possible to define new vocabulary roots; see " { $link "add-vocab-roots" } ". To keep things simple in this tutorial, we'll just use the work directory, though."
$nl
-"Open the work directory in your file manager, and open the subdirectory named " { $snippet "palindrome" } ". Inside this subdirectory you will see a file named " { $snippet "palindrome.factor" } ". We will be editing this file."
-$nl
-"Notice that the file ends with an " { $link POSTPONE: IN: } " form telling Factor that all definitions in this source file should go into the " { $snippet "palindrome" } " vocabulary using the " { $link POSTPONE: IN: } " word:"
-{ $code "IN: palindrome" }
-"We will add new definitions after the " { $link POSTPONE: IN: } " form."
+"Open the work directory in your file manager, and open the subdirectory named " { $snippet "palindrome" } ". Inside this subdirectory you will see a file named " { $snippet "palindrome.factor" } ". Open this file in your text editor."
$nl
"You are now ready to go on to the next section: " { $link "first-program-logic" } "." ;
ARTICLE: "first-program-logic" "Writing some logic in your first program"
"Your " { $snippet "palindrome.factor" } " file should look like the following after the previous section:"
{ $code
- "! Copyright (C) 2008 <your name here>"
+ "! Copyright (C) 2009 <your name here>"
"! See http://factorcode.org/license.txt for BSD license."
+ "USING: ;"
"IN: palindrome"
}
+"Notice that the file ends with an " { $link POSTPONE: IN: } " form telling Factor that all definitions in this source file should go into the " { $snippet "palindrome" } " vocabulary using the " { $link POSTPONE: IN: } " word. We will add new definitions after the " { $link POSTPONE: IN: } " form."
+$nl
+"In order to be able to call the words defined in the " { $snippet "palindrome" } " vocabulary, you need to issue the following command in the listener:"
+{ $code "USE: palindrome" }
+"Now, we will be making some additions to the file. Since the file was loaded by the scaffold tool in the previous step, you need to tell Factor to reload it if it changes. Factor has a handy feature for this; pressing " { $command tool "common" refresh-all } " in the listener window will reload any changed source files. You can also force a single vocabulary to reload:"
+{ $code "\"palindrome\" reload" }
"We will now write our first word using " { $link POSTPONE: : } ". This word will test if a string is a palindrome; it will take a string as input, and give back a boolean as output. We will call this word " { $snippet "palindrome?" } ", following a naming convention that words returning booleans have names ending with " { $snippet "?" } "."
$nl
"Recall that a string is a palindrome if it is spelled the same forwards or backwards; that is, if the string is equal to its reverse. We can express this in Factor as follows:"
$nl
"To add the word to the search path, first convince yourself that this word is in the " { $vocab-link "kernel" } " vocabulary. Enter " { $snippet "dup" } " in the listener's input area, and press " { $operation com-browse } ". This will open the documentation browser tool, viewing the help for the " { $link dup } " word. One of the subheadings in the help article will mention the word's vocabulary."
$nl
-"So now, add the following at the start of the source file:"
+"Go back to the third line in your source file and change it to:"
{ $code "USING: kernel ;" }
"Next, find out what vocabulary " { $link reverse } " lives in; type the word name " { $snippet "reverse" } " in the listener's input area, and press " { $operation com-browse } "."
$nl
ARTICLE: "first-program-test" "Testing your first program"
"Your " { $snippet "palindrome.factor" } " file should look like the following after the previous section:"
{ $code
- "! Copyright (C) 2008 <your name here>"
+ "! Copyright (C) 2009 <your name here>"
"! See http://factorcode.org/license.txt for BSD license."
- "IN: palindrome"
"USING: kernel sequences ;"
+ "IN: palindrome"
""
": palindrome? ( str -- ? ) dup reverse = ;"
}
-"We will now test our new word in the listener. First we have add the palindrome vocabulary to the listener's vocabulary search path:"
-{ $code "USE: palindrome"}
+"We will now test our new word in the listener. If you haven't done so already, add the palindrome vocabulary to the listener's vocabulary search path:"
+{ $code "USE: palindrome" }
"Next, push a string on the stack:"
{ $code "\"hello\"" }
"Note that the stack display in the listener now shows this string. Having supplied the input, we call our word:"
$nl
"We will add some unit tests, which are similar to the interactive tests we did above. Unit tests are defined with the " { $link POSTPONE: unit-test } " word, which takes a sequence of expected outputs, and a piece of code. It runs the code, and asserts that it outputs the expected values."
$nl
-"Add the following three lines to " { $snippet "palindrome-tests.factor" } ":"
+"Add the following two lines to " { $snippet "palindrome-tests.factor" } ":"
{ $code
- "USING: palindrome tools.test ;"
"[ f ] [ \"hello\" palindrome? ] unit-test"
"[ t ] [ \"racecar\" palindrome? ] unit-test"
}
{ $code "\"palindrome\" test" }
"The next step is to, of course, fix our code so that the unit test can pass."
$nl
-"We begin by writing a word called " { $snippet "normalize" } " which removes blanks and non-alphabetical characters from a string, and then converts the string to lower case. We call this word " { $snippet "normalize" } ". To figure out how to write this word, we begin with some interactive experimentation in the listener."
+"We begin by writing a word which removes blanks and non-alphabetical characters from a string, and then converts the string to lower case. We call this word " { $snippet "normalize" } ". To figure out how to write this word, we begin with some interactive experimentation in the listener."
$nl
"Start by pushing a character on the stack; notice that characters are really just integers:"
{ $code "CHAR: a" }
{ $code "[ Letter? ] filter >lower" }
"This code starts with a string on the stack, removes non-alphabetical characters, and converts the result to lower case, leaving a new string on the stack. We put this code in a new word, and add the new word to " { $snippet "palindrome.factor" } ":"
{ $code ": normalize ( str -- newstr ) [ Letter? ] filter >lower ;" }
-"You will need to add " { $vocab-link "unicode.case" } " and " { $vocab-link "unicode.categories" } " to the vocabulary search path, so that " { $link Letter? } " can be used in the source file."
+"You will need to add " { $vocab-link "unicode.case" } " and " { $vocab-link "unicode.categories" } " to the vocabulary search path, so that " { $link >lower } " and " { $link Letter? } " can be used in the source file."
$nl
"We modify " { $snippet "palindrome?" } " to first apply " { $snippet "normalize" } " to its input:"
{ $code ": palindrome? ( str -- ? ) normalize dup reverse = ;" }
dup [ array? ] all? [ first ] when length ;
SYNTAX: HINTS:
- scan-object
+ scan-object dup wrapper? [ wrapped>> ] when
[ changed-definition ]
[ parse-definition { } like "specializer" set-word-prop ] bi ;
--- /dev/null
+IN: http.server.rewrite
+USING: help.syntax help.markup http.server ;
+
+HELP: rewrite
+{ $class-description "The class of directory rewrite responders. The slots are as follows:"
+{ $list
+ { { $slot "default" } " - the responder to call if no file name is provided." }
+ { { $slot "child" } " - the responder to call if a file name is provided." }
+ { { $slot "param" } " - the name of a request parameter which will store the first path component of the file name passed to the responder." }
+} } ;
+
+HELP: <rewrite>
+{ $values { "rewrite" rewrite } }
+{ $description "Creates a new " { $link rewrite } " responder." }
+{ $examples
+ { $code
+ "<rewrite>"
+ " <display-post-action> >>default"
+ " <display-comment-action> >>child"
+ " \"comment_id\" >>param"
+ }
+} ;
+
+HELP: vhost-rewrite
+{ $class-description "The class of virtual host rewrite responders. The slots are as follows:"
+{ $list
+ { { $slot "default" } " - the responder to call if no host name prefix is provided." }
+ { { $slot "child" } " - the responder to call if a host name prefix is provided." }
+ { { $slot "param" } " - the name of a request parameter which will store the first host name component of the host name passed to the responder." }
+ { { $slot "suffix" } " - the domain name suffix which will be chopped off the end of the request's host name in order to produce the parameter." }
+} } ;
+
+HELP: <vhost-rewrite>
+{ $values { "vhost-rewrite" vhost-rewrite } }
+{ $description "Creates a new " { $link vhost-rewrite } " responder." }
+{ $examples
+ { $code
+ "<vhost-rewrite>"
+ " <show-blogs-action> >>default"
+ " <display-blog-action> >>child"
+ " \"blog_id\" >>param"
+ " \"blogs.vegan.net\" >>suffix"
+ }
+} ;
+
+ARTICLE: "http.server.rewrite.overview" "Rewrite responder overview"
+"Rewrite responders take the file name and turn it into a request parameter named by the " { $slot "param" } " slot before delegating to a child responder. If a file name is provided, it calls the responder in the " { $slot "child" } " slot. If no file name is provided, they call the default responder in the " { $slot "default" } " slot."
+$nl
+"For example, suppose you want to have the following website schema:"
+{ $list
+{ { $snippet "/posts/" } " - show a list of posts" }
+{ { $snippet "/posts/factor_language" } " - show thread with ID " { $snippet "factor_language" } }
+{ { $snippet "/posts/factor_language/1" } " - show first comment in the thread with ID " { $snippet "factor_language" } }
+{ { $snippet "/animals" } ", ... - a bunch of other actions" } }
+"One way to achieve this would be to have a nesting of responders as follows:"
+{ $list
+{ "A dispatcher at the top level" }
+ { "A " { $link rewrite } " as a child of the dispatcher under the name " { $snippet "posts" } ". The rewrite has the " { $slot "param" } " slot set to, say, " { $snippet "post_id" } ". The " { $slot "default" } " slot is set to a Furnace action which displays a list of posts." }
+ { "The child slot is set to a second " { $link rewrite } " instance, with " { $snippet "param" } " set to " { $snippet "comment_id" } ", the " { $slot "default" } " slot set to an action which displays a post identified by the " { $snippet "post_id" } " parameter, and the " { $snippet "child" } " slot set to an action which displays the comment identified by the " { $snippet "comment_id" } " parameter." } }
+"Note that parameters can be extracted from the request using the " { $link param } " word, but most of the time you want to use " { $vocab-link "furnace.actions" } " instead." ;
+
+ARTICLE: "http.server.rewrite" "URL rewrite responders"
+"The " { $vocab-link "http.server.rewrite" } " vocabulary defines two responder types which can help make website URLs more human-friendly."
+{ $subsection "http.server.rewrite.overview" }
+"Directory rewrite responders:"
+{ $subsection rewrite }
+{ $subsection <rewrite> }
+"Virtual host rewrite responders -- these chop off the value in the " { $snippet "suffix" } " slot from the tail of the host name, and use the rest as the parameter value:"
+{ $subsection vhost-rewrite }
+{ $subsection <vhost-rewrite> } ;
+
+ABOUT: "http.server.rewrite"
\ No newline at end of file
--- /dev/null
+USING: accessors arrays http.server http.server.rewrite kernel
+namespaces tools.test urls ;
+IN: http.server.rewrite.tests
+
+TUPLE: rewrite-test-default ;
+
+M: rewrite-test-default call-responder*
+ drop "DEFAULT!" 2array ;
+
+TUPLE: rewrite-test-child ;
+
+M: rewrite-test-child call-responder*
+ drop "rewritten-param" param 2array ;
+
+V{ } clone responder-nesting set
+H{ } clone params set
+
+<rewrite>
+ rewrite-test-child new >>child
+ rewrite-test-default new >>default
+ "rewritten-param" >>param
+"rewrite" set
+
+[ { { } "DEFAULT!" } ] [ { } "rewrite" get call-responder ] unit-test
+[ { { } "xxx" } ] [ { "xxx" } "rewrite" get call-responder ] unit-test
+[ { { "blah" } "xxx" } ] [ { "xxx" "blah" } "rewrite" get call-responder ] unit-test
+
+<vhost-rewrite>
+ rewrite-test-child new >>child
+ rewrite-test-default new >>default
+ "rewritten-param" >>param
+ "blogs.vegan.net" >>suffix
+"rewrite" set
+
+[ { { } "DEFAULT!" } ] [
+ URL" http://blogs.vegan.net" url set
+ { } "rewrite" get call-responder
+] unit-test
+
+[ { { } "DEFAULT!" } ] [
+ URL" http://www.blogs.vegan.net" url set
+ { } "rewrite" get call-responder
+] unit-test
+
+[ { { } "erg" } ] [
+ URL" http://erg.blogs.vegan.net" url set
+ { } "rewrite" get call-responder
+] 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 http.server http.server.dispatchers kernel
+namespaces sequences splitting urls ;
+IN: http.server.rewrite
+
+TUPLE: rewrite param child default ;
+
+: <rewrite> ( -- rewrite )
+ rewrite new ;
+
+M: rewrite call-responder*
+ over empty? [ default>> ] [
+ [ [ first ] [ param>> ] bi* set-param ]
+ [ [ rest ] [ child>> ] bi* ]
+ 2bi
+ ] if
+ call-responder* ;
+
+TUPLE: vhost-rewrite suffix param child default ;
+
+: <vhost-rewrite> ( -- vhost-rewrite )
+ vhost-rewrite new ;
+
+: sub-domain? ( vhost-rewrite url -- subdomain ? )
+ swap suffix>> dup [
+ [ host>> canonical-host ] [ "." prepend ] bi* ?tail
+ ] [ 2drop f f ] if ;
+
+M: vhost-rewrite call-responder*
+ dup url get sub-domain?
+ [ over param>> set-param child>> ] [ drop default>> ] if
+ call-responder ;
-USING: help.markup help.syntax io.streams.string quotations strings urls http vocabs.refresh math io.servers.connection ;
+USING: help.markup help.syntax io.streams.string quotations strings urls
+http vocabs.refresh math io.servers.connection assocs ;
IN: http.server
HELP: trivial-responder
HELP: http-insomniac
{ $description "Starts a thread which rotates the logs and e-mails a summary of HTTP requests every 24 hours. See " { $link "logging.insomniac" } "." } ;
+HELP: request-params
+{ $values { "request" request } { "assoc" assoc } }
+{ $description "Outputs the query parameters (if the current request is a GET or HEAD request) or the POST parameters (if the current request is a POST request)." } ;
+
+HELP: param
+{ $values
+ { "name" string }
+ { "value" string }
+}
+{ $description "Outputs the value of a query parameter (if the current request is a GET or HEAD request) or a POST parameter (if the current request is a POST request)." }
+{ $notes "Instead of using this word, it is better to use " { $vocab-link "furnace.actions" } " and the associated validation machinery, which allows you to access values using " { $link "html.forms.values" } " words." } ;
+
+HELP: params
+{ $var-description "A variable holding an assoc of query parameters (if the current request is a GET or HEAD request) or POST parameters (if the current request is a POST request)." }
+{ $notes "Instead of using this word, it is better to use " { $vocab-link "furnace.actions" } " and the associated validation machinery, which allows you to access values using " { $link "html.forms.values" } " words." } ;
+
ARTICLE: "http.server.requests" "HTTP request variables"
"The following variables are set by the HTTP server at the beginning of a request."
{ $subsection request }
{ $subsection url }
{ $subsection post-request? }
{ $subsection responder-nesting }
+{ $subsection params }
+"Utility words:"
+{ $subsection param }
+{ $subsection set-param }
+{ $subsection request-params }
"Additional vocabularies may be set by vocabularies such as " { $vocab-link "html.forms" } " and " { $vocab-link "furnace.sessions" } "." ;
ARTICLE: "http.server.responders" "HTTP server responders"
USING: kernel accessors sequences arrays namespaces splitting
vocabs.loader destructors assocs debugger continuations
combinators vocabs.refresh tools.time math math.parser present
-io vectors
+vectors hashtables
+io
io.sockets
io.sockets.secure
io.encodings
: split-path ( string -- path )
"/" split harvest ;
+: request-params ( request -- assoc )
+ dup method>> {
+ { "GET" [ url>> query>> ] }
+ { "HEAD" [ url>> query>> ] }
+ { "POST" [ post-data>> params>> ] }
+ } case ;
+
+SYMBOL: params
+
+: param ( name -- value )
+ params get at ;
+
+: set-param ( value name -- )
+ params get set-at ;
+
: init-request ( request -- )
- [ request set ] [ url>> url set ] bi
+ [ request set ]
+ [ url>> url set ]
+ [ request-params >hashtable params set ] tri
V{ } clone responder-nesting set ;
: dispatch-request ( request -- response )
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
! Copyright (C) 2007, 2009 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel words summary slots quotations
+USING: accessors kernel locals words summary slots quotations
sequences assocs math arrays stack-checker effects
continuations debugger classes.tuple namespaces make vectors
bit-arrays byte-arrays strings sbufs math.functions macros
\ output>sequence 2 [ [undo] '[ dup _ assure-same-class _ input<sequence ] ] define-pop-inverse
\ input<sequence 1 [ [undo] '[ _ { } output>sequence ] ] define-pop-inverse
+! conditionals
+
+:: undo-if-empty ( result a b -- seq )
+ a call( -- b ) result = [ { } ] [ result b [undo] call( a -- b ) ] if ;
+
+:: undo-if* ( result a b -- boolean )
+ b call( -- b ) result = [ f ] [ result a [undo] call( a -- b ) ] if ;
+
+\ if-empty 2 [ swap [ undo-if-empty ] 2curry ] define-pop-inverse
+
+\ if* 2 [ swap [ undo-if* ] 2curry ] define-pop-inverse
+
! Constructor inverse
: deconstruct-pred ( class -- quot )
"predicate" word-prop [ dupd call assure ] curry ;
reverse [ [ [undo] ] dip compose ] { } assoc>map
recover-chain ;
-MACRO: switch ( quot-alist -- ) [switch] ;
+MACRO: switch ( quot-alist -- ) [switch] ;
\ No newline at end of file
[ empty-interval ] [ 2 2 (a,b) ] unit-test
+[ empty-interval ] [ 2 2.0 (a,b) ] unit-test
+
[ empty-interval ] [ 2 2 [a,b) ] unit-test
[ empty-interval ] [ 2 2 (a,b] ] unit-test
[ f ] [ 0 10 [a,b] 0 [a,a] interval< ] unit-test
+[ f ] [ 0 10 [a,b] 0.0 [a,a] interval< ] unit-test
+
+[ f ] [ 0.0 10 [a,b] 0 [a,a] interval< ] unit-test
+
[ f ] [ 0 10 [a,b] 10 [a,a] interval> ] unit-test
[ incomparable ] [ 0 [a,a] 0 10 [a,b] interval< ] unit-test
[ t ] [ 1 100 [a,b] -1 1 [a,b] interval/i [-inf,inf] = ] unit-test
+! Accuracy of interval-mod
+[ t ] [ full-interval 40 40 [a,b] interval-mod -40 40 (a,b) interval-subset?
+] unit-test
+
! Interval random tester
: random-element ( interval -- n )
dup full-interval eq? [
-! Copyright (C) 2007, 2008 Slava Pestov, Doug Coleman.
+! Copyright (C) 2007, 2009 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
! Based on Slate's src/unfinished/interval.slate by Brian Rice.
USING: accessors kernel sequences arrays math math.order
-combinators generic layouts ;
+combinators generic layouts memoize ;
IN: math.intervals
SYMBOL: empty-interval
: <interval> ( from to -- interval )
2dup [ first ] bi@ {
{ [ 2dup > ] [ 2drop 2drop empty-interval ] }
- { [ 2dup = ] [
+ { [ 2dup number= ] [
2drop 2dup [ second ] both?
[ interval boa ] [ 2drop empty-interval ] if
] }
: (a,inf] ( a -- interval ) 1/0. (a,b] ; inline
-: [0,inf] ( -- interval ) 0 [a,inf] ; foldable
+MEMO: [0,inf] ( -- interval ) 0 [a,inf] ; foldable
+
+MEMO: fixnum-interval ( -- interval )
+ most-negative-fixnum most-positive-fixnum [a,b] ; inline
: [-inf,inf] ( -- interval ) full-interval ; inline
[ 2dup [ first ] bi@ ] dip call [
2drop t
] [
- 2dup [ first ] bi@ = [
+ 2dup [ first ] bi@ number= [
[ second ] bi@ not or
] [
2drop f
] if
] if ; inline
+: endpoint= ( p1 p2 -- ? )
+ [ [ first ] bi@ number= ] [ [ second ] bi@ eq? ] 2bi and ;
+
: endpoint< ( p1 p2 -- ? ) [ < ] compare-endpoints ;
-: endpoint<= ( p1 p2 -- ? ) [ endpoint< ] 2keep = or ;
+: endpoint<= ( p1 p2 -- ? ) [ endpoint< ] [ endpoint= ] 2bi or ;
: endpoint> ( p1 p2 -- ? ) [ > ] compare-endpoints ;
-: endpoint>= ( p1 p2 -- ? ) [ endpoint> ] 2keep = or ;
+: endpoint>= ( p1 p2 -- ? ) [ endpoint> ] [ endpoint= ] 2bi or ;
: endpoint-min ( p1 p2 -- p3 ) [ endpoint< ] most ;
] [
interval>points
2dup [ second ] both?
- [ [ first ] bi@ = ]
+ [ [ first ] bi@ number= ]
[ 2drop f ] if
] if ;
[ (interval-abs) points>interval ]
} cond ;
-: interval-mod ( i1 i2 -- i3 )
- #! Inaccurate.
- [
- [
- nip interval-abs to>> first [ neg ] keep (a,b)
- ] interval-division-op
- ] do-empty-interval ;
-
-: interval-rem ( i1 i2 -- i3 )
- #! Inaccurate.
- [
- [
- nip interval-abs to>> first 0 swap [a,b)
- ] interval-division-op
- ] do-empty-interval ;
-
: interval-recip ( i1 -- i2 ) 1 [a,a] swap interval/ ;
: interval-2/ ( i1 -- i2 ) -1 [a,a] interval-shift ;
: left-endpoint-< ( i1 i2 -- ? )
[ swap interval-subset? ]
[ nip interval-singleton? ]
- [ [ from>> ] bi@ = ]
+ [ [ from>> ] bi@ endpoint= ]
2tri and and ;
: right-endpoint-< ( i1 i2 -- ? )
[ interval-subset? ]
[ drop interval-singleton? ]
- [ [ to>> ] bi@ = ]
+ [ [ to>> ] bi@ endpoint= ]
2tri and and ;
: (interval<) ( i1 i2 -- i1 i2 ? )
} cond 2nip ;
: left-endpoint-<= ( i1 i2 -- ? )
- [ from>> ] dip to>> = ;
+ [ from>> ] [ to>> ] bi* endpoint= ;
: right-endpoint-<= ( i1 i2 -- ? )
- [ to>> ] dip from>> = ;
+ [ to>> ] [ from>> ] bi* endpoint= ;
: interval<= ( i1 i2 -- ? )
{
: interval>= ( i1 i2 -- ? )
swap interval<= ;
+: interval-mod ( i1 i2 -- i3 )
+ {
+ { [ over empty-interval eq? ] [ swap ] }
+ { [ dup empty-interval eq? ] [ ] }
+ { [ dup full-interval eq? ] [ ] }
+ [ interval-abs to>> first [ neg ] keep (a,b) ]
+ } cond
+ swap 0 [a,a] interval>= t eq? [ [0,inf] interval-intersect ] when ;
+
+: (rem-range) ( i -- i' ) interval-abs to>> first 0 swap [a,b) ;
+
+: interval-rem ( i1 i2 -- i3 )
+ {
+ { [ over empty-interval eq? ] [ drop ] }
+ { [ dup empty-interval eq? ] [ nip ] }
+ { [ dup full-interval eq? ] [ nip ] }
+ [ (rem-range) 2dup interval-subset? [ drop ] [ nip ] if ]
+ } cond ;
+
+: interval->fixnum ( i1 -- i2 )
+ {
+ { [ dup empty-interval eq? ] [ ] }
+ { [ dup full-interval eq? ] [ drop fixnum-interval ] }
+ { [ dup fixnum-interval interval-subset? not ] [ drop fixnum-interval ] }
+ [ ]
+ } cond ;
+
: interval-bitand-pos ( i1 i2 -- ? )
[ to>> first ] bi@ min 0 swap [a,b] ;
--- /dev/null
+IN: math.vectors.specialization.tests
+USING: compiler.tree.debugger math.vectors tools.test kernel
+kernel.private math specialized-arrays.double
+specialized-arrays.complex-float
+specialized-arrays.float ;
+
+[ V{ t } ] [
+ [ { double-array double-array } declare distance 0.0 < not ] final-literals
+] unit-test
+
+[ V{ float } ] [
+ [ { float-array float } declare v*n norm ] final-classes
+] unit-test
+
+[ V{ number } ] [
+ [ { complex-float-array complex-float-array } declare v. ] final-classes
+] unit-test
+
+[ V{ real } ] [
+ [ { complex-float-array complex } declare v*n norm ] final-classes
+] 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: words kernel make sequences effects kernel.private accessors
+combinators math math.intervals math.vectors namespaces assocs fry
+splitting classes.algebra generalizations
+compiler.tree.propagation.info ;
+IN: math.vectors.specialization
+
+SYMBOLS: -> +vector+ +scalar+ +nonnegative+ ;
+
+: signature-for-schema ( array-type elt-type schema -- signature )
+ [
+ {
+ { +vector+ [ drop ] }
+ { +scalar+ [ nip ] }
+ { +nonnegative+ [ nip ] }
+ } case
+ ] with with map ;
+
+: (specialize-vector-word) ( word array-type elt-type schema -- word' )
+ signature-for-schema
+ [ [ name>> ] [ [ name>> ] map "," join ] bi* "=>" glue f <word> ]
+ [ [ , \ declare , def>> % ] [ ] make ]
+ [ drop stack-effect ]
+ 2tri
+ [ define-declared ] [ 2drop ] 3bi ;
+
+: output-infos ( array-type elt-type schema -- value-infos )
+ [
+ {
+ { +vector+ [ drop <class-info> ] }
+ { +scalar+ [ nip <class-info> ] }
+ { +nonnegative+ [ nip real class-and [0,inf] <class/interval-info> ] }
+ } case
+ ] with with map ;
+
+: record-output-signature ( word array-type elt-type schema -- word )
+ output-infos
+ [ drop ]
+ [ drop ]
+ [ [ stack-effect in>> length '[ _ ndrop ] ] dip append ] 2tri
+ "outputs" set-word-prop ;
+
+CONSTANT: vector-words
+H{
+ { [v-] { +vector+ +vector+ -> +vector+ } }
+ { distance { +vector+ +vector+ -> +nonnegative+ } }
+ { n*v { +scalar+ +vector+ -> +vector+ } }
+ { n+v { +scalar+ +vector+ -> +vector+ } }
+ { n-v { +scalar+ +vector+ -> +vector+ } }
+ { n/v { +scalar+ +vector+ -> +vector+ } }
+ { norm { +vector+ -> +nonnegative+ } }
+ { norm-sq { +vector+ -> +nonnegative+ } }
+ { normalize { +vector+ -> +vector+ } }
+ { v* { +vector+ +vector+ -> +vector+ } }
+ { v*n { +vector+ +scalar+ -> +vector+ } }
+ { v+ { +vector+ +vector+ -> +vector+ } }
+ { v+n { +vector+ +scalar+ -> +vector+ } }
+ { v- { +vector+ +vector+ -> +vector+ } }
+ { v-n { +vector+ +scalar+ -> +vector+ } }
+ { v. { +vector+ +vector+ -> +scalar+ } }
+ { v/ { +vector+ +vector+ -> +vector+ } }
+ { v/n { +vector+ +scalar+ -> +vector+ } }
+ { vceiling { +vector+ -> +vector+ } }
+ { vfloor { +vector+ -> +vector+ } }
+ { vmax { +vector+ +vector+ -> +vector+ } }
+ { vmin { +vector+ +vector+ -> +vector+ } }
+ { vneg { +vector+ -> +vector+ } }
+ { vtruncate { +vector+ -> +vector+ } }
+}
+
+SYMBOL: specializations
+
+specializations [ vector-words keys [ V{ } clone ] H{ } map>assoc ] initialize
+
+: add-specialization ( new-word signature word -- )
+ specializations get at set-at ;
+
+: word-schema ( word -- schema ) vector-words at ;
+
+: inputs ( schema -- seq ) { -> } split first ;
+
+: outputs ( schema -- seq ) { -> } split second ;
+
+: specialize-vector-word ( word array-type elt-type -- word' )
+ pick word-schema
+ [ inputs (specialize-vector-word) ]
+ [ outputs record-output-signature ] 3bi ;
+
+: input-signature ( word -- signature ) def>> first ;
+
+: specialize-vector-words ( array-type elt-type -- )
+ [ vector-words keys ] 2dip
+ '[
+ [ _ _ specialize-vector-word ] keep
+ [ dup input-signature ] dip
+ add-specialization
+ ] each ;
+
+: find-specialization ( classes word -- word/f )
+ specializations get at
+ [ first [ class<= ] 2all? ] with find
+ swap [ second ] when ;
+
+: vector-word-custom-inlining ( #call -- word/f )
+ [ in-d>> [ value-info class>> ] map ] [ word>> ] bi
+ find-specialization ;
+
+vector-words keys [
+ [ vector-word-custom-inlining ]
+ "custom-inlining" set-word-prop
+] each
\ No newline at end of file
: set-axis ( u v axis -- w )
[ [ zero? 2over ? ] dip swap nth ] map-index 2nip ;
+<PRIVATE
+
: 2tetra@ ( p q r s t u v w quot -- )
dup [ [ 2bi@ ] curry 4dip ] dip 2bi@ ; inline
+PRIVATE>
+
: trilerp ( aaa baa aba bba aab bab abb bbb {t,u,v} -- a_tuv )
[ first lerp ] [ second lerp ] [ third lerp ] tri-curry
[ 2tetra@ ] [ 2bi@ ] [ call ] tri* ;
--- /dev/null
+Sam Anklesaria
\ No newline at end of file
--- /dev/null
+USING: accessors models models.arrow inverse kernel ;
+IN: models.illusion
+
+TUPLE: illusion < arrow ;
+
+: <illusion> ( model quot -- illusion )
+ illusion new V{ } clone >>connections V{ } clone >>dependencies 0 >>ref
+ swap >>quot over >>model [ add-dependency ] keep ;
+
+: <activated-illusion> ( model quot -- illusion ) <illusion> dup activate-model ;
+
+: backtalk ( value object -- )
+ [ quot>> [undo] call( a -- b ) ] [ model>> ] bi set-model ;
+
+M: illusion update-model ( model -- ) [ [ value>> ] keep backtalk ] with-locked-model ;
\ No newline at end of file
--- /dev/null
+Two Way Arrows
\ No newline at end of file
HINTS: (double-array) { 2 } { 3 } ;
-HINTS: vneg { array } { double-array } ;
-HINTS: v*n { array object } { double-array float } ;
-HINTS: n*v { array object } { float double-array } ;
-HINTS: v/n { array object } { double-array float } ;
-HINTS: n/v { object array } { float double-array } ;
-HINTS: v+ { array array } { double-array double-array } ;
-HINTS: v- { array array } { double-array double-array } ;
-HINTS: v* { array array } { double-array double-array } ;
-HINTS: v/ { array array } { double-array double-array } ;
-HINTS: vmax { array array } { double-array double-array } ;
-HINTS: vmin { array array } { double-array double-array } ;
-HINTS: v. { array array } { double-array double-array } ;
-HINTS: norm-sq { array } { double-array } ;
-HINTS: norm { array } { double-array } ;
-HINTS: normalize { array } { double-array } ;
-HINTS: distance { array array } { double-array double-array } ;
-
! Type functions
USING: words classes.algebra compiler.tree.propagation.info
math.intervals ;
-{ v+ v- v* v/ vmax vmin } [
- [
- [ class>> double-array class<= ] both?
- double-array object ? <class-info>
- ] "outputs" set-word-prop
-] each
-
-{ n*v n/v } [
- [
- nip class>> double-array class<= double-array object ? <class-info>
- ] "outputs" set-word-prop
-] each
-
-{ v*n v/n } [
- [
- drop class>> double-array class<= double-array object ? <class-info>
- ] "outputs" set-word-prop
-] each
-
-{ vneg normalize } [
- [
- class>> double-array class<= double-array object ? <class-info>
- ] "outputs" set-word-prop
-] each
-
\ norm-sq [
class>> double-array class<= [ float 0. 1/0. [a,b] <class/interval-info> ] [ object-info ] if
] "outputs" set-word-prop
-\ v. [
- [ class>> double-array class<= ] both?
- float object ? <class-info>
-] "outputs" set-word-prop
-
\ distance [
[ class>> double-array class<= ] both?
[ float 0. 1/0. [a,b] <class/interval-info> ] [ object-info ] if
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: functors sequences sequences.private prettyprint.custom
-kernel words classes math parser alien.c-types byte-arrays
-accessors summary ;
+kernel words classes math math.vectors.specialization parser
+alien.c-types byte-arrays accessors summary ;
IN: specialized-arrays.functor
ERROR: bad-byte-array-length byte-array type ;
INSTANCE: A sequence
+A T c-type-boxed-class specialize-vector-words
+
;FUNCTOR
drop
[ downward-slices ]
[ stable-slices ]
- [ upward-slices ] tri 3append [ [ from>> ] compare ] sort
+ [ upward-slices ] tri 3append [ from>> ] sort-with
]
} case ;
+++ /dev/null
-
-: 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-float@ ( n -- offset )
- double-float-regs reg-size * param@ ;
-
-: (stack-frame-size) ( stack-frame -- n )
- [
- {
- [ spill-counts>> [ swap reg-size * ] { } assoc>map sum ]
- [ gc-roots>> cells ]
- [ params>> ]
- [ return>> ]
- } cleave
- ] sum-outputs ;
\ No newline at end of file
{ } { "math.partial-dispatch" } strip-vocab-globals %
+ { } { "math.vectors.specialization" } strip-vocab-globals %
+
{ } { "peg" } strip-vocab-globals %
] when
CONSTANT: +listener-input+ "<Listener input>"
-M: source-file-error summary
+: error-location ( error -- string )
[
- [ file>> [ % ": " % ] [ +listener-input+ % ] if* ]
- [ line#>> [ # ] when* ] bi
+ [ file>> [ % ] [ +listener-input+ % ] if* ]
+ [ line#>> [ ": " % # ] when* ] bi
] "" make ;
+M: source-file-error summary error>> summary ;
+
M: source-file-error error.
- [ summary print nl ]
+ [ error-location print nl ]
[ asset>> [ "Asset: " write short. nl ] when* ]
[ error>> error. ]
tri ;
'[ _ ndup _ narray _ prefix ] ;
: experiment. ( seq -- )
- [ first write ": " write ] [ rest . ] bi ;
+ [ first write ": " write ] [ rest . flush ] bi ;
:: experiment ( word: ( -- error ? ) line# -- )
word <experiment> :> e
M: test-failure error. ( error -- )
{
- [ summary print nl ]
+ [ error-location print nl ]
[ asset>> [ experiment. nl ] when* ]
[ error>> error. ]
[ traceback-button. ]
: <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 -- )
column-line-color
selection-required?
single-click?
-selected-value
+selection
min-rows
min-cols
max-rows
{ $subsection column-titles } ;
ARTICLE: "ui.gadgets.tables.selection" "Table row selection"
-"At any given time, a single row in the table may be selected."
-$nl
"A few slots in the table gadget concern row selection:"
{ $table
- { { $slot "selected-value" } { " - if set to a model, the currently selected row's value, as determined by a " { $link row-value } " call to the renderer, is stored in this model. See " { $link "models" } "." } }
- { { $slot "selected-index" } " - the index of the currently selected row." }
+ { { $slot "selection" } { " - if set to a model, the values of the currently selected row or rows, as determined by a " { $link row-value } " call to the renderer, is stored in this model. See " { $link "models" } "." } }
+ { { $slot "selection-index" } { " - if set to a model, the indices of the currently selected rows." } }
{ { $slot "selection-required?" } { " - if set to a true value, the table ensures that some row is always selected, if the model is non-empty. If set to " { $link f } ", a state where nothing is selected is permitted to occur. The default is " { $link f } "." } }
+ { { $slot "multiple-selection?" } { " - if set to a true value, users are allowed to select more than one value." } }
}
"Some words for row selection:"
-{ $subsection selected-row }
-{ $subsection (selected-row) } ;
+{ $subsection selected-rows }
+{ $subsection (selected-rows) }
+{ $subsection selected } ;
ARTICLE: "ui.gadgets.tables.actions" "Table row actions"
"When the user double-clicks on a row, or presses " { $command table "row" row-action } " while a row is selected, optional action and hook quotations are invoked. The action receives the row value and the hook receives the table gadget itself. These quotations are stored in the " { $slot "action" } " and " { $snippet "hook" } " slots of a table, respectively."
IN: ui.gadgets.tables.tests
USING: ui.gadgets.tables ui.gadgets.scrollers ui.gadgets.debug accessors
-models namespaces tools.test kernel combinators ;
+models namespaces tools.test kernel combinators prettyprint arrays ;
SINGLETON: test-renderer
[ selected-row drop ]
} cleave
] with-grafted-gadget
-] unit-test
\ No newline at end of file
+] unit-test
+
+SINGLETON: silly-renderer
+
+M: silly-renderer row-columns drop unparse 1array ;
+
+M: silly-renderer column-titles drop { "Foo" } ;
+
+: test-table-2 ( -- table )
+ { 1 2 f } <model> silly-renderer <table> ;
+
+[ f f ] [
+ test-table dup [
+ selected-row
+ ] with-grafted-gadget
+] unit-test
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays colors colors.constants fry kernel math
-math.functions math.rectangles math.order math.vectors namespaces
-opengl sequences ui.gadgets ui.gadgets.scrollers ui.gadgets.status-bar
-ui.gadgets.worlds ui.gestures ui.render ui.pens.solid ui.text
-ui.commands ui.images ui.gadgets.menus ui.gadgets.line-support
-models math.ranges combinators
-combinators.short-circuit fonts locals strings ;
+USING: accessors assocs hashtables arrays colors colors.constants fry
+kernel math math.functions math.ranges math.rectangles math.order
+math.vectors namespaces opengl sequences ui.gadgets
+ui.gadgets.scrollers ui.gadgets.status-bar ui.gadgets.worlds
+ui.gestures ui.render ui.pens.solid ui.text ui.commands ui.images
+ui.gadgets.menus ui.gadgets.line-support models combinators
+combinators.short-circuit fonts locals strings sets sorting ;
IN: ui.gadgets.tables
! Row rendererer protocol
{ mouse-color initial: COLOR: black }
column-line-color
selection-required?
-selected-index selected-value
+selection
+selection-index
+selected-indices
mouse-index
{ takes-focus? initial: t }
-focused? ;
+focused?
+multiple-selection? ;
+
+<PRIVATE
+
+: add-selected-index ( table n -- table )
+ over selected-indices>> conjoin ;
+
+: multiple>single ( values -- value/f ? )
+ dup assoc-empty? [ drop f f ] [ values first t ] if ;
+
+: selected-index ( table -- n )
+ selected-indices>> multiple>single drop ;
+
+: set-selected-index ( table n -- table )
+ dup associate >>selected-indices ;
+
+PRIVATE>
+
+: selected ( table -- index/indices )
+ [ selected-indices>> ] [ multiple-selection?>> ] bi
+ [ multiple>single drop ] unless ;
: new-table ( rows renderer class -- table )
new-line-gadget
swap >>renderer
swap >>model
- f <model> >>selected-value
sans-serif-font >>font
focus-border-color >>focus-border-color
- transparent >>column-line-color ; inline
+ transparent >>column-line-color
+ f <model> >>selection-index
+ f <model> >>selection
+ H{ } clone >>selected-indices ;
: <table> ( rows renderer -- table ) table new-table ;
: row-bounds ( table row -- loc dim )
row-rect rect-bounds ; inline
-: draw-selected-row ( table -- )
+: draw-selected-rows ( table -- )
{
- { [ dup selected-index>> not ] [ drop ] }
+ { [ dup selected-indices>> assoc-empty? ] [ drop ] }
[
- [ ] [ selected-index>> ] [ selection-color>> gl-color ] tri
- row-bounds gl-fill-rect
+ [ selected-indices>> keys ] [ selection-color>> gl-color ] [ ] tri
+ [ swap row-bounds gl-fill-rect ] curry each
]
} cond ;
: draw-focused-row ( table -- )
{
{ [ dup focused?>> not ] [ drop ] }
- { [ dup selected-index>> not ] [ drop ] }
+ { [ dup selected-index not ] [ drop ] }
[
- [ ] [ selected-index>> ] [ focus-border-color>> gl-color ] tri
+ [ ] [ selected-index ] [ focus-border-color>> gl-color ] tri
row-bounds gl-rect
]
} cond ;
dup renderer>> column-alignment
[ ] [ column-widths>> length 0 <repetition> ] ?if ;
-:: row-font ( row index table -- font )
+:: row-font ( row ind table -- font )
table font>> clone
row table renderer>> row-color [ >>foreground ] when*
- index table selected-index>> = [ table selection-color>> >>background ] when ;
+ ind table selected-indices>> key?
+ [ table selection-color>> >>background ] when ;
: draw-columns ( columns widths alignment font gap -- )
'[ [ _ ] 3dip _ draw-column ] 3each ;
dup control-value empty? [ drop ] [
dup line-height \ line-height [
{
- [ draw-selected-row ]
+ [ draw-selected-rows ]
[ draw-lines ]
[ draw-column-lines ]
[ draw-focused-row ]
PRIVATE>
-: (selected-row) ( table -- value/f ? )
- [ selected-index>> ] keep nth-row ;
+: (selected-rows) ( table -- assoc )
+ [ selected-indices>> ] keep
+ '[ _ nth-row drop ] assoc-map ;
+
+: selected-rows ( table -- assoc )
+ [ selected-indices>> ] [ ] [ renderer>> ] tri
+ '[ _ nth-row drop _ row-value ] assoc-map ;
-: selected-row ( table -- value/f ? )
- [ (selected-row) ] keep
- swap [ renderer>> row-value t ] [ 2drop f f ] if ;
+: (selected-row) ( table -- value/f ? ) (selected-rows) multiple>single ;
+
+: selected-row ( table -- value/f ? ) selected-rows multiple>single ;
<PRIVATE
-: update-selected-value ( table -- )
- [ selected-row drop ] [ selected-value>> ] bi set-model ;
+: set-table-model ( model value multiple? -- )
+ [ values ] [ multiple>single drop ] if swap set-model ;
+
+: update-selected ( table -- )
+ [
+ [ selection>> ]
+ [ selected-rows ]
+ [ multiple-selection?>> ] tri
+ set-table-model
+ ]
+ [
+ [ selection-index>> ]
+ [ selected-indices>> ]
+ [ multiple-selection?>> ] tri
+ set-table-model
+ ] bi ;
: show-row-summary ( table n -- )
over nth-row
f >>mouse-index [ hide-status ] [ relayout-1 ] bi ;
: find-row-index ( value table -- n/f )
- [ model>> value>> ] [ renderer>> '[ _ row-value ] map index ] bi ;
+ [ model>> value>> ] [ renderer>> ] bi
+ '[ _ row-value eq? ] with find drop ;
+
+: (update-selected-indices) ( table -- set )
+ [ selection>> value>> dup [ array? not ] [ ] bi and [ 1array ] when ] keep
+ '[ _ find-row-index ] map sift unique f assoc-like ;
-: initial-selected-index ( table -- n/f )
+: initial-selected-indices ( table -- set )
{
[ model>> value>> empty? not ]
[ selection-required?>> ]
- [ drop 0 ]
+ [ drop { 0 } unique ]
} 1&& ;
-: (update-selected-index) ( table -- n/f )
- [ selected-value>> value>> ] keep over
- [ find-row-index ] [ 2drop f ] if ;
-
-: update-selected-index ( table -- n/f )
+: update-selected-indices ( table -- set )
{
- [ (update-selected-index) ]
- [ initial-selected-index ]
+ [ (update-selected-indices) ]
+ [ initial-selected-indices ]
} 1|| ;
M: table model-changed
- nip dup update-selected-index {
- [ >>selected-index f >>mouse-index drop ]
- [ show-row-summary ]
- [ drop update-selected-value ]
+ nip dup update-selected-indices {
+ [ >>selected-indices f >>mouse-index drop ]
+ [ multiple>single drop show-row-summary ]
+ [ drop update-selected ]
[ drop relayout ]
} 2cleave ;
: thin-row-rect ( table row -- rect )
row-rect [ { 0 1 } v* ] change-dim ;
+: scroll-to-row ( table n -- )
+ dup [ [ thin-row-rect ] [ drop ] 2bi scroll>rect ] [ 2drop ] if ;
+
+: add-selected-row ( table n -- )
+ [ scroll-to-row ]
+ [ add-selected-index relayout-1 ] 2bi ;
+
: (select-row) ( table n -- )
- [ dup [ [ thin-row-rect ] [ drop ] 2bi scroll>rect ] [ 2drop ] if ]
- [ >>selected-index relayout-1 ]
+ [ scroll-to-row ]
+ [ set-selected-index relayout-1 ]
2bi ;
: mouse-row ( table -- n )
[ hand-rel second ] keep y>line ;
-: if-mouse-row ( table true: ( table mouse-index -- ) false: ( table -- ) -- )
+: if-mouse-row ( table true: ( mouse-index table -- ) false: ( table -- ) -- )
[ [ mouse-row ] keep 2dup valid-line? ]
[ ] [ '[ nip @ ] ] tri* if ; inline
+: (table-button-down) ( quot table -- )
+ dup takes-focus?>> [ dup request-focus ] when swap
+ '[ swap [ >>mouse-index ] _ bi ] [ drop ] if-mouse-row ; inline
+
: table-button-down ( table -- )
- dup takes-focus?>> [ dup request-focus ] when
- [ swap [ >>mouse-index ] [ (select-row) ] bi ] [ drop ] if-mouse-row ;
+ [ (select-row) ] swap (table-button-down) ;
+
+: continued-button-down ( table -- )
+ dup multiple-selection?>>
+ [ [ add-selected-row ] swap (table-button-down) ] [ table-button-down ] if ;
+
+: thru-button-down ( table -- )
+ dup multiple-selection?>> [
+ [ 2dup over selected-index (a,b) swap
+ [ swap add-selected-index drop ] curry each add-selected-row ]
+ swap (table-button-down)
+ ] [ table-button-down ] if ;
PRIVATE>
: table-button-up ( table -- )
dup [ mouse-row ] keep valid-line? [
- dup row-action? [ row-action ] [ update-selected-value ] if
+ dup row-action? [ row-action ] [ update-selected ] if
] [ drop ] if ;
PRIVATE>
: select-row ( table n -- )
over validate-line
[ (select-row) ]
- [ drop update-selected-value ]
+ [ drop update-selected ]
[ show-row-summary ]
2tri ;
<PRIVATE
: prev/next-row ( table n -- )
- [ dup selected-index>> ] dip '[ _ + ] [ 0 ] if* select-row ;
+ [ dup selected-index ] dip '[ _ + ] [ 0 ] if* select-row ;
: previous-row ( table -- )
-1 prev/next-row ;
{ mouse-enter show-mouse-help }
{ mouse-leave hide-mouse-help }
{ motion show-mouse-help }
- { T{ button-down } table-button-down }
+ { T{ button-down f { S+ } 1 } thru-button-down }
+ { T{ button-down f { A+ } 1 } continued-button-down }
{ T{ button-up } table-button-up }
+ { T{ button-up f { S+ } } table-button-up }
+ { T{ button-down } table-button-down }
{ gain-focus focus-table }
{ lose-focus unfocus-table }
{ T{ drag } table-button-down }
: com-help ( debugger -- ) error>> error-help-window ;
-: com-edit ( debugger -- ) error>> (:edit) ;
+: com-edit ( debugger -- ) error>> edit-error ;
\ com-edit H{ { +listener+ t } } define-command
60 >>min-cols
60 >>max-cols
t >>selection-required?
- error-list source-file>> >>selected-value ;
+ error-list source-file>> >>selection ;
SINGLETON: error-renderer
60 >>min-cols
60 >>max-cols
t >>selection-required?
- error-list error>> >>selected-value ;
+ error-list error>> >>selection ;
TUPLE: error-display < track ;
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>
horizontal <track>
{ 3 3 } >>gap
profiler vocabs>> vocab-renderer <profiler-table>
- profiler vocab>> >>selected-value
+ profiler vocab>> >>selection
10 >>min-rows
10 >>max-rows
"Vocabularies" <labeled-gadget>
horizontal <track>
{ 3 3 } >>gap
profiler <generic-model> word-renderer <profiler-table>
- profiler generic>> >>selected-value
+ profiler generic>> >>selection
"Generic words" <labeled-gadget>
1/2 track-add
profiler <class-model> word-renderer <profiler-table>
- profiler class>> >>selected-value
+ profiler class>> >>selection
"Classes" <labeled-gadget>
1/2 track-add
1/2 track-add
PRIVATE>\r
\r
: (load) ( prefix -- failures )\r
- child-vocabs-recursive no-roots no-prefixes\r
+ [ child-vocabs-recursive no-roots no-prefixes ]\r
+ [ dup find-vocab-root [ >vocab-link prefix ] [ drop ] if ] bi\r
filter-unportable\r
require-all ;\r
\r
<PRIVATE
: sort-vocabs ( seq -- seq' )
- [ [ vocab-name ] compare ] sort ;
+ [ vocab-name ] sort-with ;
: pprint-using ( seq -- )
[ "syntax" vocab = not ] filter
{ "set-retainstack" "kernel" (( rs -- )) }
{ "set-callstack" "kernel" (( cs -- )) }
{ "exit" "system" (( n -- )) }
- { "data-room" "memory" (( -- cards generations )) }
- { "code-room" "memory" (( -- code-free code-total )) }
+ { "data-room" "memory" (( -- cards decks generations )) }
+ { "code-room" "memory" (( -- code-total code-used code-free largest-free-block )) }
{ "micros" "system" (( -- us )) }
{ "modify-code-heap" "compiler.units" (( alist -- )) }
{ "(dlopen)" "alien.libraries" (( path -- dll )) }
[ 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
[ swap classes-intersect? ]
} cond ;
-M: anonymous-intersection (flatten-class)
- participants>> [ flatten-builtin-class ] map
- [
- builtins get sift [ (flatten-class) ] each
- ] [
- [ ] [ assoc-intersect ] map-reduce [ swap set ] assoc-each
- ] if-empty ;
-
-M: anonymous-complement (flatten-class)
- drop builtins get sift [ (flatten-class) ] each ;
+: full-cover ( -- ) builtins get sift [ (flatten-class) ] each ;
+
+M: anonymous-complement (flatten-class) drop full-cover ;
"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 ;
--- /dev/null
+USING: kernel tools.test generic generic.standard ;
+IN: classes.intersection.tests
+
+TUPLE: a ;
+TUPLE: a1 < a ; TUPLE: a2 < a ; TUPLE: a3 < a2 ;
+MIXIN: b
+INSTANCE: a3 b
+INSTANCE: a1 b
+INTERSECTION: c a2 b ;
+
+GENERIC: x ( a -- b )
+
+M: c x drop c ;
+M: a x drop a ;
+
+[ a ] [ T{ a } x ] unit-test
+[ a ] [ T{ a1 } x ] unit-test
+[ a ] [ T{ a2 } x ] unit-test
+
+[ t ] [ T{ a3 } c? ] unit-test
+[ t ] [ T{ a3 } \ x effective-method M\ c x eq? nip ] unit-test
+[ c ] [ T{ a3 } x ] unit-test
+
+! More complex case
+TUPLE: t1 ;
+TUPLE: t2 < t1 ; TUPLE: t3 < t1 ;
+TUPLE: t4 < t2 ; TUPLE: t5 < t2 ;
+
+UNION: m t4 t5 t3 ;
+INTERSECTION: i t2 m ;
+
+GENERIC: g ( a -- b )
+
+M: i g drop i ;
+M: t4 g drop t4 ;
+
+[ t4 ] [ T{ t4 } g ] unit-test
+[ i ] [ T{ t5 } g ] unit-test
\ No newline at end of file
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: words sequences kernel assocs combinators classes
+USING: words accessors sequences kernel assocs combinators classes
classes.algebra classes.builtin namespaces arrays math quotations ;
IN: classes.intersection
M: intersection-class (flatten-class)
participants <anonymous-intersection> (flatten-class) ;
+
+! Horribly inefficient and inaccurate
+: intersect-flattened-classes ( seq1 seq2 -- seq3 )
+ ! Only keep those in seq1 that intersect something in seq2.
+ [ [ classes-intersect? ] with any? ] curry filter ;
+
+M: anonymous-intersection (flatten-class)
+ participants>> [ full-cover ] [
+ [ flatten-class keys ]
+ [ intersect-flattened-classes ] map-reduce
+ [ dup set ] each
+ ] if-empty ;
PREDICATE: tuple-c < tuple-b slot>> ;
-GENERIC: ptest ( tuple -- )
-M: tuple-a ptest drop ;
-M: tuple-c ptest drop ;
+GENERIC: ptest ( tuple -- x )
+M: tuple-a ptest drop tuple-a ;
+M: tuple-c ptest drop tuple-c ;
-[ ] [ tuple-b new ptest ] unit-test
+[ tuple-a ] [ tuple-b new ptest ] unit-test
+[ tuple-c ] [ tuple-b new t >>slot ptest ] unit-test
+
+PREDICATE: tuple-d < tuple-a slot>> ;
+
+GENERIC: ptest' ( tuple -- x )
+M: tuple-a ptest' drop tuple-a ;
+M: tuple-d ptest' drop tuple-d ;
+
+[ tuple-a ] [ tuple-b new ptest' ] unit-test
+[ tuple-d ] [ tuple-b new t >>slot ptest' ] unit-test
{ 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
HELP: with-destructors
{ $values { "quot" "a quotation" } }
-{ $description "Calls a quotation within a new dynamic scope. This quotation may register destructors using " { $link &dispose } " or " { $link |dispose } ". The former registers a destructor that will always run whether or not the quotation threw an error, and the latter registers a destructor that only runs if the quotation throws an error only. Destructors are run in reverse order from the order in which they were registered." }
+{ $description "Calls a quotation within a new dynamic scope. This quotation may register destructors using " { $link &dispose } " or " { $link |dispose } ". The former registers a destructor that will always run whether or not the quotation threw an error, and the latter registers a destructor that only runs if the quotation throws an error. Destructors are run in reverse order from the order in which they were registered." }
{ $notes
"Destructors generalize " { $link with-disposal } ". The following two lines are equivalent, except that the second line establishes a new dynamic scope:"
{ $code
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 )
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences accessors namespaces math words strings
-io vectors arrays math.parser combinators continuations ;
+io vectors arrays math.parser combinators continuations
+source-files.errors ;
IN: lexer
TUPLE: lexer text line line-text line-length column ;
ERROR: unexpected want got ;
-PREDICATE: unexpected-tab < unexpected
- got>> CHAR: \t = ;
-
: forbid-tab ( c -- c )
- [ CHAR: \t eq? [ "[space]" "[tab]" unexpected ] when ] keep ;
+ [ CHAR: \t eq? [ "[space]" "[tab]" unexpected ] when ] keep ; inline
: skip ( i seq ? -- n )
over length
TUPLE: lexer-error line column line-text error ;
+M: lexer-error error-file error>> error-file ;
+M: lexer-error error-line [ error>> error-line ] [ line>> ] bi or ;
+
: <lexer-error> ( msg -- error )
\ lexer-error new
lexer get
: make ( quot exemplar -- seq )
[
[
- 1024 swap new-resizable [
+ 100 swap new-resizable [
building set call
] keep
] keep like
HELP: gc ( -- )
{ $description "Performs a full garbage collection." } ;
-HELP: data-room ( -- cards generations )
-{ $values { "cards" "number of bytes reserved for card marking" } { "generations" "array of free/total bytes pairs" } }
+HELP: data-room ( -- cards decks generations )
+{ $values { "cards" "number of kilobytes reserved for card marking" } { "decks" "number of kilobytes reserved for decks of cards" } { "generations" "array of free/total kilobytes pairs" } }
{ $description "Queries the runtime for memory usage information." } ;
-HELP: code-room ( -- code-free code-total )
-{ $values { "code-free" "bytes free in the code heap" } { "code-total" "total bytes in the code heap" } }
+HELP: code-room ( -- code-total code-used code-free largest-free-block )
+{ $values { "code-total" "total kilobytes in the code heap" } { "code-used" "kilobytes used in the code heap" } { "code-free" "kilobytes free in the code heap" } { "largest-free-block" "size of largest free block" } }
{ $description "Queries the runtime for memory usage information." } ;
HELP: size ( obj -- n )
: reduce ( seq identity quot -- result )
swapd each ; inline
+: map-integers ( len quot exemplar -- newseq )
+ [ over ] dip [ [ collect ] keep ] new-like ; inline
+
: map-as ( seq quot exemplar -- newseq )
- [ over length ] dip [ [ map-into ] keep ] new-like ; inline
+ [ (each) ] dip map-integers ; inline
: map ( seq quot -- newseq )
over map-as ; inline
[ -rot ] dip 2each ; inline
: 2map-as ( seq1 seq2 quot exemplar -- newseq )
- [ (2each) ] dip map-as ; inline
+ [ (2each) ] dip map-integers ; inline
: 2map ( seq1 seq2 quot -- newseq )
pick 2map-as ; inline
(3each) each ; inline
: 3map-as ( seq1 seq2 seq3 quot exemplar -- newseq )
- [ (3each) ] dip map-as ; inline
+ [ (3each) ] dip map-integers ; inline
: 3map ( seq1 seq2 seq3 quot -- newseq )
[ pick ] dip swap 3map-as ; inline
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 ;
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs kernel math.order sorting sequences definitions
-namespaces arrays splitting io math.parser math init ;
+namespaces arrays splitting io math.parser math init continuations ;
IN: source-files.errors
+GENERIC: error-file ( error -- file )
+GENERIC: error-line ( error -- line )
+
+M: object error-file drop f ;
+M: object error-line drop f ;
+
+M: condition error-file error>> error-file ;
+M: condition error-line error>> error-line ;
+
TUPLE: source-file-error error asset file line# ;
+M: source-file-error error-file [ error>> error-file ] [ file>> ] bi or ;
+M: source-file-error error-line [ error>> error-line ] [ line#>> ] bi or ;
+
: 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 ( -- )
M: sphere intersect-scene ( hit ray sphere -- hit )
[ [ sphere-n normalize ] keep <hit> nip ] if-ray-sphere ;
+HINTS: M\ sphere intersect-scene { hit ray sphere } ;
+
TUPLE: group < sphere { objs array read-only } ;
: <group> ( objs bound -- group )
M: group intersect-scene ( hit ray group -- hit )
[ drop objs>> [ intersect-scene ] with each ] if-ray-sphere ;
+HINTS: M\ group intersect-scene { hit ray group } ;
+
CONSTANT: initial-hit T{ hit f double-array{ 0.0 0.0 0.0 } 1/0. }
: initial-intersect ( ray scene -- hit )
--- /dev/null
+! Copyright (C) Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.accessors alien.c-types alien.syntax byte-arrays
+destructors generalizations hints kernel libc locals math math.order
+sequences sequences.private ;
+IN: benchmark.yuv-to-rgb
+
+C-STRUCT: yuv_buffer
+ { "int" "y_width" }
+ { "int" "y_height" }
+ { "int" "y_stride" }
+ { "int" "uv_width" }
+ { "int" "uv_height" }
+ { "int" "uv_stride" }
+ { "void*" "y" }
+ { "void*" "u" }
+ { "void*" "v" } ;
+
+:: fake-data ( -- rgb yuv )
+ [let* | w [ 1600 ]
+ h [ 1200 ]
+ buffer [ "yuv_buffer" <c-object> ]
+ rgb [ w h * 3 * <byte-array> ] |
+ w buffer set-yuv_buffer-y_width
+ h buffer set-yuv_buffer-y_height
+ h buffer set-yuv_buffer-uv_height
+ w buffer set-yuv_buffer-y_stride
+ w buffer set-yuv_buffer-uv_stride
+ w h * [ dup * ] B{ } map-as malloc-byte-array &free buffer set-yuv_buffer-y
+ w h * 2/ [ dup dup * * ] B{ } map-as malloc-byte-array &free buffer set-yuv_buffer-u
+ w h * 2/ [ dup * dup * ] B{ } map-as malloc-byte-array &free buffer set-yuv_buffer-v
+ rgb buffer
+ ] ;
+
+: clamp ( n -- n )
+ 255 min 0 max ; inline
+
+: stride ( line yuv -- uvy yy )
+ [ yuv_buffer-uv_stride swap 2/ * >fixnum ]
+ [ yuv_buffer-y_stride * >fixnum ] 2bi ; inline
+
+: compute-y ( yuv uvy yy x -- y )
+ + >fixnum nip swap yuv_buffer-y swap alien-unsigned-1 16 - ; inline
+
+: compute-v ( yuv uvy yy x -- v )
+ nip 2/ + >fixnum swap yuv_buffer-u swap alien-unsigned-1 128 - ; inline
+
+: compute-u ( yuv uvy yy x -- v )
+ nip 2/ + >fixnum swap yuv_buffer-v swap alien-unsigned-1 128 - ; inline
+
+:: compute-yuv ( yuv uvy yy x -- y u v )
+ yuv uvy yy x compute-y
+ yuv uvy yy x compute-u
+ yuv uvy yy x compute-v ; inline
+
+: compute-blue ( y u v -- b )
+ drop 516 * 128 + swap 298 * + -8 shift clamp ; inline
+
+: compute-green ( y u v -- g )
+ [ [ 298 * ] dip 100 * - ] dip 208 * - 128 + -8 shift clamp ;
+ inline
+
+: compute-red ( y u v -- g )
+ nip 409 * swap 298 * + 128 + -8 shift clamp ; inline
+
+: compute-rgb ( y u v -- b g r )
+ [ compute-blue ] [ compute-green ] [ compute-red ] 3tri ;
+ inline
+
+: store-rgb ( index rgb b g r -- index )
+ [ pick 0 + pick set-nth-unsafe ]
+ [ pick 1 + pick set-nth-unsafe ]
+ [ pick 2 + pick set-nth-unsafe ] tri*
+ drop ; inline
+
+: yuv>rgb-pixel ( index rgb yuv uvy yy x -- index )
+ compute-yuv compute-rgb store-rgb 3 + >fixnum ; inline
+
+: yuv>rgb-row ( index rgb yuv y -- index )
+ over stride
+ pick yuv_buffer-y_width >fixnum
+ [ yuv>rgb-pixel ] with with with with each ; inline
+
+: yuv>rgb ( rgb yuv -- )
+ [ 0 ] 2dip
+ dup yuv_buffer-y_height >fixnum
+ [ yuv>rgb-row ] with with each
+ drop ;
+
+HINTS: yuv>rgb byte-array byte-array ;
+
+: yuv>rgb-benchmark ( -- )
+ [ fake-data yuv>rgb ] with-destructors ;
+
+MAIN: yuv>rgb-benchmark
--- /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
--- /dev/null
+USING: assocs io.pathnames fry namespaces namespaces.private kernel sequences parser hashtables ;
+IN: closures
+SYMBOL: |
+
+! Selective Binding
+: delayed-bind-with ( vars quot -- quot' ) '[ _ dup [ get ] map zip >hashtable [ _ bind ] curry ] ;
+SYNTAX: C[ | parse-until parse-quotation delayed-bind-with over push-all ;
+! Common ones
+SYNTAX: DIR[ parse-quotation { current-directory } swap delayed-bind-with over push-all ;
+
+! Namespace Binding
+: bind-to-namespace ( quot -- quot' ) '[ namespace [ _ bind ] curry ] ;
+SYNTAX: NS[ parse-quotation bind-to-namespace over push-all ;
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license
-USING: accessors compiler.cfg.rpo compiler.cfg.dominance
-compiler.cfg.dominance.private compiler.cfg.predecessors images.viewer
-io io.encodings.ascii io.files io.files.unique io.launcher kernel
-math.parser sequences assocs arrays make namespaces ;
-IN: compiler.cfg.graphviz
-
-: render-graph ( edges -- )
- "cfg" "dot" make-unique-file
- [
- ascii [
- "digraph CFG {" print
- [ [ number>> number>string ] bi@ " -> " glue write ";" print ] assoc-each
- "}" print
- ] with-file-writer
- ]
- [ { "dot" "-Tpng" "-O" } swap suffix try-process ]
- [ ".png" append { "open" } swap suffix try-process ]
- tri ;
-
-: cfg-edges ( cfg -- edges )
- [
- [
- dup successors>> [
- 2array ,
- ] with each
- ] each-basic-block
- ] { } make ;
-
-: render-cfg ( cfg -- ) cfg-edges render-graph ;
-
-: dom-edges ( cfg -- edges )
- [
- compute-predecessors
- compute-dominance
- dom-childrens get [
- [
- 2array ,
- ] with each
- ] assoc-each
- ] { } make ;
-
-: render-dom ( cfg -- ) dom-edges render-graph ;
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license
+USING: accessors compiler.tree.builder compiler.cfg compiler.cfg.rpo
+compiler.cfg.dominance compiler.cfg.dominance.private
+compiler.cfg.predecessors compiler.cfg.debugger compiler.cfg.optimizer
+compiler.cfg.utilities compiler.tree.recursive images.viewer
+images.png io io.encodings.ascii io.files io.files.unique io.launcher
+kernel math.parser sequences assocs arrays make math namespaces
+quotations combinators locals words ;
+IN: compiler.graphviz
+
+: quotes ( str -- str' ) "\"" "\"" surround ;
+
+: graph, ( quot title -- )
+ [
+ quotes "digraph " " {" surround ,
+ call
+ "}" ,
+ ] { } make , ; inline
+
+: render-graph ( quot -- )
+ { } make
+ "cfg" ".dot" make-unique-file
+ dup "Wrote " prepend print
+ [ [ concat ] dip ascii set-file-lines ]
+ [ { "dot" "-Tpng" "-O" } swap suffix try-process ]
+ [ ".png" append "open" swap 2array try-process ]
+ tri ; inline
+
+: attrs>string ( seq -- str )
+ [ "" ] [ "," join "[" "]" surround ] if-empty ;
+
+: edge,* ( from to attrs -- )
+ [
+ [ quotes % " -> " % ] [ quotes % " " % ] [ attrs>string % ] tri*
+ ";" %
+ ] "" make , ;
+
+: edge, ( from to -- )
+ { } edge,* ;
+
+: bb-edge, ( from to -- )
+ [ number>> number>string ] bi@ edge, ;
+
+: node-style, ( str attrs -- )
+ [ [ quotes % " " % ] [ attrs>string % ";" % ] bi* ] "" make , ;
+
+: cfg-title ( cfg/mr -- string )
+ [
+ "=== word: " %
+ [ word>> name>> % ", label: " % ]
+ [ label>> name>> % ]
+ bi
+ ] "" make ;
+
+: cfg-vertex, ( bb -- )
+ [ number>> number>string ]
+ [ kill-block? { "color=grey" "style=filled" } { } ? ]
+ bi node-style, ;
+
+: cfgs ( cfgs -- )
+ [
+ [
+ [ [ cfg-vertex, ] each-basic-block ]
+ [
+ [
+ dup successors>> [
+ bb-edge,
+ ] with each
+ ] each-basic-block
+ ] bi
+ ] over cfg-title graph,
+ ] each ;
+
+: optimized-cfg ( quot -- cfgs )
+ {
+ { [ dup cfg? ] [ 1array ] }
+ { [ dup quotation? ] [ test-cfg [ optimize-cfg ] map ] }
+ { [ dup word? ] [ test-cfg [ optimize-cfg ] map ] }
+ [ ]
+ } cond ;
+
+: render-cfg ( cfg -- )
+ optimized-cfg [ cfgs ] render-graph ;
+
+: dom-trees ( cfgs -- )
+ [
+ [
+ needs-dominance drop
+ dom-childrens get [
+ [
+ bb-edge,
+ ] with each
+ ] assoc-each
+ ] over cfg-title graph,
+ ] each ;
+
+: render-dom ( cfg -- )
+ optimized-cfg [ dom-trees ] render-graph ;
+
+SYMBOL: word-counts
+SYMBOL: vertex-names
+
+: vertex-name ( call-graph-node -- string )
+ label>> vertex-names get [
+ word>> name>>
+ dup word-counts get [ 0 or 1 + dup ] change-at number>string " #" glue
+ ] cache ;
+
+: vertex-attrs ( obj -- string )
+ tail?>> { "style=bold,label=\"tail\"" } { } ? ;
+
+: call-graph-edge, ( from to attrs -- )
+ [ [ vertex-name ] [ vertex-attrs ] bi ] dip append edge,* ;
+
+: (call-graph-back-edges) ( string calls -- )
+ [ { "color=red" } call-graph-edge, ] with each ;
+
+: (call-graph-edges) ( string children -- )
+ [
+ {
+ [ { } call-graph-edge, ]
+ [ [ vertex-name ] [ label>> loop?>> { "shape=box" } { } ? ] bi node-style, ]
+ [ [ vertex-name ] [ calls>> ] bi (call-graph-back-edges) ]
+ [ [ vertex-name ] [ children>> ] bi (call-graph-edges) ]
+ } cleave
+ ] with each ;
+
+: call-graph-edges ( call-graph-node -- )
+ H{ } clone word-counts set
+ H{ } clone vertex-names set
+ [ "ROOT" ] dip (call-graph-edges) ;
+
+: render-call-graph ( tree -- )
+ dup quotation? [ build-tree ] when
+ analyze-recursive drop
+ [ [ call-graph get call-graph-edges ] "Call graph" graph, ]
+ render-graph ;
\ No newline at end of file
--- /dev/null
+USING: accessors sequences generalizations io.encodings.utf8 db.postgresql parser combinators vocabs.parser db.sqlite
+io.files ;
+IN: db.info
+! having sensative (and likely to change) information directly in source code seems a bad idea
+: get-info ( -- lines ) current-vocab name>> "vocab:" "/dbinfo.txt" surround utf8 file-lines ;
+SYNTAX: get-psql-info <postgresql-db> get-info 5 firstn
+ {
+ [ >>host ]
+ [ >>port ]
+ [ >>username ]
+ [ [ f ] [ ] if-empty >>password ]
+ [ >>database ]
+ } spread parsed ;
+
+SYNTAX: get-sqlite-info get-info first <sqlite-db> parsed ;
\ No newline at end of file
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: sort-largest-first ( seq -- seq ) [ [ length ] compare ] sort reverse ;
+: sort-largest-first ( seq -- seq ) [ length ] sort-with reverse ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
USING: tools.deploy.config ;
H{
- { deploy-unicode? f }
+ { deploy-name "drills" }
+ { deploy-c-types? t }
+ { "stop-after-last-window?" t }
+ { deploy-unicode? t }
{ deploy-threads? t }
+ { deploy-reflection 6 }
+ { deploy-word-defs? t }
{ deploy-math? t }
- { deploy-name "drills" }
{ deploy-ui? t }
- { "stop-after-last-window?" t }
- { deploy-word-props? f }
- { deploy-c-types? f }
- { deploy-io 2 }
- { deploy-word-defs? f }
- { deploy-reflection 1 }
+ { deploy-word-props? t }
+ { deploy-io 3 }
}
-USING: accessors arrays cocoa.dialogs combinators continuations
+USING: arrays cocoa.dialogs combinators continuations
fry grouping io.encodings.utf8 io.files io.styles kernel math
math.parser models models.arrow models.history namespaces random
sequences splitting ui ui.gadgets.alerts ui.gadgets.book-extras
ui.gadgets.books ui.gadgets.buttons ui.gadgets.frames
ui.gadgets.grids ui.gadgets.labels ui.gadgets.tracks fonts
wrap.strings system ;
-
+EXCLUDE: accessors => change-model ;
IN: drills.deployed
SYMBOLS: it startLength ;
: big ( gadget -- gadget ) T{ font { name "sans-serif" } { size 30 } } >>font ;
-USING: accessors arrays cocoa.dialogs combinators continuations
+USING: arrays cocoa.dialogs combinators continuations
fry grouping io.encodings.utf8 io.files io.styles kernel math
math.parser models models.arrow models.history namespaces random
sequences splitting ui ui.gadgets.alerts ui.gadgets.book-extras
ui.gadgets.books ui.gadgets.buttons ui.gadgets.frames
ui.gadgets.grids ui.gadgets.labels ui.gadgets.tracks fonts
wrap.strings ;
+EXCLUDE: accessors => change-model ;
IN: drills
SYMBOLS: it startLength ;
: big ( gadget -- gadget ) T{ font { name "sans-serif" } { size 30 } } >>font ;
: card ( model quot -- button ) <arrow> <label-control> big [ next ] <book-btn> ;
-: op ( quot str -- gadget ) <label> big swap <book-bevel-btn> ;
+: op ( quot str -- gadget ) <label> big swap <book-border-btn> ;
: show ( model -- gadget ) dup it set-global [ random ] <arrow>
{ [ [ first ] card ]
--- /dev/null
+Sam Anklesaria
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Sam Anklesaria.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel parser vocabs.parser words ;
+IN: enter
+! main words are usually only used for entry, doing initialization, etc
+! it makes sense, then to define it all at once, rather than factoring it out into a seperate word
+! and then declaring it main
+SYNTAX: ENTER: gensym [ parse-definition (( -- )) define-declared ] keep current-vocab (>>main) ;
\ No newline at end of file
+++ /dev/null
-USING: kernel file-trees ;
-IN: file-trees.tests
-{ "/sample/1" "/sample/2" "/killer/1" "/killer/2/3"
-"/killer/2/4" "/killer/2/4/6" "/megakiller" } create-tree drop
\ No newline at end of file
+++ /dev/null
-USING: accessors arrays delegate delegate.protocols
-io.pathnames kernel locals namespaces prettyprint sequences
-ui.frp vectors ;
-IN: file-trees
-
-TUPLE: tree node children ;
-CONSULT: sequence-protocol tree children>> ;
-
-: <tree> ( start -- tree ) V{ } clone
- [ tree boa dup children>> ] [ ".." swap tree boa ] bi swap push ;
-
-DEFER: (tree-insert)
-
-: tree-insert ( path tree -- ) [ unclip <tree> ] [ children>> ] bi* (tree-insert) ;
-:: (tree-insert) ( path-rest path-head tree-children -- )
- tree-children [ node>> path-head node>> = ] find nip
- [ path-rest swap tree-insert ]
- [
- path-head tree-children push
- path-rest [ path-head tree-insert ] unless-empty
- ] if* ;
-: create-tree ( file-list -- tree ) [ path-components ] map
- t <tree> [ [ tree-insert ] curry each ] keep ;
-
-: <dir-table> ( tree-model -- table )
- <frp-list*> [ node>> 1array ] >>quot
- [ selected-value>> <switch> ]
- [ swap >>model ] bi ;
\ No newline at end of file
--- /dev/null
+Sam Anklesaria
\ No newline at end of file
--- /dev/null
+Syntax for modifying gadget fonts
\ No newline at end of file
--- /dev/null
+USING: help.syntax help.markup ;
+IN: fonts.syntax
+
+HELP: FONT:
+{ $syntax "\"testing\" <label> FONT: 18 serif bold ... ;" }
+{ $description "Used after a gadget to change font settings. Attributes can be in any order: the first number is set as the size, the style attributes like bold and italic will set the bold? and italic? slots, and font-names like serif or monospace will set the name slot." } ;
\ No newline at end of file
--- /dev/null
+USING: accessors arrays variants combinators io.styles
+kernel math parser sequences fry ;
+IN: fonts.syntax
+
+VARIANT: fontname serif monospace ;
+
+: install ( object quot -- quot/? ) over [ curry ] [ 2drop [ ] ] if ;
+
+: >>name* ( object fontname -- object ) name>> >>name ;
+
+SYNTAX: FONT: \ ; parse-until {
+ [ [ number? ] find nip [ >>size ] install ]
+ [ [ italic = ] find nip [ >>italic? ] install ]
+ [ [ bold = ] find nip [ >>bold? ] install ]
+ [ [ fontname? ] find nip [ >>name* ] install ]
+} cleave 4array concat '[ dup font>> @ drop ] over push-all ;
--- /dev/null
+Sam Anklesaria
\ No newline at end of file
--- /dev/null
+USING: arrays vectors combinators effects kernel math sequences splitting
+strings.parser parser fry sequences.extras ;
+IN: fries
+: str-fry ( str on -- quot ) split
+ [ unclip-last [ [ spin glue ] reduce-r ] 2curry ]
+ [ length 1 - 1 <effect> [ call-effect ] 2curry ] bi ;
+: gen-fry ( str on -- quot ) split
+ [ unclip-last [ [ spin 1array glue ] reduce-r ] 2curry ]
+ [ length 1 - 1 <effect> [ call-effect ] 2curry ] bi ;
+
+SYNTAX: i" parse-string rest "_" str-fry over push-all ;
+SYNTAX: i{ \ } parse-until >array { _ } gen-fry over push-all ;
+SYNTAX: iV{ \ } parse-until >vector V{ _ } gen-fry over push-all ;
--- /dev/null
+Generalized Frying
\ No newline at end of file
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 ] }
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 } ;
[ [ 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 -- )
! (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 ;
--- /dev/null
+Sam Anklesaria
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Sam Anklesaria.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs kernel ui.gadgets.borders ui.gestures ;
+IN: key-handlers
+
+TUPLE: key-handler < border handlers ;
+: <keys> ( gadget -- key-handler ) key-handler new-border { 0 0 } >>size ;
+
+M: key-handler handle-gesture
+ tuck handlers>> at [ call( gadget -- ) f ] [ drop t ] if* ;
\ No newline at end of file
USING: tools.deploy.config ;
H{
- { deploy-math? t }
- { deploy-io 2 }
- { deploy-unicode? t }
+ { deploy-name "Merger" }
{ deploy-c-types? f }
{ "stop-after-last-window?" t }
- { deploy-ui? t }
- { deploy-reflection 1 }
- { deploy-name "Merger" }
- { deploy-word-props? f }
+ { deploy-unicode? f }
{ deploy-threads? t }
+ { deploy-reflection 1 }
{ deploy-word-defs? f }
+ { deploy-math? t }
+ { deploy-ui? t }
+ { deploy-word-props? f }
+ { deploy-io 2 }
}
-USING: accessors arrays fry io.directories kernel models sequences sets ui
+USING: accessors arrays fry io.directories kernel
+models sequences sets ui
ui.gadgets ui.gadgets.buttons ui.gadgets.labeled
ui.gadgets.tracks ui.gadgets.labels ui.gadgets.glass
math.rectangles cocoa.dialogs ;
--- /dev/null
+Sam Anklesaria
--- /dev/null
+USING: help.markup help.syntax models models.arrow sequences monads ;
+IN: models.combinators
+
+HELP: merge
+{ $values { "models" "a list of models" } { "model" basic-model } }
+{ $description "Creates a model that merges the updates of others" } ;
+
+HELP: filter-model
+{ $values { "model" model } { "quot" "quotation with stack effect ( a b -- c )" } { "filter-model" filter-model } }
+{ $description "Creates a model that uses the updates of another model only when they satisfy a given predicate" } ;
+
+HELP: fold
+{ $values { "oldval" "starting value" } { "quot" "applied to update and previous values" } { "model" model } { "model" model } }
+{ $description "Similar to " { $link reduce } " but works on models, applying a quotation to the previous and new values at each update" } ;
+
+HELP: switch-models
+{ $values { "model1" model } { "model2" model } { "model'" model } }
+{ $description "Creates a model that starts with the behavior of model2 and switches to the behavior of model1 on its update" } ;
+
+HELP: <mapped>
+{ $values { "model" model } { "quot" "applied to model's value on updates" } { "model" model } }
+{ $description "An expanded version of " { $link <arrow> } ". Use " { $link fmap } " instead." } ;
+
+HELP: when-model
+{ $values { "model" model } { "quot" "called on the model if the quot yields true" } { "cond" "a quotation called on the model's value, yielding a boolean value" } }
+{ $description "Calls quot when model updates if its value meets the condition set in cond" } ;
+
+HELP: with-self
+{ $values { "quot" "quotation that recieves its own return value" } { "model" model } }
+{ $description "Fixed points for models: the quot reacts to the same model to gives" } ;
+
+HELP: #1
+{ $values { "model" model } { "model'" model } }
+{ $description "Moves a model to the top of its dependencies' connections, thus being notified before the others" } ;
+
+ARTICLE: "models.combinators" "Extending models"
+"The " { $vocab-link "models.combinators" } " library expands models to have discrete start and end times. "
+"Also, it provides methods of manipulating and combining models, expecially useful when programming user interfaces: "
+"The output models of some gadgets (see " { $vocab-link "ui.gadgets.controls" } " ) can be manipulated and used as the input models of others. " ;
+
+ABOUT: "models.combinators"
\ No newline at end of file
--- /dev/null
+USING: accessors arrays kernel models models.product monads
+sequences sequences.extras ;
+FROM: syntax => >> ;
+IN: models.combinators
+
+TUPLE: multi-model < model important? ;
+GENERIC: (model-changed) ( model observer -- )
+: <multi-model> ( models kind -- model ) f swap new-model [ [ add-dependency ] curry each ] keep ;
+M: multi-model model-changed over value>> [ (model-changed) ] [ 2drop ] if ;
+M: multi-model model-activated dup dependencies>> [ value>> ] find nip
+ [ swap model-changed ] [ drop ] if* ;
+
+: #1 ( model -- model' ) t >>important? ;
+
+IN: models
+: notify-connections ( model -- )
+ dup connections>> dup [ dup multi-model? [ important?>> ] [ drop f ] if ] find-all
+ [ second tuck [ remove ] dip prefix ] each
+ [ model-changed ] with each ;
+IN: models.combinators
+
+TUPLE: basic-model < multi-model ;
+M: basic-model (model-changed) [ value>> ] dip set-model ;
+: merge ( models -- model ) basic-model <multi-model> ;
+: 2merge ( model1 model2 -- model ) 2array merge ;
+: <basic> ( value -- model ) basic-model new-model ;
+
+TUPLE: filter-model < multi-model quot ;
+M: filter-model (model-changed) [ value>> ] dip 2dup quot>> call( a -- ? )
+ [ set-model ] [ 2drop ] if ;
+: filter-model ( model quot -- filter-model ) [ 1array \ filter-model <multi-model> ] dip >>quot ;
+
+TUPLE: fold-model < multi-model quot base values ;
+M: fold-model (model-changed) 2dup base>> =
+ [ [ [ value>> ] [ [ values>> ] [ quot>> ] bi ] bi* swapd reduce* ] keep set-model ]
+ [ [ [ value>> ] [ values>> ] bi* push ]
+ [ [ [ value>> ] [ [ value>> ] [ quot>> ] bi ] bi* call( val oldval -- newval ) ] keep set-model ] 2bi
+ ] if ;
+M: fold-model model-activated drop ;
+: new-fold-model ( deps -- model ) fold-model <multi-model> V{ } clone >>values ;
+: fold ( model oldval quot -- model ) rot 1array new-fold-model swap >>quot
+ swap >>value ;
+: fold* ( model oldmodel quot -- model ) over [ [ 2array new-fold-model ] dip >>quot ]
+ dip [ >>base ] [ value>> >>value ] bi ;
+
+TUPLE: updater-model < multi-model values updates ;
+M: updater-model (model-changed) [ tuck updates>> =
+ [ [ values>> value>> ] keep set-model ]
+ [ drop ] if ] keep f swap (>>value) ;
+: updates ( values updates -- model ) [ 2array updater-model <multi-model> ] 2keep
+ [ >>values ] [ >>updates ] bi* ;
+
+SYMBOL: switch
+TUPLE: switch-model < multi-model original switcher on ;
+M: switch-model (model-changed) 2dup switcher>> =
+ [ [ value>> ] dip over switch = [ nip [ original>> ] keep f >>on model-changed ] [ t >>on set-model ] if ]
+ [ dup on>> [ 2drop ] [ [ value>> ] dip over [ set-model ] [ 2drop ] if ] if ] if ;
+: switch-models ( model1 model2 -- model' ) swap [ 2array switch-model <multi-model> ] 2keep
+ [ [ value>> >>value ] [ >>original ] bi ] [ >>switcher ] bi* ;
+M: switch-model model-activated [ original>> ] keep model-changed ;
+: >behavior ( event -- behavior ) t >>value ;
+
+TUPLE: mapped-model < multi-model model quot ;
+: new-mapped-model ( model quot class -- mapped-model ) [ over 1array ] dip
+ <multi-model> swap >>quot swap >>model ;
+: <mapped> ( model quot -- model ) mapped-model new-mapped-model ;
+M: mapped-model (model-changed)
+ [ [ value>> ] [ quot>> ] bi* call( old -- new ) ] [ nip ] 2bi
+ set-model ;
+
+TUPLE: side-effect-model < mapped-model ;
+M: side-effect-model (model-changed) [ value>> ] dip [ quot>> call( old -- ) ] 2keep set-model ;
+
+TUPLE: quot-model < mapped-model ;
+M: quot-model (model-changed) nip [ quot>> call( -- b ) ] keep set-model ;
+
+TUPLE: action-value < basic-model parent ;
+: <action-value> ( parent value -- model ) action-value new-model swap >>parent ;
+M: action-value model-activated dup parent>> dup activate-model model-changed ; ! a fake dependency of sorts
+
+TUPLE: action < multi-model quot ;
+M: action (model-changed) [ [ value>> ] [ quot>> ] bi* call( a -- b ) ] keep value>>
+ [ swap add-connection ] 2keep model-changed ;
+: <action> ( model quot -- action-model ) [ 1array action <multi-model> ] dip >>quot dup f <action-value> >>value value>> ;
+
+TUPLE: collection < multi-model ;
+: <collection> ( models -- product ) collection <multi-model> ;
+M: collection (model-changed)
+ nip
+ dup dependencies>> [ value>> ] all?
+ [ dup [ value>> ] product-value swap set-model ]
+ [ drop ] if ;
+M: collection model-activated dup (model-changed) ;
+
+! for side effects
+TUPLE: (when-model) < multi-model quot cond ;
+: when-model ( model quot cond -- model ) rot 1array (when-model) <multi-model> swap >>cond swap >>quot ;
+M: (when-model) (model-changed) [ quot>> ] 2keep
+ [ value>> ] [ cond>> ] bi* call( a -- ? ) [ call( model -- ) ] [ 2drop ] if ;
+
+! only used in construction
+: with-self ( quot: ( model -- model ) -- model ) [ f <basic> dup ] dip call swap [ add-dependency ] keep ; inline
+
+USE: models.combinators.templates
+<< { "$>" "<$" "fmap" } [ fmaps ] each >>
\ No newline at end of file
--- /dev/null
+Model combination and manipulation
\ No newline at end of file
--- /dev/null
+USING: kernel sequences functors fry macros generalizations ;
+IN: models.combinators.templates
+FROM: models.combinators => <collection> #1 ;
+FUNCTOR: fmaps ( W -- )
+W IS ${W}
+w-n DEFINES ${W}-n
+w-2 DEFINES 2${W}
+w-3 DEFINES 3${W}
+w-4 DEFINES 4${W}
+w-n* DEFINES ${W}-n*
+w-2* DEFINES 2${W}*
+w-3* DEFINES 3${W}*
+w-4* DEFINES 4${W}*
+WHERE
+MACRO: w-n ( int -- quot ) dup '[ [ _ narray <collection> ] dip [ _ firstn ] prepend W ] ;
+: w-2 ( a b quot -- mapped ) 2 w-n ; inline
+: w-3 ( a b c quot -- mapped ) 3 w-n ; inline
+: w-4 ( a b c d quot -- mapped ) 4 w-n ; inline
+MACRO: w-n* ( int -- quot ) dup '[ [ _ narray <collection> #1 ] dip [ _ firstn ] prepend W ] ;
+: w-2* ( a b quot -- mapped ) 2 w-n* ; inline
+: w-3* ( a b c quot -- mapped ) 3 w-n* ; inline
+: w-4* ( a b c d quot -- mapped ) 4 w-n* ; inline
+;FUNCTOR
\ No newline at end of file
--- /dev/null
+Sam Anklesaria
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Sam Anklesaria.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays accessors kernel models threads calendar ;
+IN: models.conditional
+
+TUPLE: conditional < model condition thread ;
+
+M: conditional model-changed
+ [
+ [ dup
+ [ condition>> call( -- ? ) ]
+ [ thread>> self = not ] bi or
+ [ [ value>> ] dip set-model f ]
+ [ 2drop t ] if 100 milliseconds sleep
+ ] 2curry "models.conditional" spawn-server
+ ] keep (>>thread) ;
+
+: <conditional> ( condition -- model )
+ f conditional new-model swap >>condition ;
+
+M: conditional model-activated [ model>> ] keep model-changed ;
\ No newline at end of file
--- /dev/null
+Sam Anklesaria
--- /dev/null
+USING: help.syntax help.markup modules.rpc-server modules.using ;
+IN: modules.rpc-server
+HELP: service
+{ $syntax "IN: my-vocab service" }
+{ $description "Allows words defined in the vocabulary to be used as remote procedure calls by " { $link POSTPONE: USING*: } } ;
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Sam Anklesaria.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs combinators continuations effects
+io.encodings.binary io.servers.connection kernel namespaces
+sequences serialize sets threads vocabs vocabs.parser init io ;
+IN: modules.rpc-server
+
+<PRIVATE
+TUPLE: rpc-request args vocabspec wordname ;
+SYMBOL: serving-vocabs serving-vocabs [ V{ } clone ] initialize
+
+: getter ( -- ) deserialize dup serving-vocabs get-global index
+ [ vocab-words [ stack-effect ] { } assoc-map-as ]
+ [ \ no-vocab boa ] if serialize flush ;
+
+: doer ( -- ) deserialize dup vocabspec>> serving-vocabs get-global index
+ [ [ args>> ] [ wordname>> ] [ vocabspec>> vocab-words ] tri at [ execute ] curry with-datastack ]
+ [ vocabspec>> \ no-vocab boa ] if serialize flush ;
+
+PRIVATE>
+SYNTAX: service current-vocab name>> serving-vocabs get-global adjoin ;
+
+: start-rpc-server ( -- )
+ binary <threaded-server>
+ "rpcs" >>name 9012 >>insecure
+ [ deserialize {
+ { "getter" [ getter ] }
+ { "doer" [ doer ] }
+ { "loader" [ deserialize vocab serialize flush ] }
+ } case ] >>handler
+ start-server ;
--- /dev/null
+Serve factor words as rpcs
\ No newline at end of file
--- /dev/null
+Sam Anklesaria
--- /dev/null
+USING: help.syntax help.markup ;
+IN: modules.rpc
+ARTICLE: { "modules" "protocol" } "RPC Protocol"
+{ $list
+ "Send vocab as string"
+ "Send arglist"
+ "Send word as string"
+ "Receive result list"
+} ;
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Sam Anklesaria.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs fry generalizations io.encodings.binary
+io.sockets kernel locals namespaces parser sequences serialize
+vocabs vocabs.parser words io ;
+IN: modules.rpc
+
+TUPLE: rpc-request args vocabspec wordname ;
+
+: send-with-check ( message -- reply/* )
+ serialize flush deserialize dup no-vocab? [ throw ] when ;
+
+:: define-remote ( str effect addrspec vocabspec -- )
+ str create-in effect [ in>> length ] [ out>> length ] bi
+ '[ _ narray vocabspec str rpc-request boa addrspec 9012 <inet> binary
+ [ "doer" serialize send-with-check ] with-client _ firstn ]
+ effect define-declared ;
+
+:: remote-vocab ( addrspec vocabspec -- vocab )
+ vocabspec "-remote" append dup vocab [ dup set-current-vocab
+ vocabspec addrspec 9012 <inet> binary [ "getter" serialize send-with-check ] with-client
+ [ first2 addrspec vocabspec define-remote ] each
+ ] unless ;
+
+: remote-load ( addr vocabspec -- voabspec ) [ swap
+ 9012 <inet> binary [ "loader" serialize serialize flush deserialize ] with-client ] keep
+ [ dictionary get-global set-at ] keep ;
\ No newline at end of file
--- /dev/null
+remote procedure call client
\ No newline at end of file
--- /dev/null
+Sam Anklesaria
--- /dev/null
+Improved module import syntax with network transparency
\ No newline at end of file
--- /dev/null
+USING: help.syntax help.markup strings modules.using ;
+IN: modules.using
+ARTICLE: { "modules.using" "use" } "Using the modules.using vocab"
+"This vocabulary defines " { $link POSTPONE: USING*: } " as an alternative to " { $link POSTPONE: USING: } " which makes qualified imports easier. "
+"Secondly, it allows loading vocabularies from remote servers, as long as the remote vocabulary can be accessed at compile time. "
+"Finally, the word can treat words in remote vocabularies as remote procedure calls. Any inputs are passed to the imported words as normal, and the result will appear on the stack- the only difference is that the word isn't called locally." ;
+ABOUT: { "modules.using" "use" }
+
+HELP: USING*:
+{ $syntax "USING: rpc-server::module fetch-sever:module { module qualified-name } { module => word ... } { qualified-module } { module EXCEPT word ... } { module word => importname } ;" }
+{ $description "Adds vocabularies to the search path. Vocabularies can be loaded off a server or called as an rpc if preceded by a valid hostname. Bracketed pairs facilitate all types of qualified imports on both remote and local modules." } ;
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Sam Anklesaria.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel modules.rpc peg peg-lexer peg.ebnf sequences
+strings vocabs.parser ;
+IN: modules.using
+
+EBNF: modulize
+tokenpart = (!(':').)+ => [[ >string ]]
+s = ':' => [[ drop ignore ]]
+rpc = tokenpart s s tokenpart => [[ first2 remote-vocab ]]
+remote = tokenpart s tokenpart => [[ first2 remote-load ]]
+module = rpc | remote | tokenpart
+;EBNF
+
+ON-BNF: USING*:
+tokenizer = <foreign factor>
+sym = !(";"|"}"|"=>"|"EXCEPT").
+modspec = sym => [[ modulize ]]
+qualified-with = modspec sym => [[ first2 add-qualified ignore ]]
+qualified = modspec => [[ dup add-qualified ignore ]]
+from = modspec "=>" sym+ => [[ first3 nip add-words-from ignore ]]
+exclude = modspec "EXCEPT" sym+ => [[ first3 nip add-words-excluding ignore ]]
+rename = modspec sym "=>" sym => [[ first4 nip swapd add-renamed-word ignore ]]
+long = "{" ( from | exclude | rename | qualified-with | qualified ) "}" => [[ drop ignore ]]
+short = modspec => [[ use-vocab ignore ]]
+wordSpec = long | short
+using = wordSpec+ ";" => [[ drop ignore ]]
+;ON-BNF
\ No newline at end of file
! Functors
GENERIC# fmap 1 ( functor quot -- functor' )
+GENERIC# <$ 1 ( functor quot -- functor' )
+GENERIC# $> 1 ( functor quot -- functor' )
! Monads
M: monad fail monad-of fail ;
: bind ( mvalue quot -- mvalue' ) swap >>= call( quot -- mvalue ) ;
+: bind* ( mvalue quot -- mvalue' ) '[ drop @ ] bind ;
: >> ( mvalue k -- mvalue' ) '[ drop _ ] bind ;
:: lift-m2 ( m1 m2 f monad -- m3 )
: 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 ]
--- /dev/null
+Sam Anklesaria
\ No newline at end of file
--- /dev/null
+USING: accessors arrays byte-arrays calendar classes
+classes.tuple classes.tuple.parser combinators db db.queries
+db.tuples db.types kernel math nmake parser sequences strings
+strings.parser unicode.case urls words ;
+IN: persistency
+
+TUPLE: persistent id ;
+
+: add-types ( table -- table' ) [ dup array? [ [ first dup >upper ] [ second ] bi 3array ]
+ [ dup >upper FACTOR-BLOB 3array ] if
+ ] map { "id" "ID" +db-assigned-id+ } prefix ;
+
+: remove-types ( table -- table' ) [ dup array? [ first ] when ] map ;
+
+SYNTAX: STORED-TUPLE: parse-tuple-definition [ drop persistent ] dip [ remove-types define-tuple-class ]
+ [ nip [ dup name>> >upper ] [ add-types ] bi* define-persistent ] 3bi ;
+
+: define-db ( database class -- ) swap [ [ ensure-table ] with-db ] [ "database" set-word-prop ] 2bi ;
+
+: query>tuple ( tuple/query -- tuple ) dup query? [ tuple>> ] when ;
+: w/db ( query quot -- ) [ dup query>tuple class "database" word-prop ] dip with-db ; inline
+: get-tuples ( query -- tuples ) [ select-tuples ] w/db ;
+: get-tuple ( query -- tuple ) [ select-tuple ] w/db ;
+: store-tuple ( tuple -- ) [ insert-tuple ] w/db ;
+: modify-tuple ( tuple -- ) [ update-tuple ] w/db ;
+: remove-tuples ( tuple -- ) [ delete-tuples ] w/db ;
+
+TUPLE: pattern value ; C: <pattern> pattern
+SYNTAX: %" parse-string <pattern> parsed ;
+M: pattern where value>> over column-name>> 0% " LIKE " 0% bind# ;
--- /dev/null
+Sam Anklesaria
\ No newline at end of file
--- /dev/null
+USING: accessors arrays colors.constants combinators
+db.sqlite db.tuples db.types kernel locals math
+monads persistency sequences sequences.extras ui ui.gadgets.controls
+ui.gadgets.layout models.combinators ui.gadgets.labels
+ui.gadgets.scrollers ui.pens.solid io.files.temp ;
+FROM: sets => prune ;
+IN: recipes
+
+STORED-TUPLE: recipe { title { VARCHAR 100 } } { votes INTEGER } { txt TEXT } { genre { VARCHAR 100 } } ;
+: <recipe> ( title genre text -- recipe ) recipe new swap >>txt swap >>genre swap >>title 0 >>votes ;
+"recipes.db" temp-file <sqlite-db> recipe define-db
+: top-recipes ( offset search -- recipes ) <query> T{ recipe } rot >>title >>tuple
+ "votes" >>order 30 >>limit swap >>offset get-tuples ;
+: top-genres ( -- genres ) f f top-recipes [ genre>> ] map prune 4 short head-slice ;
+
+: interface ( -- book ) [
+ [
+ [ $ TOOLBAR $ ] <hbox> COLOR: AliceBlue <solid> >>interior ,
+ [ "Genres:" <label> , <spacer> $ ALL $ $ GENRES $ ] <hbox>
+ { 5 0 } >>gap COLOR: gray <solid> >>interior ,
+ $ RECIPES $
+ ] <vbox> ,
+ [
+ [ "Title:" <label> , $ TITLE $ "Genre:" <label> , $ GENRE $ ] <hbox> ,
+ $ BODY $
+ $ BUTTON $
+ ] <vbox> ,
+ ] <book*> { 350 245 } >>pref-dim ;
+
+:: recipe-browser ( -- ) [ [
+ interface
+ <table*> :> tbl
+ "okay" <model-border-btn> BUTTON -> :> ok
+ IMG-MODEL-BTN: submit [ store-tuple ] >>value TOOLBAR -> :> submit
+ IMG-MODEL-BTN: love 1 >>value TOOLBAR ->
+ IMG-MODEL-BTN: hate -1 >>value -> 2array merge :> votes
+ IMG-MODEL-BTN: back -> [ -30 ] <$
+ IMG-MODEL-BTN: more -> [ 30 ] <$ 2array merge :> viewed
+ <spacer> <model-field*> ->% 1 :> search
+ submit ok [ [ drop ] ] <$ 2array merge [ drop ] >>value :> quot
+ viewed 0 [ + ] fold search ok t <basic> "all" <model-btn> ALL ->
+ tbl selection>> votes [ [ + ] curry change-votes modify-tuple ] 2$>
+ 4array merge
+ [ drop [ f ] [ "%" dup surround <pattern> ] if-empty top-recipes ] 3fmap :> ups
+ ups [ top-genres [ <model-btn> GENRES -> ] map merge ] bind*
+ [ text>> T{ recipe } swap >>genre get-tuples ] fmap
+ tbl swap ups 2merge >>model
+ [ [ title>> ] [ genre>> ] bi 2array ] >>quot
+ { "Title" "Genre" } >>column-titles dup <scroller> RECIPES ,% 1 actions>>
+ submit [ "" dup dup <recipe> ] <$ 2array merge
+ { [ [ title>> ] fmap <model-field> TITLE ->% .5 ]
+ [ [ genre>> ] fmap <model-field> GENRE ->% .5 ]
+ [ [ txt>> ] fmap <model-editor> BODY ->% 1 ]
+ } cleave
+ [ <recipe> ] 3fmap
+ [ [ 1 ] <$ ]
+ [ quot ok updates #1 [ call( recipe -- ) 0 ] 2fmap ] bi
+ 2merge 0 <basic> switch-models >>model
+ ] with-interface "recipes" open-window ] with-ui ;
+
+MAIN: recipe-browser
\ No newline at end of file
--- /dev/null
+Database backed recipe sharing
\ No newline at end of file
--- /dev/null
+USING: io io.encodings.utf8 io.launcher kernel sequences ;
+IN: run-desc
+: run-desc ( desc -- result ) utf8 [ contents [ but-last ] [ f ] if* ] with-process-reader ;
[ "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 ;
--- /dev/null
+USING: arrays kernel locals math sequences ;
+IN: sequences.extras
+: reduce1 ( seq quot -- result ) [ unclip ] dip reduce ; inline
+
+:: reduce-r
+ ( list identity quot: ( obj1 obj2 -- obj ) -- result )
+ list empty?
+ [ identity ]
+ [ list rest identity quot reduce-r list first quot call ] if ;
+ inline recursive
+
+! Quot must have static stack effect, unlike "reduce"
+:: reduce* ( seq id quot -- result ) seq
+ [ id ]
+ [ unclip id swap quot call( prev elt -- next ) quot reduce* ] if-empty ; inline recursive
+
+:: combos ( list1 list2 -- result ) list2 [ [ 2array ] curry list1 swap map ] map concat ;
+: find-all ( seq quot -- elts ) [ [ length iota ] keep ] dip
+ [ dupd call( a -- ? ) [ 2array ] [ 2drop f ] if ] curry 2map [ ] filter ; inline
+
+: insert-sorted ( elt seq -- seq ) 2dup [ < ] with find drop over length or swap insert-nth ;
\ No newline at end of file
--- /dev/null
+USING: accessors assocs fry generalizations kernel math
+namespaces parser sequences words ;
+IN: set-n
+: get* ( var n -- val ) namestack dup length rot - head assoc-stack ;
+
+: set* ( val var n -- ) 1 + namestack [ length swap - ] keep nth set-at ;
+
+! dynamic lambda
+SYNTAX: :| (:) dup in>> dup length [ spin '[ _ narray _ swap zip _ bind ] ] 2curry dip define-declared ;
\ No newline at end of file
+++ /dev/null
-Sam Anklesaria
\ No newline at end of file
+++ /dev/null
-USING: combinators effects kernel math sequences splitting
-strings.parser ;
-IN: str-fry
-: str-fry ( str -- quot ) "_" split
- [ unclip [ [ rot glue ] reduce ] 2curry ]
- [ length 1 - 1 <effect> [ call-effect ] 2curry ] bi ;
-SYNTAX: I" parse-string rest str-fry over push-all ;
\ No newline at end of file
+++ /dev/null
-String Frying
\ No newline at end of file
--- /dev/null
+Sam Anklesaria
\ No newline at end of file
--- /dev/null
+USING: accessors arrays combinators.short-circuit grouping kernel lists
+lists.lazy locals math math.functions math.parser math.ranges
+models.product monads random sequences sets ui ui.gadgets.controls
+ui.gadgets.layout models.combinators ui.gadgets.alerts vectors fry
+ui.gadgets.labels ;
+IN: sudokus
+
+: row ( index -- row ) 1 + 9 / ceiling ;
+: col ( index -- col ) 9 mod 1 + ;
+: sq ( index -- square ) [ row ] [ col ] bi [ 3 / ceiling ] bi@ 2array ;
+: near ( a pos -- ? ) { [ [ row ] bi@ = ] [ [ col ] bi@ = ] [ [ sq ] bi@ = ] } 2|| ;
+: nth-or-lower ( n seq -- elt ) [ length 1 - 2dup > [ nip ] [ drop ] if ] keep nth ;
+
+:: solutions ( puzzle random? -- solutions )
+ f puzzle random? [ indices [ f ] [ random? swap nth-or-lower ] if-empty ] [ index ] if
+ [ :> pos
+ 1 9 [a,b] 80 iota [ pos near ] filter [ puzzle nth ] map prune diff
+ [ 1array puzzle pos cut-slice rest surround ] map >list [ random? solutions ] bind
+ ] [ puzzle list-monad return ] if* ;
+
+: solution ( puzzle random? -- solution ) dupd solutions dup +nil+ = [ drop "Unsolvable" alert* ] [ nip car ] if ;
+: hint ( puzzle -- puzzle' ) [ [ f swap indices random dup ] [ f solution ] bi nth ] keep swapd >vector [ set-nth ] keep ;
+: create ( difficulty -- puzzle ) 81 [ f ] replicate
+ 40 random solution [ [ dup length random f spin set-nth ] curry times ] keep ;
+
+: do-sudoku ( -- ) [ [
+ [
+ 81 [ "" ] replicate <basic> switch-models [ [ <basic> ] map 9 group [ 3 group ] map 3 group
+ [ [ [ <spacer> [ [ <model-field> ->% 2 [ string>number ] fmap ]
+ map <spacer> ] map concat ] <hbox> , ] map concat <spacer> ] map concat <product>
+ [ "Difficulty:" <label> , "1" <basic> <model-field> -> [ string>number 1 or 1 + 10 * ] fmap
+ "Generate" <model-border-btn> -> updates [ create ] fmap <spacer>
+ "Hint" <model-border-btn> -> "Solve" <model-border-btn> -> ] <hbox> ,
+ roll [ swap updates ] curry bi@
+ [ [ hint ] fmap ] [ [ f solution ] fmap ] bi* 3array merge [ [ [ number>string ] [ "" ] if* ] map ] fmap
+ ] bind
+ ] with-self , ] <vbox> { 280 220 } >>pref-dim
+ "Sudoku Sleuth" open-window ] with-ui ;
+
+MAIN: do-sudoku
\ No newline at end of file
--- /dev/null
+graphical sudoku solver
\ No newline at end of file
+++ /dev/null
-Sam Anklesaria
+++ /dev/null
-USING: help.markup help.syntax models monads sequences
-ui.gadgets.buttons ui.gadgets.tracks ;
-IN: ui.frp
-
-! Layout utilities
-
-HELP: ,
-{ $values { "uiitem" "a gadget or model" } }
-{ $description "Used in a series of gadgets created by a box, accumulating the gadget" } ;
-HELP: ->
-{ $values { "uiitem" "a gadget or model" } { "model" model } }
-{ $description "Like " { $link , } "but passes its model on for further use." } ;
-HELP: <hbox>
-{ $values { "gadgets" "a list of gadgets" } { "track" track } }
-{ $syntax "[ gadget , gadget , ... ] <hbox>" }
-{ $description "Creates an horizontal track containing the gadgets listed in the quotation" } ;
-HELP: <vbox>
-{ $values { "gadgets" "a list of gadgets" } { "track" track } }
-{ $syntax "[ gadget , gadget , ... ] <hbox>" }
-{ $description "Creates an vertical track containing the gadgets listed in the quotation" } ;
-
-! Gadgets
-HELP: <frp-button>
-{ $values { "text" "the button's label" } { "button" button } }
-{ $description "Creates an button whose model updates on clicks" } ;
-
-HELP: <merge>
-{ $values { "models" "a list of models" } { "model" merge-model } }
-{ $description "Creates a model that merges the updates of others" } ;
-
-HELP: <filter>
-{ $values { "model" model } { "quot" "quotation with stack effect ( a b -- c )" } { "filter-model" filter-model } }
-{ $description "Creates a model that uses the updates of another model when they satisfy a given predicate" } ;
-
-HELP: <fold>
-{ $values { "oldval" "starting value" } { "quot" "applied to update and previous values" } { "model" model } { "model'" model } }
-{ $description "Similar to " { $link reduce } " but works on models, applying a quotation to the previous and new values at each update" } ;
-
-HELP: <switch>
-{ $values { "signal1" model } { "signal2" model } { "signal'" model } }
-{ $description "Creates a model that starts with the behavior of model1 and switches to the behavior of model2 on its update" } ;
-
-ARTICLE: { "frp" "instances" } "FRP Instances"
-"Models are all functors, as " { $link fmap } " corresponds directly to the " { $link "models.arrow" } " vocabulary. "
-"Also, a gadget is a monad. Binding recieves a model and creates a new gadget." ;
-
+++ /dev/null
-USING: accessors arrays colors fonts kernel models
-models.product monads sequences ui.gadgets ui.gadgets.buttons
-ui.gadgets.editors ui.gadgets.line-support ui.gadgets.tables
-ui.gadgets.tracks ui.render ui.gadgets.scrollers ;
-QUALIFIED: make
-IN: ui.frp
-
-! Gadgets
-: <frp-button> ( text -- button ) [ t swap set-control-value ] <border-button> f <model> >>model ;
-TUPLE: frp-table < table quot val-quot color-quot column-titles column-alignment ;
-M: frp-table column-titles column-titles>> ;
-M: frp-table column-alignment column-alignment>> ;
-M: frp-table row-columns quot>> [ call( a -- b ) ] [ drop f ] if* ;
-M: frp-table row-value val-quot>> [ call( a -- b ) ] [ drop f ] if* ;
-M: frp-table row-color color-quot>> [ call( a -- b ) ] [ drop f ] if* ;
-
-: <frp-table> ( model -- table )
- frp-table new-line-gadget dup >>renderer [ ] >>quot swap >>model
- f <model> >>selected-value sans-serif-font >>font
- focus-border-color >>focus-border-color
- transparent >>column-line-color [ ] >>val-quot ;
-: <frp-table*> ( -- table ) f <model> <frp-table> ;
-: <frp-list> ( model -- table ) <frp-table> [ 1array ] >>quot ;
-: <frp-list*> ( -- table ) f <model> <frp-list> ;
-
-: <frp-field> ( -- field ) f <model> <model-field> ;
-
-! Layout utilities
-
-GENERIC: output-model ( gadget -- model )
-M: gadget output-model model>> ;
-M: frp-table output-model selected-value>> ;
-M: model-field output-model field-model>> ;
-M: scroller output-model children>> first model>> ;
-
-GENERIC: , ( uiitem -- )
-M: gadget , make:, ;
-M: model , activate-model ;
-
-GENERIC: -> ( uiitem -- model )
-M: gadget -> dup make:, output-model ;
-M: model -> dup , ;
-M: table -> dup , selected-value>> ;
-
-: <box> ( gadgets type -- track )
- [ { } make:make ] dip <track> swap [ f track-add ] each ; inline
-: <box*> ( gadgets type -- track ) [ <box> ] [ [ model>> ] map <product> ] bi >>model ; inline
-: <hbox> ( gadgets -- track ) horizontal <box> ; inline
-: <hbox*> ( gadgets -- track ) horizontal <box*> ; inline
-: <vbox> ( gadgets -- track ) vertical <box> ; inline
-: <vbox*> ( gadgets -- track ) vertical <box*> ; inline
-
-! !!! Model utilities
-TUPLE: multi-model < model ;
-: <multi-model> ( models kind -- model ) f swap new-model [ [ add-dependency ] curry each ] keep ;
-
-! Events- discrete model utilities
-
-TUPLE: merge-model < multi-model ;
-M: merge-model model-changed [ value>> ] dip set-model ;
-: <merge> ( models -- model ) merge-model <multi-model> ;
-
-TUPLE: filter-model < multi-model quot ;
-M: filter-model model-changed [ value>> ] dip [ quot>> call( val -- bool ) ] 2keep
- [ set-model ] [ 2drop ] if ;
-: <filter> ( model quot -- filter-model ) [ 1array filter-model <multi-model> ] dip >>quot ;
-
-! Behaviors - continuous model utilities
-
-TUPLE: fold-model < multi-model oldval quot ;
-M: fold-model model-changed [ [ value>> ] [ [ oldval>> ] [ quot>> ] bi ] bi*
- call( val oldval -- newval ) ] keep set-model ;
-: <fold> ( oldval quot model -- model' ) 1array fold-model <multi-model> swap >>quot
- swap [ >>oldval ] [ >>value ] bi ;
-
-TUPLE: switch-model < multi-model original switcher on ;
-M: switch-model model-changed 2dup switcher>> =
- [ over value>> [ [ value>> ] [ t >>on ] bi* set-model ] [ 2drop ] if ]
- [ dup on>> [ 2drop ] [ [ value>> ] dip set-model ] if ] if ;
-M: switch-model model-activated [ original>> ] keep model-changed ;
-: <switch> ( signal1 signal2 -- signal' ) [ 2array switch-model <multi-model> ] 2keep
- [ >>original ] [ >>switcher ] bi* ;
-
-TUPLE: mapped < model model quot ;
-
-: <mapped> ( model quot -- arrow )
- f mapped new-model
- swap >>quot
- over >>model
- [ add-dependency ] keep ;
-
-M: mapped model-changed
- [ [ value>> ] [ quot>> ] bi* call( old -- new ) ] [ nip ] 2bi
- set-model ;
-
-! Instances
-M: model fmap <mapped> ;
-
-SINGLETON: gadget-monad
-INSTANCE: gadget-monad monad
-INSTANCE: gadget monad
-M: gadget monad-of drop gadget-monad ;
-M: gadget-monad return drop <gadget> swap >>model ;
-M: gadget >>= output-model [ swap call( x -- y ) ] curry ;
\ No newline at end of file
+++ /dev/null
-Utilities for functional reactive programming in user interfaces
-USING: accessors ui ui.gadgets ui.gadgets.labels ui.gadgets.buttons ui.gadgets.packs locals sequences fonts io.styles ;
+USING: accessors models monads macros generalizations kernel
+ui ui.gadgets.controls models.combinators ui.gadgets.layout ui.gadgets
+ui.gadgets.labels ui.gadgets.editors ui.gadgets.buttons
+ui.gadgets.packs locals sequences fonts io.styles
+wrap.strings ;
+
IN: ui.gadgets.alerts
-:: alert ( quot string -- ) <pile> { 10 10 } >>gap 1 >>align string <label> T{ font { name "sans-serif" } { size 18 } } >>font { 200 100 } >>pref-dim add-gadget
- "okay" [ close-window ] quot append <border-button> add-gadget "" open-window ;
\ No newline at end of file
+:: alert ( quot string -- ) <pile> { 10 10 } >>gap 1 >>align
+ string 22 wrap-lines <label> T{ font { name "sans-serif" } { size 18 } } >>font { 200 100 } >>pref-dim add-gadget
+ "okay" [ close-window ] quot append <border-button> add-gadget "" open-window ;
+
+: alert* ( str -- ) [ ] swap alert ;
+
+:: ask-user ( string -- model' )
+ [ [let | lbl [ string <label> T{ font { name "sans-serif" } { size 14 } } >>font dup , ]
+ fldm [ <model-field*> ->% 1 ]
+ btn [ "okay" <model-border-btn> ] |
+ btn -> [ fldm swap updates ]
+ [ [ drop lbl close-window ] $> , ] bi
+ ] ] <vbox> { 161 86 } >>pref-dim "" open-window ;
+
+MACRO: ask-buttons ( buttons -- quot ) dup length [
+ [ swap
+ [ 22 wrap-lines <label> T{ font { name "sans-serif" } { size 18 } } >>font ,
+ [ [ <model-border-btn> [ close-window ] >>hook -> ] map ] <hbox> , ] <vbox>
+ "" open-window
+ ] dip firstn
+ ] 2curry ;
\ No newline at end of file
: |<< ( book -- ) 0 swap set-control-value ;
: next ( book -- ) model>> [ 1 + ] change-model ;
: prev ( book -- ) model>> [ 1 - ] change-model ;
-: (book-t) ( quot -- quot ) '[ : owner ( gadget -- book ) parent>> dup book? [ owner ] unless ; owner @ ] ;
+: owner ( gadget -- book ) parent>> dup book? [ owner ] unless ;
+: (book-t) ( quot -- quot ) '[ owner @ ] ;
: <book-btn> ( label quot -- button ) (book-t) <button> ;
-: <book-bevel-btn> ( label quot -- button ) (book-t) <border-button> ;
-: >>> ( label -- button ) [ next ] <book-btn> ;
-: <<< ( label -- button ) [ prev ] <book-btn> ;
\ No newline at end of file
+: <book-border-btn> ( label quot -- button ) (book-t) <border-button> ;
+: >>> ( gadget -- ) owner next ;
+: <<< ( gadget -- ) owner prev ;
+: go-to ( gadget number -- ) swap owner model>> set-model ;
+
+: <forward-btn> ( label -- button ) [ >>> ] <button> ;
+: <backward-btn> ( label -- button ) [ <<< ] <button> ;
-USING: accessors arrays kernel math.rectangles models sequences
-ui.frp ui.gadgets ui.gadgets.glass ui.gadgets.labels
-ui.gadgets.tables ui.gestures ;
+USING: accessors arrays kernel math.rectangles sequences
+ui.gadgets.controls models.combinators ui.gadgets ui.gadgets.glass
+ui.gadgets.labels ui.gestures ;
+QUALIFIED-WITH: ui.gadgets.tables tbl
IN: ui.gadgets.comboboxes
TUPLE: combo-table < table spawner ;
-M: combo-table handle-gesture [ call-next-method ] 2keep swap
+M: combo-table handle-gesture [ call-next-method drop ] 2keep swap
T{ button-up } = [
[ spawner>> ]
- [ selected-value>> value>> [ swap set-control-value ] [ drop ] if* ]
- [ hide-glass ] tri drop t
- ] [ drop ] if ;
+ [ tbl:selected-row [ swap set-control-value ] [ 2drop ] if ]
+ [ hide-glass ] tri
+ ] [ drop ] if t ;
TUPLE: combobox < label-control table ;
combobox H{
{ T{ button-down } [ dup table>> over >>spawner <zero-rect> show-glass ] }
} set-gestures
-: <combobox> ( options -- combobox ) [ first [ combobox new-label ] keep <model> >>model ] keep
- [ 1array ] map <model> trivial-renderer combo-table new-table
- >>table ;
\ No newline at end of file
+: <combobox> ( options -- combobox ) [ first [ combobox new-label ] keep <basic> >>model ] keep
+ <basic> combo-table new-table [ 1array ] >>quot >>table ;
\ No newline at end of file
--- /dev/null
+Sam Anklesaria
--- /dev/null
+USING: accessors help.markup help.syntax ui.gadgets.buttons
+ui.gadgets.editors models ui.gadgets ;
+IN: ui.gadgets.controls
+
+HELP: <model-btn>
+{ $values { "gadget" "the button's label" } { "button" button } }
+{ $description "Creates an button whose signal updates on clicks. " } ;
+
+HELP: <model-border-btn>
+{ $values { "text" "the button's label" } { "button" button } }
+{ $description "Creates an button whose signal updates on clicks. " } ;
+
+HELP: <table>
+{ $values { "model" "values the table is to display" } { "table" table } }
+{ $description "Creates an " { $link table } } ;
+
+HELP: <table*>
+{ $values { "table" table } }
+{ $description "Creates an " { $link table } " with no initial values to display" } ;
+
+HELP: <list>
+{ $values { "column-model" "values the table is to display" } { "table" table } }
+{ $description "Creates an " { $link table } " with a val-quot that renders each element as its own row" } ;
+
+HELP: <list*>
+{ $values { "table" table } }
+{ $description "Creates an model-list with no initial values to display" } ;
+
+HELP: indexed
+{ $values { "table" table } }
+{ $description "Sets the output model of an table to the selected-index, rather than the selected-value" } ;
+
+HELP: <model-field>
+{ $values { "model" model } { "gadget" model-field } }
+{ $description "Creates a field with an initial value" } ;
+
+HELP: <model-field*>
+{ $values { "field" model-field } }
+{ $description "Creates a field with an empty initial value" } ;
+
+HELP: <empty-field>
+{ $values { "model" model } { "field" model-field } }
+{ $description "Creates a field with an empty initial value that switches to another signal on its update" } ;
+
+HELP: <model-editor>
+{ $values { "model" model } { "gadget" model-field } }
+{ $description "Creates an editor with an initial value" } ;
+
+HELP: <model-editor*>
+{ $values { "editor" "an editor" } }
+{ $description "Creates a editor with an empty initial value" } ;
+
+HELP: <empty-editor>
+{ $values { "model" model } { "editor" "an editor" } }
+{ $description "Creates a field with an empty initial value that switches to another signal on its update" } ;
+
+HELP: <model-action-field>
+{ $values { "field" action-field } }
+{ $description "Field that updates its model with its contents when the user hits the return key" } ;
+
+HELP: IMG-MODEL-BTN:
+{ $syntax "IMAGE-MODEL-BTN: filename" }
+{ $description "Creates a button using a tiff image named as specified found in the icons subdirectory of the vocabulary path" } ;
+
+HELP: IMG-BTN:
+{ $syntax "[ do-something ] IMAGE-BTN: filename" }
+{ $description "Creates a button using a tiff image named as specified found in the icons subdirectory of the vocabulary path, calling the specified quotation on click" } ;
+
+HELP: output-model
+{ $values { "gadget" gadget } { "model" model } }
+{ $description "Returns the model a gadget uses for output. Often the same as " { $link model>> } } ;
\ No newline at end of file
--- /dev/null
+USING: accessors assocs arrays kernel models monads sequences
+models.combinators ui.gadgets ui.gadgets.borders ui.gadgets.buttons
+ui.gadgets.buttons.private ui.gadgets.editors words images.loader
+ui.gadgets.scrollers ui.images vocabs.parser lexer
+models.range ui.gadgets.sliders ;
+QUALIFIED-WITH: ui.gadgets.sliders slider
+QUALIFIED-WITH: ui.gadgets.tables tbl
+EXCLUDE: ui.gadgets.editors => model-field ;
+IN: ui.gadgets.controls
+
+TUPLE: model-btn < button hook value ;
+: <model-btn> ( gadget -- button ) [
+ [ dup hook>> [ call( button -- ) ] [ drop ] if* ]
+ [ [ [ value>> ] [ ] bi or ] keep set-control-value ]
+ [ model>> f swap (>>value) ] tri
+ ] model-btn new-button f <basic> >>model ;
+: <model-border-btn> ( text -- button ) <model-btn> border-button-theme ;
+
+TUPLE: table < tbl:table { quot initial: [ ] } { val-quot initial: [ ] } color-quot column-titles column-alignment actions ;
+M: table tbl:column-titles column-titles>> ;
+M: table tbl:column-alignment column-alignment>> ;
+M: table tbl:row-columns quot>> [ call( a -- b ) ] [ drop f ] if* ;
+M: table tbl:row-value val-quot>> [ call( a -- b ) ] [ drop f ] if* ;
+M: table tbl:row-color color-quot>> [ call( a -- b ) ] [ drop f ] if* ;
+
+: new-table ( model class -- table ) f swap tbl:new-table dup >>renderer
+ f <basic> >>actions dup actions>> [ set-model ] curry >>action ;
+: <table> ( model -- table ) table new-table ;
+: <table*> ( -- table ) V{ } clone <model> <table> ;
+: <list> ( column-model -- table ) <table> [ 1array ] >>quot ;
+: <list*> ( -- table ) V{ } clone <model> <list> ;
+: indexed ( table -- table ) f >>val-quot ;
+
+TUPLE: model-field < field model* ;
+: init-field ( model -- model' ) [ [ ] [ "" ] if* ] change-value ;
+: <model-field> ( model -- gadget ) model-field new-field swap init-field >>model* ;
+M: model-field graft*
+ [ [ model*>> value>> ] [ editor>> ] bi set-editor-string ]
+ [ dup editor>> model>> add-connection ]
+ [ dup model*>> add-connection ] tri ;
+M: model-field ungraft*
+ [ dup editor>> model>> remove-connection ]
+ [ dup model*>> remove-connection ] bi ;
+M: model-field model-changed 2dup model*>> =
+ [ [ value>> ] [ editor>> ] bi* set-editor-string ]
+ [ nip [ editor>> editor-string ] [ model*>> ] bi set-model ] if ;
+
+: (new-field) ( editor field -- gadget ) [ new-editor ] dip new-border dup gadget-child >>editor
+ field-theme { 1 0 } >>align ; inline
+: <model-field*> ( -- field ) "" <model> <model-field> ;
+: <empty-field> ( model -- field ) "" <model> switch-models <model-field> ;
+: <model-editor> ( model -- gadget ) multiline-editor model-field (new-field) swap init-field >>model* ;
+: <model-editor*> ( -- editor ) "" <model> <model-editor> ;
+: <empty-editor> ( model -- editor ) "" <model> switch-models <model-editor> ;
+
+: <model-action-field> ( -- field ) f <action-field> dup [ set-control-value ] curry >>quot
+ f <model> >>model ;
+
+: <slider> ( init page min max step -- slider ) <range> horizontal slider:<slider> ;
+
+: image-prep ( -- image ) scan current-vocab name>> "vocab:" "/icons/" surround ".tiff" surround <image-name> dup cached-image drop ;
+SYNTAX: IMG-MODEL-BTN: image-prep [ <model-btn> ] curry over push-all ;
+
+SYNTAX: IMG-BTN: image-prep [ swap <button> ] curry over push-all ;
+
+GENERIC: output-model ( gadget -- model )
+M: gadget output-model model>> ;
+M: table output-model dup val-quot>> [ selection>> ] [ selection-index>> ] if ;
+M: model-field output-model model*>> ;
+M: scroller output-model viewport>> children>> first output-model ;
+M: slider output-model model>> range-model ;
+
+IN: accessors
+M: model-btn text>> children>> first text>> ;
+
+IN: ui.gadgets.controls
+
+SINGLETON: gadget-monad
+INSTANCE: gadget-monad monad
+INSTANCE: gadget monad
+M: gadget monad-of drop gadget-monad ;
+M: gadget-monad return drop <gadget> swap >>model ;
+M: gadget >>= output-model [ swap call( x -- y ) ] curry ;
\ No newline at end of file
--- /dev/null
+Gadgets with expanded model usage
\ No newline at end of file
--- /dev/null
+Sam Anklesaria
--- /dev/null
+USING: help.markup help.syntax models ui.gadgets.tracks ;
+IN: ui.gadgets.layout
+
+HELP: ,
+{ $values { "item" "a gadget or model" } }
+{ $description "Used in a series of gadgets created by a box, accumulating the gadget" } ;
+
+HELP: ,%
+{ $syntax "gadget ,% width" }
+{ $description "Like ',' but stretches the gadget to always fill a percent of the parent" } ;
+
+HELP: ->
+{ $values { "uiitem" "a gadget or model" } { "model" model } }
+{ $description "Like ',' but passes its model on for further use." } ;
+
+HELP: ->%
+{ $syntax "gadget ,% width" }
+{ $description "Like '->' but stretches the gadget to always fill a percent of the parent" } ;
+
+HELP: <spacer>
+{ $description "Grows to fill any empty space in a box" } ;
+
+HELP: <hbox>
+{ $values { "gadgets" "a list of gadgets" } { "track" track } }
+{ $syntax "[ gadget , gadget , ... ] <hbox>" }
+{ $description "Creates an horizontal track containing the gadgets listed in the quotation" } ;
+
+HELP: <vbox>
+{ $values { "gadgets" "a list of gadgets" } { "track" track } }
+{ $syntax "[ gadget , gadget , ... ] <hbox>" }
+{ $description "Creates an vertical track containing the gadgets listed in the quotation" } ;
+
+HELP: $
+{ $syntax "$ PLACEHOLDER-NAME $" }
+{ $description "Defines an insertion point in a template named PLACEHOLDER-NAME which can be used by calling its name" } ;
+
+HELP: with-interface
+{ $values { "quot" "quotation that builds a template and inserts into it" } }
+{ $description "Create templates, used with " { $link POSTPONE: $ } } ;
+
+ARTICLE: "ui.gadgets.layout" "GUI Layout"
+"Laying out GUIs works the same way as building lists with " { $vocab-link "make" }
+". Gadgets are layed out using " { $vocab-link "ui.gadgets.tracks" } " through " { $link <hbox> } " and " { $link <vbox> } ", which allow both fixed and percentage widths. "
+{ $link , } " and " { $link -> } " add a model or gadget to the gadget you're building. "
+"Also, books can be made with " { $link <book> } ". "
+{ $link <spacer> } "s add flexable space between items. " $nl
+"Using " { $link with-interface } ", one can pre-build templates to add items to later: "
+"Like in the StringTemplate framework for java, placeholders are defined using $ PLACERHOLDER-NAME $ "
+"Using PLACEHOLDER-NAME again sets it as the current insertion point. "
+"For examples using normal layout, see the " { $vocab-link "sudokus" } " demo. "
+"For examples of templating, see the " { $vocab-link "recipes" } " demo. " ;
+
+ABOUT: "ui.gadgets.layout"
\ No newline at end of file
--- /dev/null
+USING: accessors assocs arrays fry kernel lexer make math.parser
+models monads namespaces parser sequences
+sequences.extras models.combinators ui.gadgets
+ui.gadgets.tracks words ui.gadgets.controls ;
+QUALIFIED: make
+QUALIFIED-WITH: ui.gadgets.books book
+IN: ui.gadgets.layout
+
+SYMBOL: templates
+TUPLE: layout gadget size ; C: <layout> layout
+TUPLE: placeholder < gadget members ;
+: <placeholder> ( -- placeholder ) placeholder new V{ } clone >>members ;
+
+: (remove-members) ( placeholder members -- ) [ [ model? ] filter swap parent>> model>> [ remove-connection ] curry each ]
+ [ nip [ gadget? ] filter [ unparent ] each ] 2bi ;
+
+: remove-members ( placeholder -- ) dup members>> [ drop ] [ [ (remove-members) ] keep delete-all ] if-empty ;
+: add-member ( obj placeholder -- ) over layout? [ [ gadget>> ] dip ] when members>> push ;
+
+: , ( item -- ) make:, ;
+: make* ( quot -- list ) { } make ; inline
+
+! Just take the previous mentioned placeholder and use it
+! If there is no previously mentioned placeholder, we're probably making a box, and will create the placeholder ourselves
+DEFER: with-interface
+: insertion-quot ( quot -- quot' ) make:building get [ [ placeholder? ] find-last nip [ <placeholder> dup , ] unless*
+ templates get spin '[ [ _ templates set _ , @ ] with-interface ] ] when* ;
+
+SYNTAX: ,% scan string>number [ <layout> , ] curry over push-all ;
+SYNTAX: ->% scan string>number '[ [ _ <layout> , ] [ output-model ] bi ] over push-all ;
+
+GENERIC: -> ( uiitem -- model )
+M: gadget -> dup , output-model ;
+M: model -> dup , ;
+
+: <spacer> ( -- ) <gadget> 1 <layout> , ;
+
+: add-layout ( track layout -- track ) [ gadget>> ] [ size>> ] bi track-add ;
+: layouts ( sized? gadgets -- layouts ) [ [ gadget? ] [ layout? ] bi or ] filter swap
+ [ [ dup layout? [ f <layout> ] unless ] map ]
+ [ [ dup gadget? [ gadget>> ] unless ] map ] if ;
+: make-layout ( building sized? -- models layouts ) [ swap layouts ] curry
+ [ make* [ [ model? ] filter ] ] dip bi ; inline
+: <box> ( gadgets type -- track )
+ [ t make-layout ] dip <track>
+ swap [ add-layout ] each
+ swap [ <collection> >>model ] unless-empty ; inline
+: <hbox> ( gadgets -- track ) horizontal <box> ; inline
+: <vbox> ( gadgets -- track ) vertical <box> ; inline
+
+: make-book ( models gadgets model -- book ) book:<book> swap [ "No models in books" throw ] unless-empty ;
+: <book> ( quot: ( -- model ) -- book ) f make-layout rot 0 >>value make-book ; inline
+: <book*> ( quot -- book ) f make-layout f make-book ; inline
+
+ERROR: not-in-template word ;
+SYNTAX: $ CREATE-WORD dup
+ [ [ dup templates get at [ nip , ] [ not-in-template ] if* ] curry (( -- )) define-declared "$" expect ]
+ [ [ <placeholder> [ swap templates get set-at ] keep , ] curry ] bi over push-all ;
+
+: insert-gadget ( number parent gadget -- ) -rot [ but-last insert-nth ] change-children drop ;
+: insert-size ( number parent size -- ) -rot [ but-last insert-nth ] change-sizes drop ;
+: insertion-point ( placeholder -- number parent ) dup parent>> [ children>> index ] keep ;
+
+GENERIC: >layout ( gadget -- layout )
+M: gadget >layout f <layout> ;
+M: layout >layout ;
+
+GENERIC# (add-gadget-at) 2 ( parent item n -- )
+M: gadget (add-gadget-at) -rot [ add-gadget ] keep insert-gadget ;
+M: track (add-gadget-at) -rot >layout [ add-layout ] keep [ gadget>> insert-gadget ] [ size>> insert-size ] 3bi ;
+
+GENERIC# add-gadget-at 1 ( item location -- )
+M: object add-gadget-at insertion-point -rot (add-gadget-at) ;
+M: model add-gadget-at parent>> dup book:book? [ "No models in books" throw ]
+ [ dup model>> dup collection? [ nip swap add-connection ] [ drop [ 1array <collection> ] dip (>>model) ] if ] if ;
+: track-add-at ( item location size -- ) swap [ <layout> ] dip add-gadget-at ;
+: (track-add-at) ( parent item n size -- ) swap [ <layout> ] dip (add-gadget-at) ;
+
+: insert-item ( item location -- ) [ dup get [ drop ] [ remove-members ] if ] [ on ] [ ] tri
+ [ add-member ] 2keep add-gadget-at ;
+
+: insert-items ( makelist -- ) t swap [ dup placeholder? [ nip ] [ over insert-item ] if ] each drop ;
+
+: with-interface ( quot -- ) [ make* ] curry H{ } clone templates rot with-variable [ insert-items ] with-scope ; inline
+
+M: model >>= [ swap insertion-quot <action> ] curry ;
+M: model fmap insertion-quot <mapped> ;
+M: model $> insertion-quot side-effect-model new-mapped-model ;
+M: model <$ insertion-quot quot-model new-mapped-model ;
\ No newline at end of file
--- /dev/null
+Syntax for easily building GUIs and using templates
\ No newline at end of file
--- /dev/null
+Sam Anklesaria
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Sam Anklesaria
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays accessors combinators kernel math
+models models.combinators namespaces sequences
+ui.gadgets ui.gadgets.controls ui.gadgets.layout
+ui.gadgets.tracks ui.gestures ui.gadgets.line-support ;
+EXCLUDE: ui.gadgets.editors => model-field ;
+IN: ui.gadgets.poppers
+
+TUPLE: popped < model-field { fatal? initial: t } ;
+TUPLE: popped-editor < multiline-editor ;
+: <popped> ( text -- gadget ) <basic> init-field popped-editor popped (new-field) swap >>model* ;
+
+: set-expansion ( popped size -- ) over dup parent>> [ children>> index ] [ sizes>> ] bi set-nth relayout ;
+: new-popped ( popped -- ) insertion-point "" <popped>
+ [ rot 1 + f (track-add-at) ] keep [ relayout ] [ request-focus ] bi ;
+: focus-prev ( popped -- ) dup parent>> children>> length 1 =
+ [ drop ] [
+ insertion-point [ 1 - dup -1 = [ drop 1 ] when ] [ children>> ] bi* nth
+ [ request-focus ] [ editor>> end-of-document ] bi
+ ] if ;
+: initial-popped ( popper -- ) "" <popped> [ f track-add drop ] keep request-focus ;
+
+TUPLE: popper < track { unfocus-hook initial: [ drop ] } ;
+! list of strings is model (make shown objects implement sequence protocol)
+: <popper> ( model -- popper ) vertical popper new-track swap >>model ;
+
+M: popped handle-gesture swap {
+ { gain-focus [ 1 set-expansion f ] }
+ { lose-focus [ dup parent>>
+ [ [ unfocus-hook>> call( a -- ) ] curry [ f set-expansion ] bi ]
+ [ drop ] if* f
+ ] }
+ { T{ key-up f f "RET" } [ dup editor>> delete-previous-character new-popped f ] }
+ { T{ key-up f f "BACKSPACE" } [ dup editor>> editor-string "" =
+ [ dup fatal?>> [ [ focus-prev ] [ unparent ] bi ] [ t >>fatal? drop ] if ]
+ [ f >>fatal? drop ] if f
+ ] }
+ [ swap call-next-method ]
+} case ;
+
+M: popper handle-gesture swap T{ button-down f f 1 } =
+ [ hand-click# get 2 = [ initial-popped ] [ drop ] if ] [ drop ] if f ;
+
+M: popper model-changed
+ [ children>> [ unparent ] each ]
+ [ [ value>> [ <popped> ] map ] dip [ f track-add ] reduce request-focus ] bi ;
+
+M: popped pref-dim* editor>> [ pref-dim* first ] [ line-height ] bi 2array ;
+M: popper focusable-child* children>> [ t ] [ first ] if-empty ;
\ No newline at end of file
>>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
--- /dev/null
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<plist version="1.0">
+<dict>
+ <key>beforeRunningCommand</key>
+ <string>nop</string>
+ <key>bundleUUID</key>
+ <string>8061D2F3-B603-411D-AFFE-61784A07906D</string>
+ <key>command</key>
+ <string>#!/usr/bin/env ruby
+require "#{ENV["TM_BUNDLE_SUPPORT"]}/lib/tm_factor"
+
+x = ENV["TM_FILEPATH"][/\/([^\/]+\.factor)/,1]
+y = x.sub("-tests","").sub("docs", "tests")
+if x == y then
+ z = x.sub(".factor","")
+ factor_eval(%Q(USING: tools.scaffold #{z} ;\n"#{z}" scaffold-help))
+ y = x.sub(".factor", "-docs.factor")
+end
+exec "mate #{ENV["TM_FILEPATH"][/(.*\/)[^\/]+\.factor/,1] << y}"</string>
+ <key>fallbackInput</key>
+ <string>word</string>
+ <key>input</key>
+ <string>none</string>
+ <key>keyEquivalent</key>
+ <string>^@`</string>
+ <key>name</key>
+ <string>Cycle Vocabs/Docs/Tests</string>
+ <key>output</key>
+ <string>discard</string>
+ <key>scope</key>
+ <string>source.factor</string>
+ <key>uuid</key>
+ <string>D348BE40-6F51-4471-B300-DDDA70ED8C8C</string>
+</dict>
+</plist>
--- /dev/null
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<plist version="1.0">
+<dict>
+ <key>beforeRunningCommand</key>
+ <string>nop</string>
+ <key>bundleUUID</key>
+ <string>8061D2F3-B603-411D-AFFE-61784A07906D</string>
+ <key>command</key>
+ <string>#!/usr/bin/env ruby
+
+require "#{ENV["TM_BUNDLE_SUPPORT"]}/lib/tm_factor"
+
+doc = STDIN.read
+word = line_current_word(ENV["TM_CURRENT_LINE"], ENV["TM_LINE_INDEX"].to_i)
+puts factor_eval(%Q(#{doc_using_statements(doc)} USE: editors\n "#{word}" edit-vocab))</string>
+ <key>fallbackInput</key>
+ <string>word</string>
+ <key>input</key>
+ <string>document</string>
+ <key>keyEquivalent</key>
+ <string>@V</string>
+ <key>name</key>
+ <string>Edit Vocab</string>
+ <key>output</key>
+ <string>discard</string>
+ <key>scope</key>
+ <string>source.factor</string>
+ <key>uuid</key>
+ <string>0034EC1C-DAD1-498F-82FD-BEF7015F84EE</string>
+</dict>
+</plist>
--- /dev/null
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<plist version="1.0">
+<dict>
+ <key>beforeRunningCommand</key>
+ <string>nop</string>
+ <key>bundleUUID</key>
+ <string>8061D2F3-B603-411D-AFFE-61784A07906D</string>
+ <key>command</key>
+ <string>#!/usr/bin/env ruby
+
+require "#{ENV["TM_BUNDLE_SUPPORT"]}/lib/tm_factor"
+
+doc = STDIN.read
+word = line_current_word(ENV["TM_CURRENT_LINE"], ENV["TM_LINE_INDEX"].to_i)
+puts factor_eval(%Q(#{doc_using_statements(doc)} USING: help.topics editors ;\n \\ #{word} >link edit))</string>
+ <key>fallbackInput</key>
+ <string>word</string>
+ <key>input</key>
+ <string>document</string>
+ <key>keyEquivalent</key>
+ <string>@D</string>
+ <key>name</key>
+ <string>Edit Word Docs</string>
+ <key>output</key>
+ <string>discard</string>
+ <key>scope</key>
+ <string>source.factor</string>
+ <key>uuid</key>
+ <string>D95A617C-E1C6-44DA-9126-04171CB21299</string>
+</dict>
+</plist>
--- /dev/null
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<plist version="1.0">
+<dict>
+ <key>beforeRunningCommand</key>
+ <string>nop</string>
+ <key>bundleUUID</key>
+ <string>8061D2F3-B603-411D-AFFE-61784A07906D</string>
+ <key>command</key>
+ <string>#!/usr/bin/env ruby
+
+require "#{ENV["TM_BUNDLE_SUPPORT"]}/lib/tm_factor"
+
+doc = STDIN.read
+word = line_current_word(ENV["TM_CURRENT_LINE"], ENV["TM_LINE_INDEX"].to_i)
+puts factor_eval(%Q(#{doc_using_statements(doc)} USE: editors\n \\ #{word} edit))</string>
+ <key>fallbackInput</key>
+ <string>word</string>
+ <key>input</key>
+ <string>document</string>
+ <key>keyEquivalent</key>
+ <string>@E</string>
+ <key>name</key>
+ <string>Edit Word</string>
+ <key>output</key>
+ <string>discard</string>
+ <key>scope</key>
+ <string>source.factor</string>
+ <key>uuid</key>
+ <string>C573487C-DD7D-497F-A728-52D7962D95E2</string>
+</dict>
+</plist>
--- /dev/null
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<plist version="1.0">
+<dict>
+ <key>beforeRunningCommand</key>
+ <string>nop</string>
+ <key>bundleUUID</key>
+ <string>8061D2F3-B603-411D-AFFE-61784A07906D</string>
+ <key>command</key>
+ <string>#!/usr/bin/env ruby
+
+require "#{ENV["TM_BUNDLE_SUPPORT"]}/lib/tm_factor"
+
+doc = STDIN.read
+puts factor_eval(%Q(#{doc_using_statements(doc)} USE: ui.tools.operations\n [ #{ENV["TM_SELECTED_TEXT"} ] com-expand-macros))</string>
+ <key>fallbackInput</key>
+ <string>word</string>
+ <key>input</key>
+ <string>document</string>
+ <key>name</key>
+ <string>Expand Selection</string>
+ <key>output</key>
+ <string>showAsTooltip</string>
+ <key>scope</key>
+ <string>source.factor</string>
+ <key>uuid</key>
+ <string>8465B33D-7CA0-4337-945C-4078346D64BC</string>
+</dict>
+</plist>
--- /dev/null
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<plist version="1.0">
+<dict>
+ <key>beforeRunningCommand</key>
+ <string>nop</string>
+ <key>bundleUUID</key>
+ <string>8061D2F3-B603-411D-AFFE-61784A07906D</string>
+ <key>command</key>
+ <string>#!/usr/bin/env ruby
+
+require "#{ENV["TM_BUNDLE_SUPPORT"]}/lib/tm_factor"
+
+doc = STDIN.read
+word = line_current_word(ENV["TM_CURRENT_LINE"], ENV["TM_LINE_INDEX"].to_i)
+puts factor_run(%Q(#{doc_using_statements(doc)} USE: editors\n \\ #{word} fix))</string>
+ <key>fallbackInput</key>
+ <string>word</string>
+ <key>input</key>
+ <string>document</string>
+ <key>keyEquivalent</key>
+ <string>@F</string>
+ <key>name</key>
+ <string>Fix Word</string>
+ <key>output</key>
+ <string>discard</string>
+ <key>scope</key>
+ <string>source.factor</string>
+ <key>uuid</key>
+ <string>D02D9D74-E073-48AE-A78E-B40FFFA519D5</string>
+</dict>
+</plist>
doc = STDIN.read
word = line_current_word(ENV["TM_CURRENT_LINE"], ENV["TM_LINE_INDEX"].to_i)
-factor_run(%Q(#{doc_using_statements(doc)} USE: ui.tools.workspace\n \\ #{word} help-window))</string>
+factor_run(%Q(#{doc_using_statements(doc)} USE: help\n \\ #{word} help))</string>
<key>fallbackInput</key>
<string>word</string>
<key>input</key>
+++ /dev/null
-<?xml version="1.0" encoding="UTF-8"?>
-<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
-<plist version="1.0">
-<dict>
- <key>beforeRunningCommand</key>
- <string>nop</string>
- <key>command</key>
- <string>#!/usr/bin/env ruby
-
-require "#{ENV["TM_BUNDLE_SUPPORT"]}/lib/tm_factor"
-
-doc = STDIN.read
-puts factor_eval(%Q(#{doc_using_statements(doc)} USE: inference\n [ #{ENV["TM_SELECTED_TEXT"]} ] infer.))</string>
- <key>fallbackInput</key>
- <string>word</string>
- <key>input</key>
- <string>document</string>
- <key>name</key>
- <string>Infer Effect of Selection</string>
- <key>output</key>
- <string>showAsTooltip</string>
- <key>scope</key>
- <string>source.factor</string>
- <key>uuid</key>
- <string>B619FCC0-2DF2-4657-82A8-0E5676A10254</string>
-</dict>
-</plist>
--- /dev/null
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<plist version="1.0">
+<dict>
+ <key>beforeRunningCommand</key>
+ <string>nop</string>
+ <key>command</key>
+ <string>#!/usr/bin/env ruby
+
+require "#{ENV["TM_BUNDLE_SUPPORT"]}/lib/tm_factor"
+
+doc = STDIN.read
+puts factor_eval(%Q(#{doc_using_statements(doc)} USE: stack-checker\n [ #{ENV["TM_SELECTED_TEXT"]} ] infer.))</string>
+ <key>fallbackInput</key>
+ <string>word</string>
+ <key>input</key>
+ <string>document</string>
+ <key>keyEquivalent</key>
+ <string>^i</string>
+ <key>name</key>
+ <string>Infer Selection</string>
+ <key>output</key>
+ <string>showAsTooltip</string>
+ <key>scope</key>
+ <string>source.factor</string>
+ <key>uuid</key>
+ <string>B619FCC0-2DF2-4657-82A8-0E5676A10254</string>
+</dict>
+</plist>
--- /dev/null
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<plist version="1.0">
+<dict>
+ <key>beforeRunningCommand</key>
+ <string>nop</string>
+ <key>command</key>
+ <string>#!/usr/bin/env ruby
+
+require "#{ENV["TM_BUNDLE_SUPPORT"]}/lib/tm_factor"
+
+doc = STDIN.read
+puts factor_eval(%Q(#{doc_using_statements(doc)} USE: stack-checker\n [ #{ENV["TM_SELECTED_TEXT"]} ] infer.))</string>
+ <key>fallbackInput</key>
+ <string>word</string>
+ <key>input</key>
+ <string>document</string>
+ <key>name</key>
+ <string>Insert Inferrence</string>
+ <key>output</key>
+ <string>afterSelectedText</string>
+ <key>scope</key>
+ <string>source.factor</string>
+ <key>uuid</key>
+ <string>DBC0A0CA-5368-43A7-864B-7B9C4034AD08</string>
+</dict>
+</plist>
--- /dev/null
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<plist version="1.0">
+<dict>
+ <key>beforeRunningCommand</key>
+ <string>nop</string>
+ <key>bundleUUID</key>
+ <string>8061D2F3-B603-411D-AFFE-61784A07906D</string>
+ <key>command</key>
+ <string>#!/usr/bin/env ruby
+
+require "#{ENV["TM_BUNDLE_SUPPORT"]}/lib/tm_factor"
+
+doc = STDIN.read
+word = line_current_word(ENV["TM_CURRENT_LINE"], ENV["TM_LINE_INDEX"].to_i)
+puts factor_run(%Q(#{doc_using_statements(doc)} USE: tools.profiler\n [ #{word} ] profile))</string>
+ <key>fallbackInput</key>
+ <string>word</string>
+ <key>input</key>
+ <string>document</string>
+ <key>keyEquivalent</key>
+ <string>^p</string>
+ <key>name</key>
+ <string>Profile</string>
+ <key>output</key>
+ <string>discard</string>
+ <key>scope</key>
+ <string>source.factor</string>
+ <key>uuid</key>
+ <string>7FF52332-CA5B-4D46-99EF-DAE0659DB478</string>
+</dict>
+</plist>
--- /dev/null
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<plist version="1.0">
+<dict>
+ <key>beforeRunningCommand</key>
+ <string>nop</string>
+ <key>command</key>
+ <string>#!/usr/bin/env ruby
+
+require "#{ENV["TM_BUNDLE_SUPPORT"]}/lib/tm_factor"
+doc = STDIN.read
+factor_run(%Q(USE: vocabs.loader\n "#{doc[/\bIN:\s(\S+)/, 1]}" reload))</string>
+ <key>input</key>
+ <string>document</string>
+ <key>keyEquivalent</key>
+ <string>^r</string>
+ <key>name</key>
+ <string>Reload in Listener</string>
+ <key>output</key>
+ <string>discard</string>
+ <key>scope</key>
+ <string>source.factor</string>
+ <key>uuid</key>
+ <string>8088D204-FFD7-4384-8FDD-A01536FFD0E7</string>
+</dict>
+</plist>
--- /dev/null
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<plist version="1.0">
+<dict>
+ <key>beforeRunningCommand</key>
+ <string>nop</string>
+ <key>bundleUUID</key>
+ <string>8061D2F3-B603-411D-AFFE-61784A07906D</string>
+ <key>command</key>
+ <string>#!/usr/bin/env ruby
+
+require "#{ENV["TM_BUNDLE_SUPPORT"]}/lib/tm_factor"
+
+doc = STDIN.read
+word = line_current_word(ENV["TM_CURRENT_LINE"], ENV["TM_LINE_INDEX"].to_i)
+puts factor_eval(%Q(#{doc_using_statements(doc)} USE: tools.annotations\n \\ #{word} reset))</string>
+ <key>fallbackInput</key>
+ <string>word</string>
+ <key>input</key>
+ <string>document</string>
+ <key>keyEquivalent</key>
+ <string>^~r</string>
+ <key>name</key>
+ <string>Reset Word</string>
+ <key>output</key>
+ <string>discard</string>
+ <key>scope</key>
+ <string>source.factor</string>
+ <key>uuid</key>
+ <string>71F08D9B-3D24-4E78-84C9-82CA736554D1</string>
+</dict>
+</plist>
doc = STDIN.read
word = line_current_word(ENV["TM_CURRENT_LINE"], ENV["TM_LINE_INDEX"].to_i)
-puts factor_eval(%Q(#{doc_using_statements(doc)} USE: prettyprint\n \\ #{word} see))</string>
+puts factor_eval(%Q(#{doc_using_statements(doc)} USE: see\n \\ #{word} see))</string>
<key>fallbackInput</key>
<string>word</string>
<key>input</key>
--- /dev/null
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<plist version="1.0">
+<dict>
+ <key>beforeRunningCommand</key>
+ <string>nop</string>
+ <key>bundleUUID</key>
+ <string>8061D2F3-B603-411D-AFFE-61784A07906D</string>
+ <key>command</key>
+ <string>#!/usr/bin/env ruby
+
+require "#{ENV["TM_BUNDLE_SUPPORT"]}/lib/tm_factor"
+
+doc = STDIN.read
+word = line_current_word(ENV["TM_CURRENT_LINE"], ENV["TM_LINE_INDEX"].to_i)
+puts factor_eval(%Q(#{doc_using_statements(doc)} USE: tools.annotations\n \\ #{word} breakpoint))</string>
+ <key>fallbackInput</key>
+ <string>word</string>
+ <key>input</key>
+ <string>document</string>
+ <key>keyEquivalent</key>
+ <string>^b</string>
+ <key>name</key>
+ <string>Set Breakpoint</string>
+ <key>output</key>
+ <string>discard</string>
+ <key>scope</key>
+ <string>source.factor</string>
+ <key>uuid</key>
+ <string>E4614756-DF2E-433A-8935-197159C67AB8</string>
+</dict>
+</plist>
--- /dev/null
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<plist version="1.0">
+<dict>
+ <key>beforeRunningCommand</key>
+ <string>nop</string>
+ <key>command</key>
+ <string>#!/usr/bin/env ruby
+
+require "#{ENV["TM_BUNDLE_SUPPORT"]}/lib/tm_factor"
+
+factor_run(%Q(USING: namespaces parser ;
+auto-use? t set "#{ENV["TM_FILEPATH"]}" run-file auto-use? f set))</string>
+ <key>fallbackInput</key>
+ <string>word</string>
+ <key>input</key>
+ <string>none</string>
+ <key>keyEquivalent</key>
+ <string>^u</string>
+ <key>name</key>
+ <string>Show Using</string>
+ <key>output</key>
+ <string>discard</string>
+ <key>scope</key>
+ <string>source.factor</string>
+ <key>uuid</key>
+ <string>93AF1721-C14D-428A-B5A0-34CEFAA3B3C5</string>
+</dict>
+</plist>
--- /dev/null
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<plist version="1.0">
+<dict>
+ <key>beforeRunningCommand</key>
+ <string>nop</string>
+ <key>bundleUUID</key>
+ <string>8061D2F3-B603-411D-AFFE-61784A07906D</string>
+ <key>command</key>
+ <string>#!/usr/bin/env ruby
+
+require "#{ENV["TM_BUNDLE_SUPPORT"]}/lib/tm_factor"
+
+doc = STDIN.read
+word = line_current_word(ENV["TM_CURRENT_LINE"], ENV["TM_LINE_INDEX"].to_i)
+puts factor_eval(%Q(#{doc_using_statements(doc)} USE: tools.crossref\n \\ #{word} usage.))</string>
+ <key>fallbackInput</key>
+ <string>word</string>
+ <key>input</key>
+ <string>document</string>
+ <key>name</key>
+ <string>Usage</string>
+ <key>output</key>
+ <string>showAsTooltip</string>
+ <key>scope</key>
+ <string>source.factor</string>
+ <key>uuid</key>
+ <string>3043A033-A113-4283-BCBB-3DE2CCC8F63E</string>
+</dict>
+</plist>
--- /dev/null
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<plist version="1.0">
+<dict>
+ <key>beforeRunningCommand</key>
+ <string>nop</string>
+ <key>bundleUUID</key>
+ <string>8061D2F3-B603-411D-AFFE-61784A07906D</string>
+ <key>command</key>
+ <string>#!/usr/bin/env ruby
+
+require "#{ENV["TM_BUNDLE_SUPPORT"]}/lib/tm_factor"
+
+word = line_current_word(ENV["TM_CURRENT_LINE"], ENV["TM_LINE_INDEX"].to_i)
+puts factor_eval(%Q(USE: tools.crossref\n "#{word}" vocab-usage.))</string>
+ <key>fallbackInput</key>
+ <string>word</string>
+ <key>input</key>
+ <string>none</string>
+ <key>name</key>
+ <string>Vocab Usage</string>
+ <key>output</key>
+ <string>showAsTooltip</string>
+ <key>scope</key>
+ <string>source.factor</string>
+ <key>uuid</key>
+ <string>B1F81321-B760-474F-875D-78FB52752E1B</string>
+</dict>
+</plist>
--- /dev/null
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<plist version="1.0">
+<dict>
+ <key>beforeRunningCommand</key>
+ <string>nop</string>
+ <key>bundleUUID</key>
+ <string>8061D2F3-B603-411D-AFFE-61784A07906D</string>
+ <key>command</key>
+ <string>#!/usr/bin/env ruby
+
+require "#{ENV["TM_BUNDLE_SUPPORT"]}/lib/tm_factor"
+
+word = line_current_word(ENV["TM_CURRENT_LINE"], ENV["TM_LINE_INDEX"].to_i)
+puts factor_eval(%Q(USE: tools.crossref\n "#{word}" vocab-uses.))</string>
+ <key>fallbackInput</key>
+ <string>word</string>
+ <key>input</key>
+ <string>none</string>
+ <key>name</key>
+ <string>Vocab Uses</string>
+ <key>output</key>
+ <string>showAsTooltip</string>
+ <key>scope</key>
+ <string>source.factor</string>
+ <key>uuid</key>
+ <string>BC3E2E39-3B79-460C-B05E-BD00BAACB90E</string>
+</dict>
+</plist>
--- /dev/null
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<plist version="1.0">
+<dict>
+ <key>beforeRunningCommand</key>
+ <string>nop</string>
+ <key>bundleUUID</key>
+ <string>8061D2F3-B603-411D-AFFE-61784A07906D</string>
+ <key>command</key>
+ <string>#!/usr/bin/env ruby
+
+require "#{ENV["TM_BUNDLE_SUPPORT"]}/lib/tm_factor"
+
+doc = STDIN.read
+puts factor_run(%Q(#{doc_using_statements(doc)} USE: tools.walker\n [ #{ENV["TM_SELECTED_TEXT"]} ] walk))</string>
+ <key>fallbackInput</key>
+ <string>word</string>
+ <key>input</key>
+ <string>document</string>
+ <key>keyEquivalent</key>
+ <string>^w</string>
+ <key>name</key>
+ <string>Walk Selection</string>
+ <key>output</key>
+ <string>discard</string>
+ <key>scope</key>
+ <string>source.factor</string>
+ <key>uuid</key>
+ <string>57C2BAAC-0474-404F-AA91-DFD02EC2A3ED</string>
+</dict>
+</plist>
--- /dev/null
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<plist version="1.0">
+<dict>
+ <key>beforeRunningCommand</key>
+ <string>nop</string>
+ <key>bundleUUID</key>
+ <string>8061D2F3-B603-411D-AFFE-61784A07906D</string>
+ <key>command</key>
+ <string>#!/usr/bin/env ruby
+
+require "#{ENV["TM_BUNDLE_SUPPORT"]}/lib/tm_factor"
+
+doc = STDIN.read
+word = line_current_word(ENV["TM_CURRENT_LINE"], ENV["TM_LINE_INDEX"].to_i)
+puts factor_eval(%Q(#{doc_using_statements(doc)} USE: tools.annotations\n \\ #{word} watch))</string>
+ <key>fallbackInput</key>
+ <string>word</string>
+ <key>input</key>
+ <string>document</string>
+ <key>keyEquivalent</key>
+ <string>^~w</string>
+ <key>name</key>
+ <string>Watch Word</string>
+ <key>output</key>
+ <string>discard</string>
+ <key>scope</key>
+ <string>source.factor</string>
+ <key>uuid</key>
+ <string>1C86869F-1030-4F74-B242-6357A080E127</string>
+</dict>
+</plist>
--- /dev/null
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<plist version="1.0">
+<dict>
+ <key>commands</key>
+ <array>
+ <dict>
+ <key>command</key>
+ <string>cut:</string>
+ </dict>
+ <dict>
+ <key>argument</key>
+ <string>m</string>
+ <key>command</key>
+ <string>insertText:</string>
+ </dict>
+ <dict>
+ <key>argument</key>
+ <string>y</string>
+ <key>command</key>
+ <string>insertText:</string>
+ </dict>
+ <dict>
+ <key>argument</key>
+ <string>-</string>
+ <key>command</key>
+ <string>insertText:</string>
+ </dict>
+ <dict>
+ <key>argument</key>
+ <string>w</string>
+ <key>command</key>
+ <string>insertText:</string>
+ </dict>
+ <dict>
+ <key>argument</key>
+ <string>o</string>
+ <key>command</key>
+ <string>insertText:</string>
+ </dict>
+ <dict>
+ <key>argument</key>
+ <string>r</string>
+ <key>command</key>
+ <string>insertText:</string>
+ </dict>
+ <dict>
+ <key>argument</key>
+ <string>d</string>
+ <key>command</key>
+ <string>insertText:</string>
+ </dict>
+ <dict>
+ <key>argument</key>
+ <dict>
+ <key>action</key>
+ <string>findPrevious</string>
+ <key>findInProjectIgnoreCase</key>
+ <true/>
+ <key>findString</key>
+ <string>: </string>
+ <key>ignoreCase</key>
+ <true/>
+ <key>replaceAllScope</key>
+ <string>document</string>
+ <key>replaceString</key>
+ <string>table</string>
+ <key>wrapAround</key>
+ <true/>
+ </dict>
+ <key>command</key>
+ <string>findWithOptions:</string>
+ </dict>
+ <dict>
+ <key>command</key>
+ <string>moveToBeginningOfLine:</string>
+ </dict>
+ <dict>
+ <key>command</key>
+ <string>paste:</string>
+ </dict>
+ <dict>
+ <key>command</key>
+ <string>moveToBeginningOfLineAndModifySelection:</string>
+ </dict>
+ <dict>
+ <key>argument</key>
+ <dict>
+ <key>beforeRunningCommand</key>
+ <string>nop</string>
+ <key>command</key>
+ <string>#!/usr/bin/env ruby
+
+require "#{ENV["TM_BUNDLE_SUPPORT"]}/lib/tm_factor"
+
+doc = STDIN.read
+puts factor_eval(%Q(#{doc_using_statements(doc)} USE: stack-checker\n [ #{ENV["TM_SELECTED_TEXT"]} ] infer.))</string>
+ <key>fallbackInput</key>
+ <string>word</string>
+ <key>input</key>
+ <string>document</string>
+ <key>name</key>
+ <string>Insert Inferrence</string>
+ <key>output</key>
+ <string>afterSelectedText</string>
+ <key>scope</key>
+ <string>source.factor</string>
+ <key>uuid</key>
+ <string>DBC0A0CA-5368-43A7-864B-7B9C4034AD08</string>
+ </dict>
+ <key>command</key>
+ <string>executeCommandWithOptions:</string>
+ </dict>
+ <dict>
+ <key>command</key>
+ <string>insertNewline:</string>
+ </dict>
+ <dict>
+ <key>argument</key>
+ <dict>
+ <key>action</key>
+ <string>findPrevious</string>
+ <key>findInProjectIgnoreCase</key>
+ <true/>
+ <key>findString</key>
+ <string>(</string>
+ <key>ignoreCase</key>
+ <true/>
+ <key>replaceAllScope</key>
+ <string>document</string>
+ <key>replaceString</key>
+ <string>table</string>
+ <key>wrapAround</key>
+ <true/>
+ </dict>
+ <key>command</key>
+ <string>findWithOptions:</string>
+ </dict>
+ <dict>
+ <key>command</key>
+ <string>moveToEndOfLineAndModifySelection:</string>
+ </dict>
+ <dict>
+ <key>command</key>
+ <string>cut:</string>
+ </dict>
+ <dict>
+ <key>argument</key>
+ <string> </string>
+ <key>command</key>
+ <string>insertText:</string>
+ </dict>
+ <dict>
+ <key>argument</key>
+ <string>;</string>
+ <key>command</key>
+ <string>insertText:</string>
+ </dict>
+ <dict>
+ <key>command</key>
+ <string>moveToBeginningOfLine:</string>
+ </dict>
+ <dict>
+ <key>argument</key>
+ <string>:</string>
+ <key>command</key>
+ <string>insertText:</string>
+ </dict>
+ <dict>
+ <key>argument</key>
+ <string> </string>
+ <key>command</key>
+ <string>insertText:</string>
+ </dict>
+ <dict>
+ <key>argument</key>
+ <string>m</string>
+ <key>command</key>
+ <string>insertText:</string>
+ </dict>
+ <dict>
+ <key>argument</key>
+ <string>y</string>
+ <key>command</key>
+ <string>insertText:</string>
+ </dict>
+ <dict>
+ <key>argument</key>
+ <string>-</string>
+ <key>command</key>
+ <string>insertText:</string>
+ </dict>
+ <dict>
+ <key>argument</key>
+ <string>w</string>
+ <key>command</key>
+ <string>insertText:</string>
+ </dict>
+ <dict>
+ <key>argument</key>
+ <string>o</string>
+ <key>command</key>
+ <string>insertText:</string>
+ </dict>
+ <dict>
+ <key>argument</key>
+ <string>r</string>
+ <key>command</key>
+ <string>insertText:</string>
+ </dict>
+ <dict>
+ <key>argument</key>
+ <string>d</string>
+ <key>command</key>
+ <string>insertText:</string>
+ </dict>
+ <dict>
+ <key>argument</key>
+ <string> </string>
+ <key>command</key>
+ <string>insertText:</string>
+ </dict>
+ <dict>
+ <key>command</key>
+ <string>paste:</string>
+ </dict>
+ <dict>
+ <key>argument</key>
+ <string> </string>
+ <key>command</key>
+ <string>insertText:</string>
+ </dict>
+ </array>
+ <key>keyEquivalent</key>
+ <string>@W</string>
+ <key>name</key>
+ <string>Extract as New Word</string>
+ <key>scope</key>
+ <string>source.factor</string>
+ <key>uuid</key>
+ <string>82E740D1-8D20-48AF-8470-C85C251D4870</string>
+</dict>
+</plist>
--- /dev/null
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<plist version="1.0">
+<dict>
+ <key>name</key>
+ <string>Miscellaneous</string>
+ <key>scope</key>
+ <string>source.factor</string>
+ <key>settings</key>
+ <dict>
+ <key>increaseIndentPattern</key>
+ <string>^:</string>
+ <key>shellVariables</key>
+ <array>
+ <dict>
+ <key>name</key>
+ <string>TM_COMMENT_START</string>
+ <key>value</key>
+ <string>! </string>
+ </dict>
+ </array>
+ </dict>
+ <key>uuid</key>
+ <string>D60675B0-9BF4-4CCF-9066-CA14FE836981</string>
+</dict>
+</plist>
--- /dev/null
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<plist version="1.0">
+<dict>
+ <key>content</key>
+ <string>[
+ $TM_SELECTED_TEXT$0
+]</string>
+ <key>keyEquivalent</key>
+ <string>~[</string>
+ <key>name</key>
+ <string>[ expanded</string>
+ <key>scope</key>
+ <string>source.factor
+</string>
+ <key>tabTrigger</key>
+ <string>“</string>
+ <key>uuid</key>
+ <string>F771F82B-6B2B-4DAE-9A2A-E1042D3B08AD</string>
+</dict>
+</plist>
--- /dev/null
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<plist version="1.0">
+<dict>
+ <key>content</key>
+ <string>[ $TM_SELECTED_TEXT$0 ]</string>
+ <key>keyEquivalent</key>
+ <string>[</string>
+ <key>name</key>
+ <string>[</string>
+ <key>scope</key>
+ <string>source.factor</string>
+ <key>tabTrigger</key>
+ <string>[</string>
+ <key>uuid</key>
+ <string>3F17AF0F-4DE0-4A86-A649-CB65907F0DA5</string>
+</dict>
+</plist>
--- /dev/null
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<plist version="1.0">
+<dict>
+ <key>content</key>
+ <string>
+ [ $1 ]
+ [ $2 ] bi</string>
+ <key>name</key>
+ <string>bi</string>
+ <key>scope</key>
+ <string>source.factor</string>
+ <key>tabTrigger</key>
+ <string>bi</string>
+ <key>uuid</key>
+ <string>8D69F968-D322-4008-A540-209B32A97F5D</string>
+</dict>
+</plist>
--- /dev/null
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<plist version="1.0">
+<dict>
+ <key>content</key>
+ <string>{
+ [ $1 ]
+ [ $2 ]
+ [ $3 ]
+ [ $4 ]
+} cleave</string>
+ <key>name</key>
+ <string>cleave</string>
+ <key>scope</key>
+ <string>source.factor</string>
+ <key>tabTrigger</key>
+ <string>cleave</string>
+ <key>uuid</key>
+ <string>E51383D9-1C82-4ACE-AE45-633E6CE35245</string>
+</dict>
+</plist>
--- /dev/null
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<plist version="1.0">
+<dict>
+ <key>content</key>
+ <string>{
+ { [ $1 ] [ $2 ] }
+ { [ $3 ] [ $4 ] }
+$5} cond </string>
+ <key>name</key>
+ <string>cond</string>
+ <key>scope</key>
+ <string>source.factor</string>
+ <key>tabTrigger</key>
+ <string>cond</string>
+ <key>uuid</key>
+ <string>C8E068DE-A117-43AE-9916-99AF2C21BD24</string>
+</dict>
+</plist>
--- /dev/null
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<plist version="1.0">
+<dict>
+ <key>content</key>
+ <string>
+FUNCTOR: $1 ( $2 -- $3 )
+$4
+WHERE
+$0
+;FUNCTOR
+</string>
+ <key>name</key>
+ <string>functor</string>
+ <key>scope</key>
+ <string>source.factor</string>
+ <key>tabTrigger</key>
+ <string>functor</string>
+ <key>uuid</key>
+ <string>B9DA0999-D710-4693-8056-9E4B8BDAC7E9</string>
+</dict>
+</plist>
--- /dev/null
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<plist version="1.0">
+<dict>
+ <key>content</key>
+ <string>
+ [ $1 ]
+ [ $2 ] if</string>
+ <key>name</key>
+ <string>if</string>
+ <key>scope</key>
+ <string>source.factor</string>
+ <key>tabTrigger</key>
+ <string>if</string>
+ <key>uuid</key>
+ <string>AD9D0A71-2371-4756-86D7-A084B4A3FE2F</string>
+</dict>
+</plist>
--- /dev/null
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<plist version="1.0">
+<dict>
+ <key>content</key>
+ <string>:: $1 ( $2 -- $3 ) $0 ;</string>
+ <key>name</key>
+ <string>::</string>
+ <key>scope</key>
+ <string>source.factor</string>
+ <key>tabTrigger</key>
+ <string>::</string>
+ <key>uuid</key>
+ <string>9A96D386-F7B9-47DC-9CAE-E4BAD1F81748</string>
+</dict>
+</plist>
--- /dev/null
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<plist version="1.0">
+<dict>
+ <key>content</key>
+ <string>
+ [let | $1 [ $2 ] $3|
+ $0
+ ]</string>
+ <key>name</key>
+ <string>let</string>
+ <key>scope</key>
+ <string>source.factor</string>
+ <key>tabTrigger</key>
+ <string>let</string>
+ <key>uuid</key>
+ <string>1B3CF04D-B23D-4D9A-A648-7191315CDF96</string>
+</dict>
+</plist>
--- /dev/null
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<plist version="1.0">
+<dict>
+ <key>content</key>
+ <string>{
+ [ $1 ]
+ [ $2 ]
+ [ $3 ]
+ [ $4 ]
+} spread</string>
+ <key>name</key>
+ <string>spread</string>
+ <key>scope</key>
+ <string>source.factor</string>
+ <key>tabTrigger</key>
+ <string>spread</string>
+ <key>uuid</key>
+ <string>3DE1C097-6F69-4562-9C49-C897FF5AB909</string>
+</dict>
+</plist>
--- /dev/null
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<plist version="1.0">
+<dict>
+ <key>content</key>
+ <string>
+ [ $1 ]
+ [ $2 ]
+ [ $3 ] tri</string>
+ <key>name</key>
+ <string>tri</string>
+ <key>scope</key>
+ <string>source.factor</string>
+ <key>tabTrigger</key>
+ <string>tri</string>
+ <key>uuid</key>
+ <string>B8B7B5ED-C75C-4BD1-906A-220C9956F91F</string>
+</dict>
+</plist>
--- /dev/null
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<plist version="1.0">
+<dict>
+ <key>content</key>
+ <string>: $1 ( $2 -- $3 ) $0 ;</string>
+ <key>name</key>
+ <string>:</string>
+ <key>scope</key>
+ <string>source.factor</string>
+ <key>tabTrigger</key>
+ <string>:</string>
+ <key>uuid</key>
+ <string>7903894E-CB75-43ED-8635-C0E65F94DEBB</string>
+</dict>
+</plist>
--- /dev/null
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<plist version="1.0">
+<dict>
+ <key>content</key>
+ <string>{
+ $TM_SELECTED_TEXT$0
+}</string>
+ <key>keyEquivalent</key>
+ <string>~{</string>
+ <key>name</key>
+ <string>{ expanded</string>
+ <key>scope</key>
+ <string>source.factor
+</string>
+ <key>uuid</key>
+ <string>275EA395-6026-481A-81C5-1F71D8026972</string>
+</dict>
+</plist>
--- /dev/null
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<plist version="1.0">
+<dict>
+ <key>content</key>
+ <string>{ $TM_SELECTED_TEXT$0 }</string>
+ <key>keyEquivalent</key>
+ <string>{</string>
+ <key>name</key>
+ <string>{</string>
+ <key>scope</key>
+ <string>source.factor</string>
+ <key>tabTrigger</key>
+ <string>[</string>
+ <key>uuid</key>
+ <string>B4448FB0-B7F9-4FFD-AB4B-EAD31A5920CB</string>
+</dict>
+</plist>
document.scan(/\b(USING:\s[^;]*\s;|USE:\s+\S+|IN:\s\S+)/).join("\n") << "\n"
end
+def doc_vocab(document)
+ document.sub(/\bIN:\s(\S+)/, %Q("\\1"))
+end
+
def line_current_word(line, point)
left = line.rindex(/\s/, point - 1) || 0; right = line.index(/\s/, point) || line.length
line[left..right]
--- /dev/null
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<plist version="1.0">
+<dict>
+ <key>command</key>
+ <string>#!/usr/bin/env ruby
+require "#{ENV["TM_BUNDLE_SUPPORT"]}/lib/tm_factor"
+require ENV['TM_SUPPORT_PATH'] + '/lib/ui'
+
+a = TextMate::UI.request_string(:title => "Scaffold Setup", :prompt =>
+"Vocab Name:")
+b = ENV["TM_FILEPATH"]
+if b then c = b[/\/factor\/([^\/]+)\//,1]
+else c = "work"
+end
+factor_eval(%Q(USING: kernel editors tools.scaffold ; "#{a}" dup #{"scaffold-" << c} edit-vocab))</string>
+ <key>extension</key>
+ <string>factor</string>
+ <key>keyEquivalent</key>
+ <string>@N</string>
+ <key>name</key>
+ <string>Vocabulary</string>
+ <key>scope</key>
+ <string>source.factor</string>
+ <key>uuid</key>
+ <string>B6D1D91E-3EF3-4112-97DF-BFCABEBAA1C9</string>
+</dict>
+</plist>
<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
<plist version="1.0">
<dict>
+ <key>deleted</key>
+ <array/>
+ <key>mainMenu</key>
+ <dict>
+ <key>excludedItems</key>
+ <array>
+ <string>DBC0A0CA-5368-43A7-864B-7B9C4034AD08</string>
+ <string>1B3CF04D-B23D-4D9A-A648-7191315CDF96</string>
+ <string>3F17AF0F-4DE0-4A86-A649-CB65907F0DA5</string>
+ <string>B4448FB0-B7F9-4FFD-AB4B-EAD31A5920CB</string>
+ <string>C8E068DE-A117-43AE-9916-99AF2C21BD24</string>
+ <string>AD9D0A71-2371-4756-86D7-A084B4A3FE2F</string>
+ <string>8D69F968-D322-4008-A540-209B32A97F5D</string>
+ <string>B8B7B5ED-C75C-4BD1-906A-220C9956F91F</string>
+ <string>E51383D9-1C82-4ACE-AE45-633E6CE35245</string>
+ <string>3DE1C097-6F69-4562-9C49-C897FF5AB909</string>
+ <string>B9DA0999-D710-4693-8056-9E4B8BDAC7E9</string>
+ <string>7903894E-CB75-43ED-8635-C0E65F94DEBB</string>
+ <string>9A96D386-F7B9-47DC-9CAE-E4BAD1F81748</string>
+ <string>F771F82B-6B2B-4DAE-9A2A-E1042D3B08AD</string>
+ <string>275EA395-6026-481A-81C5-1F71D8026972</string>
+ </array>
+ <key>items</key>
+ <array>
+ <string>8088D204-FFD7-4384-8FDD-A01536FFD0E7</string>
+ <string>CAD3BB10-C480-4C0E-9518-94D61F7A0C0B</string>
+ <string>82E740D1-8D20-48AF-8470-C85C251D4870</string>
+ <string>D348BE40-6F51-4471-B300-DDDA70ED8C8C</string>
+ <string>9D99C141-EC9D-4C9E-9C08-0CA4EAEA2F3E</string>
+ <string>1C72489C-15A1-4B44-BCDF-438962D4F3EB</string>
+ <string>9E5EC5B6-AABD-4657-A663-D3C558051216</string>
+ <string>219C4AB2-742E-48FE-92E1-CB2EC19C8A24</string>
+ <string>D25BF2AE-0595-44AE-B97A-9F20D4E28173</string>
+ <string>93AF1721-C14D-428A-B5A0-34CEFAA3B3C5</string>
+ </array>
+ <key>submenus</key>
+ <dict>
+ <key>1C72489C-15A1-4B44-BCDF-438962D4F3EB</key>
+ <dict>
+ <key>items</key>
+ <array>
+ <string>3043A033-A113-4283-BCBB-3DE2CCC8F63E</string>
+ <string>B1F81321-B760-474F-875D-78FB52752E1B</string>
+ <string>BC3E2E39-3B79-460C-B05E-BD00BAACB90E</string>
+ </array>
+ <key>name</key>
+ <string>Cross Ref</string>
+ </dict>
+ <key>219C4AB2-742E-48FE-92E1-CB2EC19C8A24</key>
+ <dict>
+ <key>items</key>
+ <array>
+ <string>57C2BAAC-0474-404F-AA91-DFD02EC2A3ED</string>
+ <string>E4614756-DF2E-433A-8935-197159C67AB8</string>
+ <string>1C86869F-1030-4F74-B242-6357A080E127</string>
+ <string>71F08D9B-3D24-4E78-84C9-82CA736554D1</string>
+ </array>
+ <key>name</key>
+ <string>Debugging</string>
+ </dict>
+ <key>9D99C141-EC9D-4C9E-9C08-0CA4EAEA2F3E</key>
+ <dict>
+ <key>items</key>
+ <array>
+ <string>D02D9D74-E073-48AE-A78E-B40FFFA519D5</string>
+ <string>C573487C-DD7D-497F-A728-52D7962D95E2</string>
+ <string>D95A617C-E1C6-44DA-9126-04171CB21299</string>
+ <string>0034EC1C-DAD1-498F-82FD-BEF7015F84EE</string>
+ </array>
+ <key>name</key>
+ <string>Edit</string>
+ </dict>
+ <key>9E5EC5B6-AABD-4657-A663-D3C558051216</key>
+ <dict>
+ <key>items</key>
+ <array>
+ <string>7FF52332-CA5B-4D46-99EF-DAE0659DB478</string>
+ <string>15A984BD-BC65-43E8-878A-267788C8DA70</string>
+ <string>8E01DDAF-959B-4237-ADB9-C133A4ACCE90</string>
+ <string>B619FCC0-2DF2-4657-82A8-0E5676A10254</string>
+ <string>8465B33D-7CA0-4337-945C-4078346D64BC</string>
+ </array>
+ <key>name</key>
+ <string>Tools</string>
+ </dict>
+ <key>D25BF2AE-0595-44AE-B97A-9F20D4E28173</key>
+ <dict>
+ <key>items</key>
+ <array>
+ <string>35484754-DBF9-4381-BB25-00CAB64DF4A1</string>
+ <string>BC5BE120-734B-40DF-8B6B-5D3243614B27</string>
+ </array>
+ <key>name</key>
+ <string>Help</string>
+ </dict>
+ </dict>
+ </dict>
<key>name</key>
<string>Factor</string>
<key>ordering</key>
<array>
<string>3C9C9C2A-314A-475B-A4E4-A68BAAF3F36E</string>
+ <string>D60675B0-9BF4-4CCF-9066-CA14FE836981</string>
<string>141517D7-73E0-4475-A481-71102575A175</string>
+ <string>B6D1D91E-3EF3-4112-97DF-BFCABEBAA1C9</string>
<string>CAD3BB10-C480-4C0E-9518-94D61F7A0C0B</string>
+ <string>8088D204-FFD7-4384-8FDD-A01536FFD0E7</string>
<string>15A984BD-BC65-43E8-878A-267788C8DA70</string>
<string>8E01DDAF-959B-4237-ADB9-C133A4ACCE90</string>
<string>35484754-DBF9-4381-BB25-00CAB64DF4A1</string>
<string>BC5BE120-734B-40DF-8B6B-5D3243614B27</string>
<string>B619FCC0-2DF2-4657-82A8-0E5676A10254</string>
+ <string>DBC0A0CA-5368-43A7-864B-7B9C4034AD08</string>
+ <string>93AF1721-C14D-428A-B5A0-34CEFAA3B3C5</string>
+ <string>3043A033-A113-4283-BCBB-3DE2CCC8F63E</string>
+ <string>B1F81321-B760-474F-875D-78FB52752E1B</string>
+ <string>BC3E2E39-3B79-460C-B05E-BD00BAACB90E</string>
+ <string>8465B33D-7CA0-4337-945C-4078346D64BC</string>
+ <string>57C2BAAC-0474-404F-AA91-DFD02EC2A3ED</string>
+ <string>1C86869F-1030-4F74-B242-6357A080E127</string>
+ <string>E4614756-DF2E-433A-8935-197159C67AB8</string>
+ <string>D02D9D74-E073-48AE-A78E-B40FFFA519D5</string>
+ <string>C573487C-DD7D-497F-A728-52D7962D95E2</string>
+ <string>0034EC1C-DAD1-498F-82FD-BEF7015F84EE</string>
+ <string>D95A617C-E1C6-44DA-9126-04171CB21299</string>
+ <string>71F08D9B-3D24-4E78-84C9-82CA736554D1</string>
+ <string>7FF52332-CA5B-4D46-99EF-DAE0659DB478</string>
+ <string>D348BE40-6F51-4471-B300-DDDA70ED8C8C</string>
+ <string>1B3CF04D-B23D-4D9A-A648-7191315CDF96</string>
+ <string>3F17AF0F-4DE0-4A86-A649-CB65907F0DA5</string>
+ <string>F771F82B-6B2B-4DAE-9A2A-E1042D3B08AD</string>
+ <string>B4448FB0-B7F9-4FFD-AB4B-EAD31A5920CB</string>
+ <string>275EA395-6026-481A-81C5-1F71D8026972</string>
+ <string>C8E068DE-A117-43AE-9916-99AF2C21BD24</string>
+ <string>AD9D0A71-2371-4756-86D7-A084B4A3FE2F</string>
+ <string>8D69F968-D322-4008-A540-209B32A97F5D</string>
+ <string>B8B7B5ED-C75C-4BD1-906A-220C9956F91F</string>
+ <string>E51383D9-1C82-4ACE-AE45-633E6CE35245</string>
+ <string>3DE1C097-6F69-4562-9C49-C897FF5AB909</string>
+ <string>B9DA0999-D710-4693-8056-9E4B8BDAC7E9</string>
+ <string>7903894E-CB75-43ED-8635-C0E65F94DEBB</string>
+ <string>9A96D386-F7B9-47DC-9CAE-E4BAD1F81748</string>
+ <string>82E740D1-8D20-48AF-8470-C85C251D4870</string>
</array>
<key>uuid</key>
<string>8061D2F3-B603-411D-AFFE-61784A07906D</string>
syn match factorComment /\<#! .*/ contains=factorTodo
syn match factorComment /\<! .*/ contains=factorTodo
-syn cluster factorDefnContents contains=@factorCluster,factorStackEffect,factorArray0,factorQuotation0
+syn cluster factorDefnContents contains=@factorCluster,factorStackEffect,factorLiteralStackEffect,factorArray0,factorQuotation0
-syn region factorDefn matchgroup=factorDefnDelims start=/\<\(MACRO\|MACRO::\|MEMO:\|MEMO::\|:\|::\)\?:\s\+\S\+\>/ end=/\<;\>/ contains=@factorDefnContents
-syn region factorMethod matchgroup=factorMethodDelims start=/\<M:\s\+\S\+\s\+\S\+\>/ end=/\<;\>/ contains=@factorDefnContents
+syn region factorDefn matchgroup=factorDefnDelims start=/\<\(SYNTAX\|\(MACRO\|MEMO\)\?:\?\):\s\+\S\+\>/ end=/\<;\>/ contains=@factorDefnContents
+syn region factorMethod matchgroup=factorMethodDelims start=/\<M::\?\s\+\S\+\s\+\S\+\>/ end=/\<;\>/ contains=@factorDefnContents
syn region factorGeneric matchgroup=factorGenericDelims start=/\<GENERIC:\s\+\S\+\>/ end=/$/ contains=factorStackEffect
syn region factorGenericN matchgroup=factorGenericNDelims start=/\<GENERIC#\s\+\S\+\s\+\d\+\>/ end=/$/ contains=factorStackEffect
-syn region factorPrivateDefn matchgroup=factorPrivateDefnDelims start=/\<\(MACRO\|MACRO::\|MEMO:\|MEMO::\|:\|::\)\?:\s\+\S\+\>/ end=/\<;\>/ contains=@factorDefnContents contained
-syn region factorPrivateMethod matchgroup=factorPrivateMethodDelims start=/\<M:\s\+\S\+\s\+\S\+\>/ end=/\<;\>/ contains=@factorDefnContents contained
+syn region factorPrivateDefn matchgroup=factorPrivateDefnDelims start=/\<\(SYNTAX\|\(MACRO\|MEMO\)\?:\?\):\s\+\S\+\>/ end=/\<;\>/ contains=@factorDefnContents contained
+syn region factorPrivateMethod matchgroup=factorPrivateMethodDelims start=/\<M::\?\s\+\S\+\s\+\S\+\>/ end=/\<;\>/ contains=@factorDefnContents contained
syn region factorPGeneric matchgroup=factorPGenericDelims start=/\<GENERIC:\s\+\S\+\>/ end=/$/ contains=factorStackEffect contained
syn region factorPGenericN matchgroup=factorPGenericNDelims start=/\<GENERIC#\s\+\S\+\s\+\d\+\>/ end=/$/ contains=factorStackEffect
syn keyword factorBoolean boolean f general-t t
-syn keyword factorCompileDirective inline foldable parsing
+syn keyword factorCompileDirective inline foldable recursive
<%
"syn match factorStackEffectErr /\<)\>/
"syn region factorStackEffectErr start=/\<(\>/ end=/\<)\>/
-syn region factorStackEffect start=/\<(\>/ end=/\<)\>/ contained
+"syn region factorStackEffect start=/\<(\>/ end=/\<)\>/ contained
+syn match factorStackEffect /\<( .*--.* )\>/ contained
+syn match factorLiteralStackEffect /\<(( .*--.* ))\>/
"adapted from lisp.vim
if exists("g:factor_norainbow")
- syn region factorQuotation matchgroup=factorDelimiter start=/\<\[\>/ matchgroup=factorDelimiter end=/\<\]\>/ contains=ALL
+ syn region factorQuotation matchgroup=factorDelimiter start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ matchgroup=factorDelimiter end=/\<\]\>/ contains=ALL
else
- syn region factorQuotation0 matchgroup=hlLevel0 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation1,factorArray1
- syn region factorQuotation1 contained matchgroup=hlLevel1 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation2,factorArray2
- syn region factorQuotation2 contained matchgroup=hlLevel2 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation3,factorArray3
- syn region factorQuotation3 contained matchgroup=hlLevel3 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation4,factorArray4
- syn region factorQuotation4 contained matchgroup=hlLevel4 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation5,factorArray5
- syn region factorQuotation5 contained matchgroup=hlLevel5 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation6,factorArray6
- syn region factorQuotation6 contained matchgroup=hlLevel6 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation7,factorArray7
- syn region factorQuotation7 contained matchgroup=hlLevel7 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation8,factorArray8
- syn region factorQuotation8 contained matchgroup=hlLevel8 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation9,factorArray9
- syn region factorQuotation9 contained matchgroup=hlLevel9 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation0,factorArray0
+ syn region factorQuotation0 matchgroup=hlLevel0 start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation1,factorArray1
+ syn region factorQuotation1 contained matchgroup=hlLevel1 start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation2,factorArray2
+ syn region factorQuotation2 contained matchgroup=hlLevel2 start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation3,factorArray3
+ syn region factorQuotation3 contained matchgroup=hlLevel3 start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation4,factorArray4
+ syn region factorQuotation4 contained matchgroup=hlLevel4 start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation5,factorArray5
+ syn region factorQuotation5 contained matchgroup=hlLevel5 start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation6,factorArray6
+ syn region factorQuotation6 contained matchgroup=hlLevel6 start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation7,factorArray7
+ syn region factorQuotation7 contained matchgroup=hlLevel7 start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation8,factorArray8
+ syn region factorQuotation8 contained matchgroup=hlLevel8 start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation9,factorArray9
+ syn region factorQuotation9 contained matchgroup=hlLevel9 start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation0,factorArray0
endif
if exists("g:factor_norainbow")
- syn region factorArray matchgroup=factorDelimiter start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ matchgroup=factorDelimiter end=/\<}\>/ contains=ALL
+ syn region factorArray matchgroup=factorDelimiter start=/\<\(V\|H\|T\|W\|F\|B\|\$\)\?{\>/ matchgroup=factorDelimiter end=/\<}\>/ contains=ALL
else
- syn region factorArray0 matchgroup=hlLevel0 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray1,factorQuotation1
- syn region factorArray1 contained matchgroup=hlLevel1 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray2,factorQuotation2
- syn region factorArray2 contained matchgroup=hlLevel2 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray3,factorQuotation3
- syn region factorArray3 contained matchgroup=hlLevel3 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray4,factorQuotation4
- syn region factorArray4 contained matchgroup=hlLevel4 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray5,factorQuotation5
- syn region factorArray5 contained matchgroup=hlLevel5 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray6,factorQuotation6
- syn region factorArray6 contained matchgroup=hlLevel6 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray7,factorQuotation7
- syn region factorArray7 contained matchgroup=hlLevel7 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray8,factorQuotation8
- syn region factorArray8 contained matchgroup=hlLevel8 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray9,factorQuotation9
- syn region factorArray9 contained matchgroup=hlLevel9 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray0,factorQuotation0
+ syn region factorArray0 matchgroup=hlLevel0 start=/\<\(V\|H\|T\|W\|F\|B\|\$\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray1,factorQuotation1
+ syn region factorArray1 contained matchgroup=hlLevel1 start=/\<\(V\|H\|T\|W\|F\|B\|\$\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray2,factorQuotation2
+ syn region factorArray2 contained matchgroup=hlLevel2 start=/\<\(V\|H\|T\|W\|F\|B\|\$\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray3,factorQuotation3
+ syn region factorArray3 contained matchgroup=hlLevel3 start=/\<\(V\|H\|T\|W\|F\|B\|\$\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray4,factorQuotation4
+ syn region factorArray4 contained matchgroup=hlLevel4 start=/\<\(V\|H\|T\|W\|F\|B\|\$\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray5,factorQuotation5
+ syn region factorArray5 contained matchgroup=hlLevel5 start=/\<\(V\|H\|T\|W\|F\|B\|\$\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray6,factorQuotation6
+ syn region factorArray6 contained matchgroup=hlLevel6 start=/\<\(V\|H\|T\|W\|F\|B\|\$\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray7,factorQuotation7
+ syn region factorArray7 contained matchgroup=hlLevel7 start=/\<\(V\|H\|T\|W\|F\|B\|\$\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray8,factorQuotation8
+ syn region factorArray8 contained matchgroup=hlLevel8 start=/\<\(V\|H\|T\|W\|F\|B\|\$\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray9,factorQuotation9
+ syn region factorArray9 contained matchgroup=hlLevel9 start=/\<\(V\|H\|T\|W\|F\|B\|\$\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray0,factorQuotation0
endif
syn match factorBracketErr /\<\]\>/
HiLink factorComment Comment
HiLink factorStackEffect Typedef
+ HiLink factorLiteralStackEffect Typedef
HiLink factorTodo Todo
HiLink factorInclude Include
HiLink factorRepeat Repeat
let b:current_syntax = "factor"
set sw=4
-set ts=4
+set sts=4
set expandtab
set autoindent " annoying?
+++ /dev/null
-Sam Anklesaria
+++ /dev/null
-USING: modules.rpc-server vocabs ;
-IN: modules.remote-loading mem-service
-
-: get-vocab ( vocabstr -- vocab ) vocab ;
\ No newline at end of file
+++ /dev/null
-required for listeners allowing remote loading of modules
\ No newline at end of file
+++ /dev/null
-Sam Anklesaria
+++ /dev/null
-USING: accessors assocs continuations effects io
-io.encodings.binary io.servers.connection kernel
-memoize namespaces parser sets sequences serialize
-threads vocabs vocabs.parser words ;
-IN: modules.rpc-server
-
-SYMBOL: serving-vocabs V{ } clone serving-vocabs set-global
-
-: do-rpc ( args word -- bytes )
- [ execute ] curry with-datastack object>bytes ; inline
-
-MEMO: mem-do-rpc ( args word -- bytes ) do-rpc ; inline
-
-: process ( vocabspec -- )
- vocab-words [ deserialize ] dip deserialize
- swap at "executer" get execute( args word -- bytes ) write flush ;
-
-: (serve) ( -- )
- deserialize dup serving-vocabs get-global index
- [ process ] [ drop ] if ;
-
-: start-serving-vocabs ( -- )
- [
- binary <threaded-server>
- 5000 >>insecure
- [ (serve) ] >>handler
- start-server
- ] in-thread ;
-
-: (service) ( -- )
- serving-vocabs get-global empty? [ start-serving-vocabs ] when
- current-vocab serving-vocabs get-global adjoin
- "get-words" create-in
- in get [ vocab vocab-words [ stack-effect ] { } assoc-map-as ] curry
- (( -- words )) define-inline ;
-
-SYNTAX: service \ do-rpc "executer" set (service) ;
-SYNTAX: mem-service \ mem-do-rpc "executer" set (service) ;
-
-load-vocab-hook [
- [
- dup words>> values
- \ mem-do-rpc "memoize" word-prop [ delete-at ] curry each
- ] append
-] change-global
+++ /dev/null
-remote procedure call server
\ No newline at end of file
+++ /dev/null
-Sam Anklesaria
+++ /dev/null
-USING: help.syntax help.markup ;
-IN: modules.rpc
-ARTICLE: { "modules" "protocol" } "RPC Protocol"
-{ $list
- "Send vocab as string"
- "Send arglist"
- "Send word as string"
- "Receive result list"
-} ;
\ No newline at end of file
+++ /dev/null
-USING: accessors compiler.units combinators fry generalizations io
-io.encodings.binary io.sockets kernel namespaces
-parser sequences serialize vocabs vocabs.parser words ;
-IN: modules.rpc
-
-DEFER: get-words
-
-: remote-quot ( addrspec vocabspec effect str -- quot )
- '[ _ 5000 <inet> binary
- [
- _ serialize _ in>> length narray serialize _ serialize flush deserialize dup length firstn
- ] with-client
- ] ;
-
-: define-remote ( addrspec vocabspec effect str -- ) [
- [ remote-quot ] 2keep create-in -rot define-declared word make-inline
- ] with-compilation-unit ;
-
-: with-in ( vocab quot -- vocab ) over
- [ '[ _ set-in @ ] in get swap dip set-in ] dip vocab ; inline
-
-: remote-vocab ( addrspec vocabspec -- vocab )
- dup "-remote" append [
- [ (( -- words )) [ "get-words" remote-quot ] keep call-effect ] 2keep
- [ rot first2 swap define-remote ] 2curry each
- ] with-in ;
\ No newline at end of file
+++ /dev/null
-remote procedure call client
\ No newline at end of file
+++ /dev/null
-Sam Anklesaria
+++ /dev/null
-module pushing in remote-loading listeners
\ No newline at end of file
+++ /dev/null
-USING: assocs modules.rpc-server vocabs
-modules.remote-loading words ;
-IN: modules.uploads service
-
-: upload-vocab ( word binary -- ) \ get-vocab "memoize" word-prop set-at ;
\ No newline at end of file
+++ /dev/null
-Sam Anklesaria
+++ /dev/null
-improved module import syntax
\ No newline at end of file
+++ /dev/null
-unportable
+++ /dev/null
-USING: modules.rpc-server io.servers.connection ;
-IN: modules.test-server service
-: rpc-hello ( -- str ) "hello world" stop-this-server ;
\ No newline at end of file
+++ /dev/null
-USING: modules.using ;
-IN: modules.using.tests
-USING: tools.test localhost::modules.test-server ;
-[ "hello world" ] [ rpc-hello ] unit-test
\ No newline at end of file
+++ /dev/null
-USING: modules.using modules.rpc-server help.syntax help.markup strings ;
-IN: modules
-
-HELP: service
-{ $syntax "IN: module service" }
-{ $description "Starts a server for requests for remote procedure calls." } ;
-
-ARTICLE: { "modules" "remote-loading" } "Using the remote-loading vocabulary"
-"If loaded, starts serving vocabularies, accessable through a " { $link POSTPONE: USING: } " form" ;
-
-HELP: USING:
-{ $syntax "USING: rpc-server::module fetch-sever::module { module qualified-name } { module => word ... } ... ;" }
-{ $description "Adds vocabularies to the front of the search path. Vocabularies can be fetched remotely, if preceded by a valid hostname. Name pairs facilitate imports like in the "
-{ $link POSTPONE: QUALIFIED: } " or " { $link POSTPONE: FROM: } " forms." } ;
\ No newline at end of file
+++ /dev/null
-USING: assocs kernel modules.remote-loading modules.rpc
-namespaces peg peg.ebnf peg-lexer sequences vocabs vocabs.parser
-strings ;
-IN: modules.using
-
-: >qualified ( vocab prefix -- assoc )
- [ vocab-words ] [ 58 suffix ] bi* [ swap [ prepend ] dip ] curry assoc-map ;
-
-: >partial-vocab ( words assoc -- assoc )
- [ dupd at [ no-word-error ] unless* ] curry { } map>assoc ;
-
-: remote-load ( addr vocabspec -- voab ) [ "modules.remote-loading" remote-vocab (use+) ] dip get-vocab ;
-
-: load'em ( vocab words/? -- ) [ swap >partial-vocab ] when* use get push ;
-
-EBNF: modulize
-tokenpart = (!(':').)+ => [[ >string ]]
-s = ':' => [[ drop ignore ]]
-rpc = tokenpart s s tokenpart => [[ first2 remote-vocab ]]
-remote = tokenpart s tokenpart => [[ first2 remote-load ]]
-plain = tokenpart => [[ load-vocab ]]
-module = rpc | remote | plain
-;EBNF
-
-ON-BNF: USING:
-tokenizer = <foreign factor>
-sym = !(";"|"}"|"=>").
-modspec = sym => [[ modulize ]]
-qualified = modspec sym => [[ first2 >qualified ]]
-unqualified = modspec => [[ vocab-words ]]
-words = ("=>" sym+ )? => [[ [ f ] [ second ] if-empty ]]
-long = "{" ( qualified | unqualified ) words "}" => [[ rest first2 load'em ignore ]]
-short = modspec => [[ use+ ignore ]]
-wordSpec = long | short
-using = wordSpec+ ";" => [[ drop ignore ]]
-;ON-BNF
\ No newline at end of file
bool performing_compaction;
cell collecting_gen;
-/* if true, we collecting aging space for the second time, so if it is still
+/* if true, we are collecting aging space for the second time, so if it is still
full, we go on to collect tenured */
bool collecting_aging_again;
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