! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien arrays alien.c-types alien.structs
-sequences math kernel namespaces libc cpu.architecture ;
+sequences math kernel namespaces make libc cpu.architecture ;
IN: alien.arrays
UNION: value-type array struct-type ;
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: byte-arrays arrays assocs kernel kernel.private libc math
-namespaces parser sequences strings words assocs splitting
+namespaces make parser sequences strings words assocs splitting
math.parser cpu.architecture alien alien.accessors quotations
layouts system compiler.units io.files io.encodings.binary
accessors combinators effects continuations ;
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays kernel kernel.private math namespaces
-sequences strings words effects combinators alien.c-types ;
+make sequences strings words effects combinators alien.c-types ;
IN: alien.structs.fields
TUPLE: field-spec name offset type reader writer ;
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien arrays byte-arrays generic assocs hashtables assocs
-hashtables.private io kernel kernel.private math namespaces
+hashtables.private io kernel kernel.private math namespaces make
parser prettyprint sequences sequences.private strings sbufs
vectors words quotations assocs system layouts splitting
grouping growable classes classes.builtin classes.tuple
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: checksums checksums.openssl splitting assocs
-kernel io.files bootstrap.image sequences io namespaces
+kernel io.files bootstrap.image sequences io namespaces make
io.launcher math io.encodings.ascii ;
IN: bootstrap.image.upload
! See http://factorcode.org/license.txt for BSD license.
!
! Remote Channels
-USING: kernel init namespaces assocs arrays random
+USING: kernel init namespaces make assocs arrays random
sequences channels match concurrency.messaging
concurrency.distributed threads accessors ;
IN: channels.remote
! Copyright (C) 2006, 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.bitwise strings io.binary namespaces
-grouping ;
+make grouping ;
IN: checksums.common
SYMBOL: bytes-read
! See http://factorcode.org/license.txt for BSD license.
USING: arrays combinators kernel io io.encodings.binary io.files
io.streams.byte-array math.vectors strings sequences namespaces
-math parser sequences assocs grouping vectors io.binary hashtables
-symbols math.bitwise checksums checksums.common ;
+make math parser sequences assocs grouping vectors io.binary
+hashtables symbols math.bitwise checksums checksums.common ;
IN: checksums.sha1
! Implemented according to RFC 3174.
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel splitting grouping math sequences namespaces
+USING: kernel splitting grouping math sequences namespaces make
io.binary symbols math.bitwise checksums checksums.common
sbufs strings ;
IN: checksums.sha2
object state stackbuf count -> countByEnumeratingWithState:objects:count:
dup zero? [ drop ] [
state NSFastEnumerationState-itemsPtr [ stackbuf ] unless*
- '[ , void*-nth quot call ] each
+ '[ _ void*-nth quot call ] each
object quot state stackbuf count (NSFastEnumeration-each)
] if ; inline recursive
: NSFastEnumeration-map ( object quot -- vector )
NS-EACH-BUFFER-SIZE <vector>
- [ '[ @ , push ] NSFastEnumeration-each ] keep ; inline
+ [ '[ @ _ push ] NSFastEnumeration-each ] keep ; inline
: NSFastEnumeration>vector ( object -- vector )
[ ] NSFastEnumeration-map ;
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien alien.c-types alien.strings
-arrays assocs combinators compiler kernel
-math namespaces parser prettyprint prettyprint.sections
-quotations sequences strings words cocoa.runtime io macros
-memoize debugger io.encodings.ascii effects compiler.generator
-libc libc.private ;
+USING: accessors alien alien.c-types alien.strings arrays assocs
+combinators compiler kernel math namespaces make parser
+prettyprint prettyprint.sections quotations sequences strings
+words cocoa.runtime io macros memoize debugger
+io.encodings.ascii effects compiler.generator libc libc.private ;
IN: cocoa.messages
: make-sender ( method function -- quot )
combinators compiler hashtables kernel libc math namespaces
parser sequences words cocoa.messages cocoa.runtime
compiler.units io.encodings.ascii generalizations
-continuations ;
+continuations make ;
IN: cocoa.subclassing
: init-method ( method -- sel imp types )
! Copyright (C) 2006, 2007 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types arrays kernel math namespaces cocoa
+USING: alien.c-types arrays kernel math namespaces make cocoa
cocoa.messages cocoa.classes cocoa.types sequences
continuations ;
IN: cocoa.views
[ '[ drop N ndup @ dup not ] [ drop N ndrop f ] 2array ]
map
[ t ] [ N nnip ] 2array suffix
- '[ f , cond ] ;
+ '[ f _ cond ] ;
MACRO: 0&& ( quots -- quot ) 0 n&&-rewrite ;
MACRO: 1&& ( quots -- quot ) 1 n&&-rewrite ;
[ '[ drop N ndup @ dup ] [ N nnip ] 2array ]
map
[ drop N ndrop t ] [ f ] 2array suffix
- '[ f , cond ] ;
+ '[ f _ cond ] ;
MACRO: 0|| ( quots -- quot ) 0 n||-rewrite ;
MACRO: 1|| ( quots -- quot ) 1 n||-rewrite ;
H{ } clone dependencies set
H{ } clone generic-dependencies set
- , {
+ _ {
[ compile-begins ]
[
[ build-tree-from-word ] [ compile-failed return ] recover
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays byte-arrays generic assocs hashtables io.binary
-kernel kernel.private math namespaces sequences words
+kernel kernel.private math namespaces make sequences words
quotations strings alien.accessors alien.strings layouts system
combinators math.bitwise words.private cpu.architecture
math.order accessors growable ;
- ! Copyright (C) 2004, 2008 Slava Pestov.
+! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs classes combinators
cpu.architecture effects generic hashtables io kernel
-kernel.private layouts math math.parser namespaces prettyprint
-quotations sequences system threads words vectors sets deques
-continuations.private summary alien alien.c-types
+kernel.private layouts math math.parser namespaces make
+prettyprint quotations sequences system threads words vectors
+sets deques continuations.private summary alien alien.c-types
alien.structs alien.strings alien.arrays libc compiler.errors
-stack-checker.inlining
-compiler.tree compiler.tree.builder compiler.tree.combinators
-compiler.tree.propagation.info compiler.generator.fixup
-compiler.generator.registers compiler.generator.iterator ;
+stack-checker.inlining compiler.tree compiler.tree.builder
+compiler.tree.combinators compiler.tree.propagation.info
+compiler.generator.fixup compiler.generator.registers
+compiler.generator.iterator ;
IN: compiler.generator
SYMBOL: compile-queue
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs classes classes.private classes.algebra
-combinators hashtables kernel layouts math namespaces quotations
-sequences system vectors words effects alien byte-arrays
-accessors sets math.order cpu.architecture
+combinators hashtables kernel layouts math namespaces make
+quotations sequences system vectors words effects alien
+byte-arrays accessors sets math.order cpu.architecture
compiler.generator.fixup ;
IN: compiler.generator.registers
USING: tools.test quotations math kernel sequences
-assocs namespaces compiler.units ;
+assocs namespaces make compiler.units ;
IN: compiler.tests
[ 3 ] [ 5 [ [ 2 - ] curry call ] compile-call ] unit-test
USING: compiler compiler.generator compiler.generator.registers
compiler.generator.registers.private tools.test namespaces
sequences words kernel math effects definitions compiler.units
-accessors cpu.architecture ;
+accessors cpu.architecture make ;
: <int-vreg> ( n -- vreg ) int-regs <vreg> ;
: inlined? ( quot seq/word -- ? )
[ cleaned-up-tree ] dip
dup word? [ 1array ] when
- '[ dup #call? [ word>> , member? ] [ drop f ] if ]
+ '[ dup #call? [ word>> _ member? ] [ drop f ] if ]
contains-node? not ;
[ f ] [
[ [ >r "A" throw r> ] [ "B" throw ] if ]
cleaned-up-tree drop
] unit-test
+
+! Regression from benchmark.nsieve
+: chicken-fingers ( i seq -- )
+ 2dup < [
+ 2drop
+ ] [
+ chicken-fingers
+ ] if ; inline recursive
+
+: buffalo-wings ( i seq -- )
+ 2dup < [
+ 2dup chicken-fingers
+ >r 1+ r> buffalo-wings
+ ] [
+ 2drop
+ ] if ; inline recursive
+
+[ t ] [
+ [ 2 swap >fixnum buffalo-wings ]
+ { <-integer-fixnum +-integer-fixnum } inlined?
+] unit-test
: delete-unreachable-branches ( #branch -- )
dup live-branches>> '[
- ,
+ _
[ [ [ drop ] [ delete-nodes ] if ] 2each ]
[ select-children ]
2bi
M: #phi cleanup*
#! Remove #phi function inputs which no longer exist.
live-branches get
- [ '[ , sift-children ] change-phi-in-d ]
- [ '[ , sift-children ] change-phi-info-d ]
- [ '[ , sift-children ] change-terminated ] tri
+ [ '[ _ sift-children ] change-phi-in-d ]
+ [ '[ _ sift-children ] change-phi-info-d ]
+ [ '[ _ sift-children ] change-terminated ] tri
eliminate-phi
live-branches off ;
: each-node ( nodes quot: ( node -- ) -- )
dup dup '[
- , [
+ _ [
dup #branch? [
- children>> [ , each-node ] each
+ children>> [ _ each-node ] each
] [
dup #recursive? [
- child>> , each-node
+ child>> _ each-node
] [ drop ] if
] if
] bi
dup dup '[
@
dup #branch? [
- [ [ , map-nodes ] map ] change-children
+ [ [ _ map-nodes ] map ] change-children
] [
dup #recursive? [
- [ , map-nodes ] change-child
+ [ _ map-nodes ] change-child
] when
] if
] map flatten ; inline recursive
: contains-node? ( nodes quot: ( node -- ? ) -- ? )
dup dup '[
- , keep swap [ drop t ] [
+ _ keep swap [ drop t ] [
dup #branch? [
- children>> [ , contains-node? ] contains?
+ children>> [ _ contains-node? ] contains?
] [
dup #recursive? [
- child>> , contains-node?
+ child>> _ contains-node?
] [ drop f ] if
] if
] if
: live-value-indices ( values -- indices )
[ length ] keep live-values get
- '[ , nth , key? ] filter ; inline
+ '[ _ nth _ key? ] filter ; inline
: drop-indexed-values ( values indices -- node )
[ drop filter-live ] [ nths ] 2bi
: insert-drops ( nodes values indices -- nodes' )
'[
over ends-with-terminate?
- [ drop ] [ , drop-indexed-values suffix ] if
+ [ drop ] [ _ drop-indexed-values suffix ] if
] 2map ;
: hoist-drops ( #phi -- )
if-node get swap
[ phi-in-d>> ] [ out-d>> live-value-indices ] bi
- '[ , , insert-drops ] change-children drop ;
+ '[ _ _ insert-drops ] change-children drop ;
: remove-phi-outputs ( #phi -- )
[ filter-live ] change-out-d drop ;
M: #alien-indirect compute-live-values* nip look-at-inputs ;
: filter-mapping ( assoc -- assoc' )
- live-values get '[ drop , key? ] assoc-filter ;
+ live-values get '[ drop _ key? ] assoc-filter ;
: filter-corresponding ( new old -- old' )
#! Remove elements from 'old' if the element with the same
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel assocs fry match accessors namespaces effects
+USING: kernel assocs fry match accessors namespaces make effects
sequences sequences.private quotations generic macros arrays
prettyprint prettyprint.backend prettyprint.sections math words
combinators io sorting hints
GENERIC: node>quot ( node -- )
MACRO: match-choose ( alist -- )
- [ '[ , ] ] assoc-map '[ , match-cond ] ;
+ [ [ ] curry ] assoc-map [ match-cond ] curry ;
MATCH-VARS: ?a ?b ?c ;
: recursive-stacks ( #enter-recursive -- stacks )
recursive-phi-in
- escaping-values get '[ [ , disjoint-set-member? ] all? ] filter
+ escaping-values get '[ [ _ disjoint-set-member? ] all? ] filter
flip ;
: analyze-recursive-phi ( #enter-recursive -- )
[ call-next-method ]
[
[ in-d>> ] [ label>> calls>> ] bi
- [ out-d>> escaping-values get '[ , equate ] 2each ] with each
+ [ out-d>> escaping-values get '[ _ equate ] 2each ] with each
] bi ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel arrays accessors sequences sequences.private words
-fry namespaces math math.order memoize classes.builtin
+fry namespaces make math math.order memoize classes.builtin
classes.tuple.private slots.private combinators layouts
byte-arrays alien.accessors
compiler.intrinsics
MEMO: (tuple-boa-expansion) ( n -- quot )
[
[ 2 + ] map <reversed>
- [ '[ [ , set-slot ] keep ] % ] each
+ [ '[ [ _ set-slot ] keep ] % ] each
] [ ] make ;
: tuple-boa-expansion ( layout -- quot )
[ rename-map get at ] keep or ;
: rename-values ( values -- values' )
- rename-map get '[ [ , at ] keep or ] map ;
+ rename-map get '[ [ _ at ] keep or ] map ;
GENERIC: rename-node-values* ( node -- node )
: add-renamings ( old new -- )
[ rename-values ] dip
- rename-map get '[ , set-at ] 2each ;
+ rename-map get '[ _ set-at ] 2each ;
M: #introduce normalize*
out-d>> [ length pop-introductions ] keep add-renamings f ;
M: #phi normalize*
remaining-introductions get swap dup terminated>>
- '[ , eliminate-phi-introductions ] change-phi-in-d ;
+ '[ _ eliminate-phi-introductions ] change-phi-in-d ;
: (normalize) ( nodes introductions -- nodes )
introduction-stack [
M: #recursive normalize*
dup label>> introductions>>
[ drop [ child>> first ] [ in-d>> ] bi >>in-d drop ]
- [ make-values '[ , (normalize) ] change-child ]
+ [ make-values '[ _ (normalize) ] change-child ]
2bi ;
M: #enter-recursive normalize*
: call<return ( #call-recursive n -- nodes )
neg dup make-values [
- [ pop-introductions '[ , prepend ] change-in-d ]
- [ '[ , prepend ] change-out-d ]
+ [ pop-introductions '[ _ prepend ] change-in-d ]
+ [ '[ _ prepend ] change-out-d ]
bi*
] [ introduction-stack [ prepend ] change ] bi ;
: call>return ( #call-recursive n -- #call-recursive )
- [ [ [ in-d>> ] [ out-d>> ] bi ] [ '[ , head ] ] bi* bi@ add-renamings ]
- [ '[ , tail ] [ change-in-d ] [ change-out-d ] bi ]
+ [ [ [ in-d>> ] [ out-d>> ] bi ] [ '[ _ head ] ] bi* bi@ add-renamings ]
+ [ '[ _ tail ] [ change-in-d ] [ change-out-d ] bi ]
2bi ;
M: #call-recursive normalize*
M: #dispatch live-branches
[ children>> length ] [ in-d>> first value-info interval>> ] bi
- '[ , interval-contains? ] map ;
+ '[ _ interval-contains? ] map ;
: live-children ( #branch -- children )
[ children>> ] [ live-branches>> ] bi select-children ;
infer-children-data get
[
'[
- , [
+ _ [
dup +bottom+ eq?
[ drop null-info ] [ value-info ] if
] bind
: binary-op ( word interval-quot post-proc-quot -- )
'[
- [ binary-op-class ] [ , binary-op-interval ] 2bi
+ [ binary-op-class ] [ _ binary-op-interval ] 2bi
@
<class/interval-info>
] "outputs" set-word-prop ;
in1 in2 op negate-comparison (comparison-constraints) out f--> /\ ;
: define-comparison-constraints ( word op -- )
- '[ , comparison-constraints ] "constraints" set-word-prop ;
+ '[ _ comparison-constraints ] "constraints" set-word-prop ;
comparison-ops
-[ dup '[ , define-comparison-constraints ] each-derived-op ] each
+[ dup '[ _ define-comparison-constraints ] each-derived-op ] each
generic-comparison-ops [
dup specific-comparison
- '[ , , define-comparison-constraints ] each-derived-op
+ '[ _ _ define-comparison-constraints ] each-derived-op
] each
! Remove redundant comparisons
comparison-ops [
dup '[
- [ , fold-comparison ] "outputs" set-word-prop
+ [ _ fold-comparison ] "outputs" set-word-prop
] each-derived-op
] each
generic-comparison-ops [
dup specific-comparison
- '[ , fold-comparison ] "outputs" set-word-prop
+ '[ _ fold-comparison ] "outputs" set-word-prop
] each
: maybe-or-never ( ? -- info )
{ >float float }
} [
'[
- ,
+ _
[ nip ] [
[ interval>> ] [ class-interval ] bi*
interval-intersect
[ in-d>> [ value-info literal?>> ] all? ] [ drop f ] if ;
: (fold-call) ( #call word -- info )
- [ [ out-d>> ] [ in-d>> [ value-info literal>> ] map ] bi ] [ '[ , execute ] ] bi*
- '[ , , with-datastack [ <literal-info> ] map nip ]
+ [ [ out-d>> ] [ in-d>> [ value-info literal>> ] map ] bi ] [ '[ _ execute ] ] bi*
+ '[ _ _ with-datastack [ <literal-info> ] map nip ]
[ drop [ object-info ] replicate ]
recover ;
: shuffle-effect ( #shuffle -- effect )
[ in-d>> ] [ out-d>> ] [ mapping>> ] tri
- '[ , at ] map
+ '[ _ at ] map
<effect> ;
: recursive-phi-in ( #enter-recursive -- seq )
! Copyright (C) 2005 Chris Double. All Rights Reserved.
! See http://factorcode.org/license.txt for BSD license.
-!
-USING: kernel threads vectors arrays sequences
-namespaces tools.test continuations deques strings math words
-match quotations concurrency.messaging concurrency.mailboxes
+USING: kernel threads vectors arrays sequences namespaces make
+tools.test continuations deques strings math words match
+quotations concurrency.messaging concurrency.mailboxes
concurrency.count-downs accessors ;
IN: concurrency.messaging.tests
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.strings alien.syntax kernel
-math sequences namespaces assocs init accessors continuations
-combinators core-foundation core-foundation.run-loop
-io.encodings.utf8 destructors ;
+math sequences namespaces make assocs init accessors
+continuations combinators core-foundation
+core-foundation.run-loop io.encodings.utf8 destructors ;
IN: core-foundation.fsevents
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic kernel kernel.private math memory
-namespaces sequences layouts system hashtables classes alien
-byte-arrays combinators words sets ;
+namespaces make sequences layouts system hashtables classes
+alien byte-arrays combinators words sets ;
IN: cpu.architecture
! Register classes
IN: cpu.ppc.assembler.tests
USING: cpu.ppc.assembler tools.test arrays kernel namespaces
-vocabs sequences ;
+make vocabs sequences ;
: test-assembler ( expected quot -- )
[ 1array ] [ [ { } make ] curry ] bi* unit-test ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: compiler.generator.fixup kernel namespaces sequences
+USING: compiler.generator.fixup kernel namespaces make sequences
words math math.bitwise io.binary parser lexer ;
IN: cpu.ppc.assembler.backend
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.c-types arrays cpu.x86.assembler
cpu.x86.assembler.private cpu.architecture kernel kernel.private
-math memory namespaces sequences words compiler.generator
+math memory namespaces make sequences words compiler.generator
compiler.generator.registers compiler.generator.fixup system
layouts combinators compiler.constants math.order ;
IN: cpu.x86.architecture
-USING: cpu.x86.assembler kernel tools.test namespaces ;
+USING: cpu.x86.assembler kernel tools.test namespaces make ;
IN: cpu.x86.assembler.tests
[ { HEX: 49 HEX: 89 HEX: 04 HEX: 24 } ] [ [ R12 [] RAX MOV ] { } make ] unit-test
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays compiler.generator.fixup io.binary kernel
-combinators kernel.private math namespaces sequences
+combinators kernel.private math namespaces make sequences
words system layouts math.order accessors
cpu.x86.assembler.syntax ;
IN: cpu.x86.assembler
! Simple CSV Parser
! Phil Dawes phil@phildawes.net
-USING: kernel sequences io namespaces combinators unicode.categories ;
+USING: kernel sequences io namespaces make
+combinators unicode.categories ;
IN: csv
SYMBOL: delimiter
! Copyright (C) 2007, 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs alien alien.syntax continuations io
-kernel math math.parser namespaces prettyprint quotations
+kernel math math.parser namespaces make prettyprint quotations
sequences debugger db db.postgresql.lib db.postgresql.ffi
db.tuples db.types tools.annotations math.ranges
combinators classes locals words tools.walker
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel math namespaces sequences random strings
-math.parser math.intervals combinators math.bitwise nmake db
-db.tuples db.types db.sql classes words shuffle arrays destructors
-continuations ;
+USING: accessors kernel math namespaces make sequences random
+strings math.parser math.intervals combinators math.bitwise
+nmake db db.tuples db.types db.sql classes words shuffle arrays
+destructors continuations ;
IN: db.queries
GENERIC: where ( specs obj -- )
"Now we've created a book. Let's save it to the database."
{ $code <" USING: db db.sqlite fry io.files ;
: with-book-tutorial ( quot -- )
- '[ "book-tutorial.db" temp-file sqlite-db , with-db ] call ;
+ '[ "book-tutorial.db" temp-file sqlite-db _ with-db ] call ;
[
book recreate-table
! ] with-db
: test-sqlite ( quot -- )
- [ ] swap '[ "tuples-test.db" temp-file sqlite-db , with-db ] unit-test ;
+ [ ] swap '[ "tuples-test.db" temp-file sqlite-db _ with-db ] unit-test ;
: test-postgresql ( quot -- )
- [ ] swap '[ { "localhost" "postgres" "foob" "factor-test" } postgresql-db , with-db ] unit-test ;
+ [ ] swap '[ { "localhost" "postgres" "foob" "factor-test" } postgresql-db _ with-db ] unit-test ;
: test-repeated-insert
[ ] [ person ensure-table ] unit-test
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: slots arrays definitions generic hashtables summary io
-kernel math namespaces prettyprint prettyprint.config sequences
-assocs sequences.private strings io.styles io.files vectors
-words system splitting math.parser classes.tuple continuations
-continuations.private combinators generic.math classes.builtin
-classes compiler.units generic.standard vocabs init
-kernel.private io.encodings accessors math.order
+kernel math namespaces make prettyprint prettyprint.config
+sequences assocs sequences.private strings io.styles io.files
+vectors words system splitting math.parser classes.tuple
+continuations continuations.private combinators generic.math
+classes.builtin classes compiler.units generic.standard vocabs
+init kernel.private io.encodings accessors math.order
destructors source-files parser classes.tuple.parser
effects.parser lexer compiler.errors generic.parser
strings.parser ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors debugger continuations threads threads.private
-io io.styles prettyprint kernel math.parser namespaces ;
+io io.styles prettyprint kernel math.parser namespaces make ;
IN: debugger.threads
: error-in-thread. ( thread -- )
! See http://factorcode.org/license.txt for BSD license.
USING: accessors parser generic kernel classes classes.tuple
words slots assocs sequences arrays vectors definitions
-prettyprint math hashtables sets macros namespaces ;
+prettyprint math hashtables sets macros namespaces make ;
IN: delegate
: protocol-words ( protocol -- words )
[ 1 -rot counts>> set-at ]
2tri ;
-: add-atoms ( seq disjoint-set -- ) '[ , add-atom ] each ;
+: add-atoms ( seq disjoint-set -- ) '[ _ add-atom ] each ;
GENERIC: disjoint-set-member? ( a disjoint-set -- ? )
] if ;
: equate-all-with ( seq a disjoint-set -- )
- '[ , , equate ] each ;
+ '[ _ _ equate ] each ;
: equate-all ( seq disjoint-set -- )
over empty? [ 2drop ] [
: assoc>disjoint-set ( assoc -- disjoint-set )
<disjoint-set>
- [ '[ drop , add-atom ] assoc-each ]
- [ '[ , equate ] assoc-each ]
+ [ '[ drop _ add-atom ] assoc-each ]
+ [ '[ _ equate ] assoc-each ]
[ nip ]
2tri ;
! Copyright (C) 2006, 2007 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays io kernel math models namespaces
+USING: accessors arrays io kernel math models namespaces make
sequences strings splitting combinators unicode.categories
math.order ;
IN: documents
USING: help.markup help.syntax quotations kernel ;\r
IN: fry\r
\r
-HELP: ,\r
+HELP: _\r
{ $description "Fry specifier. Inserts a literal value into the fried quotation." } ;\r
\r
HELP: @\r
{ $description "Fry specifier. Splices a quotation into the fried quotation." } ;\r
\r
-HELP: _\r
-{ $description "Fry specifier. Shifts all fry specifiers to the left down by one stack position." } ;\r
-\r
HELP: fry\r
{ $values { "quot" quotation } { "quot'" quotation } }\r
{ $description "Outputs a quotation that when called, fries " { $snippet "quot" } " by taking values from the stack and substituting them in." }\r
\r
HELP: '[\r
{ $syntax "code... ]" }\r
-{ $description "Literal fried quotation. Expands into code which takes values from the stack and substitutes them in place of the fry specifiers " { $link , } " and " { $link @ } "." }\r
+{ $description "Literal fried quotation. Expands into code which takes values from the stack and substitutes them in place of the fry specifiers " { $link _ } " and " { $link @ } "." }\r
{ $examples "See " { $link "fry.examples" } "." } ;\r
\r
ARTICLE: "fry.examples" "Examples of fried quotations"\r
$nl\r
"If a quotation does not contain any fry specifiers, then " { $link POSTPONE: '[ } " behaves just like " { $link POSTPONE: [ } ":"\r
{ $code "{ 10 20 30 } '[ . ] each" }\r
-"Occurrences of " { $link , } " on the left map directly to " { $link curry } ". That is, the following three lines are equivalent:"\r
+"Occurrences of " { $link _ } " on the left map directly to " { $link curry } ". That is, the following three lines are equivalent:"\r
{ $code \r
- "{ 10 20 30 } 5 '[ , + ] map"\r
+ "{ 10 20 30 } 5 '[ _ + ] map"\r
"{ 10 20 30 } 5 [ + ] curry map"\r
"{ 10 20 30 } [ 5 + ] map"\r
}\r
-"Occurrences of " { $link , } " in the middle of a quotation map to more complex quotation composition patterns. The following three lines are equivalent:"\r
+"Occurrences of " { $link _ } " in the middle of a quotation map to more complex quotation composition patterns. The following three lines are equivalent:"\r
{ $code \r
- "{ 10 20 30 } 5 '[ 3 , / ] map"\r
+ "{ 10 20 30 } 5 '[ 3 _ / ] map"\r
"{ 10 20 30 } 5 [ 3 ] swap [ / ] curry compose map"\r
"{ 10 20 30 } [ 3 5 / ] map"\r
}\r
-"Occurrences of " { $link @ } " are simply syntax sugar for " { $snippet ", call" } ". The following four lines are equivalent:"\r
+"Occurrences of " { $link @ } " are simply syntax sugar for " { $snippet "_ call" } ". The following four lines are equivalent:"\r
{ $code \r
"{ 10 20 30 } [ sq ] '[ @ . ] each"\r
"{ 10 20 30 } [ sq ] [ call . ] curry each"\r
"{ 10 20 30 } [ sq ] [ . ] compose each"\r
"{ 10 20 30 } [ sq . ] each"\r
}\r
-"The " { $link , } " and " { $link @ } " specifiers may be freely mixed:"\r
+"The " { $link _ } " and " { $link @ } " specifiers may be freely mixed:"\r
{ $code\r
- "{ 8 13 14 27 } [ even? ] 5 '[ @ dup , ? ] map"\r
+ "{ 8 13 14 27 } [ even? ] 5 '[ @ dup _ ? ] map"\r
"{ 8 13 14 27 } [ even? ] 5 [ dup ] swap [ ? ] curry 3compose map"\r
"{ 8 13 14 27 } [ even? dup 5 ? ] map"\r
}\r
-"Occurrences of " { $link _ } " have the effect of enclosing all code to their left in a quotation passed to " { $link dip } ". The following four lines are equivalent:"\r
-{ $code \r
- "{ 10 20 30 } 1 '[ , _ / ] map"\r
- "{ 10 20 30 } 1 [ [ ] curry dip / ] curry map"\r
- "{ 10 20 30 } 1 [ swap / ] curry map"\r
- "{ 10 20 30 } [ 1 swap / ] map"\r
-}\r
-"For any quotation body " { $snippet "X" } ", the following two are equivalent:"\r
-{ $code\r
- "[ [ X ] dip ]"\r
- "'[ X _ ]"\r
-}\r
"Here are some built-in combinators rewritten in terms of fried quotations:"\r
{ $table\r
- { { $link literalize } { $snippet ": literalize '[ , ] ;" } }\r
- { { $link slip } { $snippet ": slip '[ @ , ] call ;" } }\r
- { { $link dip } { $snippet ": dip '[ @ _ ] call ;" } }\r
- { { $link curry } { $snippet ": curry '[ , @ ] ;" } }\r
- { { $link with } { $snippet ": with swapd '[ , _ @ ] ;" } }\r
+ { { $link literalize } { $snippet ": literalize '[ _ ] ;" } }\r
+ { { $link slip } { $snippet ": slip '[ @ _ ] call ;" } }\r
+ { { $link curry } { $snippet ": curry '[ _ @ ] ;" } }\r
{ { $link compose } { $snippet ": compose '[ @ @ ] ;" } }\r
- { { $link bi@ } { $snippet ": bi@ tuck '[ , @ , @ ] call ;" } }\r
+ { { $link bi@ } { $snippet ": bi@ tuck '[ _ @ _ @ ] call ;" } }\r
} ;\r
\r
ARTICLE: "fry.philosophy" "Fried quotation philosophy"\r
"Fried quotations generalize quotation-building words such as " { $link curry } " and " { $link compose } ". They can clean up code with lots of currying and composition, particularly when quotations are nested:"\r
{ $code\r
- "'[ [ , key? ] all? ] filter"\r
+ "'[ [ _ key? ] all? ] filter"\r
"[ [ key? ] curry all? ] curry filter"\r
}\r
"There is a mapping from fried quotations to lexical closures as defined in the " { $vocab-link "locals" } " vocabulary. Namely, a fried quotation is equivalent to a ``let'' form where each local binding is only used once, and bindings are used in the same order in which they are defined. The following two lines are equivalent:"\r
{ $code\r
- "'[ 3 , + 4 , / ]"\r
+ "'[ 3 _ + 4 _ / ]"\r
"[let | a [ ] b [ ] | [ 3 a + 4 b / ] ]"\r
-}\r
-"The " { $link _ } " fry specifier has no direct analogue in " { $vocab-link "locals" } ", however closure conversion together with the " { $link dip } " combinator achieve the same effect:"\r
-{ $code\r
- "'[ , 2 + , * _ / ]"\r
- "[let | a [ ] b [ ] | [ [ a 2 + b * ] dip / ] ]"\r
} ;\r
\r
ARTICLE: "fry.limitations" "Fried quotation limitations"\r
"Fried quotations are denoted with a special parsing word:"\r
{ $subsection POSTPONE: '[ }\r
"Fried quotations contain zero or more " { $emphasis "fry specifiers" } ":"\r
-{ $subsection , }\r
-{ $subsection @ }\r
{ $subsection _ }\r
+{ $subsection @ }\r
"When a fried quotation is being evaluated, values are consumed from the stack and spliced into the quotation from right to left."\r
{ $subsection "fry.examples" }\r
{ $subsection "fry.philosophy" }\r
USING: fry tools.test math prettyprint kernel io arrays
sequences ;
-[ [ 3 + ] ] [ 3 '[ , + ] ] unit-test
+[ [ 3 + ] ] [ 3 '[ _ + ] ] unit-test
-[ [ 1 3 + ] ] [ 1 3 '[ , , + ] ] unit-test
+[ [ 1 3 + ] ] [ 1 3 '[ _ _ + ] ] unit-test
-[ [ 1 + ] ] [ 1 [ + ] '[ , @ ] ] unit-test
+[ [ 1 + ] ] [ 1 [ + ] '[ _ @ ] ] unit-test
-[ [ 1 + . ] ] [ 1 [ + ] '[ , @ . ] ] unit-test
+[ [ 1 + . ] ] [ 1 [ + ] '[ _ @ . ] ] unit-test
[ [ + - ] ] [ [ + ] [ - ] '[ @ @ ] ] unit-test
[ [ "a" write "b" print ] ]
-[ "a" "b" '[ , write , print ] ] unit-test
+[ "a" "b" '[ _ write _ print ] ] unit-test
[ [ 1 2 + 3 4 - ] ]
[ [ + ] [ - ] '[ 1 2 @ 3 4 @ ] ] unit-test
[ 1/2 ] [
- 1 '[ , _ / ] 2 swap call
+ 1 '[ [ _ ] dip / ] 2 swap call
] unit-test
[ { { 1 "a" "A" } { 1 "b" "B" } { 1 "c" "C" } } ] [
- 1 '[ , _ _ 3array ]
+ 1 '[ [ _ ] 2dip 3array ]
{ "a" "b" "c" } { "A" "B" "C" } rot 2map
] unit-test
[ { { 1 "a" } { 1 "b" } { 1 "c" } } ] [
- '[ 1 _ 2array ]
+ '[ [ 1 ] dip 2array ]
{ "a" "b" "c" } swap map
] unit-test
-[ 1 2 ] [
- 1 2 '[ _ , ] call
-] unit-test
-
[ { { 1 "a" 2 } { 1 "b" 2 } { 1 "c" 2 } } ] [
- 1 2 '[ , _ , 3array ]
+ 1 2 '[ [ _ ] dip _ 3array ]
{ "a" "b" "c" } swap map
] unit-test
-: funny-dip '[ @ _ ] call ; inline
+: funny-dip '[ [ @ ] dip ] call ; inline
[ "hi" 3 ] [ "h" "i" 3 [ append ] funny-dip ] unit-test
[ { 1 2 3 } ] [
- 3 1 '[ , [ , + ] map ] call
+ 3 1 '[ _ [ _ + ] map ] call
] unit-test
[ { 1 { 2 { 3 } } } ] [
- 1 2 3 '[ , [ , [ , 1array ] call 2array ] call 2array ] call
+ 1 2 3 '[ _ [ _ [ _ 1array ] call 2array ] call 2array ] call
] unit-test
-{ 1 1 } [ '[ [ [ , ] ] ] ] must-infer-as
+{ 1 1 } [ '[ [ [ _ ] ] ] ] must-infer-as
[ { { { 3 } } } ] [
- 3 '[ [ [ , 1array ] call 1array ] call 1array ] call
+ 3 '[ [ [ _ 1array ] call 1array ] call 1array ] call
] unit-test
[ { { { 3 } } } ] [
- 3 '[ [ [ , 1array ] call 1array ] call 1array ] call
+ 3 '[ [ [ _ 1array ] call 1array ] call 1array ] call
] unit-test
! Copyright (C) 2008 Slava Pestov, Eduardo Cavazos.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences combinators parser splitting math
-quotations arrays namespaces qualified ;
-QUALIFIED: namespaces
+quotations arrays make qualified words ;
IN: fry
-: , ( -- * ) "Only valid inside a fry" throw ;
-: @ ( -- * ) "Only valid inside a fry" throw ;
: _ ( -- * ) "Only valid inside a fry" throw ;
+: @ ( -- * ) "Only valid inside a fry" throw ;
+
+<PRIVATE
DEFER: (shallow-fry)
DEFER: shallow-fry
] unless-empty ; inline
: (shallow-fry) ( accum quot -- result )
- [
- 1quotation
- ] [
+ [ 1quotation ] [
unclip {
- { \ , [ [ curry ] ((shallow-fry)) ] }
+ { \ _ [ [ curry ] ((shallow-fry)) ] }
{ \ @ [ [ compose ] ((shallow-fry)) ] }
-
- ! to avoid confusion, remove if fry goes core
- { \ namespaces:, [ [ curry ] ((shallow-fry)) ] }
-
[ swap >r suffix r> (shallow-fry) ]
} case
] if-empty ;
: shallow-fry ( quot -- quot' ) [ ] swap (shallow-fry) ;
-: deep-fry ( quot -- quot )
- { _ } last-split1 dup [
- shallow-fry [ >r ] rot
- deep-fry [ [ dip ] curry r> compose ] 4array concat
- ] [
- drop shallow-fry
- ] if ;
+PREDICATE: fry-specifier < word { _ @ } memq? ;
-: fry-specifier? ( obj -- ? ) { , namespaces:, @ } member? ;
+GENERIC: count-inputs ( quot -- n )
+
+M: callable count-inputs [ count-inputs ] sigma ;
+M: fry-specifier count-inputs drop 1 ;
+M: object count-inputs drop 0 ;
+
+PRIVATE>
-: count-inputs ( quot -- n )
- [
- {
- { [ dup callable? ] [ count-inputs ] }
- { [ dup fry-specifier? ] [ drop 1 ] }
- [ drop 0 ]
- } cond
- ] map sum ;
-
: fry ( quot -- quot' )
[
[
dup callable? [
- [ count-inputs \ , <repetition> % ] [ fry % ] bi
- ] [ namespaces:, ] if
+ [ count-inputs \ _ <repetition> % ] [ fry % ] bi
+ ] [ , ] if
] each
- ] [ ] make deep-fry ;
+ ] [ ] make shallow-fry ;
: '[ \ ] parse-until fry over push-all ; parsing
\r
: handle-get ( action -- response )\r
'[\r
- , dup display>> [\r
+ _ dup display>> [\r
{\r
[ init>> call ]\r
[ authorize>> call ]\r
\r
: handle-post ( action -- response )\r
'[\r
- , dup submit>> [\r
+ _ dup submit>> [\r
[ validate>> call ]\r
[ authorize>> call ]\r
[ submit>> call ]\r
\r
: <page-action> ( -- page )\r
page-action new-action\r
- dup '[ , template>> <chloe-content> ] >>display ;\r
+ dup '[ _ template>> <chloe-content> ] >>display ;\r
'[
<conversations>
<sessions>
- , , <db-persistence>
+ _ _ <db-persistence>
<check-form-submissions>
] call ;
: start-expiring ( db params -- )
'[
- , , [ state-classes [ expire-state ] each ] with-db
+ _ _ [ state-classes [ expire-state ] each ] with-db
] 5 minutes every drop ;
C: <secure-realm-only> secure-realm-only\r
\r
M: secure-realm-only call-responder*\r
- '[ , , call-next-method ] if-secure-realm ;\r
+ '[ _ _ call-next-method ] if-secure-realm ;\r
\r
TUPLE: protected < filter-responder description capabilities ;\r
\r
! Copyright (c) 2007 Chris Double.\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: accessors kernel splitting base64 namespaces strings\r
+USING: accessors kernel splitting base64 namespaces make strings\r
http http.server.responses furnace.auth ;\r
IN: furnace.auth.basic\r
\r
! Copyright (c) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces accessors kernel assocs arrays io.sockets threads
-fry urls smtp validators html.forms present
+USING: namespaces make accessors kernel assocs arrays io.sockets
+threads fry urls smtp validators html.forms present
http http.server.responses http.server.redirection
http.server.dispatchers
furnace furnace.actions furnace.auth furnace.auth.providers
] "" make >>body ;
: send-password-email ( user -- )
- '[ , password-email send-email ]
+ '[ _ password-email send-email ]
"E-mail send thread" spawn drop ;
: <recover-action-1> ( -- action )
: compile-link-attrs ( tag -- )
#! Side-effects current namespace.
- attrs>> '[ [ , _ link-attr ] each-responder ] [code] ;
+ attrs>> '[ [ [ _ ] dip link-attr ] each-responder ] [code] ;
: a-start-tag ( tag -- )
[ compile-link-attrs ] [ compile-a-url ] bi
: compile-hidden-form-fields ( for -- )
'[
- , [ "," split [ hidden render ] each ] when*
+ _ [ "," split [ hidden render ] each ] when*
nested-forms get " " join f like nested-forms-key hidden-form-field
[ modify-form ] each-responder
] [code] ;
: restore-conversation ( seq -- )
conversation get dup [
namespace>>
- [ '[ , key? ] filter ]
- [ '[ [ , at ] keep set ] each ]
+ [ '[ _ key? ] filter ]
+ [ '[ [ _ at ] keep set ] each ]
bi
] [ 2drop ] if ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces assocs sequences kernel classes splitting
+USING: namespaces make assocs sequences kernel classes splitting
vocabs.loader accessors strings combinators arrays
continuations present fry
urls html.elements
} cond ; inline
M: secure-only call-responder*
- '[ , , call-next-method ] if-secure ;
+ '[ _ _ call-next-method ] if-secure ;
IN: furnace.sessions.tests\r
-USING: tools.test http furnace.sessions\r
-furnace.actions http.server http.server.responses\r
-math namespaces kernel accessors io.sockets io.servers.connection\r
-prettyprint io.streams.string io.files splitting destructors\r
-sequences db db.tuples db.sqlite continuations urls math.parser\r
-furnace ;\r
+USING: tools.test http furnace.sessions furnace.actions\r
+http.server http.server.responses math namespaces make kernel\r
+accessors io.sockets io.servers.connection prettyprint\r
+io.streams.string io.files splitting destructors sequences db\r
+db.tuples db.sqlite continuations urls math.parser furnace ;\r
\r
: with-session\r
[\r
feed-action new-action
dup '[
feed new
- ,
+ _
[ title>> call >>title ]
[ url>> call adjust-url relative-to-request >>url ]
[ entries>> call process-entries >>entries ]
IN: generalizations\r
\r
MACRO: nsequence ( n seq -- quot )\r
- [ drop <reversed> ] [ '[ , , new-sequence ] ] 2bi\r
- [ '[ @ [ , swap set-nth-unsafe ] keep ] ] reduce ;\r
+ [ drop <reversed> ] [ '[ _ _ new-sequence ] ] 2bi\r
+ [ '[ @ [ _ swap set-nth-unsafe ] keep ] ] reduce ;\r
\r
MACRO: narray ( n -- quot )\r
- '[ , { } nsequence ] ;\r
+ '[ _ { } nsequence ] ;\r
\r
MACRO: firstn ( n -- )\r
dup zero? [ drop [ drop ] ] [\r
- [ [ '[ , _ nth-unsafe ] ] map ]\r
- [ 1- '[ , _ bounds-check 2drop ] ]\r
- bi prefix '[ , cleave ]\r
+ [ [ '[ [ _ ] dip nth-unsafe ] ] map ]\r
+ [ 1- '[ [ _ ] dip bounds-check 2drop ] ]\r
+ bi prefix '[ _ cleave ]\r
] if ;\r
\r
MACRO: npick ( n -- )\r
1- dup saver [ dup ] rot [ r> swap ] n*quot 3append ;\r
\r
MACRO: ndup ( n -- )\r
- dup '[ , npick ] n*quot ;\r
+ dup '[ _ npick ] n*quot ;\r
\r
MACRO: nrot ( n -- )\r
1- dup saver swap [ r> swap ] n*quot append ;\r
2 + [ dupd -nrot ] curry ;\r
\r
MACRO: nrev ( n -- quot )\r
- 1 [a,b] [ ] [ '[ @ , -nrot ] ] reduce ;\r
+ 1 [a,b] [ ] [ '[ @ _ -nrot ] ] reduce ;\r
\r
MACRO: ndip ( quot n -- )\r
dup saver -rot restorer 3append ;\r
\r
MACRO: nkeep ( n -- )\r
[ ] [ 1+ ] [ ] tri\r
- '[ [ , ndup ] dip , -nrot , nslip ] ;\r
+ '[ [ _ ndup ] dip _ -nrot _ nslip ] ;\r
\r
MACRO: ncurry ( n -- )\r
[ curry ] n*quot ;\r
\r
MACRO: napply ( n -- )\r
2 [a,b]\r
- [ [ 1- ] keep '[ , ntuck , nslip ] ]\r
+ [ [ 1- ] keep '[ _ ntuck _ nslip ] ]\r
map concat >quotation [ call ] append ;\r
ARTICLE: "collections" "Collections"
{ $heading "Sequences" }
{ $subsection "sequences" }
+{ $subsection "namespaces-make" }
"Fixed-length sequences:"
{ $subsection "arrays" }
{ $subsection "quotations" }
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays io io.styles kernel namespaces parser
-prettyprint sequences words assocs definitions generic
+USING: accessors arrays io io.styles kernel namespaces make
+parser prettyprint sequences words assocs definitions generic
quotations effects slots continuations classes.tuple debugger
combinators vocabs help.stylesheet help.topics help.crossref
help.markup sorting classes vocabs.loader ;
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: fry accessors sequences parser kernel help help.markup
-help.topics words strings classes tools.vocabs namespaces io
-io.streams.string prettyprint definitions arrays vectors
+help.topics words strings classes tools.vocabs namespaces make
+io io.streams.string prettyprint definitions arrays vectors
combinators combinators.short-circuit splitting debugger
hashtables sorting effects vocabs vocabs.loader assocs editors
continuations classes.predicate macros math sets eval ;
$predicate
$class-description
$error-description
- } swap '[ , elements empty? not ] contains? ;
+ } swap '[ _ elements empty? not ] contains? ;
: check-values ( word element -- )
{
H{ } clone [
'[
dup >link where dup
- [ first , at , push-at ] [ 2drop ] if
+ [ first _ at _ push-at ] [ 2drop ] if
] each
] keep ;
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays definitions generic io kernel assocs
-hashtables namespaces parser prettyprint sequences strings
+hashtables namespaces make parser prettyprint sequences strings
io.styles vectors words math sorting splitting classes slots
vocabs help.stylesheet help.topics vocabs.loader alias ;
IN: help.markup
! Copyright (C) 2005, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.x
USING: accessors arrays definitions generic assocs
-io kernel namespaces prettyprint prettyprint.sections
+io kernel namespaces make prettyprint prettyprint.sections
sequences words summary classes strings vocabs ;
IN: help.topics
: specializer-cases ( quot word -- default alist )
dup [ array? ] all? [ 1array ] unless [
[ make-specializer ] keep
- '[ , declare ] pick append
+ '[ _ declare ] pick append
] { } map>assoc ;
: method-declaration ( method -- quot )
bi prefix ;
: specialize-method ( quot method -- quot' )
- method-declaration '[ , declare ] prepend ;
+ method-declaration '[ _ declare ] prepend ;
: specialize-quot ( quot specializer -- quot' )
specializer-cases alist>quot ;
</option> ;
: render-options ( options selected -- )
- '[ dup , member? render-option ] each ;
+ '[ dup _ member? render-option ] each ;
M: choice render*
<select
: def-for-html-word-<foo> ( name -- )
#! Return the name and code for the <foo> patterned
#! word.
- dup <foo> swap '[ , <foo> write-html ]
+ dup <foo> swap '[ _ <foo> write-html ]
(( -- )) html-word ;
: <foo ( str -- <str ) "<" prepend ;
: def-for-html-word-<foo ( name -- )
#! Return the name and code for the <foo patterned
#! word.
- <foo dup '[ , write-html ]
+ <foo dup '[ _ write-html ]
(( -- )) html-word ;
: foo> ( str -- foo> ) ">" append ;
: def-for-html-word-</foo> ( name -- )
#! Return the name and code for the </foo> patterned
#! word.
- </foo> dup '[ , write-html ] (( -- )) html-word ;
+ </foo> dup '[ _ write-html ] (( -- )) html-word ;
: <foo/> ( str -- <str/> ) "<" swap "/>" 3append ;
: def-for-html-word-<foo/> ( name -- )
#! Return the name and code for the <foo/> patterned
#! word.
- dup <foo/> swap '[ , <foo/> write-html ]
+ dup <foo/> swap '[ _ <foo/> write-html ]
(( -- )) html-word ;
: foo/> ( str -- str/> ) "/>" append ;
: define-attribute-word ( name -- )
dup "=" prepend swap
- '[ , write-attr ] (( string -- )) html-word ;
+ '[ _ write-attr ] (( string -- )) html-word ;
! Define some closed HTML tags
[
: with-form ( name quot -- )
'[
- ,
+ _
[ nested-forms [ swap prefix ] change ]
[ value form set ]
bi
swap set-value ;
: validate-values ( assoc validators -- assoc' )
- swap '[ dup , at _ validate-value ] assoc-each ;
+ swap '[ [ dup _ at ] dip validate-value ] assoc-each ;
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-
-USING: combinators generic assocs help http io io.styles io.files
- continuations io.streams.string kernel math math.order math.parser
- namespaces quotations assocs sequences strings words html.elements
- xml.entities sbufs continuations destructors accessors arrays ;
-
+USING: combinators generic assocs help http io io.styles
+io.files continuations io.streams.string kernel math math.order
+math.parser namespaces make quotations assocs sequences strings
+words html.elements xml.entities sbufs continuations destructors
+accessors arrays ;
IN: html.streams
GENERIC: browser-link-href ( presented -- href )
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel sequences combinators kernel fry
-namespaces classes.tuple assocs splitting words arrays memoize
-io io.files io.encodings.utf8 io.streams.string unicode.case
-mirrors math urls present multiline quotations xml xml.data
+namespaces make classes.tuple assocs splitting words arrays
+memoize io io.files io.encodings.utf8 io.streams.string
+unicode.case mirrors math urls present multiline quotations xml
+xml.data
html.forms
html.elements
html.components
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: assocs namespaces kernel sequences accessors combinators
-strings splitting io io.streams.string present xml.writer
-xml.data xml.entities html.forms html.templates.chloe.syntax ;
+USING: assocs namespaces make kernel sequences accessors
+combinators strings splitting io io.streams.string present
+xml.writer xml.data xml.entities html.forms
+html.templates.chloe.syntax ;
IN: html.templates.chloe.compiler
: chloe-attrs-only ( assoc -- assoc' )
: CHLOE-SINGLETON:
scan-word
- [ name>> ] [ '[ , singleton-component-tag ] ] bi
+ [ name>> ] [ '[ _ singleton-component-tag ] ] bi
define-chloe-tag ;
parsing
: compile-component-attrs ( tag class -- )
[ attrs>> [ drop main>> "name" = not ] assoc-filter ] dip
- [ all-slots swap '[ name>> , at compile-attr ] each ]
+ [ all-slots swap '[ name>> _ at compile-attr ] each ]
[ [ boa ] [code-with] ]
bi ;
: CHLOE-TUPLE:
scan-word
- [ name>> ] [ '[ , tuple-component-tag ] ] bi
+ [ name>> ] [ '[ _ tuple-component-tag ] ] bi
define-chloe-tag ;
parsing
C: <fhtml> fhtml
M: fhtml call-template* ( filename -- )
- '[ , path>> utf8 file-contents eval-template ] assert-depth ;
+ '[ _ path>> utf8 file-contents eval-template ] assert-depth ;
INSTANCE: fhtml template
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs kernel math math.parser namespaces
+USING: accessors assocs kernel math math.parser namespaces make
sequences io io.sockets io.streams.string io.files io.timeouts
strings splitting calendar continuations accessors vectors
math.order hashtables byte-arrays prettyprint
SYMBOL: redirects
: redirect-url ( request url -- request )
- '[ , >url derive-url ensure-port ] change-url ;
+ '[ _ >url derive-url ensure-port ] change-url ;
: do-redirect ( response data -- response data )
over code>> 300 399 between? [
: download-to ( url file -- )
#! Downloads the contents of a URL to a file.
swap http-get
- [ content-charset>> ] [ '[ , write ] ] bi*
+ [ content-charset>> ] [ '[ _ write ] ] bi*
with-file-writer ;
: download ( url -- )
! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel combinators math namespaces
+USING: accessors kernel combinators math namespaces make
assocs sequences splitting sorting sets debugger
strings vectors hashtables quotations arrays byte-arrays
math.parser calendar calendar.format present
[ read-crlf dup f like ] [ parse-header-line ] [ drop ] produce ;
: collect-headers ( assoc -- assoc' )
- H{ } clone [ '[ , push-at ] assoc-each ] keep ;
+ H{ } clone [ '[ _ push-at ] assoc-each ] keep ;
: process-header ( alist -- assoc )
f swap [ [ swap or dup ] dip swap ] assoc-map nip
[ clone ] change-cookies ;
: get-cookie ( request/response name -- cookie/f )
- [ cookies>> ] dip '[ , _ name>> = ] find nip ;
+ [ cookies>> ] dip '[ [ _ ] dip name>> = ] find nip ;
: delete-cookie ( request/response name -- )
over cookies>> [ get-cookie ] dip delete ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: combinators.short-circuit math math.order math.parser kernel
-sequences sequences.deep peg peg.parsers assocs arrays
-hashtables strings unicode.case namespaces ascii ;
+USING: combinators.short-circuit math math.order math.parser
+kernel sequences sequences.deep peg peg.parsers assocs arrays
+hashtables strings unicode.case namespaces make ascii ;
IN: http.parsers
: except ( quot -- parser )
200 >>code\r
"CGI output follows" >>message\r
swap '[\r
-
, output-stream get swap <cgi-process> <process-stream> [
\r+
_ output-stream get swap <cgi-process> <process-stream> [
\r post-request? [ request get post-data>> raw>> write flush ] when\r
input-stream get swap (stream-copy)\r
] with-stream\r
: <500> ( error -- response )
500 "Internal server error" <trivial-response>
- swap development? get [ '[ , http-error. ] >>body ] [ drop ] if ;
+ swap development? get [ '[ _ http-error. ] >>body ] [ drop ] if ;
: do-response ( response -- )
[ request get swap write-full-response ]
[
local-address get
[ secure? "https" "http" ? >>protocol ]
- [ port>> '[ , or ] change-port ]
+ [ port>> '[ _ or ] change-port ]
bi
] change-url drop ;
: do-request ( request -- response )
'[
- ,
+ _
{
[ init-request ]
[ prepare-request ]
\r
: list-directory ( directory -- response )\r
file-responder get allow-listings>> [\r
- '[ , directory. ] "text/html" <content>\r
+ '[ _ directory. ] "text/html" <content>\r
] [\r
drop <403>\r
] if ;\r
! Copyright (C) 2008 Daniel Ehrenberg.\r
! See http://factorcode.org/license.txt for BSD license.\r
USING: kernel sequences arrays accessors grouping math.order\r
-sorting binary-search math assocs locals namespaces ;\r
+sorting binary-search math assocs locals namespaces make ;\r
IN: interval-maps\r
\r
TUPLE: interval-map array ;\r
: handle-client ( client remote local -- )
'[
- , , log-connection
+ _ _ log-connection
threaded-server get
[ timeout>> timeouts ] [ handle-client* ] bi
] with-stream ;
: accept-connection ( threaded-server -- )
[ accept ] [ addr>> ] bi
- [ '[ , , , handle-client ] ]
+ [ '[ _ _ _ handle-client ] ]
[ drop threaded-server get name>> swap thread-name ] 2bi
spawn drop ;
PRIVATE>
: with-datagrams ( seq service quot -- )
- '[ [ , _ spawn-datagrams ] parallel-each ] with-logging ; inline
+ '[ [ [ _ ] dip spawn-datagrams ] parallel-each ] with-logging ; inline
USING: alien alien.c-types generic assocs kernel kernel.private
math io.ports sequences strings structs sbufs threads unix
vectors io.buffers io.backend io.encodings math.parser
-continuations system libc qualified namespaces io.timeouts
+continuations system libc qualified namespaces make io.timeouts
io.encodings.utf8 destructors accessors summary combinators
locals ;
QUALIFIED: io
USING: io.files io.sockets io kernel threads
namespaces tools.test continuations strings byte-arrays
sequences prettyprint system io.encodings.binary io.encodings.ascii
-io.streams.duplex destructors ;
+io.streams.duplex destructors make ;
IN: io.unix.tests
! Unix domain stream sockets
! Copyright (C) 2006 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel parser-combinators namespaces sequences promises strings
+USING: kernel parser-combinators namespaces make sequences promises strings
assocs math math.parser math.vectors math.functions math.order
lists hashtables ascii accessors ;
IN: json.reader
! Copyright (C) 2006 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel io.streams.string io strings splitting sequences math
- math.parser assocs classes words namespaces prettyprint
- hashtables mirrors tr ;
+USING: kernel io.streams.string io strings splitting sequences
+math math.parser assocs classes words namespaces make
+prettyprint hashtables mirrors tr ;
IN: json.writer
#! Writes the object out to a stream in JSON format
USING: sequences kernel math locals math.order math.ranges\r
-accessors arrays namespaces combinators combinators.short-circuit ;\r
+accessors arrays namespaces make combinators\r
+combinators.short-circuit ;\r
IN: lcs\r
\r
<PRIVATE\r
! Copyright (C) 2007, 2008 Slava Pestov, Eduardo Cavazos.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel namespaces sequences sequences.private assocs math
- vectors strings classes.tuple generalizations
- parser words quotations debugger macros arrays macros splitting
- combinators prettyprint.backend definitions prettyprint
- hashtables prettyprint.sections sets sequences.private effects
- effects.parser generic generic.parser compiler.units accessors
- locals.backend memoize macros.expander lexer
- stack-checker.known-words ;
-
+USING: kernel namespaces make sequences sequences.private assocs
+math vectors strings classes.tuple generalizations parser words
+quotations debugger macros arrays macros splitting combinators
+prettyprint.backend definitions prettyprint hashtables
+prettyprint.sections sets sequences.private effects
+effects.parser generic generic.parser compiler.units accessors
+locals.backend memoize macros.expander lexer
+stack-checker.known-words ;
IN: locals
! Inspired by
! Copyright (C) 2008 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
USING: logging.analysis logging.server logging smtp kernel\r
-io.files io.streams.string namespaces alarms assocs\r
+io.files io.streams.string namespaces make alarms assocs\r
io.encodings.utf8 accessors calendar sequences qualified ;\r
QUALIFIED: io.sockets\r
IN: logging.insomniac\r
: input# ( word -- n ) stack-effect in>> length ;\r
\r
: input-logging-quot ( quot word level -- quot' )\r
- rot [ [ input# ] keep ] 2dip '[ , , , log-stack @ ] ;\r
+ rot [ [ input# ] keep ] 2dip '[ _ _ _ log-stack @ ] ;\r
\r
: add-input-logging ( word level -- )\r
[ input-logging-quot ] (define-logging) ;\r
: output# ( word -- n ) stack-effect out>> length ;\r
\r
: output-logging-quot ( quot word level -- quot' )\r
- [ [ output# ] keep ] dip '[ @ , , , log-stack ] ;\r
+ [ [ output# ] keep ] dip '[ @ _ _ _ log-stack ] ;\r
\r
: add-output-logging ( word level -- )\r
[ output-logging-quot ] (define-logging) ;\r
\r
: error-logging-quot ( quot word -- quot' )\r
dup stack-effect stack-balancer\r
- '[ , [ , log-error @ ] recover ] ;\r
+ '[ _ [ _ log-error @ ] recover ] ;\r
\r
: add-error-logging ( word level -- )\r
[ [ input-logging-quot ] 2keep drop error-logging-quot ]\r
: LOG:\r
#! Syntax: name level\r
CREATE-WORD dup scan-word\r
- '[ 1array stack>message , , log-message ]\r
+ '[ 1array stack>message _ _ log-message ]\r
(( message -- )) define-declared ; parsing\r
\r
USE: vocabs.loader\r
! Copyright (C) 2008 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
USING: accessors peg peg.parsers memoize kernel sequences\r
-logging arrays words strings vectors io io.files io.encodings.utf8\r
-namespaces combinators logging.server calendar calendar.format ;\r
+logging arrays words strings vectors io io.files\r
+io.encodings.utf8 namespaces make combinators logging.server\r
+calendar calendar.format ;\r
IN: logging.parser\r
\r
TUPLE: log-entry date level word-name message ;\r
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences namespaces quotations accessors words
-continuations vectors effects math stack-checker.transforms ;
+USING: kernel sequences namespaces make quotations accessors
+words continuations vectors effects math
+stack-checker.transforms ;
IN: macros.expander
GENERIC: expand-macros ( quot -- quot' )
! See http://factorcode.org/license.txt for BSD license.
!
! Based on pattern matching code from Paul Graham's book 'On Lisp'.
-USING: parser lexer kernel words namespaces sequences classes.tuple
-combinators macros assocs math effects ;
+USING: parser lexer kernel words namespaces make sequences
+classes.tuple combinators macros assocs math effects ;
IN: match
SYMBOL: _
\ byte-bit-count
256 [
0 swap [ [ 1+ ] when ] each-bit
-] B{ } map-as '[ HEX: ff bitand , nth-unsafe ] define-inline
+] B{ } map-as '[ HEX: ff bitand _ nth-unsafe ] define-inline
>>
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel kernel.private math math.private words
-sequences parser namespaces assocs quotations arrays locals
+sequences parser namespaces make assocs quotations arrays locals
generic generic.math hashtables effects compiler.units ;
IN: math.partial-dispatch
! Copyright (C) 2007 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel hashtables sequences arrays words namespaces
+USING: kernel hashtables sequences arrays words namespaces make
parser math assocs effects definitions quotations summary
accessors ;
IN: memoize
} ;
MEMO: mime-types ( -- assoc )
- [ mime-db [ unclip '[ , _ set ] each ] each ] H{ } make-assoc
+ [
+ mime-db [ unclip '[ [ _ ] dip set ] each ] each
+ ] H{ } make-assoc
nonstandard-mime-types assoc-union ;
: mime-type ( filename -- mime-type )
! Copyright (C) 2007 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces parser lexer kernel sequences words quotations math
-accessors ;
+USING: namespaces make parser lexer kernel sequences words
+quotations math accessors ;
IN: multiline
<PRIVATE
! Copyright (C) 2007 Chris Double.\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: kernel compiler.units words arrays strings math.parser sequences \r
- quotations vectors namespaces math assocs continuations peg\r
- peg.parsers unicode.categories multiline \r
- splitting accessors effects sequences.deep peg.search\r
- combinators.short-circuit lexer io.streams.string\r
- stack-checker io prettyprint combinators parser ;\r
+USING: kernel compiler.units words arrays strings math.parser\r
+sequences quotations vectors namespaces make math assocs\r
+continuations peg peg.parsers unicode.categories multiline\r
+splitting accessors effects sequences.deep peg.search\r
+combinators.short-circuit lexer io.streams.string stack-checker\r
+io prettyprint combinators parser ;\r
IN: peg.ebnf\r
\r
: rule ( name word -- parser )\r
! Copyright (C) 2007, 2008 Chris Double, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences strings namespaces math assocs shuffle
- vectors arrays math.parser accessors
- unicode.categories sequences.deep peg peg.private
- peg.search math.ranges words ;
+USING: kernel sequences strings namespaces make math assocs
+shuffle vectors arrays math.parser accessors unicode.categories
+sequences.deep peg peg.private peg.search math.ranges words ;
IN: peg.parsers
TUPLE: just-parser p1 ;
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
!
-USING: kernel tools.test strings namespaces arrays sequences
+USING: kernel tools.test strings namespaces make arrays sequences
peg peg.private accessors words math accessors ;
IN: peg.tests
! Copyright (C) 2007, 2008 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences strings fry namespaces math assocs shuffle debugger io
- vectors arrays math.parser math.order vectors combinators
- classes sets unicode.categories compiler.units parser
- words quotations effects memoize accessors locals effects splitting
- combinators.short-circuit combinators.short-circuit.smart
- generalizations ;
+USING: kernel sequences strings fry namespaces make math assocs
+shuffle debugger io vectors arrays math.parser math.order
+vectors combinators classes sets unicode.categories
+compiler.units parser words quotations effects memoize accessors
+locals effects splitting combinators.short-circuit
+combinators.short-circuit.smart generalizations ;
IN: peg
USE: prettyprint
] if ;
M: token-parser (compile) ( peg -- quot )
- symbol>> '[ input-slice , parse-token ] ;
+ symbol>> '[ input-slice _ parse-token ] ;
TUPLE: satisfy-parser quot ;
M: satisfy-parser (compile) ( peg -- quot )
- quot>> '[ input-slice , parse-satisfy ] ;
+ quot>> '[ input-slice _ parse-satisfy ] ;
TUPLE: range-parser min max ;
] if ;
M: range-parser (compile) ( peg -- quot )
- [ min>> ] [ max>> ] bi '[ input-slice , , parse-range ] ;
+ [ min>> ] [ max>> ] bi '[ input-slice _ _ parse-range ] ;
TUPLE: seq-parser parsers ;
M: repeat0-parser (compile) ( peg -- quot )
p1>> compile-parser 1quotation '[
- input-slice V{ } clone <parse-result> , swap (repeat)
+ input-slice V{ } clone <parse-result> _ swap (repeat)
] ;
TUPLE: repeat1-parser p1 ;
M: repeat1-parser (compile) ( peg -- quot )
p1>> compile-parser 1quotation '[
- input-slice V{ } clone <parse-result> , swap (repeat) repeat1-empty-check
+ input-slice V{ } clone <parse-result> _ swap (repeat) repeat1-empty-check
] ;
TUPLE: optional-parser p1 ;
M: semantic-parser (compile) ( peg -- quot )
[ p1>> compile-parser 1quotation ] [ quot>> ] bi
- '[ @ , check-semantic ] ;
+ '[ @ _ check-semantic ] ;
TUPLE: ensure-parser p1 ;
] if ; inline
M: action-parser (compile) ( peg -- quot )
- [ p1>> compile-parser 1quotation ] [ quot>> ] bi '[ @ , check-action ] ;
+ [ p1>> compile-parser 1quotation ] [ quot>> ] bi '[ @ _ check-action ] ;
TUPLE: sp-parser p1 ;
: random-assocs ( -- hash phash )
[ random-string ] replicate
- [ H{ } clone [ '[ swap , set-at ] each-index ] keep ]
+ [ H{ } clone [ '[ swap _ set-at ] each-index ] keep ]
[ PH{ } clone swap [ spin new-at ] each-index ]
bi ;
! Based on Clojure's PersistentHashMap by Rich Hickey.
USING: kernel math accessors assocs fry combinators parser
-prettyprint.backend namespaces
+prettyprint.backend make
persistent.assocs
persistent.hashtables.nodes
persistent.hashtables.nodes.empty
IN: persistent.hashtables.nodes.collision
: find-index ( key hashcode collision-node -- n leaf-node )
- leaves>> -rot '[ , , _ matching-key? ] find ; inline
+ leaves>> -rot '[ [ _ _ ] dip matching-key? ] find ; inline
M:: collision-node (entry-at) ( key hashcode collision-node -- leaf-node )
key hashcode collision-node find-index nip ;
! Based on Clojure's PersistentHashMap by Rich Hickey.
-USING: kernel accessors locals math arrays namespaces
+USING: kernel accessors locals math arrays namespaces make
persistent.hashtables.config
persistent.hashtables.nodes ;
IN: persistent.hashtables.nodes.leaf
! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays byte-arrays byte-vectors generic
-hashtables io assocs kernel math namespaces sequences strings
-sbufs io.styles vectors words prettyprint.config
+hashtables io assocs kernel math namespaces make sequences
+strings sbufs io.styles vectors words prettyprint.config
prettyprint.sections quotations io io.files math.parser effects
classes.tuple math.order classes.tuple.private classes
combinators colors ;
prettyprint.sections sequences tools.test vectors words
effects splitting generic.standard prettyprint.private
continuations generic compiler.units tools.walker eval
-accessors ;
+accessors make ;
IN: prettyprint.tests
[ "4" ] [ 4 unparse ] unit-test
: another-soft-break-test
{
- "USING: namespaces sequences ;"
+ "USING: make sequences ;"
"IN: prettyprint.tests"
": another-soft-break-layout ( node -- quot )"
" parse-error-file"
! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-
-USING: arrays generic generic.standard assocs io kernel
-math namespaces sequences strings io.styles io.streams.string
+USING: arrays generic generic.standard assocs io kernel math
+namespaces make sequences strings io.styles io.streams.string
vectors words prettyprint.backend prettyprint.sections
prettyprint.config sorting splitting grouping math.parser vocabs
definitions effects classes.builtin classes.tuple io.files
classes continuations hashtables classes.mixin classes.union
classes.intersection classes.predicate classes.singleton
combinators quotations sets accessors colors ;
-
IN: prettyprint
: make-pprint ( obj quot -- block in use )
! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic hashtables io kernel math assocs
-namespaces sequences strings io.styles vectors words
+namespaces make sequences strings io.styles vectors words
prettyprint.config splitting classes continuations
io.streams.nested accessors sets ;
IN: prettyprint.sections
+++ /dev/null
-USING: help.markup help.syntax math ;
-IN: random.mersenne-twister
-
-ARTICLE: "random-numbers" "Generating random integers"
-"The " { $vocab-link "random" } " vocabulary implements the ``Mersenne Twister'' pseudo-random number generator algorithm."
-! { $subsection init-random }
-{ $subsection (random) }
-{ $subsection random } ;
-
-ABOUT: "random-numbers"
-
-! HELP: init-random
-! { $values { "seed" integer } }
-! { $description "Initializes the random number generator with the given seed. This word is called on startup to initialize the random number generator with the current time." } ;
-
-HELP: (random)
-{ $values { "rand" "an integer between 0 and 2^32-1" } }
-{ $description "Generates a random 32-bit unsigned integer." } ;
-
-HELP: random
-{ $values { "seq" "a sequence" } { "elt" "a random element" } }
-{ $description "Outputs a random element of the sequence. If the sequence is empty, always outputs " { $link f } "." }
-{ $notes "Since integers are sequences, passing an integer " { $snippet "n" } " yields a random integer in the interval " { $snippet "[0,n)" } "." } ;
-
-HELP: big-random
-{ $values { "n" "an integer" } { "r" "a random integer" } }
-{ $description "Outputs an integer with n bytes worth of bits." } ;
-
-HELP: random-256
-{ $values { "r" "a random integer" } }
-{ $description "Outputs an random integer 256 bits in length." } ;
-USING: kernel math random namespaces random.mersenne-twister
-sequences tools.test math.order ;
+USING: kernel math random namespaces make
+random.mersenne-twister sequences tools.test math.order ;
IN: random.mersenne-twister.tests
: check-random ( max -- ? )
USING: sequences.deep kernel tools.test strings math arrays
-namespaces sequences ;
+namespaces make sequences ;
IN: sequences.deep.tests
[ [ "hello" 3 4 swap ] ] [ [ { "hello" V{ 3 4 } } swap ] flatten ] unit-test
! Copyright (C) 2007, 2008 Elie CHAFTARI, Dirk Vleugels,
! Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays namespaces io io.timeouts kernel logging
+USING: arrays namespaces make io io.timeouts kernel logging
io.sockets sequences combinators splitting assocs strings
math.parser random system calendar io.encodings.ascii summary
calendar.format accessors sets hashtables ;
2array recursive-state get swap prefix infer-quot ;
: time-bomb ( error -- )
- '[ , throw ] recursive-state get infer-quot ;
+ '[ _ throw ] recursive-state get infer-quot ;
: bad-call ( -- )
"call must be given a callable" time-bomb ;
] maybe-cannot-infer ;
: apply-word/effect ( word effect -- )
- swap '[ , #call, ] consume/produce ;
+ swap '[ _ #call, ] consume/produce ;
: required-stack-effect ( word -- effect )
dup stack-effect [ ] [ \ missing-effect inference-error ] ?if ;
: pad-with-bottom ( seq -- newseq )
dup empty? [
dup [ length ] map supremum
- '[ , +bottom+ pad-left ] map
+ '[ _ +bottom+ pad-left ] map
] unless ;
: phi-inputs ( max-d-in pairs -- newseq )
dup empty? [ nip ] [
- swap '[ , _ first2 unify-inputs ] map
+ swap '[ [ _ ] dip first2 unify-inputs ] map
pad-with-bottom
] if ;
] if-empty ;
: branch-variable ( seq symbol -- seq )
- '[ , _ at ] map ;
+ '[ [ _ ] dip at ] map ;
: active-variable ( seq symbol -- seq )
[ [ terminated? over at [ drop f ] when ] map ] dip
: adjust-stack-effect ( effect -- effect' )
[ in>> ] [ out>> ] bi
meta-d get length pick length [-]
- object <repetition> '[ , prepend ] bi@
+ object <repetition> '[ _ prepend ] bi@
<effect> ;
: call-recursive-inline-word ( word -- )
dup "recursive" word-prop [
[ required-stack-effect adjust-stack-effect ] [ ] [ recursive-label ] tri
- [ 2nip check-call ] [ nip '[ , #call-recursive, ] consume/produce ] 3bi
+ [ 2nip check-call ] [ nip '[ _ #call-recursive, ] consume/produce ] 3bi
] [ undeclared-recursion-error inference-error ] if ;
: inline-word ( word -- )
: depends-on ( word how -- )
over primitive? [ 2drop ] [
dependencies get dup [
- swap '[ , strongest-dependency ] change-at
+ swap '[ _ strongest-dependency ] change-at
] [ 3drop ] if
] if ;
: depends-on-generic ( generic class -- )
generic-dependencies get dup
- [ swap '[ null or , class-or ] change-at ] [ 3drop ] if ;
+ [ swap '[ null or _ class-or ] change-at ] [ 3drop ] if ;
! Words we've inferred the stack effect of, for rollback
SYMBOL: recorded
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: fry accessors arrays kernel words sequences generic math
-namespaces quotations assocs combinators classes.tuple
+namespaces make quotations assocs combinators classes.tuple
classes.tuple.private effects summary hashtables classes generic
sets definitions generic.standard slots.private continuations
stack-checker.backend stack-checker.state stack-checker.visitor
dup [
[
[ drop ] [
- [ length meta-d get '[ , pop* ] times ]
+ [ length meta-d get '[ _ pop* ] times ]
[ #drop, ]
bi
] bi*
dup tuple-class? [
dup inlined-dependency depends-on
[ "boa-check" word-prop ]
- [ tuple-layout '[ , <tuple-boa> ] ]
+ [ tuple-layout '[ _ <tuple-boa> ] ]
bi append
] [ drop f ] if
] 1 define-transform
#! from code until the quotation given is true and\r
#! advance spot to after the substring.\r
10 <sbuf> [\r
- '[ @ [ t ] [ get-char , push f ] if ] skip-until\r
+ '[ @ [ t ] [ get-char _ push f ] if ] skip-until\r
] keep >string ; inline\r
\r
: take-rest ( -- string )\r
\r
: take ( n -- string )\r
[ 1- ] [ <sbuf> ] bi [\r
- '[ drop get-char [ next , push f ] [ t ] if* ] contains? drop\r
+ '[ drop get-char [ next _ push f ] [ t ] if* ] contains? drop\r
] keep get-char [ over push ] when* >string ;\r
\r
: pass-blank ( -- )\r
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors classes sequences splitting kernel namespaces
-words math math.parser io.styles prettyprint assocs ;
+make words math math.parser io.styles prettyprint assocs ;
IN: summary
GENERIC: summary ( object -- string )
USING: xml.utilities kernel assocs xml.generator math.order
strings sequences xml.data xml.writer
io.streams.string combinators xml xml.entities io.files io
- http.client namespaces xml.generator hashtables
+ http.client namespaces make xml.generator hashtables
calendar.format accessors continuations urls present ;
IN: syndication
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces continuations.private kernel.private init
+USING: namespaces make continuations.private kernel.private init
assocs kernel vocabs words sequences memory io system arrays
continuations math definitions mirrors splitting parser classes
summary layouts vocabs.loader prettyprint.config prettyprint
-debugger io.streams.c io.files io.backend
-quotations io.launcher words.private tools.deploy.config
-bootstrap.image io.encodings.utf8 destructors accessors ;
+debugger io.streams.c io.files io.backend quotations io.launcher
+words.private tools.deploy.config bootstrap.image
+io.encodings.utf8 destructors accessors ;
IN: tools.deploy.backend
: copy-vm ( executable bundle-name extension -- vm )
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: io io.files kernel namespaces sequences
+USING: io io.files kernel namespaces make sequences
system tools.deploy.backend tools.deploy.config assocs
hashtables prettyprint io.unix.backend cocoa io.encodings.utf8
io.backend cocoa.application cocoa.classes cocoa.plists
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors qualified io.streams.c init fry namespaces
+USING: accessors qualified io.streams.c init fry namespaces make
assocs kernel parser lexer strings.parser tools.deploy.config
vocabs sequences words words.private memory kernel.private
continuations io prettyprint vocabs.loader debugger system
[
[
props>> swap
- '[ drop , member? not ] assoc-filter sift-assoc
+ '[ drop _ member? not ] assoc-filter sift-assoc
dup assoc-empty? [ drop f ] [ >alist >vector ] if
] keep (>>props)
] with each ;
strip-globals? [
"Stripping globals" show
global swap
- '[ drop , member? not ] assoc-filter
+ '[ drop _ member? not ] assoc-filter
[ drop string? not ] assoc-filter ! strip CLI args
sift-assoc
dup keys unparse show
! Copyright (C) 2008 Slava Pestov, Jorge Acereda Macia.
! See http://factorcode.org/license.txt for BSD license.
USING: io.files io words alien kernel math.parser alien.syntax
-io.launcher system assocs arrays sequences namespaces qualified
-system math compiler.generator.fixup io.encodings.ascii
-accessors generic tr ;
+io.launcher system assocs arrays sequences namespaces make
+qualified system math compiler.generator.fixup
+io.encodings.ascii accessors generic tr ;
IN: tools.disassembler
: in-file ( -- path ) "gdb-in.txt" temp-file ;
! Copyright (C) 2007, 2008 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
USING: kernel io io.styles io.files io.encodings.utf8\r
-vocabs.loader vocabs sequences namespaces math.parser arrays\r
-hashtables assocs memoize summary sorting splitting combinators\r
-source-files debugger continuations compiler.errors init\r
-checksums checksums.crc32 sets accessors ;\r
+vocabs.loader vocabs sequences namespaces make math.parser\r
+arrays hashtables assocs memoize summary sorting splitting\r
+combinators source-files debugger continuations compiler.errors\r
+init checksums checksums.crc32 sets accessors ;\r
IN: tools.vocabs\r
\r
: vocab-tests-file ( vocab -- path )\r
sequences math namespaces.private continuations.private
concurrency.messaging quotations kernel.private words
sequences.private assocs models models.filter arrays accessors
-generic generic.standard definitions ;
+generic generic.standard definitions make ;
IN: tools.walker
SYMBOL: show-walker-hook ! ( status continuation thread -- )
<PRIVATE
: compute-tr ( quot from to -- mapping )
- zip [ 256 ] 2dip '[ [ @ , at ] keep or ] B{ } map-as ; inline
+ zip [ 256 ] 2dip '[ [ @ _ at ] keep or ] B{ } map-as ; inline
: tr-hints ( word -- )
{ { byte-array } { string } } "specializer" set-word-prop ;
create-in dup tr-hints ;
: tr-quot ( mapping -- quot )
- '[ [ dup 0 255 between? [ , nth-unsafe ] when ] map ] ;
+ '[ [ dup 0 255 between? [ _ nth-unsafe ] when ] map ] ;
: define-tr ( word mapping -- )
tr-quot (( seq -- translated )) define-declared ;
: fast-tr-quot ( mapping -- quot )
- '[ [ , nth-unsafe ] change-each ] ;
+ '[ [ _ nth-unsafe ] change-each ] ;
: define-fast-tr ( word mapping -- )
fast-tr-quot (( seq -- )) define-declared ;
USING: accessors ui.gestures help.markup help.syntax strings kernel
-hashtables quotations words classes sequences namespaces
+hashtables quotations words classes sequences namespaces make
arrays assocs ;
IN: ui.commands
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays definitions kernel sequences strings
-math assocs words generic namespaces assocs quotations splitting
-ui.gestures unicode.case unicode.categories tr ;
+math assocs words generic namespaces make assocs quotations
+splitting ui.gestures unicode.case unicode.categories tr ;
IN: ui.commands
SYMBOL: +nullary+
! Copyright (C) 2006, 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays documents io kernel math models
-namespaces opengl opengl.gl sequences strings io.styles
+namespaces make opengl opengl.gl sequences strings io.styles
math.vectors sorting colors combinators assocs math.order
ui.clipboards ui.commands ui.gadgets ui.gadgets.borders
ui.gadgets.buttons ui.gadgets.labels ui.gadgets.scrollers
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays hashtables kernel models math namespaces
- sequences quotations math.vectors combinators sorting
- binary-search vectors dlists deques models threads
- concurrency.flags math.order math.geometry.rect ;
-
+make sequences quotations math.vectors combinators sorting
+binary-search vectors dlists deques models threads
+concurrency.flags math.order math.geometry.rect ;
IN: ui.gadgets
SYMBOL: ui-notify-flag
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel math namespaces sequences words io
+USING: arrays kernel math namespaces make sequences words io
io.streams.string math.vectors ui.gadgets columns accessors
math.geometry.rect ;
IN: ui.gadgets.grids
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays hashtables io kernel math namespaces
-opengl sequences strings splitting
-ui.gadgets ui.gadgets.tracks ui.gadgets.theme ui.render colors
-models ;
+make opengl sequences strings splitting ui.gadgets
+ui.gadgets.tracks ui.gadgets.theme ui.render colors models ;
IN: ui.gadgets.labels
! A label gadget draws a string.
TUPLE: track < pack sizes ;
: normalized-sizes ( track -- seq )
- sizes>> dup sift sum '[ dup [ , / ] when ] map ;
+ sizes>> dup sift sum '[ dup [ _ / ] when ] map ;
: init-track ( track -- track )
init-gadget
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs kernel math models namespaces
-sequences words strings system hashtables math.parser
-math.vectors classes.tuple classes ui.gadgets boxes
-calendar alarms symbols combinators sets columns ;
+make sequences words strings system hashtables math.parser
+math.vectors classes.tuple classes ui.gadgets boxes calendar
+alarms symbols combinators sets columns ;
IN: ui.gestures
: set-gestures ( class hash -- ) "gestures" set-word-prop ;
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays definitions kernel ui.commands
-ui.gestures sequences strings math words generic namespaces
+ui.gestures sequences strings math words generic namespaces make
hashtables help.markup quotations assocs ;
IN: ui.operations
ui.tools.listener ui.tools.traceback ui.gadgets.buttons
ui.gadgets.status-bar ui.gadgets.tracks ui.commands ui.gadgets
models models.filter ui.tools.workspace ui.gestures
-ui.gadgets.labels ui threads namespaces tools.walker assocs
+ui.gadgets.labels ui threads namespaces make tools.walker assocs
combinators ;
IN: ui.tools.walker
-USING: accessors ui.gadgets ui.gadgets.labels namespaces sequences kernel
-math arrays tools.test io ui.gadgets.panes ui.traverse
-definitions compiler.units ;
+USING: accessors ui.gadgets ui.gadgets.labels namespaces make
+sequences kernel math arrays tools.test io ui.gadgets.panes
+ui.traverse definitions compiler.units ;
IN: ui.traverse.tests
M: array children>> ;
! Copyright (C) 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors namespaces sequences kernel math arrays io ui.gadgets
-generic combinators ;
+USING: accessors namespaces make sequences kernel math arrays io
+ui.gadgets generic combinators ;
IN: ui.traverse
TUPLE: node value children ;
ARTICLE: "ui-layouts" "Gadget hierarchy and layouts"
"A layout gadget is a gadget whose sole purpose is to contain other gadgets. Layout gadgets position and resize children according to a certain policy, taking the preferred size of the children into account. Gadget hierarchies are constructed by building up nested layouts."
{ $subsection "ui-layout-basics" }
-{ $subsection "ui-layout-combinators" }
"Common layout gadgets:"
{ $subsection "ui-pack-layout" }
{ $subsection "ui-track-layout" }
{ $subsection pref-dim* }
"To get a gadget's preferred size, do not call the above word, instead use " { $link pref-dim } ", which caches the result." ;
-ARTICLE: "ui-layout-combinators" "Creating layouts using combinators"
-"The " { $link make } " combinator provides a convenient way of constructing sequences by keeping the intermediate sequence off the stack until construction is done. The " { $link , } " and " { $link % } " words operate on this implicit sequence, reducing stack noise."
-$nl
-"Similar tools exist for constructing complex gadget hierarchies. Different words are used for different types of gadgets; see " { $link "ui-pack-layout" } ", " { $link "ui-track-layout" } " and " { $link "ui-frame-layout" } " for specifics. This section documents their common factors."
-;
-
ARTICLE: "ui-null-layout" "Manual layouts"
"When automatic layout is not appropriate, gadgets can be added to a parent with no layout policy, and then positioned and sized manually by setting the " { $snippet "loc" } " field." ;
! Copyright (C) 2006, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays assocs io kernel math models namespaces
+USING: arrays assocs io kernel math models namespaces make
prettyprint dlists deques sequences threads sequences words
debugger ui.gadgets ui.gadgets.worlds ui.gadgets.tracks
ui.gestures ui.backend ui.render continuations init combinators
-USING: combinators.short-circuit unicode.categories kernel math combinators splitting
-sequences math.parser io.files io assocs arrays namespaces
-math.ranges unicode.normalize values io.encodings.ascii
-unicode.syntax unicode.data compiler.units alien.syntax sets ;
+USING: combinators.short-circuit unicode.categories kernel math
+combinators splitting sequences math.parser io.files io assocs
+arrays namespaces make math.ranges unicode.normalize values
+io.encodings.ascii unicode.syntax unicode.data compiler.units
+alien.syntax sets ;
IN: unicode.breaks
C-ENUM: Any L V T Extend Control CR LF graphemes ;
-USING: unicode.data sequences sequences.next namespaces
+USING: unicode.data sequences sequences.next namespaces make
unicode.normalize math unicode.categories combinators
assocs strings splitting kernel accessors ;
IN: unicode.case
USING: combinators.short-circuit sequences io.files\r
io.encodings.ascii kernel values splitting accessors math.parser\r
-ascii io assocs strings math namespaces sorting combinators\r
+ascii io assocs strings math namespaces make sorting combinators\r
math.order arrays unicode.normalize unicode.data locals\r
unicode.syntax macros sequences.deep words unicode.breaks\r
quotations ;\r
-USING: sequences namespaces unicode.data kernel math arrays
+USING: sequences namespaces make unicode.data kernel math arrays
locals sorting.insertion accessors ;
IN: unicode.normalize
USING: accessors values kernel sequences assocs io.files
io.encodings ascii math.ranges io splitting math.parser
-namespaces byte-arrays locals math sets io.encodings.ascii
+namespaces make byte-arrays locals math sets io.encodings.ascii
words compiler.units arrays interval-maps unicode.data ;
IN: unicode.script
-USING: unicode.data kernel math sequences parser lexer bit-arrays
-namespaces sequences.private arrays quotations assocs
-classes.predicate math.order eval ;
+USING: unicode.data kernel math sequences parser lexer
+bit-arrays namespaces make sequences.private arrays quotations
+assocs classes.predicate math.order eval ;
IN: unicode.syntax
! Character classes (categories)
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel ascii combinators combinators.short-circuit
-sequences splitting fry namespaces assocs arrays strings
+sequences splitting fry namespaces make assocs arrays strings
io.sockets io.sockets.secure io.encodings.string
io.encodings.utf8 math math.parser accessors parser
strings.parser lexer prettyprint.backend hashtables present ;
swap query>> at ;
: set-query-param ( url value key -- url )
- '[ , , _ ?set-at ] change-query ;
+ '[ [ _ _ ] dip ?set-at ] change-query ;
: parse-host ( string -- host port )
":" split1 [ url-decode ] [
} case ;
: ensure-port ( url -- url' )
- dup protocol>> '[ , protocol-port or ] change-port ;
+ dup protocol>> '[ _ protocol-port or ] change-port ;
! Literal syntax
: URL" lexer get skip-blank parse-string >url parsed ; parsing
! Copyright (C) 2006, 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel continuations sequences math
-namespaces sets math.parser math.ranges assocs regexp
-unicode.categories arrays hashtables words
-classes quotations xmode.catalog ;
+USING: kernel continuations sequences math namespaces make sets
+math.parser math.ranges assocs regexp unicode.categories arrays
+hashtables words classes quotations xmode.catalog ;
IN: validators
: v-default ( str def -- str )
MACRO: com-invoke ( n return parameters -- )
dup length -roll
'[
- , npick com-interface-vtbl , swap void*-nth , ,
+ _ npick com-interface-vtbl _ swap void*-nth _ _
"stdcall" alien-indirect
] ;
(query-interface-cases)
'[
swap 16 memory>byte-array
- , case
+ _ case
[
"void*" heap-size * rot <displaced-alien> com-add-ref
0 rot set-void*-nth S_OK
: (make-add-ref) ( interfaces -- quot )
length "void*" heap-size * '[
- , swap <displaced-alien>
+ _ swap <displaced-alien>
0 over ulong-nth
1+ [ 0 rot set-ulong-nth ] keep
] ;
: (make-release) ( interfaces -- quot )
length "void*" heap-size * '[
- , over <displaced-alien>
+ _ over <displaced-alien>
0 over ulong-nth
1- [ 0 rot set-ulong-nth ] keep
dup zero? [ swap (free-wrapped-object) ] [ nip ] if
: (thunk) ( n -- quot )
dup 0 =
[ drop [ ] ]
- [ "void*" heap-size neg * '[ , swap <displaced-alien> ] ]
+ [ "void*" heap-size neg * '[ _ swap <displaced-alien> ] ]
if ;
: (thunked-quots) ( quots iunknown-methods thunk -- {thunk,quot}s )
- [ '[ , '[ @ com-unwrap ] [ swap 2array ] curry map ] ]
- [ '[ , [ swap 2array ] curry map ] ] bi bi*
+ [ '[ _ '[ @ com-unwrap ] [ swap 2array ] curry map ] ]
+ [ '[ _ [ swap 2array ] curry map ] ] bi bi*
swap append ;
: compile-alien-callback ( word return parameters abi quot -- word )
- '[ , , , , alien-callback ]
+ '[ _ _ _ _ alien-callback ]
[ [ (( -- alien )) define-declared ] pick slip ]
with-compilation-unit ;
"windows.com.wrapper.callbacks" create ;
: (finish-thunk) ( param-count thunk quot -- thunked-quot )
- [ [ drop [ ] ] [ swap 1- '[ , , ndip ] ] if-empty ]
+ [ [ drop [ ] ] [ swap 1- '[ _ _ ndip ] ] if-empty ]
dip compose ;
: (make-interface-callbacks) ( interface-name quots iunknown-methods n -- words )
swap [ find-com-interface-definition family-tree-functions ]
keep (next-vtbl-counter) '[
swap [
- [ name>> , , (callback-word) ]
+ [ name>> _ _ (callback-word) ]
[ return>> ] [
parameters>>
[ [ first ] map ]
: (malloc-guid-symbol) ( symbol guid -- )
global swap '[ [
- , execute [ byte-length malloc ] [ over byte-array>memory ] bi
+ _ execute [ byte-length malloc ] [ over byte-array>memory ] bi
] unless* ] change-at ;
: define-guid-constants ( -- )
-USING: sequences kernel namespaces splitting math math.order ;
+USING: sequences kernel namespaces make splitting math math.order ;
IN: wrap
! Very stupid word wrapping/line breaking
!
! based on glx.h from xfree86, and some of glxtokens.h
USING: alien alien.c-types alien.syntax alien.syntax.private x11.xlib
-namespaces kernel sequences parser words ;
+namespaces make kernel sequences parser words ;
IN: x11.glx
LIBRARY: glx
! Copyright (C) 2005, 2006 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces kernel assocs sequences ;
+USING: namespaces make kernel assocs sequences ;
IN: xml.entities
: entities-out
! Copyright (C) 2006, 2007 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces kernel xml.data xml.utilities assocs sequences ;
+USING: namespaces make kernel xml.data xml.utilities assocs
+sequences ;
IN: xml.generator
: comment, ( string -- ) <comment> , ;
! Copyright (C) 2005, 2006 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
IN: xml.tests
-USING: kernel xml tools.test io namespaces sequences xml.errors xml.entities
- parser strings xml.data io.files xml.writer xml.utilities state-parser
- continuations assocs sequences.deep accessors ;
+USING: kernel xml tools.test io namespaces make sequences
+xml.errors xml.entities parser strings xml.data io.files
+xml.writer xml.utilities state-parser continuations assocs
+sequences.deep accessors ;
! This is insufficient
\ read-xml must-infer
! Copyright (C) 2005, 2006 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: xml.errors xml.data xml.utilities xml.char-classes sets
-xml.entities kernel state-parser kernel namespaces strings math
-math.parser sequences assocs arrays splitting combinators unicode.case
-accessors ;
+xml.entities kernel state-parser kernel namespaces make strings
+math math.parser sequences assocs arrays splitting combinators
+unicode.case accessors ;
IN: xml.tokenize
! XML namespace processing: ns = namespace
[\r
drop\r
dup '[\r
- , utf8 [\r
- , file-name input-stream get htmlize-stream\r
+ _ utf8 [\r
+ _ file-name input-stream get htmlize-stream\r
] with-file-reader\r
] "text/html" <content>\r
] <file-responder> ;\r
-USING: accessors xmode.tokens xmode.rules xmode.keyword-map xml.data
-xml.utilities xml assocs kernel combinators sequences
-math.parser namespaces parser lexer xmode.utilities regexp io.files ;
+! Copyright (C) 2007, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors xmode.tokens xmode.rules xmode.keyword-map
+xml.data xml.utilities xml assocs kernel combinators sequences
+math.parser namespaces make parser lexer xmode.utilities regexp
+io.files ;
IN: xmode.loader.syntax
SYMBOL: ignore-case?
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
IN: xmode.marker
-USING: kernel namespaces xmode.rules xmode.tokens
+USING: kernel namespaces make xmode.rules xmode.tokens
xmode.marker.state xmode.marker.context xmode.utilities
xmode.catalog sequences math assocs combinators
strings regexp splitting parser-combinators ascii unicode.case
+! Copyright (C) 2007, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
USING: xmode.marker.context xmode.rules symbols accessors
-xmode.tokens namespaces kernel sequences assocs math ;
+xmode.tokens namespaces make kernel sequences assocs math ;
IN: xmode.marker.state
! Based on org.gjt.sp.jedit.syntax.TokenMarker
IN: assocs.tests
-USING: kernel math namespaces tools.test vectors sequences
+USING: kernel math namespaces make tools.test vectors sequences
sequences.private hashtables io prettyprint assocs
continuations float-arrays ;
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays definitions assocs kernel kernel.private
-slots.private namespaces sequences strings words vectors math
-quotations combinators sorting effects graphs vocabs sets ;
+slots.private namespaces make sequences strings words vectors
+math quotations combinators sorting effects graphs vocabs sets ;
IN: classes
SYMBOL: class<=-cache
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: classes classes.algebra kernel namespaces words sequences
-quotations arrays kernel.private assocs combinators ;
+USING: classes classes.algebra kernel namespaces make words
+sequences quotations arrays kernel.private assocs combinators ;
IN: classes.predicate
PREDICATE: predicate-class < class
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel sets namespaces sequences parser
+USING: accessors kernel sets namespaces make sequences parser
lexer combinators words classes.parser classes.tuple arrays
slots math assocs ;
IN: classes.tuple.parser
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays definitions hashtables kernel kernel.private math
-namespaces sequences sequences.private strings vectors words
-quotations memory combinators generic classes classes.algebra
-classes.builtin classes.private slots.private slots
-compiler.units math.private accessors assocs effects ;
+namespaces make sequences sequences.private strings vectors
+words quotations memory combinators generic classes
+classes.algebra classes.builtin classes.private slots.private
+slots compiler.units math.private accessors assocs effects ;
IN: classes.tuple
PREDICATE: tuple-class < class
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel namespaces assocs io sequences
+USING: kernel namespaces make assocs io sequences
sorting continuations math math.parser ;
IN: compiler.errors
! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays vectors kernel kernel.private sequences
-namespaces math splitting sorting quotations assocs
+namespaces make math splitting sorting quotations assocs
combinators accessors ;
IN: continuations
! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors continuations kernel namespaces
+USING: accessors continuations kernel namespaces make
sequences vectors ;
IN: destructors
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.parser namespaces sequences strings
+USING: kernel math math.parser namespaces make sequences strings
words assocs combinators accessors arrays ;
IN: effects
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors words kernel sequences namespaces assocs
+USING: accessors words kernel sequences namespaces make assocs
hashtables definitions kernel.private classes classes.private
classes.algebra quotations arrays vocabs effects combinators
sets ;
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays generic hashtables kernel kernel.private
-math namespaces sequences words quotations layouts combinators
+USING: arrays generic hashtables kernel kernel.private math
+namespaces make sequences words quotations layouts combinators
sequences.private classes classes.builtin classes.algebra
definitions math.order ;
IN: generic.math
-USING: classes.private generic.standard.engines namespaces
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: classes.private generic.standard.engines namespaces make
arrays assocs sequences.private quotations kernel.private
math slots.private math.private kernel accessors words
layouts ;
! See http://factorcode.org/license.txt for BSD license.
USING: kernel classes.tuple.private hashtables assocs sorting
accessors combinators sequences slots.private math.parser words
-effects namespaces generic generic.standard.engines
+effects namespaces make generic generic.standard.engines
classes.algebra math math.private kernel.private
quotations arrays definitions ;
IN: generic.standard.engines.tuple
IN: generic.standard.tests
USING: tools.test math math.functions math.constants
generic.standard strings sequences arrays kernel accessors
-words float-arrays byte-arrays bit-arrays parser namespaces
+words float-arrays byte-arrays bit-arrays parser namespaces make
quotations stack-checker vectors growable hashtables sbufs
prettyprint byte-vectors bit-vectors float-vectors definitions
generic sets graphs assocs ;
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs kernel kernel.private slots.private math
-namespaces sequences vectors words quotations definitions
+namespaces make sequences vectors words quotations definitions
hashtables layouts combinators sequences.private generic
classes classes.algebra classes.private generic.standard.engines
generic.standard.engines.tag generic.standard.engines.predicate
IN: hashtables.tests
-USING: kernel math namespaces tools.test vectors sequences
+USING: kernel math namespaces make tools.test vectors sequences
sequences.private hashtables io prettyprint assocs
continuations ;
USING: arrays io io.files kernel math parser strings system
-tools.test words namespaces io.encodings.8-bit
+tools.test words namespaces make io.encodings.8-bit
io.encodings.binary sequences ;
IN: io.tests
! Copyright (C) 2003, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: hashtables generic kernel math namespaces sequences
+USING: hashtables generic kernel math namespaces make sequences
continuations destructors assocs ;
IN: io
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel kernel.private namespaces io io.encodings
+USING: kernel kernel.private namespaces make io io.encodings
sequences math generic threads.private classes io.backend
io.files continuations destructors byte-arrays accessors ;
IN: io.streams.c
-USING: io.streams.string io kernel arrays namespaces tools.test ;
+USING: io.streams.string io kernel arrays namespaces make
+tools.test ;
IN: io.streams.string.tests
[ "line 1" CHAR: l ]
--- /dev/null
+IN: make
+USING: help.markup help.syntax quotations sequences math.parser
+kernel ;
+
+ARTICLE: "namespaces-make" "Making sequences with variables"
+"The " { $vocab-link "make" } " vocabulary implements a facility for constructing sequences by holding an accumulator sequence in a variable. Storing the accumulator sequence in a variable rather than the stack may allow code to be written with less stack manipulation."
+{ $subsection make }
+{ $subsection , }
+{ $subsection % }
+{ $subsection # }
+"The accumulator sequence can be accessed directly:"
+{ $subsection building } ;
+
+ABOUT: "namespaces-make"
+
+HELP: building
+{ $var-description "Temporary mutable growable sequence holding elements accumulated so far by " { $link make } "." } ;
+
+HELP: make
+{ $values { "quot" quotation } { "exemplar" sequence } { "seq" "a new sequence" } }
+{ $description "Calls the quotation in a new " { $emphasis "dynamic scope" } ". The quotation and any words it calls can execute the " { $link , } " and " { $link % } " words to accumulate elements. When the quotation returns, all accumulated elements are collected into a sequence with the same type as " { $snippet "exemplar" } "." }
+{ $examples { $example "USING: namespaces prettyprint ;" "[ 1 , 2 , 3 , ] { } make ." "{ 1 2 3 }" } } ;
+
+HELP: ,
+{ $values { "elt" object } }
+{ $description "Adds an element to the end of the sequence being constructed by " { $link make } "." } ;
+
+HELP: %
+{ $values { "seq" sequence } }
+{ $description "Appends a sequence to the end of the sequence being constructed by " { $link make } "." } ;
--- /dev/null
+! Copyright (C) 2003, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences namespaces ;
+IN: make
+
+SYMBOL: building
+
+: make ( quot exemplar -- seq )
+ [
+ [
+ 1024 swap new-resizable [
+ building set call
+ ] keep
+ ] keep like
+ ] with-scope ; inline
+
+: , ( elt -- ) building get push ;
+
+: % ( seq -- ) building get push-all ;
-USING: kernel math namespaces tools.test ;
+USING: kernel math namespaces make tools.test ;
IN: math.tests
[ ] [ 5 [ ] times ] unit-test
USING: help.markup help.syntax math math.private prettyprint
-namespaces strings ;
+namespaces make strings ;
IN: math.parser
ARTICLE: "number-strings" "Converting between numbers and strings"
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math.private namespaces sequences strings arrays
-combinators splitting math assocs ;
+USING: kernel math.private namespaces make sequences strings
+arrays combinators splitting math assocs ;
IN: math.parser
: digit> ( ch -- n )
{ $subsection get-global }
{ $subsection set-global } ;
-ARTICLE: "namespaces-make" "Constructing sequences"
-"There is a lexicon of words for constructing sequences without passing the partial sequence being built on the stack. This reduces stack noise."
-{ $subsection make }
-{ $subsection , }
-{ $subsection % }
-{ $subsection # } ;
-
ARTICLE: "namespaces.private" "Namespace implementation details"
"The namestack holds namespaces."
{ $subsection namestack }
{ $subsection "namespaces-change" }
{ $subsection "namespaces-combinators" }
{ $subsection "namespaces-global" }
-"A useful facility for constructing sequences by holding an accumulator sequence in a variable:"
-{ $subsection "namespaces-make" }
"Implementation details your code probably does not care about:"
{ $subsection "namespaces.private" }
"An alternative to dynamic scope is lexical scope. Lexically-scoped values and closures are implemented in the " { $vocab-link "locals" } " vocabulary." ;
HELP: ndrop
{ $description "Pops a namespace from the name stack." } ;
-HELP: building
-{ $var-description "Temporary mutable growable sequence holding elements accumulated so far by " { $link make } "." } ;
-
-HELP: make
-{ $values { "quot" quotation } { "exemplar" "a sequence" } { "seq" "a new sequence" } }
-{ $description "Calls the quotation in a new " { $emphasis "dynamic scope" } ". The quotation and any words it calls can execute the " { $link , } " and " { $link % } " words to accumulate elements. When the quotation returns, all accumulated elements are collected into a sequence with the same type as " { $snippet "exemplar" } "." }
-{ $examples { $example "USING: namespaces prettyprint ;" "[ 1 , 2 , 3 , ] { } make ." "{ 1 2 3 }" } } ;
-
-HELP: ,
-{ $values { "elt" object } }
-{ $description "Adds an element to the end of the sequence being constructed by " { $link make } "." } ;
-
-HELP: %
-{ $values { "seq" "a sequence" } }
-{ $description "Appends a sequence to the end of the sequence being constructed by " { $link make } "." } ;
-
HELP: init-namespaces
{ $description "Resets the name stack to its initial state, holding a single copy of the global namespace." }
$low-level-note ;
-! Copyright (C) 2003, 2007 Slava Pestov.
+! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel vectors sequences hashtables
arrays kernel.private math strings assocs ;
<PRIVATE
-: namestack* ( -- namestack )
- 0 getenv { vector } declare ; inline
-
+: namestack* ( -- namestack ) 0 getenv { vector } declare ; inline
: >n ( namespace -- ) namestack* push ;
: ndrop ( -- ) namestack* pop* ;
: off ( variable -- ) f swap set ; inline
: get-global ( variable -- value ) global at ;
: set-global ( value variable -- ) global set-at ;
-
-: change ( variable quot -- )
- >r dup get r> rot slip set ; inline
-
+: change ( variable quot -- ) >r dup get r> rot slip set ; inline
: +@ ( n variable -- ) [ 0 or + ] change ;
-
: inc ( variable -- ) 1 swap +@ ; inline
-
: dec ( variable -- ) -1 swap +@ ; inline
-
: bind ( ns quot -- ) swap >n call ndrop ; inline
-
: counter ( variable -- n ) global [ dup inc get ] bind ;
: make-assoc ( quot exemplar -- hash )
: with-variable ( value key quot -- )
>r associate >n r> call ndrop ; inline
-
-! Building sequences
-SYMBOL: building
-
-: make ( quot exemplar -- seq )
- [
- [
- 1024 swap new-resizable [
- building set call
- ] keep
- ] keep like
- ] with-scope ; inline
-
-: , ( elt -- ) building get push ;
-
-: % ( seq -- ) building get push-all ;
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays byte-arrays kernel kernel.private math namespaces
-sequences strings words effects generic generic.standard classes
-classes.algebra slots.private combinators accessors words
-sequences.private assocs alien ;
+make sequences strings words effects generic generic.standard
+classes classes.algebra slots.private combinators accessors
+words sequences.private assocs alien ;
IN: slots
TUPLE: slot-spec name offset class initial read-only ;
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math namespaces strings arrays vectors sequences
+USING: kernel math make strings arrays vectors sequences
sets math.order accessors ;
IN: splitting
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel assocs namespaces splitting sequences
+USING: kernel assocs namespaces make splitting sequences
strings math.parser lexer accessors ;
IN: strings.parser
-USING: continuations kernel math math.order namespaces strings
-strings.private sbufs tools.test sequences vectors arrays memory
-prettyprint io.streams.null ;
+USING: continuations kernel math math.order namespaces make
+strings strings.private sbufs tools.test sequences vectors
+arrays memory prettyprint io.streams.null ;
IN: strings.tests
[ CHAR: b ] [ 1 >bignum "abc" nth ] unit-test
! Copyright (C) 2007, 2008 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces sequences io.files kernel assocs words vocabs
-definitions parser continuations io hashtables sorting
+USING: namespaces make sequences io.files kernel assocs words
+vocabs definitions parser continuations io hashtables sorting
source-files arrays combinators strings system math.parser
compiler.errors splitting init accessors ;
IN: vocabs.loader
USING: arrays asn1.ldap assocs byte-arrays combinators
continuations io io.binary io.streams.string kernel math
-math.parser namespaces pack strings sequences accessors ;
+math.parser namespaces make pack strings sequences accessors ;
IN: asn1
[ fail ] unless ;\r
\r
MACRO: checkpoint ( quot -- quot' )\r
- '[ failure get ,\r
- '[ '[ failure set , continue ] callcc0\r
- , failure set @ ] callcc0 ] ;\r
+ '[ failure get _\r
+ '[ '[ failure set _ continue ] callcc0\r
+ _ failure set @ ] callcc0 ] ;\r
\r
: number-from ( from -- from+n )\r
[ 1 + number-from ] checkpoint ;\r
dup length 1 =\r
[ first 1quotation ]\r
[ [ first ] [ rest ] bi\r
- '[ , [ drop , unsafe-amb ] checkpoint ] ] if ;\r
+ '[ _ [ drop _ unsafe-amb ] checkpoint ] ] if ;\r
\r
PRIVATE> \r
\r
\r
MACRO: amb-execute ( seq -- quot )\r
[ length 1 - ] [ <enum> [ 1quotation ] assoc-map ] bi\r
- '[ , 0 unsafe-number-from-to nip , case ] ;\r
+ '[ _ 0 unsafe-number-from-to nip _ case ] ;\r
\r
: if-amb ( true false -- )\r
[\r
-USING: accessors arrays bank calendar kernel math math.functions namespaces tools.test tools.walker ;
+USING: accessors arrays bank calendar kernel math math.functions
+namespaces make tools.test tools.walker ;
IN: bank.tests
SYMBOL: my-account
-USING: namespaces math sequences splitting grouping
+USING: make math sequences splitting grouping
kernel columns float-arrays bit-arrays ;
IN: benchmark.dispatch2
USING: sequences math mirrors splitting grouping
-kernel namespaces assocs alien.syntax columns
+kernel make assocs alien.syntax columns
float-arrays bit-arrays ;
IN: benchmark.dispatch3
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays io kernel math math.functions math.order
-math.parser sequences byte-arrays byte-vectors io.files
-io.encodings.binary fry namespaces benchmark.mandel.params
+USING: arrays io kernel namespaces math math.functions
+math.order math.parser sequences byte-arrays byte-vectors
+io.files io.encodings.binary fry make benchmark.mandel.params
benchmark.mandel.colors ;
IN: benchmark.mandel
: pixel ( c -- iterations )
[ C{ 0.0 0.0 } max-iterations ] dip
- '[ sq , + ] [ absq 4.0 >= ] count-iterations ; inline
+ '[ sq _ + ] [ absq 4.0 >= ] count-iterations ; inline
: color ( iterations -- color )
[ color-map [ length mod ] keep nth ] [ B{ 0 0 0 } ] if* ; inline
: render ( -- )
- height [ width swap '[ , c pixel color % ] each ] each ; inline
+ height [ width swap '[ _ c pixel color % ] each ] each ; inline
: ppm-header ( -- )
"P6\n" % width # " " % height # "\n255\n" % ; inline
IN: benchmark.nsieve-bits
USING: math math.parser sequences sequences.private kernel
-bit-arrays namespaces io ;
+bit-arrays make io ;
: clear-flags ( step i seq -- )
2dup length >= [
IN: benchmark.nsieve
USING: math math.parser sequences sequences.private kernel
-arrays namespaces io ;
+arrays make io ;
: clear-flags ( step i seq -- )
2dup length >= [
USING: arrays accessors float-arrays io io.files
io.encodings.binary kernel math math.functions math.vectors
-math.parser namespaces sequences sequences.private words ;
+math.parser make sequences sequences.private words ;
IN: benchmark.raytracer
! parameters
-USING: parser lexer kernel math sequences namespaces assocs summary
-words splitting math.parser arrays sequences.next mirrors
-generalizations compiler.units ;
+USING: parser lexer kernel math sequences namespaces make assocs
+summary words splitting math.parser arrays sequences.next
+mirrors generalizations compiler.units ;
IN: bitfields
! Example:
-USING: kernel namespaces sequences arrays io io.files
+USING: kernel namespaces make sequences arrays io io.files
builder.util
builder.common
builder.release.archive ;
-USING: kernel alien.c-types combinators namespaces arrays
+USING: kernel alien.c-types combinators namespaces make arrays
sequences sequences.lib namespaces.lib splitting
math math.functions math.vectors math.trig
opengl.gl opengl.glu opengl ui ui.gadgets.slate
! Cleave into array
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: [narr] ( seq n -- quot ) over length '[ , , ncleave , narray ] ;
+: [narr] ( seq n -- quot ) over length '[ _ _ ncleave _ narray ] ;
MACRO: narr ( seq n -- array ) [narr] ;
MACRO: <arr> ( seq -- )
[ >quots ] [ length ] bi
- '[ , cleave , narray ] ;
+ '[ _ cleave _ narray ] ;
MACRO: <2arr> ( seq -- )
[ >quots ] [ length ] bi
- '[ , 2cleave , narray ] ;
+ '[ _ 2cleave _ narray ] ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
MACRO: <arr*> ( seq -- )
[ >quots ] [ length ] bi
- '[ , spread , narray ] ;
+ '[ _ spread _ narray ] ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-MACRO: 1if ( test then else -- ) '[ dup @ , , if ] ;
+MACRO: 1if ( test then else -- ) '[ dup @ _ _ if ] ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Doug Coleman, Eduardo Cavazos,
! Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel combinators fry namespaces quotations hashtables
+USING: kernel combinators fry namespaces make quotations hashtables
sequences assocs arrays stack-checker effects math math.ranges
generalizations macros continuations random locals accessors ;
MACRO: preserving ( predicate -- quot )
dup infer in>>
dup 1+
- '[ , , nkeep , nrot ] ;
+ '[ _ _ nkeep _ nrot ] ;
MACRO: ifte ( quot quot quot -- )
- '[ , preserving , , if ] ;
+ '[ _ preserving _ _ if ] ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! switch
! Copyright (C) 2005 Chris Double, 2007 Clemens Hofreither.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel hashtables namespaces continuations quotations
+USING: kernel hashtables namespaces make continuations quotations
accessors ;
IN: coroutines
USING: arrays kernel sequences io io.files io.backend
io.encodings.ascii math.parser vocabs definitions
-namespaces words sorting ;
+namespaces make words sorting ;
IN: ctags
: ctag-word ( ctag -- word )
! Emacs Etags generator
! Alfredo Beaumont <alfredo.beaumont@gmail.com>
USING: kernel sequences sorting assocs words prettyprint ctags
-io.encodings.ascii io.files math math.parser namespaces strings locals
-shuffle io.backend arrays ;
+io.encodings.ascii io.files math math.parser namespaces make
+strings shuffle io.backend arrays ;
IN: ctags.etags
: etag-at ( key hash -- vector )
: demo-vocabs ( -- seq ) "demos" tagged [ second ] map concat [ name>> ] map ;
: <run-vocab-button> ( vocab-name -- button )
- dup '[ drop [ , run ] call-listener ] <bevel-button> { 0 0 } >>align ;
+ dup '[ drop [ _ run ] call-listener ] <bevel-button> { 0 0 } >>align ;
: <demo-runner> ( -- gadget )
<pile> 1 >>fill demo-vocabs [ <run-vocab-button> add-gadget ] each ;
USING: kernel namespaces sequences math
- listener io prettyprint sequences.lib fry ;
+ listener io prettyprint sequences.lib bake bake.fry ;
IN: display-stack
USING: kernel combinators sequences sets math threads namespaces continuations
debugger io io.sockets unicode.case accessors destructors
combinators.cleave combinators.lib combinators.short-circuit
- newfx fry
+ newfx bake bake.fry
dns dns.util dns.misc ;
IN: dns.server
-USING: kernel sequences sorting math math.order macros fry ;
+USING: kernel sequences sorting math math.order macros bake bake.fry ;
IN: dns.util
! See http://factorcode.org/license.txt for BSD license.
USING: xml kernel sequences xml.utilities combinators.lib
math xml.data arrays assocs xml.generator xml.writer namespaces
-math.parser io accessors ;
+make math.parser io accessors ;
IN: faq
: find-after ( seq quot -- elem after )
! Copyright (C) 2006 Chris Double. All Rights Reserved.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel peg strings sequences math
-math.parser namespaces words quotations arrays hashtables io
+USING: accessors kernel peg strings sequences math math.parser
+namespaces make words quotations arrays hashtables io
io.streams.string assocs ascii peg.parsers accessors ;
IN: fjsc
: with-ftp-client ( ftp-client quot -- )
dupd '[
- , [ ftp-login ] [ @ ] bi
+ _ [ ftp-login ] [ @ ] bi
ftp-quit drop
] >r ftp-connect r> with-stream ; inline
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: combinators.short-circuit accessors combinators io io.encodings.8-bit
-io.encodings io.encodings.binary io.encodings.utf8 io.files
-io.sockets kernel math.parser namespaces sequences
-ftp io.unix.launcher.parser unicode.case splitting assocs
-classes io.servers.connection destructors calendar io.timeouts
-io.streams.duplex threads continuations math
-concurrency.promises byte-arrays ;
+USING: combinators.short-circuit accessors combinators io
+io.encodings.8-bit io.encodings io.encodings.binary
+io.encodings.utf8 io.files io.sockets kernel math.parser
+namespaces make sequences ftp io.unix.launcher.parser
+unicode.case splitting assocs classes io.servers.connection
+destructors calendar io.timeouts io.streams.duplex threads
+continuations math concurrency.promises byte-arrays ;
IN: ftp.server
SYMBOL: client
vertices length ;
M: graph num-edges
- [ vertices ] [ '[ , adjlist length ] map sum ] bi ;
+ [ vertices ] [ '[ _ adjlist length ] map sum ] bi ;
M: graph adjlist
- [ vertices ] [ swapd '[ , swap , adj? ] filter ] bi ;
+ [ vertices ] [ swapd '[ _ swap _ adj? ] filter ] bi ;
M: graph adj?
swapd adjlist index >boolean ;
[ delete-edge* ] [ swapd delete-edge* ] 3bi ;
: add-blank-vertices ( seq graph -- )
- '[ , add-blank-vertex ] each ;
+ '[ _ add-blank-vertex ] each ;
: delete-vertex ( index graph -- )
[ adjlist ]
- [ '[ , , 3dup adj? [ delete-edge* ] [ 3drop ] if ] each ]
+ [ '[ _ _ 3dup adj? [ delete-edge* ] [ 3drop ] if ] each ]
[ delete-blank-vertex ] 2tri ;
<PRIVATE
{ [ 2drop visited? get t -rot set-at ]
[ drop call ]
[ [ graph get adjlist ] 2dip
- '[ dup visited? get at [ drop ] [ , , (depth-first) ] if ] each ]
+ '[ dup visited? get at [ drop ] [ _ _ (depth-first) ] if ] each ]
[ nip call ] } 3cleave ; inline
PRIVATE>
: depth-first ( v graph pre post -- ?list ? )
- '[ , , (depth-first) visited? get ] swap search-wrap ; inline
+ '[ _ _ (depth-first) visited? get ] swap search-wrap ; inline
: full-depth-first ( graph pre post tail -- ? )
'[ [ visited? get [ nip not ] assoc-find ]
- [ drop , , (depth-first) @ ]
+ [ drop _ _ (depth-first) @ ]
[ 2drop ] while ] swap search-wrap ; inline
: dag? ( graph -- ? )
V{ } clone swap [ 2dup swap push dupd
- '[ , swap graph get adj? not ] all?
+ '[ _ swap graph get adj? not ] all?
[ end-search ] unless ]
[ drop dup pop* ] [ ] full-depth-first nip ;
: >sparse-graph ( graph -- sparse-graph )
[ vertices ] keep
- '[ dup , adjlist 2array ] map >hashtable sparse-graph boa ;
+ '[ dup _ adjlist 2array ] map >hashtable sparse-graph boa ;
INSTANCE: sparse-graph graph
USING: assocs html.parser kernel math sequences strings ascii
-arrays generalizations shuffle unicode.case namespaces splitting
-http sequences.lib accessors io combinators http.client urls ;
+arrays generalizations shuffle unicode.case namespaces make
+splitting http sequences.lib accessors io combinators
+http.client urls ;
IN: html.parser.analyzer
TUPLE: link attributes clickable ;
USING: accessors arrays html.parser.utils hashtables io kernel
-namespaces prettyprint quotations
-sequences splitting state-parser strings unicode.categories unicode.case
+namespaces make prettyprint quotations sequences splitting
+state-parser strings unicode.categories unicode.case
sequences.lib ;
IN: html.parser
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel words summary slots quotations
sequences assocs math arrays stack-checker effects generalizations
-continuations debugger classes.tuple namespaces vectors
+continuations debugger classes.tuple namespaces make vectors
bit-arrays byte-arrays strings sbufs math.functions macros
sequences.private combinators mirrors
combinators.short-circuit ;
: set+run-listener ( name irc-listener -- )
over irc> listeners>> set-at
- '[ , listener-loop ] "listener" spawn-irc-loop ;
+ '[ _ listener-loop ] "listener" spawn-irc-loop ;
GENERIC: (add-listener) ( irc-listener -- )
[ [ name>> ] [ password>> ] bi /JOIN ]
[ [ [ drop irc> join-messages>> ]
[ timeout>> ]
- [ name>> '[ trailing>> , = ] ]
+ [ name>> '[ trailing>> _ = ] ]
tri mailbox-get-timeout? trailing>> ] keep set+run-listener
] bi ;
spawn-irc ] with-irc-client ;
: add-listener ( irc-listener irc-client -- )
- swap '[ , (add-listener) ] with-irc-client ;
+ swap '[ _ (add-listener) ] with-irc-client ;
: remove-listener ( irc-listener irc-client -- )
- swap '[ , (remove-listener) ] with-irc-client ;
+ swap '[ _ (remove-listener) ] with-irc-client ;
: write-message ( message irc-listener -- ) out-messages>> mailbox-put ;
: read-message ( irc-listener -- message ) in-messages>> mailbox-get ;
! ======================================
: split-at-first ( seq separators -- before after )
- dupd '[ , member? ] find
+ dupd '[ _ member? ] find
[ cut 1 tail ]
[ swap ]
if ;
} case
[ [ tuple-slots ] [ parameters>> ] bi append ] dip
[ all-slots over [ length ] bi@ min head >quotation ] keep
- '[ @ , boa ] call ;
+ '[ @ _ boa ] call ;
GENERIC: handle-inbox ( tab message -- )\r
\r
: value-labels ( assoc val -- seq )\r
- '[ nip , = ] assoc-filter keys sort-strings [ <label> ] map ;\r
+ '[ nip _ = ] assoc-filter keys sort-strings [ <label> ] map ;\r
\r
: add-gadget-color ( pack seq color -- pack )\r
- '[ , >>color add-gadget ] each ;\r
+ '[ _ >>color add-gadget ] each ;\r
\r
M: object handle-inbox\r
nip print-irc ;\r
\r
: display ( stream tab -- )\r
- '[ , [ [ t ]\r
- [ , dup listener>> read-message handle-inbox ]\r
+ '[ _ [ [ t ]\r
+ [ _ dup listener>> read-message handle-inbox ]\r
[ ] while ] with-output-stream ] "ircv" spawn drop ;\r
\r
: <irc-pane> ( tab -- tab pane )\r
[ [ irc-tab? ] find-parent ]\r
[ editor-string ]\r
[ "" swap set-editor-string ] } cleave\r
- '[ , irc-tab set , parse-message ] with-output-stream ;\r
+ '[ _ irc-tab set _ parse-message ] with-output-stream ;\r
\r
irc-editor "general" f {\r
{ T{ key-down f f "RET" } editor-send }\r
[ (update-axes) ] [ kill-update-axes ] if* ;
M: joystick-demo-gadget graft*
- dup '[ , update-axes ] FREQUENCY every >>alarm
+ dup '[ _ update-axes ] FREQUENCY every >>alarm
drop ;
M: joystick-demo-gadget ungraft*
relayout-1 ;
M: key-caps-gadget graft*
- dup '[ , update-key-caps-state ] FREQUENCY every >>alarm
+ dup '[ _ update-key-caps-state ] FREQUENCY every >>alarm
drop ;
M: key-caps-gadget ungraft*
: convert-cond ( cons -- quot )
cdr [ 2car [ convert-form ] bi@ 2array ]
- { } lmap-as '[ , cond ] ;
+ { } lmap-as '[ _ cond ] ;
: convert-general-form ( cons -- quot )
- uncons [ convert-body ] [ convert-form ] bi* '[ , @ funcall ] ;
+ uncons [ convert-body ] [ convert-form ] bi* '[ _ @ funcall ] ;
! words for convert-lambda
<PRIVATE
: localize-body ( assoc body -- newbody )
{
- { [ dup list? ] [ [ lisp-symbol? ] rot '[ [ name>> , at ] [ ] bi or ] traverse ] }
+ { [ dup list? ] [ [ lisp-symbol? ] rot '[ [ name>> _ at ] [ ] bi or ] traverse ] }
{ [ dup lisp-symbol? ] [ name>> swap at ] }
[ nip ]
} cond ;
: rest-lambda ( body vars -- quot )
"&rest" swap [ remove ] [ index ] 2bi
[ localize-lambda <lambda> lambda-rewrite call ] dip
- swap '[ , cut '[ @ , seq>list ] call , call call ] 1quotation ;
+ swap '[ _ cut '[ @ _ seq>list ] call _ call call ] 1quotation ;
: normal-lambda ( body vars -- quot )
localize-lambda <lambda> lambda-rewrite '[ @ compose call call ] 1quotation ;
: convert-begin ( cons -- quot )
cdr [ convert-form ] [ ] lmap-as [ 1 tail* ] [ but-last ] bi
- [ '[ { } , with-datastack drop ] ] map prepend '[ , [ call ] each ] ;
+ [ '[ { } _ with-datastack drop ] ] map prepend '[ _ [ call ] each ] ;
: form-dispatch ( cons lisp-symbol -- quot )
name>>
{
{ [ dup cons? ] [ convert-list-form ] }
{ [ dup lisp-var? ] [ lookup-var 1quotation ] }
- { [ dup lisp-symbol? ] [ '[ , lookup-var ] ] }
+ { [ dup lisp-symbol? ] [ '[ _ lookup-var ] ] }
[ 1quotation ]
} cond ;
[ 1array [ call ] with-datastack >quotation ] dip curry call ; inline
: define-primitive ( name vocab word -- )
- swap lookup 1quotation '[ , compose call ] swap lisp-define ;
+ swap lookup 1quotation '[ _ compose call ] swap lisp-define ;
: lookup-macro ( lisp-symbol -- lambda )
name>> macro-env get at ;
! Updated by Chris Double, September 2006
! Updated by James Cash, June 2008
!
-USING: kernel sequences math vectors arrays namespaces
+USING: kernel sequences math vectors arrays namespaces make
quotations promises combinators io lists accessors ;
IN: lists.lazy
1 ;
MACRO: (do-copy) ( copy make-vector -- )
- '[ over 6 npick , 2dip 1 @ ] ;
+ '[ over 6 npick _ 2dip 1 @ ] ;
: (prepare-swap) ( v1 v2 -- length v1-data v1-inc v2-data v2-inc v1 v2 )
[
MACRO: (complex-nth) ( nth-quot -- )
'[
[ 2 * dup 1+ ] dip
- , curry bi@ rect>
+ _ curry bi@ rect>
] ;
: (c-complex-nth) ( n alien -- complex )
[ 2 * dup 1+ ] bi*
swapd
] dip
- , curry 2bi@
+ _ curry 2bi@
] ;
: (set-c-complex-nth) ( complex n alien -- )
! Copyright (c) 2007, 2008 Slava Pestov, Doug Coleman, Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs kernel math math.order math.ranges mirrors
-namespaces sequences sequences.lib sorting ;
+namespaces make sequences sequences.lib sorting ;
IN: math.combinatorics
<PRIVATE
-USING: arrays kernel sequences namespaces math math.ranges
+USING: arrays kernel sequences namespaces make math math.ranges
math.vectors vectors ;
IN: math.numerical-integration
-USING: arrays kernel sequences vectors math math.vectors namespaces
-shuffle splitting sequences.lib math.order ;
+USING: arrays kernel sequences vectors math math.vectors
+namespaces make shuffle splitting sequences.lib math.order ;
IN: math.polynomials
! Polynomials are vectors with the highest powers on the right:
! Copyright (C) 2007 Samuel Tardieu.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel lists math math.primes namespaces sequences ;
+USING: arrays kernel lists math math.primes namespaces make
+sequences ;
IN: math.primes.factors
<PRIVATE
M: monad fail monad-of fail ;
: bind ( mvalue quot -- mvalue' ) swap >>= call ;
-: >> ( mvalue k -- mvalue' ) '[ drop , ] bind ;
+: >> ( mvalue k -- mvalue' ) '[ drop _ ] bind ;
:: lift-m2 ( m1 m2 f monad -- m3 )
m1 [| x1 | m2 [| x2 | x1 x2 f monad return ] bind ] bind ;
] bind
] bind ;
-M: monad fmap over '[ @ , return ] bind ;
+M: monad fmap over '[ @ _ return ] bind ;
! 'do' notation
: do ( quots -- result ) unclip dip [ bind ] each ;
M: identity-monad return drop identity boa ;
M: identity-monad fail "Fail" throw ;
-M: identity >>= value>> '[ , _ call ] ;
+M: identity >>= value>> '[ _ swap call ] ;
: run-identity ( identity -- value ) value>> ;
M: maybe-monad return drop just ;
M: maybe-monad fail 2drop nothing ;
-M: nothing >>= '[ drop , ] ;
-M: just >>= value>> '[ , _ call ] ;
+M: nothing >>= '[ drop _ ] ;
+M: just >>= value>> '[ _ swap call ] ;
: if-maybe ( maybe just-quot nothing-quot -- )
pick nothing? [ 2nip call ] [ drop [ value>> ] dip call ] if ; inline
M: either-monad return drop right ;
M: either-monad fail drop left ;
-M: left >>= '[ drop , ] ;
-M: right >>= value>> '[ , _ call ] ;
+M: left >>= '[ drop _ ] ;
+M: right >>= value>> '[ _ swap call ] ;
: if-either ( value left-quot right-quot -- )
[ [ value>> ] [ left? ] bi ] 2dip if ; inline
M: array monad-of drop array-monad ;
-M: array >>= '[ , _ map concat ] ;
+M: array >>= '[ _ swap map concat ] ;
! List
SINGLETON: list-monad
M: list monad-of drop list-monad ;
-M: list >>= '[ , _ lazy-map lconcat ] ;
+M: list >>= '[ _ swap lazy-map lconcat ] ;
! State
SINGLETON: state-monad
M: state monad-of drop state-monad ;
-M: state-monad return drop '[ , 2array ] state ;
+M: state-monad return drop '[ _ 2array ] state ;
M: state-monad fail "Fail" throw ;
: mcall ( state -- ) quot>> call ;
-M: state >>= '[ , _ '[ , mcall first2 @ mcall ] state ] ;
+M: state >>= '[ _ swap '[ _ mcall first2 @ mcall ] state ] ;
: get-st ( -- state ) [ dup 2array ] state ;
-: put-st ( value -- state ) '[ drop , f 2array ] state ;
+: put-st ( value -- state ) '[ drop _ f 2array ] state ;
: run-st ( state initial -- ) swap mcall second ;
M: reader monad-of drop reader-monad ;
-M: reader-monad return drop '[ drop , ] reader ;
+M: reader-monad return drop '[ drop _ ] reader ;
M: reader-monad fail "Fail" throw ;
-M: reader >>= '[ , _ '[ dup , mcall @ mcall ] reader ] ;
+M: reader >>= '[ _ swap '[ dup _ mcall @ mcall ] reader ] ;
: run-reader ( reader env -- ) swap mcall ;
: ask ( -- reader ) [ ] reader ;
-: local ( reader quot -- reader' ) swap '[ @ , mcall ] reader ;
+: local ( reader quot -- reader' ) swap '[ @ _ mcall ] reader ;
! Writer
SINGLETON: writer-monad
: run-writer ( writer -- value log ) [ value>> ] [ log>> ] bi ;
-M: writer >>= '[ , run-writer _ '[ @ run-writer ] dip append writer ] ;
+M: writer >>= '[ [ _ run-writer ] dip '[ @ run-writer ] dip append writer ] ;
: pass ( writer -- writer' ) run-writer [ first2 ] dip swap call writer ;
: listen ( writer -- writer' ) run-writer [ 2array ] keep writer ;
USING: io kernel math math.functions math.parser parser lexer
-namespaces sequences splitting grouping combinators
+namespaces make sequences splitting grouping combinators
continuations sequences.lib ;
IN: money
! Copyright (C) 2007, 2008 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs combinators hashtables kernel lists math namespaces openal parser-combinators promises sequences strings symbols synth synth.buffers unicode.case ;
+USING: accessors assocs combinators hashtables kernel lists math
+namespaces make openal parser-combinators promises sequences
+strings symbols synth synth.buffers unicode.case ;
IN: morse
<PRIVATE
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math sequences vectors classes classes.algebra
-combinators arrays words assocs parser namespaces definitions
-prettyprint prettyprint.backend quotations generalizations
-debugger io compiler.units kernel.private effects accessors
-hashtables sorting shuffle math.order sets ;
+combinators arrays words assocs parser namespaces make
+definitions prettyprint prettyprint.backend quotations
+generalizations debugger io compiler.units kernel.private
+effects accessors hashtables sorting shuffle math.order sets ;
IN: multi-methods
! PART I: Converting hook specializers
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel alien alien.strings alien.syntax
-combinators alien.c-types strings sequences namespaces words
-math threads io.encodings.ascii ;
+combinators alien.c-types strings sequences namespaces make
+words math threads io.encodings.ascii ;
IN: odbc
<< "odbc" "odbc32.dll" "stdcall" add-library >>
! Copyright (C) 2008 Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel namespaces sequences splitting opengl.gl
+USING: kernel namespaces make sequences splitting opengl.gl
continuations math.parser math arrays sets math.order ;
IN: opengl.capabilities
-USING: kernel namespaces accessors
+USING: kernel namespaces make accessors
math math.constants math.functions math.matrices math.vectors
sequences splitting grouping self math.trig ;
-USING: io io.streams.string kernel namespaces pack strings tools.test ;
+USING: io io.streams.string kernel namespaces make
+pack strings tools.test ;
[ B{ 1 0 2 0 0 3 0 0 0 4 0 0 0 0 0 0 0 5 } ] [
{ 1 2 3 4 5 }
USING: alien alien.c-types arrays assocs byte-arrays io
io.binary io.streams.string kernel math math.parser namespaces
-parser prettyprint quotations sequences strings vectors words
-macros math.functions math.bitwise ;
+make parser prettyprint quotations sequences strings vectors
+words macros math.functions math.bitwise ;
IN: pack
SYMBOL: big-endian
combinators
combinators.lib
combinators.cleave
- rewrite-closures fry accessors newfx
+ rewrite-closures bake bake.fry accessors newfx
processing.gadget math.geometry.rect
processing.shapes
colors ;
! Copyright (c) 2007 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.functions namespaces sequences sorting ;
+USING: kernel math math.functions namespaces make sequences sorting ;
IN: project-euler.009
! http://projecteuler.net/index.php?section=problems&id=9
! Copyright (c) 2007 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel namespaces project-euler.common sequences
+USING: kernel namespaces make project-euler.common sequences
splitting grouping ;
IN: project-euler.011
! Copyright (c) 2007 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays combinators.lib combinators.short-circuit kernel math math.ranges
- namespaces sequences sorting ;
+USING: arrays combinators.lib combinators.short-circuit kernel
+math math.ranges namespaces make sequences sorting ;
IN: project-euler.014
! http://projecteuler.net/index.php?section=problems&id=14
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: ascii io.files kernel math math.functions namespaces
+USING: ascii io.files kernel math math.functions namespaces make
project-euler.common sequences sequences.lib splitting io.encodings.ascii ;
IN: project-euler.042
! Copyright (c) 2008 Aaron Schaefer, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays ascii assocs hashtables io.encodings.ascii io.files kernel math
- math.parser namespaces sequences sequences.lib sequences.private sorting
+ math.parser namespaces make sequences sequences.lib sequences.private sorting
splitting grouping strings sets accessors ;
IN: project-euler.059
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: assocs hashtables io.files kernel math math.parser namespaces
-io.encodings.ascii sequences sets ;
+USING: assocs hashtables io.files kernel math math.parser
+namespaces make io.encodings.ascii sequences sets ;
IN: project-euler.079
! http://projecteuler.net/index.php?section=problems&id=79
! Copyright (c) 2007 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: continuations io kernel math math.functions math.parser math.statistics
- namespaces tools.time ;
+ namespaces make tools.time ;
IN: project-euler.ave-time
: collect-benchmarks ( quot n -- seq )
-USING: arrays kernel math math.functions math.miller-rabin math.matrices
- math.order math.parser math.primes.factors math.ranges namespaces
- sequences sequences.lib sorting unicode.case ;
+USING: arrays kernel math math.functions math.miller-rabin
+math.matrices math.order math.parser math.primes.factors
+math.ranges namespaces make sequences sequences.lib sorting
+unicode.case ;
IN: project-euler.common
! A collection of words used by more than one Project Euler solution
! Updated by Chris Double, September 2006
USING: arrays kernel sequences math vectors arrays namespaces
-quotations parser effects stack-checker words accessors ;
+make quotations parser effects stack-checker words accessors ;
IN: promises
TUPLE: promise quot forced? value ;
USING: kernel namespaces arrays quotations sequences assocs combinators
- mirrors math math.vectors random macros fry ;
+ mirrors math math.vectors random macros bake bake.fry ;
IN: random-weighted
namespaces parser lexer parser-combinators parser-combinators.simple
promises quotations sequences combinators.lib strings math.order
assocs prettyprint.backend memoize unicode.case unicode.categories
-combinators.short-circuit accessors ;
-USE: io
+combinators.short-circuit accessors make io ;
IN: regexp
<PRIVATE
-USING: kernel parser math quotations namespaces sequences macros fry ;
+USING: kernel parser math quotations namespaces sequences macros
+bake bake.fry ;
IN: rewrite-closures
! Copyright (C) 2007 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays assocs kernel math math.order math.vectors namespaces
-quotations sequences sequences.lib sequences.private strings unicode.case ;
+USING: arrays assocs kernel math math.order math.vectors
+namespaces make quotations sequences sequences.lib
+sequences.private strings unicode.case ;
IN: roman
<PRIVATE
! Copyright (C) 2007 Slava Pestov, Chris Double, Doug Coleman,
! Eduardo Cavazos, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: combinators.lib kernel sequences math namespaces assocs
-random sequences.private shuffle math.functions
-arrays math.parser math.private sorting strings ascii macros
-assocs.lib quotations hashtables math.order locals
-generalizations ;
+USING: combinators.lib kernel sequences math namespaces make
+assocs random sequences.private shuffle math.functions arrays
+math.parser math.private sorting strings ascii macros assocs.lib
+quotations hashtables math.order locals generalizations ;
IN: sequences.lib
: each-withn ( seq quot n -- ) nwith each ; inline
-USING: kernel parser lexer strings math namespaces
+USING: kernel parser lexer strings math namespaces make
sequences words io arrays quotations debugger accessors
sequences.private ;
IN: state-machine
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel namespaces sequences vectors assocs accessors ;
+USING: kernel namespaces make sequences vectors assocs accessors ;
IN: state-tables
TUPLE: table rows columns start-state final-states ;
! Copyright (C) 2008 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays kernel namespaces openal sequences synth synth.buffers ;
+USING: accessors arrays kernel namespaces make openal sequences
+synth synth.buffers ;
IN: synth.example
: play-sine-wave ( freq seconds sample-freq -- )
\r
:: add-toggle ( model n name toggler -- )\r
<frame>\r
- n name toggler parent>> '[ , , , (del-page) ] "X" swap <bevel-button>\r
+ n name toggler parent>> '[ _ _ _ (del-page) ] "X" swap <bevel-button>\r
@right grid-add\r
n model name <toggle-button> @center grid-add\r
toggler swap add-gadget drop ;\r
[ names>> ] [ model>> ] [ toggler>> ] tri\r
[ clear-gadget ] keep\r
[ [ length ] keep ] 2dip\r
- '[ , _ _ , add-toggle ] 2each ;\r
+ '[ [ _ ] 2dip _ add-toggle ] 2each ;\r
\r
: refresh-book ( tabbed -- )\r
model>> [ ] change-model ;\r
USING: kernel sequences math math.order
ui.gadgets ui.gadgets.tracks ui.gestures
- fry accessors ;
+ bake.fry accessors ;
IN: ui.gadgets.tiling
: exchanged! ( seq a b -- )
[ 0 max ] bi@
- pick length 1 - '[ , min ] bi@
+ pick length 1 - '[ _ min ] bi@
rot exchange ;
: move-prev ( tiling -- tiling )
: <counter-action> ( quot -- action )
<action>
swap '[
- count , schange
+ count _ schange
URL" $counter-app" <redirect>
] >>submit ;
: fetch-blogroll ( blogroll -- entries )
[ [ feed-url>> fetch-feed ] parallel-map ] [ [ name>> ] map ] bi
- [ '[
, <posting> ] map ] 2map concat ;
+ [ '[
_ <posting> ] map ] 2map concat ;
: sort-entries ( entries -- entries' )
[ [ date>> ] compare invert-comparison ] sort ;
{ planet "planet-common" } >>template ;
: start-update-task ( db params -- )
- '[ , , [ update-cached-postings ] with-db ] 10 minutes every drop ;
+ '[ _ _ [ update-cached-postings ] with-db ] 10 minutes every drop ;
1 6 [a,b] random [ letter-bank random ] "" replicate-as ;
: insert-short-url ( short-url -- short-url )
- '[ , dup random-url >>short insert-tuple ] 10 retry ;
+ '[ _ dup random-url >>short insert-tuple ] 10 retry ;
: shorten ( url -- short )
short-url new swap >>url dup select-tuple
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel hashtables calendar random assocs
-namespaces splitting sequences sorting math.order present
+namespaces make splitting sequences sorting math.order present
io.files io.encodings.ascii
syndication farkup
html.components html.forms
<article> select-tuple
dup [ revision>> <revision> select-tuple ] when ;
-: init-relative-link-prefix ( -- )
- URL" $wiki/view/" adjust-url present relative-link-prefix set ;
-
: <view-article-action> ( -- action )
<action>
"title" >>rest
- [
- validate-title
- init-relative-link-prefix
- ] >>init
+ [ validate-title ] >>init
[
"title" value dup latest-revision [
validate-integer-id
"id" value <revision>
select-tuple from-object
- init-relative-link-prefix
] >>init
{ wiki "view" } >>template
"noreply@concatenative.org" lost-password-from set-global
"website@concatenative.org" insomniac-sender set-global
"slava@factorcode.org" insomniac-recipients set-global
- <factor-website> main-responder set-global
init-factor-db ;
: init-testing ( -- )
"resource:basis/openssl/test/dh1024.pem" dh-file set-global
"resource:basis/openssl/test/server.pem" key-file set-global
"password" key-password set-global
- common-configuration ;
+ common-configuration
+ <factor-website> main-responder set-global ;
+
+: no-www-prefix ( -- responder )
+ "http://concatenative.org" <permanent-redirect> <trivial-responder> ;
: init-production ( -- )
- f dh-file set-global
- f key-password set-global
- "/home/slava/cert/host.pem" key-file set-global
- common-configuration ;
+ common-configuration
+ <vhost-dispatcher>
+ <factor-website> "concatenative.org" add-responder
+ no-www-prefix "www.concatenative.org" add-responder
+ main-responder set-global ;
: <factor-secure-config> ( -- config )
<secure-config>
-USING: kernel sequences namespaces math assocs words arrays tools.annotations vocabs sorting prettyprint io micros math.statistics accessors ;
+USING: kernel sequences namespaces make math assocs words arrays
+tools.annotations vocabs sorting prettyprint io micros
+math.statistics accessors ;
IN: wordtimer
SYMBOL: *wordtimes*
! Copyright (C) 2008 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: lexer parser splitting kernel quotations namespaces
+USING: lexer parser splitting kernel quotations namespaces make
sequences assocs sequences.lib xml.generator xml.utilities
xml.data ;
IN: xml.syntax
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel namespaces make math sequences layouts
+alien.c-types alien.structs compiler.backend ;
+IN: compiler.alien
+
+! Common utilities
+
+: large-struct? ( ctype -- ? )
+ dup c-struct? [
+ heap-size struct-small-enough? not
+ ] [ drop f ] if ;
+
+: alien-parameters ( params -- seq )
+ dup parameters>>
+ swap return>> large-struct? [ "void*" prefix ] when ;
+
+: alien-return ( params -- ctype )
+ return>> dup large-struct? [ drop "void" ] when ;
+
+: c-type-stack-align ( type -- align )
+ dup c-type-stack-align? [ c-type-align ] [ drop cell ] if ;
+
+: parameter-align ( n type -- n delta )
+ over >r c-type-stack-align align dup r> - ;
+
+: parameter-sizes ( types -- total offsets )
+ #! Compute stack frame locations.
+ [
+ 0 [
+ [ parameter-align drop dup , ] keep stack-size +
+ ] reduce cell align
+ ] { } make ;
+
+: return-size ( ctype -- n )
+ #! Amount of space we reserve for a return value.
+ dup large-struct? [ heap-size ] [ drop 0 ] if ;
+
+: alien-stack-frame ( params -- n )
+ alien-parameters parameter-sizes drop ;
+
+: alien-invoke-frame ( params -- n )
+ #! One cell is temporary storage, temp@
+ dup return>> return-size
+ swap alien-stack-frame +
+ cell + ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: compiler.backend.alien
+
+! #alien-invoke
+: set-stack-frame ( n -- )
+ dup [ frame-required ] when* \ stack-frame set ;
+
+: with-stack-frame ( n quot -- )
+ swap set-stack-frame
+ call
+ f set-stack-frame ; inline
+
+GENERIC: reg-size ( register-class -- n )
+
+M: int-regs reg-size drop cell ;
+
+M: single-float-regs reg-size drop 4 ;
+
+M: double-float-regs reg-size drop 8 ;
+
+GENERIC: reg-class-variable ( register-class -- symbol )
+
+M: reg-class reg-class-variable ;
+
+M: float-regs reg-class-variable drop float-regs ;
+
+GENERIC: inc-reg-class ( register-class -- )
+
+M: reg-class inc-reg-class
+ dup reg-class-variable inc
+ fp-shadows-int? [ reg-size stack-params +@ ] [ drop ] if ;
+
+M: float-regs inc-reg-class
+ dup call-next-method
+ fp-shadows-int? [ reg-size cell /i int-regs +@ ] [ drop ] if ;
+
+GENERIC: reg-class-full? ( class -- ? )
+
+M: stack-params reg-class-full? drop t ;
+
+M: object reg-class-full?
+ [ reg-class-variable get ] [ param-regs length ] bi >= ;
+
+: spill-param ( reg-class -- n reg-class )
+ stack-params get
+ >r reg-size stack-params +@ r>
+ stack-params ;
+
+: fastcall-param ( reg-class -- n reg-class )
+ [ reg-class-variable get ] [ inc-reg-class ] [ ] tri ;
+
+: alloc-parameter ( parameter -- reg reg-class )
+ c-type-reg-class dup reg-class-full?
+ [ spill-param ] [ fastcall-param ] if
+ [ param-reg ] keep ;
+
+: (flatten-int-type) ( size -- )
+ cell /i "void*" c-type <repetition> % ;
+
+GENERIC: flatten-value-type ( type -- )
+
+M: object flatten-value-type , ;
+
+M: struct-type flatten-value-type ( type -- )
+ stack-size cell align (flatten-int-type) ;
+
+M: long-long-type flatten-value-type ( type -- )
+ stack-size cell align (flatten-int-type) ;
+
+: flatten-value-types ( params -- params )
+ #! Convert value type structs to consecutive void*s.
+ [
+ 0 [
+ c-type
+ [ parameter-align (flatten-int-type) ] keep
+ [ stack-size cell align + ] keep
+ flatten-value-type
+ ] reduce drop
+ ] { } make ;
+
+: each-parameter ( parameters quot -- )
+ >r [ parameter-sizes nip ] keep r> 2each ; inline
+
+: reverse-each-parameter ( parameters quot -- )
+ >r [ parameter-sizes nip ] keep r> 2reverse-each ; inline
+
+: reset-freg-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
+
+: move-parameters ( node word -- )
+ #! Moves values from C stack to registers (if word is
+ #! %load-param-reg) and registers to C stack (if word is
+ #! %save-param-reg).
+ >r
+ alien-parameters
+ flatten-value-types
+ r> [ >r alloc-parameter r> execute ] curry each-parameter ;
+ inline
+
+: unbox-parameters ( offset node -- )
+ parameters>> [
+ %prepare-unbox >r over + r> unbox-parameter
+ ] reverse-each-parameter drop ;
+
+: prepare-box-struct ( node -- offset )
+ #! Return offset on C stack where to store unboxed
+ #! parameters. If the C function is returning a structure,
+ #! the first parameter is an implicit target area pointer,
+ #! so we need to use a different offset.
+ return>> dup large-struct?
+ [ heap-size %prepare-box-struct cell ] [ drop 0 ] if ;
+
+: objects>registers ( params -- )
+ #! Generate code for unboxing a list of C types, then
+ #! generate code for moving these parameters to register on
+ #! architectures where parameters are passed in registers.
+ [
+ [ prepare-box-struct ] keep
+ [ unbox-parameters ] keep
+ \ %load-param-reg move-parameters
+ ] with-param-regs ;
+
+: box-return* ( node -- )
+ return>> [ ] [ box-return ] if-void ;
+
+TUPLE: no-such-library name ;
+
+M: no-such-library summary
+ drop "Library not found" ;
+
+M: no-such-library compiler-error-type
+ drop +linkage+ ;
+
+: no-such-library ( name -- )
+ \ no-such-library boa
+ compiling-word get compiler-error ;
+
+TUPLE: no-such-symbol name ;
+
+M: no-such-symbol summary
+ drop "Symbol not found" ;
+
+M: no-such-symbol compiler-error-type
+ drop +linkage+ ;
+
+: no-such-symbol ( name -- )
+ \ no-such-symbol boa
+ compiling-word get compiler-error ;
+
+: check-dlsym ( symbols dll -- )
+ dup dll-valid? [
+ dupd [ dlsym ] curry contains?
+ [ drop ] [ no-such-symbol ] if
+ ] [
+ dll-path no-such-library drop
+ ] if ;
+
+: stdcall-mangle ( symbol node -- symbol )
+ "@"
+ swap parameters>> parameter-sizes drop
+ number>string 3append ;
+
+: alien-invoke-dlsym ( params -- symbols dll )
+ dup function>> dup pick stdcall-mangle 2array
+ swap library>> library dup [ dll>> ] when
+ 2dup check-dlsym ;
+
+M: #alien-invoke generate-node
+ params>>
+ dup alien-invoke-frame [
+ end-basic-block
+ %prepare-alien-invoke
+ dup objects>registers
+ %prepare-var-args
+ dup alien-invoke-dlsym %alien-invoke
+ dup %cleanup
+ box-return*
+ iterate-next
+ ] with-stack-frame ;
+
+! #alien-indirect
+M: #alien-indirect generate-node
+ params>>
+ dup alien-invoke-frame [
+ ! Flush registers
+ end-basic-block
+ ! Save registers for GC
+ %prepare-alien-invoke
+ ! Save alien at top of stack to temporary storage
+ %prepare-alien-indirect
+ dup objects>registers
+ %prepare-var-args
+ ! Call alien in temporary storage
+ %alien-indirect
+ dup %cleanup
+ box-return*
+ iterate-next
+ ] with-stack-frame ;
+
+! #alien-callback
+: box-parameters ( params -- )
+ alien-parameters [ box-parameter ] each-parameter ;
+
+: registers>objects ( node -- )
+ [
+ dup \ %save-param-reg move-parameters
+ "nest_stacks" f %alien-invoke
+ box-parameters
+ ] with-param-regs ;
+
+TUPLE: callback-context ;
+
+: current-callback 2 getenv ;
+
+: wait-to-return ( token -- )
+ dup current-callback eq? [
+ drop
+ ] [
+ yield wait-to-return
+ ] if ;
+
+: do-callback ( quot token -- )
+ init-catchstack
+ dup 2 setenv
+ slip
+ wait-to-return ; inline
+
+: callback-return-quot ( ctype -- quot )
+ return>> {
+ { [ dup "void" = ] [ drop [ ] ] }
+ { [ dup large-struct? ] [ heap-size [ memcpy ] curry ] }
+ [ c-type c-type-unboxer-quot ]
+ } cond ;
+
+: callback-prep-quot ( params -- quot )
+ parameters>> [ c-type c-type-boxer-quot ] map spread>quot ;
+
+: wrap-callback-quot ( params -- quot )
+ [
+ [ callback-prep-quot ]
+ [ quot>> ]
+ [ callback-return-quot ] tri 3append ,
+ [ callback-context new do-callback ] %
+ ] [ ] make ;
+
+: %unnest-stacks ( -- ) "unnest_stacks" f %alien-invoke ;
+
+: callback-unwind ( params -- n )
+ {
+ { [ dup abi>> "stdcall" = ] [ alien-stack-frame ] }
+ { [ dup return>> large-struct? ] [ drop 4 ] }
+ [ drop 0 ]
+ } cond ;
+
+: %callback-return ( params -- )
+ #! All the extra book-keeping for %unwind is only for x86.
+ #! On other platforms its an alias for %return.
+ dup alien-return
+ [ %unnest-stacks ] [ %callback-value ] if-void
+ callback-unwind %unwind ;
+
+: generate-callback ( params -- )
+ dup xt>> dup [
+ init-templates
+ %prologue
+ dup alien-stack-frame [
+ [ registers>objects ]
+ [ wrap-callback-quot %alien-callback ]
+ [ %callback-return ]
+ tri
+ ] with-stack-frame
+ ] with-cfg-builder ;
+
+M: #alien-callback generate-node
+ end-basic-block
+ params>> generate-callback iterate-next ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: system ;
+IN: compiler.backend
+
+! Is this structure small enough to be returned in registers?
+HOOK: struct-small-enough? cpu ( size -- ? )
+
+! Mapping from register class to machine registers
+HOOK: machine-registers cpu ( -- assoc )
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: system cpu.x86.assembler compiler.registers compiler.backend ;
+IN: compiler.backend.x86.32
+
+M: x86.32 machine-registers
+ {
+ { int-regs { EAX ECX EDX EBP EBX } }
+ { float-regs { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } }
+ } ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math namespaces assocs hashtables sequences
+accessors vectors combinators sets compiler.vops compiler.cfg ;
+IN: compiler.cfg.alias
+
+! Alias analysis -- must be run after compiler.cfg.stack.
+!
+! We try to eliminate redundant slot and stack
+! traffic using some simple heuristics.
+!
+! All heap-allocated objects which are loaded from the stack, or
+! other object slots are pessimistically assumed to belong to
+! the same alias class.
+!
+! Freshly-allocated objects get their own alias class.
+!
+! The data and retain stack pointer registers are treated
+! uniformly, and each one gets its own alias class.
+!
+! Simple pseudo-C example showing load elimination:
+!
+! int *x, *y, z: inputs
+! int a, b, c, d, e: locals
+!
+! Before alias analysis:
+!
+! a = x[2]
+! b = x[2]
+! c = x[3]
+! y[2] = z
+! d = x[2]
+! e = y[2]
+! f = x[3]
+!
+! After alias analysis:
+!
+! a = x[2]
+! b = a /* ELIMINATED */
+! c = x[3]
+! y[2] = z
+! d = x[2] /* if x=y, d=z, if x!=y, d=b; NOT ELIMINATED */
+! e = z /* ELIMINATED */
+! f = c /* ELIMINATED */
+!
+! Simple pseudo-C example showing store elimination:
+!
+! Before alias analysis:
+!
+! x[0] = a
+! b = x[n]
+! x[0] = c
+! x[1] = d
+! e = x[0]
+! x[1] = c
+!
+! After alias analysis:
+!
+! x[0] = a /* dead if n = 0, live otherwise; NOT ELIMINATED */
+! b = x[n]
+! x[0] = c
+! /* x[1] = d */ /* ELIMINATED */
+! e = c
+! x[1] = c
+
+! Map vregs -> alias classes
+SYMBOL: vregs>acs
+
+: check [ "BUG: static type error detected" throw ] unless* ; inline
+
+: vreg>ac ( vreg -- ac )
+ #! Only vregs produced by %%allot, %peek and %%slot can
+ #! ever be used as valid inputs to %%slot and %%set-slot,
+ #! so we assert this fact by not giving alias classes to
+ #! other vregs.
+ vregs>acs get at check ;
+
+! Map alias classes -> sequence of vregs
+SYMBOL: acs>vregs
+
+: ac>vregs ( ac -- vregs ) acs>vregs get at ;
+
+: aliases ( vreg -- vregs )
+ #! All vregs which may contain the same value as vreg.
+ vreg>ac ac>vregs ;
+
+: each-alias ( vreg quot -- )
+ [ aliases ] dip each ; inline
+
+! Map vregs -> slot# -> vreg
+SYMBOL: live-slots
+
+! Current instruction number
+SYMBOL: insn#
+
+! Load/store history, for dead store elimination
+TUPLE: load insn# ;
+TUPLE: store insn# ;
+
+: new-action ( class -- action )
+ insn# get swap boa ; inline
+
+! Maps vreg -> slot# -> sequence of loads/stores
+SYMBOL: histories
+
+: history ( vreg -- history ) histories get at ;
+
+: set-ac ( vreg ac -- )
+ #! Set alias class of newly-seen vreg.
+ {
+ [ drop H{ } clone swap histories get set-at ]
+ [ drop H{ } clone swap live-slots get set-at ]
+ [ swap vregs>acs get set-at ]
+ [ acs>vregs get push-at ]
+ } 2cleave ;
+
+: live-slot ( slot#/f vreg -- vreg' )
+ #! If the slot number is unknown, we never reuse a previous
+ #! value.
+ over [ live-slots get at at ] [ 2drop f ] if ;
+
+: load-constant-slot ( value slot# vreg -- )
+ live-slots get at check set-at ;
+
+: load-slot ( value slot#/f vreg -- )
+ over [ load-constant-slot ] [ 3drop ] if ;
+
+: record-constant-slot ( slot# vreg -- )
+ #! A load can potentially read every store of this slot#
+ #! in that alias class.
+ [
+ history [ load new-action swap ?push ] change-at
+ ] with each-alias ;
+
+: record-computed-slot ( vreg -- )
+ #! Computed load is like a load of every slot touched so far
+ [
+ history values [ load new-action swap push ] each
+ ] each-alias ;
+
+: remember-slot ( value slot#/f vreg -- )
+ over
+ [ [ record-constant-slot ] [ load-constant-slot ] 2bi ]
+ [ 2nip record-computed-slot ] if ;
+
+SYMBOL: ac-counter
+
+: next-ac ( -- n )
+ ac-counter [ dup 1+ ] change ;
+
+! Alias class for objects which are loaded from the data stack
+! or other object slots. We pessimistically assume that they
+! can all alias each other.
+SYMBOL: heap-ac
+
+: set-heap-ac ( vreg -- ) heap-ac get set-ac ;
+
+: set-new-ac ( vreg -- ) next-ac set-ac ;
+
+: kill-constant-set-slot ( slot# vreg -- )
+ [ live-slots get at delete-at ] with each-alias ;
+
+: record-constant-set-slot ( slot# vreg -- )
+ history [
+ dup empty? [ dup peek store? [ dup pop* ] when ] unless
+ store new-action swap ?push
+ ] change-at ;
+
+: kill-computed-set-slot ( ac -- )
+ [ live-slots get at clear-assoc ] each-alias ;
+
+: remember-set-slot ( slot#/f vreg -- )
+ over [
+ [ record-constant-set-slot ]
+ [ kill-constant-set-slot ] 2bi
+ ] [ nip kill-computed-set-slot ] if ;
+
+SYMBOL: copies
+
+: resolve ( vreg -- vreg )
+ dup copies get at swap or ;
+
+SYMBOL: constants
+
+: constant ( vreg -- n/f )
+ #! Return an %iconst value, or f if the vreg was not
+ #! assigned by an %iconst.
+ resolve constants get at ;
+
+! We treat slot accessors and stack traffic alike
+GENERIC: insn-slot# ( insn -- slot#/f )
+GENERIC: insn-object ( insn -- vreg )
+
+M: %peek insn-slot# n>> ;
+M: %replace insn-slot# n>> ;
+M: %%slot insn-slot# slot>> constant ;
+M: %%set-slot insn-slot# slot>> constant ;
+
+M: %peek insn-object stack>> ;
+M: %replace insn-object stack>> ;
+M: %%slot insn-object obj>> resolve ;
+M: %%set-slot insn-object obj>> resolve ;
+
+: init-alias-analysis ( -- )
+ H{ } clone histories set
+ H{ } clone vregs>acs set
+ H{ } clone acs>vregs set
+ H{ } clone live-slots set
+ H{ } clone constants set
+ H{ } clone copies set
+
+ 0 ac-counter set
+ next-ac heap-ac set
+
+ %data next-ac set-ac
+ %retain next-ac set-ac ;
+
+GENERIC: analyze-aliases ( insn -- insn' )
+
+M: %iconst analyze-aliases
+ dup [ value>> ] [ out>> ] bi constants get set-at ;
+
+M: %%allot analyze-aliases
+ #! A freshly allocated object is distinct from any other
+ #! object.
+ dup out>> set-new-ac ;
+
+M: read-op analyze-aliases
+ dup out>> set-heap-ac
+ dup [ out>> ] [ insn-slot# ] [ insn-object ] tri
+ 2dup live-slot dup [
+ 2nip %copy boa analyze-aliases nip
+ ] [
+ drop remember-slot
+ ] if ;
+
+: idempotent? ( value slot#/f vreg -- ? )
+ #! Are we storing a value back to the same slot it was read
+ #! from?
+ live-slot = ;
+
+M: write-op analyze-aliases
+ dup
+ [ in>> resolve ] [ insn-slot# ] [ insn-object ] tri
+ 3dup idempotent? [
+ 2drop 2drop nop
+ ] [
+ [ remember-set-slot drop ] [ load-slot ] 3bi
+ ] if ;
+
+M: %copy analyze-aliases
+ #! The output vreg gets the same alias class as the input
+ #! vreg, since they both contain the same value.
+ dup [ in>> resolve ] [ out>> ] bi copies get set-at ;
+
+M: vop analyze-aliases ;
+
+SYMBOL: live-stores
+
+: compute-live-stores ( -- )
+ histories get
+ values [
+ values [ [ store? ] filter [ insn#>> ] map ] map concat
+ ] map concat unique
+ live-stores set ;
+
+GENERIC: eliminate-dead-store ( insn -- insn' )
+
+: (eliminate-dead-store) ( insn -- insn' )
+ dup insn-slot# [
+ insn# get live-stores get key? [
+ drop nop
+ ] unless
+ ] when ;
+
+M: %replace eliminate-dead-store
+ #! Writes to above the top of the stack can be pruned also.
+ #! This is sound since any such writes are not observable
+ #! after the basic block, and any reads of those locations
+ #! will have been converted to copies by analyze-slot,
+ #! and the final stack height of the basic block is set at
+ #! the beginning by compiler.cfg.stack.
+ dup n>> 0 < [ drop nop ] [ (eliminate-dead-store) ] if ;
+
+M: %%set-slot eliminate-dead-store (eliminate-dead-store) ;
+
+M: vop eliminate-dead-store ;
+
+: alias-analysis ( insns -- insns' )
+ init-alias-analysis
+ [ insn# set analyze-aliases ] map-index
+ compute-live-stores
+ [ insn# set eliminate-dead-store ] map-index ;
--- /dev/null
+Slava Pestov
--- /dev/null
+IN: compiler.cfg.builder.tests
+USING: compiler.cfg.builder tools.test ;
+
+\ build-cfg must-infer
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays kernel assocs sequences sequences.lib fry accessors
+namespaces math combinators math.order
+compiler.tree
+compiler.tree.combinators
+compiler.tree.propagation.info
+compiler.cfg
+compiler.vops
+compiler.vops.builder ;
+IN: compiler.cfg.builder
+
+! Convert tree SSA IR to CFG SSA IR.
+
+! We construct the graph and set successors first, then we
+! set predecessors in a separate pass. This simplifies the
+! logic.
+
+SYMBOL: procedures
+
+SYMBOL: loop-nesting
+
+SYMBOL: values>vregs
+
+GENERIC: convert ( node -- )
+
+M: #introduce convert drop ;
+
+: init-builder ( -- )
+ H{ } clone values>vregs set ;
+
+: end-basic-block ( -- )
+ basic-block get [ %b emit ] when ;
+
+: set-basic-block ( basic-block -- )
+ [ basic-block set ] [ instructions>> building set ] bi ;
+
+: begin-basic-block ( -- )
+ <basic-block> basic-block get
+ [
+ end-basic-block
+ dupd successors>> push
+ ] when*
+ set-basic-block ;
+
+: convert-nodes ( node -- )
+ [ convert ] each ;
+
+: (build-cfg) ( node word -- )
+ init-builder
+ begin-basic-block
+ basic-block get swap procedures get set-at
+ convert-nodes ;
+
+: build-cfg ( node word -- procedures )
+ H{ } clone [
+ procedures [ (build-cfg) ] with-variable
+ ] keep ;
+
+: value>vreg ( value -- vreg )
+ values>vregs get at ;
+
+: output-vreg ( value vreg -- )
+ swap values>vregs get set-at ;
+
+: produce-vreg ( value -- vreg )
+ next-vreg [ output-vreg ] keep ;
+
+: (load-inputs) ( seq stack -- )
+ over empty? [ 2drop ] [
+ [ <reversed> ] dip
+ [ '[ produce-vreg _ , %peek emit ] each-index ]
+ [ [ length neg ] dip %height emit ]
+ 2bi
+ ] if ;
+
+: load-in-d ( node -- ) in-d>> %data (load-inputs) ;
+
+: load-in-r ( node -- ) in-r>> %retain (load-inputs) ;
+
+: (store-outputs) ( seq stack -- )
+ over empty? [ 2drop ] [
+ [ <reversed> ] dip
+ [ [ length ] dip %height emit ]
+ [ '[ value>vreg _ , %replace emit ] each-index ]
+ 2bi
+ ] if ;
+
+: store-out-d ( node -- ) out-d>> %data (store-outputs) ;
+
+: store-out-r ( node -- ) out-r>> %retain (store-outputs) ;
+
+: (emit-call) ( word -- )
+ begin-basic-block %call emit begin-basic-block ;
+
+: intrinsic-inputs ( node -- )
+ [ load-in-d ]
+ [ in-d>> { #1 #2 #3 #4 } [ [ value>vreg ] dip set ] 2each ]
+ bi ;
+
+: intrinsic-outputs ( node -- )
+ [ out-d>> { ^1 ^2 ^3 ^4 } [ get output-vreg ] 2each ]
+ [ store-out-d ]
+ bi ;
+
+: intrinsic ( node quot -- )
+ [
+ init-intrinsic
+
+ [ intrinsic-inputs ]
+ swap
+ [ intrinsic-outputs ]
+ tri
+ ] with-scope ; inline
+
+USING: kernel.private math.private slots.private ;
+
+: maybe-emit-fixnum-shift-fast ( node -- node )
+ dup dup in-d>> second node-value-info literal>> dup fixnum? [
+ '[ , emit-fixnum-shift-fast ] intrinsic
+ ] [
+ drop dup word>> (emit-call)
+ ] if ;
+
+: emit-call ( node -- )
+ dup word>> {
+ { \ tag [ [ emit-tag ] intrinsic ] }
+
+ { \ slot [ [ dup emit-slot ] intrinsic ] }
+ { \ set-slot [ [ dup emit-set-slot ] intrinsic ] }
+
+ { \ fixnum-bitnot [ [ emit-fixnum-bitnot ] intrinsic ] }
+ { \ fixnum+fast [ [ emit-fixnum+fast ] intrinsic ] }
+ { \ fixnum-fast [ [ emit-fixnum-fast ] intrinsic ] }
+ { \ fixnum-bitand [ [ emit-fixnum-bitand ] intrinsic ] }
+ { \ fixnum-bitor [ [ emit-fixnum-bitor ] intrinsic ] }
+ { \ fixnum-bitxor [ [ emit-fixnum-bitxor ] intrinsic ] }
+ { \ fixnum*fast [ [ emit-fixnum*fast ] intrinsic ] }
+ { \ fixnum<= [ [ emit-fixnum<= ] intrinsic ] }
+ { \ fixnum>= [ [ emit-fixnum>= ] intrinsic ] }
+ { \ fixnum< [ [ emit-fixnum< ] intrinsic ] }
+ { \ fixnum> [ [ emit-fixnum> ] intrinsic ] }
+ { \ eq? [ [ emit-eq? ] intrinsic ] }
+
+ { \ fixnum-shift-fast [ maybe-emit-fixnum-shift-fast ] }
+
+ { \ float+ [ [ emit-float+ ] intrinsic ] }
+ { \ float- [ [ emit-float- ] intrinsic ] }
+ { \ float* [ [ emit-float* ] intrinsic ] }
+ { \ float/f [ [ emit-float/f ] intrinsic ] }
+ { \ float<= [ [ emit-float<= ] intrinsic ] }
+ { \ float>= [ [ emit-float>= ] intrinsic ] }
+ { \ float< [ [ emit-float< ] intrinsic ] }
+ { \ float> [ [ emit-float> ] intrinsic ] }
+ { \ float? [ [ emit-float= ] intrinsic ] }
+
+ ! { \ (tuple) [ dup first-input '[ , emit-(tuple) ] intrinsic ] }
+ ! { \ (array) [ dup first-input '[ , emit-(array) ] intrinsic ] }
+ ! { \ (byte-array) [ dup first-input '[ , emit-(byte-array) ] intrinsic ] }
+
+ [ (emit-call) ]
+ } case drop ;
+
+M: #call convert emit-call ;
+
+: emit-call-loop ( #recursive -- )
+ dup label>> loop-nesting get at basic-block get successors>> push
+ end-basic-block
+ basic-block off
+ drop ;
+
+: emit-call-recursive ( #recursive -- )
+ label>> id>> (emit-call) ;
+
+M: #call-recursive convert
+ dup label>> loop?>>
+ [ emit-call-loop ] [ emit-call-recursive ] if ;
+
+M: #push convert
+ [
+ [ out-d>> first produce-vreg ]
+ [ node-output-infos first literal>> ]
+ bi emit-literal
+ ]
+ [ store-out-d ] bi ;
+
+M: #shuffle convert [ load-in-d ] [ store-out-d ] bi ;
+
+M: #>r convert [ load-in-d ] [ store-out-r ] bi ;
+
+M: #r> convert [ load-in-r ] [ store-out-d ] bi ;
+
+M: #terminate convert drop ;
+
+: integer-conditional ( in1 in2 cc -- )
+ [ [ next-vreg dup ] 2dip %icmp emit ] dip %bi emit ; inline
+
+: float-conditional ( in1 in2 branch -- )
+ [ next-vreg [ %fcmp emit ] keep ] dip emit ; inline
+
+: emit-if ( #if -- )
+ in-d>> first value>vreg
+ next-vreg dup f emit-literal
+ cc/= integer-conditional ;
+
+: convert-nested ( node -- last-bb )
+ [
+ <basic-block>
+ [ set-basic-block ] keep
+ [ convert-nodes end-basic-block ] dip
+ basic-block get
+ ] with-scope
+ [ basic-block get successors>> push ] dip ;
+
+: convert-if-children ( #if -- )
+ children>> [ convert-nested ] map sift
+ <basic-block>
+ [ '[ , _ successors>> push ] each ]
+ [ set-basic-block ]
+ bi ;
+
+M: #if convert
+ [ load-in-d ] [ emit-if ] [ convert-if-children ] tri ;
+
+M: #dispatch convert
+ "Unimplemented" throw ;
+
+M: #phi convert drop ;
+
+M: #declare convert drop ;
+
+M: #return convert drop %return emit ;
+
+: convert-recursive ( #recursive -- )
+ [ [ label>> id>> ] [ child>> ] bi (build-cfg) ]
+ [ (emit-call) ]
+ bi ;
+
+: begin-loop ( #recursive -- )
+ label>> basic-block get 2array loop-nesting get push ;
+
+: end-loop ( -- )
+ loop-nesting get pop* ;
+
+: convert-loop ( #recursive -- )
+ begin-basic-block
+ [ begin-loop ]
+ [ child>> convert-nodes ]
+ [ drop end-loop ]
+ tri ;
+
+M: #recursive convert
+ dup label>> loop?>>
+ [ convert-loop ] [ convert-recursive ] if ;
+
+M: #copy convert drop ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors namespaces assocs sequences sets fry ;
+IN: compiler.cfg
+
+! The id is a globally unique id used for fast hashcode* and
+! equal? on basic blocks. The number is assigned by
+! linearization.
+TUPLE: basic-block < identity-tuple
+id
+number
+instructions
+successors
+predecessors
+stack-frame ;
+
+SYMBOL: next-block-id
+
+: <basic-block> ( -- basic-block )
+ basic-block new
+ next-block-id counter >>id
+ V{ } clone >>instructions
+ V{ } clone >>successors
+ V{ } clone >>predecessors ;
+
+M: basic-block hashcode* id>> nip ;
+
+! Utilities
+SYMBOL: visited-blocks
+
+: visit-block ( basic-block quot -- )
+ over visited-blocks get 2dup key?
+ [ 2drop 2drop ] [ conjoin call ] if ; inline
+
+: (each-block) ( basic-block quot -- )
+ '[
+ ,
+ [ call ]
+ [ [ successors>> ] dip '[ , (each-block) ] each ]
+ 2bi
+ ] visit-block ; inline
+
+: each-block ( basic-block quot -- )
+ H{ } clone visited-blocks [ (each-block) ] with-variable ; inline
+
+: copy-at ( from to assoc -- )
+ 3dup nip at* [ -rot set-at drop ] [ 2drop 2drop ] if ; inline
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors namespaces math layouts sequences locals
+combinators compiler.vops compiler.vops.builder
+compiler.cfg.builder ;
+IN: compiler.cfg.elaboration
+
+! This pass must run before conversion to machine IR to ensure
+! correctness.
+
+GENERIC: elaborate* ( insn -- )
+
+: slot-shift ( -- n )
+ tag-bits get cell log2 - ;
+
+:: compute-slot-known-tag ( insn -- addr )
+ { $1 $2 $3 $4 $5 } temps
+ init-intrinsic
+ $1 slot-shift %iconst emit ! load shift offset
+ $2 insn slot>> $1 %shr emit ! shift slot by shift offset
+ $3 insn tag>> %iconst emit ! load tag number
+ $4 $2 $3 %isub emit
+ $5 insn obj>> $4 %iadd emit ! compute slot offset
+ $5
+ ;
+
+:: compute-slot-any-tag ( insn -- addr )
+ { $1 $2 $3 $4 } temps
+ init-intrinsic
+ $1 insn obj>> emit-untag ! untag object
+ $2 slot-shift %iconst emit ! load shift offset
+ $3 insn slot>> $2 %shr emit ! shift slot by shift offset
+ $4 $1 $3 %iadd emit ! compute slot offset
+ $4
+ ;
+
+: compute-slot ( insn -- addr )
+ dup tag>> [ compute-slot-known-tag ] [ compute-slot-any-tag ] if ;
+
+M: %%slot elaborate*
+ [ out>> ] [ compute-slot ] bi %load emit ;
+
+M: %%set-slot elaborate*
+ [ in>> ] [ compute-slot ] bi %store emit ;
+
+M: object elaborate* , ;
+
+: elaboration ( insns -- insns )
+ [ [ elaborate* ] each ] { } make ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: sequences kernel compiler.vops ;
+IN: compiler.cfg.kill-nops
+
+! Smallest compiler pass ever.
+
+: kill-nops ( instructions -- instructions' )
+ [ nop? not ] filter ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel namespaces assocs accessors math.order sequences
+compiler.vops ;
+IN: compiler.cfg.live-ranges
+
+TUPLE: live-range from to ;
+
+! Maps vregs to live ranges
+SYMBOL: live-ranges
+
+: def ( n vreg -- )
+ [ dup live-range boa ] dip live-ranges get set-at ;
+
+: use ( n vreg -- )
+ live-ranges get at [ max ] change-to drop ;
+
+GENERIC: compute-live-ranges* ( n insn -- )
+
+M: nullary-op compute-live-ranges*
+ 2drop ;
+
+M: flushable-op compute-live-ranges*
+ out>> def ;
+
+M: effect-op compute-live-ranges*
+ in>> use ;
+
+M: unary-op compute-live-ranges*
+ [ out>> def ] [ in>> use ] 2bi ;
+
+M: binary-op compute-live-ranges*
+ [ call-next-method ] [ in1>> use ] [ in2>> use ] 2tri ;
+
+M: %store compute-live-ranges*
+ [ call-next-method ] [ addr>> use ] 2bi ;
+
+: compute-live-ranges ( insns -- )
+ H{ } clone live-ranges set
+ [ swap compute-live-ranges* ] each-index ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: compiler.cfg kernel accessors sequences ;
+IN: compiler.cfg.predecessors
+
+! Pass to compute precedecessors.
+
+: compute-predecessors ( procedure -- )
+ [
+ dup successors>>
+ [ predecessors>> push ] with each
+ ] each-block ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors sequences kernel
+compiler.cfg
+compiler.cfg.predecessors
+compiler.cfg.stack
+compiler.cfg.alias
+compiler.cfg.write-barrier
+compiler.cfg.elaboration
+compiler.cfg.vn
+compiler.cfg.vn.conditions
+compiler.cfg.kill-nops ;
+IN: compiler.cfg.simplifier
+
+: simplify ( insns -- insns' )
+ normalize-height
+ alias-analysis
+ elaboration
+ value-numbering
+ eliminate-write-barrier
+ kill-nops ;
+
+: simplify-cfg ( procedure -- procedure )
+ dup compute-predecessors
+ dup [ [ simplify ] change-instructions drop ] each-block ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors math namespaces sequences kernel fry
+compiler.vops ;
+IN: compiler.cfg.stack
+
+! Combine multiple stack height changes into one, done at the
+! start of the basic block.
+!
+! Alias analysis and value numbering assume this optimization
+! has been performed.
+
+! Current data and retain stack height is stored in
+! %data, %retain variables.
+GENERIC: compute-heights ( insn -- )
+
+M: %height compute-heights
+ [ n>> ] [ stack>> ] bi [ + ] change ;
+
+M: object compute-heights drop ;
+
+GENERIC: normalize-height* ( insn -- insn )
+
+M: %height normalize-height*
+ [ n>> ] [ stack>> ] bi [ swap - ] change nop ;
+
+: (normalize-height) ( insn -- insn )
+ dup stack>> get '[ , + ] change-n ; inline
+
+M: %peek normalize-height* (normalize-height) ;
+
+M: %replace normalize-height* (normalize-height) ;
+
+M: object normalize-height* ;
+
+: normalize-height ( insns -- insns' )
+ 0 %data set
+ 0 %retain set
+ [ [ compute-heights ] each ]
+ [ [ [ normalize-height* ] map ] with-scope ] bi
+ %data get dup zero? [ drop ] [ %data %height boa prefix ] if
+ %retain get dup zero? [ drop ] [ %retain %height boa prefix ] if ;
--- /dev/null
+Low-level optimizer operating on control flow graph SSA IR
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences layouts accessors compiler.vops
+compiler.cfg.vn.graph
+compiler.cfg.vn.expressions
+compiler.cfg.vn.liveness
+compiler.cfg.vn ;
+IN: compiler.cfg.vn.conditions
+
+! The CFG generator produces naive code for the following code
+! sequence:
+!
+! fixnum< [ ... ] [ ... ] if
+!
+! The fixnum< comparison generates a boolean, which is then
+! tested against f.
+!
+! Using value numbering, we optimize the comparison of a boolean
+! against f where the boolean is the result of comparison.
+
+: expr-f? ( expr -- ? )
+ dup op>> %iconst eq?
+ [ value>> \ f tag-number = ] [ drop f ] if ;
+
+: comparison-with-f? ( insn -- expr/f ? )
+ #! The expr is a binary-op %icmp or %fcmp.
+ dup code>> cc/= eq? [
+ in>> vreg>vn vn>expr dup in2>> vn>expr expr-f?
+ ] [ drop f f ] if ;
+
+: of-boolean? ( expr -- expr/f ? )
+ #! The expr is a binary-op %icmp or %fcmp.
+ in1>> vn>expr dup op>> { %%iboolean %%fboolean } memq? ;
+
+: original-comparison ( expr -- in/f code/f )
+ [ in>> vn>vreg ] [ code>> ] bi ;
+
+: eliminate-boolean ( insn -- in/f code/f )
+ comparison-with-f? [
+ of-boolean? [
+ original-comparison
+ ] [ drop f f ] if
+ ] [ drop f f ] if ;
+
+M: cond-branch make-value-node
+ #! If the conditional branch is testing the result of an
+ #! earlier comparison against f, we only mark as live the
+ #! earlier comparison, so DCE will eliminate the boolean.
+ dup eliminate-boolean drop swap in>> or live-vreg ;
+
+M: cond-branch eliminate
+ dup eliminate-boolean dup
+ [ [ >>in ] [ >>code ] bi* ] [ 2drop ] if ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel compiler.vops compiler.cfg.vn.graph
+compiler.cfg.vn.expressions ;
+IN: compiler.cfg.vn.constant-fold
+
+GENERIC: constant-fold ( insn -- insn' )
+
+M: vop constant-fold ;
+
+: expr>insn ( out constant-expr -- constant-op )
+ [ value>> ] [ op>> ] bi new swap >>value swap >>out ;
+
+M: pure-op constant-fold
+ dup out>>
+ dup vreg>vn vn>expr
+ dup constant-expr? [ expr>insn nip ] [ 2drop ] if ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors classes kernel math namespaces sorting
+compiler.vops compiler.cfg.vn.graph ;
+IN: compiler.cfg.vn.expressions
+
+! Referentially-transparent expressions
+TUPLE: expr op ;
+TUPLE: nullary-expr < expr ;
+TUPLE: unary-expr < expr in ;
+TUPLE: binary-expr < expr in1 in2 ;
+TUPLE: commutative-expr < binary-expr ;
+TUPLE: boolean-expr < unary-expr code ;
+TUPLE: constant-expr < expr value ;
+TUPLE: literal-expr < unary-expr object ;
+
+! op is always %peek
+TUPLE: peek-expr < expr loc ;
+
+SYMBOL: input-expr-counter
+
+: next-input-expr ( -- n )
+ input-expr-counter [ dup 1 + ] change ;
+
+! Expressions whose values are inputs to the basic block. We
+! can eliminate a second computation having the same 'n' as
+! the first one; we can also eliminate input-exprs whose
+! result is not used.
+TUPLE: input-expr < expr n ;
+
+GENERIC: >expr ( insn -- expr )
+
+M: %literal-table >expr
+ class nullary-expr boa ;
+
+M: constant-op >expr
+ [ class ] [ value>> ] bi constant-expr boa ;
+
+M: %literal >expr
+ [ class ] [ in>> vreg>vn ] [ object>> ] tri literal-expr boa ;
+
+M: unary-op >expr
+ [ class ] [ in>> vreg>vn ] bi unary-expr boa ;
+
+M: binary-op >expr
+ [ class ] [ in1>> vreg>vn ] [ in2>> vreg>vn ] tri
+ binary-expr boa ;
+
+M: commutative-op >expr
+ [ class ] [ in1>> vreg>vn ] [ in2>> vreg>vn ] tri
+ sort-pair commutative-expr boa ;
+
+M: boolean-op >expr
+ [ class ] [ in>> vreg>vn ] [ code>> ] tri
+ boolean-expr boa ;
+
+M: %peek >expr
+ [ class ] [ stack-loc ] bi peek-expr boa ;
+
+M: flushable-op >expr
+ class next-input-expr input-expr boa ;
+
+: init-expressions ( -- )
+ 0 input-expr-counter set ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math namespaces assocs biassocs accessors
+math.order prettyprint.backend parser ;
+IN: compiler.cfg.vn.graph
+
+TUPLE: vn n ;
+
+SYMBOL: vn-counter
+
+: next-vn ( -- vn ) vn-counter [ dup 1 + ] change vn boa ;
+
+: VN: scan-word vn boa parsed ; parsing
+
+M: vn <=> [ n>> ] compare ;
+
+M: vn pprint* \ VN: pprint-word n>> pprint* ;
+
+! biassoc mapping expressions to value numbers
+SYMBOL: exprs>vns
+
+: expr>vn ( expr -- vn ) exprs>vns get [ drop next-vn ] cache ;
+
+: vn>expr ( vn -- expr ) exprs>vns get value-at ;
+
+SYMBOL: vregs>vns
+
+: vreg>vn ( vreg -- vn ) vregs>vns get at ;
+
+: vn>vreg ( vn -- vreg ) vregs>vns get value-at ;
+
+: set-vn ( vn vreg -- ) vregs>vns get set-at ;
+
+: init-value-graph ( -- )
+ 0 vn-counter set
+ <bihash> exprs>vns set
+ <bihash> vregs>vns set ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: namespaces kernel assocs sets accessors compiler.vops
+compiler.cfg.vn.graph compiler.cfg.vn.expressions ;
+IN: compiler.cfg.vn.liveness
+
+! A set of VNs which are (transitively) used by effect-ops. This
+! is precisely the set of VNs whose value is needed outside of
+! the basic block.
+SYMBOL: live-vns
+
+GENERIC: live-expr ( expr -- )
+
+: live-vn ( vn -- )
+ #! Mark a VN and all VNs used in its computation as live.
+ dup live-vns get key? [ drop ] [
+ [ live-vns get conjoin ] [ vn>expr live-expr ] bi
+ ] if ;
+
+: live-vreg ( vreg -- ) vreg>vn live-vn ;
+
+M: expr live-expr drop ;
+M: literal-expr live-expr in>> live-vn ;
+M: unary-expr live-expr in>> live-vn ;
+M: binary-expr live-expr [ in1>> live-vn ] [ in2>> live-vn ] bi ;
+
+: live? ( vreg -- ? )
+ dup vreg>vn tuck vn>vreg =
+ [ live-vns get key? ] [ drop f ] if ;
+
+: init-liveness ( -- )
+ H{ } clone live-vns set ;
+
+GENERIC: eliminate ( insn -- insn' )
+
+M: flushable-op eliminate dup out>> live? ?nop ;
+M: vop eliminate ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: namespaces assocs sequences kernel accessors
+compiler.vops
+compiler.cfg.vn.graph ;
+IN: compiler.cfg.vn.propagate
+
+! If two vregs compute the same value, replace references to
+! the latter with the former.
+
+: resolve ( vreg -- vreg' ) vreg>vn vn>vreg ;
+
+GENERIC: propogate ( insn -- insn )
+
+M: effect-op propogate
+ [ resolve ] change-in ;
+
+M: unary-op propogate
+ [ resolve ] change-in ;
+
+M: binary-op propogate
+ [ resolve ] change-in1
+ [ resolve ] change-in2 ;
+
+M: %phi propogate
+ [ [ resolve ] map ] change-in ;
+
+M: %%slot propogate
+ [ resolve ] change-obj
+ [ resolve ] change-slot ;
+
+M: %%set-slot propogate
+ call-next-method
+ [ resolve ] change-obj
+ [ resolve ] change-slot ;
+
+M: %store propogate
+ call-next-method
+ [ resolve ] change-addr ;
+
+M: nullary-op propogate ;
+
+M: flushable-op propogate ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors combinators classes math math.order
+layouts locals
+compiler.vops
+compiler.cfg.vn.graph
+compiler.cfg.vn.expressions ;
+IN: compiler.cfg.vn.simplify
+
+! Return value of f means we didn't simplify.
+GENERIC: simplify* ( expr -- vn/expr/f )
+
+: constant ( val type -- expr ) swap constant-expr boa ;
+
+: simplify-not ( in -- vn/expr/f )
+ {
+ { [ dup constant-expr? ] [ value>> bitnot %iconst constant ] }
+ { [ dup op>> %not = ] [ in>> ] }
+ [ drop f ]
+ } cond ;
+
+: simplify-box-float ( in -- vn/expr/f )
+ {
+ { [ dup op>> %%unbox-float = ] [ in>> ] }
+ [ drop f ]
+ } cond ;
+
+: simplify-unbox-float ( in -- vn/expr/f )
+ {
+ { [ dup literal-expr? ] [ object>> %fconst constant ] }
+ { [ dup op>> %%box-float = ] [ in>> ] }
+ [ drop f ]
+ } cond ;
+
+M: unary-expr simplify*
+ #! Note the copy propagation: a %copy always simplifies to
+ #! its source vn.
+ [ in>> vn>expr ] [ op>> ] bi {
+ { %copy [ ] }
+ { %not [ simplify-not ] }
+ { %%box-float [ simplify-box-float ] }
+ { %%unbox-float [ simplify-unbox-float ] }
+ [ 2drop f ]
+ } case ;
+
+: izero? ( expr -- ? ) T{ constant-expr f %iconst 0 } = ;
+
+: ione? ( expr -- ? ) T{ constant-expr f %iconst 1 } = ;
+
+: ineg-one? ( expr -- ? ) T{ constant-expr f %iconst -1 } = ;
+
+: fzero? ( expr -- ? ) T{ constant-expr f %fconst 0 } = ;
+
+: fone? ( expr -- ? ) T{ constant-expr f %fconst 1 } = ;
+
+: fneg-one? ( expr -- ? ) T{ constant-expr f %fconst -1 } = ;
+
+: identity ( in1 in2 val type -- expr ) constant 2nip ;
+
+: constant-fold? ( in1 in2 -- ? )
+ [ constant-expr? ] both? ;
+
+:: constant-fold ( in1 in2 quot type -- expr )
+ in1 in2 constant-fold?
+ [ in1 value>> in2 value>> quot call type constant ]
+ [ f ]
+ if ; inline
+
+: simplify-iadd ( in1 in2 -- vn/expr/f )
+ {
+ { [ over izero? ] [ nip ] }
+ { [ dup izero? ] [ drop ] }
+ [ [ + ] %iconst constant-fold ]
+ } cond ;
+
+: simplify-imul ( in1 in2 -- vn/expr/f )
+ {
+ { [ over ione? ] [ nip ] }
+ { [ dup ione? ] [ drop ] }
+ [ [ * ] %iconst constant-fold ]
+ } cond ;
+
+: simplify-and ( in1 in2 -- vn/expr/f )
+ {
+ { [ dup izero? ] [ 0 %iconst identity ] }
+ { [ dup ineg-one? ] [ drop ] }
+ { [ 2dup = ] [ drop ] }
+ [ [ bitand ] %iconst constant-fold ]
+ } cond ;
+
+: simplify-or ( in1 in2 -- vn/expr/f )
+ {
+ { [ dup izero? ] [ drop ] }
+ { [ dup ineg-one? ] [ -1 %iconst identity ] }
+ { [ 2dup = ] [ drop ] }
+ [ [ bitor ] %iconst constant-fold ]
+ } cond ;
+
+: simplify-xor ( in1 in2 -- vn/expr/f )
+ {
+ { [ dup izero? ] [ drop ] }
+ [ [ bitxor ] %iconst constant-fold ]
+ } cond ;
+
+: simplify-fadd ( in1 in2 -- vn/expr/f )
+ {
+ { [ over fzero? ] [ nip ] }
+ { [ dup fzero? ] [ drop ] }
+ [ [ + ] %fconst constant-fold ]
+ } cond ;
+
+: simplify-fmul ( in1 in2 -- vn/expr/f )
+ {
+ { [ over fone? ] [ nip ] }
+ { [ dup fone? ] [ drop ] }
+ [ [ * ] %fconst constant-fold ]
+ } cond ;
+
+: commutative-operands ( expr -- in1 in2 )
+ [ in1>> vn>expr ] [ in2>> vn>expr ] bi
+ over constant-expr? [ swap ] when ;
+
+M: commutative-expr simplify*
+ [ commutative-operands ] [ op>> ] bi {
+ { %iadd [ simplify-iadd ] }
+ { %imul [ simplify-imul ] }
+ { %and [ simplify-and ] }
+ { %or [ simplify-or ] }
+ { %xor [ simplify-xor ] }
+ { %fadd [ simplify-fadd ] }
+ { %fmul [ simplify-fmul ] }
+ [ 3drop f ]
+ } case ;
+
+: simplify-isub ( in1 in2 -- vn/expr/f )
+ {
+ { [ dup izero? ] [ drop ] }
+ { [ 2dup = ] [ 0 %iconst identity ] }
+ [ [ - ] %iconst constant-fold ]
+ } cond ;
+
+: simplify-idiv ( in1 in2 -- vn/expr/f )
+ {
+ { [ dup ione? ] [ drop ] }
+ [ [ /i ] %iconst constant-fold ]
+ } cond ;
+
+: simplify-imod ( in1 in2 -- vn/expr/f )
+ {
+ { [ dup ione? ] [ 0 %iconst identity ] }
+ { [ 2dup = ] [ 0 %iconst identity ] }
+ [ [ mod ] %iconst constant-fold ]
+ } cond ;
+
+: simplify-shl ( in1 in2 -- vn/expr/f )
+ {
+ { [ dup izero? ] [ drop ] }
+ { [ over izero? ] [ drop ] }
+ [ [ shift ] %iconst constant-fold ]
+ } cond ;
+
+: unsigned ( n -- n' )
+ cell-bits 2^ 1- bitand ;
+
+: useless-shift? ( in1 in2 -- ? )
+ over op>> %shl = [ [ in2>> ] [ expr>vn ] bi* = ] [ 2drop f ] if ;
+
+: simplify-shr ( in1 in2 -- vn/expr/f )
+ {
+ { [ dup izero? ] [ drop ] }
+ { [ over izero? ] [ drop ] }
+ { [ 2dup useless-shift? ] [ drop in1>> ] }
+ [ [ neg shift unsigned ] %iconst constant-fold ]
+ } cond ;
+
+: simplify-sar ( in1 in2 -- vn/expr/f )
+ {
+ { [ dup izero? ] [ drop ] }
+ { [ over izero? ] [ drop ] }
+ { [ 2dup useless-shift? ] [ drop in1>> ] }
+ [ [ neg shift ] %iconst constant-fold ]
+ } cond ;
+
+: simplify-icmp ( in1 in2 -- vn/expr/f )
+ = [ +eq+ %cconst constant ] [ f ] if ;
+
+: simplify-fsub ( in1 in2 -- vn/expr/f )
+ {
+ { [ dup izero? ] [ drop ] }
+ [ [ - ] %fconst constant-fold ]
+ } cond ;
+
+: simplify-fdiv ( in1 in2 -- vn/expr/f )
+ {
+ { [ dup fone? ] [ drop ] }
+ [ [ /i ] %fconst constant-fold ]
+ } cond ;
+
+M: binary-expr simplify*
+ [ in1>> vn>expr ] [ in2>> vn>expr ] [ op>> ] tri {
+ { %isub [ simplify-isub ] }
+ { %idiv [ simplify-idiv ] }
+ { %imod [ simplify-imod ] }
+ { %shl [ simplify-shl ] }
+ { %shr [ simplify-shr ] }
+ { %sar [ simplify-sar ] }
+ { %icmp [ simplify-icmp ] }
+ { %fsub [ simplify-fsub ] }
+ { %fdiv [ simplify-fdiv ] }
+ [ 3drop f ]
+ } case ;
+
+M: expr simplify* drop f ;
+
+: simplify ( expr -- vn )
+ dup simplify* {
+ { [ dup not ] [ drop expr>vn ] }
+ { [ dup expr? ] [ expr>vn nip ] }
+ { [ dup vn? ] [ nip ] }
+ } cond ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: namespaces assocs biassocs classes kernel math accessors
+sorting sets sequences compiler.vops
+compiler.cfg.vn.graph
+compiler.cfg.vn.expressions
+compiler.cfg.vn.simplify
+compiler.cfg.vn.liveness
+compiler.cfg.vn.constant-fold
+compiler.cfg.vn.propagate ;
+IN: compiler.cfg.vn
+
+: insn>vn ( insn -- vn ) >expr simplify ; inline
+
+GENERIC: make-value-node ( insn -- )
+M: flushable-op make-value-node [ insn>vn ] [ out>> ] bi set-vn ;
+M: effect-op make-value-node in>> live-vreg ;
+M: %store make-value-node [ in>> live-vreg ] [ addr>> live-vreg ] bi ;
+M: %%set-slot make-value-node [ in>> live-vreg ] [ obj>> live-vreg ] bi ;
+M: nullary-op make-value-node drop ;
+
+: init-value-numbering ( -- )
+ init-value-graph
+ init-expressions
+ init-liveness ;
+
+: value-numbering ( instructions -- instructions )
+ init-value-numbering
+ [ [ make-value-node ] each ]
+ [ [ eliminate constant-fold propogate ] map ]
+ bi ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors namespaces assocs sets sequences
+compiler.vops compiler.cfg ;
+IN: compiler.cfg.write-barrier
+
+! Eliminate redundant write barrier hits.
+SYMBOL: hits
+
+GENERIC: eliminate-write-barrier* ( insn -- insn' )
+
+M: %%allot eliminate-write-barrier*
+ dup out>> hits get conjoin ;
+
+M: %write-barrier eliminate-write-barrier*
+ dup in>> hits get key?
+ [ drop nop ] [ dup in>> hits get conjoin ] if ;
+
+M: %copy eliminate-write-barrier*
+ dup in/out hits get copy-at ;
+
+M: vop eliminate-write-barrier* ;
+
+: eliminate-write-barrier ( insns -- insns )
+ H{ } clone hits set
+ [ eliminate-write-barrier* ] map ;
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math namespaces assocs hashtables sequences
-accessors vectors combinators sets compiler.vops compiler.cfg ;
-IN: compiler.cfg.alias
-
-! Alias analysis -- must be run after compiler.cfg.stack.
-!
-! We try to eliminate redundant slot and stack
-! traffic using some simple heuristics.
-!
-! All heap-allocated objects which are loaded from the stack, or
-! other object slots are pessimistically assumed to belong to
-! the same alias class.
-!
-! Freshly-allocated objects get their own alias class.
-!
-! The data and retain stack pointer registers are treated
-! uniformly, and each one gets its own alias class.
-!
-! Simple pseudo-C example showing load elimination:
-!
-! int *x, *y, z: inputs
-! int a, b, c, d, e: locals
-!
-! Before alias analysis:
-!
-! a = x[2]
-! b = x[2]
-! c = x[3]
-! y[2] = z
-! d = x[2]
-! e = y[2]
-! f = x[3]
-!
-! After alias analysis:
-!
-! a = x[2]
-! b = a /* ELIMINATED */
-! c = x[3]
-! y[2] = z
-! d = x[2] /* if x=y, d=z, if x!=y, d=b; NOT ELIMINATED */
-! e = z /* ELIMINATED */
-! f = c /* ELIMINATED */
-!
-! Simple pseudo-C example showing store elimination:
-!
-! Before alias analysis:
-!
-! x[0] = a
-! b = x[n]
-! x[0] = c
-! x[1] = d
-! e = x[0]
-! x[1] = c
-!
-! After alias analysis:
-!
-! x[0] = a /* dead if n = 0, live otherwise; NOT ELIMINATED */
-! b = x[n]
-! x[0] = c
-! /* x[1] = d */ /* ELIMINATED */
-! e = c
-! x[1] = c
-
-! Map vregs -> alias classes
-SYMBOL: vregs>acs
-
-: check [ "BUG: static type error detected" throw ] unless* ; inline
-
-: vreg>ac ( vreg -- ac )
- #! Only vregs produced by %%allot, %peek and %%slot can
- #! ever be used as valid inputs to %%slot and %%set-slot,
- #! so we assert this fact by not giving alias classes to
- #! other vregs.
- vregs>acs get at check ;
-
-! Map alias classes -> sequence of vregs
-SYMBOL: acs>vregs
-
-: ac>vregs ( ac -- vregs ) acs>vregs get at ;
-
-: aliases ( vreg -- vregs )
- #! All vregs which may contain the same value as vreg.
- vreg>ac ac>vregs ;
-
-: each-alias ( vreg quot -- )
- [ aliases ] dip each ; inline
-
-! Map vregs -> slot# -> vreg
-SYMBOL: live-slots
-
-! Current instruction number
-SYMBOL: insn#
-
-! Load/store history, for dead store elimination
-TUPLE: load insn# ;
-TUPLE: store insn# ;
-
-: new-action ( class -- action )
- insn# get swap boa ; inline
-
-! Maps vreg -> slot# -> sequence of loads/stores
-SYMBOL: histories
-
-: history ( vreg -- history ) histories get at ;
-
-: set-ac ( vreg ac -- )
- #! Set alias class of newly-seen vreg.
- {
- [ drop H{ } clone swap histories get set-at ]
- [ drop H{ } clone swap live-slots get set-at ]
- [ swap vregs>acs get set-at ]
- [ acs>vregs get push-at ]
- } 2cleave ;
-
-: live-slot ( slot#/f vreg -- vreg' )
- #! If the slot number is unknown, we never reuse a previous
- #! value.
- over [ live-slots get at at ] [ 2drop f ] if ;
-
-: load-constant-slot ( value slot# vreg -- )
- live-slots get at check set-at ;
-
-: load-slot ( value slot#/f vreg -- )
- over [ load-constant-slot ] [ 3drop ] if ;
-
-: record-constant-slot ( slot# vreg -- )
- #! A load can potentially read every store of this slot#
- #! in that alias class.
- [
- history [ load new-action swap ?push ] change-at
- ] with each-alias ;
-
-: record-computed-slot ( vreg -- )
- #! Computed load is like a load of every slot touched so far
- [
- history values [ load new-action swap push ] each
- ] each-alias ;
-
-: remember-slot ( value slot#/f vreg -- )
- over
- [ [ record-constant-slot ] [ load-constant-slot ] 2bi ]
- [ 2nip record-computed-slot ] if ;
-
-SYMBOL: ac-counter
-
-: next-ac ( -- n )
- ac-counter [ dup 1+ ] change ;
-
-! Alias class for objects which are loaded from the data stack
-! or other object slots. We pessimistically assume that they
-! can all alias each other.
-SYMBOL: heap-ac
-
-: set-heap-ac ( vreg -- ) heap-ac get set-ac ;
-
-: set-new-ac ( vreg -- ) next-ac set-ac ;
-
-: kill-constant-set-slot ( slot# vreg -- )
- [ live-slots get at delete-at ] with each-alias ;
-
-: record-constant-set-slot ( slot# vreg -- )
- history [
- dup empty? [ dup peek store? [ dup pop* ] when ] unless
- store new-action swap ?push
- ] change-at ;
-
-: kill-computed-set-slot ( ac -- )
- [ live-slots get at clear-assoc ] each-alias ;
-
-: remember-set-slot ( slot#/f vreg -- )
- over [
- [ record-constant-set-slot ]
- [ kill-constant-set-slot ] 2bi
- ] [ nip kill-computed-set-slot ] if ;
-
-SYMBOL: copies
-
-: resolve ( vreg -- vreg )
- dup copies get at swap or ;
-
-SYMBOL: constants
-
-: constant ( vreg -- n/f )
- #! Return an %iconst value, or f if the vreg was not
- #! assigned by an %iconst.
- resolve constants get at ;
-
-! We treat slot accessors and stack traffic alike
-GENERIC: insn-slot# ( insn -- slot#/f )
-GENERIC: insn-object ( insn -- vreg )
-
-M: %peek insn-slot# n>> ;
-M: %replace insn-slot# n>> ;
-M: %%slot insn-slot# slot>> constant ;
-M: %%set-slot insn-slot# slot>> constant ;
-
-M: %peek insn-object stack>> ;
-M: %replace insn-object stack>> ;
-M: %%slot insn-object obj>> resolve ;
-M: %%set-slot insn-object obj>> resolve ;
-
-: init-alias-analysis ( -- )
- H{ } clone histories set
- H{ } clone vregs>acs set
- H{ } clone acs>vregs set
- H{ } clone live-slots set
- H{ } clone constants set
- H{ } clone copies set
-
- 0 ac-counter set
- next-ac heap-ac set
-
- %data next-ac set-ac
- %retain next-ac set-ac ;
-
-GENERIC: analyze-aliases ( insn -- insn' )
-
-M: %iconst analyze-aliases
- dup [ value>> ] [ out>> ] bi constants get set-at ;
-
-M: %%allot analyze-aliases
- #! A freshly allocated object is distinct from any other
- #! object.
- dup out>> set-new-ac ;
-
-M: read-op analyze-aliases
- dup out>> set-heap-ac
- dup [ out>> ] [ insn-slot# ] [ insn-object ] tri
- 2dup live-slot dup [
- 2nip %copy boa analyze-aliases nip
- ] [
- drop remember-slot
- ] if ;
-
-: idempotent? ( value slot#/f vreg -- ? )
- #! Are we storing a value back to the same slot it was read
- #! from?
- live-slot = ;
-
-M: write-op analyze-aliases
- dup
- [ in>> resolve ] [ insn-slot# ] [ insn-object ] tri
- 3dup idempotent? [
- 2drop 2drop nop
- ] [
- [ remember-set-slot drop ] [ load-slot ] 3bi
- ] if ;
-
-M: %copy analyze-aliases
- #! The output vreg gets the same alias class as the input
- #! vreg, since they both contain the same value.
- dup [ in>> resolve ] [ out>> ] bi copies get set-at ;
-
-M: vop analyze-aliases ;
-
-SYMBOL: live-stores
-
-: compute-live-stores ( -- )
- histories get
- values [
- values [ [ store? ] filter [ insn#>> ] map ] map concat
- ] map concat unique
- live-stores set ;
-
-GENERIC: eliminate-dead-store ( insn -- insn' )
-
-: (eliminate-dead-store) ( insn -- insn' )
- dup insn-slot# [
- insn# get live-stores get key? [
- drop nop
- ] unless
- ] when ;
-
-M: %replace eliminate-dead-store
- #! Writes to above the top of the stack can be pruned also.
- #! This is sound since any such writes are not observable
- #! after the basic block, and any reads of those locations
- #! will have been converted to copies by analyze-slot,
- #! and the final stack height of the basic block is set at
- #! the beginning by compiler.cfg.stack.
- dup n>> 0 < [ drop nop ] [ (eliminate-dead-store) ] if ;
-
-M: %%set-slot eliminate-dead-store (eliminate-dead-store) ;
-
-M: vop eliminate-dead-store ;
-
-: alias-analysis ( insns -- insns' )
- init-alias-analysis
- [ insn# set analyze-aliases ] map-index
- compute-live-stores
- [ insn# set eliminate-dead-store ] map-index ;
+++ /dev/null
-Slava Pestov
--- /dev/null
+Slava Pestov
IN: compiler.cfg.builder.tests
-USING: compiler.cfg.builder tools.test ;
+USING: compiler.cfg.builder tools.test kernel sequences
+math.private compiler.tree.builder compiler.tree.optimizer
+words sequences.private fry prettyprint alien ;
-\ build-cfg must-infer
+! Just ensure that various CFGs build correctly.
+: test-cfg ( quot -- result )
+ build-tree optimize-tree gensym gensym build-cfg ;
+
+{
+ [ ]
+ [ dup ]
+ [ swap ]
+ [ >r r> ]
+ [ fixnum+ ]
+ [ fixnum< ]
+ [ [ 1 ] [ 2 ] if ]
+ [ fixnum< [ 1 ] [ 2 ] if ]
+ [ float+ [ 2.0 float* ] [ 3.0 float* ] bi float/f ]
+ [ { [ 1 ] [ 2 ] [ 3 ] } dispatch ]
+ [ [ t ] loop ]
+ [ [ dup ] loop ]
+ [ [ 2 ] [ 3 throw ] if 4 ]
+ [ "int" f "malloc" { "int" } alien-invoke ]
+ [ "int" { "int" } "cdecl" alien-indirect ]
+ [ "int" { "int" } "cdecl" [ ] alien-callback ]
+} [
+ '[ _ test-cfg drop ] [ ] swap unit-test
+] each
+
+: test-word-cfg ( word -- result )
+ [ build-tree-from-word nip optimize-tree ] keep dup
+ build-cfg ;
+
+: test-1 ( -- ) test-1 ;
+: test-2 ( -- ) 3 . test-2 ;
+: test-3 ( a -- b ) dup [ test-3 ] when ;
+
+{
+ test-1
+ test-2
+ test-3
+} [
+ '[ _ test-word-cfg drop ] [ ] swap unit-test
+] each
-! Copyright (C) 2008 Slava Pestov.
+ ! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel assocs sequences sequences.lib fry accessors
-namespaces math combinators math.order
+USING: accessors arrays assocs combinators hashtables kernel
+math fry namespaces make sequences words stack-checker.inlining
compiler.tree
+compiler.tree.builder
compiler.tree.combinators
compiler.tree.propagation.info
compiler.cfg
-compiler.vops
-compiler.vops.builder ;
+compiler.cfg.stacks
+compiler.cfg.templates
+compiler.cfg.iterator
+compiler.alien
+compiler.instructions
+compiler.registers ;
IN: compiler.cfg.builder
-! Convert tree SSA IR to CFG SSA IR.
-
-! We construct the graph and set successors first, then we
-! set predecessors in a separate pass. This simplifies the
-! logic.
-
-SYMBOL: procedures
-
-SYMBOL: loop-nesting
-
-SYMBOL: values>vregs
-
-GENERIC: convert ( node -- )
-
-M: #introduce convert drop ;
-
-: init-builder ( -- )
- H{ } clone values>vregs set ;
-
-: end-basic-block ( -- )
- basic-block get [ %b emit ] when ;
+! Convert tree SSA IR to CFG (not quite SSA yet) IR.
: set-basic-block ( basic-block -- )
[ basic-block set ] [ instructions>> building set ] bi ;
: begin-basic-block ( -- )
- <basic-block> basic-block get
- [
- end-basic-block
+ <basic-block> basic-block get [
dupd successors>> push
] when*
set-basic-block ;
-: convert-nodes ( node -- )
- [ convert ] each ;
+: end-basic-block ( -- )
+ building off
+ basic-block off ;
-: (build-cfg) ( node word -- )
- init-builder
- begin-basic-block
- basic-block get swap procedures get set-at
- convert-nodes ;
+USE: qualified
+FROM: compiler.generator.registers => +input+ ;
+FROM: compiler.generator.registers => +output+ ;
+FROM: compiler.generator.registers => +scratch+ ;
+FROM: compiler.generator.registers => +clobber+ ;
-: build-cfg ( node word -- procedures )
- H{ } clone [
- procedures [ (build-cfg) ] with-variable
- ] keep ;
+SYMBOL: procedures
-: value>vreg ( value -- vreg )
- values>vregs get at ;
+SYMBOL: current-word
-: output-vreg ( value vreg -- )
- swap values>vregs get set-at ;
+SYMBOL: current-label
-: produce-vreg ( value -- vreg )
- next-vreg [ output-vreg ] keep ;
+SYMBOL: loops
-: (load-inputs) ( seq stack -- )
- over empty? [ 2drop ] [
- [ <reversed> ] dip
- [ '[ produce-vreg _ , %peek emit ] each-index ]
- [ [ length neg ] dip %height emit ]
- 2bi
- ] if ;
+! Basic block after prologue, makes recursion faster
+SYMBOL: current-label-start
-: load-in-d ( node -- ) in-d>> %data (load-inputs) ;
+: add-procedure ( -- )
+ basic-block get current-word get current-label get
+ <procedure> procedures get push ;
-: load-in-r ( node -- ) in-r>> %retain (load-inputs) ;
+: begin-procedure ( word label -- )
+ end-basic-block
+ begin-basic-block
+ H{ } clone loops set
+ current-label set
+ current-word set
+ add-procedure ;
-: (store-outputs) ( seq stack -- )
- over empty? [ 2drop ] [
- [ <reversed> ] dip
- [ [ length ] dip %height emit ]
- [ '[ value>vreg _ , %replace emit ] each-index ]
- 2bi
- ] if ;
+: with-cfg-builder ( nodes word label quot -- )
+ '[ begin-procedure @ ] with-scope ; inline
-: store-out-d ( node -- ) out-d>> %data (store-outputs) ;
+GENERIC: emit-node ( node -- next )
-: store-out-r ( node -- ) out-r>> %retain (store-outputs) ;
+: check-basic-block ( node -- node' )
+ basic-block get [ drop f ] unless ; inline
-: (emit-call) ( word -- )
- begin-basic-block %call emit begin-basic-block ;
+: emit-nodes ( nodes -- )
+ [ current-node emit-node check-basic-block ] iterate-nodes
+ finalize-phantoms ;
-: intrinsic-inputs ( node -- )
- [ load-in-d ]
- [ in-d>> { #1 #2 #3 #4 } [ [ value>vreg ] dip set ] 2each ]
- bi ;
+: remember-loop ( label -- )
+ basic-block get swap loops get set-at ;
-: intrinsic-outputs ( node -- )
- [ out-d>> { ^1 ^2 ^3 ^4 } [ get output-vreg ] 2each ]
- [ store-out-d ]
- bi ;
+: begin-word ( -- )
+ #! We store the basic block after the prologue as a loop
+ #! labelled by the current word, so that self-recursive
+ #! calls can skip an epilogue/prologue.
+ init-phantoms
+ %prologue
+ %branch
+ begin-basic-block
+ current-label get remember-loop ;
-: intrinsic ( node quot -- )
+: (build-cfg) ( nodes word label -- )
[
- init-intrinsic
+ begin-word
+ [ emit-nodes ] with-node-iterator
+ ] with-cfg-builder ;
+
+: build-cfg ( nodes word label -- procedures )
+ V{ } clone [
+ procedures [
+ (build-cfg)
+ ] with-variable
+ ] keep ;
- [ intrinsic-inputs ]
- swap
- [ intrinsic-outputs ]
- tri
- ] with-scope ; inline
+: if-intrinsics ( #call -- quot )
+ word>> "if-intrinsics" word-prop ;
+
+: local-recursive-call ( basic-block -- )
+ %branch
+ basic-block get successors>> push
+ end-basic-block ;
+
+: emit-call ( word -- next )
+ finalize-phantoms
+ {
+ { [ tail-call? not ] [ 0 %frame-required %call iterate-next ] }
+ { [ dup loops get key? ] [ loops get at local-recursive-call f ] }
+ [ %epilogue %jump f ]
+ } cond ;
+
+! #recursive
+: compile-recursive ( node -- next )
+ [ label>> id>> emit-call ]
+ [ [ child>> ] [ label>> word>> ] [ label>> id>> ] tri (build-cfg) ] bi ;
+
+: compile-loop ( node -- next )
+ finalize-phantoms
+ begin-basic-block
+ [ label>> id>> remember-loop ] [ child>> emit-nodes ] bi
+ iterate-next ;
-USING: kernel.private math.private slots.private ;
+M: #recursive emit-node
+ dup label>> loop?>> [ compile-loop ] [ compile-recursive ] if ;
-: maybe-emit-fixnum-shift-fast ( node -- node )
- dup dup in-d>> second node-value-info literal>> dup fixnum? [
- '[ , emit-fixnum-shift-fast ] intrinsic
- ] [
- drop dup word>> (emit-call)
- ] if ;
+! #if
+: emit-branch ( nodes -- final-bb )
+ [
+ begin-basic-block copy-phantoms
+ emit-nodes
+ basic-block get dup [ %branch ] when
+ ] with-scope ;
-: emit-call ( node -- )
- dup word>> {
- { \ tag [ [ emit-tag ] intrinsic ] }
-
- { \ slot [ [ dup emit-slot ] intrinsic ] }
- { \ set-slot [ [ dup emit-set-slot ] intrinsic ] }
-
- { \ fixnum-bitnot [ [ emit-fixnum-bitnot ] intrinsic ] }
- { \ fixnum+fast [ [ emit-fixnum+fast ] intrinsic ] }
- { \ fixnum-fast [ [ emit-fixnum-fast ] intrinsic ] }
- { \ fixnum-bitand [ [ emit-fixnum-bitand ] intrinsic ] }
- { \ fixnum-bitor [ [ emit-fixnum-bitor ] intrinsic ] }
- { \ fixnum-bitxor [ [ emit-fixnum-bitxor ] intrinsic ] }
- { \ fixnum*fast [ [ emit-fixnum*fast ] intrinsic ] }
- { \ fixnum<= [ [ emit-fixnum<= ] intrinsic ] }
- { \ fixnum>= [ [ emit-fixnum>= ] intrinsic ] }
- { \ fixnum< [ [ emit-fixnum< ] intrinsic ] }
- { \ fixnum> [ [ emit-fixnum> ] intrinsic ] }
- { \ eq? [ [ emit-eq? ] intrinsic ] }
-
- { \ fixnum-shift-fast [ maybe-emit-fixnum-shift-fast ] }
-
- { \ float+ [ [ emit-float+ ] intrinsic ] }
- { \ float- [ [ emit-float- ] intrinsic ] }
- { \ float* [ [ emit-float* ] intrinsic ] }
- { \ float/f [ [ emit-float/f ] intrinsic ] }
- { \ float<= [ [ emit-float<= ] intrinsic ] }
- { \ float>= [ [ emit-float>= ] intrinsic ] }
- { \ float< [ [ emit-float< ] intrinsic ] }
- { \ float> [ [ emit-float> ] intrinsic ] }
- { \ float? [ [ emit-float= ] intrinsic ] }
-
- ! { \ (tuple) [ dup first-input '[ , emit-(tuple) ] intrinsic ] }
- ! { \ (array) [ dup first-input '[ , emit-(array) ] intrinsic ] }
- ! { \ (byte-array) [ dup first-input '[ , emit-(byte-array) ] intrinsic ] }
-
- [ (emit-call) ]
- } case drop ;
-
-M: #call convert emit-call ;
-
-: emit-call-loop ( #recursive -- )
- dup label>> loop-nesting get at basic-block get successors>> push
+: emit-if ( node -- next )
+ children>> [ emit-branch ] map
end-basic-block
- basic-block off
- drop ;
-
-: emit-call-recursive ( #recursive -- )
- label>> id>> (emit-call) ;
+ begin-basic-block
+ basic-block get '[ [ _ swap successors>> push ] when* ] each
+ init-phantoms
+ iterate-next ;
+
+M: #if emit-node
+ { { f "flag" } } lazy-load first %branch-t
+ emit-if ;
+
+! #dispatch
+: dispatch-branch ( nodes word -- label )
+ gensym [
+ [
+ copy-phantoms
+ %prologue
+ [ emit-nodes ] with-node-iterator
+ %epilogue
+ %return
+ ] with-cfg-builder
+ ] keep ;
-M: #call-recursive convert
- dup label>> loop?>>
- [ emit-call-loop ] [ emit-call-recursive ] if ;
+: dispatch-branches ( node -- )
+ children>> [
+ current-word get dispatch-branch
+ %dispatch-label
+ ] each ;
+
+: emit-dispatch ( node -- )
+ %dispatch dispatch-branches init-phantoms ;
+
+M: #dispatch emit-node
+ #! The order here is important, dispatch-branches must
+ #! run after %dispatch, so that each branch gets the
+ #! correct register state
+ tail-call? [
+ emit-dispatch iterate-next
+ ] [
+ current-word get gensym [
+ [
+ begin-word
+ emit-dispatch
+ ] with-cfg-builder
+ ] keep emit-call
+ ] if ;
-M: #push convert
- [
- [ out-d>> first produce-vreg ]
- [ node-output-infos first literal>> ]
- bi emit-literal
- ]
- [ store-out-d ] bi ;
+! #call
+: define-intrinsics ( word intrinsics -- )
+ "intrinsics" set-word-prop ;
-M: #shuffle convert [ load-in-d ] [ store-out-d ] bi ;
+: define-intrinsic ( word quot assoc -- )
+ 2array 1array define-intrinsics ;
-M: #>r convert [ load-in-d ] [ store-out-r ] bi ;
+: define-if-intrinsics ( word intrinsics -- )
+ [ +input+ associate ] assoc-map
+ "if-intrinsics" set-word-prop ;
-M: #r> convert [ load-in-r ] [ store-out-d ] bi ;
+: define-if-intrinsic ( word quot inputs -- )
+ 2array 1array define-if-intrinsics ;
-M: #terminate convert drop ;
+: find-intrinsic ( #call -- pair/f )
+ word>> "intrinsics" word-prop find-template ;
-: integer-conditional ( in1 in2 cc -- )
- [ [ next-vreg dup ] 2dip %icmp emit ] dip %bi emit ; inline
+: find-boolean-intrinsic ( #call -- pair/f )
+ word>> "if-intrinsics" word-prop find-template ;
-: float-conditional ( in1 in2 branch -- )
- [ next-vreg [ %fcmp emit ] keep ] dip emit ; inline
+: find-if-intrinsic ( #call -- pair/f )
+ node@ {
+ { [ dup length 2 < ] [ 2drop f ] }
+ { [ dup second #if? ] [ drop find-boolean-intrinsic ] }
+ [ 2drop f ]
+ } cond ;
-: emit-if ( #if -- )
- in-d>> first value>vreg
- next-vreg dup f emit-literal
- cc/= integer-conditional ;
+: do-if-intrinsic ( pair -- next )
+ [ %if-intrinsic ] apply-template skip-next emit-if ;
-: convert-nested ( node -- last-bb )
+: do-boolean-intrinsic ( pair -- next )
[
- <basic-block>
- [ set-basic-block ] keep
- [ convert-nodes end-basic-block ] dip
- basic-block get
- ] with-scope
- [ basic-block get successors>> push ] dip ;
-
-: convert-if-children ( #if -- )
- children>> [ convert-nested ] map sift
- <basic-block>
- [ '[ , _ successors>> push ] each ]
- [ set-basic-block ]
+ f alloc-vreg [ %boolean-intrinsic ] keep phantom-push
+ ] apply-template iterate-next ;
+
+: do-intrinsic ( pair -- next )
+ [ %intrinsic ] apply-template iterate-next ;
+
+: setup-operand-classes ( #call -- )
+ node-input-infos [ class>> ] map set-operand-classes ;
+
+M: #call emit-node
+ dup setup-operand-classes
+ dup find-if-intrinsic [ do-if-intrinsic ] [
+ dup find-boolean-intrinsic [ do-boolean-intrinsic ] [
+ dup find-intrinsic [ do-intrinsic ] [
+ word>> emit-call
+ ] ?if
+ ] ?if
+ ] ?if ;
+
+! #call-recursive
+M: #call-recursive emit-node label>> id>> emit-call ;
+
+! #push
+M: #push emit-node
+ literal>> <constant> phantom-push iterate-next ;
+
+! #shuffle
+M: #shuffle emit-node
+ shuffle-effect phantom-shuffle iterate-next ;
+
+M: #>r emit-node
+ [ in-d>> length ] [ out-r>> empty? ] bi
+ [ phantom-drop ] [ phantom->r ] if
+ iterate-next ;
+
+M: #r> emit-node
+ [ in-r>> length ] [ out-d>> empty? ] bi
+ [ phantom-rdrop ] [ phantom-r> ] if
+ iterate-next ;
+
+! #return
+M: #return emit-node
+ drop finalize-phantoms %epilogue %return f ;
+
+M: #return-recursive emit-node
+ finalize-phantoms
+ label>> id>> loops get key?
+ [ %epilogue %return ] unless f ;
+
+! #terminate
+M: #terminate emit-node drop end-basic-block f ;
+
+! FFI
+M: #alien-invoke emit-node
+ params>>
+ [ alien-invoke-frame %frame-required ]
+ [ %alien-invoke iterate-next ]
bi ;
-M: #if convert
- [ load-in-d ] [ emit-if ] [ convert-if-children ] tri ;
-
-M: #dispatch convert
- "Unimplemented" throw ;
-
-M: #phi convert drop ;
-
-M: #declare convert drop ;
-
-M: #return convert drop %return emit ;
-
-: convert-recursive ( #recursive -- )
- [ [ label>> id>> ] [ child>> ] bi (build-cfg) ]
- [ (emit-call) ]
+M: #alien-indirect emit-node
+ params>>
+ [ alien-invoke-frame %frame-required ]
+ [ %alien-indirect iterate-next ]
bi ;
-: begin-loop ( #recursive -- )
- label>> basic-block get 2array loop-nesting get push ;
+M: #alien-callback emit-node
+ params>> dup xt>> dup
+ [ init-phantoms %alien-callback ] with-cfg-builder
+ iterate-next ;
-: end-loop ( -- )
- loop-nesting get pop* ;
+! No-op nodes
+M: #introduce emit-node drop iterate-next ;
-: convert-loop ( #recursive -- )
- begin-basic-block
- [ begin-loop ]
- [ child>> convert-nodes ]
- [ drop end-loop ]
- tri ;
+M: #copy emit-node drop iterate-next ;
-M: #recursive convert
- dup label>> loop?>>
- [ convert-loop ] [ convert-recursive ] if ;
+M: #enter-recursive emit-node drop iterate-next ;
-M: #copy convert drop ;
+M: #phi emit-node drop iterate-next ;
--- /dev/null
+Final stage of compilation generates machine code from dataflow IR
USING: kernel accessors namespaces assocs sequences sets fry ;
IN: compiler.cfg
-! The id is a globally unique id used for fast hashcode* and
-! equal? on basic blocks. The number is assigned by
-! linearization.
+TUPLE: procedure entry word label ;
+
+C: <procedure> procedure
+
+! - "id" is a globally unique id used for hashcode*.
+! - "number" is assigned by linearization.
TUPLE: basic-block < identity-tuple
id
number
+label
instructions
successors
-predecessors
-stack-frame ;
+predecessors ;
SYMBOL: next-block-id
: (each-block) ( basic-block quot -- )
'[
- ,
+ _
[ call ]
- [ [ successors>> ] dip '[ , (each-block) ] each ]
+ [ [ successors>> ] dip '[ _ (each-block) ] each ]
2bi
] visit-block ; inline
: each-block ( basic-block quot -- )
H{ } clone visited-blocks [ (each-block) ] with-variable ; inline
-
-: copy-at ( from to assoc -- )
- 3dup nip at* [ -rot set-at drop ] [ 2drop 2drop ] if ; inline
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors namespaces math layouts sequences locals
-combinators compiler.vops compiler.vops.builder
-compiler.cfg.builder ;
-IN: compiler.cfg.elaboration
-
-! This pass must run before conversion to machine IR to ensure
-! correctness.
-
-GENERIC: elaborate* ( insn -- )
-
-: slot-shift ( -- n )
- tag-bits get cell log2 - ;
-
-:: compute-slot-known-tag ( insn -- addr )
- { $1 $2 $3 $4 $5 } temps
- init-intrinsic
- $1 slot-shift %iconst emit ! load shift offset
- $2 insn slot>> $1 %shr emit ! shift slot by shift offset
- $3 insn tag>> %iconst emit ! load tag number
- $4 $2 $3 %isub emit
- $5 insn obj>> $4 %iadd emit ! compute slot offset
- $5
- ;
-
-:: compute-slot-any-tag ( insn -- addr )
- { $1 $2 $3 $4 } temps
- init-intrinsic
- $1 insn obj>> emit-untag ! untag object
- $2 slot-shift %iconst emit ! load shift offset
- $3 insn slot>> $2 %shr emit ! shift slot by shift offset
- $4 $1 $3 %iadd emit ! compute slot offset
- $4
- ;
-
-: compute-slot ( insn -- addr )
- dup tag>> [ compute-slot-known-tag ] [ compute-slot-any-tag ] if ;
-
-M: %%slot elaborate*
- [ out>> ] [ compute-slot ] bi %load emit ;
-
-M: %%set-slot elaborate*
- [ in>> ] [ compute-slot ] bi %store emit ;
-
-M: object elaborate* , ;
-
-: elaboration ( insns -- insns )
- [ [ elaborate* ] each ] { } make ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: namespaces sequences kernel compiler.tree ;
+IN: compiler.cfg.iterator
+
+SYMBOL: node-stack
+
+: >node ( cursor -- ) node-stack get push ;
+: node> ( -- cursor ) node-stack get pop ;
+: node@ ( -- cursor ) node-stack get peek ;
+: current-node ( -- node ) node@ first ;
+: iterate-next ( -- cursor ) node@ rest-slice ;
+: skip-next ( -- next ) node> rest-slice [ first ] [ >node ] bi ;
+
+: iterate-nodes ( cursor quot: ( -- ) -- )
+ over empty? [
+ 2drop
+ ] [
+ [ swap >node call node> drop ] keep iterate-nodes
+ ] if ; inline recursive
+
+: with-node-iterator ( quot -- )
+ >r V{ } clone node-stack r> with-variable ; inline
+
+DEFER: (tail-call?)
+
+: tail-phi? ( cursor -- ? )
+ [ first #phi? ] [ rest-slice (tail-call?) ] bi and ;
+
+: (tail-call?) ( cursor -- ? )
+ [ t ] [
+ [
+ first
+ [ #return? ]
+ [ #return-recursive? ]
+ [ #terminate? ] tri or or
+ ] [ tail-phi? ] bi or
+ ] if-empty ;
+
+: tail-call? ( -- ? )
+ node-stack get [
+ rest-slice
+ [ t ] [
+ [ (tail-call?) ]
+ [ first #terminate? not ]
+ bi and
+ ] if-empty
+ ] all? ;
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: sequences kernel compiler.vops ;
-IN: compiler.cfg.kill-nops
-
-! Smallest compiler pass ever.
-
-: kill-nops ( instructions -- instructions' )
- [ nop? not ] filter ;
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel namespaces assocs accessors math.order sequences
-compiler.vops ;
-IN: compiler.cfg.live-ranges
-
-TUPLE: live-range from to ;
-
-! Maps vregs to live ranges
-SYMBOL: live-ranges
-
-: def ( n vreg -- )
- [ dup live-range boa ] dip live-ranges get set-at ;
-
-: use ( n vreg -- )
- live-ranges get at [ max ] change-to drop ;
-
-GENERIC: compute-live-ranges* ( n insn -- )
-
-M: nullary-op compute-live-ranges*
- 2drop ;
-
-M: flushable-op compute-live-ranges*
- out>> def ;
-
-M: effect-op compute-live-ranges*
- in>> use ;
-
-M: unary-op compute-live-ranges*
- [ out>> def ] [ in>> use ] 2bi ;
-
-M: binary-op compute-live-ranges*
- [ call-next-method ] [ in1>> use ] [ in2>> use ] 2tri ;
-
-M: %store compute-live-ranges*
- [ call-next-method ] [ addr>> use ] 2bi ;
-
-: compute-live-ranges ( insns -- )
- H{ } clone live-ranges set
- [ swap compute-live-ranges* ] each-index ;
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: compiler.cfg kernel accessors sequences ;
-IN: compiler.cfg.predecessors
-
-! Pass to compute precedecessors.
-
-: compute-predecessors ( procedure -- )
- [
- dup successors>>
- [ predecessors>> push ] with each
- ] each-block ;
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors sequences kernel
-compiler.cfg
-compiler.cfg.predecessors
-compiler.cfg.stack
-compiler.cfg.alias
-compiler.cfg.write-barrier
-compiler.cfg.elaboration
-compiler.cfg.vn
-compiler.cfg.vn.conditions
-compiler.cfg.kill-nops ;
-IN: compiler.cfg.simplifier
-
-: simplify ( insns -- insns' )
- normalize-height
- alias-analysis
- elaboration
- value-numbering
- eliminate-write-barrier
- kill-nops ;
-
-: simplify-cfg ( procedure -- procedure )
- dup compute-predecessors
- dup [ [ simplify ] change-instructions drop ] each-block ;
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors math namespaces sequences kernel fry
-compiler.vops ;
-IN: compiler.cfg.stack
-
-! Combine multiple stack height changes into one, done at the
-! start of the basic block.
-!
-! Alias analysis and value numbering assume this optimization
-! has been performed.
-
-! Current data and retain stack height is stored in
-! %data, %retain variables.
-GENERIC: compute-heights ( insn -- )
-
-M: %height compute-heights
- [ n>> ] [ stack>> ] bi [ + ] change ;
-
-M: object compute-heights drop ;
-
-GENERIC: normalize-height* ( insn -- insn )
-
-M: %height normalize-height*
- [ n>> ] [ stack>> ] bi [ swap - ] change nop ;
-
-: (normalize-height) ( insn -- insn )
- dup stack>> get '[ , + ] change-n ; inline
-
-M: %peek normalize-height* (normalize-height) ;
-
-M: %replace normalize-height* (normalize-height) ;
-
-M: object normalize-height* ;
-
-: normalize-height ( insns -- insns' )
- 0 %data set
- 0 %retain set
- [ [ compute-heights ] each ]
- [ [ [ normalize-height* ] map ] with-scope ] bi
- %data get dup zero? [ drop ] [ %data %height boa prefix ] if
- %retain get dup zero? [ drop ] [ %retain %height boa prefix ] if ;
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2006, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays assocs classes classes.private classes.algebra
+combinators hashtables kernel layouts math fry namespaces
+quotations sequences system vectors words effects alien
+byte-arrays accessors sets math.order compiler.instructions
+compiler.registers ;
+IN: compiler.cfg.stacks
+
+! Converting stack operations into register operations, while
+! doing a bit of optimization along the way.
+
+USE: qualified
+FROM: compiler.generator.registers => +input+ ;
+FROM: compiler.generator.registers => +output+ ;
+FROM: compiler.generator.registers => +scratch+ ;
+FROM: compiler.generator.registers => +clobber+ ;
+SYMBOL: known-tag
+
+! Value protocol
+GENERIC: set-operand-class ( class obj -- )
+GENERIC: operand-class* ( operand -- class )
+GENERIC: move-spec ( obj -- spec )
+GENERIC: live-loc? ( actual current -- ? )
+GENERIC# (lazy-load) 1 ( value spec -- value )
+GENERIC# (eager-load) 1 ( value spec -- value )
+GENERIC: lazy-store ( dst src -- )
+GENERIC: minimal-ds-loc* ( min obj -- min )
+
+! This will be a multimethod soon
+DEFER: %move
+
+PRIVATE>
+
+: operand-class ( operand -- class )
+ operand-class* object or ;
+
+! Default implementation
+M: value set-operand-class 2drop ;
+M: value operand-class* drop f ;
+M: value live-loc? 2drop f ;
+M: value minimal-ds-loc* drop ;
+M: value lazy-store 2drop ;
+
+M: vreg move-spec reg-class>> move-spec ;
+
+M: int-regs move-spec drop f ;
+M: int-regs operand-class* drop object ;
+
+M: float-regs move-spec drop float ;
+M: float-regs operand-class* drop float ;
+
+M: ds-loc minimal-ds-loc* n>> min ;
+M: ds-loc live-loc?
+ over ds-loc? [ [ n>> ] bi@ = not ] [ 2drop t ] if ;
+
+M: rs-loc live-loc?
+ over rs-loc? [ [ n>> ] bi@ = not ] [ 2drop t ] if ;
+
+M: loc operand-class* class>> ;
+M: loc set-operand-class (>>class) ;
+M: loc move-spec drop loc ;
+
+M: f move-spec drop loc ;
+M: f operand-class* ;
+
+M: cached set-operand-class vreg>> set-operand-class ;
+M: cached operand-class* vreg>> operand-class* ;
+M: cached move-spec drop cached ;
+M: cached live-loc? loc>> live-loc? ;
+M: cached (lazy-load) >r vreg>> r> (lazy-load) ;
+M: cached (eager-load) >r vreg>> r> (eager-load) ;
+M: cached lazy-store
+ 2dup loc>> live-loc?
+ [ "live-locs" get at %move ] [ 2drop ] if ;
+M: cached minimal-ds-loc* loc>> minimal-ds-loc* ;
+
+M: tagged set-operand-class (>>class) ;
+M: tagged operand-class* class>> ;
+M: tagged move-spec drop f ;
+
+M: unboxed-alien operand-class* drop simple-alien ;
+M: unboxed-alien move-spec class ;
+
+M: unboxed-byte-array operand-class* drop c-ptr ;
+M: unboxed-byte-array move-spec class ;
+
+M: unboxed-f operand-class* drop \ f ;
+M: unboxed-f move-spec class ;
+
+M: unboxed-c-ptr operand-class* drop c-ptr ;
+M: unboxed-c-ptr move-spec class ;
+
+M: constant operand-class* value>> class ;
+M: constant move-spec class ;
+
+! Moving values between locations and registers
+: %move-bug ( -- * ) "Bug in generator.registers" throw ;
+
+: %unbox-c-ptr ( dst src -- )
+ dup operand-class {
+ { [ dup \ f class<= ] [ drop %unbox-f ] }
+ { [ dup simple-alien class<= ] [ drop %unbox-alien ] }
+ { [ dup byte-array class<= ] [ drop %unbox-byte-array ] }
+ [ drop %unbox-any-c-ptr ]
+ } cond ; inline
+
+: %move-via-temp ( dst src -- )
+ #! For many transfers, such as loc to unboxed-alien, we
+ #! don't have an intrinsic, so we transfer the source to
+ #! temp then temp to the destination.
+ int-regs next-vreg [ over %move operand-class ] keep
+ tagged new
+ swap >>vreg
+ swap >>class
+ %move ;
+
+: %move ( dst src -- )
+ 2dup [ move-spec ] bi@ 2array {
+ { { f f } [ %copy ] }
+ { { unboxed-alien unboxed-alien } [ %copy ] }
+ { { unboxed-byte-array unboxed-byte-array } [ %copy ] }
+ { { unboxed-f unboxed-f } [ %copy ] }
+ { { unboxed-c-ptr unboxed-c-ptr } [ %copy ] }
+ { { float float } [ %copy-float ] }
+
+ { { f unboxed-c-ptr } [ %move-bug ] }
+ { { f unboxed-byte-array } [ %move-bug ] }
+
+ { { f constant } [ value>> swap %load-literal ] }
+
+ { { f float } [ %box-float ] }
+ { { f unboxed-alien } [ %box-alien ] }
+ { { f loc } [ %peek ] }
+
+ { { float f } [ %unbox-float ] }
+ { { unboxed-alien f } [ %unbox-alien ] }
+ { { unboxed-byte-array f } [ %unbox-byte-array ] }
+ { { unboxed-f f } [ %unbox-f ] }
+ { { unboxed-c-ptr f } [ %unbox-c-ptr ] }
+ { { loc f } [ swap %replace ] }
+
+ [ drop %move-via-temp ]
+ } case ;
+
+! A compile-time stack
+TUPLE: phantom-stack height stack ;
+
+M: phantom-stack clone
+ call-next-method [ clone ] change-stack ;
+
+GENERIC: finalize-height ( stack -- )
+
+: new-phantom-stack ( class -- stack )
+ >r 0 V{ } clone r> boa ; inline
+
+: (loc) ( m stack -- n )
+ #! Utility for methods on <loc>
+ height>> - ;
+
+: (finalize-height) ( stack word -- )
+ #! We consolidate multiple stack height changes until the
+ #! last moment, and we emit the final height changing
+ #! instruction here.
+ '[ dup zero? [ drop ] [ _ execute ] if 0 ] change-height drop ; inline
+
+GENERIC: <loc> ( n stack -- loc )
+
+TUPLE: phantom-datastack < phantom-stack ;
+
+: <phantom-datastack> ( -- stack )
+ phantom-datastack new-phantom-stack ;
+
+M: phantom-datastack <loc> (loc) <ds-loc> ;
+
+M: phantom-datastack finalize-height
+ \ %inc-d (finalize-height) ;
+
+TUPLE: phantom-retainstack < phantom-stack ;
+
+: <phantom-retainstack> ( -- stack )
+ phantom-retainstack new-phantom-stack ;
+
+M: phantom-retainstack <loc> (loc) <rs-loc> ;
+
+M: phantom-retainstack finalize-height
+ \ %inc-r (finalize-height) ;
+
+: phantom-locs ( n phantom -- locs )
+ #! A sequence of n ds-locs or rs-locs indexing the stack.
+ >r <reversed> r> '[ _ <loc> ] map ;
+
+: phantom-locs* ( phantom -- locs )
+ [ stack>> length ] keep phantom-locs ;
+
+: phantoms ( -- phantom phantom )
+ phantom-datastack get phantom-retainstack get ;
+
+: (each-loc) ( phantom quot -- )
+ >r [ phantom-locs* ] [ stack>> ] bi r> 2each ; inline
+
+: each-loc ( quot -- )
+ phantoms 2array swap '[ _ (each-loc) ] each ; inline
+
+: adjust-phantom ( n phantom -- )
+ swap '[ _ + ] change-height drop ;
+
+: cut-phantom ( n phantom -- seq )
+ swap '[ _ cut* swap ] change-stack drop ;
+
+: phantom-append ( seq stack -- )
+ over length over adjust-phantom stack>> push-all ;
+
+: add-locs ( n phantom -- )
+ 2dup stack>> length <= [
+ 2drop
+ ] [
+ [ phantom-locs ] keep
+ [ stack>> length head-slice* ] keep
+ [ append >vector ] change-stack drop
+ ] if ;
+
+: phantom-input ( n phantom -- seq )
+ 2dup add-locs
+ 2dup cut-phantom
+ >r >r neg r> adjust-phantom r> ;
+
+: each-phantom ( quot -- ) phantoms rot bi@ ; inline
+
+: finalize-heights ( -- ) [ finalize-height ] each-phantom ;
+
+: (live-locs) ( phantom -- seq )
+ #! Discard locs which haven't moved
+ [ phantom-locs* ] [ stack>> ] bi zip
+ [ live-loc? ] assoc-filter
+ values ;
+
+: live-locs ( -- seq )
+ [ (live-locs) ] each-phantom append prune ;
+
+! Operands holding pointers to freshly-allocated objects which
+! are guaranteed to be in the nursery
+SYMBOL: fresh-objects
+
+: reg-spec>class ( spec -- class )
+ float eq? double-float-regs int-regs ? ;
+
+: alloc-vreg ( spec -- reg )
+ [ reg-spec>class next-vreg ] keep {
+ { f [ <tagged> ] }
+ { unboxed-alien [ <unboxed-alien> ] }
+ { unboxed-byte-array [ <unboxed-byte-array> ] }
+ { unboxed-f [ <unboxed-f> ] }
+ { unboxed-c-ptr [ <unboxed-c-ptr> ] }
+ [ drop ]
+ } case ;
+
+: compatible? ( value spec -- ? )
+ >r move-spec r> {
+ { [ 2dup = ] [ t ] }
+ { [ dup unboxed-c-ptr eq? ] [
+ over { unboxed-byte-array unboxed-alien } member?
+ ] }
+ [ f ]
+ } cond 2nip ;
+
+: alloc-vreg-for ( value spec -- vreg )
+ alloc-vreg swap operand-class
+ over tagged? [ >>class ] [ drop ] if ;
+
+M: value (lazy-load)
+ {
+ { [ dup quotation? ] [ drop ] }
+ { [ 2dup compatible? ] [ drop ] }
+ [ (eager-load) ]
+ } cond ;
+
+M: value (eager-load) ( value spec -- vreg )
+ [ alloc-vreg-for ] [ drop ] 2bi
+ [ %move ] [ drop ] 2bi ;
+
+M: loc lazy-store
+ 2dup live-loc? [ "live-locs" get at %move ] [ 2drop ] if ;
+
+: finalize-locs ( -- )
+ #! Perform any deferred stack shuffling.
+ live-locs [ dup f (lazy-load) ] H{ } map>assoc
+ dup assoc-empty? [ drop ] [
+ "live-locs" set [ lazy-store ] each-loc
+ ] if ;
+
+: finalize-vregs ( -- )
+ #! Store any vregs to their final stack locations.
+ [
+ dup loc? over cached? or [ 2drop ] [ %move ] if
+ ] each-loc ;
+
+: reset-phantom ( phantom -- )
+ #! Kill register assignments but preserve constants and
+ #! class information.
+ dup phantom-locs*
+ over stack>> [
+ dup constant? [ nip ] [
+ operand-class over set-operand-class
+ ] if
+ ] 2map
+ over stack>> delete-all
+ swap stack>> push-all ;
+
+: reset-phantoms ( -- )
+ [ reset-phantom ] each-phantom ;
+
+: finalize-contents ( -- )
+ finalize-locs finalize-vregs reset-phantoms ;
+
+! Loading stacks to vregs
+: vreg-substitution ( value vreg -- pair )
+ dupd <cached> 2array ;
+
+: substitute-vreg? ( old new -- ? )
+ #! We don't substitute locs for float or alien vregs,
+ #! since in those cases the boxing overhead might kill us.
+ vreg>> tagged? >r loc? r> and ;
+
+: substitute-vregs ( values vregs -- )
+ [ vreg-substitution ] 2map
+ [ substitute-vreg? ] assoc-filter >hashtable
+ '[ stack>> _ substitute-here ] each-phantom ;
+
+: clear-phantoms ( -- )
+ [ stack>> delete-all ] each-phantom ;
+
+: set-operand-classes ( classes -- )
+ phantom-datastack get
+ over length over add-locs
+ stack>> [ set-operand-class ] 2reverse-each ;
+
+: finalize-phantoms ( -- )
+ #! Commit all deferred stacking shuffling, and ensure the
+ #! in-memory data and retain stacks are up to date with
+ #! respect to the compiler's current picture.
+ finalize-contents
+ clear-phantoms
+ finalize-heights
+ fresh-objects get [ empty? [ %gc ] unless ] [ delete-all ] bi ;
+
+: fresh-object ( obj -- ) fresh-objects get push ;
+
+: fresh-object? ( obj -- ? ) fresh-objects get memq? ;
+
+: init-phantoms ( -- )
+ V{ } clone fresh-objects set
+ <phantom-datastack> phantom-datastack set
+ <phantom-retainstack> phantom-retainstack set ;
+
+: copy-phantoms ( -- )
+ fresh-objects [ clone ] change
+ phantom-datastack [ clone ] change
+ phantom-retainstack [ clone ] change ;
+
+: operand-tag ( operand -- tag/f )
+ operand-class dup [ class-tag ] when ;
+
+UNION: immediate fixnum POSTPONE: f ;
+
+: operand-immediate? ( operand -- ? )
+ operand-class immediate class<= ;
+
+: phantom-push ( obj -- )
+ 1 phantom-datastack get adjust-phantom
+ phantom-datastack get stack>> push ;
+
+: phantom-shuffle ( shuffle -- )
+ [ in>> length phantom-datastack get phantom-input ] keep
+ shuffle phantom-datastack get phantom-append ;
+
+: phantom->r ( n -- )
+ phantom-datastack get phantom-input
+ phantom-retainstack get phantom-append ;
+
+: phantom-r> ( n -- )
+ phantom-retainstack get phantom-input
+ phantom-datastack get phantom-append ;
+
+: phantom-drop ( n -- )
+ phantom-datastack get phantom-input drop ;
+
+: phantom-rdrop ( n -- )
+ phantom-retainstack get phantom-input drop ;
+++ /dev/null
-Low-level optimizer operating on control flow graph SSA IR
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs accessors sequences kernel fry namespaces
+quotations combinators classes.algebra compiler.instructions
+compiler.registers compiler.cfg.stacks ;
+IN: compiler.cfg.templates
+
+USE: qualified
+FROM: compiler.generator.registers => +input+ ;
+FROM: compiler.generator.registers => +output+ ;
+FROM: compiler.generator.registers => +scratch+ ;
+FROM: compiler.generator.registers => +clobber+ ;
+
+: template-input +input+ swap at ; inline
+: template-output +output+ swap at ; inline
+: template-scratch +scratch+ swap at ; inline
+: template-clobber +clobber+ swap at ; inline
+
+: phantom&spec ( phantom specs -- phantom' specs' )
+ >r stack>> r>
+ [ length f pad-left ] keep
+ [ <reversed> ] bi@ ; inline
+
+: phantom&spec-agree? ( phantom spec quot -- ? )
+ >r phantom&spec r> 2all? ; inline
+
+: live-vregs ( -- seq )
+ [ stack>> [ >vreg ] map sift ] each-phantom append ;
+
+: clobbered ( template -- seq )
+ [ template-output ] [ template-clobber ] bi append ;
+
+: clobbered? ( value name -- ? )
+ \ clobbered get member? [
+ >vreg \ live-vregs get member?
+ ] [ drop f ] if ;
+
+: lazy-load ( specs -- seq )
+ [ length phantom-datastack get phantom-input ] keep
+ [ drop ] [
+ [
+ 2dup second clobbered?
+ [ first (eager-load) ] [ first (lazy-load) ] if
+ ] 2map
+ ] 2bi
+ [ substitute-vregs ] keep ;
+
+: load-inputs ( template -- assoc )
+ [
+ live-vregs \ live-vregs set
+ dup clobbered \ clobbered set
+ template-input [ values ] [ lazy-load ] bi zip
+ ] with-scope ;
+
+: alloc-scratch ( template -- assoc )
+ template-scratch [ swap alloc-vreg ] assoc-map ;
+
+: do-template-inputs ( template -- inputs )
+ #! Load input values into registers and allocates scratch
+ #! registers.
+ [ load-inputs ] [ alloc-scratch ] bi assoc-union ;
+
+: do-template-outputs ( template inputs -- )
+ [ template-output ] dip '[ _ at ] map
+ phantom-datastack get phantom-append ;
+
+: apply-template ( pair quot -- vregs )
+ [
+ first2 dup do-template-inputs
+ [ do-template-outputs ] keep
+ ] dip call ; inline
+
+: value-matches? ( value spec -- ? )
+ #! If the spec is a quotation and the value is a literal
+ #! fixnum, see if the quotation yields true when applied
+ #! to the fixnum. Otherwise, the values don't match. If the
+ #! spec is not a quotation, its a reg-class, in which case
+ #! the value is always good.
+ dup quotation? [
+ over constant?
+ [ >r value>> r> 2drop f ] [ 2drop f ] if
+ ] [
+ 2drop t
+ ] if ;
+
+: class-matches? ( actual expected -- ? )
+ {
+ { f [ drop t ] }
+ { known-tag [ dup [ class-tag >boolean ] when ] }
+ [ class<= ]
+ } case ;
+
+: spec-matches? ( value spec -- ? )
+ 2dup first value-matches?
+ >r >r operand-class 2 r> ?nth class-matches? r> and ;
+
+: template-matches? ( template -- ? )
+ template-input phantom-datastack get swap
+ [ spec-matches? ] phantom&spec-agree? ;
+
+: find-template ( templates -- pair/f )
+ #! Pair has shape { quot assoc }
+ [ second template-matches? ] find nip ;
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences layouts accessors compiler.vops
-compiler.cfg.vn.graph
-compiler.cfg.vn.expressions
-compiler.cfg.vn.liveness
-compiler.cfg.vn ;
-IN: compiler.cfg.vn.conditions
-
-! The CFG generator produces naive code for the following code
-! sequence:
-!
-! fixnum< [ ... ] [ ... ] if
-!
-! The fixnum< comparison generates a boolean, which is then
-! tested against f.
-!
-! Using value numbering, we optimize the comparison of a boolean
-! against f where the boolean is the result of comparison.
-
-: expr-f? ( expr -- ? )
- dup op>> %iconst eq?
- [ value>> \ f tag-number = ] [ drop f ] if ;
-
-: comparison-with-f? ( insn -- expr/f ? )
- #! The expr is a binary-op %icmp or %fcmp.
- dup code>> cc/= eq? [
- in>> vreg>vn vn>expr dup in2>> vn>expr expr-f?
- ] [ drop f f ] if ;
-
-: of-boolean? ( expr -- expr/f ? )
- #! The expr is a binary-op %icmp or %fcmp.
- in1>> vn>expr dup op>> { %%iboolean %%fboolean } memq? ;
-
-: original-comparison ( expr -- in/f code/f )
- [ in>> vn>vreg ] [ code>> ] bi ;
-
-: eliminate-boolean ( insn -- in/f code/f )
- comparison-with-f? [
- of-boolean? [
- original-comparison
- ] [ drop f f ] if
- ] [ drop f f ] if ;
-
-M: cond-branch make-value-node
- #! If the conditional branch is testing the result of an
- #! earlier comparison against f, we only mark as live the
- #! earlier comparison, so DCE will eliminate the boolean.
- dup eliminate-boolean drop swap in>> or live-vreg ;
-
-M: cond-branch eliminate
- dup eliminate-boolean dup
- [ [ >>in ] [ >>code ] bi* ] [ 2drop ] if ;
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel compiler.vops compiler.cfg.vn.graph
-compiler.cfg.vn.expressions ;
-IN: compiler.cfg.vn.constant-fold
-
-GENERIC: constant-fold ( insn -- insn' )
-
-M: vop constant-fold ;
-
-: expr>insn ( out constant-expr -- constant-op )
- [ value>> ] [ op>> ] bi new swap >>value swap >>out ;
-
-M: pure-op constant-fold
- dup out>>
- dup vreg>vn vn>expr
- dup constant-expr? [ expr>insn nip ] [ 2drop ] if ;
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors classes kernel math namespaces sorting
-compiler.vops compiler.cfg.vn.graph ;
-IN: compiler.cfg.vn.expressions
-
-! Referentially-transparent expressions
-TUPLE: expr op ;
-TUPLE: nullary-expr < expr ;
-TUPLE: unary-expr < expr in ;
-TUPLE: binary-expr < expr in1 in2 ;
-TUPLE: commutative-expr < binary-expr ;
-TUPLE: boolean-expr < unary-expr code ;
-TUPLE: constant-expr < expr value ;
-TUPLE: literal-expr < unary-expr object ;
-
-! op is always %peek
-TUPLE: peek-expr < expr loc ;
-
-SYMBOL: input-expr-counter
-
-: next-input-expr ( -- n )
- input-expr-counter [ dup 1 + ] change ;
-
-! Expressions whose values are inputs to the basic block. We
-! can eliminate a second computation having the same 'n' as
-! the first one; we can also eliminate input-exprs whose
-! result is not used.
-TUPLE: input-expr < expr n ;
-
-GENERIC: >expr ( insn -- expr )
-
-M: %literal-table >expr
- class nullary-expr boa ;
-
-M: constant-op >expr
- [ class ] [ value>> ] bi constant-expr boa ;
-
-M: %literal >expr
- [ class ] [ in>> vreg>vn ] [ object>> ] tri literal-expr boa ;
-
-M: unary-op >expr
- [ class ] [ in>> vreg>vn ] bi unary-expr boa ;
-
-M: binary-op >expr
- [ class ] [ in1>> vreg>vn ] [ in2>> vreg>vn ] tri
- binary-expr boa ;
-
-M: commutative-op >expr
- [ class ] [ in1>> vreg>vn ] [ in2>> vreg>vn ] tri
- sort-pair commutative-expr boa ;
-
-M: boolean-op >expr
- [ class ] [ in>> vreg>vn ] [ code>> ] tri
- boolean-expr boa ;
-
-M: %peek >expr
- [ class ] [ stack-loc ] bi peek-expr boa ;
-
-M: flushable-op >expr
- class next-input-expr input-expr boa ;
-
-: init-expressions ( -- )
- 0 input-expr-counter set ;
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math namespaces assocs biassocs accessors
-math.order prettyprint.backend parser ;
-IN: compiler.cfg.vn.graph
-
-TUPLE: vn n ;
-
-SYMBOL: vn-counter
-
-: next-vn ( -- vn ) vn-counter [ dup 1 + ] change vn boa ;
-
-: VN: scan-word vn boa parsed ; parsing
-
-M: vn <=> [ n>> ] compare ;
-
-M: vn pprint* \ VN: pprint-word n>> pprint* ;
-
-! biassoc mapping expressions to value numbers
-SYMBOL: exprs>vns
-
-: expr>vn ( expr -- vn ) exprs>vns get [ drop next-vn ] cache ;
-
-: vn>expr ( vn -- expr ) exprs>vns get value-at ;
-
-SYMBOL: vregs>vns
-
-: vreg>vn ( vreg -- vn ) vregs>vns get at ;
-
-: vn>vreg ( vn -- vreg ) vregs>vns get value-at ;
-
-: set-vn ( vn vreg -- ) vregs>vns get set-at ;
-
-: init-value-graph ( -- )
- 0 vn-counter set
- <bihash> exprs>vns set
- <bihash> vregs>vns set ;
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces kernel assocs sets accessors compiler.vops
-compiler.cfg.vn.graph compiler.cfg.vn.expressions ;
-IN: compiler.cfg.vn.liveness
-
-! A set of VNs which are (transitively) used by effect-ops. This
-! is precisely the set of VNs whose value is needed outside of
-! the basic block.
-SYMBOL: live-vns
-
-GENERIC: live-expr ( expr -- )
-
-: live-vn ( vn -- )
- #! Mark a VN and all VNs used in its computation as live.
- dup live-vns get key? [ drop ] [
- [ live-vns get conjoin ] [ vn>expr live-expr ] bi
- ] if ;
-
-: live-vreg ( vreg -- ) vreg>vn live-vn ;
-
-M: expr live-expr drop ;
-M: literal-expr live-expr in>> live-vn ;
-M: unary-expr live-expr in>> live-vn ;
-M: binary-expr live-expr [ in1>> live-vn ] [ in2>> live-vn ] bi ;
-
-: live? ( vreg -- ? )
- dup vreg>vn tuck vn>vreg =
- [ live-vns get key? ] [ drop f ] if ;
-
-: init-liveness ( -- )
- H{ } clone live-vns set ;
-
-GENERIC: eliminate ( insn -- insn' )
-
-M: flushable-op eliminate dup out>> live? ?nop ;
-M: vop eliminate ;
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces assocs sequences kernel accessors
-compiler.vops
-compiler.cfg.vn.graph ;
-IN: compiler.cfg.vn.propagate
-
-! If two vregs compute the same value, replace references to
-! the latter with the former.
-
-: resolve ( vreg -- vreg' ) vreg>vn vn>vreg ;
-
-GENERIC: propogate ( insn -- insn )
-
-M: effect-op propogate
- [ resolve ] change-in ;
-
-M: unary-op propogate
- [ resolve ] change-in ;
-
-M: binary-op propogate
- [ resolve ] change-in1
- [ resolve ] change-in2 ;
-
-M: %phi propogate
- [ [ resolve ] map ] change-in ;
-
-M: %%slot propogate
- [ resolve ] change-obj
- [ resolve ] change-slot ;
-
-M: %%set-slot propogate
- call-next-method
- [ resolve ] change-obj
- [ resolve ] change-slot ;
-
-M: %store propogate
- call-next-method
- [ resolve ] change-addr ;
-
-M: nullary-op propogate ;
-
-M: flushable-op propogate ;
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors combinators classes math math.order
-layouts locals
-compiler.vops
-compiler.cfg.vn.graph
-compiler.cfg.vn.expressions ;
-IN: compiler.cfg.vn.simplify
-
-! Return value of f means we didn't simplify.
-GENERIC: simplify* ( expr -- vn/expr/f )
-
-: constant ( val type -- expr ) swap constant-expr boa ;
-
-: simplify-not ( in -- vn/expr/f )
- {
- { [ dup constant-expr? ] [ value>> bitnot %iconst constant ] }
- { [ dup op>> %not = ] [ in>> ] }
- [ drop f ]
- } cond ;
-
-: simplify-box-float ( in -- vn/expr/f )
- {
- { [ dup op>> %%unbox-float = ] [ in>> ] }
- [ drop f ]
- } cond ;
-
-: simplify-unbox-float ( in -- vn/expr/f )
- {
- { [ dup literal-expr? ] [ object>> %fconst constant ] }
- { [ dup op>> %%box-float = ] [ in>> ] }
- [ drop f ]
- } cond ;
-
-M: unary-expr simplify*
- #! Note the copy propagation: a %copy always simplifies to
- #! its source vn.
- [ in>> vn>expr ] [ op>> ] bi {
- { %copy [ ] }
- { %not [ simplify-not ] }
- { %%box-float [ simplify-box-float ] }
- { %%unbox-float [ simplify-unbox-float ] }
- [ 2drop f ]
- } case ;
-
-: izero? ( expr -- ? ) T{ constant-expr f %iconst 0 } = ;
-
-: ione? ( expr -- ? ) T{ constant-expr f %iconst 1 } = ;
-
-: ineg-one? ( expr -- ? ) T{ constant-expr f %iconst -1 } = ;
-
-: fzero? ( expr -- ? ) T{ constant-expr f %fconst 0 } = ;
-
-: fone? ( expr -- ? ) T{ constant-expr f %fconst 1 } = ;
-
-: fneg-one? ( expr -- ? ) T{ constant-expr f %fconst -1 } = ;
-
-: identity ( in1 in2 val type -- expr ) constant 2nip ;
-
-: constant-fold? ( in1 in2 -- ? )
- [ constant-expr? ] both? ;
-
-:: constant-fold ( in1 in2 quot type -- expr )
- in1 in2 constant-fold?
- [ in1 value>> in2 value>> quot call type constant ]
- [ f ]
- if ; inline
-
-: simplify-iadd ( in1 in2 -- vn/expr/f )
- {
- { [ over izero? ] [ nip ] }
- { [ dup izero? ] [ drop ] }
- [ [ + ] %iconst constant-fold ]
- } cond ;
-
-: simplify-imul ( in1 in2 -- vn/expr/f )
- {
- { [ over ione? ] [ nip ] }
- { [ dup ione? ] [ drop ] }
- [ [ * ] %iconst constant-fold ]
- } cond ;
-
-: simplify-and ( in1 in2 -- vn/expr/f )
- {
- { [ dup izero? ] [ 0 %iconst identity ] }
- { [ dup ineg-one? ] [ drop ] }
- { [ 2dup = ] [ drop ] }
- [ [ bitand ] %iconst constant-fold ]
- } cond ;
-
-: simplify-or ( in1 in2 -- vn/expr/f )
- {
- { [ dup izero? ] [ drop ] }
- { [ dup ineg-one? ] [ -1 %iconst identity ] }
- { [ 2dup = ] [ drop ] }
- [ [ bitor ] %iconst constant-fold ]
- } cond ;
-
-: simplify-xor ( in1 in2 -- vn/expr/f )
- {
- { [ dup izero? ] [ drop ] }
- [ [ bitxor ] %iconst constant-fold ]
- } cond ;
-
-: simplify-fadd ( in1 in2 -- vn/expr/f )
- {
- { [ over fzero? ] [ nip ] }
- { [ dup fzero? ] [ drop ] }
- [ [ + ] %fconst constant-fold ]
- } cond ;
-
-: simplify-fmul ( in1 in2 -- vn/expr/f )
- {
- { [ over fone? ] [ nip ] }
- { [ dup fone? ] [ drop ] }
- [ [ * ] %fconst constant-fold ]
- } cond ;
-
-: commutative-operands ( expr -- in1 in2 )
- [ in1>> vn>expr ] [ in2>> vn>expr ] bi
- over constant-expr? [ swap ] when ;
-
-M: commutative-expr simplify*
- [ commutative-operands ] [ op>> ] bi {
- { %iadd [ simplify-iadd ] }
- { %imul [ simplify-imul ] }
- { %and [ simplify-and ] }
- { %or [ simplify-or ] }
- { %xor [ simplify-xor ] }
- { %fadd [ simplify-fadd ] }
- { %fmul [ simplify-fmul ] }
- [ 3drop f ]
- } case ;
-
-: simplify-isub ( in1 in2 -- vn/expr/f )
- {
- { [ dup izero? ] [ drop ] }
- { [ 2dup = ] [ 0 %iconst identity ] }
- [ [ - ] %iconst constant-fold ]
- } cond ;
-
-: simplify-idiv ( in1 in2 -- vn/expr/f )
- {
- { [ dup ione? ] [ drop ] }
- [ [ /i ] %iconst constant-fold ]
- } cond ;
-
-: simplify-imod ( in1 in2 -- vn/expr/f )
- {
- { [ dup ione? ] [ 0 %iconst identity ] }
- { [ 2dup = ] [ 0 %iconst identity ] }
- [ [ mod ] %iconst constant-fold ]
- } cond ;
-
-: simplify-shl ( in1 in2 -- vn/expr/f )
- {
- { [ dup izero? ] [ drop ] }
- { [ over izero? ] [ drop ] }
- [ [ shift ] %iconst constant-fold ]
- } cond ;
-
-: unsigned ( n -- n' )
- cell-bits 2^ 1- bitand ;
-
-: useless-shift? ( in1 in2 -- ? )
- over op>> %shl = [ [ in2>> ] [ expr>vn ] bi* = ] [ 2drop f ] if ;
-
-: simplify-shr ( in1 in2 -- vn/expr/f )
- {
- { [ dup izero? ] [ drop ] }
- { [ over izero? ] [ drop ] }
- { [ 2dup useless-shift? ] [ drop in1>> ] }
- [ [ neg shift unsigned ] %iconst constant-fold ]
- } cond ;
-
-: simplify-sar ( in1 in2 -- vn/expr/f )
- {
- { [ dup izero? ] [ drop ] }
- { [ over izero? ] [ drop ] }
- { [ 2dup useless-shift? ] [ drop in1>> ] }
- [ [ neg shift ] %iconst constant-fold ]
- } cond ;
-
-: simplify-icmp ( in1 in2 -- vn/expr/f )
- = [ +eq+ %cconst constant ] [ f ] if ;
-
-: simplify-fsub ( in1 in2 -- vn/expr/f )
- {
- { [ dup izero? ] [ drop ] }
- [ [ - ] %fconst constant-fold ]
- } cond ;
-
-: simplify-fdiv ( in1 in2 -- vn/expr/f )
- {
- { [ dup fone? ] [ drop ] }
- [ [ /i ] %fconst constant-fold ]
- } cond ;
-
-M: binary-expr simplify*
- [ in1>> vn>expr ] [ in2>> vn>expr ] [ op>> ] tri {
- { %isub [ simplify-isub ] }
- { %idiv [ simplify-idiv ] }
- { %imod [ simplify-imod ] }
- { %shl [ simplify-shl ] }
- { %shr [ simplify-shr ] }
- { %sar [ simplify-sar ] }
- { %icmp [ simplify-icmp ] }
- { %fsub [ simplify-fsub ] }
- { %fdiv [ simplify-fdiv ] }
- [ 3drop f ]
- } case ;
-
-M: expr simplify* drop f ;
-
-: simplify ( expr -- vn )
- dup simplify* {
- { [ dup not ] [ drop expr>vn ] }
- { [ dup expr? ] [ expr>vn nip ] }
- { [ dup vn? ] [ nip ] }
- } cond ;
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces assocs biassocs classes kernel math accessors
-sorting sets sequences compiler.vops
-compiler.cfg.vn.graph
-compiler.cfg.vn.expressions
-compiler.cfg.vn.simplify
-compiler.cfg.vn.liveness
-compiler.cfg.vn.constant-fold
-compiler.cfg.vn.propagate ;
-IN: compiler.cfg.vn
-
-: insn>vn ( insn -- vn ) >expr simplify ; inline
-
-GENERIC: make-value-node ( insn -- )
-M: flushable-op make-value-node [ insn>vn ] [ out>> ] bi set-vn ;
-M: effect-op make-value-node in>> live-vreg ;
-M: %store make-value-node [ in>> live-vreg ] [ addr>> live-vreg ] bi ;
-M: %%set-slot make-value-node [ in>> live-vreg ] [ obj>> live-vreg ] bi ;
-M: nullary-op make-value-node drop ;
-
-: init-value-numbering ( -- )
- init-value-graph
- init-expressions
- init-liveness ;
-
-: value-numbering ( instructions -- instructions )
- init-value-numbering
- [ [ make-value-node ] each ]
- [ [ eliminate constant-fold propogate ] map ]
- bi ;
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors namespaces assocs sets sequences
-compiler.vops compiler.cfg ;
-IN: compiler.cfg.write-barrier
-
-! Eliminate redundant write barrier hits.
-SYMBOL: hits
-
-GENERIC: eliminate-write-barrier* ( insn -- insn' )
-
-M: %%allot eliminate-write-barrier*
- dup out>> hits get conjoin ;
-
-M: %write-barrier eliminate-write-barrier*
- dup in>> hits get key?
- [ drop nop ] [ dup in>> hits get conjoin ] if ;
-
-M: %copy eliminate-write-barrier*
- dup in/out hits get copy-at ;
-
-M: vop eliminate-write-barrier* ;
-
-: eliminate-write-barrier ( insns -- insns )
- H{ } clone hits set
- [ eliminate-write-barrier* ] map ;
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2007, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays byte-arrays generic assocs hashtables io.binary
+kernel kernel.private math namespaces make sequences words
+quotations strings alien.accessors alien.strings layouts system
+combinators math.bitwise words.private cpu.architecture
+math.order accessors growable ;
+IN: compiler.cfg.fixup
+
+: no-stack-frame -1 ; inline
+
+TUPLE: frame-required n ;
+
+: frame-required ( n -- ) \ frame-required boa , ;
+
+: stack-frame-size ( code -- n )
+ no-stack-frame [
+ dup frame-required? [ n>> max ] [ drop ] if
+ ] reduce ;
+
+GENERIC: fixup* ( frame-size obj -- frame-size )
+
+: code-format 22 getenv ;
+
+: compiled-offset ( -- n ) building get length code-format * ;
+
+TUPLE: label offset ;
+
+: <label> ( -- label ) label new ;
+
+M: label fixup*
+ compiled-offset >>offset drop ;
+
+: define-label ( name -- ) <label> swap set ;
+
+: resolve-label ( label/name -- ) dup label? [ get ] unless , ;
+
+: if-stack-frame ( frame-size quot -- )
+ swap dup no-stack-frame =
+ [ 2drop ] [ stack-frame swap call ] if ; inline
+
+M: word fixup*
+ {
+ { \ %prologue-later [ dup [ %prologue ] if-stack-frame ] }
+ { \ %epilogue-later [ dup [ %epilogue ] if-stack-frame ] }
+ } case ;
+
+SYMBOL: relocation-table
+SYMBOL: label-table
+
+! Relocation classes
+: rc-absolute-cell 0 ;
+: rc-absolute 1 ;
+: rc-relative 2 ;
+: rc-absolute-ppc-2/2 3 ;
+: rc-relative-ppc-2 4 ;
+: rc-relative-ppc-3 5 ;
+: rc-relative-arm-3 6 ;
+: rc-indirect-arm 7 ;
+: rc-indirect-arm-pc 8 ;
+
+: rc-absolute? ( n -- ? )
+ dup rc-absolute-cell =
+ over rc-absolute =
+ rot rc-absolute-ppc-2/2 = or or ;
+
+! Relocation types
+: rt-primitive 0 ;
+: rt-dlsym 1 ;
+: rt-literal 2 ;
+: rt-dispatch 3 ;
+: rt-xt 4 ;
+: rt-here 5 ;
+: rt-label 6 ;
+: rt-immediate 7 ;
+
+TUPLE: label-fixup label class ;
+
+: label-fixup ( label class -- ) \ label-fixup boa , ;
+
+M: label-fixup fixup*
+ dup class>> rc-absolute?
+ [ "Absolute labels not supported" throw ] when
+ dup label>> swap class>> compiled-offset 4 - rot
+ 3array label-table get push ;
+
+TUPLE: rel-fixup arg class type ;
+
+: rel-fixup ( arg class type -- ) \ rel-fixup boa , ;
+
+: push-4 ( value vector -- )
+ [ length ] [ B{ 0 0 0 0 } swap push-all ] [ underlying>> ] tri
+ swap set-alien-unsigned-4 ;
+
+M: rel-fixup fixup*
+ [ [ arg>> ] [ class>> ] [ type>> ] tri { 0 8 16 } bitfield ]
+ [ class>> rc-absolute-cell = cell 4 ? compiled-offset swap - ] bi
+ [ relocation-table get push-4 ] bi@ ;
+
+M: frame-required fixup* drop ;
+
+M: integer fixup* , ;
+
+: adjoin* ( obj table -- n )
+ 2dup swap [ eq? ] curry find drop
+ [ 2nip ] [ dup length >r push r> ] if* ;
+
+SYMBOL: literal-table
+
+: add-literal ( obj -- n ) literal-table get adjoin* ;
+
+: add-dlsym-literals ( symbol dll -- )
+ >r string>symbol r> 2array literal-table get push-all ;
+
+: rel-dlsym ( name dll class -- )
+ >r literal-table get length >r
+ add-dlsym-literals
+ r> r> rt-dlsym rel-fixup ;
+
+: rel-word ( word class -- )
+ >r add-literal r> rt-xt rel-fixup ;
+
+: rel-primitive ( word class -- )
+ >r def>> first r> rt-primitive rel-fixup ;
+
+: rel-literal ( literal class -- )
+ >r add-literal r> rt-literal rel-fixup ;
+
+: rel-this ( class -- )
+ 0 swap rt-label rel-fixup ;
+
+: rel-here ( class -- )
+ 0 swap rt-here rel-fixup ;
+
+: init-fixup ( -- )
+ BV{ } clone relocation-table set
+ V{ } clone label-table set ;
+
+: resolve-labels ( labels -- labels' )
+ [
+ first3 offset>>
+ [ "Unresolved label" throw ] unless*
+ 3array
+ ] map concat ;
+
+: fixup ( code -- literals relocation labels code )
+ [
+ init-fixup
+ dup stack-frame-size swap [ fixup* ] each drop
+
+ literal-table get >array
+ relocation-table get >byte-array
+ label-table get resolve-labels
+ ] { } make ;
--- /dev/null
+Support for generation of relocatable code
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs accessors arrays kernel sequences
+compiler.instructions.syntax ;
+IN: compiler.instructions
+
+! Virtual CPU instructions, used by CFG and machine IRs
+
+INSN: %cond-branch vreg ;
+INSN: %unary dst src ;
+
+! Stack operations
+INSN: %peek vreg loc ;
+INSN: %replace vreg loc ;
+INSN: %inc-d n ;
+INSN: %inc-r n ;
+INSN: %load-literal obj vreg ;
+
+! Calling convention
+INSN: %prologue ;
+INSN: %epilogue ;
+INSN: %frame-required n ;
+INSN: %return ;
+
+! Subroutine calls
+INSN: %call word ;
+INSN: %jump word ;
+INSN: %intrinsic quot vregs ;
+
+! Jump tables
+INSN: %dispatch-label label ;
+INSN: %dispatch ;
+
+! Unconditional branch to successor (CFG only)
+INSN: %branch ;
+
+! Conditional branches (CFG only)
+INSN: %branch-f < %cond-branch ;
+INSN: %branch-t < %cond-branch ;
+INSN: %if-intrinsic quot vregs ;
+INSN: %boolean-intrinsic quot vregs out ;
+
+! Boxing and unboxing
+INSN: %copy < %unary ;
+INSN: %copy-float < %unary ;
+INSN: %unbox-float < %unary ;
+INSN: %unbox-f < %unary ;
+INSN: %unbox-alien < %unary ;
+INSN: %unbox-byte-array < %unary ;
+INSN: %unbox-any-c-ptr < %unary ;
+INSN: %box-float < %unary ;
+INSN: %box-alien < %unary ;
+
+INSN: %gc ;
+
+! FFI
+INSN: %alien-invoke params ;
+INSN: %alien-indirect params ;
+INSN: %alien-callback params ;
+
+GENERIC: uses-vregs ( insn -- seq )
+
+M: insn uses-vregs drop f ;
+M: %peek uses-vregs vreg>> 1array ;
+M: %replace uses-vregs vreg>> 1array ;
+M: %load-literal uses-vregs vreg>> 1array ;
+M: %cond-branch uses-vregs vreg>> 1array ;
+M: %unary uses-vregs [ dst>> ] [ src>> ] bi 2array ;
+M: %intrinsic uses-vregs vregs>> values ;
+M: %if-intrinsic uses-vregs vregs>> values ;
+M: %boolean-intrinsic uses-vregs
+ [ vregs>> values ] [ out>> ] bi suffix ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: classes.tuple classes.tuple.parser kernel words
+make parser ;
+IN: compiler.instructions.syntax
+
+TUPLE: insn ;
+
+: INSN:
+ parse-tuple-definition
+ [ dup tuple eq? [ drop insn ] when ] dip
+ [ define-tuple-class ]
+ [ 2drop save-location ]
+ [ 2drop dup [ boa , ] curry define-inline ]
+ 3tri ; parsing
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: compiler.lvops
+
+! Machine representation ("linear virtual operations"). Uses
+! same operations as CFG basic blocks, except edges and branches
+! are replaced by linear jumps (_b* instances).
+
+TUPLE: _label label ;
+
+! Unconditional jump to label
+TUPLE: _b label ;
+
+! Integer
+TUPLE: _bi label in code ;
+TUPLE: _bf label in code ;
+
+! Dispatch table, jumps to one of following _address
+! depending value of 'in'
+TUPLE: _dispatch in ;
+TUPLE: _address word ;
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-IN: compiler.lvops
-
-! Machine representation ("linear virtual operations"). Uses
-! same operations as CFG basic blocks, except edges and branches
-! are replaced by linear jumps (_b* instances).
-
-TUPLE: _label label ;
-
-! Unconditional jump to label
-TUPLE: _b label ;
-
-! Integer
-TUPLE: _bi label in code ;
-TUPLE: _bf label in code ;
-
-! Dispatch table, jumps to one of following _address
-! depending value of 'in'
-TUPLE: _dispatch in ;
-TUPLE: _address word ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math accessors sequences namespaces
+compiler.cfg compiler.vops compiler.lvops ;
+IN: compiler.machine.builder
+
+SYMBOL: block-counter
+
+: number-basic-block ( basic-block -- )
+ #! Make this fancy later.
+ dup number>> [ drop ] [
+ block-counter [ dup 1+ ] change >>number
+ [ , ] [
+ successors>> <reversed>
+ [ number-basic-block ] each
+ ] bi
+ ] if ;
+
+: flatten-basic-blocks ( procedure -- blocks )
+ [
+ 0 block-counter
+ [ number-basic-block ]
+ with-variable
+ ] { } make ;
+
+GENERIC: linearize-instruction ( basic-block insn -- )
+
+M: object linearize-instruction
+ , drop ;
+
+M: %b linearize-instruction
+ drop successors>> first number>> _b emit ;
+
+: conditional-branch ( basic-block insn class -- )
+ [ successors>> ] 2dip
+ [ [ first number>> ] [ [ in>> ] [ code>> ] bi ] [ ] tri* emit ]
+ [ 2drop second number>> _b emit ]
+ 3bi ; inline
+
+M: %bi linearize-instruction _bi conditional-branch ;
+M: %bf linearize-instruction _bf conditional-branch ;
+
+: build-mr ( procedure -- insns )
+ [
+ flatten-basic-blocks [
+ [ number>> _label emit ]
+ [ dup instructions>> [ linearize-instruction ] with each ]
+ bi
+ ] each
+ ] { } make ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel namespaces sequences assocs io
+prettyprint inference generator optimizer
+compiler.vops
+compiler.tree.builder
+compiler.tree.optimizer
+compiler.cfg.builder
+compiler.cfg.simplifier
+compiler.machine.builder
+compiler.machine.simplifier ;
+IN: compiler.machine.debugger
+
+: tree>linear ( tree word -- linear )
+ [
+ init-counter
+ build-cfg
+ [ simplify-cfg build-mr simplify-mr ] assoc-map
+ ] with-scope ;
+
+: linear. ( linear -- )
+ [
+ "==== " write swap .
+ [ . ] each
+ ] assoc-each ;
+
+: linearized-quot. ( quot -- )
+ build-tree optimize-tree
+ "Anonymous quotation" tree>linear
+ linear. ;
+
+: linearized-word. ( word -- )
+ dup build-tree-from-word nip optimize-tree
+ dup word-dataflow nip optimize swap tree>linear linear. ;
+
+: >basic-block ( quot -- basic-block )
+ build-tree optimize-tree
+ [
+ init-counter
+ "Anonymous quotation" build-cfg
+ >alist first second simplify-cfg
+ ] with-scope ;
+
+: basic-block. ( basic-block -- )
+ instructions>> [ . ] each ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors namespaces sequences.next compiler.lvops ;
+IN: compiler.machine.simplifier
+
+: useless-branch? ( next insn -- ? )
+ 2dup [ _label? ] [ _b? ] bi* and
+ [ [ label>> ] bi@ = ] [ 2drop f ] if ;
+
+: simplify-mr ( insns -- insns )
+ #! Remove unconditional branches to labels immediately
+ #! following.
+ [
+ [
+ tuck useless-branch?
+ [ drop ] [ , ] if
+ ] each-next
+ ] { } make ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math accessors sequences namespaces
-compiler.cfg compiler.vops compiler.lvops ;
+USING: kernel math accessors sequences namespaces make
+compiler.cfg compiler.instructions compiler.machine ;
IN: compiler.machine.builder
+! Convert CFG IR to machine IR.
+
SYMBOL: block-counter
: number-basic-block ( basic-block -- )
#! Make this fancy later.
dup number>> [ drop ] [
+ <label> >>label
block-counter [ dup 1+ ] change >>number
[ , ] [
successors>> <reversed>
with-variable
] { } make ;
-GENERIC: linearize-instruction ( basic-block insn -- )
+GENERIC: linearize* ( basic-block insn -- )
+
+M: object linearize* , drop ;
+
+M: %branch linearize*
+ drop successors>> first label>> _branch ;
-M: object linearize-instruction
- , drop ;
+: conditional ( basic-block -- label1 label2 )
+ successors>> first2 [ label>> ] bi@ swap ; inline
-M: %b linearize-instruction
- drop successors>> first number>> _b emit ;
+: boolean-conditional ( basic-block insn -- label1 vreg label2 )
+ [ conditional ] [ vreg>> ] bi* swap ; inline
-: conditional-branch ( basic-block insn class -- )
- [ successors>> ] 2dip
- [ [ first number>> ] [ [ in>> ] [ code>> ] bi ] [ ] tri* emit ]
- [ 2drop second number>> _b emit ]
- 3bi ; inline
+M: %branch-f linearize*
+ boolean-conditional _branch-f _branch ;
-M: %bi linearize-instruction _bi conditional-branch ;
-M: %bf linearize-instruction _bf conditional-branch ;
+M: %branch-t linearize*
+ boolean-conditional _branch-t _branch ;
+
+M: %if-intrinsic linearize*
+ [ conditional ] [ [ quot>> ] [ vregs>> ] bi ] bi*
+ _if-intrinsic _branch ;
+
+M: %boolean-intrinsic linearize*
+ [
+ "false" define-label
+ "end" define-label
+ "false" get over [ quot>> ] [ vregs>> ] bi _if-intrinsic
+ t over out>> %load-literal
+ "end" get _branch
+ "false" resolve-label
+ f over out>> %load-literal
+ "end" resolve-label
+ ] with-scope
+ 2drop ;
-: build-mr ( procedure -- insns )
+: build-machine ( procedure -- insns )
[
- flatten-basic-blocks [
- [ number>> _label emit ]
- [ dup instructions>> [ linearize-instruction ] with each ]
+ entry>> flatten-basic-blocks [
+ [ label>> _label ]
+ [ dup instructions>> [ linearize* ] with each ]
bi
] each
] { } make ;
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel namespaces sequences assocs io
-prettyprint inference generator optimizer
-compiler.vops
-compiler.tree.builder
-compiler.tree.optimizer
-compiler.cfg.builder
-compiler.cfg.simplifier
-compiler.machine.builder
-compiler.machine.simplifier ;
-IN: compiler.machine.debugger
-
-: tree>linear ( tree word -- linear )
- [
- init-counter
- build-cfg
- [ simplify-cfg build-mr simplify-mr ] assoc-map
- ] with-scope ;
-
-: linear. ( linear -- )
- [
- "==== " write swap .
- [ . ] each
- ] assoc-each ;
-
-: linearized-quot. ( quot -- )
- build-tree optimize-tree
- "Anonymous quotation" tree>linear
- linear. ;
-
-: linearized-word. ( word -- )
- dup build-tree-from-word nip optimize-tree
- dup word-dataflow nip optimize swap tree>linear linear. ;
-
-: >basic-block ( quot -- basic-block )
- build-tree optimize-tree
- [
- init-counter
- "Anonymous quotation" build-cfg
- >alist first second simplify-cfg
- ] with-scope ;
-
-: basic-block. ( basic-block -- )
- instructions>> [ . ] each ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: namespaces sequences math math.order kernel assocs
+accessors vectors fry
+compiler.machine.linear-scan.live-intervals
+compiler.backend ;
+IN: compiler.machine.linear-scan.allocation
+
+! Mapping from vregs to machine registers
+SYMBOL: register-allocation
+
+! Mapping from vregs to spill locations
+SYMBOL: spill-locations
+
+! Vector of active live intervals, in order of increasing end point
+SYMBOL: active-intervals
+
+: add-active ( live-interval -- )
+ active-intervals get push ;
+
+: delete-active ( live-interval -- )
+ active-intervals get delete ;
+
+! Mapping from register classes to sequences of machine registers
+SYMBOL: free-registers
+
+! Counter of spill locations
+SYMBOL: spill-counter
+
+: next-spill-location ( -- n )
+ spill-counter [ dup 1+ ] change ;
+
+: assign-spill ( live-interval -- )
+ next-spill-location swap vreg>> spill-locations get set-at ;
+
+: free-registers-for ( vreg -- seq )
+ reg-class>> free-registers get at ;
+
+: free-register ( vreg -- )
+ #! Free machine register currently assigned to vreg.
+ [ register-allocation get at ] [ free-registers-for ] bi push ;
+
+: expire-old-intervals ( live-interval -- )
+ active-intervals get
+ swap '[ end>> _ start>> < ] partition
+ active-intervals set
+ [ vreg>> free-register ] each ;
+
+: interval-to-spill ( -- live-interval )
+ #! We spill the interval with the longest remaining range.
+ active-intervals get unclip-slice [
+ [ [ end>> ] bi@ > ] most
+ ] reduce ;
+
+: reuse-register ( live-interval to-spill -- )
+ vreg>> swap vreg>>
+ register-allocation get
+ tuck [ at ] [ set-at ] 2bi* ;
+
+: spill-at-interval ( live-interval -- )
+ interval-to-spill
+ 2dup [ end>> ] bi@ > [
+ [ reuse-register ]
+ [ nip assign-spill ]
+ [ [ add-active ] [ delete-active ] bi* ]
+ 2tri
+ ] [ drop assign-spill ] if ;
+
+: init-allocator ( -- )
+ H{ } clone register-allocation set
+ H{ } clone spill-locations set
+ V{ } clone active-intervals set
+ machine-registers [ >vector ] assoc-map free-registers set
+ 0 spill-counter set ;
+
+: assign-register ( live-interval register -- )
+ swap vreg>> register-allocation get set-at ;
+
+: allocate-register ( live-interval -- )
+ dup vreg>> free-registers-for [
+ spill-at-interval
+ ] [
+ [ pop assign-register ]
+ [ drop add-active ]
+ 2bi
+ ] if-empty ;
+
+: allocate-registers ( live-intervals -- )
+ init-allocator
+ [ [ expire-old-intervals ] [ allocate-register ] bi ] each ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: compiler.machine.linear-scan
+
+! See http://www.cs.ucla.edu/~palsberg/course/cs132/linearscan.pdf
+
+! ! ! Step 1: compute live intervals
+
+
+! ! ! Step 2: allocate registers
+
+
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: namespaces kernel assocs accessors sequences math
+math.order sorting compiler.instructions compiler.registers ;
+IN: compiler.machine.linear-scan.live-intervals
+
+TUPLE: live-interval < identity-tuple vreg start end ;
+
+M: live-interval hashcode* nip [ start>> ] [ end>> 1000 * ] bi + ;
+
+! Mapping from vreg to live-interval
+SYMBOL: live-intervals
+
+: update-live-interval ( n vreg -- )
+ >vreg
+ live-intervals get
+ [ over f live-interval boa ] cache
+ (>>end) ;
+
+: compute-live-intervals* ( n insn -- )
+ uses-vregs [ update-live-interval ] with each ;
+
+: sort-live-intervals ( assoc -- seq' )
+ #! Sort by increasing start location.
+ values [ [ start>> ] compare ] sort ;
+
+: compute-live-intervals ( instructions -- live-intervals )
+ H{ } clone [
+ live-intervals [
+ [ swap compute-live-intervals* ] each-index
+ ] with-variable
+ ] keep sort-live-intervals ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs accessors arrays namespaces kernel math
+sequences compiler.instructions compiler.instructions.syntax ;
+IN: compiler.machine
+
+! Machine representation. Flat list of instructions, all
+! registers allocated, with labels and jumps.
+
+INSN: _prologue n ;
+INSN: _epilogue n ;
+
+INSN: _label label ;
+
+: <label> ( -- label ) \ <label> counter ;
+: define-label ( name -- ) <label> swap set ;
+: resolve-label ( label/name -- ) dup integer? [ get ] unless _label ;
+
+TUPLE: _cond-branch vreg label ;
+
+INSN: _branch label ;
+INSN: _branch-f < _cond-branch ;
+INSN: _branch-t < _cond-branch ;
+INSN: _if-intrinsic label quot vregs ;
+
+M: _cond-branch uses-vregs vreg>> 1array ;
+M: _if-intrinsic uses-vregs vregs>> values ;
--- /dev/null
+IN: compiler.machine.optimizer.tests
+USING: compiler.machine.optimizer tools.test ;
+
+\ optimize-machine must-infer
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors math namespaces make sequences
+sequences.next
+compiler.instructions
+compiler.instructions.syntax
+compiler.machine ;
+IN: compiler.machine.optimizer
+
+: frame-required ( insns -- n/f )
+ [ %frame-required? ] filter
+ [ f ] [ [ n>> ] map supremum ] if-empty ;
+
+GENERIC: optimize* ( next insn -- )
+
+: useless-branch? ( next insn -- ? )
+ over _label? [ [ label>> ] bi@ = ] [ 2drop f ] if ;
+
+M: _branch optimize*
+ #! Remove unconditional branches to labels immediately
+ #! following.
+ tuck useless-branch? [ drop ] [ , ] if ;
+
+M: %prologue optimize*
+ 2drop \ frame-required get [ _prologue ] when* ;
+
+M: %epilogue optimize*
+ 2drop \ frame-required get [ _epilogue ] when* ;
+
+M: %frame-required optimize* 2drop ;
+
+M: insn optimize* nip , ;
+
+: optimize-machine ( insns -- insns )
+ [
+ [ frame-required \ frame-required set ]
+ [ [ optimize* ] each-next ]
+ bi
+ ] { } make ;
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors namespaces sequences.next compiler.lvops ;
-IN: compiler.machine.simplifier
-
-: useless-branch? ( next insn -- ? )
- 2dup [ _label? ] [ _b? ] bi* and
- [ [ label>> ] bi@ = ] [ 2drop f ] if ;
-
-: simplify-mr ( insns -- insns )
- #! Remove unconditional branches to labels immediately
- #! following.
- [
- [
- tuck useless-branch?
- [ drop ] [ , ] if
- ] each-next
- ] { } make ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors namespaces math kernel ;
+IN: compiler.registers
+
+! Virtual CPU registers, used by CFG and machine IRs
+
+MIXIN: value
+
+GENERIC: >vreg ( obj -- vreg )
+
+M: value >vreg drop f ;
+
+! 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 ;
+
+! Virtual registers
+TUPLE: vreg reg-class n ;
+SYMBOL: vreg-counter
+: next-vreg ( reg-class -- vreg ) \ vreg-counter counter vreg boa ;
+
+M: vreg >vreg ;
+
+INSTANCE: vreg value
+
+! Stack locations
+TUPLE: loc n class ;
+
+! A data stack location.
+TUPLE: ds-loc < loc ;
+: <ds-loc> ( n -- loc ) f ds-loc boa ;
+
+TUPLE: rs-loc < loc ;
+: <rs-loc> ( n -- loc ) f rs-loc boa ;
+
+INSTANCE: loc value
+
+! A stack location which has been loaded into a register. To
+! read the location, we just read the register, but when time
+! comes to save it back to the stack, we know the register just
+! contains a stack value so we don't have to redundantly write
+! it back.
+TUPLE: cached loc vreg ;
+C: <cached> cached
+
+M: cached >vreg vreg>> >vreg ;
+
+INSTANCE: cached value
+
+! A tagged pointer
+TUPLE: tagged vreg class ;
+: <tagged> ( vreg -- tagged ) f tagged boa ;
+
+M: tagged >vreg vreg>> ;
+
+INSTANCE: tagged value
+
+! Unboxed value
+TUPLE: unboxed vreg ;
+C: <unboxed> unboxed
+
+M: unboxed >vreg vreg>> ;
+
+INSTANCE: unboxed value
+
+! Unboxed alien pointer
+TUPLE: unboxed-alien < unboxed ;
+C: <unboxed-alien> unboxed-alien
+
+! Untagged byte array pointer
+TUPLE: unboxed-byte-array < unboxed ;
+C: <unboxed-byte-array> unboxed-byte-array
+
+! A register set to f
+TUPLE: unboxed-f < unboxed ;
+C: <unboxed-f> unboxed-f
+
+! An alien, byte array or f
+TUPLE: unboxed-c-ptr < unboxed ;
+C: <unboxed-c-ptr> unboxed-c-ptr
+
+! A constant value
+TUPLE: constant value ;
+C: <constant> constant
+
+INSTANCE: constant value
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: parser kernel namespaces words layouts sequences classes
+classes.algebra accessors math arrays byte-arrays
+inference.dataflow optimizer.allot compiler.cfg compiler.vops ;
+IN: compiler.vops.builder
+
+<< : TEMP: CREATE dup [ get ] curry define-inline ; parsing >>
+
+! Temps Inputs Outputs
+TEMP: $1 TEMP: #1 TEMP: ^1
+TEMP: $2 TEMP: #2 TEMP: ^2
+TEMP: $3 TEMP: #3 TEMP: ^3
+TEMP: $4 TEMP: #4 TEMP: ^4
+TEMP: $5 TEMP: #5 TEMP: ^5
+
+GENERIC: emit-literal ( vreg object -- )
+
+M: fixnum emit-literal ( vreg object -- )
+ tag-bits get shift %iconst emit ;
+
+M: f emit-literal
+ class tag-number %iconst emit ;
+
+M: object emit-literal ( vreg object -- )
+ next-vreg [ %literal-table emit ] keep
+ swap %literal emit ;
+
+: temps ( seq -- ) [ next-vreg swap set ] each ;
+
+: init-intrinsic ( -- )
+ { $1 $2 $3 $4 ^1 ^2 ^3 ^4 } temps ;
+
+: load-iconst ( value -- vreg )
+ [ next-vreg dup ] dip %iconst emit ;
+
+: load-tag-mask ( -- vreg )
+ tag-mask get load-iconst ;
+
+: load-tag-bits ( -- vreg )
+ tag-bits get load-iconst ;
+
+: emit-tag-fixnum ( out in -- )
+ load-tag-bits %shl emit ;
+
+: emit-untag-fixnum ( out in -- )
+ load-tag-bits %sar emit ;
+
+: emit-untag ( out in -- )
+ next-vreg dup tag-mask get bitnot %iconst emit
+ %and emit ;
+
+: emit-tag ( -- )
+ $1 #1 load-tag-mask %and emit
+ ^1 $1 emit-tag-fixnum ;
+
+: emit-slot ( node -- )
+ [ ^1 #1 #2 ] dip dup in-d>> first node-class class-tag %%slot emit ;
+
+UNION: immediate fixnum POSTPONE: f ;
+
+: emit-write-barrier ( node -- )
+ dup in-d>> first node-class immediate class< [ #2 %write-barrier emit ] unless ;
+
+: emit-set-slot ( node -- )
+ [ emit-write-barrier ]
+ [ [ #1 #2 #3 ] dip dup in-d>> second node-class class-tag %%set-slot emit ]
+ bi ;
+
+: emit-fixnum-bitnot ( -- )
+ $1 #1 %not emit
+ ^1 $1 load-tag-mask %xor emit ;
+
+: emit-fixnum+fast ( -- )
+ ^1 #1 #2 %iadd emit ;
+
+: emit-fixnum-fast ( -- )
+ ^1 #1 #2 %isub emit ;
+
+: emit-fixnum-bitand ( -- )
+ ^1 #1 #2 %and emit ;
+
+: emit-fixnum-bitor ( -- )
+ ^1 #1 #2 %or emit ;
+
+: emit-fixnum-bitxor ( -- )
+ ^1 #1 #2 %xor emit ;
+
+: emit-fixnum*fast ( -- )
+ $1 #1 emit-untag-fixnum
+ ^1 $1 #2 %imul emit ;
+
+: emit-fixnum-shift-left-fast ( n -- )
+ [ $1 ] dip %iconst emit
+ ^1 #1 $1 %shl emit ;
+
+: emit-fixnum-shift-right-fast ( n -- )
+ [ $1 ] dip %iconst emit
+ $2 #1 $1 %sar emit
+ ^1 $2 emit-untag ;
+
+: emit-fixnum-shift-fast ( n -- )
+ dup 0 >=
+ [ emit-fixnum-shift-left-fast ]
+ [ neg emit-fixnum-shift-right-fast ] if ;
+
+: emit-fixnum-compare ( cc -- )
+ $1 #1 #2 %icmp emit
+ [ ^1 $1 ] dip %%iboolean emit ;
+
+: emit-fixnum<= ( -- )
+ cc<= emit-fixnum-compare ;
+
+: emit-fixnum>= ( -- )
+ cc>= emit-fixnum-compare ;
+
+: emit-fixnum< ( -- )
+ cc< emit-fixnum-compare ;
+
+: emit-fixnum> ( -- )
+ cc> emit-fixnum-compare ;
+
+: emit-eq? ( -- )
+ cc= emit-fixnum-compare ;
+
+: emit-unbox-float ( out in -- )
+ %%unbox-float emit ;
+
+: emit-box-float ( out in -- )
+ %%box-float emit ;
+
+: emit-unbox-floats ( -- )
+ $1 #1 emit-unbox-float
+ $2 #2 emit-unbox-float ;
+
+: emit-float+ ( -- )
+ emit-unbox-floats
+ $3 $1 $2 %fadd emit
+ ^1 $3 emit-box-float ;
+
+: emit-float- ( -- )
+ emit-unbox-floats
+ $3 $1 $2 %fsub emit
+ ^1 $3 emit-box-float ;
+
+: emit-float* ( -- )
+ emit-unbox-floats
+ $3 $1 $2 %fmul emit
+ ^1 $3 emit-box-float ;
+
+: emit-float/f ( -- )
+ emit-unbox-floats
+ $3 $1 $2 %fdiv emit
+ ^1 $3 emit-box-float ;
+
+: emit-float-compare ( cc -- )
+ emit-unbox-floats
+ $3 $1 $2 %fcmp emit
+ [ ^1 $3 ] dip %%fboolean emit ;
+
+: emit-float<= ( -- )
+ cc<= emit-float-compare ;
+
+: emit-float>= ( -- )
+ cc>= emit-float-compare ;
+
+: emit-float< ( -- )
+ cc< emit-float-compare ;
+
+: emit-float> ( -- )
+ cc> emit-float-compare ;
+
+: emit-float= ( -- )
+ cc= emit-float-compare ;
+
+: emit-allot ( vreg size class -- )
+ [ tag-number ] [ type-number ] bi %%allot emit ;
+
+: emit-(tuple) ( layout -- )
+ [ [ ^1 ] dip size>> 2 + tuple emit-allot ]
+ [ [ $1 ] dip emit-literal ] bi
+ $2 1 emit-literal
+ $1 ^1 $2 tuple tag-number %%set-slot emit ;
+
+: emit-(array) ( n -- )
+ [ [ ^1 ] dip 2 + array emit-allot ]
+ [ [ $1 ] dip emit-literal ] bi
+ $2 1 emit-literal
+ $1 ^1 $2 array tag-number %%set-slot emit ;
+
+: emit-(byte-array) ( n -- )
+ [ [ ^1 ] dip bytes>cells 2 + byte-array emit-allot ]
+ [ [ $1 ] dip emit-literal ] bi
+ $2 1 emit-literal
+ $1 ^1 $2 byte-array tag-number %%set-slot emit ;
+
+! fixnum>bignum
+! bignum>fixnum
+! fixnum+
+! fixnum-
+! getenv, setenv
+! alien accessors
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: parser prettyprint.backend kernel accessors math
+math.order sequences namespaces arrays assocs ;
+IN: compiler.vops
+
+TUPLE: vreg n ;
+
+: VREG: scan-word vreg boa parsed ; parsing
+
+M: vreg pprint* \ VREG: pprint-word n>> pprint* ;
+
+SYMBOL: vreg-counter
+
+: init-counter ( -- )
+ { 0 } clone vreg-counter set ;
+
+: next-vreg ( -- n )
+ 0 vreg-counter get [ dup 1+ ] change-nth vreg boa ;
+
+: emit ( ... class -- ) boa , ; inline
+
+! ! ! Instructions. Those prefixed with %% are high level
+! ! ! instructions eliminated during the elaboration phase.
+TUPLE: vop ;
+
+! Instruction which does not touch vregs.
+TUPLE: nullary-op < vop ;
+
+! Does nothing
+TUPLE: nop < nullary-op ;
+
+: nop ( -- vop ) T{ nop } ;
+
+: ?nop ( vop ? -- vop/nop ) [ drop nop ] unless ;
+
+! Instruction with no side effects; if 'out' is never read, we
+! can eliminate it.
+TUPLE: flushable-op < vop out ;
+
+! Instruction which is referentially transparent; we can replace
+! repeated computation with a reference to a previous value
+TUPLE: pure-op < flushable-op ;
+
+! Instruction only used for its side effect, produces no values
+TUPLE: effect-op < vop in ;
+
+TUPLE: binary-op < pure-op in1 in2 ;
+
+: inputs ( insn -- in1 in2 ) [ in1>> ] [ in2>> ] bi ; inline
+
+: in/out ( insn -- in out ) [ in>> ] [ out>> ] bi ; inline
+
+TUPLE: unary-op < pure-op in ;
+
+! Merge point; out is a sequence of vregs in a sequence of
+! sequences of vregs
+TUPLE: %phi < pure-op in ;
+
+! Integer, floating point, condition register copy
+TUPLE: %copy < unary-op ;
+
+! Constants
+TUPLE: constant-op < pure-op value ;
+
+TUPLE: %iconst < constant-op ; ! Integer
+TUPLE: %fconst < constant-op ; ! Float
+TUPLE: %cconst < constant-op ; ! Comparison result, +lt+ +eq+ +gt+
+
+! Load address of literal table into out
+TUPLE: %literal-table < pure-op ;
+
+! Load object literal from table.
+TUPLE: %literal < unary-op object ;
+
+! Read/write ops: candidates for alias analysis
+TUPLE: read-op < flushable-op ;
+TUPLE: write-op < effect-op ;
+
+! Stack shuffling
+SINGLETON: %data
+SINGLETON: %retain
+
+TUPLE: %peek < read-op n stack ;
+TUPLE: %replace < write-op n stack ;
+TUPLE: %height < nullary-op n stack ;
+
+: stack-loc ( insn -- pair ) [ n>> ] [ stack>> ] bi 2array ;
+
+TUPLE: commutative-op < binary-op ;
+
+! Integer arithmetic
+TUPLE: %iadd < commutative-op ;
+TUPLE: %isub < binary-op ;
+TUPLE: %imul < commutative-op ;
+TUPLE: %idiv < binary-op ;
+TUPLE: %imod < binary-op ;
+TUPLE: %icmp < binary-op ;
+
+! Bitwise ops
+TUPLE: %not < unary-op ;
+TUPLE: %and < commutative-op ;
+TUPLE: %or < commutative-op ;
+TUPLE: %xor < commutative-op ;
+TUPLE: %shl < binary-op ;
+TUPLE: %shr < binary-op ;
+TUPLE: %sar < binary-op ;
+
+! Float arithmetic
+TUPLE: %fadd < commutative-op ;
+TUPLE: %fsub < binary-op ;
+TUPLE: %fmul < commutative-op ;
+TUPLE: %fdiv < binary-op ;
+TUPLE: %fcmp < binary-op ;
+
+! Float/integer conversion
+TUPLE: %f>i < unary-op ;
+TUPLE: %i>f < unary-op ;
+
+! Float boxing/unboxing
+TUPLE: %%box-float < unary-op ;
+TUPLE: %%unbox-float < unary-op ;
+
+! High level slot accessors for alias analysis
+! tag is f; if its not f, we can generate a faster sequence
+TUPLE: %%slot < read-op obj slot tag ;
+TUPLE: %%set-slot < write-op obj slot tag ;
+
+TUPLE: %write-barrier < effect-op ;
+
+! Memory
+TUPLE: %load < unary-op ;
+TUPLE: %store < effect-op addr ;
+
+! Control flow; they jump to either the first or second successor
+! of the BB
+
+! Unconditional transfer to first successor
+TUPLE: %b < nullary-op ;
+
+SYMBOL: cc<
+SYMBOL: cc<=
+SYMBOL: cc=
+SYMBOL: cc>
+SYMBOL: cc>=
+SYMBOL: cc/=
+
+: evaluate-cc ( result cc -- ? )
+ H{
+ { cc< { +lt+ } }
+ { cc<= { +lt+ +eq+ } }
+ { cc= { +eq+ } }
+ { cc>= { +eq+ +gt+ } }
+ { cc> { +gt+ } }
+ { cc/= { +lt+ +gt+ } }
+ } at memq? ;
+
+TUPLE: cond-branch < effect-op code ;
+
+TUPLE: %bi < cond-branch ;
+TUPLE: %bf < cond-branch ;
+
+! Convert condition register to a boolean
+TUPLE: boolean-op < unary-op code ;
+
+TUPLE: %%iboolean < boolean-op ;
+TUPLE: %%fboolean < boolean-op ;
+
+! Dispatch table, jumps to successor 0..n-1 depending value of
+! in, which must be in the range [0,n)
+TUPLE: %dispatch < effect-op ;
+
+! Procedures
+TUPLE: %return < nullary-op ;
+TUPLE: %prolog < nullary-op ;
+TUPLE: %epilog < nullary-op ;
+TUPLE: %jump < nullary-op word ;
+TUPLE: %call < nullary-op word ;
+
+! Heap allocation
+TUPLE: %%allot < flushable-op size tag type ;
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: parser kernel namespaces words layouts sequences classes
-classes.algebra accessors math arrays byte-arrays
-inference.dataflow optimizer.allot compiler.cfg compiler.vops ;
-IN: compiler.vops.builder
-
-<< : TEMP: CREATE dup [ get ] curry define-inline ; parsing >>
-
-! Temps Inputs Outputs
-TEMP: $1 TEMP: #1 TEMP: ^1
-TEMP: $2 TEMP: #2 TEMP: ^2
-TEMP: $3 TEMP: #3 TEMP: ^3
-TEMP: $4 TEMP: #4 TEMP: ^4
-TEMP: $5 TEMP: #5 TEMP: ^5
-
-GENERIC: emit-literal ( vreg object -- )
-
-M: fixnum emit-literal ( vreg object -- )
- tag-bits get shift %iconst emit ;
-
-M: f emit-literal
- class tag-number %iconst emit ;
-
-M: object emit-literal ( vreg object -- )
- next-vreg [ %literal-table emit ] keep
- swap %literal emit ;
-
-: temps ( seq -- ) [ next-vreg swap set ] each ;
-
-: init-intrinsic ( -- )
- { $1 $2 $3 $4 ^1 ^2 ^3 ^4 } temps ;
-
-: load-iconst ( value -- vreg )
- [ next-vreg dup ] dip %iconst emit ;
-
-: load-tag-mask ( -- vreg )
- tag-mask get load-iconst ;
-
-: load-tag-bits ( -- vreg )
- tag-bits get load-iconst ;
-
-: emit-tag-fixnum ( out in -- )
- load-tag-bits %shl emit ;
-
-: emit-untag-fixnum ( out in -- )
- load-tag-bits %sar emit ;
-
-: emit-untag ( out in -- )
- next-vreg dup tag-mask get bitnot %iconst emit
- %and emit ;
-
-: emit-tag ( -- )
- $1 #1 load-tag-mask %and emit
- ^1 $1 emit-tag-fixnum ;
-
-: emit-slot ( node -- )
- [ ^1 #1 #2 ] dip dup in-d>> first node-class class-tag %%slot emit ;
-
-UNION: immediate fixnum POSTPONE: f ;
-
-: emit-write-barrier ( node -- )
- dup in-d>> first node-class immediate class< [ #2 %write-barrier emit ] unless ;
-
-: emit-set-slot ( node -- )
- [ emit-write-barrier ]
- [ [ #1 #2 #3 ] dip dup in-d>> second node-class class-tag %%set-slot emit ]
- bi ;
-
-: emit-fixnum-bitnot ( -- )
- $1 #1 %not emit
- ^1 $1 load-tag-mask %xor emit ;
-
-: emit-fixnum+fast ( -- )
- ^1 #1 #2 %iadd emit ;
-
-: emit-fixnum-fast ( -- )
- ^1 #1 #2 %isub emit ;
-
-: emit-fixnum-bitand ( -- )
- ^1 #1 #2 %and emit ;
-
-: emit-fixnum-bitor ( -- )
- ^1 #1 #2 %or emit ;
-
-: emit-fixnum-bitxor ( -- )
- ^1 #1 #2 %xor emit ;
-
-: emit-fixnum*fast ( -- )
- $1 #1 emit-untag-fixnum
- ^1 $1 #2 %imul emit ;
-
-: emit-fixnum-shift-left-fast ( n -- )
- [ $1 ] dip %iconst emit
- ^1 #1 $1 %shl emit ;
-
-: emit-fixnum-shift-right-fast ( n -- )
- [ $1 ] dip %iconst emit
- $2 #1 $1 %sar emit
- ^1 $2 emit-untag ;
-
-: emit-fixnum-shift-fast ( n -- )
- dup 0 >=
- [ emit-fixnum-shift-left-fast ]
- [ neg emit-fixnum-shift-right-fast ] if ;
-
-: emit-fixnum-compare ( cc -- )
- $1 #1 #2 %icmp emit
- [ ^1 $1 ] dip %%iboolean emit ;
-
-: emit-fixnum<= ( -- )
- cc<= emit-fixnum-compare ;
-
-: emit-fixnum>= ( -- )
- cc>= emit-fixnum-compare ;
-
-: emit-fixnum< ( -- )
- cc< emit-fixnum-compare ;
-
-: emit-fixnum> ( -- )
- cc> emit-fixnum-compare ;
-
-: emit-eq? ( -- )
- cc= emit-fixnum-compare ;
-
-: emit-unbox-float ( out in -- )
- %%unbox-float emit ;
-
-: emit-box-float ( out in -- )
- %%box-float emit ;
-
-: emit-unbox-floats ( -- )
- $1 #1 emit-unbox-float
- $2 #2 emit-unbox-float ;
-
-: emit-float+ ( -- )
- emit-unbox-floats
- $3 $1 $2 %fadd emit
- ^1 $3 emit-box-float ;
-
-: emit-float- ( -- )
- emit-unbox-floats
- $3 $1 $2 %fsub emit
- ^1 $3 emit-box-float ;
-
-: emit-float* ( -- )
- emit-unbox-floats
- $3 $1 $2 %fmul emit
- ^1 $3 emit-box-float ;
-
-: emit-float/f ( -- )
- emit-unbox-floats
- $3 $1 $2 %fdiv emit
- ^1 $3 emit-box-float ;
-
-: emit-float-compare ( cc -- )
- emit-unbox-floats
- $3 $1 $2 %fcmp emit
- [ ^1 $3 ] dip %%fboolean emit ;
-
-: emit-float<= ( -- )
- cc<= emit-float-compare ;
-
-: emit-float>= ( -- )
- cc>= emit-float-compare ;
-
-: emit-float< ( -- )
- cc< emit-float-compare ;
-
-: emit-float> ( -- )
- cc> emit-float-compare ;
-
-: emit-float= ( -- )
- cc= emit-float-compare ;
-
-: emit-allot ( vreg size class -- )
- [ tag-number ] [ type-number ] bi %%allot emit ;
-
-: emit-(tuple) ( layout -- )
- [ [ ^1 ] dip size>> 2 + tuple emit-allot ]
- [ [ $1 ] dip emit-literal ] bi
- $2 1 emit-literal
- $1 ^1 $2 tuple tag-number %%set-slot emit ;
-
-: emit-(array) ( n -- )
- [ [ ^1 ] dip 2 + array emit-allot ]
- [ [ $1 ] dip emit-literal ] bi
- $2 1 emit-literal
- $1 ^1 $2 array tag-number %%set-slot emit ;
-
-: emit-(byte-array) ( n -- )
- [ [ ^1 ] dip bytes>cells 2 + byte-array emit-allot ]
- [ [ $1 ] dip emit-literal ] bi
- $2 1 emit-literal
- $1 ^1 $2 byte-array tag-number %%set-slot emit ;
-
-! fixnum>bignum
-! bignum>fixnum
-! fixnum+
-! fixnum-
-! getenv, setenv
-! alien accessors
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: parser prettyprint.backend kernel accessors math
-math.order sequences namespaces arrays assocs ;
-IN: compiler.vops
-
-TUPLE: vreg n ;
-
-: VREG: scan-word vreg boa parsed ; parsing
-
-M: vreg pprint* \ VREG: pprint-word n>> pprint* ;
-
-SYMBOL: vreg-counter
-
-: init-counter ( -- )
- { 0 } clone vreg-counter set ;
-
-: next-vreg ( -- n )
- 0 vreg-counter get [ dup 1+ ] change-nth vreg boa ;
-
-: emit ( ... class -- ) boa , ; inline
-
-! ! ! Instructions. Those prefixed with %% are high level
-! ! ! instructions eliminated during the elaboration phase.
-TUPLE: vop ;
-
-! Instruction which does not touch vregs.
-TUPLE: nullary-op < vop ;
-
-! Does nothing
-TUPLE: nop < nullary-op ;
-
-: nop ( -- vop ) T{ nop } ;
-
-: ?nop ( vop ? -- vop/nop ) [ drop nop ] unless ;
-
-! Instruction with no side effects; if 'out' is never read, we
-! can eliminate it.
-TUPLE: flushable-op < vop out ;
-
-! Instruction which is referentially transparent; we can replace
-! repeated computation with a reference to a previous value
-TUPLE: pure-op < flushable-op ;
-
-! Instruction only used for its side effect, produces no values
-TUPLE: effect-op < vop in ;
-
-TUPLE: binary-op < pure-op in1 in2 ;
-
-: inputs ( insn -- in1 in2 ) [ in1>> ] [ in2>> ] bi ; inline
-
-: in/out ( insn -- in out ) [ in>> ] [ out>> ] bi ; inline
-
-TUPLE: unary-op < pure-op in ;
-
-! Merge point; out is a sequence of vregs in a sequence of
-! sequences of vregs
-TUPLE: %phi < pure-op in ;
-
-! Integer, floating point, condition register copy
-TUPLE: %copy < unary-op ;
-
-! Constants
-TUPLE: constant-op < pure-op value ;
-
-TUPLE: %iconst < constant-op ; ! Integer
-TUPLE: %fconst < constant-op ; ! Float
-TUPLE: %cconst < constant-op ; ! Comparison result, +lt+ +eq+ +gt+
-
-! Load address of literal table into out
-TUPLE: %literal-table < pure-op ;
-
-! Load object literal from table.
-TUPLE: %literal < unary-op object ;
-
-! Read/write ops: candidates for alias analysis
-TUPLE: read-op < flushable-op ;
-TUPLE: write-op < effect-op ;
-
-! Stack shuffling
-SINGLETON: %data
-SINGLETON: %retain
-
-TUPLE: %peek < read-op n stack ;
-TUPLE: %replace < write-op n stack ;
-TUPLE: %height < nullary-op n stack ;
-
-: stack-loc ( insn -- pair ) [ n>> ] [ stack>> ] bi 2array ;
-
-TUPLE: commutative-op < binary-op ;
-
-! Integer arithmetic
-TUPLE: %iadd < commutative-op ;
-TUPLE: %isub < binary-op ;
-TUPLE: %imul < commutative-op ;
-TUPLE: %idiv < binary-op ;
-TUPLE: %imod < binary-op ;
-TUPLE: %icmp < binary-op ;
-
-! Bitwise ops
-TUPLE: %not < unary-op ;
-TUPLE: %and < commutative-op ;
-TUPLE: %or < commutative-op ;
-TUPLE: %xor < commutative-op ;
-TUPLE: %shl < binary-op ;
-TUPLE: %shr < binary-op ;
-TUPLE: %sar < binary-op ;
-
-! Float arithmetic
-TUPLE: %fadd < commutative-op ;
-TUPLE: %fsub < binary-op ;
-TUPLE: %fmul < commutative-op ;
-TUPLE: %fdiv < binary-op ;
-TUPLE: %fcmp < binary-op ;
-
-! Float/integer conversion
-TUPLE: %f>i < unary-op ;
-TUPLE: %i>f < unary-op ;
-
-! Float boxing/unboxing
-TUPLE: %%box-float < unary-op ;
-TUPLE: %%unbox-float < unary-op ;
-
-! High level slot accessors for alias analysis
-! tag is f; if its not f, we can generate a faster sequence
-TUPLE: %%slot < read-op obj slot tag ;
-TUPLE: %%set-slot < write-op obj slot tag ;
-
-TUPLE: %write-barrier < effect-op ;
-
-! Memory
-TUPLE: %load < unary-op ;
-TUPLE: %store < effect-op addr ;
-
-! Control flow; they jump to either the first or second successor
-! of the BB
-
-! Unconditional transfer to first successor
-TUPLE: %b < nullary-op ;
-
-SYMBOL: cc<
-SYMBOL: cc<=
-SYMBOL: cc=
-SYMBOL: cc>
-SYMBOL: cc>=
-SYMBOL: cc/=
-
-: evaluate-cc ( result cc -- ? )
- H{
- { cc< { +lt+ } }
- { cc<= { +lt+ +eq+ } }
- { cc= { +eq+ } }
- { cc>= { +eq+ +gt+ } }
- { cc> { +gt+ } }
- { cc/= { +lt+ +gt+ } }
- } at memq? ;
-
-TUPLE: cond-branch < effect-op code ;
-
-TUPLE: %bi < cond-branch ;
-TUPLE: %bf < cond-branch ;
-
-! Convert condition register to a boolean
-TUPLE: boolean-op < unary-op code ;
-
-TUPLE: %%iboolean < boolean-op ;
-TUPLE: %%fboolean < boolean-op ;
-
-! Dispatch table, jumps to successor 0..n-1 depending value of
-! in, which must be in the range [0,n)
-TUPLE: %dispatch < effect-op ;
-
-! Procedures
-TUPLE: %return < nullary-op ;
-TUPLE: %prolog < nullary-op ;
-TUPLE: %epilog < nullary-op ;
-TUPLE: %jump < nullary-op word ;
-TUPLE: %call < nullary-op word ;
-
-! Heap allocation
-TUPLE: %%allot < flushable-op size tag type ;
projects / factor.git / commitdiff